Index: /NEMO/branches/2020/r12377_ticket2386/README.rst
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/README.rst (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/README.rst (revision 13540)
@@ -62,5 +62,5 @@
|NEMO-OCE| |DOI man OCE|_ |DOI qsg|
|NEMO-ICE| |DOI man ICE|
- |NEMO-MBG| |DOI man MBG|
+ |NEMO-TOP| |DOI man TOP|
============ ================== ===================
Index: /NEMO/branches/2020/r12377_ticket2386/cfgs/AGRIF_DEMO/EXPREF/1_context_nemo.xml
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/cfgs/AGRIF_DEMO/EXPREF/1_context_nemo.xml (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/cfgs/AGRIF_DEMO/EXPREF/1_context_nemo.xml (revision 13540)
@@ -11,5 +11,5 @@
01
01
- 1026.0
+ 1026.0
3991.86795711963
0.99530670233846
Index: /NEMO/branches/2020/r12377_ticket2386/cfgs/AGRIF_DEMO/EXPREF/1_namelist_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/cfgs/AGRIF_DEMO/EXPREF/1_namelist_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/cfgs/AGRIF_DEMO/EXPREF/1_namelist_cfg (revision 13540)
@@ -81,6 +81,7 @@
ln_blk = .true. ! Bulk formulation (T => fill namsbc_blk )
! Sea-ice :
- nn_ice = 2 ! =2 or 3 automatically for SI3 or CICE ("key_si3" or "key_cice")
- ! except in AGRIF zoom where it has to be specified
+ nn_ice = 2 ! =0 no ice boundary condition
+ ! ! =1 use observed ice-cover ( => fill namsbc_iif )
+ ! ! =2 or 3 for SI3 and CICE, respectively
! Misc. options of sbc :
ln_traqsr = .true. ! Light penetration in the ocean (T => fill namtra_qsr)
@@ -94,22 +95,4 @@
! ! bulk algorithm :
ln_NCAR = .true. ! "NCAR" algorithm (Large and Yeager 2008)
- ln_COARE_3p0 = .false. ! "COARE 3.0" algorithm (Fairall et al. 2003)
- ln_COARE_3p6 = .false. ! "COARE 3.6" algorithm (Edson et al. 2013)
- ln_ECMWF = .false. ! "ECMWF" algorithm (IFS cycle 31)
- !
- rn_zqt = 10. ! Air temperature & humidity reference height (m)
- rn_zu = 10. ! Wind vector reference height (m)
- ln_Cd_L12 = .false. ! air-ice drags = F(ice concentration) (Lupkes et al. 2012)
- ln_Cd_L15 = .false. ! air-ice drags = F(ice concentration) (Lupkes et al. 2015)
- rn_pfac = 1. ! multiplicative factor for precipitation (total & snow)
- rn_efac = 1. ! multiplicative factor for evaporation (0. or 1.)
- rn_vfac = 0. ! multiplicative factor for ocean & ice velocity used to
- ! ! calculate the wind stress (0.=absolute or 1.=relative winds)
- ln_skin_cs = .false. ! use the cool-skin parameterization (only available in ECMWF and COARE algorithms) !LB
- ln_skin_wl = .false. ! use the warm-layer " " "
- !
- ln_humi_sph = .true. ! humidity specified below in "sn_humi" is specific humidity [kg/kg] if .true.
- ln_humi_dpt = .false. ! humidity specified below in "sn_humi" is dew-point temperature [K] if .true.
- ln_humi_rlh = .false. ! humidity specified below in "sn_humi" is relative humidity [%] if .true.
!
cn_dir = './' ! root directory for the bulk data location
@@ -192,6 +175,6 @@
!! !!
!! namdrg top/bottom drag coefficient (default: NO selection)
-!! namdrg_top top friction (ln_OFF=F & ln_isfcav=T)
-!! namdrg_bot bottom friction (ln_OFF=F)
+!! 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)
@@ -370,5 +353,4 @@
&namzdf_tke ! turbulent eddy kinetic dependent vertical diffusion (ln_zdftke =T)
!-----------------------------------------------------------------------
- rn_eice = 0 ! below sea ice: =0 ON ; =4 OFF when ice fraction > 1/4
/
!!======================================================================
Index: /NEMO/branches/2020/r12377_ticket2386/cfgs/AGRIF_DEMO/EXPREF/2_context_nemo.xml
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/cfgs/AGRIF_DEMO/EXPREF/2_context_nemo.xml (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/cfgs/AGRIF_DEMO/EXPREF/2_context_nemo.xml (revision 13540)
@@ -11,5 +11,5 @@
01
01
- 1026.0
+ 1026.0
3991.86795711963
0.99530670233846
Index: /NEMO/branches/2020/r12377_ticket2386/cfgs/AGRIF_DEMO/EXPREF/2_namelist_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/cfgs/AGRIF_DEMO/EXPREF/2_namelist_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/cfgs/AGRIF_DEMO/EXPREF/2_namelist_cfg (revision 13540)
@@ -78,5 +78,7 @@
ln_blk = .true. ! Bulk formulation (T => fill namsbc_blk )
! Sea-ice :
- nn_ice = 2 ! =0 Use SI3 model
+ nn_ice = 2 ! =0 no ice boundary condition
+ ! ! =1 use observed ice-cover ( => fill namsbc_iif )
+ ! ! =2 or 3 for SI3 and CICE, respectively
! Misc. options of sbc :
ln_traqsr = .true. ! Light penetration in the ocean (T => fill namtra_qsr)
@@ -90,22 +92,4 @@
! ! bulk algorithm :
ln_NCAR = .true. ! "NCAR" algorithm (Large and Yeager 2008)
- ln_COARE_3p0 = .false. ! "COARE 3.0" algorithm (Fairall et al. 2003)
- ln_COARE_3p6 = .false. ! "COARE 3.6" algorithm (Edson et al. 2013)
- ln_ECMWF = .false. ! "ECMWF" algorithm (IFS cycle 31)
- !
- rn_zqt = 10. ! Air temperature & humidity reference height (m)
- rn_zu = 10. ! Wind vector reference height (m)
- ln_Cd_L12 = .false. ! air-ice drags = F(ice concentration) (Lupkes et al. 2012)
- ln_Cd_L15 = .false. ! air-ice drags = F(ice concentration) (Lupkes et al. 2015)
- rn_pfac = 1. ! multiplicative factor for precipitation (total & snow)
- rn_efac = 1. ! multiplicative factor for evaporation (0. or 1.)
- rn_vfac = 0. ! multiplicative factor for ocean & ice velocity used to
- ! ! calculate the wind stress (0.=absolute or 1.=relative winds)
- ln_skin_cs = .false. ! use the cool-skin parameterization (only available in ECMWF and COARE algorithms) !LB
- ln_skin_wl = .false. ! use the warm-layer " " "
- !
- ln_humi_sph = .true. ! humidity specified below in "sn_humi" is specific humidity [kg/kg] if .true.
- ln_humi_dpt = .false. ! humidity specified below in "sn_humi" is dew-point temperature [K] if .true.
- ln_humi_rlh = .false. ! humidity specified below in "sn_humi" is relative humidity [%] if .true.
!
cn_dir = './' ! root directory for the bulk data location
@@ -174,6 +158,4 @@
!-----------------------------------------------------------------------
ln_spc_dyn = .true. ! use 0 as special value for dynamics
- rn_sponge_tra = 1440. ! coefficient for tracer sponge layer [m2/s]
- rn_sponge_dyn = 1440. ! coefficient for dynamics sponge layer [m2/s]
ln_chk_bathy = .true. ! =T check the parent bathymetry
/
Index: /NEMO/branches/2020/r12377_ticket2386/cfgs/AGRIF_DEMO/EXPREF/3_context_nemo.xml
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/cfgs/AGRIF_DEMO/EXPREF/3_context_nemo.xml (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/cfgs/AGRIF_DEMO/EXPREF/3_context_nemo.xml (revision 13540)
@@ -11,5 +11,5 @@
01
01
- 1026.0
+ 1026.0
3991.86795711963
0.99530670233846
Index: /NEMO/branches/2020/r12377_ticket2386/cfgs/AGRIF_DEMO/EXPREF/3_namelist_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/cfgs/AGRIF_DEMO/EXPREF/3_namelist_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/cfgs/AGRIF_DEMO/EXPREF/3_namelist_cfg (revision 13540)
@@ -78,5 +78,7 @@
ln_blk = .true. ! Bulk formulation (T => fill namsbc_blk )
! Sea-ice :
- nn_ice = 2 ! =0 Use SI3 model
+ nn_ice = 2 ! =0 no ice boundary condition
+ ! ! =1 use observed ice-cover ( => fill namsbc_iif )
+ ! ! =2 or 3 for SI3 and CICE, respectively
! Misc. options of sbc :
ln_traqsr = .true. ! Light penetration in the ocean (T => fill namtra_qsr)
@@ -156,6 +158,4 @@
!-----------------------------------------------------------------------
ln_spc_dyn = .true. ! use 0 as special value for dynamics
- rn_sponge_tra = 480. ! coefficient for tracer sponge layer [m2/s]
- rn_sponge_dyn = 480. ! coefficient for dynamics sponge layer [m2/s]
ln_chk_bathy = .true. ! =T check the parent bathymetry
/
Index: /NEMO/branches/2020/r12377_ticket2386/cfgs/AGRIF_DEMO/EXPREF/AGRIF_FixedGrids.in
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/cfgs/AGRIF_DEMO/EXPREF/AGRIF_FixedGrids.in (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/cfgs/AGRIF_DEMO/EXPREF/AGRIF_FixedGrids.in (revision 13540)
@@ -1,5 +1,5 @@
2
-42 82 49 91 1 1 1
-122 153 110 143 4 4 4
+41 81 49 91 1 1 1
+121 152 110 143 4 4 4
0
1
Index: /NEMO/branches/2020/r12377_ticket2386/cfgs/AGRIF_DEMO/EXPREF/context_nemo.xml
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/cfgs/AGRIF_DEMO/EXPREF/context_nemo.xml (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/cfgs/AGRIF_DEMO/EXPREF/context_nemo.xml (revision 13540)
@@ -11,5 +11,5 @@
01
01
- 1026.0
+ 1026.0
3991.86795711963
0.99530670233846
Index: /NEMO/branches/2020/r12377_ticket2386/cfgs/AGRIF_DEMO/EXPREF/namelist_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/cfgs/AGRIF_DEMO/EXPREF/namelist_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/cfgs/AGRIF_DEMO/EXPREF/namelist_cfg (revision 13540)
@@ -33,5 +33,5 @@
/
!-----------------------------------------------------------------------
-&namcfg ! parameters of the configuration (default: user defined GYRE)
+&namcfg ! parameters of the configuration (default: use namusr_def in namelist_cfg)
!-----------------------------------------------------------------------
ln_read_cfg = .true. ! (=T) read the domain configuration file
@@ -42,5 +42,5 @@
/
!-----------------------------------------------------------------------
-&namtsd ! Temperature & Salinity Data (default: OFF)
+&namtsd ! Temperature & Salinity Data (init/dmp) (default: OFF)
!-----------------------------------------------------------------------
! ! =T read T-S fields for:
@@ -63,10 +63,11 @@
!! 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_isf ice shelf melting/freezing (ln_isfcav =T : read (ln_read_cfg=T) or set or usr_def_zgr )
!! namsbc_iscpl coupling option between land ice model and ocean (ln_isfcav =T)
-!! namsbc_apr Atmospheric Pressure (ln_apr_dyn =T)
-!! namsbc_ssr sea surface restoring term (for T and/or S) (ln_ssr =T)
!! namsbc_wave external fields from wave model (ln_wave =T)
!! namberg iceberg floats (ln_icebergs=T)
@@ -74,5 +75,5 @@
!
!-----------------------------------------------------------------------
-&namsbc ! Surface Boundary Condition (surface module)
+&namsbc ! Surface Boundary Condition manager (default: NO selection)
!-----------------------------------------------------------------------
nn_fsbc = 1 ! frequency of SBC module call
@@ -81,49 +82,31 @@
ln_blk = .true. ! Bulk formulation (T => fill namsbc_blk )
! Sea-ice :
- nn_ice = 2 ! =2 or 3 automatically for SI3 or CICE ("key_si3" or "key_cice")
- ! except in AGRIF zoom where it has to be specified
+ nn_ice = 2 ! =0 no ice boundary condition
+ ! ! =1 use observed ice-cover ( => fill namsbc_iif )
+ ! ! =2 or 3 for SI3 and CICE, respectively
! Misc. options of sbc :
ln_traqsr = .true. ! Light penetration in the ocean (T => fill namtra_qsr)
+ ln_ssr = .true. ! Sea Surface Restoring on T and/or S (T => fill namsbc_ssr)
ln_rnf = .true. ! runoffs (T => fill namsbc_rnf)
- ln_ssr = .true. ! Sea Surface Restoring on T and/or S (T => fill namsbc_ssr)
nn_fwb = 0 ! FreshWater Budget: =0 unchecked
/
!-----------------------------------------------------------------------
-&namsbc_blk ! namsbc_blk generic Bulk formula (ln_blk =T)
+&namsbc_blk ! namsbc_blk generic Bulk formula (ln_blk =T)
!-----------------------------------------------------------------------
! ! bulk algorithm :
- ln_NCAR = .true. ! "NCAR" algorithm (Large and Yeager 2008)
- ln_COARE_3p0 = .false. ! "COARE 3.0" algorithm (Fairall et al. 2003)
- ln_COARE_3p6 = .false. ! "COARE 3.6" algorithm (Edson et al. 2013)
- ln_ECMWF = .false. ! "ECMWF" algorithm (IFS cycle 31)
- !
- rn_zqt = 10. ! Air temperature & humidity reference height (m)
- rn_zu = 10. ! Wind vector reference height (m)
- ln_Cd_L12 = .false. ! air-ice drags = F(ice concentration) (Lupkes et al. 2012)
- ln_Cd_L15 = .false. ! air-ice drags = F(ice concentration) (Lupkes et al. 2015)
- rn_pfac = 1. ! multiplicative factor for precipitation (total & snow)
- rn_efac = 1. ! multiplicative factor for evaporation (0. or 1.)
- rn_vfac = 0. ! multiplicative factor for ocean & ice velocity used to
- ! ! calculate the wind stress (0.=absolute or 1.=relative winds)
- ln_skin_cs = .false. ! use the cool-skin parameterization (only available in ECMWF and COARE algorithms) !LB
- ln_skin_wl = .false. ! use the warm-layer " " "
- !
- ln_humi_sph = .true. ! humidity specified below in "sn_humi" is specific humidity [kg/kg] if .true.
- ln_humi_dpt = .false. ! humidity specified below in "sn_humi" is dew-point temperature [K] if .true.
- ln_humi_rlh = .false. ! humidity specified below in "sn_humi" is relative humidity [%] if .true.
- !
+ ln_NCAR = .true. ! "NCAR" algorithm (Large and Yeager 2008)
cn_dir = './' ! root directory for the bulk data location
!___________!_________________________!___________________!___________!_____________!________!___________!______________________________________!__________!_______________!
! ! file name ! frequency (hours) ! variable ! time interp.! clim ! 'yearly'/ ! weights filename ! rotation ! land/sea mask !
! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! ! pairing ! filename !
- sn_wndi = 'u_10.15JUNE2009_fill' , 6. , 'U_10_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bicubic_noc.nc' , 'Uwnd' , ''
- sn_wndj = 'v_10.15JUNE2009_fill' , 6. , 'V_10_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bicubic_noc.nc' , 'Vwnd' , ''
- sn_qsr = 'ncar_rad.15JUNE2009_fill' , 24. , 'SWDN_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
- sn_qlw = 'ncar_rad.15JUNE2009_fill' , 24. , 'LWDN_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
- sn_tair = 't_10.15JUNE2009_fill' , 6. , 'T_10_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
- sn_humi = 'q_10.15JUNE2009_fill' , 6. , 'Q_10_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
- sn_prec = 'ncar_precip.15JUNE2009_fill', -1. , 'PRC_MOD1', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
- sn_snow = 'ncar_precip.15JUNE2009_fill', -1. , 'SNOW' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
- sn_slp = 'slp.15JUNE2009_fill' , 6. , 'SLP' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
+ sn_wndi = 'u_10.15JUNE2009_fill' , 6. , 'U_10_MOD', .false. , .true. , 'yearly' , 'weights_core2_orca2_bicub' , 'Uwnd' , ''
+ sn_wndj = 'v_10.15JUNE2009_fill' , 6. , 'V_10_MOD', .false. , .true. , 'yearly' , 'weights_core2_orca2_bicub' , 'Vwnd' , ''
+ sn_qsr = 'ncar_rad.15JUNE2009_fill' , 24. , 'SWDN_MOD', .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , ''
+ sn_qlw = 'ncar_rad.15JUNE2009_fill' , 24. , 'LWDN_MOD', .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , ''
+ sn_tair = 't_10.15JUNE2009_fill' , 6. , 'T_10_MOD', .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , ''
+ sn_humi = 'q_10.15JUNE2009_fill' , 6. , 'Q_10_MOD', .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , ''
+ sn_prec = 'ncar_precip.15JUNE2009_fill', -1. , 'PRC_MOD1', .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , ''
+ sn_snow = 'ncar_precip.15JUNE2009_fill', -1. , 'SNOW' , .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , ''
+ sn_slp = 'slp.15JUNE2009_fill' , 6. , 'SLP' , .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , ''
/
!-----------------------------------------------------------------------
@@ -142,4 +125,12 @@
/
!-----------------------------------------------------------------------
+&namsbc_ssr ! surface boundary condition : sea surface restoring (ln_ssr =T)
+!-----------------------------------------------------------------------
+ nn_sssr = 2 ! add a damping term to the surface freshwater flux
+ rn_deds = -166.67 ! magnitude of the damping on salinity [mm/day]
+ ln_sssr_bnd = .true. ! flag to bound erp term (associated with nn_sssr=2)
+ rn_sssr_bnd = 4.e0 ! ABS(Max/Min) value of the damping erp term [mm/day]
+/
+!-----------------------------------------------------------------------
&namsbc_rnf ! runoffs (ln_rnf =T)
!-----------------------------------------------------------------------
@@ -147,4 +138,5 @@
rn_hrnf = 15.e0 ! depth over which enhanced vertical mixing is used (ln_rnf_mouth=T)
rn_avt_rnf = 1.e-3 ! value of the additional vertical mixing coef. [m2/s] (ln_rnf_mouth=T)
+ rn_rfact = 1.e0 ! multiplicative factor for runoff
cn_dir = './' ! root directory for the location of the runoff files
@@ -159,13 +151,9 @@
/
!-----------------------------------------------------------------------
-&namsbc_ssr ! surface boundary condition : sea surface restoring (ln_ssr =T)
-!-----------------------------------------------------------------------
- nn_sssr = 2 ! add a damping term to the surface freshwater flux
- rn_deds = -166.67 ! magnitude of the damping on salinity [mm/day]
- ln_sssr_bnd = .true. ! flag to bound erp term (associated with nn_sssr=2)
- rn_sssr_bnd = 4.e0 ! ABS(Max/Min) value of the damping erp term [mm/day]
-/
-!-----------------------------------------------------------------------
-&namberg ! iceberg parameters (default: No iceberg)
+&namsbc_wave ! External fields from wave model (ln_wave=T)
+!-----------------------------------------------------------------------
+/
+!-----------------------------------------------------------------------
+&namberg ! iceberg parameters (default: OFF)
!-----------------------------------------------------------------------
! iceberg floats are not currently available with AGRIF
@@ -176,5 +164,5 @@
!! !!
!! namlbc lateral momentum boundary condition (default: NO selection)
-!! namagrif agrif nested grid ( read by child model only ) ("key_agrif")
+!! namagrif agrif nested grid (read by child model only) ("key_agrif")
!! nam_tide Tidal forcing (default: OFF)
!! nambdy Unstructured open boundaries (default: OFF)
@@ -192,6 +180,6 @@
!! !!
!! namdrg top/bottom drag coefficient (default: NO selection)
-!! namdrg_top top friction (ln_OFF=F & ln_isfcav=T)
-!! namdrg_bot bottom friction (ln_OFF=F)
+!! 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)
@@ -229,5 +217,5 @@
/
!!======================================================================
-!! Tracer (T & S) namelists !!
+!! Tracer (T-S) namelists !!
!! !!
!! nameos equation of state (default: NO selection)
@@ -250,9 +238,4 @@
nn_fct_h = 2 ! =2/4, horizontal 2nd / 4th order
nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order
-/
-!-----------------------------------------------------------------------
-&namtra_mle ! mixed layer eddy parametrisation (Fox-Kemper) (default: OFF)
-!-----------------------------------------------------------------------
- ln_mle = .true. ! (T) use the Mixed Layer Eddy (MLE) parameterisation
/
!-----------------------------------------------------------------------
@@ -272,7 +255,12 @@
/
!-----------------------------------------------------------------------
-&namtra_eiv ! eddy induced velocity param. (default: OFF)
-!-----------------------------------------------------------------------
- ln_ldfeiv =.true. ! use eddy induced velocity parameterization
+&namtra_mle ! mixed layer eddy parametrisation (Fox-Kemper) (default: OFF)
+!-----------------------------------------------------------------------
+ ln_mle = .true. ! (T) use the Mixed Layer Eddy (MLE) parameterisation
+/
+!-----------------------------------------------------------------------
+&namtra_eiv ! eddy induced velocity param. (default: OFF)
+!-----------------------------------------------------------------------
+ ln_ldfeiv = .true. ! use eddy induced velocity parameterization
! ! Coefficients:
nn_aei_ijk_t = 21 ! space/time variation of the eiv coeficient
@@ -303,8 +291,4 @@
!
!-----------------------------------------------------------------------
-&nam_vvl ! vertical coordinate options (default: z-star)
-!-----------------------------------------------------------------------
-/
-!-----------------------------------------------------------------------
&namdyn_adv ! formulation of the momentum advection (default: NO selection)
!-----------------------------------------------------------------------
@@ -351,5 +335,5 @@
!
!-----------------------------------------------------------------------
-&namzdf ! vertical physics (default: NO selection)
+&namzdf ! vertical physics manager (default: NO selection)
!-----------------------------------------------------------------------
! ! type of vertical closure
@@ -370,5 +354,4 @@
&namzdf_tke ! turbulent eddy kinetic dependent vertical diffusion (ln_zdftke =T)
!-----------------------------------------------------------------------
- rn_eice = 0 ! below sea ice: =0 ON ; =4 OFF when ice fraction > 1/4
/
!!======================================================================
@@ -401,5 +384,4 @@
!!======================================================================
!
-!
!-----------------------------------------------------------------------
&nammpp ! Massively Parallel Processing ("key_mpp_mpi")
Index: /NEMO/branches/2020/r12377_ticket2386/cfgs/AMM12/EXPREF/context_nemo.xml
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/cfgs/AMM12/EXPREF/context_nemo.xml (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/cfgs/AMM12/EXPREF/context_nemo.xml (revision 13540)
@@ -11,5 +11,5 @@
01
01
- 1026.0
+ 1026.0
3991.86795711963
0.99530670233846
Index: /NEMO/branches/2020/r12377_ticket2386/cfgs/AMM12/EXPREF/namelist_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/cfgs/AMM12/EXPREF/namelist_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/cfgs/AMM12/EXPREF/namelist_cfg (revision 13540)
@@ -212,6 +212,6 @@
!! !!
!! namdrg top/bottom drag coefficient (default: NO selection)
-!! namdrg_top top friction (ln_OFF =F & ln_isfcav=T)
-!! namdrg_bot bottom friction (ln_OFF =F)
+!! 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)
Index: /NEMO/branches/2020/r12377_ticket2386/cfgs/C1D_PAPA/EXPREF/file_def_nemo-oce.xml
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/cfgs/C1D_PAPA/EXPREF/file_def_nemo-oce.xml (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/cfgs/C1D_PAPA/EXPREF/file_def_nemo-oce.xml (revision 13540)
@@ -53,5 +53,4 @@
-
Index: /NEMO/branches/2020/r12377_ticket2386/cfgs/C1D_PAPA/EXPREF/namelist_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/cfgs/C1D_PAPA/EXPREF/namelist_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/cfgs/C1D_PAPA/EXPREF/namelist_cfg (revision 13540)
@@ -49,4 +49,6 @@
&namdom ! time and space domain
!-----------------------------------------------------------------------
+ ln_linssh = .true. ! =T linear free surface ==>> model level are fixed in time
+ !
rn_Dt = 360. ! time step for the dynamics and tracer
/
@@ -256,6 +258,6 @@
!! !!
!! namdrg top/bottom drag coefficient (default: NO selection)
-!! namdrg_top top friction (ln_OFF=F & ln_isfcav=T)
-!! namdrg_bot bottom friction (ln_OFF=F)
+!! 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)
@@ -268,9 +270,9 @@
/
!-----------------------------------------------------------------------
-&namdrg_top ! TOP friction (ln_OFF =F & ln_isfcav=T)
-!-----------------------------------------------------------------------
-/
-!-----------------------------------------------------------------------
-&namdrg_bot ! BOTTOM friction (ln_OFF =F)
+&namdrg_top ! TOP friction (ln_drg_OFF =F & ln_isfcav=T)
+!-----------------------------------------------------------------------
+/
+!-----------------------------------------------------------------------
+&namdrg_bot ! BOTTOM friction (ln_drg_OFF =F)
!-----------------------------------------------------------------------
/
@@ -358,7 +360,4 @@
&namdyn_spg ! surface pressure gradient (default: NO selection)
!-----------------------------------------------------------------------
- ln_dynspg_ts = .true. ! split-explicit free surface
- ln_bt_fw = .false. ! Forward integration of barotropic Eqs.
- ln_bt_av = .true. ! Time filtering of barotropic variables
/
!-----------------------------------------------------------------------
Index: /NEMO/branches/2020/r12377_ticket2386/cfgs/C1D_PAPA/MY_SRC/usrdef_zgr.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/cfgs/C1D_PAPA/MY_SRC/usrdef_zgr.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/cfgs/C1D_PAPA/MY_SRC/usrdef_zgr.F90 (revision 13540)
@@ -30,4 +30,6 @@
PUBLIC usr_def_zgr ! called by domzgr.F90
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -157,16 +159,15 @@
pe3vw(:,:,jk) = pe3w_1d (jk)
END DO
- DO jj = 1, jpj ! bottom scale factors and depth at T- and W-points
- DO ji = 1, jpi
- 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 )
- END DO
- END DO
+ ! 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) ! = 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
Index: /NEMO/branches/2020/r12377_ticket2386/cfgs/GYRE_BFM/EXPREF/context_nemo.xml
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/cfgs/GYRE_BFM/EXPREF/context_nemo.xml (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/cfgs/GYRE_BFM/EXPREF/context_nemo.xml (revision 13540)
@@ -11,5 +11,5 @@
01
01
- 1026.0
+ 1026.0
3991.86795711963
0.99530670233846
Index: /NEMO/branches/2020/r12377_ticket2386/cfgs/GYRE_BFM/EXPREF/namelist_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/cfgs/GYRE_BFM/EXPREF/namelist_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/cfgs/GYRE_BFM/EXPREF/namelist_cfg (revision 13540)
@@ -101,6 +101,6 @@
!! !!
!! namdrg top/bottom drag coefficient (default: NO selection)
-!! namdrg_top top friction (ln_OFF=F & ln_isfcav=T)
-!! namdrg_bot bottom friction (ln_OFF=F)
+!! 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)
Index: /NEMO/branches/2020/r12377_ticket2386/cfgs/GYRE_PISCES/EXPREF/context_nemo.xml
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/cfgs/GYRE_PISCES/EXPREF/context_nemo.xml (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/cfgs/GYRE_PISCES/EXPREF/context_nemo.xml (revision 13540)
@@ -11,5 +11,5 @@
01
01
- 1026.0
+ 1026.0
3991.86795711963
0.99530670233846
Index: /NEMO/branches/2020/r12377_ticket2386/cfgs/GYRE_PISCES/EXPREF/namelist_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/cfgs/GYRE_PISCES/EXPREF/namelist_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/cfgs/GYRE_PISCES/EXPREF/namelist_cfg (revision 13540)
@@ -99,6 +99,6 @@
!! !!
!! namdrg top/bottom drag coefficient (default: NO selection)
-!! namdrg_top top friction (ln_OFF=F & ln_isfcav=T)
-!! namdrg_bot bottom friction (ln_OFF=F)
+!! 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)
Index: /NEMO/branches/2020/r12377_ticket2386/cfgs/ORCA2_ICE_ABL/EXPREF/file_def_nemo-oce.xml
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/cfgs/ORCA2_ICE_ABL/EXPREF/file_def_nemo-oce.xml (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/cfgs/ORCA2_ICE_ABL/EXPREF/file_def_nemo-oce.xml (revision 13540)
@@ -56,4 +56,10 @@
+
+
+
+
+
+
Index: /NEMO/branches/2020/r12377_ticket2386/cfgs/ORCA2_ICE_ABL/EXPREF/namelist_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/cfgs/ORCA2_ICE_ABL/EXPREF/namelist_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/cfgs/ORCA2_ICE_ABL/EXPREF/namelist_cfg (revision 13540)
@@ -84,6 +84,7 @@
ln_abl = .true. ! ABL formulation (T => fill namsbc_abl )
! Sea-ice :
- nn_ice = 2 ! =2 or 3 automatically for SI3 or CICE ("key_si3" or "key_cice")
- ! except in AGRIF zoom where it has to be specified
+ nn_ice = 2 ! =0 no ice boundary condition
+ ! ! =1 use observed ice-cover ( => fill namsbc_iif )
+ ! ! =2 or 3 for SI3 and CICE, respectively
! Misc. options of sbc :
ln_traqsr = .true. ! Light penetration in the ocean (T => fill namtra_qsr)
@@ -109,17 +110,4 @@
! ! bulk algorithm :
ln_NCAR = .true. ! "NCAR" algorithm (Large and Yeager 2008)
- ln_COARE_3p0 = .false. ! "COARE 3.0" algorithm (Fairall et al. 2003)
- ln_COARE_3p6 = .false. ! "COARE 3.6" algorithm (Edson et al. 2013)
- ln_ECMWF = .false. ! "ECMWF" algorithm (IFS cycle 31)
- rn_zqt = 10. ! Air temperature & humidity reference height (m)
- rn_zu = 10. ! Wind vector reference height (m)
- !
- ! Skin is ONLY available in ECMWF and COARE algorithms:
- ln_skin_cs = .false. ! use the cool-skin parameterization => set nn_fsbc=1 and ln_dm2dc=.true.!
- ln_skin_wl = .false. ! use the warm-layer " => set nn_fsbc=1 and ln_dm2dc=.true.!
- !
- ln_humi_sph = .true. ! humidity specified below in "sn_humi" is specific humidity [kg/kg] if .true.
- ln_humi_dpt = .false. ! humidity specified below in "sn_humi" is dew-point temperature [K] if .true.
- ln_humi_rlh = .false. ! humidity specified below in "sn_humi" is relative humidity [%] if .true.
!
cn_dir = './' ! root directory for the bulk data location
@@ -131,7 +119,4 @@
sn_tair = 'tair_drwnlnd_ERAI_L25Z10_GLOBAL_F128R_ana1d', 24., 'tair' , .false. , .false. , 'monthly' , 'weights_ERAI3D_F128_2_ORCA2_bilinear' , '' , ''
sn_humi = 'humi_drwnlnd_ERAI_L25Z10_GLOBAL_F128R_ana1d', 24., 'humi' , .false. , .false. , 'monthly' , 'weights_ERAI3D_F128_2_ORCA2_bilinear' , '' , ''
- sn_hpgi = 'uhpg_drwnlnd_ERAI_L25Z10_GLOBAL_F128R_ana1d', 24., 'uhpg' , .false. , .false. , 'monthly' , 'weights_ERAI3D_F128_2_ORCA2_bicubic' , 'UG' , ''
- sn_hpgj = 'vhpg_drwnlnd_ERAI_L25Z10_GLOBAL_F128R_ana1d', 24., 'vhpg' , .false. , .false. , 'monthly' , 'weights_ERAI3D_F128_2_ORCA2_bicubic' , 'VG' , ''
-
sn_qsr = 'ncar_rad.15JUNE2009_fill' , 24., 'SWDN_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
sn_qlw = 'ncar_rad.15JUNE2009_fill' , 24., 'LWDN_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
@@ -139,4 +124,6 @@
sn_snow = 'ncar_precip.15JUNE2009_fill' , -1., 'SNOW' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
sn_slp = 'slp.15JUNE2009_fill' , 6., 'SLP' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
+ sn_hpgi = 'uhpg_drwnlnd_ERAI_L25Z10_GLOBAL_F128R_ana1d', 24., 'uhpg' , .false. , .false. , 'monthly' , 'weights_ERAI3D_F128_2_ORCA2_bicubic' , 'UG' , ''
+ sn_hpgj = 'vhpg_drwnlnd_ERAI_L25Z10_GLOBAL_F128R_ana1d', 24., 'vhpg' , .false. , .false. , 'monthly' , 'weights_ERAI3D_F128_2_ORCA2_bicubic' , 'VG' , ''
/
@@ -230,6 +217,6 @@
!! !!
!! namdrg top/bottom drag coefficient (default: NO selection)
-!! namdrg_top top friction (ln_OFF=F & ln_isfcav=T)
-!! namdrg_bot bottom friction (ln_OFF=F)
+!! 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)
Index: /NEMO/branches/2020/r12377_ticket2386/cfgs/ORCA2_ICE_PISCES/EXPREF/context_nemo.xml
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/cfgs/ORCA2_ICE_PISCES/EXPREF/context_nemo.xml (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/cfgs/ORCA2_ICE_PISCES/EXPREF/context_nemo.xml (revision 13540)
@@ -11,5 +11,5 @@
01
01
- 1026.0
+ 1026.0
3991.86795711963
0.99530670233846
Index: /NEMO/branches/2020/r12377_ticket2386/cfgs/ORCA2_ICE_PISCES/EXPREF/namelist_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/cfgs/ORCA2_ICE_PISCES/EXPREF/namelist_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/cfgs/ORCA2_ICE_PISCES/EXPREF/namelist_cfg (revision 13540)
@@ -28,5 +28,5 @@
&namdom ! time and space domain
!-----------------------------------------------------------------------
- rn_Dt = 5400. ! time step for the dynamics and tracer
+ rn_Dt = 5400. ! time step for the dynamics and tracer
/
!-----------------------------------------------------------------------
@@ -80,6 +80,7 @@
ln_blk = .true. ! Bulk formulation (T => fill namsbc_blk )
! Sea-ice :
- nn_ice = 2 ! =2 or 3 automatically for SI3 or CICE ("key_si3" or "key_cice")
- ! except in AGRIF zoom where it has to be specified
+ nn_ice = 2 ! =0 no ice boundary condition
+ ! ! =1 use observed ice-cover ( => fill namsbc_iif )
+ ! ! =2 or 3 for SI3 and CICE, respectively
! Misc. options of sbc :
ln_traqsr = .true. ! Light penetration in the ocean (T => fill namtra_qsr)
@@ -109,13 +110,17 @@
! ! file name ! frequency (hours) ! variable ! time interp.! clim ! 'yearly'/ ! weights filename ! rotation ! land/sea mask !
! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! ! pairing ! filename !
- sn_wndi = 'u_10.15JUNE2009_fill' , 6. , 'U_10_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bicubic_noc.nc' , 'Uwnd' , ''
- sn_wndj = 'v_10.15JUNE2009_fill' , 6. , 'V_10_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bicubic_noc.nc' , 'Vwnd' , ''
- sn_qsr = 'ncar_rad.15JUNE2009_fill' , 24. , 'SWDN_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
- sn_qlw = 'ncar_rad.15JUNE2009_fill' , 24. , 'LWDN_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
- sn_tair = 't_10.15JUNE2009_fill' , 6. , 'T_10_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
- sn_humi = 'q_10.15JUNE2009_fill' , 6. , 'Q_10_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
- sn_prec = 'ncar_precip.15JUNE2009_fill', -1. , 'PRC_MOD1', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
- sn_snow = 'ncar_precip.15JUNE2009_fill', -1. , 'SNOW' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
- sn_slp = 'slp.15JUNE2009_fill' , 6. , 'SLP' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
+ sn_wndi = 'u_10.15JUNE2009_fill' , 6. , 'U_10_MOD', .false. , .true. , 'yearly' , 'weights_core2_orca2_bicub' , 'Uwnd' , ''
+ sn_wndj = 'v_10.15JUNE2009_fill' , 6. , 'V_10_MOD', .false. , .true. , 'yearly' , 'weights_core2_orca2_bicub' , 'Vwnd' , ''
+ sn_qsr = 'ncar_rad.15JUNE2009_fill' , 24. , 'SWDN_MOD', .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , ''
+ sn_qlw = 'ncar_rad.15JUNE2009_fill' , 24. , 'LWDN_MOD', .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , ''
+ sn_tair = 't_10.15JUNE2009_fill' , 6. , 'T_10_MOD', .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , ''
+ sn_humi = 'q_10.15JUNE2009_fill' , 6. , 'Q_10_MOD', .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , ''
+ sn_prec = 'ncar_precip.15JUNE2009_fill', -1. , 'PRC_MOD1', .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , ''
+ sn_snow = 'ncar_precip.15JUNE2009_fill', -1. , 'SNOW' , .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , ''
+ sn_slp = 'slp.15JUNE2009_fill' , 6. , 'SLP' , .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , ''
+/
+!-----------------------------------------------------------------------
+&namsbc_abl ! Atmospheric Boundary Layer formulation (ln_abl = T)
+!-----------------------------------------------------------------------
/
!-----------------------------------------------------------------------
@@ -202,6 +207,6 @@
!! !!
!! namdrg top/bottom drag coefficient (default: NO selection)
-!! namdrg_top top friction (ln_OFF=F & ln_isfcav=T)
-!! namdrg_bot bottom friction (ln_OFF=F)
+!! 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)
@@ -373,5 +378,4 @@
! = 2 add a tke source just at the base of the ML
! = 3 as = 1 applied on HF part of the stress (ln_cpl=T)
- rn_eice = 0 ! below sea ice: =0 ON ; =4 OFF when ice fraction > 1/4
/
!-----------------------------------------------------------------------
@@ -381,4 +385,14 @@
ln_mevar = .true. ! variable (T) or constant (F) mixing efficiency
ln_tsdiff = .true. ! account for differential T/S mixing (T) or not (F)
+
+ cn_dir = './' ! root directory for the iwm data location
+ !___________!_________________________!___________________!___________!_____________!________!___________!__________________!__________!_______________!
+ ! ! file name ! frequency (hours) ! variable ! time interp.! clim ! 'yearly'/ ! weights filename ! rotation ! land/sea mask !
+ ! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! ! pairing ! filename !
+ sn_mpb = 'int_wave_mix' , -12. , 'mixing_power_bot' , .false. , .true. , 'yearly' , '' , '' , ''
+ sn_mpp = 'int_wave_mix' , -12. , 'mixing_power_pyc' , .false. , .true. , 'yearly' , '' , '' , ''
+ sn_mpc = 'int_wave_mix' , -12. , 'mixing_power_cri' , .false. , .true. , 'yearly' , '' , '' , ''
+ sn_dsb = 'int_wave_mix' , -12. , 'decay_scale_bot' , .false. , .true. , 'yearly' , '' , '' , ''
+ sn_dsc = 'int_wave_mix' , -12. , 'decay_scale_cri' , .false. , .true. , 'yearly' , '' , '' , ''
/
!!======================================================================
Index: /NEMO/branches/2020/r12377_ticket2386/cfgs/ORCA2_ICE_PISCES/EXPREF/namelist_top_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/cfgs/ORCA2_ICE_PISCES/EXPREF/namelist_top_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/cfgs/ORCA2_ICE_PISCES/EXPREF/namelist_top_cfg (revision 13540)
@@ -20,5 +20,5 @@
!
ln_trcdta = .true. ! Initialisation from data input file (T) or not (F)
- ln_trcbc = .true. ! Enables Boundary conditions
+ ln_trcbc = .false. ! Enables Boundary conditions
! ! ! ! ! !
! ! name ! title of the field ! units ! init ! sbc ! cbc ! obc !
Index: /NEMO/branches/2020/r12377_ticket2386/cfgs/ORCA2_OFF_PISCES/EXPREF/context_nemo.xml
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/cfgs/ORCA2_OFF_PISCES/EXPREF/context_nemo.xml (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/cfgs/ORCA2_OFF_PISCES/EXPREF/context_nemo.xml (revision 13540)
@@ -11,5 +11,5 @@
01
01
- 1026.0
+ 1026.0
3991.86795711963
0.99530670233846
Index: /NEMO/branches/2020/r12377_ticket2386/cfgs/ORCA2_OFF_PISCES/EXPREF/namelist_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/cfgs/ORCA2_OFF_PISCES/EXPREF/namelist_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/cfgs/ORCA2_OFF_PISCES/EXPREF/namelist_cfg (revision 13540)
@@ -190,6 +190,6 @@
!! !!
!! namdrg top/bottom drag coefficient (default: NO selection)
-!! namdrg_top top friction (ln_OFF=F & ln_isfcav=T)
-!! namdrg_bot bottom friction (ln_OFF=F)
+!! 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)
@@ -201,9 +201,9 @@
/
!-----------------------------------------------------------------------
-&namdrg_top ! TOP friction (ln_OFF =F & ln_isfcav=T)
-!-----------------------------------------------------------------------
-/
-!-----------------------------------------------------------------------
-&namdrg_bot ! BOTTOM friction (ln_OFF =F)
+&namdrg_top ! TOP friction (ln_drg_OFF =F & ln_isfcav=T)
+!-----------------------------------------------------------------------
+/
+!-----------------------------------------------------------------------
+&namdrg_bot ! BOTTOM friction (ln_drg_OFF =F)
!-----------------------------------------------------------------------
/
Index: /NEMO/branches/2020/r12377_ticket2386/cfgs/ORCA2_OFF_PISCES/EXPREF/namelist_top_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/cfgs/ORCA2_OFF_PISCES/EXPREF/namelist_top_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/cfgs/ORCA2_OFF_PISCES/EXPREF/namelist_top_cfg (revision 13540)
@@ -20,5 +20,5 @@
!
ln_trcdta = .true. ! Initialisation from data input file (T) or not (F)
- ln_trcbc = .true. ! Enables Boundary conditions
+ ln_trcbc = .false. ! Enables Boundary conditions
! ! ! ! ! !
! ! name ! title of the field ! units ! init ! sbc ! cbc ! obc !
Index: /NEMO/branches/2020/r12377_ticket2386/cfgs/ORCA2_OFF_TRC/EXPREF/context_nemo.xml
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/cfgs/ORCA2_OFF_TRC/EXPREF/context_nemo.xml (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/cfgs/ORCA2_OFF_TRC/EXPREF/context_nemo.xml (revision 13540)
@@ -11,5 +11,5 @@
01
01
- 1026.0
+ 1026.0
3991.86795711963
0.99530670233846
Index: /NEMO/branches/2020/r12377_ticket2386/cfgs/ORCA2_OFF_TRC/EXPREF/namelist_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/cfgs/ORCA2_OFF_TRC/EXPREF/namelist_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/cfgs/ORCA2_OFF_TRC/EXPREF/namelist_cfg (revision 13540)
@@ -188,6 +188,6 @@
!! !!
!! namdrg top/bottom drag coefficient (default: NO selection)
-!! namdrg_top top friction (ln_OFF=F & ln_isfcav=T)
-!! namdrg_bot bottom friction (ln_OFF=F)
+!! 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)
@@ -199,9 +199,9 @@
/
!-----------------------------------------------------------------------
-&namdrg_top ! TOP friction (ln_OFF =F & ln_isfcav=T)
-!-----------------------------------------------------------------------
-/
-!-----------------------------------------------------------------------
-&namdrg_bot ! BOTTOM friction (ln_OFF =F)
+&namdrg_top ! TOP friction (ln_drg_OFF =F & ln_isfcav=T)
+!-----------------------------------------------------------------------
+/
+!-----------------------------------------------------------------------
+&namdrg_bot ! BOTTOM friction (ln_drg_OFF =F)
!-----------------------------------------------------------------------
/
Index: /NEMO/branches/2020/r12377_ticket2386/cfgs/ORCA2_SAS_ICE/EXPREF/context_nemo.xml
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/cfgs/ORCA2_SAS_ICE/EXPREF/context_nemo.xml (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/cfgs/ORCA2_SAS_ICE/EXPREF/context_nemo.xml (revision 13540)
@@ -11,5 +11,5 @@
01
01
- 1026.0
+ 1026.0
3991.86795711963
0.99530670233846
Index: /NEMO/branches/2020/r12377_ticket2386/cfgs/ORCA2_SAS_ICE/EXPREF/namelist_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/cfgs/ORCA2_SAS_ICE/EXPREF/namelist_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/cfgs/ORCA2_SAS_ICE/EXPREF/namelist_cfg (revision 13540)
@@ -59,5 +59,7 @@
nn_fsbc = 1 ! frequency of SBC module call
ln_blk = .true. ! Bulk formulation (T => fill namsbc_blk )
- nn_ice = 2 ! =2 sea-ice model ("key_SI3" or "key_cice")
+ nn_ice = 2 ! =0 no ice boundary condition
+ ! ! =1 use observed ice-cover ( => fill namsbc_iif )
+ ! ! =2 or 3 for SI3 and CICE, respectively
/
!-----------------------------------------------------------------------
@@ -66,22 +68,4 @@
! ! bulk algorithm :
ln_NCAR = .true. ! "NCAR" algorithm (Large and Yeager 2008)
- ln_COARE_3p0 = .false. ! "COARE 3.0" algorithm (Fairall et al. 2003)
- ln_COARE_3p6 = .false. ! "COARE 3.6" algorithm (Edson et al. 2013)
- ln_ECMWF = .false. ! "ECMWF" algorithm (IFS cycle 31)
- !
- rn_zqt = 10. ! Air temperature & humidity reference height (m)
- rn_zu = 10. ! Wind vector reference height (m)
- ln_Cd_L12 = .false. ! air-ice drags = F(ice concentration) (Lupkes et al. 2012)
- ln_Cd_L15 = .false. ! air-ice drags = F(ice concentration) (Lupkes et al. 2015)
- rn_pfac = 1. ! multiplicative factor for precipitation (total & snow)
- rn_efac = 1. ! multiplicative factor for evaporation (0. or 1.)
- rn_vfac = 0. ! multiplicative factor for ocean & ice velocity used to
- ! ! calculate the wind stress (0.=absolute or 1.=relative winds)
- ln_skin_cs = .false. ! use the cool-skin parameterization (only available in ECMWF and COARE algorithms) !LB
- ln_skin_wl = .false. ! use the warm-layer " " "
- !
- ln_humi_sph = .true. ! humidity specified below in "sn_humi" is specific humidity [kg/kg] if .true.
- ln_humi_dpt = .false. ! humidity specified below in "sn_humi" is dew-point temperature [K] if .true.
- ln_humi_rlh = .false. ! humidity specified below in "sn_humi" is relative humidity [%] if .true.
!
cn_dir = './' ! root directory for the bulk data location
@@ -89,17 +73,13 @@
! ! file name ! frequency (hours) ! variable ! time interp.! clim ! 'yearly'/ ! weights filename ! rotation ! land/sea mask !
! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! ! pairing ! filename !
- sn_wndi = 'u_10.15JUNE2009_fill' , 6. , 'U_10_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bicubic_noc.nc' , 'Uwnd' , ''
- sn_wndj = 'v_10.15JUNE2009_fill' , 6. , 'V_10_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bicubic_noc.nc' , 'Vwnd' , ''
- sn_qsr = 'ncar_rad.15JUNE2009_fill' , 24. , 'SWDN_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
- sn_qlw = 'ncar_rad.15JUNE2009_fill' , 24. , 'LWDN_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
- sn_tair = 't_10.15JUNE2009_fill' , 6. , 'T_10_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
- sn_humi = 'q_10.15JUNE2009_fill' , 6. , 'Q_10_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
- sn_prec = 'ncar_precip.15JUNE2009_fill', -1. , 'PRC_MOD1', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
- sn_snow = 'ncar_precip.15JUNE2009_fill', -1. , 'SNOW' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
- sn_slp = 'slp.15JUNE2009_fill' , 6. , 'SLP' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
-/
-!-----------------------------------------------------------------------
-&namsbc_cpl ! coupled ocean/atmosphere model ("key_oasis3")
-!-----------------------------------------------------------------------
+ sn_wndi = 'u_10.15JUNE2009_fill' , 6. , 'U_10_MOD', .false. , .true. , 'yearly' , 'weights_core2_orca2_bicub' , 'Uwnd' , ''
+ sn_wndj = 'v_10.15JUNE2009_fill' , 6. , 'V_10_MOD', .false. , .true. , 'yearly' , 'weights_core2_orca2_bicub' , 'Vwnd' , ''
+ sn_qsr = 'ncar_rad.15JUNE2009_fill' , 24. , 'SWDN_MOD', .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , ''
+ sn_qlw = 'ncar_rad.15JUNE2009_fill' , 24. , 'LWDN_MOD', .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , ''
+ sn_tair = 't_10.15JUNE2009_fill' , 6. , 'T_10_MOD', .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , ''
+ sn_humi = 'q_10.15JUNE2009_fill' , 6. , 'Q_10_MOD', .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , ''
+ sn_prec = 'ncar_precip.15JUNE2009_fill', -1. , 'PRC_MOD1', .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , ''
+ sn_snow = 'ncar_precip.15JUNE2009_fill', -1. , 'SNOW' , .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , ''
+ sn_slp = 'slp.15JUNE2009_fill' , 6. , 'SLP' , .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , ''
/
!-----------------------------------------------------------------------
@@ -142,6 +122,6 @@
!! !!
!! namdrg top/bottom drag coefficient (default: NO selection)
-!! namdrg_top top friction (ln_OFF=F & ln_isfcav=T)
-!! namdrg_bot bottom friction (ln_OFF=F)
+!! 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)
Index: /NEMO/branches/2020/r12377_ticket2386/cfgs/SHARED/field_def_nemo-ice.xml
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/cfgs/SHARED/field_def_nemo-ice.xml (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/cfgs/SHARED/field_def_nemo-ice.xml (revision 13540)
@@ -49,4 +49,6 @@
+
+
@@ -81,5 +83,6 @@
-
+
+
@@ -173,4 +176,7 @@
+
+
+
@@ -211,4 +217,5 @@
+
@@ -289,5 +296,7 @@
+
+
@@ -300,4 +309,8 @@
snwthic_cat * icemask_cat + $missval * (1.-icemask_cat)
iceconc_cat*100. * icemask_cat + $missval * (1.-icemask_cat)
+
+
+
+
@@ -560,4 +573,5 @@
+
Index: /NEMO/branches/2020/r12377_ticket2386/cfgs/SHARED/field_def_nemo-oce.xml
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/cfgs/SHARED/field_def_nemo-oce.xml (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/cfgs/SHARED/field_def_nemo-oce.xml (revision 13540)
@@ -1,3 +1,3 @@
-
+
@@ -16,5 +16,5 @@
Configuration of multiple-linear-regression analysis (diamlr)
=====================================================================================================
-
+
This field group configures diamlr for tidal harmonic analysis of field
ssh: in addition to a regressor for fitting the mean value (diamlr_r101),
@@ -73,6 +73,6 @@
-
-
-
+
-
+
-
+
toce * e3t
@@ -129,4 +129,14 @@
+
+
+
+
+
+
+
+
+
+
@@ -146,5 +156,5 @@
-
+
sss * sss
@@ -152,7 +162,7 @@
-
-
-
+
+
+
@@ -177,9 +187,7 @@
-
-
@@ -295,5 +303,5 @@
-
+
@@ -311,5 +319,5 @@
-
+
@@ -321,5 +329,5 @@
-
+
@@ -369,4 +377,19 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
@@ -405,11 +428,11 @@
-
+
-
+
-
+
@@ -422,8 +445,8 @@
-
+
-
+
@@ -440,9 +463,11 @@
-
+
+
-
+
+
@@ -456,5 +481,5 @@
- sqrt( uz1_dta^2 + vz1_dta^2 )
+ sqrt( uz1_dta^2 + vz1_dta^2 )
@@ -462,12 +487,12 @@
- sqrt( uz1_geo^2 + vz1_geo^2 )
+ sqrt( uz1_geo^2 + vz1_geo^2 )
-
+
-
+
@@ -478,9 +503,9 @@
uoce * e3u
- this * uoce_e3u_vsum
+ this * uoce_e3u_vsum
@uocetr_vsum
-
- uocetr_vsum_cumul * $rau0
+
+ uocetr_vsum_cumul * $rho0
@@ -534,7 +559,7 @@
-
+
-
+
@@ -593,11 +618,11 @@
-
+
-
+
- woce * e3w
+ woce * e3w
@@ -609,17 +634,17 @@
- avt * e3w
+ avt * e3w
- avm * e3w
+ avm * e3w
- avs * e3w
+ avs * e3w
- avt_evd * e3w
+ avt_evd * e3w
@@ -634,10 +659,13 @@
-
+
+
+
+
-
+
@@ -683,5 +711,5 @@
this * e2u
- this * maskMFO_u * $rau0
+ this * maskMFO_u * $rho0
@voce_e3v
@@ -689,10 +717,9 @@
this * e1v
- this * maskMFO_v * $rau0
+ this * maskMFO_v * $rho0
u_masstr_strait + v_masstr_strait
-
@@ -709,5 +736,5 @@
-
+
@@ -727,6 +754,6 @@
-
-
+
+
@@ -736,5 +763,5 @@
-
+
@@ -742,5 +769,5 @@
-
+
@@ -758,5 +785,5 @@
-
-
-
+
+
-
+
@@ -926,7 +953,7 @@
-
-
-
+
+
+
@@ -945,8 +972,8 @@
-
-
-
-
+
+
+
+
@@ -965,12 +992,12 @@
-
-
-
-
+
+
+
+
-
-
-
+
+
-
+
-
-
+
+
-
-
+
+
-
-
+
+
Index: /NEMO/branches/2020/r12377_ticket2386/cfgs/SHARED/namelist_ice_ref
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/cfgs/SHARED/namelist_ice_ref (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/cfgs/SHARED/namelist_ice_ref (revision 13540)
@@ -43,5 +43,6 @@
ln_cat_usr = .false. ! ice categories are defined by rn_catbnd below (m)
rn_catbnd = 0.,0.45,1.1,2.1,3.7,6.0
- rn_himin = 0.1 ! minimum ice thickness (m) used in remapping
+ rn_himin = 0.1 ! minimum ice thickness (m) allowed
+ rn_himax = 99.0 ! maximum ice thickness (m) allowed
/
!------------------------------------------------------------------------------
@@ -56,9 +57,9 @@
rn_ishlat = 2. ! lbc : free slip (0) ; partial slip (0-2) ; no slip (2) ; strong slip (>2)
ln_landfast_L16 = .false. ! landfast: parameterization from Lemieux 2016
- rn_depfra = 0.125 ! fraction of ocean depth that ice must reach to initiate landfast
+ rn_lf_depfra = 0.125 ! fraction of ocean depth that ice must reach to initiate landfast
! recommended range: [0.1 ; 0.25]
- rn_icebfr = 15. ! maximum bottom stress per unit volume [N/m3]
- rn_lfrelax = 1.e-5 ! relaxation time scale to reach static friction [s-1]
- rn_tensile = 0.05 ! isotropic tensile strength [0-0.5??]
+ rn_lf_bfr = 15. ! maximum bottom stress per unit volume [N/m3]
+ rn_lf_relax = 1.e-5 ! relaxation time scale to reach static friction [s-1]
+ rn_lf_tensile = 0.05 ! isotropic tensile strength [0-0.5??]
/
!------------------------------------------------------------------------------
@@ -91,16 +92,21 @@
!------------------------------------------------------------------------------
ln_rhg_EVP = .true. ! EVP rheology
- ln_aEVP = .false. ! adaptive rheology (Kimmritz et al. 2016 & 2017)
+ ln_aEVP = .true. ! adaptive rheology (Kimmritz et al. 2016 & 2017)
rn_creepl = 2.0e-9 ! creep limit [1/s]
rn_ecc = 2.0 ! eccentricity of the elliptical yield curve
- nn_nevp = 120 ! number of EVP subcycles
+ nn_nevp = 100 ! number of EVP subcycles
rn_relast = 0.333 ! ratio of elastic timescale to ice time step: Telast = dt_ice * rn_relast
- ! advised value: 1/3 (rn_nevp=120) or 1/9 (rn_nevp=300)
+ ! advised value: 1/3 (nn_nevp=100) or 1/9 (nn_nevp=300)
+ nn_rhg_chkcvg = 0 ! check convergence of rheology
+ ! = 0 no check
+ ! = 1 check at the main time step (output xml: uice_cvg)
+ ! = 2 check at both main and rheology time steps (additional output: ice_cvg.nc)
+ ! this option 2 asks a lot of communications between cpu
/
!------------------------------------------------------------------------------
&namdyn_adv ! Ice advection
!------------------------------------------------------------------------------
- ln_adv_Pra = .true. ! Advection scheme (Prather)
- ln_adv_UMx = .false. ! Advection scheme (Ultimate-Macho)
+ ln_adv_Pra = .true. ! Advection scheme (Prather)
+ ln_adv_UMx = .false. ! Advection scheme (Ultimate-Macho)
nn_UMx = 5 ! order of the scheme for UMx (1-5 ; 20=centered 2nd order)
/
@@ -109,5 +115,9 @@
!------------------------------------------------------------------------------
rn_cio = 5.0e-03 ! ice-ocean drag coefficient (-)
- rn_blow_s = 0.66 ! mesure of snow blowing into the leads
+ nn_snwfra = 2 ! calculate the fraction of ice covered by snow (for zdf and albedo)
+ ! = 0 fraction = 1 (if snow) or 0 (if no snow)
+ ! = 1 fraction = 1-exp(-0.2*rhos*hsnw) [MetO formulation]
+ ! = 2 fraction = hsnw / (hsnw+0.02) [CICE formulation]
+ rn_snwblow = 0.66 ! mesure of snow blowing into the leads
! = 1 => no snow blowing, < 1 => some snow blowing
nn_flxdist = -1 ! Redistribute heat flux over ice categories
@@ -118,4 +128,7 @@
ln_cndflx = .false. ! Use conduction flux as surface boundary conditions (i.e. for Jules coupling)
ln_cndemulate = .false. ! emulate conduction flux (if not provided in the inputs)
+ nn_qtrice = 1 ! Solar flux transmitted thru the surface scattering layer:
+ ! = 0 Grenfell and Maykut 1977 (depends on cloudiness and is 0 when there is snow)
+ ! = 1 Lebrun 2019 (equals 0.3 anytime with different melting/dry snw conductivities)
/
!------------------------------------------------------------------------------
@@ -126,4 +139,6 @@
ln_icedO = .true. ! activate ice growth in open-water (T) or not (F)
ln_icedS = .true. ! activate brine drainage (T) or not (F)
+ !
+ ln_leadhfx = .true. ! heat in the leads is used to melt sea-ice before warming the ocean
/
!------------------------------------------------------------------------------
@@ -135,5 +150,9 @@
rn_cnd_s = 0.31 ! thermal conductivity of the snow (0.31 W/m/K, Maykut and Untersteiner, 1971)
! Obs: 0.1-0.5 (Lecomte et al, JAMES 2013)
- rn_kappa_i = 1.0 ! radiation attenuation coefficient in sea ice [1/m]
+ rn_kappa_i = 1.0 ! radiation attenuation coefficient in sea ice [1/m]
+ rn_kappa_s = 10.0 ! nn_qtrice = 0: radiation attenuation coefficient in snow [1/m]
+ rn_kappa_smlt = 7.0 ! nn_qtrice = 1: radiation attenuation coefficient in melting snow [1/m]
+ rn_kappa_sdry = 10.0 ! radiation attenuation coefficient in dry snow [1/m]
+ ln_zdf_chkcvg = .false. ! check convergence of heat diffusion scheme (outputs: tice_cvgerr, tice_cvgstp)
/
!------------------------------------------------------------------------------
@@ -175,10 +194,13 @@
&namthd_pnd ! Melt ponds
!------------------------------------------------------------------------------
- ln_pnd = .false. ! activate melt ponds or not
- ln_pnd_H12 = .false. ! activate evolutive melt ponds (from Holland et al 2012)
- ln_pnd_CST = .false. ! activate constant melt ponds
- rn_apnd = 0.2 ! prescribed pond fraction, at Tsu=0 degC
- rn_hpnd = 0.05 ! prescribed pond depth, at Tsu=0 degC
- ln_pnd_alb = .false. ! melt ponds affect albedo or not
+ ln_pnd = .true. ! activate melt ponds or not
+ ln_pnd_LEV = .true. ! level ice melt ponds (from Flocco et al 2007,2010 & Holland et al 2012)
+ rn_apnd_min = 0.15 ! minimum ice fraction that contributes to melt pond. range: 0.0 -- 0.15 ??
+ rn_apnd_max = 0.85 ! maximum ice fraction that contributes to melt pond. range: 0.7 -- 0.85 ??
+ ln_pnd_CST = .false. ! constant melt ponds
+ rn_apnd = 0.2 ! prescribed pond fraction, at Tsu=0 degC
+ rn_hpnd = 0.05 ! prescribed pond depth, at Tsu=0 degC
+ ln_pnd_lids = .true. ! frozen lids on top of the ponds (only for ln_pnd_LEV)
+ ln_pnd_alb = .true. ! effect of melt ponds on ice albedo
/
!------------------------------------------------------------------------------
@@ -186,5 +208,7 @@
!------------------------------------------------------------------------------
ln_iceini = .true. ! activate ice initialization (T) or not (F)
- ln_iceini_file = .false. ! netcdf file provided for initialization (T) or not (F)
+ nn_iceini_file = 0 ! 0 = Initialise sea ice based on SSTs
+ ! 1 = Initialise sea ice from single category netcdf file
+ ! 2 = Initialise sea ice from multi category restart file
rn_thres_sst = 2.0 ! max temp. above Tfreeze with initial ice = (sst - tfreeze)
rn_hti_ini_n = 3.0 ! initial ice thickness (m), North
@@ -206,15 +230,18 @@
rn_hpd_ini_n = 0.05 ! initial pond depth (m), North
rn_hpd_ini_s = 0.05 ! " " South
- ! -- for ln_iceini_file = T
- sn_hti = 'Ice_initialization' , -12 ,'hti' , .false. , .true., 'yearly' , '' , '', ''
- sn_hts = 'Ice_initialization' , -12 ,'hts' , .false. , .true., 'yearly' , '' , '', ''
- sn_ati = 'Ice_initialization' , -12 ,'ati' , .false. , .true., 'yearly' , '' , '', ''
- sn_smi = 'Ice_initialization' , -12 ,'smi' , .false. , .true., 'yearly' , '' , '', ''
- sn_tmi = 'Ice_initialization' , -12 ,'tmi' , .false. , .true., 'yearly' , '' , '', ''
- sn_tsu = 'Ice_initialization' , -12 ,'tsu' , .false. , .true., 'yearly' , '' , '', ''
- sn_tms = 'NOT USED' , -12 ,'tms' , .false. , .true., 'yearly' , '' , '', ''
+ rn_hld_ini_n = 0.0 ! initial pond lid depth (m), North
+ rn_hld_ini_s = 0.0 ! " " South
+ ! -- for nn_iceini_file = 1
+ sn_hti = 'Ice_initialization' , -12. ,'hti' , .false. , .true., 'yearly' , '' , '', ''
+ sn_hts = 'Ice_initialization' , -12. ,'hts' , .false. , .true., 'yearly' , '' , '', ''
+ sn_ati = 'Ice_initialization' , -12. ,'ati' , .false. , .true., 'yearly' , '' , '', ''
+ sn_smi = 'Ice_initialization' , -12. ,'smi' , .false. , .true., 'yearly' , '' , '', ''
+ sn_tmi = 'Ice_initialization' , -12. ,'tmi' , .false. , .true., 'yearly' , '' , '', ''
+ sn_tsu = 'Ice_initialization' , -12. ,'tsu' , .false. , .true., 'yearly' , '' , '', ''
+ sn_tms = 'NOT USED' , -12. ,'tms' , .false. , .true., 'yearly' , '' , '', ''
! melt ponds (be careful, sn_apd is the pond concentration (not fraction), so it differs from rn_apd)
- sn_apd = 'NOT USED' , -12 ,'apd' , .false. , .true., 'yearly' , '' , '', ''
- sn_hpd = 'NOT USED' , -12 ,'hpd' , .false. , .true., 'yearly' , '' , '', ''
+ sn_apd = 'NOT USED' , -12. ,'apd' , .false. , .true., 'yearly' , '' , '', ''
+ sn_hpd = 'NOT USED' , -12. ,'hpd' , .false. , .true., 'yearly' , '' , '', ''
+ sn_hld = 'NOT USED' , -12. ,'hld' , .false. , .true., 'yearly' , '' , '', ''
cn_dir='./'
/
@@ -238,5 +265,5 @@
ln_icediahsb = .false. ! output the heat, mass & salt budgets (T) or not (F)
ln_icectl = .false. ! ice points output for debug (T or F)
- iiceprt = 10 ! i-index for debug
- jiceprt = 10 ! j-index for debug
-/
+ iiceprt = 10 ! i-index for debug
+ jiceprt = 10 ! j-index for debug
+/
Index: /NEMO/branches/2020/r12377_ticket2386/cfgs/SHARED/namelist_pisces_ref
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/cfgs/SHARED/namelist_pisces_ref (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/cfgs/SHARED/namelist_pisces_ref (revision 13540)
@@ -352,7 +352,7 @@
!
cn_dir = './' ! root directory for the location of the dynamical files
- ln_ironsed = .true. ! boolean for Fe input from sediments
- ln_ironice = .true. ! boolean for Fe input from sea ice
- ln_hydrofe = .true. ! boolean for from hydrothermal vents
+ ln_ironsed = .false. ! boolean for Fe input from sediments
+ ln_ironice = .false. ! boolean for Fe input from sea ice
+ ln_hydrofe = .false. ! boolean for from hydrothermal vents
sedfeinput = 2.e-9 ! Coastal release of Iron
distcoast = 5.e3 ! Distance off the coast for Iron from sediments
Index: /NEMO/branches/2020/r12377_ticket2386/cfgs/SHARED/namelist_ref
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/cfgs/SHARED/namelist_ref (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/cfgs/SHARED/namelist_ref (revision 13540)
@@ -72,5 +72,5 @@
ln_linssh = .false. ! =T linear free surface ==>> model level are fixed in time
!
- rn_Dt = 5400. ! time step for the dynamics and tracer
+ rn_Dt = 5400. ! time step for the dynamics and tracer
rn_atfp = 0.1 ! asselin time filter parameter
!
@@ -217,6 +217,5 @@
nn_ice = 0 ! =0 no ice boundary condition
! ! =1 use observed ice-cover ( => fill namsbc_iif )
- ! ! =2 or 3 automatically for SI3 or CICE ("key_si3" or "key_cice")
- ! ! except in AGRIF zoom where it has to be specified
+ ! ! =2 or 3 for SI3 and CICE, respectively
ln_ice_embd = .false. ! =T embedded sea-ice (pressure + mass and salt exchanges)
! ! =F levitating ice (no pressure, mass and salt exchanges)
@@ -269,10 +268,9 @@
ln_Cd_L12 = .false. ! air-ice drags = F(ice conc.) (Lupkes et al. 2012)
ln_Cd_L15 = .false. ! air-ice drags = F(ice conc.) (Lupkes et al. 2015)
- ! ! - module of the mean stress" data
+ ln_crt_fbk = .false. ! Add surface current feedback to the wind stress (Renault et al. 2020, doi: 10.1029/2019MS001715)
+ rn_stau_a = -2.9e-3 ! Alpha from eq. 10: Stau = Alpha * Wnd + Beta
+ rn_stau_b = 8.0e-3 ! Beta
rn_pfac = 1. ! multipl. factor for precipitation (total & snow)
rn_efac = 1. ! multipl. factor for evaporation (0. or 1.)
- rn_vfac = 0. ! multipl. factor for ocean & ice velocity
- ! ! used to calculate the wind stress
- ! ! (0. => absolute or 1. => relative winds)
ln_skin_cs = .false. ! use the cool-skin parameterization
ln_skin_wl = .false. ! use the warm-layer parameterization
@@ -281,4 +279,5 @@
ln_humi_dpt = .false. ! humidity "sn_humi" is dew-point temperature [K]
ln_humi_rlh = .false. ! humidity "sn_humi" is relative humidity [%]
+ ln_tpot = .true. !!GS: compute potential temperature or not
!
cn_dir = './' ! root directory for the bulk data location
@@ -292,9 +291,12 @@
sn_tair = 't_10.15JUNE2009_fill' , 6. , 'T_10_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
sn_humi = 'q_10.15JUNE2009_fill' , 6. , 'Q_10_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
- sn_hpgi = 'NONE' , 24. , 'uhpg' , .false. , .false., 'monthly' , 'weights_ERAI3D_F128_2_ORCA2_bicubic', 'UG' , ''
- sn_hpgj = 'NONE' , 24. , 'vhpg' , .false. , .false., 'monthly' , 'weights_ERAI3D_F128_2_ORCA2_bicubic', 'VG' , ''
sn_prec = 'ncar_precip.15JUNE2009_fill', -1. , 'PRC_MOD1', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
sn_snow = 'ncar_precip.15JUNE2009_fill', -1. , 'SNOW' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
sn_slp = 'slp.15JUNE2009_fill' , 6. , 'SLP' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
+ sn_uoatm = 'NOT USED' , 6. , 'UOATM' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , 'Uoceatm', ''
+ sn_voatm = 'NOT USED' , 6. , 'VOATM' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , 'Voceatm', ''
+ sn_cc = 'NOT USED' , 24. , 'CC' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
+ sn_hpgi = 'NOT USED' , 24. , 'uhpg' , .false. , .false., 'monthly' , 'weights_ERAI3D_F128_2_ORCA2_bicubic', 'UG' , ''
+ sn_hpgj = 'NOT USED' , 24. , 'vhpg' , .false. , .false., 'monthly' , 'weights_ERAI3D_F128_2_ORCA2_bicubic', 'VG' , ''
/
!-----------------------------------------------------------------------
@@ -309,30 +311,34 @@
cn_ablrst_outdir = "." ! directory to write output abl restarts
+ ln_rstart_abl = .false.
ln_hpgls_frc = .false.
ln_geos_winds = .false.
- nn_dyn_restore = 2 ! restoring option for dynamical ABL variables: = 0 no restoring
+ ln_smth_pblh = .false.
+ nn_dyn_restore = 0 ! restoring option for dynamical ABL variables: = 0 no restoring
! = 1 equatorial restoring
! = 2 global restoring
- rn_ldyn_min = 4.5 ! magnitude of the nudging on ABL dynamics at the bottom of the ABL [hour]
- rn_ldyn_max = 1.5 ! magnitude of the nudging on ABL dynamics at the top of the ABL [hour]
- rn_ltra_min = 4.5 ! magnitude of the nudging on ABL tracers at the bottom of the ABL [hour]
- rn_ltra_max = 1.5 ! magnitude of the nudging on ABL tracers at the top of the ABL [hour]
+ 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)
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
- rn_Cm = 0.0667 ! 0.126 in MesoNH
- rn_Ct = 0.1667 ! 0.143 in MesoNH
- rn_Ce = 0.4 ! 0.4 in MesoNH
- rn_Ceps = 0.7 ! 0.85 in MesoNH
- rn_Rod = 0.15 ! c0 in RMCA17 mixing length formulation (not yet implemented)
- rn_Ric = 0.139 ! Critical Richardson number (to compute PBL height and diffusivities)
+ ! CBR00 ! CCH02 ! MesoNH !
+ rn_Cm = 0.0667 ! 0.0667 ! 0.1260 ! 0.1260 !
+ rn_Ct = 0.1667 ! 0.1667 ! 0.1430 ! 0.1430 !
+ rn_Ce = 0.40 ! 0.40 ! 0.34 ! 0.40 !
+ rn_Ceps = 0.700 ! 0.700 ! 0.845 ! 0.850 !
+ rn_Ric = 0.139 ! 0.139 ! 0.143 ! ? ! Critical Richardson number (to compute PBL height and diffusivities)
+ rn_Rod = 0.15 ! c0 in RMCA17 mixing length formulation (not yet implemented)
/
!-----------------------------------------------------------------------
&namsbc_cpl ! coupled ocean/atmosphere model ("key_oasis3")
!-----------------------------------------------------------------------
- nn_cplmodel = 1 ! Maximum number of models to/from which NEMO is potentially sending/receiving data
- ln_usecplmask = .false. ! 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)
- nn_cats_cpl = 5 ! Number of sea ice categories over which coupling is to be carried out (if not 1)
+ nn_cplmodel = 1 ! Maximum number of models to/from which NEMO is potentially sending/receiving data
+ ln_usecplmask = .false. ! 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)
+ ln_scale_ice_flux = .false. ! use ice fluxes that are already "ice weighted" ( i.e. multiplied ice concentration)
+ nn_cats_cpl = 5 ! Number of sea ice categories over which coupling is to be carried out (if not 1)
!_____________!__________________________!____________!_____________!______________________!________!
! ! description ! multiple ! vector ! vector ! vector !
@@ -540,10 +546,10 @@
! ! file name ! frequency (hours) ! variable ! time interp.! clim ! 'yearly'/ ! weights ! rotation ! land/sea mask !
! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! filename ! pairing ! filename !
- sn_isfpar_zmax = 'isfmlt_par', 0 ,'sozisfmax', .false. , .true. , 'yearly' , '' , '' , ''
- sn_isfpar_zmin = 'isfmlt_par', 0 ,'sozisfmin', .false. , .true. , 'yearly' , '' , '' , ''
+ sn_isfpar_zmax = 'isfmlt_par', 0. ,'sozisfmax', .false. , .true. , 'yearly' , '' , '' , ''
+ sn_isfpar_zmin = 'isfmlt_par', 0. ,'sozisfmin', .false. , .true. , 'yearly' , '' , '' , ''
!* 'spe' and 'oasis' case
- sn_isfpar_fwf = 'isfmlt_par' , -12. ,'sofwfisf' , .false. , .true. , 'yearly' , '' , '' , ''
+ sn_isfpar_fwf = 'isfmlt_par' , -12. ,'sofwfisf' , .false. , .true. , 'yearly' , '' , '' , ''
!* 'bg03' case
- sn_isfpar_Leff = 'isfmlt_par', 0. ,'Leff' , .false. , .true. , 'yearly' , '' , '' , ''
+ sn_isfpar_Leff = 'isfmlt_par', 0. ,'Leff' , .false. , .true. , 'yearly' , '' , '' , ''
!
! ---------------- ice sheet coupling -------------------------------
@@ -639,11 +645,12 @@
&namagrif ! AGRIF zoom ("key_agrif")
!-----------------------------------------------------------------------
- ln_agrif_2way = .true. ! activate two way nesting
- ln_spc_dyn = .true. ! use 0 as special value for dynamics
- rn_sponge_tra = 2880. ! coefficient for tracer sponge layer [m2/s]
- rn_sponge_dyn = 2880. ! coefficient for dynamics sponge layer [m2/s]
- rn_trelax_tra = 0.01 ! inverse of relaxation time (in steps) for tracers []
- rn_trelax_dyn = 0.01 ! inverse of relaxation time (in steps) for dynamics []
- ln_chk_bathy = .false. ! =T check the parent bathymetry
+ ln_agrif_2way = .true. ! activate two way nesting
+ ln_init_chfrpar = .false. ! initialize child grids from parent
+ ln_spc_dyn = .true. ! use 0 as special value for dynamics
+ rn_sponge_tra = 0.002 ! coefficient for tracer sponge layer []
+ rn_sponge_dyn = 0.002 ! coefficient for dynamics sponge layer []
+ rn_trelax_tra = 0.01 ! inverse of relaxation time (in steps) for tracers []
+ rn_trelax_dyn = 0.01 ! inverse of relaxation time (in steps) for dynamics []
+ ln_chk_bathy = .false. ! =T check the parent bathymetry
/
!-----------------------------------------------------------------------
@@ -727,4 +734,5 @@
bn_aip = 'NOT USED' , 24. , 'siapnd' , .true. , .false., 'daily' , '' , '' , ''
bn_hip = 'NOT USED' , 24. , 'sihpnd' , .true. , .false., 'daily' , '' , '' , ''
+ bn_hil = 'NOT USED' , 24. , 'sihlid' , .true. , .false., 'daily' , '' , '' , ''
! if bn_t_i etc are "not used", then define arbitrary temperatures and salinity and ponds
rn_ice_tem = 270. ! arbitrary temperature of incoming sea ice
@@ -733,4 +741,5 @@
rn_ice_apnd = 0.2 ! -- pond fraction = a_ip/a_i --
rn_ice_hpnd = 0.05 ! -- pond depth --
+ rn_ice_hlid = 0.0 ! -- pond lid depth --
/
!-----------------------------------------------------------------------
@@ -745,6 +754,6 @@
!! !!
!! namdrg top/bottom drag coefficient (default: NO selection)
-!! namdrg_top top friction (ln_OFF=F & ln_isfcav=T)
-!! namdrg_bot bottom friction (ln_OFF=F)
+!! 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)
@@ -754,5 +763,5 @@
&namdrg ! top/bottom drag coefficient (default: NO selection)
!-----------------------------------------------------------------------
- ln_OFF = .false. ! free-slip : Cd = 0 (F => fill namdrg_bot
+ 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 = .false. ! non-linear drag: Cd = Cd0 |U|
@@ -760,7 +769,8 @@
!
ln_drgimp = .true. ! implicit top/bottom friction flag
-/
-!-----------------------------------------------------------------------
-&namdrg_top ! TOP friction (ln_OFF =F & ln_isfcav=T)
+ ln_drgice_imp = .true. ! implicit ice-ocean drag
+/
+!-----------------------------------------------------------------------
+&namdrg_top ! TOP friction (ln_drg_OFF =F & ln_isfcav=T)
!-----------------------------------------------------------------------
rn_Cd0 = 1.e-3 ! drag coefficient [-]
@@ -773,5 +783,5 @@
/
!-----------------------------------------------------------------------
-&namdrg_bot ! BOTTOM friction (ln_OFF =F)
+&namdrg_bot ! BOTTOM friction (ln_drg_OFF =F)
!-----------------------------------------------------------------------
rn_Cd0 = 1.e-3 ! drag coefficient [-]
@@ -826,5 +836,5 @@
!
! ! S-EOS coefficients (ln_seos=T):
- ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
+ ! ! rd(T,S,Z)*rho0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
rn_a0 = 1.6550e-1 ! thermal expension coefficient
rn_b0 = 7.6554e-1 ! saline expension coefficient
@@ -999,5 +1009,5 @@
ln_bt_auto = .true. ! Number of sub-step defined from:
rn_bt_cmax = 0.8 ! =T : the Maximum Courant Number allowed
- nn_e = 30 ! =F : the number of sub-step in rn_Dt seconds
+ nn_e = 30 ! =F : the number of sub-step in rn_Dt seconds
rn_bt_alpha = 0. ! Temporal diffusion parameter (if ln_bt_av=F)
/
@@ -1130,11 +1140,16 @@
rn_bshear = 1.e-20 ! background shear (>0) currently a numerical threshold (do not change it)
nn_pdl = 1 ! Prandtl number function of richarson number (=1, avt=pdl(Ri)*avm) or not (=0, avt=avm)
- nn_mxl = 2 ! mixing length: = 0 bounded by the distance to surface and bottom
+ nn_mxl = 3 ! mixing length: = 0 bounded by the distance to surface and bottom
! ! = 1 bounded by the local vertical scale factor
! ! = 2 first vertical derivative of mixing length bounded by 1
! ! = 3 as =2 with distinct dissipative an mixing length scale
ln_mxl0 = .true. ! surface mixing length scale = F(wind stress) (T) or not (F)
+ nn_mxlice = 2 ! type of scaling under sea-ice
+ ! = 0 no scaling under sea-ice
+ ! = 1 scaling with constant sea-ice thickness
+ ! = 2 scaling with mean sea-ice thickness ( only with SI3 sea-ice model )
+ ! = 3 scaling with maximum sea-ice thickness
+ rn_mxlice = 10. ! max constant ice thickness value when scaling under sea-ice ( nn_mxlice=1)
rn_mxl0 = 0.04 ! surface buoyancy lenght scale minimum value
- ln_drg = .false. ! top/bottom friction added as boundary condition of TKE
ln_lc = .true. ! Langmuir cell parameterisation (Axell 2002)
rn_lc = 0.15 ! coef. associated to Langmuir cells
@@ -1147,5 +1162,9 @@
! = 0 constant 10 m length scale
! = 1 0.5m at the equator to 30m poleward of 40 degrees
- rn_eice = 4 ! below sea ice: =0 ON ; =4 OFF when ice fraction > 1/4
+ nn_eice = 1 ! attenutaion of langmuir & surface wave breaking under ice
+ ! ! = 0 no impact of ice cover on langmuir & surface wave breaking
+ ! ! = 1 weigthed by 1-TANH(10*fr_i)
+ ! ! = 2 weighted by 1-fr_i
+ ! ! = 3 weighted by 1-MIN(1,4*fr_i)
/
!-----------------------------------------------------------------------
@@ -1160,7 +1179,13 @@
rn_charn = 70000. ! Charnock constant for wb induced roughness length
rn_hsro = 0.02 ! Minimum surface roughness
+ rn_hsri = 0.03 ! Ice-ocean roughness
rn_frac_hs = 1.3 ! Fraction of wave height as roughness (if nn_z0_met>1)
nn_z0_met = 2 ! Method for surface roughness computation (0/1/2/3)
- ! ! =3 requires ln_wave=T
+ ! ! = 3 requires ln_wave=T
+ nn_z0_ice = 1 ! attenutaion of surface wave breaking under ice
+ ! ! = 0 no impact of ice cover
+ ! ! = 1 roughness uses rn_hsri and is weigthed by 1-TANH(10*fr_i)
+ ! ! = 2 roughness uses rn_hsri and is weighted by 1-fr_i
+ ! ! = 3 roughness uses rn_hsri and is weighted by 1-MIN(1,4*fr_i)
nn_bc_surf = 1 ! surface condition (0/1=Dir/Neum)
nn_bc_bot = 1 ! bottom condition (0/1=Dir/Neum)
@@ -1193,6 +1218,15 @@
ln_mevar = .true. ! variable (T) or constant (F) mixing efficiency
ln_tsdiff = .true. ! account for differential T/S mixing (T) or not (F)
-/
-
+
+ cn_dir = './' ! root directory for the iwm data location
+ !___________!_________________________!___________________!___________!_____________!________!___________!__________________!__________!_______________!
+ ! ! file name ! frequency (hours) ! variable ! time interp.! clim ! 'yearly'/ ! weights filename ! rotation ! land/sea mask !
+ ! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! ! pairing ! filename !
+ sn_mpb = 'NOT USED' , -12. , 'mixing_power_bot' , .false. , .true. , 'yearly' , '' , '' , ''
+ sn_mpp = 'NOT USED' , -12. , 'mixing_power_pyc' , .false. , .true. , 'yearly' , '' , '' , ''
+ sn_mpc = 'NOT USED' , -12. , 'mixing_power_cri' , .false. , .true. , 'yearly' , '' , '' , ''
+ sn_dsb = 'NOT USED' , -12. , 'decay_scale_bot' , .false. , .true. , 'yearly' , '' , '' , ''
+ sn_dsc = 'NOT USED' , -12. , 'decay_scale_cri' , .false. , .true. , 'yearly' , '' , '' , ''
+/
!!======================================================================
!! *** Diagnostics namelists *** !!
@@ -1382,31 +1416,28 @@
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)
/
!-----------------------------------------------------------------------
&namctl ! Control prints (default: OFF)
!-----------------------------------------------------------------------
- sn_cfctl%l_glochk = .FALSE. ! Range sanity checks are local (F) or global (T). Set T for debugging only
- sn_cfctl%l_allon = .FALSE. ! IF T activate all options. If F deactivate all unless l_config is T
- sn_cfctl%l_config = .TRUE. ! IF .true. then control which reports are written with the following
- sn_cfctl%l_runstat = .TRUE. ! switches and which areas produce reports with the proc integer settings.
- sn_cfctl%l_trcstat = .FALSE. ! The default settings for the proc integers should ensure
- sn_cfctl%l_oceout = .FALSE. ! that all areas report.
- sn_cfctl%l_layout = .FALSE. !
- sn_cfctl%l_prtctl = .FALSE. !
- sn_cfctl%l_prttrc = .FALSE. !
- sn_cfctl%l_oasout = .FALSE. !
- sn_cfctl%procmin = 0 ! Minimum area number for reporting [default:0]
- sn_cfctl%procmax = 1000000 ! Maximum area number for reporting [default:1000000]
- sn_cfctl%procincr = 1 ! Increment for optional subsetting of areas [default:1]
- sn_cfctl%ptimincr = 1 ! Timestep increment for writing time step progress info
- nn_print = 0 ! level of print (0 no extra print)
- nn_ictls = 0 ! start i indice of control sum (use to compare mono versus
- nn_ictle = 0 ! end i indice of control sum multi processor runs
- nn_jctls = 0 ! start j indice of control over a subdomain)
- nn_jctle = 0 ! end j indice of control
- nn_isplt = 1 ! number of processors in i-direction
- nn_jsplt = 1 ! number of processors in j-direction
- ln_timing = .false. ! timing by routine write out in timing.output file
- ln_diacfl = .false. ! CFL diagnostics write out in cfl_diagnostics.ascii
+ sn_cfctl%l_runstat = .TRUE. ! switches and which areas produce reports with the proc integer settings.
+ sn_cfctl%l_trcstat = .FALSE. ! The default settings for the proc integers should ensure
+ sn_cfctl%l_oceout = .FALSE. ! that all areas report.
+ sn_cfctl%l_layout = .FALSE. !
+ sn_cfctl%l_prtctl = .FALSE. !
+ sn_cfctl%l_prttrc = .FALSE. !
+ sn_cfctl%l_oasout = .FALSE. !
+ sn_cfctl%procmin = 0 ! Minimum area number for reporting [default:0]
+ sn_cfctl%procmax = 1000000 ! Maximum area number for reporting [default:1000000]
+ sn_cfctl%procincr = 1 ! Increment for optional subsetting of areas [default:1]
+ sn_cfctl%ptimincr = 1 ! Timestep increment for writing time step progress info
+ nn_ictls = 0 ! start i indice of control sum (use to compare mono versus
+ nn_ictle = 0 ! end i indice of control sum multi processor runs
+ nn_jctls = 0 ! start j indice of control over a subdomain)
+ nn_jctle = 0 ! end j indice of control
+ nn_isplt = 1 ! number of processors in i-direction
+ nn_jsplt = 1 ! number of processors in j-direction
+ ln_timing = .false. ! timing by routine write out in timing.output file
+ ln_diacfl = .false. ! CFL diagnostics write out in cfl_diagnostics.ascii
/
!-----------------------------------------------------------------------
Index: /NEMO/branches/2020/r12377_ticket2386/cfgs/SPITZ12/EXPREF/context_nemo.xml
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/cfgs/SPITZ12/EXPREF/context_nemo.xml (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/cfgs/SPITZ12/EXPREF/context_nemo.xml (revision 13540)
@@ -11,5 +11,5 @@
01
01
- 1026.0
+ 1026.0
3991.86795711963
0.99530670233846
Index: /NEMO/branches/2020/r12377_ticket2386/cfgs/SPITZ12/EXPREF/namelist_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/cfgs/SPITZ12/EXPREF/namelist_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/cfgs/SPITZ12/EXPREF/namelist_cfg (revision 13540)
@@ -205,6 +205,6 @@
!! !!
!! namdrg top/bottom drag coefficient (default: NO selection)
-!! namdrg_top top friction (ln_OFF=F & ln_isfcav=T)
-!! namdrg_bot bottom friction (ln_OFF=F)
+!! 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)
@@ -216,7 +216,8 @@
ln_loglayer = .true. ! logarithmic drag: Cd = vkarmn/log(z/z0) |U|
ln_drgimp = .true. ! implicit top/bottom friction flag
-/
-!-----------------------------------------------------------------------
-&namdrg_bot ! BOTTOM friction (ln_OFF =F)
+ ln_drgice_imp = .true. ! implicit ice-ocean drag
+/
+!-----------------------------------------------------------------------
+&namdrg_bot ! BOTTOM friction (ln_drg_OFF =F)
!-----------------------------------------------------------------------
rn_Cd0 = 2.5e-3 ! drag coefficient [-]
@@ -339,4 +340,19 @@
nn_havtb = 1 ! horizontal shape for avtb (=1) or not (=0)
/
+!-----------------------------------------------------------------------
+&namzdf_tke ! turbulent eddy kinetic dependent vertical diffusion (ln_zdftke =T)
+!-----------------------------------------------------------------------
+ ln_mxl0 = .true. ! surface mixing length scale = F(wind stress) (T) or not (F)
+ nn_mxlice = 0 ! type of scaling under sea-ice
+ ! = 0 no scaling under sea-ice
+ ! = 1 scaling with constant sea-ice thickness
+ ! = 2 scaling with mean sea-ice thickness ( only with SI3 sea-ice model )
+ ! = 3 scaling with maximum sea-ice thickness
+ nn_eice = 0 ! attenutaion of langmuir & surface wave breaking under ice
+ ! ! = 0 no impact of ice cover on langmuir & surface wave breaking
+ ! ! = 1 weigthed by 1-TANH(10*fr_i)
+ ! ! = 2 weighted by 1-fr_i
+ ! ! = 3 weighted by 1-MIN(1,4*fr_i)
+/
!!======================================================================
!! *** Diagnostics namelists *** !!
Index: /NEMO/branches/2020/r12377_ticket2386/cfgs/SPITZ12/EXPREF/namelist_ice_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/cfgs/SPITZ12/EXPREF/namelist_ice_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/cfgs/SPITZ12/EXPREF/namelist_ice_cfg (revision 13540)
@@ -55,4 +55,11 @@
&namsbc ! Ice surface boundary conditions
!------------------------------------------------------------------------------
+ nn_snwfra = 0 ! calculate the fraction of ice covered by snow (for zdf and albedo)
+ ! = 0 fraction = 1 (if snow) or 0 (if no snow)
+ ! = 1 fraction = 1-exp(-0.2*rhos*hsnw) [MetO formulation]
+ ! = 2 fraction = hsnw / (hsnw+0.02) [CICE formulation]
+ nn_qtrice = 0 ! Solar flux transmitted thru the surface scattering layer:
+ ! = 0 Grenfell and Maykut 1977 (depends on cloudiness and is 0 when there is snow)
+ ! = 1 Lebrun 2019 (equals 0.3 anytime with different melting/dry snw conductivities)
/
!------------------------------------------------------------------------------
@@ -81,7 +88,6 @@
&namthd_pnd ! Melt ponds
!------------------------------------------------------------------------------
- ln_pnd = .true. ! activate melt ponds or not
- ln_pnd_H12 = .true. ! activate evolutive melt ponds (from Holland et al 2012)
- ln_pnd_alb = .true. ! melt ponds affect albedo or not
+ ln_pnd = .false. ! activate melt ponds or not
+ ln_pnd_LEV = .false. ! activate level ice melt ponds
/
Index: /NEMO/branches/2020/r12377_ticket2386/cfgs/WED025/EXPREF/context_nemo.xml
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/cfgs/WED025/EXPREF/context_nemo.xml (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/cfgs/WED025/EXPREF/context_nemo.xml (revision 13540)
@@ -9,5 +9,5 @@
1800
- 1026.0
+ 1026.0
3991.86795711963
0.99530670233846
Index: /NEMO/branches/2020/r12377_ticket2386/cfgs/WED025/EXPREF/file_def_nemo-ice.xml
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/cfgs/WED025/EXPREF/file_def_nemo-ice.xml (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/cfgs/WED025/EXPREF/file_def_nemo-ice.xml (revision 13540)
@@ -78,29 +78,4 @@
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
Index: /NEMO/branches/2020/r12377_ticket2386/cfgs/WED025/EXPREF/namelist_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/cfgs/WED025/EXPREF/namelist_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/cfgs/WED025/EXPREF/namelist_cfg (revision 13540)
@@ -5,5 +5,5 @@
!! namelists 2 - Surface boundary (namsbc, namsbc_flx, namsbc_blk, namsbc_cpl,
!! namsbc_sas, namtra_qsr, namsbc_rnf,
-!! namsbc_isf, namsbc_iscpl, namsbc_apr,
+!! namisf, namsbc_apr,
!! namsbc_ssr, namsbc_wave, namberg)
!! 3 - lateral boundary (namlbc, namagrif, nambdy, nambdy_tide)
@@ -38,5 +38,5 @@
nn_it000 = 1 ! first time step
nn_itend = 26280 ! last time step (std 5475)
- nn_date0 = 19760301 ! date at nit_0000 (format yyyymmdd) used if ln_rstart=F or (ln_rstart=T and nn_rstctl=0 or 1)
+ nn_date0 = 20000101 ! date at nit_0000 (format yyyymmdd) used if ln_rstart=F or (ln_rstart=T and nn_rstctl=0 or 1)
ln_rstart = .false. ! start from rest (F) or from a restart file (T)
nn_rstctl = 2 ! restart control ==> activated only if ln_rstart=T
@@ -61,11 +61,11 @@
ln_tsd_init = .true. ! ocean initialisation
ln_tsd_dmp = .false. ! T-S restoring (see namtra_dmp)
-
+
cn_dir = './' ! root directory for the T-S data location
- !___________!_________________________!___________________!___________!_____________!________!___________!__________________!__________!_______________!
- ! ! file name ! frequency (hours) ! variable ! time interp.! clim ! 'yearly'/ ! weights filename ! rotation ! land/sea mask !
- ! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! ! pairing ! filename !
- sn_tem = 'dta_temp_WED025' , -12 , 'votemper', .true. , .true. , 'yearly' , '' , '' , ''
- sn_sal = 'dta_sal_WED025' , -12 , 'vosaline', .true. , .true. , 'yearly' , '' , '' , ''
+ !___________!_____________________!___________________!___________!_____________!________!___________!__________________!__________!_______________!
+ ! ! file name ! frequency (hours) ! variable ! time interp.! clim ! 'yearly'/ ! weights filename ! rotation ! land/sea mask !
+ ! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! ! pairing ! filename !
+ sn_tem = 'WED025_init_JRA_200001.nc', -12 , 'votemper', .false. , .true. , 'yearly' , '' , '' , ''
+ sn_sal = 'WED025_init_JRA_200001.nc', -12 , 'vosaline', .false. , .true. , 'yearly' , '' , '' , ''
/
!-----------------------------------------------------------------------
@@ -116,13 +116,12 @@
ln_blk = .true. ! Bulk formulation (T => fill namsbc_blk )
! Sea-ice :
- nn_ice = 2 ! =0 no ice boundary condition
+ nn_ice = 2 ! =0 no ice boundary condition
! ! =1 use observed ice-cover ( => fill namsbc_iif )
- ! ! =2 or 3 automatically for SI3 or CICE ("key_si3" or "key_cice")
- ! ! except in AGRIF zoom where it has to be specified
+ ! ! =2 or 3 for SI3 and CICE, respectively
ln_ice_embd = .false. ! =T embedded sea-ice (pressure + mass and salt exchanges)
! ! =F levitating ice (no pressure, mass and salt exchanges)
! Misc. options of sbc :
ln_traqsr = .true. ! Light penetration in the ocean (T => fill namtra_qsr)
- ln_dm2dc = .true. ! daily mean to diurnal cycle on short wave
+ ln_dm2dc = .false. ! daily mean to diurnal cycle on short wave
ln_ssr = .false. ! Sea Surface Restoring on T and/or S (T => fill namsbc_ssr)
nn_fwb = 0 ! FreshWater Budget: =0 unchecked
@@ -139,22 +138,22 @@
!-----------------------------------------------------------------------
! ! bulk algorithm :
- ln_NCAR = .true. ! "NCAR" algorithm (Large and Yeager 2008)
+ ln_NCAR = .true. ! "NCAR" algorithm (Large and Yeager 2008)
ln_COARE_3p0 = .false. ! "COARE 3.0" algorithm (Fairall et al. 2003)
- ln_COARE_3p5 = .false. ! "COARE 3.5" algorithm (Edson et al. 2013)
- ln_ECMWF = .false. ! "ECMWF" algorithm (IFS cycle 31)
-
+ ln_COARE_3p6 = .false. ! "COARE 3.6" algorithm (Edson et al. 2013)
+ ln_ECMWF = .false. ! "ECMWF" algorithm (IFS cycle 45r1)
+ !
cn_dir = './' ! root directory for the bulk data location
!___________!_________________________!___________________!___________!_____________!________!___________!______________________________________!__________!_______________!
! ! file name ! frequency (hours) ! variable ! time interp.! clim ! 'yearly'/ ! weights filename ! rotation ! land/sea mask !
! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! ! pairing ! filename !
- sn_wndi = 'u10_core' , 6 , 'U_10_MOD', .true. , .false. , 'yearly' , 'weights_bicubic_core.nc' , 'Uwnd' , ''
- sn_wndj = 'v10_core' , 6 , 'V_10_MOD', .true. , .false. , 'yearly' , 'weights_bicubic_core.nc' , 'Vwnd' , ''
- sn_qsr = 'qsw_core' , 24 , 'SWDN_MOD', .false. , .false. , 'yearly' , 'weights_bilin_core.nc' , '' , ''
- sn_qlw = 'qlw_core' , 24 , 'LWDN_MOD', .false. , .false. , 'yearly' , 'weights_bilin_core.nc' , '' , ''
- sn_tair = 't10_core' , 6 , 'T_10_MOD', .true. , .false. , 'yearly' , 'weights_bilin_core.nc' , '' , ''
- sn_humi = 'q10_core' , 6 , 'Q_10_MOD', .true. , .false. , 'yearly' , 'weights_bilin_core.nc' , '' , ''
- sn_prec = 'precip_core' , -1 , 'TPRECIP', .true. , .false. , 'yearly' , 'weights_bilin_core.nc' , '' , ''
- sn_snow = 'snow_core' , -1 , 'SNOW' , .true. , .false. , 'yearly' , 'weights_bilin_core.nc' , '' , ''
- sn_slp = 'slp_core' , 6 , 'SLP' , .true. , .false. , 'yearly' , 'weights_bilin_core.nc' , '' , ''
+ sn_wndi = 'u10_JRA' , 3 , 'uas_10m' , .true. , .false. , 'yearly' , 'weights_bicubic_JRA.nc' , 'Uwnd' , ''
+ sn_wndj = 'v10_JRA' , 3 , 'vas_10m' , .true. , .false. , 'yearly' , 'weights_bicubic_JRA.nc' , 'Vwnd' , ''
+ sn_qsr = 'rsds_JRA' , 3 , 'rsds' , .true. , .false. , 'yearly' , 'weights_bilin_JRA.nc' , '' , ''
+ sn_qlw = 'rlds_JRA' , 3 , 'rlds' , .true. , .false. , 'yearly' , 'weights_bilin_JRA.nc' , '' , ''
+ sn_tair = 't10_JRA' , 3 , 'tas_10m' , .true. , .false. , 'yearly' , 'weights_bilin_JRA.nc' , '' , ''
+ sn_humi = 'q10_JRA' , 3 , 'huss_10m', .true. , .false. , 'yearly' , 'weights_bilin_JRA.nc' , '' , ''
+ sn_prec = 'precip_JRA' , 3 , 'prto' , .true. , .false. , 'yearly' , 'weights_bilin_JRA.nc' , '' , ''
+ sn_snow = 'snow_JRA' , 3 , 'prsn' , .true. , .false. , 'yearly' , 'weights_bilin_JRA.nc' , '' , ''
+ sn_slp = 'slp_JRA' , 3 , 'psl' , .true. , .false. , 'yearly' , 'weights_bilin_JRA.nc' , '' , ''
/
!-----------------------------------------------------------------------
@@ -201,5 +200,5 @@
! ! file name ! frequency (hours) ! variable ! time interp.! clim ! 'yearly'/ ! weights filename ! rotation ! land/sea mask !
! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! ! pairing ! filename !
- sn_rnf = 'runoff_WED025' , -1 , 'runoff' , .true. , .false., 'yearly' , '' , '' , ''
+ sn_rnf = 'WED025_icb' , -1 , 'runoff' , .true. , .false., 'yearly' , '' , '' , ''
/
!-----------------------------------------------------------------------
@@ -221,13 +220,14 @@
cn_isfcav_mlt = '3eq' ! 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)
+ ! ! 2eq = ISOMIP like: 2 equations formulation (Hunter et al., 2006 for a short description)
+ ! ! 3eq = ISOMIP+ like: 3 equations formulation (Asay-Davis et al., 2016 for a short description)
! ! oasis = fwfisf is given by oasis and pattern by file sn_isfcav_fwf
! ! cn_isfcav_mlt = 2eq or 3eq cases:
cn_gammablk = 'vel' ! 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.4e-2 ! gammat coefficient used in blk formula
- rn_gammas0 = 4.e-4 ! gammas coefficient used in blk formula
+ ! ! spe = constant transfert velocity (rn_gammat0, rn_gammas0)
+ ! ! vel = velocity dependent transfert velocity (u* * gammat/s) (Asay-Davis et al. 2016 for a short description)
+ ! ! vel_stab = velocity and stability dependent transfert coeficient (Holland et al. 1999 for a complete description)
+ rn_gammat0 = 1.4e-2 ! gammat coefficient used in spe, vel and vel_stab gamma computation method
+ rn_gammas0 = 4.0e-4 ! gammas coefficient used in spe, vel and vel_stab gamma computation method
!
rn_htbl = 30. ! thickness of the top boundary layer (Losh et al. 2008)
@@ -255,7 +255,7 @@
sn_isfpar_zmin = 'isfmlt_par', -12. , 'sozisfmin' , .false. , .true. , 'yearly' , '' , '' , ''
!* 'spe' and 'oasis' case
- sn_isfpar_fwf = 'isfmlt_par' , -12. , 'sofwfisf' , .false. , .true. , 'yearly' , '' , '' , ''
+ sn_isfpar_fwf = 'isfmlt_par' , -12. ,'sofwfisf' , .false. , .true. , 'yearly' , '' , '' , ''
!* 'bg03' case
- sn_isfpar_Leff = 'isfmlt_par', 0. , 'Leff' , .false. , .true. , 'yearly' , '' , '' , ''
+ sn_isfpar_Leff = 'isfmlt_par', 0. ,'Leff' , .false. , .true. , 'yearly' , '' , '' , ''
!
! ---------------- ice sheet coupling -------------------------------
@@ -300,8 +300,8 @@
ln_tide = .true. ! Activate tides
ln_tide_pot = .false. ! use tidal potential forcing
- clname(1) = 'M2' ! name of constituent - all tidal components must be set in namelist_cfg
- clname(2) = 'S2'
- clname(3) = 'K1'
- clname(4) = 'O1'
+ sn_tide_cnames(1) = 'M2' ! name of constituent - all tidal components must be set in namelist_cfg
+ sn_tide_cnames(2) = 'S2'
+ sn_tide_cnames(3) = 'K1'
+ sn_tide_cnames(4) = 'O1'
/
!-----------------------------------------------------------------------
@@ -340,20 +340,20 @@
! ! file name ! frequency (hours) ! variable ! time interp.! clim ! 'yearly'/ ! weights filename ! rotation ! land/sea mask !
! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! ! pairing ! filename !
- bn_ssh = 'bdyT_ssh_WED025' , -1 , 'sossheig' , .true. , .false., 'yearly' , '' , '' , ''
- bn_u2d = 'bdyU_u2d_WED025' , -1 , 'vobtcrtx' , .true. , .false., 'yearly' , '' , '' , ''
- bn_v2d = 'bdyV_u2d_WED025' , -1 , 'vobtcrty' , .true. , .false., 'yearly' , '' , '' , ''
- bn_u3d = 'bdyU_u3d_WED025' , -1 , 'vozocrtx' , .true. , .false., 'yearly' , '' , '' , ''
- bn_v3d = 'bdyV_u3d_WED025' , -1 , 'vomecrty' , .true. , .false., 'yearly' , '' , '' , ''
- bn_tem = 'bdyT_tra_WED025' , -1 , 'votemper' , .true. , .false., 'yearly' , '' , '' , ''
- bn_sal = 'bdyT_tra_WED025' , -1 , 'vosaline' , .true. , .false., 'yearly' , '' , '' , ''
+ bn_ssh = 'WED025_bdyT_ssh' , -1 , 'sossheig' , .true. , .false., 'yearly' , '' , '' , ''
+ bn_u2d = 'WED025_bdyU_u2d' , -1 , 'vobtcrtx' , .true. , .false., 'yearly' , '' , '' , ''
+ bn_v2d = 'WED025_bdyV_u2d' , -1 , 'vobtcrty' , .true. , .false., 'yearly' , '' , '' , ''
+ bn_u3d = 'WED025_bdyU_u3d' , -1 , 'vozocrtx' , .true. , .false., 'yearly' , '' , '' , ''
+ bn_v3d = 'WED025_bdyV_u3d' , -1 , 'vomecrty' , .true. , .false., 'yearly' , '' , '' , ''
+ bn_tem = 'WED025_bdyT_tra' , -1 , 'votemper' , .true. , .false., 'yearly' , '' , '' , ''
+ bn_sal = 'WED025_bdyT_tra' , -1 , 'vosaline' , .true. , .false., 'yearly' , '' , '' , ''
!* for si3
- bn_a_i = 'bdyT_ice_WED025' , -1 , 'ileadfra' , .true. , .false., 'yearly' , '' , '' , ''
- bn_h_i = 'bdyT_ice_WED025' , -1 , 'iicethic' , .true. , .false., 'yearly' , '' , '' , ''
- bn_h_s = 'bdyT_ice_WED025' , -1 , 'isnowthi' , .true. , .false., 'yearly' , '' , '' , ''
+ bn_a_i = 'WED025_bdyT_ice' , -1 , 'ileadfra' , .true. , .false., 'yearly' , '' , '' , ''
+ bn_h_i = 'WED025_bdyT_ice' , -1 , 'iicethic' , .true. , .false., 'yearly' , '' , '' , ''
+ bn_h_s = 'WED025_bdyT_ice' , -1 , 'isnowthi' , .true. , .false., 'yearly' , '' , '' , ''
/
!-----------------------------------------------------------------------
&nambdy_tide ! tidal forcing at open boundaries (default: OFF)
!-----------------------------------------------------------------------
- filtide = 'bdytide_WED025_' ! file name root of tidal forcing files
+ filtide = 'WED025_bdytide_' ! file name root of tidal forcing files
/
@@ -362,6 +362,6 @@
!! !!
!! namdrg top/bottom drag coefficient (default: NO selection)
-!! namdrg_top top friction (ln_OFF=F & ln_isfcav=T)
-!! namdrg_bot bottom friction (ln_OFF=F)
+!! 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)
@@ -374,10 +374,10 @@
/
!-----------------------------------------------------------------------
-&namdrg_top ! TOP friction (ln_OFF =F & ln_isfcav=T)
+&namdrg_top ! TOP friction (ln_drg_OFF =F & ln_isfcav=T)
!-----------------------------------------------------------------------
rn_Cd0 = 2.5e-3 ! drag coefficient [-]
/
!-----------------------------------------------------------------------
-&namdrg_bot ! BOTTOM friction (ln_OFF =F)
+&namdrg_bot ! BOTTOM friction (ln_drg_OFF =F)
!-----------------------------------------------------------------------
rn_Cd0 = 2.5e-3 ! drag coefficient [-]
@@ -658,25 +658,6 @@
&namctl ! Control prints (default: OFF)
!-----------------------------------------------------------------------
- ln_ctl = .FALSE. ! Toggle all report printing on/off (T/F); Ignored if sn_cfctl%l_config is T
- sn_cfctl%l_config = .TRUE. ! IF .true. then control which reports are written with the following
- sn_cfctl%l_runstat = .FALSE. ! switches and which areas produce reports with the proc integer settings.
- sn_cfctl%l_trcstat = .FALSE. ! The default settings for the proc integers should ensure
- sn_cfctl%l_oceout = .FALSE. ! that all areas report.
- sn_cfctl%l_layout = .FALSE. !
- sn_cfctl%l_mppout = .FALSE. !
- sn_cfctl%l_mpptop = .FALSE. !
- sn_cfctl%procmin = 0 ! Minimum area number for reporting [default:0]
- sn_cfctl%procmax = 1000000 ! Maximum area number for reporting [default:1000000]
- sn_cfctl%procincr = 1 ! Increment for optional subsetting of areas [default:1]
- sn_cfctl%ptimincr = 1 ! Timestep increment for writing time step progress info
- nn_print = 0 ! level of print (0 no extra print)
- nn_ictls = 0 ! start i indice of control sum (use to compare mono versus
- nn_ictle = 0 ! end i indice of control sum multi processor runs
- nn_jctls = 0 ! start j indice of control over a subdomain)
- nn_jctle = 0 ! end j indice of control
- nn_isplt = 1 ! number of processors in i-direction
- nn_jsplt = 1 ! number of processors in j-direction
- ln_timing = .true. ! timing by routine write out in timing.output file
- ln_diacfl = .false. ! CFL diagnostics write out in cfl_diagnostics.ascii
+ sn_cfctl%l_runstat = .true. ! switches and which areas produce reports with the proc integer settings.
+ ln_timing = .true. ! timing by routine write out in timing.output file
/
!-----------------------------------------------------------------------
Index: /NEMO/branches/2020/r12377_ticket2386/cfgs/WED025/EXPREF/namelist_ice_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/cfgs/WED025/EXPREF/namelist_ice_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/cfgs/WED025/EXPREF/namelist_ice_cfg (revision 13540)
@@ -26,8 +26,12 @@
&namitd ! Ice discretization
!------------------------------------------------------------------------------
+ ln_cat_hfn = .true. ! ice categories are defined by a function following rn_himean**(-0.05)
+ rn_himean = 2.0 ! expected domain-average ice thickness (m)
+ rn_himin = 0.01 ! minimum ice thickness (m) used in remapping
/
!------------------------------------------------------------------------------
&namdyn ! Ice dynamics
!------------------------------------------------------------------------------
+ ln_landfast_L16 = .true. ! landfast: parameterization from Lemieux 2016
/
!------------------------------------------------------------------------------
@@ -38,12 +42,24 @@
&namdyn_rhg ! Ice rheology
!------------------------------------------------------------------------------
+ ln_rhg_EVP = .true. ! EVP rheology
+ ln_aEVP = .false. ! adaptive rheology (Kimmritz et al. 2016 & 2017)
/
!------------------------------------------------------------------------------
&namdyn_adv ! Ice advection
!------------------------------------------------------------------------------
+ ln_adv_Pra = .false. ! Advection scheme (Prather)
+ ln_adv_UMx = .true. ! Advection scheme (Ultimate-Macho)
+ nn_UMx = 5 ! order of the scheme for UMx (1-5 ; 20=centered 2nd order)
/
!------------------------------------------------------------------------------
&namsbc ! Ice surface boundary conditions
!------------------------------------------------------------------------------
+ nn_snwfra = 0 ! calculate the fraction of ice covered by snow (for zdf and albedo)
+ ! = 0 fraction = 1 (if snow) or 0 (if no snow)
+ ! = 1 fraction = 1-exp(-0.2*rhos*hsnw) [MetO formulation]
+ ! = 2 fraction = hsnw / (hsnw+0.02) [CICE formulation]
+ nn_qtrice = 0 ! Solar flux transmitted thru the surface scattering layer:
+ ! = 0 Grenfell and Maykut 1977 (depends on cloudiness and is 0 when there is snow)
+ ! = 1 Lebrun 2019 (equals 0.3 anytime with different melting/dry snw conductivities)
/
!------------------------------------------------------------------------------
@@ -62,4 +78,6 @@
&namthd_do ! Ice growth in open water
!------------------------------------------------------------------------------
+ rn_hinew = 0.02 ! thickness for new ice formation in open water (m), must be larger than rn_himin
+ ln_frazil = .true. ! Frazil ice parameterization (ice collection as a function of wind)
/
!------------------------------------------------------------------------------
@@ -70,8 +88,27 @@
&namthd_pnd ! Melt ponds
!------------------------------------------------------------------------------
+ ln_pnd = .false. ! activate melt ponds or not
+ ln_pnd_LEV = .false. ! level ice melt ponds (from Flocco et al 2007,2010 & Holland et al 2012)
/
!------------------------------------------------------------------------------
&namini ! Ice initialization
!------------------------------------------------------------------------------
+ ln_iceini = .true. ! activate ice initialization (T) or not (F)
+ nn_iceini_file = 1 ! 0 = Initialise sea ice based on SSTs
+ ! 1 = Initialise sea ice from single category netcdf file
+ ! 2 = Initialise sea ice from multi category restart file
+ ! -- for ln_iceini_file = T
+ sn_hti = 'WED025_init_JRA_200001.nc', -12. ,'icethic_cea', .false. , .true., 'yearly' , '' , '', ''
+ sn_hts = 'WED025_init_JRA_200001.nc', -12. ,'icesnow_cea', .false. , .true., 'yearly' , '' , '', ''
+ sn_ati = 'WED025_init_JRA_200001.nc', -12. ,'ice_cover' , .false. , .true., 'yearly' , '' , '', ''
+ sn_smi = 'NOT USED' , -12. ,'smi' , .false. , .true., 'yearly' , '' , '', ''
+ sn_tmi = 'NOT USED' , -12. ,'tmi' , .false. , .true., 'yearly' , '' , '', ''
+ sn_tsu = 'NOT USED' , -12. ,'tsu' , .false. , .true., 'yearly' , '' , '', ''
+ sn_tms = 'NOT USED' , -12. ,'tms' , .false. , .true., 'yearly' , '' , '', ''
+ ! melt ponds (be careful, sn_apd is the pond concentration (not fraction), so it differs from rn_apd)
+ sn_apd = 'NOT USED' , -12. ,'apd' , .false. , .true., 'yearly' , '' , '', ''
+ sn_hpd = 'NOT USED' , -12. ,'hpd' , .false. , .true., 'yearly' , '' , '', ''
+ sn_hld = 'NOT USED' , -12. ,'hld' , .false. , .true., 'yearly' , '' , '', ''
+ cn_dir='./'
/
!------------------------------------------------------------------------------
Index: /NEMO/branches/2020/r12377_ticket2386/cfgs/ref_cfgs.txt
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/cfgs/ref_cfgs.txt (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/cfgs/ref_cfgs.txt (revision 13540)
@@ -7,11 +7,6 @@
ORCA2_OFF_TRC OCE TOP OFF
ORCA2_SAS_ICE OCE ICE NST SAS
-ORCA2_ICE_PISCES OCE TOP ICE NST
+ORCA2_ICE_PISCES OCE TOP ICE NST ABL
ORCA2_ICE_ABL OCE ICE ABL
-ORCA2_SAS_ICE_ABL OCE SAS ICE ABL
-ORCA2_ICE OCE ICE
SPITZ12 OCE ICE
WED025 OCE ICE
-eORCA025_ICE OCE ICE
-eORCA025_ICE_ABL OCE ICE ABL
-eORCA025_SAS_ICE_ABL OCE SAS ICE ABL
Index: /NEMO/branches/2020/r12377_ticket2386/doc/NEMO_manual_state.txt
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/doc/NEMO_manual_state.txt (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/doc/NEMO_manual_state.txt (revision 13540)
@@ -39,5 +39,5 @@
namdia: iiceprt jiceprt
nam_diaharm: nit000_han nitend_han nstep_han tname(1) tname(2)
- namdrg: ln_OFF
+ namdrg: ln_drg_OFF
namdrg_bot: rn_Cd0 rn_Uc0 rn_Cdmax
namdrg_top: rn_Cd0 rn_Uc0 rn_Cdmax
Index: /NEMO/branches/2020/r12377_ticket2386/doc/latex/NEMO/subfiles/chap_SBC.tex
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/doc/latex/NEMO/subfiles/chap_SBC.tex (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/doc/latex/NEMO/subfiles/chap_SBC.tex (revision 13540)
@@ -832,5 +832,5 @@
Solid precipitation & snow & $Kg.m^{-2}.s^{-1}$ & T \\
\hline
- Mean sea-level pressure & slp & $hPa$ & T \\
+ Mean sea-level pressure & slp & $Pa$ & T \\
\hline
\end{tabular}
Index: /NEMO/branches/2020/r12377_ticket2386/doc/latex/NEMO/subfiles/chap_TRA.tex
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/doc/latex/NEMO/subfiles/chap_TRA.tex (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/doc/latex/NEMO/subfiles/chap_TRA.tex (revision 13540)
@@ -1229,5 +1229,5 @@
In the computer code, a density anomaly, $d_a = \rho / \rho_o - 1$, is computed,
with $\rho_o$ a reference density.
-Called \textit{rau0} in the code,
+Called \textit{rho0} in the code,
$\rho_o$ is set in \mdl{phycst} to a value of \texttt{1,026} $Kg/m^3$.
This is a sensible choice for the reference density used in a Boussinesq ocean climate model,
Index: /NEMO/branches/2020/r12377_ticket2386/doc/latex/NEMO/subfiles/chap_ZDF.tex
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/doc/latex/NEMO/subfiles/chap_ZDF.tex (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/doc/latex/NEMO/subfiles/chap_ZDF.tex (revision 13540)
@@ -1160,5 +1160,5 @@
\]
When \np[=.true.]{ln_lin}{ln\_lin}, the value of $r$ used is \np{rn_Uc0}{rn\_Uc0}*\np{rn_Cd0}{rn\_Cd0}.
-Setting \np[=.true.]{ln_OFF}{ln\_OFF} (and \forcode{ln_lin=.true.}) is equivalent to setting $r=0$ and leads to a free-slip boundary condition.
+Setting \np[=.true.]{ln_drg_OFF}{ln\_OFF} (and \forcode{ln_lin=.true.}) is equivalent to setting $r=0$ and leads to a free-slip boundary condition.
These values are assigned in \mdl{zdfdrg}.
Index: /NEMO/branches/2020/r12377_ticket2386/doc/namelists/nambdy_dta
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/doc/namelists/nambdy_dta (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/doc/namelists/nambdy_dta (revision 13540)
@@ -29,4 +29,5 @@
bn_aip = 'NOT USED' , 24. , 'siapnd' , .true. , .false., 'daily' , '' , '' , ''
bn_hip = 'NOT USED' , 24. , 'sihpnd' , .true. , .false., 'daily' , '' , '' , ''
+ bn_hil = 'NOT USED' , 24. , 'sihlid' , .true. , .false., 'daily' , '' , '' , ''
! if bn_t_i etc are "not used", then define arbitrary temperatures and salinity and ponds
rn_ice_tem = 270. ! arbitrary temperature of incoming sea ice
@@ -35,3 +36,4 @@
rn_ice_apnd = 0.2 ! -- pond fraction = a_ip/a_i --
rn_ice_hpnd = 0.05 ! -- pond depth --
+ rn_ice_hlid = 0.0 ! -- pond lid depth --
/
Index: /NEMO/branches/2020/r12377_ticket2386/doc/namelists/namdia
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/doc/namelists/namdia (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/doc/namelists/namdia (revision 13540)
@@ -8,5 +8,5 @@
ln_icediahsb = .false. ! output the heat, mass & salt budgets (T) or not (F)
ln_icectl = .false. ! ice points output for debug (T or F)
- iiceprt = 10 ! i-index for debug
- jiceprt = 10 ! j-index for debug
+ iiceprt = 10 ! i-index for debug
+ jiceprt = 10 ! j-index for debug
/
Index: /NEMO/branches/2020/r12377_ticket2386/doc/namelists/namdrg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/doc/namelists/namdrg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/doc/namelists/namdrg (revision 13540)
@@ -2,5 +2,5 @@
&namdrg ! top/bottom drag coefficient (default: NO selection)
!-----------------------------------------------------------------------
- ln_OFF = .false. ! free-slip : Cd = 0 (F => fill namdrg_bot
+ 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 = .false. ! non-linear drag: Cd = Cd0 |U|
@@ -8,3 +8,4 @@
!
ln_drgimp = .true. ! implicit top/bottom friction flag
+ ln_drgice_imp = .false. ! implicit ice-ocean drag
/
Index: /NEMO/branches/2020/r12377_ticket2386/doc/namelists/namdrg_bot
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/doc/namelists/namdrg_bot (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/doc/namelists/namdrg_bot (revision 13540)
@@ -1,4 +1,4 @@
!-----------------------------------------------------------------------
-&namdrg_bot ! BOTTOM friction (ln_OFF =F)
+&namdrg_bot ! BOTTOM friction (ln_drg_OFF =F)
!-----------------------------------------------------------------------
rn_Cd0 = 1.e-3 ! drag coefficient [-]
Index: /NEMO/branches/2020/r12377_ticket2386/doc/namelists/namdrg_top
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/doc/namelists/namdrg_top (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/doc/namelists/namdrg_top (revision 13540)
@@ -1,4 +1,4 @@
!-----------------------------------------------------------------------
-&namdrg_top ! TOP friction (ln_OFF =F & ln_isfcav=T)
+&namdrg_top ! TOP friction (ln_drg_OFF =F & ln_isfcav=T)
!-----------------------------------------------------------------------
rn_Cd0 = 1.e-3 ! drag coefficient [-]
Index: /NEMO/branches/2020/r12377_ticket2386/doc/namelists/namdyn
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/doc/namelists/namdyn (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/doc/namelists/namdyn (revision 13540)
@@ -10,8 +10,8 @@
rn_ishlat = 2. ! lbc : free slip (0) ; partial slip (0-2) ; no slip (2) ; strong slip (>2)
ln_landfast_L16 = .false. ! landfast: parameterization from Lemieux 2016
- rn_depfra = 0.125 ! fraction of ocean depth that ice must reach to initiate landfast
+ rn_lf_depfra = 0.125 ! fraction of ocean depth that ice must reach to initiate landfast
! recommended range: [0.1 ; 0.25]
- rn_icebfr = 15. ! maximum bottom stress per unit volume [N/m3]
- rn_lfrelax = 1.e-5 ! relaxation time scale to reach static friction [s-1]
- rn_tensile = 0.05 ! isotropic tensile strength [0-0.5??]
+ rn_lf_bfr = 15. ! maximum bottom stress per unit volume [N/m3]
+ rn_lf_relax = 1.e-5 ! relaxation time scale to reach static friction [s-1]
+ rn_lf_tensile = 0.05 ! isotropic tensile strength [0-0.5??]
/
Index: /NEMO/branches/2020/r12377_ticket2386/doc/namelists/namdyn_rhg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/doc/namelists/namdyn_rhg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/doc/namelists/namdyn_rhg (revision 13540)
@@ -9,3 +9,4 @@
rn_relast = 0.333 ! ratio of elastic timescale to ice time step: Telast = dt_ice * rn_relast
! advised value: 1/3 (rn_nevp=120) or 1/9 (rn_nevp=300)
+ ln_rhg_chkcvg = .false. ! check convergence of rheology (outputs: file ice_cvg.nc & variable uice_cvg)
/
Index: /NEMO/branches/2020/r12377_ticket2386/doc/namelists/nameos
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/doc/namelists/nameos (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/doc/namelists/nameos (revision 13540)
@@ -7,5 +7,5 @@
!
! ! S-EOS coefficients (ln_seos=T):
- ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
+ ! ! rd(T,S,Z)*rho0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
rn_a0 = 1.6550e-1 ! thermal expension coefficient
rn_b0 = 7.6554e-1 ! saline expension coefficient
Index: /NEMO/branches/2020/r12377_ticket2386/doc/namelists/namini
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/doc/namelists/namini (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/doc/namelists/namini (revision 13540)
@@ -3,5 +3,7 @@
!------------------------------------------------------------------------------
ln_iceini = .true. ! activate ice initialization (T) or not (F)
- ln_iceini_file = .false. ! netcdf file provided for initialization (T) or not (F)
+ nn_iceini_file = 0 ! 0 = Initialise sea ice based on SSTs
+ ! 1 = Initialise sea ice from single category netcdf file
+ ! 2 = Initialise sea ice from multi category restart file
rn_thres_sst = 2.0 ! max temp. above Tfreeze with initial ice = (sst - tfreeze)
rn_hti_ini_n = 3.0 ! initial ice thickness (m), North
@@ -23,5 +25,7 @@
rn_hpd_ini_n = 0.05 ! initial pond depth (m), North
rn_hpd_ini_s = 0.05 ! " " South
- ! -- for ln_iceini_file = T
+ rn_hld_ini_n = 0.0 ! initial pond lid depth (m), North
+ rn_hld_ini_s = 0.0 ! " " South
+ ! -- for nn_iceini_file = 1
sn_hti = 'Ice_initialization' , -12 ,'hti' , .false. , .true., 'yearly' , '' , '', ''
sn_hts = 'Ice_initialization' , -12 ,'hts' , .false. , .true., 'yearly' , '' , '', ''
@@ -34,4 +38,5 @@
sn_apd = 'NOT USED' , -12 ,'apd' , .false. , .true., 'yearly' , '' , '', ''
sn_hpd = 'NOT USED' , -12 ,'hpd' , .false. , .true., 'yearly' , '' , '', ''
+ sn_hld = 'NOT USED' , -12 ,'hld' , .false. , .true., 'yearly' , '' , '', ''
cn_dir='./'
/
Index: /NEMO/branches/2020/r12377_ticket2386/doc/namelists/namsbc_blk
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/doc/namelists/namsbc_blk (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/doc/namelists/namsbc_blk (revision 13540)
@@ -35,8 +35,11 @@
sn_tair = 't_10.15JUNE2009_fill' , 6. , 'T_10_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
sn_humi = 'q_10.15JUNE2009_fill' , 6. , 'Q_10_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
- sn_hpgi = 'NONE' , 24. , 'uhpg' , .false. , .false., 'monthly' , 'weights_ERAI3D_F128_2_ORCA2_bicubic', 'UG' , ''
- sn_hpgj = 'NONE' , 24. , 'vhpg' , .false. , .false., 'monthly' , 'weights_ERAI3D_F128_2_ORCA2_bicubic', 'VG' , ''
sn_prec = 'ncar_precip.15JUNE2009_fill', -1. , 'PRC_MOD1', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
sn_snow = 'ncar_precip.15JUNE2009_fill', -1. , 'SNOW' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
sn_slp = 'slp.15JUNE2009_fill' , 6. , 'SLP' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
+ sn_uoatm = 'NOT USED' , 6. , 'UOATM' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , 'Uoceatm', ''
+ sn_voatm = 'NOT USED' , 6. , 'VOATM' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , 'Voceatm', ''
+ sn_cc = 'NOT USED' , 24. , 'CC' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
+ sn_hpgi = 'NOT USED' , 24. , 'uhpg' , .false. , .false., 'monthly' , 'weights_ERAI3D_F128_2_ORCA2_bicubic', 'UG' , ''
+ sn_hpgj = 'NOT USED' , 24. , 'vhpg' , .false. , .false., 'monthly' , 'weights_ERAI3D_F128_2_ORCA2_bicubic', 'VG' , ''
/
Index: /NEMO/branches/2020/r12377_ticket2386/doc/namelists/namsbc_cpl
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/doc/namelists/namsbc_cpl (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/doc/namelists/namsbc_cpl (revision 13540)
@@ -2,9 +2,9 @@
&namsbc_cpl ! coupled ocean/atmosphere model ("key_oasis3")
!-----------------------------------------------------------------------
- nn_cplmodel = 1 ! Maximum number of models to/from which NEMO is potentially sending/receiving data
- ln_usecplmask = .false. ! 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)
- nn_cats_cpl = 5 ! Number of sea ice categories over which coupling is to be carried out (if not 1)
-
+ nn_cplmodel = 1 ! Maximum number of models to/from which NEMO is potentially sending/receiving data
+ ln_usecplmask = .false. ! 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)
+ ln_scale_ice_flux = .false. ! use ice fluxes that are already "ice weighted" ( i.e. multiplied ice concentration)
+ nn_cats_cpl = 5 ! Number of sea ice categories over which coupling is to be carried out (if not 1)
!_____________!__________________________!____________!_____________!______________________!________!
! ! description ! multiple ! vector ! vector ! vector !
Index: /NEMO/branches/2020/r12377_ticket2386/doc/namelists/namthd
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/doc/namelists/namthd (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/doc/namelists/namthd (revision 13540)
@@ -6,3 +6,5 @@
ln_icedO = .true. ! activate ice growth in open-water (T) or not (F)
ln_icedS = .true. ! activate brine drainage (T) or not (F)
+ !
+ ln_leadhfx = .true. ! heat in the leads is used to melt sea-ice before warming the ocean
/
Index: /NEMO/branches/2020/r12377_ticket2386/doc/namelists/namthd_pnd
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/doc/namelists/namthd_pnd (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/doc/namelists/namthd_pnd (revision 13540)
@@ -2,9 +2,12 @@
&namthd_pnd ! Melt ponds
!------------------------------------------------------------------------------
- ln_pnd = .false. ! activate melt ponds or not
- ln_pnd_H12 = .false. ! activate evolutive melt ponds (from Holland et al 2012)
- ln_pnd_CST = .false. ! activate constant melt ponds
- rn_apnd = 0.2 ! prescribed pond fraction, at Tsu=0 degC
- rn_hpnd = 0.05 ! prescribed pond depth, at Tsu=0 degC
- ln_pnd_alb = .false. ! melt ponds affect albedo or not
+ ln_pnd = .false. ! activate melt ponds or not
+ ln_pnd_LEV = .false. ! level ice melt ponds (from Flocco et al 2007,2010 & Holland et al 2012)
+ rn_apnd_min = 0.15 ! minimum ice fraction that contributes to melt pond. range: 0.0 -- 0.15 ??
+ rn_apnd_max = 0.85 ! maximum ice fraction that contributes to melt pond. range: 0.7 -- 0.85 ??
+ ln_pnd_CST = .false. ! constant melt ponds
+ rn_apnd = 0.2 ! prescribed pond fraction, at Tsu=0 degC
+ rn_hpnd = 0.05 ! prescribed pond depth, at Tsu=0 degC
+ ln_pnd_lids = .true. ! frozen lids on top of the ponds (only for ln_pnd_LEV)
+ ln_pnd_alb = .true. ! effect of melt ponds on ice albedo
/
Index: /NEMO/branches/2020/r12377_ticket2386/doc/namelists/namthd_zdf
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/doc/namelists/namthd_zdf (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/doc/namelists/namthd_zdf (revision 13540)
@@ -7,4 +7,8 @@
rn_cnd_s = 0.31 ! thermal conductivity of the snow (0.31 W/m/K, Maykut and Untersteiner, 1971)
! Obs: 0.1-0.5 (Lecomte et al, JAMES 2013)
- rn_kappa_i = 1.0 ! radiation attenuation coefficient in sea ice [1/m]
+ rn_kappa_i = 1.0 ! radiation attenuation coefficient in sea ice [1/m]
+ rn_kappa_s = 10.0 ! nn_qtrice = 0: radiation attenuation coefficient in snow [1/m]
+ rn_kappa_smlt = 7.0 ! nn_qtrice = 1: radiation attenuation coefficient in melting snow [1/m]
+ rn_kappa_sdry = 10.0 ! radiation attenuation coefficient in dry snow [1/m]
+ ln_zdf_chkcvg = .false. ! check convergence of heat diffusion scheme (output variable: tice_cvg)
/
Index: /NEMO/branches/2020/r12377_ticket2386/doc/namelists/namzdf_gls
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/doc/namelists/namzdf_gls (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/doc/namelists/namzdf_gls (revision 13540)
@@ -13,4 +13,9 @@
nn_z0_met = 2 ! Method for surface roughness computation (0/1/2/3)
! ! =3 requires ln_wave=T
+ nn_z0_ice = 1 ! attenutaion of surface wave breaking under ice
+ ! ! = 0 no impact of ice cover
+ ! ! = 1 roughness uses rn_hsri and is weigthed by 1-TANH(10*fr_i)
+ ! ! = 2 roughness uses rn_hsri and is weighted by 1-fr_i
+ ! ! = 3 roughness uses rn_hsri and is weighted by 1-MIN(1,4*fr_i)
nn_bc_surf = 1 ! surface condition (0/1=Dir/Neum)
nn_bc_bot = 1 ! bottom condition (0/1=Dir/Neum)
Index: /NEMO/branches/2020/r12377_ticket2386/doc/namelists/namzdf_tke
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/doc/namelists/namzdf_tke (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/doc/namelists/namzdf_tke (revision 13540)
@@ -15,5 +15,4 @@
ln_mxl0 = .true. ! surface mixing length scale = F(wind stress) (T) or not (F)
rn_mxl0 = 0.04 ! surface buoyancy lenght scale minimum value
- ln_drg = .false. ! top/bottom friction added as boundary condition of TKE
ln_lc = .true. ! Langmuir cell parameterisation (Axell 2002)
rn_lc = 0.15 ! coef. associated to Langmuir cells
@@ -26,4 +25,8 @@
! = 0 constant 10 m length scale
! = 1 0.5m at the equator to 30m poleward of 40 degrees
- rn_eice = 4 ! below sea ice: =0 ON ; =4 OFF when ice fraction > 1/4
+ nn_eice = 1 ! attenutaion of langmuir & surface wave breaking under ice
+ ! ! = 0 no impact of ice cover on langmuir & surface wave breaking
+ ! ! = 1 weigthed by 1-TANH(10*fr_i)
+ ! ! = 2 weighted by 1-fr_i
+ ! ! = 3 weighted by 1-MIN(1,4*fr_i)
/
Index: /NEMO/branches/2020/r12377_ticket2386/doc/rst/source/cite.rst
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/doc/rst/source/cite.rst (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/doc/rst/source/cite.rst (revision 13540)
@@ -25,7 +25,6 @@
Scientific Notes of Climate Modelling Center, 31,
ISSN 1288-1619 Institut Pierre-Simon Laplace (IPSL),
- :doi:`10.5281/zenodo.1471689`
+ :doi:`10.5281/zenodo.1464816`
-.. warning:: No official publication yet
.. literalinclude:: ref.bib
@@ -34,12 +33,12 @@
:caption: BibTeX source for SI\ :sup:`3` manual
-|NEMO-MBG|
+|NEMO-TOP|
:title:`Tracer in Ocean Paradigm (TOP) -- The NEMO passive tracer engine`,
NEMO TOP Working Group,
Scientific Notes of Climate Modelling Center, 28,
ISSN 1288-1619 Institut Pierre-Simon Laplace (IPSL),
- :doi:`10.5281/zenodo.1471700`
+ :doi:`10.5281/zenodo.1464816`
-.. warning:: No official publication yet
+
.. literalinclude:: ref.bib
Index: /NEMO/branches/2020/r12377_ticket2386/doc/rst/source/guide.rst
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/doc/rst/source/guide.rst (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/doc/rst/source/guide.rst (revision 13540)
@@ -16,6 +16,5 @@
.. toctree::
:hidden:
-
- todos
+.. todos::
.. Only displayed with 'make drafthtml'
Index: /NEMO/branches/2020/r12377_ticket2386/src/ABL/abl.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/ABL/abl.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/ABL/abl.F90 (revision 13540)
@@ -29,5 +29,6 @@
REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: avm_abl !: turbulent viscosity [m2/s]
REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: avt_abl !: turbulent diffusivity [m2/s]
- REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: mxl_abl !: mixing length [m]
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: mxld_abl !: dissipative mixing length [m]
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: mxlm_abl !: master mixing length [m]
REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:,:) :: tke_abl !: turbulent kinetic energy [m2/s2]
REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: fft_abl !: Coriolis parameter [1/s]
@@ -55,16 +56,18 @@
!!----------------------------------------------------------------------
!
- 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), &
- & avm_abl(1:jpi,1:jpj,1:jpka), &
- & avt_abl(1:jpi,1:jpj,1:jpka), &
- & mxl_abl(1:jpi,1:jpj,1:jpka), &
- & tke_abl(1:jpi,1:jpj,1:jpka,jptime), &
- & fft_abl(1:jpi,1:jpj), &
- & pblh (1:jpi,1:jpj), &
- & msk_abl(1:jpi,1:jpj), &
- & rest_eq(1:jpi,1:jpj), &
- & e3t_abl(1:jpka), e3w_abl(1:jpka), ght_abl(1:jpka), ghw_abl(1:jpka), STAT=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 ), &
+ & e3t_abl (1:jpka), e3w_abl(1:jpka) , &
+ & ght_abl (1:jpka), ghw_abl(1:jpka) , STAT=ierr )
!
abl_alloc = ierr
Index: /NEMO/branches/2020/r12377_ticket2386/src/ABL/ablmod.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/ABL/ablmod.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/ABL/ablmod.F90 (revision 13540)
@@ -2,10 +2,10 @@
!!======================================================================
!! *** MODULE ablmod ***
- !! Surface module : ABL computation to provide atmospheric data
+ !! Surface module : ABL computation to provide atmospheric data
!! for surface fluxes computation
!!======================================================================
!! History : 3.6 ! 2019-03 (F. Lemarié & G. Samson) Original code
!!----------------------------------------------------------------------
-
+
!!----------------------------------------------------------------------
!! abl_stp : ABL single column model
@@ -16,7 +16,7 @@
USE phycst ! physical constants
- USE dom_oce, ONLY : tmask
+ USE dom_oce, ONLY : tmask
USE sbc_oce, ONLY : ght_abl, ghw_abl, e3t_abl, e3w_abl, jpka, jpkam1, rhoa
- USE sbcblk ! use rn_?fac
+ USE sbcblk ! use rn_efac, cdn_oce
USE sbcblk_phy ! use some physical constants for flux computation
!
@@ -30,5 +30,5 @@
PUBLIC abl_stp ! called by sbcabl.F90
- REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ustar2
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ustar2, zrough
!! * Substitutions
# include "do_loop_substitute.h90"
@@ -38,15 +38,16 @@
!===================================================================================================
- SUBROUTINE abl_stp( kt, psst, pssu, pssv, pssq, & ! in
- & pu_dta, pv_dta, pt_dta, pq_dta, &
+ SUBROUTINE abl_stp( kt, psst, pssu, pssv, pssq, & ! in
+ & pu_dta, pv_dta, pt_dta, pq_dta, &
& pslp_dta, pgu_dta, pgv_dta, &
- & pcd_du, psen, pevp, & ! in/out
- & pwndm, ptaui, ptauj, ptaum &
-#if defined key_si3
- & , ptm_su,pssu_ice,pssv_ice,pssq_ice,pcd_du_ice &
- & , psen_ice, pevp_ice, pwndm_ice, pfrac_oce &
- & , ptaui_ice, ptauj_ice &
-#endif
- & )
+ & pcd_du, psen, pevp, & ! in/out
+ & pwndm, ptaui, ptauj, ptaum &
+#if defined key_si3
+ & , ptm_su, pssu_ice, pssv_ice &
+ & , pssq_ice, pcd_du_ice, psen_ice &
+ & , pevp_ice, pwndm_ice, pfrac_oce &
+ & , ptaui_ice, ptauj_ice &
+#endif
+ & )
!---------------------------------------------------------------------------------------------------
@@ -54,9 +55,9 @@
!! *** ROUTINE abl_stp ***
!!
- !! ** Purpose : Time-integration of the ABL model
+ !! ** Purpose : Time-integration of the ABL model
!!
- !! ** Method : Compute atmospheric variables : vertical turbulence
+ !! ** Method : Compute atmospheric variables : vertical turbulence
!! + Coriolis term + newtonian relaxation
- !!
+ !!
!! ** Action : - Advance TKE to time n+1 and compute Avm_abl, Avt_abl, PBLh
!! - Advance tracers to time n+1 (Euler backward scheme)
@@ -70,5 +71,5 @@
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(:,: ) :: 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
@@ -82,37 +83,36 @@
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||
+ REAL(wp) , INTENT(inout), DIMENSION(:,: ) :: pwndm ! ||uwnd||
REAL(wp) , INTENT( out), DIMENSION(:,: ) :: ptaui ! taux
REAL(wp) , INTENT( out), DIMENSION(:,: ) :: ptauj ! tauy
- REAL(wp) , INTENT( out), DIMENSION(:,: ) :: ptaum ! ||tau||
- !
-#if defined key_si3
+ REAL(wp) , INTENT( out), DIMENSION(:,: ) :: 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(:,: ) :: 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(inout), DIMENSION(:,: ) :: pfrac_oce !!GS: out useless ?
- REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: pfrac_oce !
+ 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)
-#endif
- !
- REAL(wp), DIMENSION(1:jpi,1:jpj ) :: zwnd_i, zwnd_j
- REAL(wp), DIMENSION(1:jpi,2:jpka ) :: zCF
- REAL(wp), DIMENSION(1:jpi,1:jpj,1:jpka) :: z_cft !--FL--to be removed after the test phase
- !
- 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
+ REAL(wp) , INTENT( out), DIMENSION(:,: ) :: ptauj_ice ! ice-surface tauy stress (V-point)
+#endif
+ !
+ REAL(wp), DIMENSION(1:jpi,1:jpj ) :: zwnd_i, zwnd_j
+ REAL(wp), DIMENSION(1:jpi ,2:jpka) :: 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
!
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.
+ !
+ !!---------------------------------------------------------------------
!
IF(lwp .AND. kt == nit000) THEN ! control print
@@ -120,18 +120,20 @@
WRITE(numout,*) 'abl_stp : ABL time stepping'
WRITE(numout,*) '~~~~~~'
- ENDIF
+ ENDIF
!
IF( kt == nit000 ) ALLOCATE ( ustar2( 1:jpi, 1:jpj ) )
- !! Compute ustar squared as Cd || Uatm-Uoce ||^2
- !! needed for surface boundary condition of TKE
+ IF( kt == nit000 ) ALLOCATE ( zrough( 1:jpi, 1:jpj ) )
+ !! 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_11_11
+ DO_2D( 1, 1, 1, 1 )
zzoce = pCd_du (ji,jj) * pwndm (ji,jj)
#if defined key_si3
- zzice = pCd_du_ice(ji,jj) * pwndm_ice(ji,jj)
- ustar2(ji,jj) = zzoce * pfrac_oce(ji,jj) + (1._wp - pfrac_oce(ji,jj)) * zzice
+ zzice = pCd_du_ice(ji,jj) * pwndm_ice(ji,jj)
+ ustar2(ji,jj) = zzoce * pfrac_oce(ji,jj) + (1._wp - pfrac_oce(ji,jj)) * zzice
#else
- ustar2(ji,jj) = zzoce
+ ustar2(ji,jj) = zzoce
#endif
+ 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
END_2D
!
@@ -140,201 +142,247 @@
! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
- 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 (1,jpi) x (1,jpj)
+
! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
! ! 2 *** Advance tracers to time n+1
! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
-
+
!-------------
DO jj = 1, jpj ! outer loop !--> tq_abl computed on (1:jpi) x (1:jpj)
- !-------------
- ! Compute matrix elements for interior points
+ !-------------
+ ! Compute matrix elements for interior points
DO jk = 3, jpkam1
DO ji = 1, jpi ! vector opt.
- 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 DO
- ! Boundary conditions
- DO ji = 1, jpi ! vector opt.
- ! 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 )
+ 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 DO
+ ! Boundary conditions
+ DO ji = 1, jpi ! vector opt.
+ ! 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 )
! Homogeneous Neumann at the top
- 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
+ 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
DO jtra = 1,jptq ! loop on active tracers
-
+
DO jk = 3, jpkam1
- DO ji = 1,jpi
- tq_abl ( ji, jj, jk, nt_a, jtra ) = e3t_abl(jk) * tq_abl ( ji, jj, jk, nt_n, jtra ) ! initialize right-hand-side
+ !DO ji = 2, jpim1
+ DO ji = 1,jpi !!GS: to be checked if needed
+ 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 DO
IF(jtra == jp_ta) THEN
- DO ji = 1,jpi ! boundary conditions for temperature
- zztmp1 = psen(ji, jj)
- zztmp2 = psen(ji, jj) * ( psst(ji, jj) + rt0 )
-#if defined key_si3
- zztmp1 = zztmp1 * pfrac_oce(ji,jj) + (1._wp - pfrac_oce(ji,jj)) * psen_ice(ji,jj)
+ DO ji = 1,jpi ! surface boundary condition for temperature
+ zztmp1 = psen(ji, jj)
+ zztmp2 = psen(ji, jj) * ( psst(ji, jj) + rt0 )
+#if defined key_si3
+ zztmp1 = zztmp1 * pfrac_oce(ji,jj) + (1._wp - pfrac_oce(ji,jj)) * psen_ice(ji,jj)
zztmp2 = zztmp2 * pfrac_oce(ji,jj) + (1._wp - pfrac_oce(ji,jj)) * psen_ice(ji,jj) * ptm_su(ji,jj)
-#endif
- 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
+#endif
+ 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
- ELSE
- DO ji = 1,jpi ! boundary conditions for humidity
- zztmp1 = pevp(ji, jj)
- zztmp2 = pevp(ji, jj) * pssq(ji, jj)
-#if defined key_si3
- zztmp1 = zztmp1 * pfrac_oce(ji,jj) + (1._wp - pfrac_oce(ji,jj)) * pevp_ice(ji,jj)
- zztmp2 = zztmp2 * pfrac_oce(ji,jj) + (1._wp - pfrac_oce(ji,jj)) * pevp_ice(ji, jj) * pssq_ice(ji, jj)
-#endif
- 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
+ END DO
+ ELSE ! jp_qa
+ DO ji = 1,jpi ! surface boundary condition for humidity
+ zztmp1 = pevp(ji, jj)
+ zztmp2 = pevp(ji, jj) * pssq(ji, jj)
+#if defined key_si3
+ zztmp1 = zztmp1 * pfrac_oce(ji,jj) + (1._wp - pfrac_oce(ji,jj)) * pevp_ice(ji,jj)
+ zztmp2 = zztmp2 * pfrac_oce(ji,jj) + (1._wp - pfrac_oce(ji,jj)) * pevp_ice(ji, jj) * pssq_ice(ji, jj)
+#endif
+ 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 DO
END IF
!!
!! Matrix inversion
!! ----------------------------------------------------------
- DO ji = 1,jpi
- 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
-
- DO jk = 3, jpka
- DO ji = 1,jpi
- zcff = 1._wp / ( z_elem_b( ji, jk ) + z_elem_a( ji, jk ) * zCF (ji, jk-1 ) )
+ DO ji = 1,jpi
+ 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
+
+ DO jk = 3, jpka
+ DO ji = 1,jpi
+ 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 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
+ & - z_elem_a(ji, jk) * tq_abl(ji,jj,jk-1,nt_a,jtra) )
+ END DO
+ 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
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 DO
-
- END DO !<-- loop on tracers
- !!
- !-------------
- END DO ! end outer loop
- !-------------
-
-
+
+ END DO !<-- loop on tracers
+ !!
+ !-------------
+ END DO ! end outer loop
+ !-------------
+
! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
! ! 3 *** Compute Coriolis term with geostrophic guide
- ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
- !-------------
- DO jk = 2, jpka ! outer loop
- !-------------
- !
- ! Advance u_abl & v_abl to time n+1
- DO_2D_11_11
- zcff = ( fft_abl(ji,jj) * rDt_abl )*( fft_abl(ji,jj) * rDt_abl ) ! (f dt)**2
+ ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ IF( SemiImp_Cor ) THEN
+
+ !-------------
+ DO jk = 2, jpka ! outer loop
+ !-------------
+ !
+ ! Advance u_abl & v_abl to time n+1
+ DO_2D( 1, 1, 1, 1 )
+ 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) *( &
+ & (1._wp-gamma_Cor*(1._wp-gamma_Cor)*zcff) * u_abl( ji, jj, jk, nt_n ) &
+ & + rDt_abl * fft_abl(ji, jj) * v_abl( ji, jj, jk, nt_n ) ) &
+ & / (1._wp + gamma_Cor*gamma_Cor*zcff)
- u_abl( ji, jj, jk, nt_a ) = e3t_abl(jk) *( &
- & (1._wp-gamma_Cor*(1._wp-gamma_Cor)*zcff)*u_abl( ji, jj, jk, nt_n ) &
- & + rDt_abl * fft_abl(ji, jj) * v_abl ( ji , jj , jk, nt_n ) ) &
- & / (1._wp + gamma_Cor*gamma_Cor*zcff)
-
- v_abl( ji, jj, jk, nt_a ) = e3t_abl(jk) *( &
- & (1._wp-gamma_Cor*(1._wp-gamma_Cor)*zcff)*v_abl( ji, jj, jk, nt_n ) &
- & - rDt_abl * fft_abl(ji, jj) * u_abl ( ji , jj, jk, nt_n ) ) &
- & / (1._wp + gamma_Cor*gamma_Cor*zcff)
- END_2D
- !
- !-------------
- END DO ! end outer loop !<-- u_abl and v_abl are properly updated on (1:jpi) x (1:jpj)
- !-------------
- !
- IF( ln_geos_winds ) THEN
- DO jj = 1, jpj ! outer loop
- DO jk = 1, jpka
- DO ji = 1, jpi
- 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 ) &
- & + rDt_abl * e3t_abl(jk) * fft_abl(ji, jj ) * pgu_dta(ji ,jj ,jk)
- END DO
- END DO
- END DO
- END IF
- !-------------
- !
- IF( ln_hpgls_frc ) THEN
- DO jj = 1, jpj ! outer loop
- DO jk = 1, jpka
- DO ji = 1, jpi
- 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)
+ v_abl( ji, jj, jk, nt_a ) = e3t_abl(jk) *( &
+ & (1._wp-gamma_Cor*(1._wp-gamma_Cor)*zcff) * v_abl( ji, jj, jk, nt_n ) &
+ & - rDt_abl * fft_abl(ji, jj) * u_abl( ji, jj, jk, nt_n ) ) &
+ & / (1._wp + gamma_Cor*gamma_Cor*zcff)
+ END_2D
+ !
+ !-------------
+ END DO ! end outer loop !<-- u_abl and v_abl are properly updated on (1:jpi) x (1:jpj)
+ !-------------
+ !
+ IF( ln_geos_winds ) THEN
+ DO jj = 1, jpj ! outer loop
+ DO jk = 1, jpka
+ DO ji = 1, jpi
+ 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 ) &
+ & + rDt_abl * e3t_abl(jk) * fft_abl(ji, jj ) * pgu_dta(ji ,jj ,jk)
+ END DO
+ END DO
+ END DO
+ END IF
+ !
+ IF( ln_hpgls_frc ) THEN
+ DO jj = 1, jpj ! outer loop
+ DO jk = 1, jpka
+ DO ji = 1, jpi
+ 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
ENDDO
ENDDO
- ENDDO
- END IF
-
- ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
- ! ! 4 *** Advance u,v to time n+1
- ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
- !
- ! Vertical diffusion for u_abl
+ END IF
+
+ ELSE ! SemiImp_Cor = .FALSE.
+
+ IF( ln_geos_winds ) THEN
+
+ !-------------
+ DO jk = 2, jpka ! outer loop
+ !-------------
+ !
+ 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
+ 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
+ END IF
+ !
+ !-------------
+ END DO ! end outer loop !<-- u_abl and v_abl are properly updated on (1:jpi) x (1:jpj)
+ !-------------
+
+ ENDIF ! ln_geos_winds
+
+ ENDIF ! SemiImp_Cor
+ ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ ! ! 4 *** Advance u,v to time n+1
+ ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ !
+ ! Vertical diffusion for u_abl
!-------------
DO jj = 1, jpj ! outer loop
- !-------------
+ !-------------
DO jk = 3, jpkam1
- DO ji = 1, jpi
- 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 DO
-
- DO ji = 2, jpi ! boundary conditions (Avm_abl and pcd_du must be available at ji=jpi)
+ DO ji = 1, jpi
+ 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 DO
+
+ DO ji = 2, jpi ! boundary conditions (Avm_abl and pcd_du must be available at ji=jpi)
!++ 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 )
- !
- zztmp1 = pcd_du(ji, jj)
- zztmp2 = 0.5_wp * pcd_du(ji, jj) * ( pssu(ji-1, jj) + pssu(ji,jj) )
-#if defined key_si3
+ z_elem_a( ji, 2 ) = 0._wp
+ z_elem_c( ji, 2 ) = - rDt_abl * Avm_abl( ji, jj, 2 ) / e3w_abl( 2 )
+ !
+ zztmp1 = pcd_du(ji, jj)
+ zztmp2 = 0.5_wp * pcd_du(ji, jj) * ( pssu(ji-1, jj) + pssu(ji,jj) )
+#if defined key_si3
zztmp1 = zztmp1 * pfrac_oce(ji,jj) + (1._wp - pfrac_oce(ji,jj)) * pcd_du_ice(ji, jj)
- zzice = 0.5_wp * ( pssu_ice(ji-1, jj) + pssu_ice(ji,jj) )
- zztmp2 = zztmp2 * pfrac_oce(ji,jj) + (1._wp - pfrac_oce(ji,jj)) * pcd_du_ice(ji, jj) * zzice
-#endif
- z_elem_b( ji, 2 ) = e3t_abl( 2 ) - z_elem_c( ji, 2 ) + rDt_abl * zztmp1
+ zzice = 0.5_wp * ( pssu_ice(ji-1, jj) + pssu_ice(ji, jj) )
+ zztmp2 = zztmp2 * pfrac_oce(ji,jj) + (1._wp - pfrac_oce(ji,jj)) * pcd_du_ice(ji, jj) * zzice
+#endif
+ z_elem_b( ji, 2 ) = e3t_abl( 2 ) - z_elem_c( ji, 2 ) + rDt_abl * zztmp1
u_abl( ji, jj, 2, nt_a ) = u_abl( ji, jj, 2, nt_a ) + rDt_abl * zztmp2
-
- !++ Top Neumann B.C.
- !z_elem_a( ji, jpka ) = - 0.5_wp * rDt_abl * ( Avm_abl( ji, jj, jpka )+ Avm_abl( ji+1, 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 )
- !++ Top Dirichlet B.C.
- z_elem_a( ji, jpka ) = 0._wp
- z_elem_c( ji, jpka ) = 0._wp
- z_elem_b( ji, jpka ) = e3t_abl( jpka )
- u_abl ( ji, jj, jpka, nt_a ) = e3t_abl( jpka ) * pu_dta(ji,jj,jk)
- END DO
+
+ ! idealized test cases only
+ !IF( ln_topbc_neumann ) THEN
+ ! !++ Top Neumann B.C.
+ ! z_elem_a( ji, jpka ) = - rDt_abl * Avm_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 )
+ ! !u_abl ( ji, jj, jpka, nt_a ) = e3t_abl( jpka ) * u_abl ( ji, jj, jpka, nt_a )
+ !ELSE
+ !++ Top Dirichlet B.C.
+ z_elem_a( ji, jpka ) = 0._wp
+ z_elem_c( ji, jpka ) = 0._wp
+ z_elem_b( ji, jpka ) = e3t_abl( jpka )
+ u_abl ( ji, jj, jpka, nt_a ) = e3t_abl( jpka ) * pu_dta(ji,jj,jk)
+ !ENDIF
+
+ END DO
!!
!! Matrix inversion
!! ----------------------------------------------------------
- DO ji = 2, jpi
+ !DO ji = 2, jpi
+ DO ji = 1, jpi !!GS: TBI
zcff = 1._wp / z_elem_b( ji, 2 )
- zCF (ji, 2 ) = - zcff * z_elem_c( 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
-
- DO jk = 3, jpka
- DO ji = 2, jpi
+ END DO
+
+ DO jk = 3, jpka
+ DO ji = 2, jpi
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 )
@@ -343,64 +391,71 @@
END DO
END DO
-
- DO jk = jpkam1,2,-1
+
+ DO jk = jpkam1,2,-1
DO ji = 2, jpi
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 DO
-
- !-------------
- END DO ! end outer loop
- !-------------
-
- !
- ! Vertical diffusion for v_abl
+
+ !-------------
+ END DO ! end outer loop
+ !-------------
+
+ !
+ ! Vertical diffusion for v_abl
!-------------
DO jj = 2, jpj ! outer loop
- !-------------
+ !-------------
!
DO jk = 3, jpkam1
- DO ji = 1, jpi
- 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 DO
-
- DO ji = 1, jpi ! boundary conditions (Avm_abl and pcd_du must be available at jj=jpj)
+ DO ji = 1, jpi
+ 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 DO
+
+ DO ji = 1, jpi ! boundary conditions (Avm_abl and pcd_du must be available at jj=jpj)
!++ 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 )
- !
- zztmp1 = pcd_du(ji, jj)
- zztmp2 = 0.5_wp * pcd_du(ji, jj) * ( pssv(ji, jj) + pssv(ji, jj-1) )
-#if defined key_si3
+ z_elem_a( ji, 2 ) = 0._wp
+ z_elem_c( ji, 2 ) = - rDt_abl * Avm_abl( ji, jj, 2 ) / e3w_abl( 2 )
+ !
+ zztmp1 = pcd_du(ji, jj)
+ zztmp2 = 0.5_wp * pcd_du(ji, jj) * ( pssv(ji, jj) + pssv(ji, jj-1) )
+#if defined key_si3
zztmp1 = zztmp1 * pfrac_oce(ji,jj) + (1._wp - pfrac_oce(ji,jj)) * pcd_du_ice(ji, jj)
- zzice = 0.5_wp * ( pssv_ice(ji, jj) + pssv_ice(ji,jj-1) )
- zztmp2 = zztmp2 * pfrac_oce(ji,jj) + (1._wp - pfrac_oce(ji,jj)) * pcd_du_ice(ji, jj) * zzice
-#endif
- z_elem_b( ji, 2 ) = e3t_abl( 2 ) - z_elem_c( ji, 2 ) + rDt_abl * zztmp1
+ zzice = 0.5_wp * ( pssv_ice(ji, jj) + pssv_ice(ji, jj-1) )
+ zztmp2 = zztmp2 * pfrac_oce(ji,jj) + (1._wp - pfrac_oce(ji,jj)) * pcd_du_ice(ji, jj) * zzice
+#endif
+ z_elem_b( ji, 2 ) = e3t_abl( 2 ) - z_elem_c( ji, 2 ) + rDt_abl * zztmp1
v_abl( ji, jj, 2, nt_a ) = v_abl( ji, jj, 2, nt_a ) + rDt_abl * zztmp2
- !++ Top Neumann B.C.
- !z_elem_a( ji, jpka ) = -rDt_abl * Avm_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 )
- !++ Top Dirichlet B.C.
- z_elem_a( ji, jpka ) = 0._wp
- z_elem_c( ji, jpka ) = 0._wp
- z_elem_b( ji, jpka ) = e3t_abl( jpka )
- v_abl ( ji, jj, jpka, nt_a ) = e3t_abl( jpka ) * pv_dta(ji,jj,jk)
- END DO
+
+ ! idealized test cases only
+ !IF( ln_topbc_neumann ) THEN
+ ! !++ Top Neumann B.C.
+ ! z_elem_a( ji, jpka ) = - rDt_abl * Avm_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 )
+ ! !v_abl ( ji, jj, jpka, nt_a ) = e3t_abl( jpka ) * v_abl ( ji, jj, jpka, nt_a )
+ !ELSE
+ !++ Top Dirichlet B.C.
+ z_elem_a( ji, jpka ) = 0._wp
+ z_elem_c( ji, jpka ) = 0._wp
+ z_elem_b( ji, jpka ) = e3t_abl( jpka )
+ v_abl ( ji, jj, jpka, nt_a ) = e3t_abl( jpka ) * pv_dta(ji,jj,jk)
+ !ENDIF
+
+ END DO
!!
!! Matrix inversion
!! ----------------------------------------------------------
- DO ji = 1, jpi
+ DO ji = 1, jpi
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
-
- DO jk = 3, jpka
- DO ji = 1, jpi
+ 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
+
+ DO jk = 3, jpka
+ DO ji = 1, jpi
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 )
@@ -409,37 +464,35 @@
END DO
END DO
-
- DO jk = jpkam1,2,-1
- DO ji = 1, jpi
+
+ DO jk = jpkam1,2,-1
+ DO ji = 1, jpi
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 DO
- !
- !-------------
- END DO ! end outer loop
- !-------------
-
- ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
- ! ! 5 *** Apply nudging on the dynamics and the tracers
- ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
- z_cft(:,:,:) = 0._wp
-
+ !
+ !-------------
+ END DO ! end outer loop
+ !-------------
+
+ ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ ! ! 5 *** Apply nudging on the dynamics and the tracers
+ ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+
IF( nn_dyn_restore > 0 ) THEN
- !-------------
+ !-------------
DO jk = 2, jpka ! outer loop
- !-------------
- DO_2D_01_01
+ !-------------
+ DO_2D( 0, 1, 0, 1 )
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) )
+ zsig = ght_abl(jk) / MAX( jp_pblh_min, MIN( jp_pblh_max, zcff1 ) )
+ zsig = MIN( jp_bmax , MAX( zsig, jp_bmin) )
zmsk = msk_abl(ji,jj)
zcff2 = jp_alp3_dyn * zsig**3 + jp_alp2_dyn * zsig**2 &
& + jp_alp1_dyn * zsig + jp_alp0_dyn
zcff = (1._wp-zmsk) + zmsk * zcff2 * rn_Dt ! zcff = 1 for masked points
- ! rn_Dt = rDt_abl / nn_fsbc
+ ! rn_Dt = rDt_abl / nn_fsbc
zcff = zcff * rest_eq(ji,jj)
- z_cft( ji, jj, jk ) = zcff
u_abl( ji, jj, jk, nt_a ) = (1._wp - zcff ) * u_abl( ji, jj, jk, nt_a ) &
- & + zcff * pu_dta( ji, jj, jk )
+ & + zcff * pu_dta( ji, jj, jk )
v_abl( ji, jj, jk, nt_a ) = (1._wp - zcff ) * v_abl( ji, jj, jk, nt_a ) &
& + zcff * pv_dta( ji, jj, jk )
@@ -447,38 +500,39 @@
!-------------
END DO ! end outer loop
- !-------------
+ !-------------
END IF
- !-------------
+ !-------------
DO jk = 2, jpka ! outer loop
- !-------------
- DO_2D_11_11
+ !-------------
+ DO_2D( 1, 1, 1, 1 )
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) )
+ zsig = MIN( jp_bmax , MAX( zsig, jp_bmin) )
zmsk = msk_abl(ji,jj)
zcff2 = jp_alp3_tra * zsig**3 + jp_alp2_tra * zsig**2 &
& + jp_alp1_tra * zsig + jp_alp0_tra
zcff = (1._wp-zmsk) + zmsk * zcff2 * rn_Dt ! zcff = 1 for masked points
- ! rn_Dt = rDt_abl / nn_fsbc
- !z_cft( ji, jj, jk ) = zcff
+ ! rn_Dt = rDt_abl / nn_fsbc
tq_abl( ji, jj, jk, nt_a, jp_ta ) = (1._wp - zcff ) * tq_abl( ji, jj, jk, nt_a, jp_ta ) &
& + zcff * pt_dta( ji, jj, jk )
-
+
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
- ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
- !
- CALL lbc_lnk_multi( 'ablmod', u_abl(:,:,:,nt_a ), 'T', -1., v_abl(:,:,:,nt_a ), 'T', -1. )
- CALL lbc_lnk_multi( 'ablmod', tq_abl(:,:,:,nt_a,jp_ta), 'T', 1., tq_abl(:,:,:,nt_a,jp_qa), 'T', 1., kfillmode = jpfillnothing ) ! ++++ this should not be needed...
- !
- ! first ABL level
+ !-------------
+ ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ ! ! 6 *** MPI exchanges
+ ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ !
+ CALL lbc_lnk_multi( 'ablmod', u_abl(:,:,:,nt_a ), 'T', -1._wp, v_abl(:,:,:,nt_a) , 'T', -1._wp )
+ CALL lbc_lnk_multi( '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_iomput
+ ! 2D & first ABL level
+ IF ( iom_use("pblh" ) ) CALL iom_put ( "pblh", pblh(:,: ) )
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 ) )
@@ -489,57 +543,63 @@
IF ( iom_use("tz1_dta") ) CALL iom_put ( "tz1_dta", pt_dta(:,:,2 ) )
IF ( iom_use("qz1_dta") ) CALL iom_put ( "qz1_dta", pq_dta(:,:,2 ) )
- ! all ABL levels
- IF ( iom_use("u_abl" ) ) CALL iom_put ( "u_abl" , u_abl(:,:,2:jpka,nt_a ) )
- IF ( iom_use("v_abl" ) ) CALL iom_put ( "v_abl" , v_abl(:,:,2:jpka,nt_a ) )
- IF ( iom_use("t_abl" ) ) CALL iom_put ( "t_abl" , tq_abl(:,:,2:jpka,nt_a,jp_ta) )
- IF ( iom_use("q_abl" ) ) CALL iom_put ( "q_abl" , tq_abl(:,:,2:jpka,nt_a,jp_qa) )
- IF ( iom_use("tke_abl") ) CALL iom_put ( "tke_abl", tke_abl(:,:,2:jpka,nt_a ) )
- IF ( iom_use("avm_abl") ) CALL iom_put ( "avm_abl", avm_abl(:,:,2:jpka ) )
- IF ( iom_use("avt_abl") ) CALL iom_put ( "avt_abl", avm_abl(:,:,2:jpka ) )
- IF ( iom_use("mxl_abl") ) CALL iom_put ( "mxl_abl", mxl_abl(:,:,2:jpka ) )
- IF ( iom_use("pblh" ) ) CALL iom_put ( "pblh" , pblh(:,: ) )
- ! debug (to be removed)
+ ! debug 2D
+ IF( ln_geos_winds ) THEN
+ IF ( iom_use("uz1_geo") ) CALL iom_put ( "uz1_geo", pgu_dta(:,:,2) )
+ IF ( iom_use("vz1_geo") ) CALL iom_put ( "vz1_geo", pgv_dta(:,:,2) )
+ END IF
+ IF( ln_hpgls_frc ) THEN
+ IF ( iom_use("uz1_geo") ) CALL iom_put ( "uz1_geo", pgu_dta(:,:,2)/MAX(fft_abl(:,:),2.5e-5_wp) )
+ IF ( iom_use("vz1_geo") ) CALL iom_put ( "vz1_geo", -pgv_dta(:,:,2)/MAX(fft_abl(:,:),2.5e-5_wp) )
+ END IF
+ ! 3D (all ABL levels)
+ IF ( iom_use("u_abl" ) ) CALL iom_put ( "u_abl" , u_abl(:,:,2:jpka,nt_a ) )
+ IF ( iom_use("v_abl" ) ) CALL iom_put ( "v_abl" , v_abl(:,:,2:jpka,nt_a ) )
+ IF ( iom_use("t_abl" ) ) CALL iom_put ( "t_abl" , tq_abl(:,:,2:jpka,nt_a,jp_ta) )
+ IF ( iom_use("q_abl" ) ) CALL iom_put ( "q_abl" , tq_abl(:,:,2:jpka,nt_a,jp_qa) )
+ IF ( iom_use("tke_abl" ) ) CALL iom_put ( "tke_abl" , tke_abl(:,:,2:jpka,nt_a ) )
+ IF ( iom_use("avm_abl" ) ) CALL iom_put ( "avm_abl" , avm_abl(:,:,2:jpka ) )
+ IF ( iom_use("avt_abl" ) ) CALL iom_put ( "avt_abl" , avt_abl(:,:,2:jpka ) )
+ IF ( iom_use("mxlm_abl") ) CALL iom_put ( "mxlm_abl", mxlm_abl(:,:,2:jpka ) )
+ IF ( iom_use("mxld_abl") ) CALL iom_put ( "mxld_abl", mxld_abl(:,:,2:jpka ) )
+ ! debug 3D
IF ( iom_use("u_dta") ) CALL iom_put ( "u_dta", pu_dta(:,:,2:jpka) )
IF ( iom_use("v_dta") ) CALL iom_put ( "v_dta", pv_dta(:,:,2:jpka) )
IF ( iom_use("t_dta") ) CALL iom_put ( "t_dta", pt_dta(:,:,2:jpka) )
IF ( iom_use("q_dta") ) CALL iom_put ( "q_dta", pq_dta(:,:,2:jpka) )
- IF ( iom_use("coeft") ) CALL iom_put ( "coeft", z_cft(:,:,2:jpka) )
IF( ln_geos_winds ) THEN
- IF ( iom_use("uz1_geo") ) CALL iom_put ( "uz1_geo", pgu_dta(:,:,2 ) )
- IF ( iom_use("vz1_geo") ) CALL iom_put ( "vz1_geo", pgv_dta(:,:,2 ) )
+ IF ( iom_use("u_geo") ) CALL iom_put ( "u_geo", pgu_dta(:,:,2:jpka) )
+ IF ( iom_use("v_geo") ) CALL iom_put ( "v_geo", pgv_dta(:,:,2:jpka) )
END IF
IF( ln_hpgls_frc ) THEN
- IF ( iom_use("uz1_geo") ) CALL iom_put ( "uz1_geo", pgu_dta(:,:,2)/MAX(fft_abl(:,:),2.5e-5_wp) )
- IF ( iom_use("vz1_geo") ) CALL iom_put ( "vz1_geo", -pgv_dta(:,:,2)/MAX(fft_abl(:,:),2.5e-5_wp) )
+ IF ( iom_use("u_geo") ) CALL iom_put ( "u_geo", pgu_dta(:,:,2:jpka)/MAX( RESHAPE( fft_abl(:,:), (/jpi,jpj,jpka-1/), fft_abl(:,:)), 2.5e-5_wp) )
+ IF ( iom_use("v_geo") ) CALL iom_put ( "v_geo", -pgv_dta(:,:,2:jpka)/MAX( RESHAPE( fft_abl(:,:), (/jpi,jpj,jpka-1/), fft_abl(:,:)), 2.5e-5_wp) )
END IF
- !
+#endif
! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
! ! 7 *** Finalize flux computation
- ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
-
- DO_2D_11_11
- ztemp = tq_abl ( ji, jj, 2, nt_a, jp_ta )
- zhumi = tq_abl ( ji, jj, 2, nt_a, jp_qa )
- !zcff = pslp_dta( ji, jj ) / & !<-- At this point ztemp and zhumi should not be zero ...
- ! & ( R_dry*ztemp * ( 1._wp + rctv0*zhumi ) )
- zcff = rho_air( ztemp, zhumi, pslp_dta( ji, jj ) )
- psen ( ji, jj ) = cp_air(zhumi) * zcff * psen(ji,jj) * ( psst(ji,jj) + rt0 - ztemp )
- pevp ( ji, jj ) = rn_efac*MAX( 0._wp, zcff * pevp(ji,jj) * ( pssq(ji,jj) - zhumi ) )
- rhoa( ji, jj ) = zcff
+ ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ !
+ DO_2D( 1, 1, 1, 1 )
+ ztemp = tq_abl( ji, jj, 2, nt_a, jp_ta )
+ zhumi = tq_abl( ji, jj, 2, nt_a, jp_qa )
+ zcff = rho_air( ztemp, zhumi, pslp_dta( ji, jj ) )
+ psen( ji, jj ) = - cp_air(zhumi) * zcff * psen(ji,jj) * ( psst(ji,jj) + rt0 - ztemp ) !GS: negative sign to respect aerobulk convention
+ pevp( ji, jj ) = rn_efac*MAX( 0._wp, zcff * pevp(ji,jj) * ( pssq(ji,jj) - zhumi ) )
+ rhoa( ji, jj ) = zcff
END_2D
-
- DO_2D_01_01
- zwnd_i(ji,jj) = u_abl(ji ,jj,2,nt_a) - 0.5_wp * rn_vfac * ( pssu(ji ,jj) + pssu(ji-1,jj) )
- zwnd_j(ji,jj) = v_abl(ji,jj ,2,nt_a) - 0.5_wp * rn_vfac * ( pssv(ji,jj ) + pssv(ji,jj-1) )
+
+ DO_2D( 0, 1, 0, 1 )
+ zwnd_i(ji,jj) = u_abl(ji ,jj,2,nt_a) - 0.5_wp * ( pssu(ji ,jj) + pssu(ji-1,jj) )
+ zwnd_j(ji,jj) = v_abl(ji,jj ,2,nt_a) - 0.5_wp * ( pssv(ji,jj ) + pssv(ji,jj-1) )
END_2D
- !
- CALL lbc_lnk_multi( 'ablmod', zwnd_i(:,:) , 'T', -1., zwnd_j(:,:) , 'T', -1. )
+ !
+ CALL lbc_lnk_multi( 'ablmod', zwnd_i(:,:) , 'T', -1.0_wp, zwnd_j(:,:) , 'T', -1.0_wp )
!
! ... scalar wind ( = | U10m - U_oce | ) at T-point (masked)
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
zcff = SQRT( zwnd_i(ji,jj) * zwnd_i(ji,jj) &
- & + zwnd_j(ji,jj) * zwnd_j(ji,jj) ) ! * msk_abl(ji,jj)
+ & + zwnd_j(ji,jj) * zwnd_j(ji,jj) ) ! * msk_abl(ji,jj)
zztmp = rhoa(ji,jj) * pcd_du(ji,jj)
-
+
pwndm (ji,jj) = zcff
ptaum (ji,jj) = zztmp * zcff
@@ -550,5 +610,5 @@
! 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
- DO_2D_00_00
+ 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))
@@ -559,57 +619,59 @@
END_2D
!
- CALL lbc_lnk_multi( 'ablmod', ptaui(:,:), 'U', -1., ptauj(:,:), 'V', -1. )
+ CALL lbc_lnk_multi( 'ablmod', ptaui(:,:), 'U', -1.0_wp, ptauj(:,:), 'V', -1.0_wp )
CALL iom_put( "taum_oce", ptaum )
IF(sn_cfctl%l_prtctl) THEN
- CALL prt_ctl( tab2d_1=pwndm , clinfo1=' abl_stp: wndm : ' )
- CALL prt_ctl( tab2d_1=ptaui , clinfo1=' abl_stp: utau : ' )
- CALL prt_ctl( tab2d_2=ptauj , clinfo2= 'vtau : ' )
+ CALL prt_ctl( tab2d_1=ptaui , clinfo1=' abl_stp: utau : ', mask1=umask, &
+ & tab2d_2=ptauj , clinfo2=' vtau : ', mask2=vmask )
+ CALL prt_ctl( tab2d_1=pwndm , clinfo1=' abl_stp: wndm : ' )
ENDIF
#if defined key_si3
- ! ------------------------------------------------------------ !
- ! Wind stress relative to the moving ice ( U10m - U_ice ) !
- ! ------------------------------------------------------------ !
- DO_2D_00_00
-
- 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 - rn_vfac * 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 ) ) &
- & * ( zztmp2 - rn_vfac * pssv_ice(ji,jj) )
- END_2D
- CALL lbc_lnk_multi( 'ablmod', ptaui_ice, 'U', -1., ptauj_ice, 'V', -1. )
- !
- 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 )
+ 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_multi( '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) )
+ 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) )
+ END_2D
+ CALL lbc_lnk_multi( 'ablmod', ptaui_ice, 'U', -1.0_wp, ptauj_ice,'V', -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 )
+ END IF
#endif
! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
! ! 8 *** Swap time indices for the next timestep
- ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
- nt_n = 1 + MOD( kt , 2)
- nt_a = 1 + MOD( kt+1, 2)
- !
+ ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ nt_n = 1 + MOD( nt_n, 2)
+ nt_a = 1 + MOD( nt_a, 2)
+ !
!---------------------------------------------------------------------------------------------------
END SUBROUTINE abl_stp
!===================================================================================================
-
-
-
-
-
-
-
-
-
-
-
-
-
@@ -634,13 +696,13 @@
!! (= Kz dz[Ub] * dz[Un] )
!! ---------------------------------------------------------------------
- INTEGER :: ji, jj, jk, tind, jbak, jkup, jkdwn
+ 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
- REAL(wp) :: zwndi,zwndj
+ 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 ) :: zFC, zRH, zCF
REAL(wp), DIMENSION(1:jpi,1:jpka ) :: z_elem_a
REAL(wp), DIMENSION(1:jpi,1:jpka ) :: z_elem_b
@@ -648,5 +710,5 @@
LOGICAL :: ln_Patankar = .FALSE.
LOGICAL :: ln_dumpvar = .FALSE.
- LOGICAL , DIMENSION(1:jpi ) :: ln_foundl
+ LOGICAL , DIMENSION(1:jpi ) :: ln_foundl
!
tind = nt_n
@@ -660,18 +722,18 @@
!-------------
!
- ! Compute vertical shear
+ ! Compute vertical shear
DO jk = 2, jpkam1
- DO ji = 1,jpi
- 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
+ DO ji = 1, jpi
+ 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
- END DO
- END DO
+ zsh2(ji,jk) = zdU+zdV !<-- zsh2 = Km ( ( du/dz )^2 + ( dv/dz )^2 )
+ END DO
+ END DO
!
! Compute brunt-vaisala frequency
DO jk = 2, jpkam1
- DO ji = 1,jpi
- zcff = grav * itvref / e3w_abl( jk )
+ DO ji = 1,jpi
+ 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) &
@@ -679,40 +741,54 @@
zbn2(ji,jj,jk) = zcff * ( zcff1 + rctv0 * zcff2 ) !<-- zbn2 defined on (2,jpi)
END DO
- END DO
+ END DO
!
! Terms for the tridiagonal problem
DO jk = 2, jpkam1
- DO ji = 1,jpi
- 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 )
-
- z_elem_a( ji, jk ) = - 0.5_wp * rDt_abl * rn_Sch * ( Avm_abl( ji, jj, jk )+Avm_abl( ji, jj, jk-1 ) ) / e3t_abl( jk ) ! lower-diagonal
- z_elem_c( ji, jk ) = - 0.5_wp * rDt_abl * rn_Sch * ( Avm_abl( ji, jj, jk )+Avm_abl( ji, jj, jk+1 ) ) / e3t_abl( jk+1 ) ! upper-diagonal
+ DO ji = 1, jpi
+ 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 )
+
+ z_elem_a( ji, jk ) = - 0.5_wp * rDt_abl * rn_Sch * ( Avm_abl( ji, jj, jk ) + Avm_abl( ji, jj, jk-1 ) ) / e3t_abl( jk ) ! lower-diagonal
+ z_elem_c( ji, jk ) = - 0.5_wp * rDt_abl * rn_Sch * ( Avm_abl( ji, jj, jk ) + Avm_abl( ji, jj, jk+1 ) ) / e3t_abl( jk+1 ) ! upper-diagonal
IF( (zbuoy + zshear) .gt. 0.) THEN ! Patankar trick to avoid negative values of TKE
- z_elem_b( ji, jk ) = e3w_abl(jk) - z_elem_a( ji, jk ) - z_elem_c( ji, jk ) &
- & + e3w_abl(jk) * rDt_abl * rn_Ceps * sqrt(tke_abl( ji, jj, jk, nt_n )) / mxl_abl(ji,jj,jk) ! diagonal
- tke_abl( ji, jj, jk, nt_a ) = e3w_abl(jk) * ( tke_abl( ji, jj, jk, nt_n ) + rDt_abl * ( zbuoy + zshear ) ) ! right-hand-side
+ z_elem_b( ji, jk ) = e3w_abl(jk) - z_elem_a( ji, jk ) - z_elem_c( ji, jk ) &
+ & + e3w_abl(jk) * rDt_abl * rn_Ceps * sqrt(tke_abl( ji, jj, jk, nt_n )) / mxld_abl(ji,jj,jk) ! diagonal
+ tke_abl( ji, jj, jk, nt_a ) = e3w_abl(jk) * ( tke_abl( ji, jj, jk, nt_n ) + rDt_abl * ( zbuoy + zshear ) ) ! right-hand-side
ELSE
- z_elem_b( ji, jk ) = e3w_abl(jk) - z_elem_a( ji, jk ) - z_elem_c( ji, jk ) &
- & + e3w_abl(jk) * rDt_abl * rn_Ceps * sqrt(tke_abl( ji, jj, jk, nt_n )) / mxl_abl(ji,jj,jk) & ! diagonal
- & - 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
+ z_elem_b( ji, jk ) = e3w_abl(jk) - z_elem_a( ji, jk ) - z_elem_c( ji, jk ) &
+ & + e3w_abl(jk) * rDt_abl * rn_Ceps * sqrt(tke_abl( ji, jj, jk, nt_n )) / mxld_abl(ji,jj,jk) & ! diagonal
+ & - 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 DO
-
- DO ji = 1,jpi ! vector opt.
- zesrf = MAX( 4.63_wp * ustar2(ji,jj), tke_min )
- zetop = tke_min
- z_elem_a ( ji, 1 ) = 0._wp; z_elem_c ( ji, 1 ) = 0._wp; z_elem_b ( ji, 1 ) = 1._wp
- z_elem_a ( ji, jpka ) = 0._wp; z_elem_c ( ji, jpka ) = 0._wp; z_elem_b ( ji, jpka ) = 1._wp
- tke_abl( ji, jj, 1, nt_a ) = zesrf
- tke_abl( ji, jj, jpka, nt_a ) = zetop
- zbn2(ji,jj, 1) = zbn2( ji,jj, 2)
- zsh2(ji, 1) = zsh2( ji, 2)
- zbn2(ji,jj,jpka) = zbn2( ji,jj,jpkam1)
- zsh2(ji, jpka) = zsh2( ji , jpkam1)
- END DO
+ END DO
+
+ DO ji = 1,jpi ! vector opt.
+ zesrf = MAX( rn_Esfc * ustar2(ji,jj), tke_min )
+ zetop = tke_min
+
+ z_elem_a ( ji, 1 ) = 0._wp
+ z_elem_c ( ji, 1 ) = 0._wp
+ z_elem_b ( ji, 1 ) = 1._wp
+ tke_abl ( ji, jj, 1, nt_a ) = zesrf
+
+ !++ Top Neumann B.C.
+ !z_elem_a ( ji, jpka ) = - 0.5 * rDt_abl * rn_Sch * (Avm_abl(ji,jj, jpka-1 )+Avm_abl(ji,jj, jpka )) / e3t_abl( jpka )
+ !z_elem_c ( ji, jpka ) = 0._wp
+ !z_elem_b ( ji, jpka ) = e3w_abl(jpka) - z_elem_a(ji, jpka )
+ !tke_abl ( ji, jj, jpka, nt_a ) = e3w_abl(jpka) * tke_abl( ji,jj, jpka, nt_n )
+
+ !++ Top Dirichlet B.C.
+ z_elem_a ( ji, jpka ) = 0._wp
+ z_elem_c ( ji, jpka ) = 0._wp
+ z_elem_b ( ji, jpka ) = 1._wp
+ tke_abl ( ji, jj, jpka, nt_a ) = zetop
+
+ zbn2 ( ji, jj, 1 ) = zbn2 ( ji, jj, 2 )
+ zsh2 ( ji, 1 ) = zsh2 ( ji, 2 )
+ zbn2 ( ji, jj, jpka ) = zbn2 ( ji, jj, jpkam1 )
+ zsh2 ( ji, jpka ) = zsh2 ( ji , jpkam1 )
+ END DO
!!
!! Matrix inversion
@@ -720,9 +796,9 @@
DO ji = 1,jpi
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
-
- DO jk = 2, jpka
+ 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
+
+ DO jk = 2, jpka
DO ji = 1,jpi
zcff = 1._wp / ( z_elem_b( ji, jk ) + z_elem_a( ji, jk ) * zCF(ji, jk-1 ) )
@@ -732,12 +808,12 @@
END DO
END DO
-
- DO jk = jpkam1,1,-1
+
+ DO jk = jpkam1,1,-1
DO ji = 1,jpi
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 DO
-
-!!FL should not be needed because of Patankar procedure
+
+!!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 )
@@ -745,15 +821,15 @@
!! 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( 1:jpi ) = 0
+
DO jk = 2,jpka
- DO ji = 1, jpi
+ DO ji = 1, jpi
zcff = ghw_abl( jk-1 )
zcff1 = zcff / ( zcff + rn_epssfc * pblh ( ji, jj ) )
@@ -781,15 +857,15 @@
ELSE
pblh( ji, jj ) = ghw_abl(jpka)
- END IF
- END DO
- !-------------
- END DO
- !-------------
- !
- ! Optional : could add pblh smoothing if pblh is noisy horizontally ...
+ END IF
+ END DO
+ !-------------
+ END DO
+ !-------------
+ !
+ ! Optional : could add pblh smoothing if pblh is noisy horizontally ...
IF(ln_smth_pblh) THEN
- CALL lbc_lnk( 'ablmod', pblh, 'T', 1.)
+ CALL lbc_lnk( 'ablmod', pblh, 'T', 1.0_wp) !, kfillmode = jpfillnothing)
CALL smooth_pblh( pblh, msk_abl )
- CALL lbc_lnk( 'ablmod', pblh, 'T', 1.)
+ CALL lbc_lnk( 'ablmod', pblh, 'T', 1.0_wp) !, kfillmode = jpfillnothing)
ENDIF
! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
@@ -799,92 +875,147 @@
SELECT CASE ( nn_amxl )
!
- CASE ( 0 ) ! Deardroff 80 length-scale bounded by the distance to surface and bottom
-# define zlup zRH
-# define zldw zFC
+ 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 ji = 1, jpi
- mxl_abl ( ji, jj, 1 ) = 0._wp
- mxl_abl ( ji, jj, jpka ) = mxl_min
- zldw( ji, 1 ) = 0._wp
- zlup( ji, jpka ) = 0._wp
- END DO
- !
- DO jk = 2, jpkam1
- DO ji = 1, jpi
- zbuoy = MAX( zbn2(ji, jj, jk), rsmall )
- mxl_abl( ji, jj, jk ) = MAX( mxl_min, &
- & SQRT( 2._wp * tke_abl( ji, jj, jk, nt_a ) / zbuoy ) )
- END DO
- END DO
+ 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
+ !
+ DO jk = 2, jpkam1
+ DO ji = 1, jpi
+ 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 DO
!
! Limit mxl
- DO jk = jpkam1,1,-1
- DO ji = 1, jpi
- zlup(ji,jk) = MIN( zlup(ji,jk+1) + (ghw_abl(jk+1)-ghw_abl(jk)) , mxl_abl(ji, jj, jk) )
- END DO
- END DO
+ DO jk = jpkam1,1,-1
+ DO ji = 1, jpi
+ zlup(ji,jk) = MIN( zlup(ji,jk+1) + (ghw_abl(jk+1)-ghw_abl(jk)) , mxlm_abl(ji, jj, jk) )
+ END DO
+ END DO
!
DO jk = 2, jpka
- DO ji = 1, jpi
- zldw(ji,jk) = MIN( zldw(ji,jk-1) + (ghw_abl(jk)-ghw_abl(jk-1)) , mxl_abl(ji, jj, jk) )
- END DO
- END DO
+ DO ji = 1, jpi
+ zldw(ji,jk) = MIN( zldw(ji,jk-1) + (ghw_abl(jk)-ghw_abl(jk-1)) , mxlm_abl(ji, jj, jk) )
+ END DO
+ END DO
+ !
+! DO jk = 1, jpka
+! DO ji = 1, jpi
+! 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 DO
!
DO jk = 1, jpka
DO ji = 1, jpi
- mxl_abl( ji, jj, jk ) = SQRT( zldw( ji, jk ) * zlup( ji, jk ) )
- END DO
- END DO
- !
- END DO
-# undef zlup
-# undef zldw
- !
- !
- CASE ( 1 ) ! length-scale computed as the distance to the PBL height
- DO jj = 1,jpj ! outer loop
- !
- DO ji = 1, jpi ! vector opt.
- zcff = 1._wp / pblh( ji, jj ) ! inverse of hbl
- DO jk = 1, jpka
- zsig = MIN( zcff * ghw_abl( jk ), 1. )
- zcff1 = pblh( ji, jj )
- mxl_abl( ji, jj, jk ) = mxl_min &
- & + zsig * ( amx1*zcff1 + bmx1*mxl_min ) &
- & + zsig * zsig * ( amx2*zcff1 + bmx2*mxl_min ) &
- & + zsig**3 * ( amx3*zcff1 + bmx3*mxl_min ) &
- & + zsig**4 * ( amx4*zcff1 + bmx4*mxl_min ) &
- & + zsig**5 * ( amx5*zcff1 + bmx5*mxl_min )
- END DO
- END DO
- !
- END DO
+! 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 DO
+ !
+ END DO
+# undef zlup
+# undef zldw
+ !
+ !
+ 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 jk = 2, jpkam1
+ DO ji = 1,jpi
+ 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
+ zcff = zrough(ji,jj) * rn_Lsfc
+ mxld_abl ( ji, jj, 1 ) = zcff
+ mxld_abl ( ji, jj, jpka ) = mxl_min
+ mxlm_abl ( ji, jj, 1 ) = zcff
+ mxlm_abl ( ji, jj, jpka ) = mxl_min
+ zldw ( ji, 1 ) = zcff
+ zlup ( ji, jpka ) = mxl_min
+ END DO
+ !
+ DO jk = 2, jpkam1
+ DO ji = 1, jpi
+ 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 DO
+ !
+ ! Limit mxl
+ DO jk = jpkam1,1,-1
+ DO ji = 1, jpi
+ zlup(ji,jk) = MIN( zlup(ji,jk+1) + (ghw_abl(jk+1)-ghw_abl(jk)) , mxlm_abl(ji, jj, jk) )
+ END DO
+ END DO
+ !
+ DO jk = 2, jpka
+ DO ji = 1, jpi
+ zldw(ji,jk) = MIN( zldw(ji,jk-1) + (ghw_abl(jk)-ghw_abl(jk-1)) , mxlm_abl(ji, jj, jk) )
+ END DO
+ END DO
+ !
+ DO jk = 1, jpka
+ DO ji = 1, jpi
+ !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 DO
+ !
+ END DO
+# undef zlup
+# undef zldw
!
CASE ( 2 ) ! Bougeault & Lacarrere 89 length-scale
!
-# define zlup zRH
-# define zldw zFC
+# define zlup zRH
+# define zldw zFC
! zCF is used for matrix inversion
-!
+!
DO jj = 1, jpj ! outer loop
-
- DO ji = 1, jpi
- zlup( ji, 1 ) = mxl_min
- zldw( ji, 1 ) = mxl_min
+
+ 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
-
+ zldw( ji, jpka ) = mxl_min
+ END DO
+
DO jk = 2,jpka-1
DO ji = 1, jpi
zlup(ji,jk) = ghw_abl(jpka) - ghw_abl(jk)
- zldw(ji,jk) = ghw_abl(jk ) - ghw_abl( 1)
- END DO
- END DO
+ zldw(ji,jk) = ghw_abl(jk ) - ghw_abl( 1)
+ END DO
+ END DO
!!
!! BL89 search for lup
- !! ----------------------------------------------------------
- DO jk=2,jpka-1
+ !! ----------------------------------------------------------
+ DO jk=2,jpka-1
!
DO ji = 1, jpi
@@ -892,17 +1023,20 @@
zCF(ji, jk ) = - tke_abl( ji, jj, jk, nt_a )
ln_foundl(ji ) = .false.
- END DO
- !
+ END DO
+ !
DO jkup=jk+1,jpka-1
DO ji = 1, jpi
+ 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) * &
- & ( zbn2(ji,jj,jkup )*(ghw_abl(jkup )-ghw_abl(jk)) &
- & + zbn2(ji,jj,jkup-1)*(ghw_abl(jkup-1)-ghw_abl(jk)) )
+ & ( zbuoy1*(ghw_abl(jkup )-ghw_abl(jk)) &
+ & + zbuoy2*(ghw_abl(jkup-1)-ghw_abl(jk)) )
IF( zCF (ji,jkup) * zCF (ji,jkup-1) .le. 0._wp .and. .not. ln_foundl(ji) ) THEN
zcff2 = ghw_abl(jkup ) - ghw_abl(jk)
- zcff1 = ghw_abl(jkup-1) - ghw_abl(jk)
+ zcff1 = ghw_abl(jkup-1) - ghw_abl(jk)
zcff = ( zcff1 * zCF(ji,jkup) - zcff2 * zCF(ji,jkup-1) ) / &
- & ( zCF(ji,jkup) - zCF(ji,jkup-1) )
- zlup(ji,jk) = zcff
+ & ( zCF(ji,jkup) - zCF(ji,jkup-1) )
+ zlup(ji,jk) = zcff
+ zlup(ji,jk) = ghw_abl(jkup ) - ghw_abl(jk)
ln_foundl(ji) = .true.
END IF
@@ -910,9 +1044,9 @@
END DO
!
- END DO
+ END DO
!!
!! BL89 search for ldwn
- !! ----------------------------------------------------------
- DO jk=2,jpka-1
+ !! ----------------------------------------------------------
+ DO jk=2,jpka-1
!
DO ji = 1, jpi
@@ -920,55 +1054,179 @@
zCF(ji, jk ) = - tke_abl( ji, jj, jk, nt_a )
ln_foundl(ji ) = .false.
- END DO
- !
+ END DO
+ !
DO jkdwn=jk-1,1,-1
- DO ji = 1, jpi
+ DO ji = 1, jpi
+ 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) &
- & * ( zbn2(ji,jj,jkdwn+1)*(ghw_abl(jk)-ghw_abl(jkdwn+1)) &
- + zbn2(ji,jj,jkdwn )*(ghw_abl(jk)-ghw_abl(jkdwn )) )
- IF(zCF (ji,jkdwn) * zCF (ji,jkdwn+1) .le. 0._wp .and. .not. ln_foundl(ji) ) THEN
+ & * ( zbuoy1*(ghw_abl(jk)-ghw_abl(jkdwn+1)) &
+ + zbuoy2*(ghw_abl(jk)-ghw_abl(jkdwn )) )
+ IF(zCF (ji,jkdwn) * zCF (ji,jkdwn+1) .le. 0._wp .and. .not. ln_foundl(ji) ) THEN
zcff2 = ghw_abl(jk) - ghw_abl(jkdwn+1)
- zcff1 = ghw_abl(jk) - ghw_abl(jkdwn )
+ zcff1 = ghw_abl(jk) - ghw_abl(jkdwn )
zcff = ( zcff1 * zCF(ji,jkdwn+1) - zcff2 * zCF(ji,jkdwn) ) / &
- & ( zCF(ji,jkdwn+1) - zCF(ji,jkdwn) )
- zldw(ji,jk) = zcff
- ln_foundl(ji) = .true.
- END IF
- END DO
- END DO
- !
+ & ( zCF(ji,jkdwn+1) - zCF(ji,jkdwn) )
+ zldw(ji,jk) = zcff
+ zldw(ji,jk) = ghw_abl(jk) - ghw_abl(jkdwn )
+ ln_foundl(ji) = .true.
+ END IF
+ END DO
+ END DO
+ !
END DO
DO jk = 1, jpka
- DO ji = 1, jpi
- mxl_abl( ji, jj, jk ) = MAX( SQRT( zldw( ji, jk ) * zlup( ji, jk ) ), mxl_min )
- END DO
- END DO
+ DO ji = 1, jpi
+ !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 DO
END DO
-# undef zlup
-# undef zldw
- !
- END SELECT
+# undef zlup
+# undef zldw
+ !
+ CASE ( 3 ) ! Bougeault & Lacarrere 89 length-scale
+ !
+# define zlup zRH
+# define zldw zFC
+! zCF is used for matrix inversion
+!
+ DO jj = 1, jpj ! outer loop
+ !
+ DO jk = 2, jpkam1
+ DO ji = 1,jpi
+ 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
+ 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 jk = 2,jpka-1
+ DO ji = 1, jpi
+ zlup(ji,jk) = ghw_abl(jpka) - ghw_abl(jk)
+ zldw(ji,jk) = ghw_abl(jk ) - ghw_abl( 1)
+ END DO
+ END DO
+ !!
+ !! BL89 search for lup
+ !! ----------------------------------------------------------
+ DO jk=2,jpka-1
+ !
+ DO ji = 1, jpi
+ zCF(ji,1:jpka) = 0._wp
+ zCF(ji, jk ) = - tke_abl( ji, jj, jk, nt_a )
+ ln_foundl(ji ) = .false.
+ END DO
+ !
+ DO jkup=jk+1,jpka-1
+ DO ji = 1, jpi
+ 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) * &
+ & ( zbuoy1*(ghw_abl(jkup )-ghw_abl(jk)) &
+ & + zbuoy2*(ghw_abl(jkup-1)-ghw_abl(jk)) ) &
+ & + 0.5_wp * e3t_abl(jkup) * rn_Rod * &
+ & ( SQRT(tke_abl( ji, jj, jkup , nt_a ))*zsh2(ji,jkup ) &
+ & + SQRT(tke_abl( ji, jj, jkup-1, nt_a ))*zsh2(ji,jkup-1) )
+
+ IF( zCF (ji,jkup) * zCF (ji,jkup-1) .le. 0._wp .and. .not. ln_foundl(ji) ) THEN
+ zcff2 = ghw_abl(jkup ) - ghw_abl(jk)
+ zcff1 = ghw_abl(jkup-1) - ghw_abl(jk)
+ zcff = ( zcff1 * zCF(ji,jkup) - zcff2 * zCF(ji,jkup-1) ) / &
+ & ( zCF(ji,jkup) - zCF(ji,jkup-1) )
+ zlup(ji,jk) = zcff
+ zlup(ji,jk) = ghw_abl(jkup ) - ghw_abl(jk)
+ ln_foundl(ji) = .true.
+ END IF
+ END DO
+ END DO
+ !
+ END DO
+ !!
+ !! BL89 search for ldwn
+ !! ----------------------------------------------------------
+ DO jk=2,jpka-1
+ !
+ DO ji = 1, jpi
+ zCF(ji,1:jpka) = 0._wp
+ zCF(ji, jk ) = - tke_abl( ji, jj, jk, nt_a )
+ ln_foundl(ji ) = .false.
+ END DO
+ !
+ DO jkdwn=jk-1,1,-1
+ DO ji = 1, jpi
+ 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) &
+ & * (zbuoy1*(ghw_abl(jk)-ghw_abl(jkdwn+1)) &
+ & +zbuoy2*(ghw_abl(jk)-ghw_abl(jkdwn )) ) &
+ & + 0.5_wp * e3t_abl(jkup) * rn_Rod * &
+ & ( SQRT(tke_abl( ji, jj, jkdwn+1, nt_a ))*zsh2(ji,jkdwn+1) &
+ & + SQRT(tke_abl( ji, jj, jkdwn , nt_a ))*zsh2(ji,jkdwn ) )
+
+ IF(zCF (ji,jkdwn) * zCF (ji,jkdwn+1) .le. 0._wp .and. .not. ln_foundl(ji) ) THEN
+ zcff2 = ghw_abl(jk) - ghw_abl(jkdwn+1)
+ zcff1 = ghw_abl(jk) - ghw_abl(jkdwn )
+ zcff = ( zcff1 * zCF(ji,jkdwn+1) - zcff2 * zCF(ji,jkdwn) ) / &
+ & ( zCF(ji,jkdwn+1) - zCF(ji,jkdwn) )
+ zldw(ji,jk) = zcff
+ zldw(ji,jk) = ghw_abl(jk) - ghw_abl(jkdwn )
+ ln_foundl(ji) = .true.
+ END IF
+ END DO
+ END DO
+ !
+ END DO
+
+ DO jk = 1, jpka
+ DO ji = 1, jpi
+ !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 DO
+
+ END DO
+# undef zlup
+# undef zldw
+ !
+ !
+ END SELECT
! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
! ! Finalize the computation of turbulent visc./diff.
! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
-
+
!-------------
DO jj = 1, jpj ! outer loop
!-------------
- DO jk = 1, jpka
+ DO jk = 1, jpka
DO ji = 1, jpi ! vector opt.
- zcff = MAX( rn_phimax, rn_Ric * mxl_abl( ji, jj, jk ) * mxl_abl( ji, jj, jk ) &
- & * zbn2(ji, jj, jk) / tke_abl( ji, jj, jk, nt_a ) )
- zcff2 = 1. / ( 1. + zcff ) !<-- phi_z(z)
- zcff = mxl_abl( ji, jj, jk ) * SQRT( tke_abl( ji, jj, jk, nt_a ) )
-!!FL: MAX function probably useless because of the definition of mxl_min
+ 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)
+ zcff = mxlm_abl( ji, jj, jk ) * SQRT( tke_abl( ji, jj, jk, nt_a ) )
+ !!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 DO
- !-------------
- END DO
+ Avt_abl( ji, jj, jk ) = MAX( rn_Ct * zcff * zcff2 , avt_bak )
+ END DO
+ END DO
+ !-------------
+ END DO
!-------------
@@ -988,10 +1246,10 @@
!!
!! ---------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: msk
- REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pvar2d
+ 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) :: smth_a, smth_b
+ REAL(wp), DIMENSION(jpi,jpj) :: zdX,zdY,zFX,zFY
+ REAL(wp) :: zumsk,zvmsk
!!
!!=========================================================
@@ -1001,21 +1259,21 @@
smth_b = 1._wp / 4._wp
!
- DO_2D_11_10
+ DO_2D( 1, 1, 1, 0 )
zumsk = msk(ji,jj) * msk(ji+1,jj)
zdX ( ji, jj ) = ( pvar2d( ji+1,jj ) - pvar2d( ji ,jj ) ) * zumsk
END_2D
-
- DO_2D_10_11
+
+ DO_2D( 1, 0, 1, 1 )
zvmsk = msk(ji,jj) * msk(ji,jj+1)
zdY ( ji, jj ) = ( pvar2d( ji, jj+1 ) - pvar2d( ji ,jj ) ) * zvmsk
- END_2D
-
- DO_2D_10_00
+ END_2D
+
+ DO_2D( 1, 0, 0, 0 )
zFY ( ji, jj ) = zdY ( ji, jj ) &
& + smth_a* ( (zdX ( ji, jj+1 ) - zdX( ji-1, jj+1 )) &
& - (zdX ( ji, jj ) - zdX( ji-1, jj )) )
- END_2D
-
- DO_2D_00_10
+ END_2D
+
+ DO_2D( 0, 0, 1, 0 )
zFX( ji, jj ) = zdX( ji, jj ) &
& + smth_a*( (zdY( ji+1, jj ) - zdY( ji+1, jj-1)) &
@@ -1023,5 +1281,5 @@
END_2D
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
pvar2d( ji ,jj ) = pvar2d( ji ,jj ) &
& + msk(ji,jj) * smth_b * ( &
@@ -1029,5 +1287,5 @@
& +zFY( ji, jj ) - zFY( ji, jj-1 ) )
END_2D
- !!
+
!---------------------------------------------------------------------------------------------------
END SUBROUTINE smooth_pblh
Index: /NEMO/branches/2020/r12377_ticket2386/src/ABL/ablrst.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/ABL/ablrst.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/ABL/ablrst.F90 (revision 13540)
@@ -74,5 +74,5 @@
ENDIF
!
- CALL iom_open( TRIM(clpath)//TRIM(clname), numraw, ldwrt = .TRUE., kdlev = jpka )
+ CALL iom_open( TRIM(clpath)//TRIM(clname), numraw, ldwrt = .TRUE., kdlev = jpka, cdcomp = 'ABL' )
lrst_abl = .TRUE.
ENDIF
@@ -109,5 +109,5 @@
CALL iom_delay_rst( 'WRITE', 'ABL', numraw ) ! save only abl delayed global communication variables
- ! Prognostic variables
+ ! Prognostic (after timestep + swap time indices = now timestep) variables
CALL iom_rstput( iter, nitrst, numraw, 'u_abl', u_abl(:,:,:,nt_n ) )
CALL iom_rstput( iter, nitrst, numraw, 'v_abl', v_abl(:,:,:,nt_n ) )
@@ -117,5 +117,5 @@
CALL iom_rstput( iter, nitrst, numraw, 'avm_abl', avm_abl(:,:,: ) )
CALL iom_rstput( iter, nitrst, numraw, 'avt_abl', avt_abl(:,:,: ) )
- CALL iom_rstput( iter, nitrst, numraw, 'mxl_abl', mxl_abl(:,:,: ) )
+ CALL iom_rstput( iter, nitrst, numraw,'mxld_abl',mxld_abl(:,:,: ) )
CALL iom_rstput( iter, nitrst, numraw, 'pblh', pblh(:,: ) )
!
@@ -146,5 +146,5 @@
ENDIF
- CALL iom_open ( TRIM(cn_ablrst_indir)//'/'//cn_ablrst_in, numrar, kdlev = jpka )
+ CALL iom_open ( TRIM(cn_ablrst_indir)//'/'//cn_ablrst_in, numrar )
! Time info
@@ -165,13 +165,13 @@
! --- mandatory fields --- !
- CALL iom_get( numrar, jpdom_autoglo, 'u_abl', u_abl(:,:,:,nt_n ) )
- CALL iom_get( numrar, jpdom_autoglo, 'v_abl', v_abl(:,:,:,nt_n ) )
- CALL iom_get( numrar, jpdom_autoglo, 't_abl', tq_abl(:,:,:,nt_n,jp_ta) )
- CALL iom_get( numrar, jpdom_autoglo, 'q_abl', tq_abl(:,:,:,nt_n,jp_qa) )
- CALL iom_get( numrar, jpdom_autoglo, 'tke_abl', tke_abl(:,:,:,nt_n ) )
- CALL iom_get( numrar, jpdom_autoglo, 'avm_abl', avm_abl(:,:,: ) )
- CALL iom_get( numrar, jpdom_autoglo, 'avt_abl', avt_abl(:,:,: ) )
- CALL iom_get( numrar, jpdom_autoglo, 'mxl_abl', mxl_abl(:,:,: ) )
- CALL iom_get( numrar, jpdom_autoglo, 'pblh', pblh(:,: ) )
+ CALL iom_get( numrar, jpdom_auto, 'u_abl', u_abl(:,:,:,nt_n ), cd_type = 'U', psgn = -1._wp )
+ CALL iom_get( numrar, jpdom_auto, 'v_abl', v_abl(:,:,:,nt_n ), cd_type = 'V', psgn = -1._wp )
+ CALL iom_get( numrar, jpdom_auto, 't_abl', tq_abl(:,:,:,nt_n,jp_ta) )
+ 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(:,:,: ) )
+ CALL iom_get( numrar, jpdom_auto, 'avt_abl', avt_abl(:,:,: ) )
+ CALL iom_get( numrar, jpdom_auto,'mxld_abl',mxld_abl(:,:,: ) )
+ CALL iom_get( numrar, jpdom_auto, 'pblh', pblh(:,: ) )
CALL iom_delay_rst( 'READ', 'ABL', numrar ) ! read only abl delayed global communication variables
Index: /NEMO/branches/2020/r12377_ticket2386/src/ABL/par_abl.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/ABL/par_abl.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/ABL/par_abl.F90 (revision 13540)
@@ -28,9 +28,11 @@
LOGICAL , PUBLIC :: ln_hpgls_frc !: forcing of ABL winds by large-scale pressure gradient
LOGICAL , PUBLIC :: ln_smth_pblh !: smoothing of atmospheric PBL height
+ !LOGICAL , PUBLIC :: ln_topbc_neumann = .FALSE. !: idealised testcases only
- CHARACTER(len=256), PUBLIC :: cn_ablrst_in !: suffix of abl restart name (input)
- CHARACTER(len=256), PUBLIC :: cn_ablrst_out !: suffix of abl restart name (output)
- CHARACTER(len=256), PUBLIC :: cn_ablrst_indir !: abl restart input directory
- CHARACTER(len=256), PUBLIC :: cn_ablrst_outdir !: abl restart output directory
+ LOGICAL , PUBLIC :: ln_rstart_abl !: (de)activate abl restart
+ CHARACTER(len=256), PUBLIC :: cn_ablrst_in !: suffix of abl restart name (input)
+ CHARACTER(len=256), PUBLIC :: cn_ablrst_out !: suffix of abl restart name (output)
+ CHARACTER(len=256), PUBLIC :: cn_ablrst_indir !: abl restart input directory
+ CHARACTER(len=256), PUBLIC :: cn_ablrst_outdir !: abl restart output directory
!!---------------------------------------------------------------------
@@ -45,10 +47,12 @@
REAL(wp), PUBLIC, PARAMETER :: rn_Cek = 258._wp !: Ekman constant for Richardson number
REAL(wp), PUBLIC, PARAMETER :: rn_epssfc = 1._wp / ( 1._wp + 2.8_wp * 2.8_wp )
- REAL(wp), PUBLIC :: rn_ceps !: namelist parameter
- REAL(wp), PUBLIC :: rn_cm !: namelist parameter
- REAL(wp), PUBLIC :: rn_ct !: namelist parameter
- REAL(wp), PUBLIC :: rn_ce !: namelist parameter
+ REAL(wp), PUBLIC :: rn_Ceps !: namelist parameter
+ REAL(wp), PUBLIC :: rn_Cm !: namelist parameter
+ REAL(wp), PUBLIC :: rn_Ct !: namelist parameter
+ REAL(wp), PUBLIC :: rn_Ce !: namelist parameter
REAL(wp), PUBLIC :: rn_Rod !: namelist parameter
REAL(wp), PUBLIC :: rn_Sch
+ REAL(wp), PUBLIC :: rn_Esfc
+ REAL(wp), PUBLIC :: rn_Lsfc
REAL(wp), PUBLIC :: mxl_min
REAL(wp), PUBLIC :: rn_ldyn_min !: namelist parameter
Index: /NEMO/branches/2020/r12377_ticket2386/src/ABL/sbcabl.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/ABL/sbcabl.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/ABL/sbcabl.F90 (revision 13540)
@@ -68,16 +68,16 @@
LOGICAL :: lluldl
NAMELIST/namsbc_abl/ cn_dir, cn_dom, cn_ablrst_in, cn_ablrst_out, &
- & cn_ablrst_indir, cn_ablrst_outdir, &
+ & cn_ablrst_indir, cn_ablrst_outdir, ln_rstart_abl, &
& ln_hpgls_frc, ln_geos_winds, nn_dyn_restore, &
& rn_ldyn_min , rn_ldyn_max, rn_ltra_min, rn_ltra_max, &
- & nn_amxl, rn_cm, rn_ct, rn_ce, rn_ceps, rn_Rod, rn_Ric, &
+ & nn_amxl, rn_Cm, rn_Ct, rn_Ce, rn_Ceps, rn_Rod, rn_Ric, &
& ln_smth_pblh
!!---------------------------------------------------------------------
- REWIND( numnam_ref ) ! Namelist namsbc_abl in reference namelist : ABL parameters
+ ! Namelist namsbc_abl in reference namelist : ABL parameters
READ ( numnam_ref, namsbc_abl, IOSTAT = ios, ERR = 901 )
901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_abl in reference namelist' )
!
- REWIND( numnam_cfg ) ! Namelist namsbc_abl in configuration namelist : ABL parameters
+ ! Namelist namsbc_abl in configuration namelist : ABL parameters
READ ( numnam_cfg, namsbc_abl, IOSTAT = ios, ERR = 902 )
902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_abl in configuration namelist' )
@@ -166,4 +166,6 @@
rn_Sch = rn_ce / rn_cm
mxl_min = (avm_bak / rn_cm) / sqrt( tke_min )
+ rn_Esfc = 1._wp / SQRT(rn_cm*rn_ceps)
+ rn_Lsfc = vkarmn * SQRT(SQRT(rn_cm*rn_ceps)) / rn_cm
IF(lwp) THEN
@@ -172,5 +174,7 @@
WRITE(numout,*) ' ~~~~~~~~~~~'
IF(nn_amxl==0) WRITE(numout,*) 'Deardorff 80 length-scale '
- IF(nn_amxl==1) WRITE(numout,*) 'length-scale based on the distance to the PBL height '
+ IF(nn_amxl==1) WRITE(numout,*) 'Modified Deardorff 80 length-scale '
+ IF(nn_amxl==2) WRITE(numout,*) 'Bougeault and Lacarrere length-scale '
+ IF(nn_amxl==3) WRITE(numout,*) 'Rodier et al. length-scale '
WRITE(numout,*) ' Minimum value of atmospheric TKE = ',tke_min,' m^2 s^-2'
WRITE(numout,*) ' Minimum value of atmospheric mixing length = ',mxl_min,' m'
@@ -179,4 +183,6 @@
WRITE(numout,*) ' Constant for Schmidt number = ',rn_Sch
WRITE(numout,*) ' Constant for TKE dissipation = ',rn_Ceps
+ WRITE(numout,*) ' Constant for TKE sfc boundary condition = ',rn_Esfc
+ WRITE(numout,*) ' Constant for mxl sfc boundary condition = ',rn_Lsfc
END IF
@@ -203,4 +209,5 @@
! ABL timestep
rDt_abl = nn_fsbc * rn_Dt
+ IF(lwp) WRITE(numout,*) ' ABL timestep = ', rDt_abl,' s'
! Check parameters for dynamics
@@ -249,7 +256,4 @@
zcff = 2._wp * omega * SIN( rad * 90._wp ) !++ fmax
rest_eq(:,:) = SIN( 0.5_wp*rpi*( (fft_abl(:,:) - zcff) / zcff ) )**8
- !!GS: alternative shape
- !rest_eq(:,:) = SIN( 0.5_wp*rpi*(zcff - ABS(ff_t(:,:))) / (zcff - 3.e-5) )**8
- !WHERE(ABS(ff_t(:,:)).LE.3.e-5) rest_eq(:,:) = 1._wp
ELSE
rest_eq(:,:) = 1._wp
@@ -264,15 +268,14 @@
! Initialize the time index for now time (nt_n) and after time (nt_a)
- nt_n = 1 + MOD( nit000 , 2)
- nt_a = 1 + MOD( nit000+1, 2)
+ nt_n = 1; nt_a = 2
! initialize ABL from data or restart
- IF( ln_rstart ) THEN
+ IF( ln_rstart_abl ) THEN
CALL abl_rst_read
ELSE
CALL fld_read( nit000, nn_fsbc, sf ) ! input fields provided at the first time-step
- u_abl(:,:,:,nt_n ) = sf(jp_wndi)%fnow(:,:,:)
- v_abl(:,:,:,nt_n ) = sf(jp_wndj)%fnow(:,:,:)
+ u_abl(:,:,:,nt_n ) = sf(jp_wndi)%fnow(:,:,:)
+ v_abl(:,:,:,nt_n ) = sf(jp_wndj)%fnow(:,:,:)
tq_abl(:,:,:,nt_n,jp_ta) = sf(jp_tair)%fnow(:,:,:)
tq_abl(:,:,:,nt_n,jp_qa) = sf(jp_humi)%fnow(:,:,:)
@@ -281,5 +284,4 @@
avm_abl(:,:,: ) = avm_bak
avt_abl(:,:,: ) = avt_bak
- mxl_abl(:,:,: ) = mxl_min
pblh (:,: ) = ghw_abl( 3 ) !<-- assume that the pbl contains 3 grid points
u_abl (:,:,:,nt_a ) = 0._wp
@@ -287,7 +289,8 @@
tq_abl (:,:,:,nt_a,: ) = 0._wp
tke_abl(:,:,:,nt_a ) = 0._wp
+
+ mxlm_abl(:,:,: ) = mxl_min
+ mxld_abl(:,:,: ) = mxl_min
ENDIF
-
- rhoa(:,:) = rho_air( tq_abl(:,:,2,nt_n,jp_ta), tq_abl(:,:,2,nt_n,jp_qa), sf(jp_slp)%fnow(:,:,1) ) !!GS: rhoa must be (re)computed here here to avoid division by zero in blk_ice_1 (TBI)
END SUBROUTINE sbc_abl_init
@@ -330,55 +333,59 @@
CALL fld_read( kt, nn_fsbc, sf ) ! input fields provided at the current time-step
- !!-------------------------------------------------------------------------------------------
- !! 2 - Compute Cd x ||U||, Ch x ||U||, Ce x ||U||, and SSQ using now fields
- !!-------------------------------------------------------------------------------------------
-
- 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_qsr )%fnow(:,:,1) , sf(jp_qlw )%fnow(:,:,1) , & ! <<= in
- & tsk_m, zssq, zcd_du, zsen, zevp ) ! =>> out
-
-#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
- & pseni=zseni, pevpi=zevpi, pssqi=zssqi, pcd_dui=zcd_dui ) ! <<= out
-#endif
-
- !!-------------------------------------------------------------------------------------------
- !! 3 - Advance ABL variables from now (n) to after (n+1)
- !!-------------------------------------------------------------------------------------------
-
- CALL abl_stp( kt, tsk_m, 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
- & sf(jp_hpgi)%fnow(:,:,:), sf(jp_hpgj)%fnow(:,:,:), & ! <<= in
- & zcd_du, zsen, zevp, & ! <=> in/out
- & 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
- & , utau_ice, vtau_ice & ! =>> out
-#endif
- & )
- !!-------------------------------------------------------------------------------------------
- !! 4 - Finalize flux computation using ABL variables at (n+1), nt_n corresponds to (n+1) since
- !! time swap is done in abl_stp
- !!-------------------------------------------------------------------------------------------
-
- CALL blk_oce_2( tq_abl(:,:,2,nt_n,jp_ta), &
- & sf(jp_qsr )%fnow(:,:,1) , sf(jp_qlw )%fnow(:,:,1), &
- & sf(jp_prec)%fnow(:,:,1) , sf(jp_snow)%fnow(:,:,1), &
- & tsk_m, zsen, zevp )
-
- CALL abl_rst_opn( kt ) ! Open abl restart file (if necessary)
- IF( lrst_abl ) CALL abl_rst_write( kt ) ! -- abl restart file
-
-#if defined key_si3
- ! Avoid a USE abl in icesbc module
- sf(jp_tair)%fnow(:,:,1) = tq_abl(:,:,2,nt_n,jp_ta); sf(jp_humi)%fnow(:,:,1) = tq_abl(:,:,2,nt_n,jp_qa)
-#endif
+ IF( MOD( kt - 1, nn_fsbc ) == 0 ) THEN
+
+ !!-------------------------------------------------------------------------------------------
+ !! 2 - Compute Cd x ||U||, Ch x ||U||, Ce x ||U||, and SSQ using now fields
+ !!-------------------------------------------------------------------------------------------
+
+ 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_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, zevp ) ! =>> out
+
+#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
+ & pseni=zseni, pevpi=zevpi, pssqi=zssqi, pcd_dui=zcd_dui ) ! <<= out
+#endif
+
+ !!-------------------------------------------------------------------------------------------
+ !! 3 - Advance ABL variables from now (n) to after (n+1)
+ !!-------------------------------------------------------------------------------------------
+
+ CALL abl_stp( kt, tsk_m, 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
+ & sf(jp_hpgi)%fnow(:,:,:), sf(jp_hpgj)%fnow(:,:,:), & ! <<= in
+ & zcd_du, zsen, zevp, & ! <=> in/out
+ & 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
+ & , utau_ice, vtau_ice & ! =>> out
+#endif
+ & )
+ !!-------------------------------------------------------------------------------------------
+ !! 4 - Finalize flux computation using ABL variables at (n+1), nt_n corresponds to (n+1) since
+ !! time swap is done in abl_stp
+ !!-------------------------------------------------------------------------------------------
+
+ CALL blk_oce_2( tq_abl(:,:,2,nt_n,jp_ta), &
+ & sf(jp_qsr )%fnow(:,:,1) , sf(jp_qlw )%fnow(:,:,1), &
+ & sf(jp_prec)%fnow(:,:,1) , sf(jp_snow)%fnow(:,:,1), &
+ & tsk_m, zsen, zevp )
+
+ CALL abl_rst_opn( kt ) ! Open abl restart file (if necessary)
+ IF( lrst_abl ) CALL abl_rst_write( kt ) ! -- abl restart file
+
+#if defined key_si3
+ ! Avoid a USE abl in icesbc module
+ sf(jp_tair)%fnow(:,:,1) = tq_abl(:,:,2,nt_n,jp_ta); sf(jp_humi)%fnow(:,:,1) = tq_abl(:,:,2,nt_n,jp_qa)
+#endif
+ END IF
END SUBROUTINE sbc_abl
Index: /NEMO/branches/2020/r12377_ticket2386/src/ICE/ice.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/ICE/ice.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/ICE/ice.F90 (revision 13540)
@@ -70,4 +70,5 @@
!! a_ip | - | Ice pond concentration | |
!! v_ip | - | Ice pond volume per unit area| m |
+ !! v_il | v_il_1d | Ice pond lid volume per area | m |
!! |
!!-------------|-------------|---------------------------------|-------|
@@ -85,4 +86,5 @@
!! t_su ! t_su_1d | Sea ice surface temperature ! K |
!! h_ip | h_ip_1d | Ice pond thickness | m |
+ !! h_il | h_il_1d | Ice pond lid thickness | m |
!! |
!! notes: the ice model only sees a bulk (i.e., vertically averaged) |
@@ -112,4 +114,6 @@
!! hm_ip | - | Mean ice pond depth | m |
!! vt_ip | - | Total ice pond vol. per unit area| m |
+ !! hm_il | - | Mean ice pond lid depth | m |
+ !! vt_il | - | Total ice pond lid vol. per area | m |
!!=====================================================================
@@ -137,8 +141,8 @@
REAL(wp), PUBLIC :: rn_ishlat !: lateral boundary condition for sea-ice
LOGICAL , PUBLIC :: ln_landfast_L16 !: landfast ice parameterizationfrom lemieux2016
- REAL(wp), PUBLIC :: rn_depfra !: fraction of ocean depth that ice must reach to initiate landfast ice
- REAL(wp), PUBLIC :: rn_icebfr !: maximum bottom stress per unit area of contact (lemieux2016) or per unit volume (home)
- REAL(wp), PUBLIC :: rn_lfrelax !: relaxation time scale (s-1) to reach static friction
- REAL(wp), PUBLIC :: rn_tensile !: isotropic tensile strength
+ REAL(wp), PUBLIC :: rn_lf_depfra !: fraction of ocean depth that ice must reach to initiate landfast ice
+ REAL(wp), PUBLIC :: rn_lf_bfr !: maximum bottom stress per unit area of contact (lemieux2016) or per unit volume (home)
+ REAL(wp), PUBLIC :: rn_lf_relax !: relaxation time scale (s-1) to reach static friction
+ REAL(wp), PUBLIC :: rn_lf_tensile !: isotropic tensile strength
!
! !!** ice-ridging/rafting namelist (namdyn_rdgrft) **
@@ -151,4 +155,5 @@
INTEGER , PUBLIC :: nn_nevp !: number of iterations for subcycling
REAL(wp), PUBLIC :: rn_relast !: ratio => telast/rDt_ice (1/3 or 1/9 depending on nb of subcycling nevp)
+ INTEGER , PUBLIC :: nn_rhg_chkcvg !: check ice rheology convergence
!
! !!** ice-advection namelist (namdyn_adv) **
@@ -158,5 +163,10 @@
! !!** ice-surface boundary conditions namelist (namsbc) **
! -- icethd_dh -- !
- REAL(wp), PUBLIC :: rn_blow_s !: coef. for partitioning of snowfall between leads and sea ice
+ REAL(wp), PUBLIC :: rn_snwblow !: coef. for partitioning of snowfall between leads and sea ice
+ ! -- icethd_zdf and icealb -- !
+ INTEGER , PUBLIC :: nn_snwfra !: calculate the fraction of ice covered by snow
+ ! ! = 0 fraction = 1 (if snow) or 0 (if no snow)
+ ! ! = 1 fraction = 1-exp(-0.2*rhos*hsnw) [MetO formulation]
+ ! ! = 2 fraction = hsnw / (hsnw+0.02) [CICE formulation]
! -- icethd -- !
REAL(wp), PUBLIC :: rn_cio !: drag coefficient for oceanic stress
@@ -166,4 +176,5 @@
! ! = 1 Average N(cat) fluxes then redistribute over the N(cat) ice using T-ice and albedo sensitivity
! ! = 2 Redistribute a single flux over categories
+ ! -- icethd_zdf -- !
LOGICAL , PUBLIC :: ln_cndflx !: use conduction flux as surface boundary condition (instead of qsr and qns)
LOGICAL , PUBLIC :: ln_cndemulate !: emulate conduction flux (if not provided)
@@ -172,10 +183,17 @@
INTEGER, PUBLIC, PARAMETER :: np_cnd_ON = 1 !: forcing from conduction flux (SM0L) (compute qcn and qsr_tr via sbcblk.F90 or sbccpl.F90)
INTEGER, PUBLIC, PARAMETER :: np_cnd_EMU = 2 !: emulate conduction flux via icethd_zdf.F90 (BL99) (1st round compute qcn and qsr_tr, 2nd round use it)
-
+ INTEGER, PUBLIC :: nn_qtrice !: Solar flux transmitted thru the surface scattering layer:
+ ! ! = 0 Grenfell and Maykut 1977 (depends on cloudiness and is 0 when there is snow)
+ ! ! = 1 Lebrun 2019 (equals 0.3 anytime with different melting/dry snw conductivities)
+ !
! !!** ice-vertical diffusion namelist (namthd_zdf) **
LOGICAL , PUBLIC :: ln_cndi_U64 !: thermal conductivity: Untersteiner (1964)
LOGICAL , PUBLIC :: ln_cndi_P07 !: thermal conductivity: Pringle et al (2007)
- REAL(wp), PUBLIC :: rn_kappa_i !: coef. for the extinction of radiation Grenfell et al. (2006) [1/m]
REAL(wp), PUBLIC :: rn_cnd_s !: thermal conductivity of the snow [W/m/K]
+ REAL(wp), PUBLIC :: rn_kappa_i !: coef. for the extinction of radiation in sea ice, Grenfell et al. (2006) [1/m]
+ REAL(wp), PUBLIC :: rn_kappa_s !: coef. for the extinction of radiation in snw (nn_qtrice=0) [1/m]
+ REAL(wp), PUBLIC :: rn_kappa_smlt !: coef. for the extinction of radiation in melt snw (nn_qtrice=1) [1/m]
+ REAL(wp), PUBLIC :: rn_kappa_sdry !: coef. for the extinction of radiation in dry snw (nn_qtrice=1) [1/m]
+ LOGICAL , PUBLIC :: ln_zdf_chkcvg !: check convergence of heat diffusion scheme
! !!** ice-salinity namelist (namthd_sal) **
@@ -190,8 +208,11 @@
! !!** ice-ponds namelist (namthd_pnd)
LOGICAL , PUBLIC :: ln_pnd !: Melt ponds (T) or not (F)
- LOGICAL , PUBLIC :: ln_pnd_H12 !: Melt ponds scheme from Holland et al 2012
+ LOGICAL , PUBLIC :: ln_pnd_LEV !: Melt ponds scheme from Holland et al (2012), Flocco et al (2007, 2010)
+ REAL(wp), PUBLIC :: rn_apnd_min !: Minimum ice fraction that contributes to melt ponds
+ REAL(wp), PUBLIC :: rn_apnd_max !: Maximum ice fraction that contributes to melt ponds
LOGICAL , PUBLIC :: ln_pnd_CST !: Melt ponds scheme with constant fraction and depth
REAL(wp), PUBLIC :: rn_apnd !: prescribed pond fraction (0 g.m-2.s-1]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_bom !: salt flux due to ice bottom melt [pss.kg.m-2.s-1 => g.m-2.s-1]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_lam !: salt flux due to ice lateral melt [pss.kg.m-2.s-1 => g.m-2.s-1]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_sum !: salt flux due to ice surface melt [pss.kg.m-2.s-1 => g.m-2.s-1]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_sni !: salt flux due to snow-ice growth [pss.kg.m-2.s-1 => g.m-2.s-1]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_opw !: salt flux due to growth in open water [pss.kg.m-2.s-1 => g.m-2.s-1]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_bri !: salt flux due to brine rejection [pss.kg.m-2.s-1 => g.m-2.s-1]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_dyn !: salt flux due to porous ridged ice formation [pss.kg.m-2.s-1 => g.m-2.s-1]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_res !: salt flux due to correction on ice thick. (residual) [pss.kg.m-2.s-1 => g.m-2.s-1]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_sub !: salt flux due to ice sublimation [pss.kg.m-2.s-1 => g.m-2.s-1]
-
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_bog !: total heat flux causing bottom ice growth [W.m-2]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_bom !: total heat flux causing bottom ice melt [W.m-2]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_sum !: total heat flux causing surface ice melt [W.m-2]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_opw !: total heat flux causing open water ice formation [W.m-2]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_dif !: total heat flux causing Temp change in the ice [W.m-2]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_snw !: heat flux for snow melt [W.m-2]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_err_dif !: heat flux remaining due to change in non-solar flux [W.m-2]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_err_rem !: heat flux error after heat remapping => must be 0 [W.m-2]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qt_atm_oi !: heat flux at the interface atm-[oce+ice] [W.m-2]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qt_oce_ai !: heat flux at the interface oce-[atm+ice] [W.m-2]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_oce,v_oce !: surface ocean velocity used in ice dynamics
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ht_i_new !: ice collection thickness accreted in leads
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: strength !: ice strength
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: stress1_i, stress2_i, stress12_i !: 1st, 2nd & diagonal stress tensor element
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: delta_i !: ice rheology elta factor (Flato & Hibler 95) [s-1]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: divu_i !: Divergence of the velocity field [s-1]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: shear_i !: Shear of the velocity field [s-1]
+ !
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: t_bo !: Sea-Ice bottom temperature [Kelvin]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qlead !: heat balance of the lead (or of the open ocean)
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qsb_ice_bot !: net downward heat flux from the ice to the ocean
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fhld !: heat flux from the lead used for bottom melting
+
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_snw !: mass flux from snow-ocean mass exchange [kg.m-2.s-1]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_snw_sni !: mass flux from snow ice growth component of wfx_snw [kg.m-2.s-1]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_snw_sum !: mass flux from surface melt component of wfx_snw [kg.m-2.s-1]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_pnd !: mass flux from melt pond-ocean mass exchange [kg.m-2.s-1]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_spr !: mass flux from snow precipitation on ice [kg.m-2.s-1]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_sub !: mass flux from sublimation of snow/ice [kg.m-2.s-1]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_snw_sub !: mass flux from snow sublimation [kg.m-2.s-1]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_ice_sub !: mass flux from ice sublimation [kg.m-2.s-1]
+
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_snw_dyn !: mass flux from dynamical component of wfx_snw [kg.m-2.s-1]
+
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_ice !: mass flux from ice-ocean mass exchange [kg.m-2.s-1]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_sni !: mass flux from snow ice growth component of wfx_ice [kg.m-2.s-1]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_opw !: mass flux from lateral ice growth component of wfx_ice [kg.m-2.s-1]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_bog !: mass flux from bottom ice growth component of wfx_ice [kg.m-2.s-1]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_dyn !: mass flux from dynamical ice growth component of wfx_ice [kg.m-2.s-1]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_bom !: mass flux from bottom melt component of wfx_ice [kg.m-2.s-1]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_sum !: mass flux from surface melt component of wfx_ice [kg.m-2.s-1]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_lam !: mass flux from lateral melt component of wfx_ice [kg.m-2.s-1]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_res !: mass flux from residual component of wfx_ice [kg.m-2.s-1]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_err_sub !: mass flux error after sublimation [kg.m-2.s-1]
+
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_bog !: salt flux due to ice bottom growth [pss.kg.m-2.s-1 => g.m-2.s-1]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_bom !: salt flux due to ice bottom melt [pss.kg.m-2.s-1 => g.m-2.s-1]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_lam !: salt flux due to ice lateral melt [pss.kg.m-2.s-1 => g.m-2.s-1]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_sum !: salt flux due to ice surface melt [pss.kg.m-2.s-1 => g.m-2.s-1]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_sni !: salt flux due to snow-ice growth [pss.kg.m-2.s-1 => g.m-2.s-1]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_opw !: salt flux due to growth in open water [pss.kg.m-2.s-1 => g.m-2.s-1]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_bri !: salt flux due to brine rejection [pss.kg.m-2.s-1 => g.m-2.s-1]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_dyn !: salt flux due to porous ridged ice formation [pss.kg.m-2.s-1 => g.m-2.s-1]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_res !: salt flux due to correction on ice thick. (residual) [pss.kg.m-2.s-1 => g.m-2.s-1]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_sub !: salt flux due to ice sublimation [pss.kg.m-2.s-1 => g.m-2.s-1]
+
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_bog !: total heat flux causing bottom ice growth [W.m-2]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_bom !: total heat flux causing bottom ice melt [W.m-2]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_sum !: total heat flux causing surface ice melt [W.m-2]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_opw !: total heat flux causing open water ice formation [W.m-2]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_dif !: total heat flux causing Temp change in the ice [W.m-2]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_snw !: heat flux for snow melt [W.m-2]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_err_dif !: heat flux remaining due to change in non-solar flux [W.m-2]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qt_atm_oi !: heat flux at the interface atm-[oce+ice] [W.m-2]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qt_oce_ai !: heat flux at the interface oce-[atm+ice] [W.m-2]
! heat flux associated with ice-atmosphere mass exchange
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_sub !: heat flux for sublimation [W.m-2]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_spr !: heat flux of the snow precipitation [W.m-2]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_sub !: heat flux for sublimation [W.m-2]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_spr !: heat flux of the snow precipitation [W.m-2]
! heat flux associated with ice-ocean mass exchange
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_thd !: ice-ocean heat flux from thermo processes (icethd_dh) [W.m-2]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_dyn !: ice-ocean heat flux from ridging [W.m-2]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_res !: heat flux due to correction on ice thick. (residual) [W.m-2]
-
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rn_amax_2d !: maximum ice concentration 2d array
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qtr_ice_bot !: transmitted solar radiation under ice
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: t1_ice !: temperature of the first layer (ln_cndflx=T) [K]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: cnd_ice !: effective conductivity at the top of ice/snow (ln_cndflx=T) [W.m-2.K-1]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_thd !: ice-ocean heat flux from thermo processes (icethd_dh) [W.m-2]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_dyn !: ice-ocean heat flux from ridging [W.m-2]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_res !: heat flux due to correction on ice thick. (residual) [W.m-2]
+
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rn_amax_2d !: maximum ice concentration 2d array
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qtr_ice_bot !: transmitted solar radiation under ice
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: t1_ice !: temperature of the first layer (ln_cndflx=T) [K]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: cnd_ice !: effective conductivity of the 1st layer (ln_cndflx=T) [W.m-2.K-1]
!!----------------------------------------------------------------------
@@ -293,87 +313,92 @@
!!----------------------------------------------------------------------
!! Variables defined for each ice category
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: h_i !: Ice thickness (m)
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_i !: Ice fractional areas (concentration)
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: v_i !: Ice volume per unit area (m)
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: v_s !: Snow volume per unit area (m)
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: h_s !: Snow thickness (m)
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: t_su !: Sea-Ice Surface Temperature (K)
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: s_i !: Sea-Ice Bulk salinity (pss)
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sv_i !: Sea-Ice Bulk salinity * volume per area (pss.m)
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: o_i !: Sea-Ice Age (s)
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: oa_i !: Sea-Ice Age times ice area (s)
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: bv_i !: brine volume
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: h_i !: Ice thickness (m)
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_i !: Ice fractional areas (concentration)
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: v_i !: Ice volume per unit area (m)
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: v_s !: Snow volume per unit area (m)
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: h_s !: Snow thickness (m)
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: t_su !: Sea-Ice Surface Temperature (K)
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: s_i !: Sea-Ice Bulk salinity (pss)
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sv_i !: Sea-Ice Bulk salinity * volume per area (pss.m)
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: o_i !: Sea-Ice Age (s)
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: oa_i !: Sea-Ice Age times ice area (s)
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: bv_i !: brine volume
!! Variables summed over all categories, or associated to all the ice in a single grid cell
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_ice, v_ice !: components of the ice velocity (m/s)
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: vt_i , vt_s !: ice and snow total volume per unit area (m)
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: st_i !: Total ice salinity content (pss.m)
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: at_i !: ice total fractional area (ice concentration)
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ato_i !: =1-at_i ; total open water fractional area
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: et_i , et_s !: ice and snow total heat content (J/m2)
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tm_i !: mean ice temperature over all categories (K)
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tm_s !: mean snw temperature over all categories (K)
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: bvm_i !: brine volume averaged over all categories
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sm_i !: mean sea ice salinity averaged over all categories (pss)
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tm_su !: mean surface temperature over all categories (K)
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hm_i !: mean ice thickness over all categories (m)
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hm_s !: mean snow thickness over all categories (m)
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: om_i !: mean ice age over all categories (s)
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tau_icebfr !: ice friction on ocean bottom (landfast param activated)
-
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: t_s !: Snow temperatures [K]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: e_s !: Snow enthalpy [J/m2]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: t_i !: ice temperatures [K]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: e_i !: ice enthalpy [J/m2]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: sz_i !: ice salinity [PSS]
-
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_ip !: melt pond concentration
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: v_ip !: melt pond volume per grid cell area [m]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_ip_frac !: melt pond fraction (a_ip/a_i)
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: h_ip !: melt pond depth [m]
-
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: at_ip !: total melt pond concentration
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hm_ip !: mean melt pond depth [m]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: vt_ip !: total melt pond volume per gridcell area [m]
-
- !!----------------------------------------------------------------------
- !! * Old values of global variables
- !!----------------------------------------------------------------------
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: v_s_b, v_i_b, h_s_b, h_i_b, h_ip_b !: snow and ice volumes/thickness
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_i_b, sv_i_b, oa_i_b !:
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: e_s_b !: snow heat content
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: e_i_b !: ice temperatures
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_ice_b, v_ice_b !: ice velocity
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: at_i_b !: ice concentration (total)
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_ice, v_ice !: components of the ice velocity (m/s)
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: vt_i , vt_s !: ice and snow total volume per unit area (m)
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: st_i !: Total ice salinity content (pss.m)
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: at_i !: ice total fractional area (ice concentration)
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ato_i !: =1-at_i ; total open water fractional area
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: et_i , et_s !: ice and snow total heat content (J/m2)
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tm_i !: mean ice temperature over all categories (K)
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tm_s !: mean snw temperature over all categories (K)
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: bvm_i !: brine volume averaged over all categories
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sm_i !: mean sea ice salinity averaged over all categories (pss)
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tm_su !: mean surface temperature over all categories (K)
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hm_i !: mean ice thickness over all categories (m)
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hm_s !: mean snow thickness over all categories (m)
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: om_i !: mean ice age over all categories (s)
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tau_icebfr !: ice friction on ocean bottom (landfast param activated)
+
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: t_s !: Snow temperatures [K]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: e_s !: Snow enthalpy [J/m2]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: t_i !: ice temperatures [K]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: e_i !: ice enthalpy [J/m2]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: sz_i !: ice salinity [PSS]
+
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_ip !: melt pond concentration
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: v_ip !: melt pond volume per grid cell area [m]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_ip_frac !: melt pond fraction (a_ip/a_i)
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_ip_eff !: melt pond effective fraction (not covered up by lid) (a_ip/a_i)
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: h_ip !: melt pond depth [m]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: v_il !: melt pond lid volume [m]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: h_il !: melt pond lid thickness [m]
+
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: at_ip !: total melt pond concentration
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hm_ip !: mean melt pond depth [m]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: vt_ip !: total melt pond volume per gridcell area [m]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hm_il !: mean melt pond lid depth [m]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: vt_il !: total melt pond lid volume per gridcell area [m]
+
+ !!----------------------------------------------------------------------
+ !! * Global variables at before time step
+ !!----------------------------------------------------------------------
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: v_s_b, v_i_b, h_s_b, h_i_b !: snow and ice volumes/thickness
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_i_b, sv_i_b !:
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: e_s_b !: snow heat content
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: e_i_b !: ice temperatures
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_ice_b, v_ice_b !: ice velocity
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: at_i_b !: ice concentration (total)
!!----------------------------------------------------------------------
!! * Ice thickness distribution variables
!!----------------------------------------------------------------------
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hi_max !: Boundary of ice thickness categories in thickness space
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hi_mean !: Mean ice thickness in catgories
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hi_max !: Boundary of ice thickness categories in thickness space
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hi_mean !: Mean ice thickness in catgories
!
!!----------------------------------------------------------------------
!! * Ice diagnostics
!!----------------------------------------------------------------------
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_trp_vi !: transport of ice volume
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_trp_vs !: transport of snw volume
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_trp_ei !: transport of ice enthalpy [W/m2]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_trp_es !: transport of snw enthalpy [W/m2]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_trp_sv !: transport of salt content
- !
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_heat !: snw/ice heat content variation [W/m2]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_sice !: ice salt content variation []
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_vice !: ice volume variation [m/s]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_vsnw !: snw volume variation [m/s]
-
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_trp_vi !: transport of ice volume
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_trp_vs !: transport of snw volume
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_trp_ei !: transport of ice enthalpy [W/m2]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_trp_es !: transport of snw enthalpy [W/m2]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_trp_sv !: transport of salt content
+ !
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_heat !: snw/ice heat content variation [W/m2]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_sice !: ice salt content variation []
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_vice !: ice volume variation [m/s]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_vsnw !: snw volume variation [m/s]
+ !
!!----------------------------------------------------------------------
!! * Ice conservation
!!----------------------------------------------------------------------
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_v !: conservation of ice volume
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_s !: conservation of ice salt
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_t !: conservation of ice heat
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_fv !: conservation of ice volume
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_fs !: conservation of ice salt
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_ft !: conservation of ice heat
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_v !: conservation of ice volume
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_s !: conservation of ice salt
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_t !: conservation of ice heat
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_fv !: conservation of ice volume
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_fs !: conservation of ice salt
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_ft !: conservation of ice heat
!
!!----------------------------------------------------------------------
@@ -381,9 +406,8 @@
!!----------------------------------------------------------------------
! Extra sea ice diagnostics to address the data request
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: t_si !: Temperature at Snow-ice interface (K)
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tm_si !: mean temperature at the snow-ice interface (K)
- 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)
-
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: t_si !: Temperature at Snow-ice interface (K)
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tm_si !: mean temperature at the snow-ice interface (K)
+ 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)
!
!!----------------------------------------------------------------------
@@ -424,5 +448,5 @@
& 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) , hfx_err_rem(jpi,jpj) , wfx_err_sub(jpi,jpj) , STAT=ierr(ii) )
+ & hfx_err_dif(jpi,jpj) , wfx_err_sub(jpi,jpj) , STAT=ierr(ii) )
! * Ice global state variables
@@ -448,14 +472,15 @@
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) , STAT = ierr(ii) )
-
- ii = ii + 1
- ALLOCATE( at_ip(jpi,jpj) , hm_ip(jpi,jpj) , vt_ip(jpi,jpj) , STAT = ierr(ii) )
+ 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) , 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) )
! * Old values of global variables
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), h_ip_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) , &
- & oa_i_b(jpi,jpj,jpl) , STAT=ierr(ii) )
+ 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), &
+ & 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) )
ii = ii + 1
@@ -484,4 +509,5 @@
IF( ice_alloc /= 0 ) CALL ctl_stop( 'STOP', 'ice_alloc: failed to allocate arrays.' )
!
+
END FUNCTION ice_alloc
Index: /NEMO/branches/2020/r12377_ticket2386/src/ICE/ice1d.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/ICE/ice1d.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/ICE/ice1d.F90 (revision 13540)
@@ -51,5 +51,4 @@
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hfx_snw_1d
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hfx_dyn_1d
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hfx_err_rem_1d
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hfx_err_dif_1d
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: qt_oce_ai_1d
@@ -124,8 +123,9 @@
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: oa_i_1d !:
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: o_i_1d !:
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: a_ip_1d !:
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: a_ip_1d !: ice ponds
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: v_ip_1d !:
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: h_ip_1d !:
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: a_ip_frac_1d !:
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: v_il_1d !: Ice pond lid
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: h_il_1d !:
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: t_s_1d !: corresponding to the 2D var t_s
@@ -146,4 +146,7 @@
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sss_1d
+ ! convergence check
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: tice_cvgerr_1d !: convergence of ice/snow temp (dT) [K]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: tice_cvgstp_1d !: convergence of ice/snow temp (subtimestep) [-]
!
!!----------------------
@@ -157,4 +160,5 @@
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: a_ip_2d
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: v_ip_2d
+ 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
@@ -175,5 +179,5 @@
!!---------------------------------------------------------------------!
INTEGER :: ice1D_alloc ! return value
- INTEGER :: ierr(7), ii
+ INTEGER :: ierr(8), ii
!!---------------------------------------------------------------------!
ierr(:) = 0
@@ -189,5 +193,5 @@
& hfx_thd_1d(jpij) , hfx_spr_1d (jpij) , &
& hfx_snw_1d(jpij) , hfx_sub_1d (jpij) , &
- & hfx_res_1d(jpij) , hfx_err_rem_1d(jpij) , hfx_err_dif_1d(jpij) , qt_oce_ai_1d(jpij), STAT=ierr(ii) )
+ & hfx_res_1d(jpij) , hfx_err_dif_1d(jpij) , qt_oce_ai_1d(jpij), STAT=ierr(ii) )
!
ii = ii + 1
@@ -208,6 +212,6 @@
& 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) , &
- & h_ip_1d (jpij) , a_ip_frac_1d(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) )
!
@@ -224,7 +228,10 @@
!
ii = ii + 1
+ ALLOCATE( tice_cvgerr_1d(jpij) , tice_cvgstp_1d(jpij) , STAT=ierr(ii) )
+ !
+ 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) , &
+ & a_ip_2d(jpij,jpl) , v_ip_2d(jpij,jpl) , t_su_2d(jpij,jpl) , v_il_2d(jpij,jpl) , &
& STAT=ierr(ii) )
Index: /NEMO/branches/2020/r12377_ticket2386/src/ICE/icealb.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/ICE/icealb.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/ICE/icealb.F90 (revision 13540)
@@ -14,7 +14,8 @@
!! ice_alb_init : initialisation of albedo computation
!!----------------------------------------------------------------------
- USE ice, ONLY: jpl ! sea-ice: number of categories
USE phycst ! physical constants
USE dom_oce ! domain: ocean
+ USE ice, ONLY: jpl ! sea-ice: number of categories
+ USE icevar ! sea-ice: operations
!
USE in_out_manager ! I/O manager
@@ -47,5 +48,5 @@
CONTAINS
- SUBROUTINE ice_alb( pt_su, ph_ice, ph_snw, ld_pnd_alb, pafrac_pnd, ph_pnd, palb_cs, palb_os )
+ SUBROUTINE ice_alb( pt_su, ph_ice, ph_snw, ld_pnd_alb, pafrac_pnd, ph_pnd, pcloud_fra, palb_ice )
!!----------------------------------------------------------------------
!! *** ROUTINE ice_alb ***
@@ -99,7 +100,8 @@
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( out), DIMENSION(:,:,:) :: palb_cs ! albedo of ice under clear sky
- REAL(wp), INTENT( out), DIMENSION(:,:,:) :: palb_os ! albedo of ice under overcast sky
- !
+ REAL(wp), INTENT(in ), DIMENSION(:,:) :: pcloud_fra ! cloud fraction
+ REAL(wp), INTENT( out), DIMENSION(:,:,:) :: palb_ice ! albedo of ice
+ !
+ REAL(wp), DIMENSION(jpi,jpj,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
@@ -108,4 +110,5 @@
REAL(wp) :: zalb_ice, zafrac_ice ! bare sea ice albedo & relative ice fraction
REAL(wp) :: zalb_snw, zafrac_snw ! snow-covered sea ice albedo & relative snow fraction
+ REAL(wp) :: zalb_cs, zalb_os ! albedo of ice under clear/overcast sky
!!---------------------------------------------------------------------
!
@@ -118,27 +121,29 @@
z1_c4 = 1. / 0.03
!
+ CALL ice_var_snwfra( ph_snw, za_s_fra ) ! calculate ice fraction covered by snow
+ !
DO jl = 1, jpl
- DO_2D_11_11
- ! !--- Specific snow, ice and pond fractions (for now, we prevent melt ponds and snow at the same time)
- IF( ph_snw(ji,jj,jl) == 0._wp ) THEN
- zafrac_snw = 0._wp
- IF( ld_pnd_alb ) THEN
- zafrac_pnd = pafrac_pnd(ji,jj,jl)
- ELSE
- zafrac_pnd = 0._wp
- ENDIF
- zafrac_ice = 1._wp - zafrac_pnd
+ DO_2D( 1, 1, 1, 1 )
+ !
+ !---------------------------------------------!
+ !--- Specific snow, ice and pond fractions ---!
+ !---------------------------------------------!
+ zafrac_snw = za_s_fra(ji,jj,jl)
+ IF( ld_pnd_alb ) THEN
+ zafrac_pnd = MIN( pafrac_pnd(ji,jj,jl), 1._wp - zafrac_snw ) ! make sure (a_ip_eff + a_s_fra) <= 1
ELSE
- zafrac_snw = 1._wp ! Snow fully "shades" melt ponds and ice
zafrac_pnd = 0._wp
- zafrac_ice = 0._wp
- ENDIF
- !
+ ENDIF
+ zafrac_ice = MAX( 0._wp, 1._wp - zafrac_pnd - zafrac_snw ) ! max for roundoff errors
+ !
+ !---------------!
+ !--- Albedos ---!
+ !---------------!
! !--- Bare ice albedo (for hi > 150cm)
IF( ld_pnd_alb ) THEN
zalb_ice = rn_alb_idry
ELSE
- IF( ph_snw(ji,jj,jl) == 0._wp .AND. pt_su(ji,jj,jl) >= rt0 ) THEN ; zalb_ice = rn_alb_imlt
- ELSE ; zalb_ice = rn_alb_idry ; ENDIF
+ IF( ph_snw(ji,jj,jl) == 0._wp .AND. pt_su(ji,jj,jl) >= rt0 ) THEN ; zalb_ice = rn_alb_imlt
+ ELSE ; zalb_ice = rn_alb_idry ; ENDIF
ENDIF
! !--- Bare ice albedo (for hi < 150cm)
@@ -156,16 +161,15 @@
ENDIF
! !--- Ponded ice albedo
- IF( ld_pnd_alb ) THEN
- zalb_pnd = rn_alb_dpnd - ( rn_alb_dpnd - zalb_ice ) * EXP( - ph_pnd(ji,jj,jl) * z1_href_pnd )
- ELSE
- zalb_pnd = rn_alb_dpnd
- ENDIF
+ 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
- palb_os(ji,jj,jl) = ( zafrac_snw * zalb_snw + zafrac_pnd * zalb_pnd + zafrac_ice * zalb_ice ) * tmask(ji,jj,1)
- !
- palb_cs(ji,jj,jl) = palb_os(ji,jj,jl) &
- & - ( - 0.1010 * palb_os(ji,jj,jl) * palb_os(ji,jj,jl) &
- & + 0.1933 * palb_os(ji,jj,jl) - 0.0148 ) * tmask(ji,jj,1)
- !
+ zalb_os = ( zafrac_snw * zalb_snw + zafrac_pnd * zalb_pnd + zafrac_ice * zalb_ice ) * tmask(ji,jj,1)
+ !
+ zalb_cs = zalb_os - ( - 0.1010 * zalb_os * zalb_os &
+ & + 0.1933 * zalb_os - 0.0148 ) * tmask(ji,jj,1)
+ !
+ ! 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
+
END_2D
END DO
Index: /NEMO/branches/2020/r12377_ticket2386/src/ICE/icecor.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/ICE/icecor.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/ICE/icecor.F90 (revision 13540)
@@ -81,6 +81,10 @@
DO jl = 1, jpl
WHERE( at_i(:,:) > rn_amax_2d(:,:) ) a_i(:,:,jl) = a_i(:,:,jl) * rn_amax_2d(:,:) / at_i(:,:)
- END DO
-
+ END DO
+ ! !-----------------------------------------------------
+ ! ! Rebin categories with thickness out of bounds !
+ ! !-----------------------------------------------------
+ IF ( jpl > 1 ) CALL ice_itd_reb( kt )
+ !
! !-----------------------------------------------------
IF ( nn_icesal == 2 ) THEN ! salinity must stay in bounds [Simin,Simax] !
@@ -88,5 +92,5 @@
zzc = rhoi * r1_Dt_ice
DO jl = 1, jpl
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
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) )
@@ -96,9 +100,4 @@
ENDIF
! !-----------------------------------------------------
- ! ! Rebin categories with thickness out of bounds !
- ! !-----------------------------------------------------
- IF ( jpl > 1 ) CALL ice_itd_reb( kt )
-
- ! !-----------------------------------------------------
CALL ice_var_zapsmall ! Zap small values !
! !-----------------------------------------------------
@@ -106,5 +105,5 @@
! !-----------------------------------------------------
IF( kn == 2 ) THEN ! Ice drift case: Corrections to avoid wrong values !
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 ) !-----------------------------------------------------
IF ( at_i(ji,jj) == 0._wp ) THEN ! what to do if there is no ice
IF ( at_i(ji+1,jj) == 0._wp ) u_ice(ji ,jj) = 0._wp ! right side
@@ -114,5 +113,5 @@
ENDIF
END_2D
- CALL lbc_lnk_multi( 'icecor', u_ice, 'U', -1., v_ice, 'V', -1. )
+ CALL lbc_lnk_multi( 'icecor', u_ice, 'U', -1.0_wp, v_ice, 'V', -1.0_wp )
ENDIF
Index: /NEMO/branches/2020/r12377_ticket2386/src/ICE/icectl.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/ICE/icectl.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/ICE/icectl.F90 (revision 13540)
@@ -331,5 +331,5 @@
IF(lwp) WRITE(numout,*)
- CALL iom_open( TRIM(cdfile_name), inum, ldwrt = .TRUE., kdlev = jpl )
+ CALL iom_open( TRIM(cdfile_name), inum, ldwrt = .TRUE., kdlev = jpl, cdcomp = 'ICE' )
CALL iom_rstput( 0, 0, inum, 'cons_mass', pdiag_mass(:,:) , ktype = jp_r8 ) ! ice mass spurious lost/gain
@@ -350,138 +350,136 @@
!! *** ROUTINE ice_ctl ***
!!
- !! ** Purpose : Alerts in case of model crash
+ !! ** Purpose : control checks
!!-------------------------------------------------------------------
INTEGER, INTENT(in) :: kt ! ocean time step
- INTEGER :: ji, jj, jk, jl ! dummy loop indices
- INTEGER :: inb_altests ! number of alert tests (max 20)
- INTEGER :: ialert_id ! number of the current alert
- REAL(wp) :: ztmelts ! ice layer melting point
+ INTEGER :: ja, ji, jj, jk, jl ! dummy loop indices
+ INTEGER :: ialert_id ! number of the current alert
+ REAL(wp) :: ztmelts ! ice layer melting point
CHARACTER (len=30), DIMENSION(20) :: cl_alname ! name of alert
INTEGER , DIMENSION(20) :: inb_alp ! number of alerts positive
!!-------------------------------------------------------------------
-
- inb_altests = 10
- inb_alp(:) = 0
-
- ! Alert if incompatible volume and concentration
- ialert_id = 2 ! reference number of this alert
- cl_alname(ialert_id) = ' Incompat vol and con ' ! name of the alert
+ inb_alp(:) = 0
+ ialert_id = 0
+
+ ! Alert if very high salinity
+ ialert_id = ialert_id + 1 ! reference number of this alert
+ cl_alname(ialert_id) = ' Very high salinity ' ! name of the alert
DO jl = 1, jpl
- DO_2D_11_11
- IF( v_i(ji,jj,jl) /= 0._wp .AND. a_i(ji,jj,jl) == 0._wp ) THEN
- WRITE(numout,*) ' ALERTE 2 : Incompatible volume and concentration '
- inb_alp(ialert_id) = inb_alp(ialert_id) + 1
+ DO_2D( 1, 1, 1, 1 )
+ IF( v_i(ji,jj,jl) > epsi10 ) THEN
+ IF( sv_i(ji,jj,jl) / v_i(ji,jj,jl) > rn_simax ) THEN
+ WRITE(numout,*) ' ALERTE : Very high salinity ',sv_i(ji,jj,jl)/v_i(ji,jj,jl)
+ WRITE(numout,*) ' at i,j,l = ',ji,jj,jl
+ inb_alp(ialert_id) = inb_alp(ialert_id) + 1
+ ENDIF
ENDIF
END_2D
END DO
- ! Alerte if very thick ice
- ialert_id = 3 ! reference number of this alert
- cl_alname(ialert_id) = ' Very thick ice ' ! name of the alert
- jl = jpl
- DO_2D_11_11
- IF( h_i(ji,jj,jl) > 50._wp ) THEN
- WRITE(numout,*) ' ALERTE 3 : Very thick ice'
- !CALL ice_prt( kt, ji, jj, 2, ' ALERTE 3 : Very thick ice ' )
- inb_alp(ialert_id) = inb_alp(ialert_id) + 1
- ENDIF
- END_2D
-
- ! Alert if very fast ice
- ialert_id = 4 ! reference number of this alert
- cl_alname(ialert_id) = ' Very fast ice ' ! name of the alert
- DO_2D_11_11
- IF( MAX( ABS( u_ice(ji,jj) ), ABS( v_ice(ji,jj) ) ) > 2. .AND. &
- & at_i(ji,jj) > 0._wp ) THEN
- WRITE(numout,*) ' ALERTE 4 : Very fast ice'
- !CALL ice_prt( kt, ji, jj, 1, ' ALERTE 4 : Very fast ice ' )
- inb_alp(ialert_id) = inb_alp(ialert_id) + 1
- ENDIF
- END_2D
-
- ! Alert on salt flux
- ialert_id = 5 ! reference number of this alert
- cl_alname(ialert_id) = ' High salt flux ' ! name of the alert
- DO_2D_11_11
- IF( ABS( sfx (ji,jj) ) > 1.0e-2 ) THEN ! = 1 psu/day for 1m ocean depth
- WRITE(numout,*) ' ALERTE 5 : High salt flux'
- !CALL ice_prt( kt, ji, jj, 3, ' ALERTE 5 : High salt flux ' )
- inb_alp(ialert_id) = inb_alp(ialert_id) + 1
- ENDIF
- END_2D
-
- ! Alert if there is ice on continents
- ialert_id = 6 ! reference number of this alert
- cl_alname(ialert_id) = ' Ice on continents ' ! name of the alert
- DO_2D_11_11
- IF( tmask(ji,jj,1) <= 0._wp .AND. at_i(ji,jj) > 0._wp ) THEN
- WRITE(numout,*) ' ALERTE 6 : Ice on continents'
- !CALL ice_prt( kt, ji, jj, 1, ' ALERTE 6 : Ice on continents ' )
- inb_alp(ialert_id) = inb_alp(ialert_id) + 1
- ENDIF
- END_2D
-
-!
-! ! Alert if very fresh ice
- ialert_id = 7 ! reference number of this alert
- cl_alname(ialert_id) = ' Very fresh ice ' ! name of the alert
+ ! Alert if very low salinity
+ ialert_id = ialert_id + 1 ! reference number of this alert
+ cl_alname(ialert_id) = ' Very low salinity ' ! name of the alert
DO jl = 1, jpl
- DO_2D_11_11
- IF( s_i(ji,jj,jl) < 0.1 .AND. a_i(ji,jj,jl) > 0._wp ) THEN
- WRITE(numout,*) ' ALERTE 7 : Very fresh ice'
-! CALL ice_prt(kt,ji,jj,1, ' ALERTE 7 : Very fresh ice ' )
- inb_alp(ialert_id) = inb_alp(ialert_id) + 1
+ DO_2D( 1, 1, 1, 1 )
+ IF( v_i(ji,jj,jl) > epsi10 ) THEN
+ IF( sv_i(ji,jj,jl) / v_i(ji,jj,jl) < rn_simin ) THEN
+ WRITE(numout,*) ' ALERTE : Very low salinity ',sv_i(ji,jj,jl),v_i(ji,jj,jl)
+ WRITE(numout,*) ' at i,j,l = ',ji,jj,jl
+ inb_alp(ialert_id) = inb_alp(ialert_id) + 1
+ ENDIF
ENDIF
END_2D
END DO
-!
- ! Alert if qns very big
- ialert_id = 8 ! reference number of this alert
- cl_alname(ialert_id) = ' fnsolar very big ' ! name of the alert
- DO_2D_11_11
- IF( ABS( qns(ji,jj) ) > 1500._wp .AND. at_i(ji,jj) > 0._wp ) THEN
- !
- WRITE(numout,*) ' ALERTE 8 : Very high non-solar heat flux'
- !CALL ice_prt( kt, ji, jj, 2, ' ')
- inb_alp(ialert_id) = inb_alp(ialert_id) + 1
- !
- ENDIF
- END_2D
- !+++++
-
-! ! Alert if too old ice
- ialert_id = 9 ! reference number of this alert
- cl_alname(ialert_id) = ' Very old ice ' ! name of the alert
+
+ ! Alert if very cold ice
+ ialert_id = ialert_id + 1 ! reference number of this alert
+ cl_alname(ialert_id) = ' Very cold ice ' ! name of the alert
DO jl = 1, jpl
- DO_2D_11_11
- IF ( ( ( ABS( o_i(ji,jj,jl) ) > rDt_ice ) .OR. &
- ( ABS( o_i(ji,jj,jl) ) < 0._wp) ) .AND. &
- ( a_i(ji,jj,jl) > 0._wp ) ) THEN
- WRITE(numout,*) ' ALERTE 9 : Wrong ice age'
- !CALL ice_prt( kt, ji, jj, 1, ' ALERTE 9 : Wrong ice age ')
- inb_alp(ialert_id) = inb_alp(ialert_id) + 1
- ENDIF
- END_2D
- END DO
-
- ! Alert if very warm ice
- ialert_id = 10 ! reference number of this alert
- cl_alname(ialert_id) = ' Very warm ice ' ! name of the alert
- inb_alp(ialert_id) = 0
- DO jl = 1, jpl
- DO_3D_11_11( 1, nlay_i )
+ DO_3D( 1, 1, 1, 1, 1, nlay_i )
ztmelts = -rTmlt * sz_i(ji,jj,jk,jl) + rt0
- IF( t_i(ji,jj,jk,jl) > ztmelts .AND. v_i(ji,jj,jl) > 1.e-10 &
- & .AND. a_i(ji,jj,jl) > 0._wp ) THEN
- WRITE(numout,*) ' ALERTE 10 : Very warm ice'
+ IF( t_i(ji,jj,jk,jl) < -50.+rt0 .AND. v_i(ji,jj,jl) > epsi10 ) THEN
+ WRITE(numout,*) ' ALERTE : Very cold ice ',(t_i(ji,jj,jk,jl)-rt0)
+ WRITE(numout,*) ' at i,j,k,l = ',ji,jj,jk,jl
inb_alp(ialert_id) = inb_alp(ialert_id) + 1
ENDIF
END_3D
END DO
+
+ ! Alert if very warm ice
+ ialert_id = ialert_id + 1 ! reference number of this alert
+ cl_alname(ialert_id) = ' Very warm ice ' ! name of the alert
+ DO jl = 1, jpl
+ DO_3D( 1, 1, 1, 1, 1, nlay_i )
+ ztmelts = -rTmlt * sz_i(ji,jj,jk,jl) + rt0
+ IF( t_i(ji,jj,jk,jl) > ztmelts .AND. v_i(ji,jj,jl) > epsi10 ) THEN
+ WRITE(numout,*) ' ALERTE : Very warm ice',(t_i(ji,jj,jk,jl)-rt0)
+ WRITE(numout,*) ' at i,j,k,l = ',ji,jj,jk,jl
+ inb_alp(ialert_id) = inb_alp(ialert_id) + 1
+ ENDIF
+ END_3D
+ END DO
+
+ ! Alerte if very thick ice
+ ialert_id = ialert_id + 1 ! reference number of this alert
+ cl_alname(ialert_id) = ' Very thick ice ' ! name of the alert
+ jl = jpl
+ DO_2D( 1, 1, 1, 1 )
+ IF( h_i(ji,jj,jl) > 50._wp ) THEN
+ WRITE(numout,*) ' ALERTE : Very thick ice ',h_i(ji,jj,jl)
+ WRITE(numout,*) ' at i,j,l = ',ji,jj,jl
+ inb_alp(ialert_id) = inb_alp(ialert_id) + 1
+ ENDIF
+ END_2D
+
+ ! Alerte if very thin ice
+ ialert_id = ialert_id + 1 ! reference number of this alert
+ cl_alname(ialert_id) = ' Very thin ice ' ! name of the alert
+ jl = 1
+ DO_2D( 1, 1, 1, 1 )
+ IF( h_i(ji,jj,jl) < rn_himin ) THEN
+ WRITE(numout,*) ' ALERTE : Very thin ice ',h_i(ji,jj,jl)
+ WRITE(numout,*) ' at i,j,l = ',ji,jj,jl
+ inb_alp(ialert_id) = inb_alp(ialert_id) + 1
+ ENDIF
+ END_2D
+
+ ! Alert if very fast ice
+ ialert_id = ialert_id + 1 ! reference number of this alert
+ cl_alname(ialert_id) = ' Very fast ice ' ! name of the alert
+ DO_2D( 1, 1, 1, 1 )
+ IF( MAX( ABS( u_ice(ji,jj) ), ABS( v_ice(ji,jj) ) ) > 2. ) THEN
+ WRITE(numout,*) ' ALERTE : Very fast ice ',MAX( ABS( u_ice(ji,jj) ), ABS( v_ice(ji,jj) ) )
+ WRITE(numout,*) ' at i,j = ',ji,jj
+ inb_alp(ialert_id) = inb_alp(ialert_id) + 1
+ ENDIF
+ END_2D
+
+ ! Alert if there is ice on continents
+ ialert_id = ialert_id + 1 ! reference number of this alert
+ cl_alname(ialert_id) = ' Ice on continents ' ! name of the alert
+ DO_2D( 1, 1, 1, 1 )
+ IF( tmask(ji,jj,1) == 0._wp .AND. ( at_i(ji,jj) > 0._wp .OR. vt_i(ji,jj) > 0._wp ) ) THEN
+ WRITE(numout,*) ' ALERTE : Ice on continents ',at_i(ji,jj),vt_i(ji,jj)
+ WRITE(numout,*) ' at i,j = ',ji,jj
+ inb_alp(ialert_id) = inb_alp(ialert_id) + 1
+ ENDIF
+ END_2D
+
+ ! Alert if incompatible ice concentration and volume
+ ialert_id = ialert_id + 1 ! reference number of this alert
+ cl_alname(ialert_id) = ' Incompatible ice conc and vol ' ! name of the alert
+ DO_2D( 1, 1, 1, 1 )
+ IF( ( vt_i(ji,jj) == 0._wp .AND. at_i(ji,jj) > 0._wp ) .OR. &
+ & ( vt_i(ji,jj) > 0._wp .AND. at_i(ji,jj) == 0._wp ) ) THEN
+ WRITE(numout,*) ' ALERTE : Incompatible ice conc and vol ',at_i(ji,jj),vt_i(ji,jj)
+ WRITE(numout,*) ' at i,j = ',ji,jj
+ inb_alp(ialert_id) = inb_alp(ialert_id) + 1
+ ENDIF
+ END_2D
! sum of the alerts on all processors
IF( lk_mpp ) THEN
- DO ialert_id = 1, inb_altests
- CALL mpp_sum('icectl', inb_alp(ialert_id))
+ DO ja = 1, ialert_id
+ CALL mpp_sum('icectl', inb_alp(ja))
END DO
ENDIF
@@ -489,10 +487,8 @@
! print alerts
IF( lwp ) THEN
- ialert_id = 1 ! reference number of this alert
- cl_alname(ialert_id) = ' NO alerte 1 ' ! name of the alert
WRITE(numout,*) ' time step ',kt
WRITE(numout,*) ' All alerts at the end of ice model '
- DO ialert_id = 1, inb_altests
- WRITE(numout,*) ialert_id, cl_alname(ialert_id)//' : ', inb_alp(ialert_id), ' times ! '
+ DO ja = 1, ialert_id
+ WRITE(numout,*) ja, cl_alname(ja)//' : ', inb_alp(ja), ' times ! '
END DO
ENDIF
@@ -543,5 +539,4 @@
WRITE(numout,*) ' v_ice(i ,j) : ', v_ice(ji,jj)
WRITE(numout,*) ' strength : ', strength(ji,jj)
- WRITE(numout,*)
WRITE(numout,*) ' - Cell values '
WRITE(numout,*) ' ~~~~~~~~~~~ '
@@ -552,4 +547,5 @@
DO jl = 1, jpl
WRITE(numout,*) ' - Category (', jl,')'
+ WRITE(numout,*) ' ~~~~~~~~~~~ '
WRITE(numout,*) ' a_i : ', a_i(ji,jj,jl)
WRITE(numout,*) ' h_i : ', h_i(ji,jj,jl)
@@ -588,5 +584,4 @@
WRITE(numout,*) ' v_ice(i ,j) : ', v_ice(ji,jj)
WRITE(numout,*) ' strength : ', strength(ji,jj)
- WRITE(numout,*) ' u_ice_b : ', u_ice_b(ji,jj) , ' v_ice_b : ', v_ice_b(ji,jj)
WRITE(numout,*)
@@ -605,5 +600,4 @@
WRITE(numout,*) ' e_snow : ', e_s(ji,jj,1,jl) , ' e_snow_b : ', e_s_b(ji,jj,1,jl)
WRITE(numout,*) ' sv_i : ', sv_i(ji,jj,jl) , ' sv_i_b : ', sv_i_b(ji,jj,jl)
- WRITE(numout,*) ' oa_i : ', oa_i(ji,jj,jl) , ' oa_i_b : ', oa_i_b(ji,jj,jl)
END DO !jl
@@ -702,5 +696,5 @@
DO jl = 1, jpl
CALL prt_ctl_info(' ')
- CALL prt_ctl_info(' - Category : ', ivar1=jl)
+ CALL prt_ctl_info(' - Category : ', ivar=jl)
CALL prt_ctl_info(' ~~~~~~~~~~')
CALL prt_ctl(tab2d_1=h_i (:,:,jl) , clinfo1= ' h_i : ')
@@ -713,5 +707,4 @@
CALL prt_ctl(tab2d_1=v_i (:,:,jl) , clinfo1= ' v_i : ')
CALL prt_ctl(tab2d_1=v_s (:,:,jl) , clinfo1= ' v_s : ')
- CALL prt_ctl(tab2d_1=e_i (:,:,1,jl) , clinfo1= ' e_i1 : ')
CALL prt_ctl(tab2d_1=e_s (:,:,1,jl) , clinfo1= ' e_snow : ')
CALL prt_ctl(tab2d_1=sv_i (:,:,jl) , clinfo1= ' sv_i : ')
@@ -719,15 +712,9 @@
DO jk = 1, nlay_i
- CALL prt_ctl_info(' - Layer : ', ivar1=jk)
+ CALL prt_ctl_info(' - Layer : ', ivar=jk)
CALL prt_ctl(tab2d_1=t_i(:,:,jk,jl) , clinfo1= ' t_i : ')
+ CALL prt_ctl(tab2d_1=e_i(:,:,jk,jl) , clinfo1= ' e_i : ')
END DO
END DO
-
- CALL prt_ctl_info(' ')
- CALL prt_ctl_info(' - Heat / FW fluxes : ')
- CALL prt_ctl_info(' ~~~~~~~~~~~~~~~~~~ ')
- CALL prt_ctl(tab2d_1=sst_m , clinfo1= ' sst : ', tab2d_2=sss_m , clinfo2= ' sss : ')
- CALL prt_ctl(tab2d_1=qsr , clinfo1= ' qsr : ', tab2d_2=qns , clinfo2= ' qns : ')
- CALL prt_ctl(tab2d_1=emp , clinfo1= ' emp : ', tab2d_2=sfx , clinfo2= ' sfx : ')
CALL prt_ctl_info(' ')
Index: /NEMO/branches/2020/r12377_ticket2386/src/ICE/icedia.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/ICE/icedia.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/ICE/icedia.F90 (revision 13540)
@@ -230,7 +230,7 @@
CALL iom_get( numrir, 'frc_tembot' , frc_tembot )
CALL iom_get( numrir, 'frc_sal' , frc_sal )
- CALL iom_get( numrir, jpdom_autoglo, 'vol_loc_ini', vol_loc_ini )
- CALL iom_get( numrir, jpdom_autoglo, 'tem_loc_ini', tem_loc_ini )
- CALL iom_get( numrir, jpdom_autoglo, 'sal_loc_ini', sal_loc_ini )
+ CALL iom_get( numrir, jpdom_auto, 'vol_loc_ini', vol_loc_ini )
+ CALL iom_get( numrir, jpdom_auto, 'tem_loc_ini', tem_loc_ini )
+ CALL iom_get( numrir, jpdom_auto, 'sal_loc_ini', sal_loc_ini )
ELSE
IF(lwp) WRITE(numout,*)
Index: /NEMO/branches/2020/r12377_ticket2386/src/ICE/icedyn.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/ICE/icedyn.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/ICE/icedyn.F90 (revision 13540)
@@ -100,6 +100,8 @@
WHERE( a_ip(:,:,:) >= epsi20 )
h_ip(:,:,:) = v_ip(:,:,:) / a_ip(:,:,:)
+ h_il(:,:,:) = v_il(:,:,:) / a_ip(:,:,:)
ELSEWHERE
h_ip(:,:,:) = 0._wp
+ h_il(:,:,:) = 0._wp
END WHERE
!
@@ -126,9 +128,9 @@
! CFL = 0.5 at a distance from the bound of 1/6 of the basin length
! Then for dx = 2m and dt = 1s => rn_uice = u (1/6th) = 1m/s
- DO_2D_11_11
- zcoefu = ( REAL(jpiglo+1)*0.5 - REAL(ji+nimpp-1) ) / ( REAL(jpiglo+1)*0.5 - 1. )
- zcoefv = ( REAL(jpjglo+1)*0.5 - REAL(jj+njmpp-1) ) / ( REAL(jpjglo+1)*0.5 - 1. )
- u_ice(ji,jj) = rn_uice * 1.5 * SIGN( 1., zcoefu ) * ABS( zcoefu ) * umask(ji,jj,1)
- v_ice(ji,jj) = rn_vice * 1.5 * SIGN( 1., zcoefv ) * ABS( zcoefv ) * vmask(ji,jj,1)
+ DO_2D( 1, 1, 1, 1 )
+ zcoefu = ( REAL(jpiglo+1)*0.5_wp - REAL(ji+nimpp-1) ) / ( REAL(jpiglo+1)*0.5_wp - 1._wp )
+ zcoefv = ( REAL(jpjglo+1)*0.5_wp - REAL(jj+njmpp-1) ) / ( REAL(jpjglo+1)*0.5_wp - 1._wp )
+ u_ice(ji,jj) = rn_uice * 1.5_wp * SIGN( 1.0_wp, zcoefu ) * ABS( zcoefu ) * umask(ji,jj,1)
+ v_ice(ji,jj) = rn_vice * 1.5_wp * SIGN( 1.0_wp, zcoefv ) * ABS( zcoefv ) * vmask(ji,jj,1)
END_2D
! ---
@@ -155,9 +157,9 @@
ALLOCATE( zdivu_i(jpi,jpj) )
- DO_2D_00_00
+ 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)
END_2D
- CALL lbc_lnk( 'icedyn', zdivu_i, 'T', 1. )
+ CALL lbc_lnk( 'icedyn', zdivu_i, 'T', 1.0_wp )
! output
CALL iom_put( 'icediv' , zdivu_i )
@@ -218,5 +220,5 @@
NAMELIST/namdyn/ ln_dynALL, ln_dynRHGADV, ln_dynADV1D, ln_dynADV2D, rn_uice, rn_vice, &
& rn_ishlat , &
- & ln_landfast_L16, rn_depfra, rn_icebfr, rn_lfrelax, rn_tensile
+ & ln_landfast_L16, rn_lf_depfra, rn_lf_bfr, rn_lf_relax, rn_lf_tensile
!!-------------------------------------------------------------------
!
@@ -239,8 +241,8 @@
WRITE(numout,*) ' lateral boundary condition for sea ice dynamics rn_ishlat = ', rn_ishlat
WRITE(numout,*) ' Landfast: param from Lemieux 2016 ln_landfast_L16 = ', ln_landfast_L16
- WRITE(numout,*) ' fraction of ocean depth that ice must reach rn_depfra = ', rn_depfra
- WRITE(numout,*) ' maximum bottom stress per unit area of contact rn_icebfr = ', rn_icebfr
- WRITE(numout,*) ' relax time scale (s-1) to reach static friction rn_lfrelax = ', rn_lfrelax
- WRITE(numout,*) ' isotropic tensile strength rn_tensile = ', rn_tensile
+ WRITE(numout,*) ' fraction of ocean depth that ice must reach rn_lf_depfra = ', rn_lf_depfra
+ WRITE(numout,*) ' maximum bottom stress per unit area of contact rn_lf_bfr = ', rn_lf_bfr
+ WRITE(numout,*) ' relax time scale (s-1) to reach static friction rn_lf_relax = ', rn_lf_relax
+ WRITE(numout,*) ' isotropic tensile strength rn_lf_tensile = ', rn_lf_tensile
WRITE(numout,*)
ENDIF
Index: /NEMO/branches/2020/r12377_ticket2386/src/ICE/icedyn_adv.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/ICE/icedyn_adv.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/ICE/icedyn_adv.F90 (revision 13540)
@@ -82,10 +82,10 @@
! !-----------------------!
CALL ice_dyn_adv_umx( nn_UMx, kt, u_ice, v_ice, h_i, h_s, h_ip, &
- & ato_i, v_i, v_s, sv_i, oa_i, a_i, a_ip, v_ip, e_s, e_i )
+ & ato_i, v_i, v_s, sv_i, oa_i, a_i, a_ip, v_ip, v_il, e_s, e_i )
! !-----------------------!
CASE( np_advPRA ) ! PRATHER scheme !
! !-----------------------!
CALL ice_dyn_adv_pra( kt, u_ice, v_ice, h_i, h_s, h_ip, &
- & ato_i, v_i, v_s, sv_i, oa_i, a_i, a_ip, v_ip, e_s, e_i )
+ & ato_i, v_i, v_s, sv_i, oa_i, a_i, a_ip, v_ip, v_il, e_s, e_i )
END SELECT
Index: /NEMO/branches/2020/r12377_ticket2386/src/ICE/icedyn_adv_pra.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/ICE/icedyn_adv_pra.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/ICE/icedyn_adv_pra.F90 (revision 13540)
@@ -44,4 +44,5 @@
REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sxap , syap , sxxap , syyap , sxyap ! melt pond fraction
REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sxvp , syvp , sxxvp , syyvp , sxyvp ! melt pond volume
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sxvl , syvl , sxxvl , syyvl , sxyvl ! melt pond lid volume
!! * Substitutions
@@ -55,5 +56,5 @@
SUBROUTINE ice_dyn_adv_pra( kt, pu_ice, pv_ice, ph_i, ph_s, ph_ip, &
- & pato_i, pv_i, pv_s, psv_i, poa_i, pa_i, pa_ip, pv_ip, pe_s, pe_i )
+ & pato_i, pv_i, pv_s, psv_i, poa_i, pa_i, pa_ip, pv_ip, pv_il, pe_s, pe_i )
!!----------------------------------------------------------------------
!! ** routine ice_dyn_adv_pra **
@@ -81,8 +82,9 @@
REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: pa_ip ! melt pond fraction
REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: pv_ip ! melt pond volume
+ REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: pv_il ! melt pond lid thickness
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 :: ji, jj, jk, jl, jt ! dummy loop indices
INTEGER :: icycle ! number of sub-timestep for the advection
REAL(wp) :: zdt ! - -
@@ -90,8 +92,10 @@
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
+ 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
+ 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
@@ -100,7 +104,11 @@
IF( kt == nit000 .AND. lwp ) WRITE(numout,*) '-- ice_dyn_adv_pra: Prather advection scheme'
!
- ! --- Record max of the surrounding 9-pts ice thick. (for call Hbig) --- !
+ ! --- 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
DO jl = 1, jpl
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
zhip_max(ji,jj,jl) = MAX( epsi20, ph_ip(ji,jj,jl), ph_ip(ji+1,jj ,jl), ph_ip(ji ,jj+1,jl), &
& ph_ip(ji-1,jj ,jl), ph_ip(ji ,jj-1,jl), &
@@ -115,7 +123,42 @@
& ph_s (ji+1,jj+1,jl), ph_s (ji-1,jj-1,jl), &
& ph_s (ji+1,jj-1,jl), ph_s (ji-1,jj+1,jl) )
+ zsi_max (ji,jj,jl) = MAX( epsi20, zs_i (ji,jj,jl), zs_i (ji+1,jj ,jl), zs_i (ji ,jj+1,jl), &
+ & zs_i (ji-1,jj ,jl), zs_i (ji ,jj-1,jl), &
+ & zs_i (ji+1,jj+1,jl), zs_i (ji-1,jj-1,jl), &
+ & zs_i (ji+1,jj-1,jl), zs_i (ji-1,jj+1,jl) )
END_2D
END DO
- CALL lbc_lnk_multi( 'icedyn_adv_pra', zhi_max, 'T', 1., zhs_max, 'T', 1., zhip_max, 'T', 1. )
+ CALL lbc_lnk_multi( '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
+ DO jl = 1, jpl
+ DO_3D( 0, 0, 0, 0, 1, nlay_i )
+ zei_max(ji,jj,jk,jl) = MAX( epsi20, ze_i(ji,jj,jk,jl), ze_i(ji+1,jj ,jk,jl), ze_i(ji ,jj+1,jk,jl), &
+ & ze_i(ji-1,jj ,jk,jl), ze_i(ji ,jj-1,jk,jl), &
+ & ze_i(ji+1,jj+1,jk,jl), ze_i(ji-1,jj-1,jk,jl), &
+ & ze_i(ji+1,jj-1,jk,jl), ze_i(ji-1,jj+1,jk,jl) )
+ END_3D
+ END DO
+ DO jl = 1, jpl
+ DO_3D( 0, 0, 0, 0, 1, nlay_s )
+ zes_max(ji,jj,jk,jl) = MAX( epsi20, ze_s(ji,jj,jk,jl), ze_s(ji+1,jj ,jk,jl), ze_s(ji ,jj+1,jk,jl), &
+ & ze_s(ji-1,jj ,jk,jl), ze_s(ji ,jj-1,jk,jl), &
+ & ze_s(ji+1,jj+1,jk,jl), ze_s(ji-1,jj-1,jk,jl), &
+ & ze_s(ji+1,jj-1,jk,jl), ze_s(ji-1,jj+1,jk,jl) )
+ END_3D
+ END DO
+ CALL lbc_lnk( 'icedyn_adv_pra', zei_max, 'T', 1. )
+ CALL lbc_lnk( 'icedyn_adv_pra', zes_max, 'T', 1. )
+ !
!
! --- If ice drift is too fast, use subtime steps for advection (CFL test for stability) --- !
@@ -156,7 +199,10 @@
z0ei(:,:,jk,jl) = pe_i(:,:,jk,jl) * e1e2t(:,:) ! Ice heat content
END DO
- IF ( ln_pnd_H12 ) THEN
- z0ap(:,:,jl) = pa_ip(:,:,jl) * e1e2t(:,:) ! Melt pond fraction
- z0vp(:,:,jl) = pv_ip(:,:,jl) * e1e2t(:,:) ! Melt pond volume
+ IF ( ln_pnd_LEV ) 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
@@ -189,9 +235,13 @@
END DO
!
- IF ( ln_pnd_H12 ) THEN
+ IF ( ln_pnd_LEV ) 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
! !--------------------------------------------!
@@ -220,10 +270,14 @@
& sxxe(:,:,jk,:), sye(:,:,jk,:), syye(:,:,jk,:), sxye(:,:,jk,:) )
END DO
- IF ( ln_pnd_H12 ) THEN
+ IF ( ln_pnd_LEV ) 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 )
- ENDIF
+ 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 )
+ ENDIF
+ ENDIF
!
ENDIF
@@ -242,7 +296,10 @@
pe_i(:,:,jk,jl) = z0ei(:,:,jk,jl) * r1_e1e2t(:,:) * tmask(:,:,1)
END DO
- IF ( ln_pnd_H12 ) THEN
+ IF ( ln_pnd_LEV ) THEN
pa_ip(:,:,jl) = z0ap(:,:,jl) * r1_e1e2t(:,:) * tmask(:,:,1)
pv_ip(:,:,jl) = z0vp(:,:,jl) * r1_e1e2t(:,:) * tmask(:,:,1)
+ IF ( ln_pnd_lids ) THEN
+ pv_il(:,:,jl) = z0vl(:,:,jl) * r1_e1e2t(:,:) * tmask(:,:,1)
+ ENDIF
ENDIF
END DO
@@ -250,18 +307,19 @@
! derive open water from ice concentration
zati2(:,:) = SUM( pa_i(:,:,:), dim=3 )
- DO_2D_00_00
+ 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
END_2D
- CALL lbc_lnk( 'icedyn_adv_pra', pato_i, 'T', 1. )
+ CALL lbc_lnk( 'icedyn_adv_pra', pato_i, 'T', 1.0_wp )
!
! --- 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, pe_s, pe_i )
+ 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 )
!
! --- 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, pv_i, pv_s, pa_i, pa_ip, pv_ip, pe_s )
+ 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 --- !
@@ -305,5 +363,5 @@
!
! Limitation of moments.
- DO_2D_00_11
+ DO_2D( 0, 0, 1, 1 )
! Initialize volumes of boxes (=area if adv_x first called, =psm otherwise)
psm (ji,jj,jl) = MAX( pcrh * e1e2t(ji,jj) + ( 1.0 - pcrh ) * psm(ji,jj,jl) , epsi20 )
@@ -325,5 +383,5 @@
! Calculate fluxes and moments between boxes i<-->i+1
- DO_2D_00_11
+ DO_2D( 0, 0, 1, 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 / psm(ji,jj,jl)
@@ -350,5 +408,5 @@
END_2D
- DO_2D_00_10
+ DO_2D( 0, 0, 1, 0 ) ! 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
@@ -369,5 +427,5 @@
END_2D
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 ) ! Readjust moments remaining in the box.
zbt = zbet(ji-1,jj)
zbt1 = 1.0 - zbet(ji-1,jj)
@@ -383,5 +441,5 @@
! Put the temporary moments into appropriate neighboring boxes.
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 ) ! Flux from i to i+1 IF u GT 0.
zbt = zbet(ji-1,jj)
zbt1 = 1.0 - zbet(ji-1,jj)
@@ -403,5 +461,5 @@
END_2D
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 ) ! Flux from i+1 to i IF u LT 0.
zbt = zbet(ji,jj)
zbt1 = 1.0 - zbet(ji,jj)
@@ -425,7 +483,7 @@
!-- Lateral boundary conditions
- CALL lbc_lnk_multi( 'icedyn_adv_pra', psm(:,:,1:jcat) , 'T', 1., ps0 , 'T', 1. &
- & , psx , 'T', -1., psy , 'T', -1. & ! caution gradient ==> the sign changes
- & , psxx , 'T', 1., psyy, 'T', 1. , psxy, 'T', 1. )
+ CALL lbc_lnk_multi( 'icedyn_adv_pra', psm(:,:,1:jcat) , 'T', 1.0_wp, ps0 , 'T', 1.0_wp &
+ & , psx , 'T', -1.0_wp, psy , 'T', -1.0_wp & ! caution gradient ==> the sign changes
+ & , psxx , 'T', 1.0_wp, psyy, 'T', 1.0_wp , psxy, 'T', 1.0_wp )
!
END SUBROUTINE adv_x
@@ -462,5 +520,5 @@
!
! Limitation of moments.
- DO_2D_11_00
+ DO_2D( 1, 1, 0, 0 )
! Initialize volumes of boxes (=area if adv_x first called, =psm otherwise)
psm(ji,jj,jl) = MAX( pcrh * e1e2t(ji,jj) + ( 1.0 - pcrh ) * psm(ji,jj,jl) , epsi20 )
@@ -482,5 +540,5 @@
! Calculate fluxes and moments between boxes j<-->j+1
- DO_2D_11_00
+ DO_2D( 1, 1, 0, 0 ) ! 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 / psm(ji,jj,jl)
@@ -507,5 +565,5 @@
END_2D
!
- DO_2D_10_00
+ DO_2D( 1, 0, 0, 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
@@ -527,5 +585,5 @@
! Readjust moments remaining in the box.
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
zbt = zbet(ji,jj-1)
zbt1 = ( 1.0 - zbet(ji,jj-1) )
@@ -541,5 +599,5 @@
! Put the temporary moments into appropriate neighboring boxes.
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 ) ! Flux from j to j+1 IF v GT 0.
zbt = zbet(ji,jj-1)
zbt1 = 1.0 - zbet(ji,jj-1)
@@ -562,5 +620,5 @@
END_2D
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 ) ! Flux from j+1 to j IF v LT 0.
zbt = zbet(ji,jj)
zbt1 = 1.0 - zbet(ji,jj)
@@ -584,12 +642,13 @@
!-- Lateral boundary conditions
- CALL lbc_lnk_multi( 'icedyn_adv_pra', psm(:,:,1:jcat) , 'T', 1., ps0 , 'T', 1. &
- & , psx , 'T', -1., psy , 'T', -1. & ! caution gradient ==> the sign changes
- & , psxx , 'T', 1., psyy, 'T', 1. , psxy, 'T', 1. )
+ CALL lbc_lnk_multi( 'icedyn_adv_pra', psm(:,:,1:jcat) , 'T', 1.0_wp, ps0 , 'T', 1.0_wp &
+ & , psx , 'T', -1.0_wp, psy , 'T', -1.0_wp & ! caution gradient ==> the sign changes
+ & , psxx , 'T', 1.0_wp, psyy, 'T', 1.0_wp , psxy, 'T', 1.0_wp )
!
END SUBROUTINE adv_y
- SUBROUTINE Hbig( pdt, phi_max, phs_max, phip_max, pv_i, pv_s, pa_i, pa_ip, pv_ip, pe_s )
+ SUBROUTINE Hbig( 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 ***
@@ -605,11 +664,14 @@
!! ** input : Max thickness of the surrounding 9-points
!!-------------------------------------------------------------------
- REAL(wp) , INTENT(in ) :: pdt ! tracer time-step
- REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: phi_max, phs_max, phip_max ! max ice thick from surrounding 9-pts
- REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: pv_i, pv_s, pa_i, pa_ip, pv_ip
+ 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(inout) :: pv_i, pv_s, pa_i, pa_ip, pv_ip, psv_i
REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: pe_s
- !
- INTEGER :: ji, jj, jl ! dummy loop indices
- REAL(wp) :: z1_dt, zhip, zhi, zhs, zfra
+ REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: pe_i
+ !
+ INTEGER :: ji, jj, jk, jl ! dummy loop indices
+ REAL(wp) :: z1_dt, zhip, zhi, zhs, zsi, zes, zei, zfra
!!-------------------------------------------------------------------
!
@@ -617,11 +679,10 @@
!
DO jl = 1, jpl
-
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
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_H12 .AND. pv_ip(ji,jj,jl) > 0._wp ) THEN
+ IF( ln_pnd_LEV .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
@@ -650,7 +711,45 @@
ENDIF
!
+ ! ! -- 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
+ !
ENDIF
END_2D
END DO
+ !
+ ! ! -- check e_i/v_i -- !
+ DO jl = 1, jpl
+ DO_3D( 1, 1, 1, 1, 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
+ ENDIF
+ END_3D
+ END DO
+ ! ! -- check e_s/v_s -- !
+ DO jl = 1, jpl
+ DO_3D( 1, 1, 1, 1, 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
+ ENDIF
+ END_3D
+ END DO
!
END SUBROUTINE Hbig
@@ -684,5 +783,5 @@
! -- check snow load -- !
DO jl = 1, jpl
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
IF ( pv_i(ji,jj,jl) > 0._wp ) THEN
!
@@ -724,6 +823,7 @@
& sxsal(jpi,jpj,jpl) , sysal(jpi,jpj,jpl) , sxxsal(jpi,jpj,jpl) , syysal(jpi,jpj,jpl) , sxysal(jpi,jpj,jpl) , &
& sxage(jpi,jpj,jpl) , syage(jpi,jpj,jpl) , sxxage(jpi,jpj,jpl) , syyage(jpi,jpj,jpl) , sxyage(jpi,jpj,jpl) , &
- & sxap(jpi,jpj,jpl) , syap (jpi,jpj,jpl) , sxxap (jpi,jpj,jpl) , syyap (jpi,jpj,jpl) , sxyap (jpi,jpj,jpl) , &
- & sxvp(jpi,jpj,jpl) , syvp (jpi,jpj,jpl) , sxxvp (jpi,jpj,jpl) , syyvp (jpi,jpj,jpl) , sxyvp (jpi,jpj,jpl) , &
+ & sxap (jpi,jpj,jpl) , syap (jpi,jpj,jpl) , sxxap (jpi,jpj,jpl) , syyap (jpi,jpj,jpl) , sxyap (jpi,jpj,jpl) , &
+ & sxvp (jpi,jpj,jpl) , syvp (jpi,jpj,jpl) , sxxvp (jpi,jpj,jpl) , syyvp (jpi,jpj,jpl) , sxyvp (jpi,jpj,jpl) , &
+ & sxvl (jpi,jpj,jpl) , syvl (jpi,jpj,jpl) , sxxvl (jpi,jpj,jpl) , syyvl (jpi,jpj,jpl) , sxyvl (jpi,jpj,jpl) , &
!
& sxc0 (jpi,jpj,nlay_s,jpl) , syc0 (jpi,jpj,nlay_s,jpl) , sxxc0(jpi,jpj,nlay_s,jpl) , &
@@ -772,64 +872,81 @@
!
! ! ice thickness
- CALL iom_get( numrir, jpdom_autoglo, 'sxice' , sxice )
- CALL iom_get( numrir, jpdom_autoglo, 'syice' , syice )
- CALL iom_get( numrir, jpdom_autoglo, 'sxxice', sxxice )
- CALL iom_get( numrir, jpdom_autoglo, 'syyice', syyice )
- CALL iom_get( numrir, jpdom_autoglo, 'sxyice', sxyice )
+ CALL iom_get( numrir, jpdom_auto, 'sxice' , sxice )
+ CALL iom_get( numrir, jpdom_auto, 'syice' , syice )
+ CALL iom_get( numrir, jpdom_auto, 'sxxice', sxxice )
+ CALL iom_get( numrir, jpdom_auto, 'syyice', syyice )
+ CALL iom_get( numrir, jpdom_auto, 'sxyice', sxyice )
! ! snow thickness
- CALL iom_get( numrir, jpdom_autoglo, 'sxsn' , sxsn )
- CALL iom_get( numrir, jpdom_autoglo, 'sysn' , sysn )
- CALL iom_get( numrir, jpdom_autoglo, 'sxxsn' , sxxsn )
- CALL iom_get( numrir, jpdom_autoglo, 'syysn' , syysn )
- CALL iom_get( numrir, jpdom_autoglo, 'sxysn' , sxysn )
+ CALL iom_get( numrir, jpdom_auto, 'sxsn' , sxsn )
+ CALL iom_get( numrir, jpdom_auto, 'sysn' , sysn )
+ CALL iom_get( numrir, jpdom_auto, 'sxxsn' , sxxsn )
+ CALL iom_get( numrir, jpdom_auto, 'syysn' , syysn )
+ CALL iom_get( numrir, jpdom_auto, 'sxysn' , sxysn )
! ! ice concentration
- CALL iom_get( numrir, jpdom_autoglo, 'sxa' , sxa )
- CALL iom_get( numrir, jpdom_autoglo, 'sya' , sya )
- CALL iom_get( numrir, jpdom_autoglo, 'sxxa' , sxxa )
- CALL iom_get( numrir, jpdom_autoglo, 'syya' , syya )
- CALL iom_get( numrir, jpdom_autoglo, 'sxya' , sxya )
+ CALL iom_get( numrir, jpdom_auto, 'sxa' , sxa )
+ CALL iom_get( numrir, jpdom_auto, 'sya' , sya )
+ CALL iom_get( numrir, jpdom_auto, 'sxxa' , sxxa )
+ CALL iom_get( numrir, jpdom_auto, 'syya' , syya )
+ CALL iom_get( numrir, jpdom_auto, 'sxya' , sxya )
! ! ice salinity
- CALL iom_get( numrir, jpdom_autoglo, 'sxsal' , sxsal )
- CALL iom_get( numrir, jpdom_autoglo, 'sysal' , sysal )
- CALL iom_get( numrir, jpdom_autoglo, 'sxxsal', sxxsal )
- CALL iom_get( numrir, jpdom_autoglo, 'syysal', syysal )
- CALL iom_get( numrir, jpdom_autoglo, 'sxysal', sxysal )
+ CALL iom_get( numrir, jpdom_auto, 'sxsal' , sxsal )
+ CALL iom_get( numrir, jpdom_auto, 'sysal' , sysal )
+ CALL iom_get( numrir, jpdom_auto, 'sxxsal', sxxsal )
+ CALL iom_get( numrir, jpdom_auto, 'syysal', syysal )
+ CALL iom_get( numrir, jpdom_auto, 'sxysal', sxysal )
! ! ice age
- CALL iom_get( numrir, jpdom_autoglo, 'sxage' , sxage )
- CALL iom_get( numrir, jpdom_autoglo, 'syage' , syage )
- CALL iom_get( numrir, jpdom_autoglo, 'sxxage', sxxage )
- CALL iom_get( numrir, jpdom_autoglo, 'syyage', syyage )
- CALL iom_get( numrir, jpdom_autoglo, 'sxyage', sxyage )
+ CALL iom_get( numrir, jpdom_auto, 'sxage' , sxage )
+ CALL iom_get( numrir, jpdom_auto, 'syage' , syage )
+ CALL iom_get( numrir, jpdom_auto, 'sxxage', sxxage )
+ CALL iom_get( numrir, jpdom_auto, 'syyage', syyage )
+ CALL iom_get( numrir, jpdom_auto, 'sxyage', sxyage )
! ! snow layers heat content
DO jk = 1, nlay_s
WRITE(zchar1,'(I2.2)') jk
- znam = 'sxc0'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_autoglo, znam , z3d ) ; sxc0 (:,:,jk,:) = z3d(:,:,:)
- znam = 'syc0'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_autoglo, znam , z3d ) ; syc0 (:,:,jk,:) = z3d(:,:,:)
- znam = 'sxxc0'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_autoglo, znam , z3d ) ; sxxc0(:,:,jk,:) = z3d(:,:,:)
- znam = 'syyc0'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_autoglo, znam , z3d ) ; syyc0(:,:,jk,:) = z3d(:,:,:)
- znam = 'sxyc0'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_autoglo, znam , z3d ) ; sxyc0(:,:,jk,:) = z3d(:,:,:)
+ znam = 'sxc0'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; sxc0 (:,:,jk,:) = z3d(:,:,:)
+ znam = 'syc0'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; syc0 (:,:,jk,:) = z3d(:,:,:)
+ znam = 'sxxc0'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; sxxc0(:,:,jk,:) = z3d(:,:,:)
+ znam = 'syyc0'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; syyc0(:,:,jk,:) = z3d(:,:,:)
+ znam = 'sxyc0'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; sxyc0(:,:,jk,:) = z3d(:,:,:)
END DO
! ! ice layers heat content
DO jk = 1, nlay_i
WRITE(zchar1,'(I2.2)') jk
- znam = 'sxe'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_autoglo, znam , z3d ) ; sxe (:,:,jk,:) = z3d(:,:,:)
- znam = 'sye'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_autoglo, znam , z3d ) ; sye (:,:,jk,:) = z3d(:,:,:)
- znam = 'sxxe'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_autoglo, znam , z3d ) ; sxxe(:,:,jk,:) = z3d(:,:,:)
- znam = 'syye'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_autoglo, znam , z3d ) ; syye(:,:,jk,:) = z3d(:,:,:)
- znam = 'sxye'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_autoglo, znam , z3d ) ; sxye(:,:,jk,:) = z3d(:,:,:)
+ znam = 'sxe'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; sxe (:,:,jk,:) = z3d(:,:,:)
+ znam = 'sye'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; sye (:,:,jk,:) = z3d(:,:,:)
+ znam = 'sxxe'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; sxxe(:,:,jk,:) = z3d(:,:,:)
+ znam = 'syye'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; syye(:,:,jk,:) = z3d(:,:,:)
+ znam = 'sxye'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; sxye(:,:,jk,:) = z3d(:,:,:)
END DO
!
- IF( ln_pnd_H12 ) THEN ! melt pond fraction
- CALL iom_get( numrir, jpdom_autoglo, 'sxap' , sxap )
- CALL iom_get( numrir, jpdom_autoglo, 'syap' , syap )
- CALL iom_get( numrir, jpdom_autoglo, 'sxxap', sxxap )
- CALL iom_get( numrir, jpdom_autoglo, 'syyap', syyap )
- CALL iom_get( numrir, jpdom_autoglo, 'sxyap', sxyap )
- ! ! melt pond volume
- CALL iom_get( numrir, jpdom_autoglo, 'sxvp' , sxvp )
- CALL iom_get( numrir, jpdom_autoglo, 'syvp' , syvp )
- CALL iom_get( numrir, jpdom_autoglo, 'sxxvp', sxxvp )
- CALL iom_get( numrir, jpdom_autoglo, 'syyvp', syyvp )
- CALL iom_get( numrir, jpdom_autoglo, 'sxyvp', sxyvp )
+ IF( ln_pnd_LEV ) THEN ! melt pond fraction
+ IF( iom_varid( numror, 'sxap', ldstop = .FALSE. ) > 0 ) THEN
+ CALL iom_get( numrir, jpdom_auto, 'sxap' , sxap )
+ CALL iom_get( numrir, jpdom_auto, 'syap' , syap )
+ 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
+ CALL iom_get( numrir, jpdom_auto, 'sxvp' , sxvp )
+ CALL iom_get( numrir, jpdom_auto, 'syvp' , syvp )
+ CALL iom_get( numrir, jpdom_auto, 'sxxvp', sxxvp )
+ CALL iom_get( numrir, jpdom_auto, 'syyvp', syyvp )
+ CALL iom_get( numrir, jpdom_auto, 'sxyvp', sxyvp )
+ ELSE
+ 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
+ ENDIF
+ !
+ IF ( ln_pnd_lids ) THEN ! melt pond lid volume
+ IF( iom_varid( numror, 'sxvl', ldstop = .FALSE. ) > 0 ) THEN
+ CALL iom_get( numrir, jpdom_auto, 'sxvl' , sxvl )
+ CALL iom_get( numrir, jpdom_auto, 'syvl' , syvl )
+ 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
ENDIF
!
@@ -845,7 +962,10 @@
sxc0 = 0._wp ; syc0 = 0._wp ; sxxc0 = 0._wp ; syyc0 = 0._wp ; sxyc0 = 0._wp ! snow layers heat content
sxe = 0._wp ; sye = 0._wp ; sxxe = 0._wp ; syye = 0._wp ; sxye = 0._wp ! ice layers heat content
- IF( ln_pnd_H12 ) 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_LEV ) 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
ENDIF
ENDIF
@@ -910,5 +1030,5 @@
END DO
!
- IF( ln_pnd_H12 ) THEN ! melt pond fraction
+ IF( ln_pnd_LEV ) THEN ! melt pond fraction
CALL iom_rstput( iter, nitrst, numriw, 'sxap' , sxap )
CALL iom_rstput( iter, nitrst, numriw, 'syap' , syap )
@@ -922,4 +1042,12 @@
CALL iom_rstput( iter, nitrst, numriw, 'syyvp', syyvp )
CALL iom_rstput( iter, nitrst, numriw, 'sxyvp', sxyvp )
+ !
+ IF ( ln_pnd_lids ) THEN ! melt pond lid volume
+ CALL iom_rstput( iter, nitrst, numriw, 'sxvl' , sxvl )
+ CALL iom_rstput( iter, nitrst, numriw, 'syvl' , syvl )
+ CALL iom_rstput( iter, nitrst, numriw, 'sxxvl', sxxvl )
+ CALL iom_rstput( iter, nitrst, numriw, 'syyvl', syyvl )
+ CALL iom_rstput( iter, nitrst, numriw, 'sxyvl', sxyvl )
+ ENDIF
ENDIF
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/ICE/icedyn_adv_umx.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/ICE/icedyn_adv_umx.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/ICE/icedyn_adv_umx.F90 (revision 13540)
@@ -60,5 +60,5 @@
SUBROUTINE ice_dyn_adv_umx( kn_umx, kt, pu_ice, pv_ice, ph_i, ph_s, ph_ip, &
- & pato_i, pv_i, pv_s, psv_i, poa_i, pa_i, pa_ip, pv_ip, pe_s, pe_i )
+ & pato_i, pv_i, pv_s, psv_i, poa_i, pa_i, pa_ip, pv_ip, pv_il, pe_s, pe_i )
!!----------------------------------------------------------------------
!! *** ROUTINE ice_dyn_adv_umx ***
@@ -85,4 +85,5 @@
REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: pa_ip ! melt pond concentration
REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: pv_ip ! melt pond volume
+ REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: pv_il ! melt pond lid volume
REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: pe_s ! snw heat content
REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: pe_i ! ice heat content
@@ -92,11 +93,13 @@
REAL(wp) :: zamsk ! 1 if advection of concentration, 0 if advection of other tracers
REAL(wp) :: zdt, zvi_cen
- 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,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
- REAL(wp), DIMENSION(jpi,jpj,jpl) :: zhi_max, zhs_max, zhip_max
+ 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,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
+ 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), ALLOCATABLE, DIMENSION(:,:,:) :: zuv_ho, zvv_ho, zuv_ups, zvv_ups, z1_vi, z1_vs
@@ -105,7 +108,11 @@
IF( kt == nit000 .AND. lwp ) WRITE(numout,*) '-- ice_dyn_adv_umx: Ultimate-Macho advection scheme'
!
- ! --- Record max of the surrounding 9-pts ice thick. (for call Hbig) --- !
- DO jl = 1, jpl
- DO_2D_00_00
+ ! --- 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
+ DO jl = 1, jpl
+ DO_2D( 0, 0, 0, 0 )
zhip_max(ji,jj,jl) = MAX( epsi20, ph_ip(ji,jj,jl), ph_ip(ji+1,jj ,jl), ph_ip(ji ,jj+1,jl), &
& ph_ip(ji-1,jj ,jl), ph_ip(ji ,jj-1,jl), &
@@ -120,7 +127,41 @@
& ph_s (ji+1,jj+1,jl), ph_s (ji-1,jj-1,jl), &
& ph_s (ji+1,jj-1,jl), ph_s (ji-1,jj+1,jl) )
- END_2D
- END DO
- CALL lbc_lnk_multi( 'icedyn_adv_umx', zhi_max, 'T', 1., zhs_max, 'T', 1., zhip_max, 'T', 1. )
+ zsi_max (ji,jj,jl) = MAX( epsi20, zs_i (ji,jj,jl), zs_i (ji+1,jj ,jl), zs_i (ji ,jj+1,jl), &
+ & zs_i (ji-1,jj ,jl), zs_i (ji ,jj-1,jl), &
+ & zs_i (ji+1,jj+1,jl), zs_i (ji-1,jj-1,jl), &
+ & zs_i (ji+1,jj-1,jl), zs_i (ji-1,jj+1,jl) )
+ END_2D
+ END DO
+ CALL lbc_lnk_multi( 'icedyn_adv_umx', 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
+ DO jl = 1, jpl
+ DO_3D( 0, 0, 0, 0, 1, nlay_i )
+ zei_max(ji,jj,jk,jl) = MAX( epsi20, ze_i(ji,jj,jk,jl), ze_i(ji+1,jj ,jk,jl), ze_i(ji ,jj+1,jk,jl), &
+ & ze_i(ji-1,jj ,jk,jl), ze_i(ji ,jj-1,jk,jl), &
+ & ze_i(ji+1,jj+1,jk,jl), ze_i(ji-1,jj-1,jk,jl), &
+ & ze_i(ji+1,jj-1,jk,jl), ze_i(ji-1,jj+1,jk,jl) )
+ END_3D
+ END DO
+ DO jl = 1, jpl
+ DO_3D( 0, 0, 0, 0, 1, nlay_s )
+ zes_max(ji,jj,jk,jl) = MAX( epsi20, ze_s(ji,jj,jk,jl), ze_s(ji+1,jj ,jk,jl), ze_s(ji ,jj+1,jk,jl), &
+ & ze_s(ji-1,jj ,jk,jl), ze_s(ji ,jj-1,jk,jl), &
+ & ze_s(ji+1,jj+1,jk,jl), ze_s(ji-1,jj-1,jk,jl), &
+ & ze_s(ji+1,jj-1,jk,jl), ze_s(ji-1,jj+1,jk,jl) )
+ END_3D
+ END DO
+ CALL lbc_lnk( 'icedyn_adv_pra', zei_max, 'T', 1. )
+ CALL lbc_lnk( 'icedyn_adv_pra', zes_max, 'T', 1. )
!
!
@@ -150,5 +191,5 @@
!
! --- define velocity for advection: u*grad(H) --- !
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
IF ( pu_ice(ji,jj) * pu_ice(ji-1,jj) <= 0._wp ) THEN ; zcu_box(ji,jj) = 0._wp
ELSEIF( pu_ice(ji,jj) > 0._wp ) THEN ; zcu_box(ji,jj) = pu_ice(ji-1,jj)
@@ -183,5 +224,5 @@
IF( .NOT. ALLOCATED(jmsk_small) ) ALLOCATE( jmsk_small(jpi,jpj,jpl) )
DO jl = 1, jpl
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
zvi_cen = 0.5_wp * ( pv_i(ji+1,jj,jl) + pv_i(ji,jj,jl) )
IF( zvi_cen < epsi06) THEN ; imsk_small(ji,jj,jl) = 0
@@ -318,5 +359,5 @@
!
!== melt ponds ==!
- IF ( ln_pnd_H12 ) THEN
+ IF ( ln_pnd_LEV ) THEN
! concentration
zamsk = 1._wp
@@ -328,13 +369,20 @@
CALL adv_umx( zamsk, kn_umx, jt, kt, zdt, zudy , zvdx , zua_ho , zva_ho , zcu_box, zcv_box, &
& zhvar, pv_ip, zua_ups, zva_ups )
+ ! lid
+ IF ( ln_pnd_lids ) THEN
+ zamsk = 0._wp
+ zhvar(:,:,:) = pv_il(:,:,:) * z1_aip(:,:,:)
+ CALL adv_umx( zamsk, kn_umx, jt, kt, zdt, zudy , zvdx , zua_ho , zva_ho , zcu_box, zcv_box, &
+ & zhvar, pv_il, zua_ups, zva_ups )
+ ENDIF
ENDIF
!
!== Open water area ==!
zati2(:,:) = SUM( pa_i(:,:,:), dim=3 )
- DO_2D_00_00
+ 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
END_2D
- CALL lbc_lnk( 'icedyn_adv_umx', pato_i, 'T', 1. )
+ CALL lbc_lnk( 'icedyn_adv_umx', pato_i, 'T', 1.0_wp )
!
!
@@ -342,9 +390,10 @@
! 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, pe_s, pe_i )
+ 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 )
!
! --- 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, pv_i, pv_s, pa_i, pa_ip, pv_ip, pe_s )
+ 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 --- !
@@ -441,5 +490,5 @@
IF( pamsk == 0._wp ) THEN
DO jl = 1, jpl
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
IF( ABS( pu(ji,jj) ) > epsi10 ) THEN
zfu_ho (ji,jj,jl) = zfu_ho (ji,jj,jl) * puc (ji,jj,jl) / pu(ji,jj)
@@ -463,5 +512,5 @@
! thus we calculate the upstream solution and apply a limiter again
DO jl = 1, jpl
- DO_2D_00_00
+ 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) )
!
@@ -469,5 +518,5 @@
END_2D
END DO
- CALL lbc_lnk( 'icedyn_adv_umx', zt_ups, 'T', 1. )
+ CALL lbc_lnk( 'icedyn_adv_umx', zt_ups, 'T', 1.0_wp )
!
IF ( np_limiter == 1 ) THEN
@@ -484,5 +533,5 @@
IF( PRESENT( pua_ho ) ) THEN
DO jl = 1, jpl
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
pua_ho (ji,jj,jl) = zfu_ho (ji,jj,jl) ; pva_ho (ji,jj,jl) = zfv_ho (ji,jj,jl)
pua_ups(ji,jj,jl) = zfu_ups(ji,jj,jl) ; pva_ups(ji,jj,jl) = zfv_ups(ji,jj,jl)
@@ -494,5 +543,5 @@
! ---------------------------------
DO jl = 1, jpl
- DO_2D_00_00
+ 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) )
!
@@ -500,5 +549,5 @@
END_2D
END DO
- CALL lbc_lnk( 'icedyn_adv_umx', ptc, 'T', 1. )
+ CALL lbc_lnk( 'icedyn_adv_umx', ptc, 'T', 1.0_wp )
!
END SUBROUTINE adv_umx
@@ -528,5 +577,5 @@
!
DO jl = 1, jpl
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
pfu_ups(ji,jj,jl) = MAX( pu(ji,jj), 0._wp ) * pt(ji,jj,jl) + MIN( pu(ji,jj), 0._wp ) * pt(ji+1,jj,jl)
pfv_ups(ji,jj,jl) = MAX( pv(ji,jj), 0._wp ) * pt(ji,jj,jl) + MIN( pv(ji,jj), 0._wp ) * pt(ji,jj+1,jl)
@@ -539,5 +588,5 @@
!
DO jl = 1, jpl !-- flux in x-direction
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
pfu_ups(ji,jj,jl) = MAX( pu(ji,jj), 0._wp ) * pt(ji,jj,jl) + MIN( pu(ji,jj), 0._wp ) * pt(ji+1,jj,jl)
END_2D
@@ -545,5 +594,5 @@
!
DO jl = 1, jpl !-- first guess of tracer from u-flux
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
ztra = - ( pfu_ups(ji,jj,jl) - pfu_ups(ji-1,jj,jl) ) &
& + ( pu (ji,jj ) - pu (ji-1,jj ) ) * pt(ji,jj,jl) * (1.-pamsk)
@@ -552,8 +601,8 @@
END_2D
END DO
- CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. )
+ CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1.0_wp )
!
DO jl = 1, jpl !-- flux in y-direction
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
pfv_ups(ji,jj,jl) = MAX( pv(ji,jj), 0._wp ) * zpt(ji,jj,jl) + MIN( pv(ji,jj), 0._wp ) * zpt(ji,jj+1,jl)
END_2D
@@ -563,5 +612,5 @@
!
DO jl = 1, jpl !-- flux in y-direction
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
pfv_ups(ji,jj,jl) = MAX( pv(ji,jj), 0._wp ) * pt(ji,jj,jl) + MIN( pv(ji,jj), 0._wp ) * pt(ji,jj+1,jl)
END_2D
@@ -569,5 +618,5 @@
!
DO jl = 1, jpl !-- first guess of tracer from v-flux
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
ztra = - ( pfv_ups(ji,jj,jl) - pfv_ups(ji,jj-1,jl) ) &
& + ( pv (ji,jj ) - pv (ji,jj-1 ) ) * pt(ji,jj,jl) * (1.-pamsk)
@@ -576,8 +625,8 @@
END_2D
END DO
- CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. )
+ CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1.0_wp )
!
DO jl = 1, jpl !-- flux in x-direction
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
pfu_ups(ji,jj,jl) = MAX( pu(ji,jj), 0._wp ) * zpt(ji,jj,jl) + MIN( pu(ji,jj), 0._wp ) * zpt(ji+1,jj,jl)
END_2D
@@ -589,5 +638,5 @@
!
DO jl = 1, jpl !-- after tracer with upstream scheme
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
ztra = - ( pfu_ups(ji,jj,jl) - pfu_ups(ji-1,jj ,jl) &
& + pfv_ups(ji,jj,jl) - pfv_ups(ji ,jj-1,jl) ) &
@@ -598,5 +647,5 @@
END_2D
END DO
- CALL lbc_lnk( 'icedyn_adv_umx', pt_ups, 'T', 1. )
+ CALL lbc_lnk( 'icedyn_adv_umx', pt_ups, 'T', 1.0_wp )
END SUBROUTINE upstream
@@ -628,5 +677,5 @@
!
DO jl = 1, jpl
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
pfu_ho(ji,jj,jl) = 0.5_wp * pu(ji,jj) * ( pt(ji,jj,jl) + pt(ji+1,jj ,jl) )
pfv_ho(ji,jj,jl) = 0.5_wp * pv(ji,jj) * ( pt(ji,jj,jl) + pt(ji ,jj+1,jl) )
@@ -646,5 +695,5 @@
!
DO jl = 1, jpl !-- flux in x-direction
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
pfu_ho(ji,jj,jl) = 0.5_wp * pu(ji,jj) * ( pt(ji,jj,jl) + pt(ji+1,jj,jl) )
END_2D
@@ -653,5 +702,5 @@
DO jl = 1, jpl !-- first guess of tracer from u-flux
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
ztra = - ( pfu_ho(ji,jj,jl) - pfu_ho(ji-1,jj,jl) ) &
& + ( pu (ji,jj ) - pu (ji-1,jj ) ) * pt(ji,jj,jl) * (1.-pamsk)
@@ -660,8 +709,8 @@
END_2D
END DO
- CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. )
+ CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1.0_wp )
DO jl = 1, jpl !-- flux in y-direction
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
pfv_ho(ji,jj,jl) = 0.5_wp * pv(ji,jj) * ( zpt(ji,jj,jl) + zpt(ji,jj+1,jl) )
END_2D
@@ -672,5 +721,5 @@
!
DO jl = 1, jpl !-- flux in y-direction
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
pfv_ho(ji,jj,jl) = 0.5_wp * pv(ji,jj) * ( pt(ji,jj,jl) + pt(ji,jj+1,jl) )
END_2D
@@ -679,5 +728,5 @@
!
DO jl = 1, jpl !-- first guess of tracer from v-flux
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
ztra = - ( pfv_ho(ji,jj,jl) - pfv_ho(ji,jj-1,jl) ) &
& + ( pv (ji,jj ) - pv (ji,jj-1 ) ) * pt(ji,jj,jl) * (1.-pamsk)
@@ -686,8 +735,8 @@
END_2D
END DO
- CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. )
+ CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1.0_wp )
!
DO jl = 1, jpl !-- flux in x-direction
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
pfu_ho(ji,jj,jl) = 0.5_wp * pu(ji,jj) * ( zpt(ji,jj,jl) + zpt(ji+1,jj,jl) )
END_2D
@@ -737,5 +786,5 @@
! !-- advective form update in zpt --!
DO jl = 1, jpl
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
zpt(ji,jj,jl) = ( pt(ji,jj,jl) - ( pubox(ji,jj ) * ( zt_u(ji,jj,jl) - zt_u(ji-1,jj,jl) ) * r1_e1t (ji,jj) &
& + pt (ji,jj,jl) * ( pu (ji,jj ) - pu (ji-1,jj ) ) * r1_e1e2t(ji,jj) &
@@ -744,5 +793,5 @@
END_2D
END DO
- CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. )
+ CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1.0_wp )
!
! !-- ultimate interpolation of pt at v-point --!
@@ -764,5 +813,5 @@
! !-- advective form update in zpt --!
DO jl = 1, jpl
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
zpt(ji,jj,jl) = ( pt(ji,jj,jl) - ( pvbox(ji,jj ) * ( zt_v(ji,jj,jl) - zt_v(ji,jj-1,jl) ) * r1_e2t (ji,jj) &
& + pt (ji,jj,jl) * ( pv (ji,jj ) - pv (ji,jj-1 ) ) * r1_e1e2t(ji,jj) &
@@ -771,5 +820,5 @@
END_2D
END DO
- CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. )
+ CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1.0_wp )
!
! !-- ultimate interpolation of pt at u-point --!
@@ -824,5 +873,5 @@
END DO
END DO
- CALL lbc_lnk( 'icedyn_adv_umx', ztu2, 'T', 1. )
+ CALL lbc_lnk( 'icedyn_adv_umx', ztu2, 'T', 1.0_wp )
!
! !-- BiLaplacian in i-direction --!
@@ -838,5 +887,5 @@
END DO
END DO
- CALL lbc_lnk( 'icedyn_adv_umx', ztu4, 'T', 1. )
+ CALL lbc_lnk( 'icedyn_adv_umx', ztu4, 'T', 1.0_wp )
!
!
@@ -846,5 +895,5 @@
!
DO jl = 1, jpl
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
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) ) )
@@ -855,5 +904,5 @@
!
DO jl = 1, jpl
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
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) &
@@ -865,5 +914,5 @@
!
DO jl = 1, jpl
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
zcu = pu(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj)
zdx2 = e1u(ji,jj) * e1u(ji,jj)
@@ -879,5 +928,5 @@
!
DO jl = 1, jpl
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
zcu = pu(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj)
zdx2 = e1u(ji,jj) * e1u(ji,jj)
@@ -893,5 +942,5 @@
!
DO jl = 1, jpl
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
zcu = pu(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj)
zdx2 = e1u(ji,jj) * e1u(ji,jj)
@@ -914,5 +963,5 @@
IF( ll_neg ) THEN
DO jl = 1, jpl
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
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) &
@@ -924,5 +973,5 @@
! !-- High order flux in i-direction --!
DO jl = 1, jpl
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
pfu_ho(ji,jj,jl) = pu(ji,jj) * pt_u(ji,jj,jl)
END_2D
@@ -957,23 +1006,23 @@
! !-- Laplacian in j-direction --!
DO jl = 1, jpl
- DO_2D_10_00
+ DO_2D( 1, 0, 0, 0 ) ! First derivative (gradient)
ztv1(ji,jj,jl) = ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) * r1_e2v(ji,jj) * vmask(ji,jj,1)
END_2D
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 ) ! Second derivative (Laplacian)
ztv2(ji,jj,jl) = ( ztv1(ji,jj,jl) - ztv1(ji,jj-1,jl) ) * r1_e2t(ji,jj)
END_2D
END DO
- CALL lbc_lnk( 'icedyn_adv_umx', ztv2, 'T', 1. )
+ CALL lbc_lnk( 'icedyn_adv_umx', ztv2, 'T', 1.0_wp )
!
! !-- BiLaplacian in j-direction --!
DO jl = 1, jpl
- DO_2D_10_00
+ DO_2D( 1, 0, 0, 0 ) ! First derivative
ztv3(ji,jj,jl) = ( ztv2(ji,jj+1,jl) - ztv2(ji,jj,jl) ) * r1_e2v(ji,jj) * vmask(ji,jj,1)
END_2D
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 ) ! Second derivative
ztv4(ji,jj,jl) = ( ztv3(ji,jj,jl) - ztv3(ji,jj-1,jl) ) * r1_e2t(ji,jj)
END_2D
END DO
- CALL lbc_lnk( 'icedyn_adv_umx', ztv4, 'T', 1. )
+ CALL lbc_lnk( 'icedyn_adv_umx', ztv4, 'T', 1.0_wp )
!
!
@@ -982,5 +1031,5 @@
CASE( 1 ) !== 1st order central TIM ==! (Eq. 21)
DO jl = 1, jpl
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
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) ) )
@@ -990,5 +1039,5 @@
CASE( 2 ) !== 2nd order central TIM ==! (Eq. 23)
DO jl = 1, jpl
- DO_2D_10_10
+ DO_2D( 1, 0, 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) &
@@ -999,5 +1048,5 @@
CASE( 3 ) !== 3rd order central TIM ==! (Eq. 24)
DO jl = 1, jpl
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
zcv = pv(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj)
zdy2 = e2v(ji,jj) * e2v(ji,jj)
@@ -1012,5 +1061,5 @@
CASE( 4 ) !== 4th order central TIM ==! (Eq. 27)
DO jl = 1, jpl
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
zcv = pv(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj)
zdy2 = e2v(ji,jj) * e2v(ji,jj)
@@ -1025,5 +1074,5 @@
CASE( 5 ) !== 5th order central TIM ==! (Eq. 29)
DO jl = 1, jpl
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
zcv = pv(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj)
zdy2 = e2v(ji,jj) * e2v(ji,jj)
@@ -1046,5 +1095,5 @@
IF( ll_neg ) THEN
DO jl = 1, jpl
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
IF( pt_v(ji,jj,jl) < 0._wp .OR. ( jmsk_small(ji,jj,jl) == 0 .AND. pamsk == 0. ) ) THEN
pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * ( ( pt(ji,jj+1,jl) + pt(ji,jj,jl) ) &
@@ -1056,5 +1105,5 @@
! !-- High order flux in j-direction --!
DO jl = 1, jpl
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
pfv_ho(ji,jj,jl) = pv(ji,jj) * pt_v(ji,jj,jl)
END_2D
@@ -1092,5 +1141,5 @@
! --------------------------------------------------
DO jl = 1, jpl
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
pfu_ho(ji,jj,jl) = pfu_ho(ji,jj,jl) - pfu_ups(ji,jj,jl)
pfv_ho(ji,jj,jl) = pfv_ho(ji,jj,jl) - pfv_ups(ji,jj,jl)
@@ -1109,13 +1158,13 @@
DO jl = 1, jpl
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
zti_ups(ji,jj,jl)= pt_ups(ji+1,jj ,jl)
ztj_ups(ji,jj,jl)= pt_ups(ji ,jj+1,jl)
END_2D
END DO
- CALL lbc_lnk_multi( 'icedyn_adv_umx', zti_ups, 'T', 1., ztj_ups, 'T', 1. )
-
- DO jl = 1, jpl
- DO_2D_00_00
+ CALL lbc_lnk_multi( 'icedyn_adv_umx', zti_ups, 'T', 1.0_wp, ztj_ups, 'T', 1.0_wp )
+
+ DO jl = 1, jpl
+ DO_2D( 0, 0, 0, 0 )
IF ( pfu_ho(ji,jj,jl) * ( pt_ups(ji+1,jj ,jl) - pt_ups(ji,jj,jl) ) <= 0._wp .AND. &
& pfv_ho(ji,jj,jl) * ( pt_ups(ji ,jj+1,jl) - pt_ups(ji,jj,jl) ) <= 0._wp ) THEN
@@ -1136,5 +1185,5 @@
END_2D
END DO
- CALL lbc_lnk_multi( 'icedyn_adv_umx', pfu_ho, 'U', -1., pfv_ho, 'V', -1. ) ! lateral boundary cond.
+ CALL lbc_lnk_multi( 'icedyn_adv_umx', pfu_ho, 'U', -1.0_wp, pfv_ho, 'V', -1.0_wp ) ! lateral boundary cond.
ENDIF
@@ -1146,5 +1195,5 @@
DO jl = 1, jpl
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
IF ( pt(ji,jj,jl) <= 0._wp .AND. pt_ups(ji,jj,jl) <= 0._wp ) THEN
zbup(ji,jj) = -zbig
@@ -1162,5 +1211,5 @@
END_2D
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
!
zup = MAX( zbup(ji,jj), zbup(ji-1,jj), zbup(ji+1,jj), zbup(ji,jj-1), zbup(ji,jj+1) ) ! search max/min in neighbourhood
@@ -1193,5 +1242,5 @@
END_2D
END DO
- CALL lbc_lnk_multi( 'icedyn_adv_umx', zbetup, 'T', 1., zbetdo, 'T', 1. ) ! lateral boundary cond. (unchanged sign)
+ CALL lbc_lnk_multi( 'icedyn_adv_umx', zbetup, 'T', 1.0_wp, zbetdo, 'T', 1.0_wp ) ! lateral boundary cond. (unchanged sign)
@@ -1199,5 +1248,5 @@
! ---------------------------------
DO jl = 1, jpl
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
zau = MIN( 1._wp , zbetdo(ji,jj,jl) , zbetup(ji+1,jj,jl) )
zbu = MIN( 1._wp , zbetup(ji,jj,jl) , zbetdo(ji+1,jj,jl) )
@@ -1210,5 +1259,5 @@
END_2D
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
zav = MIN( 1._wp , zbetdo(ji,jj,jl) , zbetup(ji,jj+1,jl) )
zbv = MIN( 1._wp , zbetup(ji,jj,jl) , zbetdo(ji,jj+1,jl) )
@@ -1244,12 +1293,12 @@
!
DO jl = 1, jpl
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
zslpx(ji,jj,jl) = ( pt(ji+1,jj,jl) - pt(ji,jj,jl) ) * umask(ji,jj,1)
END_2D
END DO
- CALL lbc_lnk( 'icedyn_adv_umx', zslpx, 'U', -1.) ! lateral boundary cond.
+ CALL lbc_lnk( 'icedyn_adv_umx', zslpx, 'U', -1.0_wp) ! lateral boundary cond.
DO jl = 1, jpl
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
uCFL = pdt * ABS( pu(ji,jj) ) * r1_e1e2t(ji,jj)
@@ -1312,5 +1361,5 @@
END_2D
END DO
- CALL lbc_lnk( 'icedyn_adv_umx', pfu_ho, 'U', -1.) ! lateral boundary cond.
+ CALL lbc_lnk( 'icedyn_adv_umx', pfu_ho, 'U', -1.0_wp) ! lateral boundary cond.
!
END SUBROUTINE limiter_x
@@ -1335,12 +1384,12 @@
!
DO jl = 1, jpl
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
zslpy(ji,jj,jl) = ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) * vmask(ji,jj,1)
END_2D
END DO
- CALL lbc_lnk( 'icedyn_adv_umx', zslpy, 'V', -1.) ! lateral boundary cond.
-
- DO jl = 1, jpl
- DO_2D_00_00
+ CALL lbc_lnk( 'icedyn_adv_umx', zslpy, 'V', -1.0_wp) ! lateral boundary cond.
+
+ DO jl = 1, jpl
+ DO_2D( 0, 0, 0, 0 )
vCFL = pdt * ABS( pv(ji,jj) ) * r1_e1e2t(ji,jj)
@@ -1404,10 +1453,11 @@
END_2D
END DO
- CALL lbc_lnk( 'icedyn_adv_umx', pfv_ho, 'V', -1.) ! lateral boundary cond.
+ CALL lbc_lnk( 'icedyn_adv_umx', pfv_ho, 'V', -1.0_wp) ! lateral boundary cond.
!
END SUBROUTINE limiter_y
- SUBROUTINE Hbig( pdt, phi_max, phs_max, phip_max, pv_i, pv_s, pa_i, pa_ip, pv_ip, pe_s )
+ SUBROUTINE Hbig( 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 ***
@@ -1423,11 +1473,14 @@
!! ** input : Max thickness of the surrounding 9-points
!!-------------------------------------------------------------------
- REAL(wp) , INTENT(in ) :: pdt ! tracer time-step
- REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: phi_max, phs_max, phip_max ! max ice thick from surrounding 9-pts
- REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: pv_i, pv_s, pa_i, pa_ip, pv_ip
+ 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(inout) :: pv_i, pv_s, pa_i, pa_ip, pv_ip, psv_i
REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: pe_s
- !
- INTEGER :: ji, jj, jl ! dummy loop indices
- REAL(wp) :: z1_dt, zhip, zhi, zhs, zfra
+ REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: pe_i
+ !
+ INTEGER :: ji, jj, jk, jl ! dummy loop indices
+ REAL(wp) :: z1_dt, zhip, zhi, zhs, zsi, zes, zei, zfra
!!-------------------------------------------------------------------
!
@@ -1435,11 +1488,10 @@
!
DO jl = 1, jpl
-
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
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_H12 .AND. pv_ip(ji,jj,jl) > 0._wp ) THEN
+ IF( ln_pnd_LEV .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
@@ -1468,7 +1520,45 @@
ENDIF
!
+ ! ! -- 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
+ !
ENDIF
END_2D
END DO
+ !
+ ! ! -- check e_i/v_i -- !
+ DO jl = 1, jpl
+ DO_3D( 1, 1, 1, 1, 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
+ ENDIF
+ END_3D
+ END DO
+ ! ! -- check e_s/v_s -- !
+ DO jl = 1, jpl
+ DO_3D( 1, 1, 1, 1, 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
+ ENDIF
+ END_3D
+ END DO
!
END SUBROUTINE Hbig
@@ -1502,5 +1592,5 @@
! -- check snow load -- !
DO jl = 1, jpl
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
IF ( pv_i(ji,jj,jl) > 0._wp ) THEN
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/ICE/icedyn_rdgrft.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/ICE/icedyn_rdgrft.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/ICE/icedyn_rdgrft.F90 (revision 13540)
@@ -161,5 +161,5 @@
npti = 0 ; nptidx(:) = 0
ipti = 0 ; iptidx(:) = 0
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
IF ( at_i(ji,jj) > epsi10 ) THEN
npti = npti + 1
@@ -300,5 +300,13 @@
! ! Ice thickness needed for rafting
+ ! In single precision there were floating point invalids due a sqrt of zhi which happens to have negative values
+ ! To solve that an extra check about the value of pv_i was added.
+ ! Although adding this condition is safe, the double definition (one for single other for double) has been kept to preserve the results of the sette test.
+#if defined key_single
+
+ WHERE( pa_i(1:npti,:) > epsi10 .and. pv_i(1:npti,:) > epsi10 ) ; zhi(1:npti,:) = pv_i(1:npti,:) / pa_i(1:npti,:)
+#else
WHERE( pa_i(1:npti,:) > epsi10 ) ; zhi(1:npti,:) = pv_i(1:npti,:) / pa_i(1:npti,:)
+#endif
ELSEWHERE ; zhi(1:npti,:) = 0._wp
END WHERE
@@ -494,6 +502,6 @@
REAL(wp) :: airdg1, oirdg1, aprdg1, virdg1, sirdg1
REAL(wp) :: airft1, oirft1, aprft1
- REAL(wp), DIMENSION(jpij) :: airdg2, oirdg2, aprdg2, virdg2, sirdg2, vsrdg, vprdg ! area etc of new ridges
- REAL(wp), DIMENSION(jpij) :: airft2, oirft2, aprft2, virft , sirft , vsrft, vprft ! area etc of rafted ice
+ 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
@@ -522,5 +530,7 @@
DO jl1 = 1, jpl
- CALL tab_2d_1d( npti, nptidx(1:npti), s_i_1d(1:npti), s_i(:,:,jl1) )
+ IF( nn_icesal /= 2 ) THEN
+ CALL tab_2d_1d( npti, nptidx(1:npti), s_i_1d(1:npti), s_i(:,:,jl1) )
+ ENDIF
DO ji = 1, npti
@@ -565,5 +575,5 @@
oirft2(ji) = oa_i_2d(ji,jl1) * afrft * hi_hrft
- IF ( ln_pnd_H12 ) THEN
+ IF ( ln_pnd_LEV ) THEN
aprdg1 = a_ip_2d(ji,jl1) * afrdg
aprdg2(ji) = a_ip_2d(ji,jl1) * afrdg * hi_hrdg(ji,jl1)
@@ -572,4 +582,8 @@
aprft2(ji) = a_ip_2d(ji,jl1) * afrft * hi_hrft
vprft (ji) = v_ip_2d(ji,jl1) * afrft
+ IF ( ln_pnd_lids ) THEN
+ vlrdg (ji) = v_il_2d(ji,jl1) * afrdg
+ vlrft (ji) = v_il_2d(ji,jl1) * afrft
+ ENDIF
ENDIF
@@ -598,7 +612,10 @@
sv_i_2d(ji,jl1) = sv_i_2d(ji,jl1) - sirdg1 - sirft(ji)
oa_i_2d(ji,jl1) = oa_i_2d(ji,jl1) - oirdg1 - oirft1
- IF ( ln_pnd_H12 ) THEN
+ IF ( ln_pnd_LEV ) THEN
a_ip_2d(ji,jl1) = a_ip_2d(ji,jl1) - aprdg1 - aprft1
v_ip_2d(ji,jl1) = v_ip_2d(ji,jl1) - vprdg(ji) - vprft(ji)
+ IF ( ln_pnd_lids ) THEN
+ v_il_2d(ji,jl1) = v_il_2d(ji,jl1) - vlrdg(ji) - vlrft(ji)
+ ENDIF
ENDIF
ENDIF
@@ -692,9 +709,13 @@
v_s_2d (ji,jl2) = v_s_2d (ji,jl2) + ( vsrdg (ji) * rn_fsnwrdg * fvol(ji) + &
& vsrft (ji) * rn_fsnwrft * zswitch(ji) )
- IF ( ln_pnd_H12 ) THEN
+ IF ( ln_pnd_LEV ) 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) )
+ 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) )
+ ENDIF
ENDIF
@@ -727,5 +748,5 @@
!----------------
! 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, 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, ze_s_2d, ze_i_2d )
!
END SUBROUTINE rdgrft_shift
@@ -766,5 +787,5 @@
! !--------------------------------------------------!
CASE( 1 ) !--- Spatial smoothing
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
IF ( SUM( a_i(ji,jj,:) ) > 0._wp ) THEN
zworka(ji,jj) = ( 4.0 * strength(ji,jj) &
@@ -777,8 +798,8 @@
END_2D
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
strength(ji,jj) = zworka(ji,jj)
END_2D
- CALL lbc_lnk( 'icedyn_rdgrft', strength, 'T', 1. )
+ CALL lbc_lnk( 'icedyn_rdgrft', strength, 'T', 1.0_wp )
!
CASE( 2 ) !--- Temporal smoothing
@@ -788,5 +809,5 @@
ENDIF
!
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
IF ( SUM( a_i(ji,jj,:) ) > 0._wp ) THEN
itframe = 1 ! number of time steps for the running mean
@@ -799,5 +820,5 @@
ENDIF
END_2D
- CALL lbc_lnk( 'icedyn_rdgrft', strength, 'T', 1. )
+ CALL lbc_lnk( 'icedyn_rdgrft', strength, 'T', 1.0_wp )
!
END SELECT
@@ -833,4 +854,5 @@
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
@@ -859,4 +881,5 @@
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
Index: /NEMO/branches/2020/r12377_ticket2386/src/ICE/icedyn_rhg.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/ICE/icedyn_rhg.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/ICE/icedyn_rhg.F90 (revision 13540)
@@ -108,5 +108,5 @@
INTEGER :: ios, ioptio ! Local integer output status for namelist read
!!
- NAMELIST/namdyn_rhg/ ln_rhg_EVP, ln_aEVP, rn_creepl, rn_ecc , nn_nevp, rn_relast
+ NAMELIST/namdyn_rhg/ ln_rhg_EVP, ln_aEVP, rn_creepl, rn_ecc , nn_nevp, rn_relast, nn_rhg_chkcvg
!!-------------------------------------------------------------------
!
@@ -122,10 +122,15 @@
WRITE(numout,*) '~~~~~~~~~~~~~~~'
WRITE(numout,*) ' Namelist : namdyn_rhg:'
- WRITE(numout,*) ' rheology EVP (icedyn_rhg_evp) ln_rhg_EVP = ', ln_rhg_EVP
- WRITE(numout,*) ' use adaptive EVP (aEVP) ln_aEVP = ', ln_aEVP
- WRITE(numout,*) ' creep limit rn_creepl = ', rn_creepl
- WRITE(numout,*) ' eccentricity of the elliptical yield curve rn_ecc = ', rn_ecc
- WRITE(numout,*) ' number of iterations for subcycling nn_nevp = ', nn_nevp
- WRITE(numout,*) ' ratio of elastic timescale over ice time step rn_relast = ', rn_relast
+ WRITE(numout,*) ' rheology EVP (icedyn_rhg_evp) ln_rhg_EVP = ', ln_rhg_EVP
+ WRITE(numout,*) ' use adaptive EVP (aEVP) ln_aEVP = ', ln_aEVP
+ WRITE(numout,*) ' creep limit rn_creepl = ', rn_creepl
+ WRITE(numout,*) ' eccentricity of the elliptical yield curve rn_ecc = ', rn_ecc
+ WRITE(numout,*) ' number of iterations for subcycling nn_nevp = ', nn_nevp
+ WRITE(numout,*) ' ratio of elastic timescale over ice time step rn_relast = ', rn_relast
+ WRITE(numout,*) ' check convergence of rheology nn_rhg_chkcvg = ', nn_rhg_chkcvg
+ IF ( nn_rhg_chkcvg == 0 ) THEN ; WRITE(numout,*) ' no check'
+ ELSEIF( nn_rhg_chkcvg == 1 ) THEN ; WRITE(numout,*) ' check cvg at the main time step'
+ ELSEIF( nn_rhg_chkcvg == 2 ) THEN ; WRITE(numout,*) ' check cvg at both main and rheology time steps'
+ ENDIF
ENDIF
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/ICE/icedyn_rhg_evp.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/ICE/icedyn_rhg_evp.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/ICE/icedyn_rhg_evp.F90 (revision 13540)
@@ -41,4 +41,5 @@
USE prtctl ! Print control
+ USE netcdf ! NetCDF library for convergence test
IMPLICIT NONE
PRIVATE
@@ -49,4 +50,10 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
+
+ !! for convergence tests
+ INTEGER :: ncvgid ! netcdf file id
+ INTEGER :: nvarid ! netcdf variable id
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zmsk00, zmsk15
!!----------------------------------------------------------------------
!! NEMO/ICE 4.0 , NEMO Consortium (2018)
@@ -120,4 +127,5 @@
REAL(wp) :: ecc2, z1_ecc2 ! square of yield ellipse eccenticity
REAL(wp) :: zalph1, z1_alph1, zalph2, z1_alph2 ! alpha coef from Bouillon 2009 or Kimmritz 2017
+ REAl(wp) :: zbetau, zbetav
REAL(wp) :: zm1, zm2, zm3, zmassU, zmassV, zvU, zvV ! ice/snow mass and volume
REAL(wp) :: zdelta, zp_delf, zds2, zdt, zdt2, zdiv, zdiv2 ! temporary scalars
@@ -126,5 +134,4 @@
REAL(wp) :: zvCr ! critical ice volume above which ice is landfast
!
- REAL(wp) :: zresm ! Maximal error on ice velocity
REAL(wp) :: zintb, zintn ! dummy argument
REAL(wp) :: zfac_x, zfac_y
@@ -142,5 +149,4 @@
REAL(wp), DIMENSION(jpi,jpj) :: zds ! shear
REAL(wp), DIMENSION(jpi,jpj) :: zs1, zs2, zs12 ! stress tensor components
-!!$ REAL(wp), DIMENSION(jpi,jpj) :: zu_ice, zv_ice, zresr ! check convergence
REAL(wp), DIMENSION(jpi,jpj) :: zsshdyn ! array used for the calculation of ice surface slope:
! ! ocean surface (ssh_m) if ice is not embedded
@@ -156,11 +162,12 @@
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) :: zfmask, zwf ! mask at F points for the ice
+ REAL(wp), DIMENSION(jpi,jpj) :: zfmask ! mask at F points for the ice
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
!! --- diags
- REAL(wp), DIMENSION(jpi,jpj) :: zmsk00
REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zsig1, zsig2, zsig3
!! --- SIMIP diags
@@ -175,10 +182,17 @@
IF( kt == nit000 .AND. lwp ) WRITE(numout,*) '-- ice_dyn_rhg_evp: EVP sea-ice rheology'
!
-!!gm for Clem: OPTIMIZATION: I think zfmask can be computed one for all at the initialization....
+ ! for diagnostics and convergence tests
+ ALLOCATE( zmsk00(jpi,jpj), zmsk15(jpi,jpj) )
+ DO_2D( 1, 1, 1, 1 )
+ zmsk00(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi06 ) ) ! 1 if ice , 0 if no ice
+ 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
+ !
+ !!gm for Clem: OPTIMIZATION: I think zfmask can be computed one for all at the initialization....
!------------------------------------------------------------------------------!
! 0) mask at F points for the ice
!------------------------------------------------------------------------------!
! ocean/land mask
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
zfmask(ji,jj) = tmask(ji,jj,1) * tmask(ji+1,jj,1) * tmask(ji,jj+1,1) * tmask(ji+1,jj+1,1)
END_2D
@@ -186,24 +200,24 @@
! Lateral boundary conditions on velocity (modify zfmask)
- zwf(:,:) = zfmask(:,:)
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
IF( zfmask(ji,jj) == 0._wp ) THEN
- zfmask(ji,jj) = rn_ishlat * MIN( 1._wp , MAX( zwf(ji+1,jj), zwf(ji,jj+1), zwf(ji-1,jj), zwf(ji,jj-1) ) )
+ zfmask(ji,jj) = rn_ishlat * MIN( 1._wp , MAX( umask(ji,jj,1), umask(ji,jj+1,1), &
+ & vmask(ji,jj,1), vmask(ji+1,jj,1) ) )
ENDIF
END_2D
DO jj = 2, jpjm1
IF( zfmask(1,jj) == 0._wp ) THEN
- zfmask(1 ,jj) = rn_ishlat * MIN( 1._wp , MAX( zwf(2,jj), zwf(1,jj+1), zwf(1,jj-1) ) )
+ zfmask(1 ,jj) = rn_ishlat * MIN( 1._wp , MAX( vmask(2,jj,1), umask(1,jj+1,1), umask(1,jj,1) ) )
ENDIF
IF( zfmask(jpi,jj) == 0._wp ) THEN
- zfmask(jpi,jj) = rn_ishlat * MIN( 1._wp , MAX( zwf(jpi,jj+1), zwf(jpim1,jj), zwf(jpi,jj-1) ) )
- ENDIF
+ zfmask(jpi,jj) = rn_ishlat * MIN( 1._wp , MAX( umask(jpi,jj+1,1), vmask(jpim1,jj,1), umask(jpi,jj-1,1) ) )
+ ENDIF
END DO
DO ji = 2, jpim1
IF( zfmask(ji,1) == 0._wp ) THEN
- zfmask(ji,1 ) = rn_ishlat * MIN( 1._wp , MAX( zwf(ji+1,1), zwf(ji,2), zwf(ji-1,1) ) )
+ zfmask(ji, 1 ) = rn_ishlat * MIN( 1._wp , MAX( vmask(ji+1,1,1), umask(ji,2,1), vmask(ji,1,1) ) )
ENDIF
IF( zfmask(ji,jpj) == 0._wp ) THEN
- zfmask(ji,jpj) = rn_ishlat * MIN( 1._wp , MAX( zwf(ji+1,jpj), zwf(ji-1,jpj), zwf(ji,jpjm1) ) )
+ zfmask(ji,jpj) = rn_ishlat * MIN( 1._wp , MAX( vmask(ji+1,jpj,1), vmask(ji-1,jpj,1), umask(ji,jpjm1,1) ) )
ENDIF
END DO
@@ -219,16 +233,17 @@
z1_ecc2 = 1._wp / ecc2
- ! Time step for subcycling
- zdtevp = rDt_ice / REAL( nn_nevp )
- z1_dtevp = 1._wp / zdtevp
-
! alpha parameters (Bouillon 2009)
IF( .NOT. ln_aEVP ) THEN
- zalph1 = ( 2._wp * rn_relast * rDt_ice ) * z1_dtevp
+ zdtevp = rDt_ice / REAL( nn_nevp )
+ zalph1 = 2._wp * rn_relast * REAL( nn_nevp )
zalph2 = zalph1 * z1_ecc2
z1_alph1 = 1._wp / ( zalph1 + 1._wp )
z1_alph2 = 1._wp / ( zalph2 + 1._wp )
+ ELSE
+ zdtevp = rdt_ice
+ ! zalpha parameters set later on adaptatively
ENDIF
+ z1_dtevp = 1._wp / zdtevp
! Initialise stress tensor
@@ -241,5 +256,5 @@
! landfast param from Lemieux(2016): add isotropic tensile strength (following Konig Beatty and Holland, 2010)
- IF( ln_landfast_L16 ) THEN ; zkt = rn_tensile
+ IF( ln_landfast_L16 ) THEN ; zkt = rn_lf_tensile
ELSE ; zkt = 0._wp
ENDIF
@@ -253,5 +268,5 @@
zsshdyn(:,:) = ice_var_sshdyn( ssh_m, snwice_mass, snwice_mass_b)
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
! ice fraction at U-V points
@@ -299,27 +314,27 @@
END_2D
- CALL lbc_lnk_multi( 'icedyn_rhg_evp', zmf, 'T', 1., zdt_m, 'T', 1. )
+ CALL lbc_lnk_multi( 'icedyn_rhg_evp', zmf, 'T', 1.0_wp, zdt_m, 'T', 1.0_wp )
!
! !== Landfast ice parameterization ==!
!
IF( ln_landfast_L16 ) THEN !-- Lemieux 2016
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
! 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)
! ice-bottom stress at U points
- zvCr = zaU(ji,jj) * rn_depfra * hu(ji,jj,Kmm)
- ztaux_base(ji,jj) = - rn_icebfr * MAX( 0._wp, zvU - zvCr ) * EXP( -rn_crhg * ( 1._wp - zaU(ji,jj) ) )
+ zvCr = zaU(ji,jj) * rn_lf_depfra * hu(ji,jj,Kmm)
+ ztaux_base(ji,jj) = - rn_lf_bfr * MAX( 0._wp, zvU - zvCr ) * EXP( -rn_crhg * ( 1._wp - zaU(ji,jj) ) )
! ice-bottom stress at V points
- zvCr = zaV(ji,jj) * rn_depfra * hv(ji,jj,Kmm)
- ztauy_base(ji,jj) = - rn_icebfr * MAX( 0._wp, zvV - zvCr ) * EXP( -rn_crhg * ( 1._wp - zaV(ji,jj) ) )
+ zvCr = zaV(ji,jj) * rn_lf_depfra * hv(ji,jj,Kmm)
+ 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_depfra * ht(ji,jj)
- tau_icebfr(ji,jj) = - rn_icebfr * MAX( 0._wp, vt_i(ji,jj) - zvCr ) * EXP( -rn_crhg * ( 1._wp - at_i(ji,jj) ) )
+ zvCr = at_i(ji,jj) * rn_lf_depfra * ht(ji,jj)
+ 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. )
+ CALL lbc_lnk( 'icedyn_rhg_evp', tau_icebfr(:,:), 'T', 1.0_wp )
!
ELSE !-- no landfast
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
ztaux_base(ji,jj) = 0._wp
ztauy_base(ji,jj) = 0._wp
@@ -336,13 +351,14 @@
l_full_nf_update = jter == nn_nevp ! false: disable full North fold update (performances) for iter = 1 to nn_nevp-1
!
-!!$ IF(sn_cfctl%l_prtctl) THEN ! Convergence test
-!!$ DO jj = 1, jpjm1
-!!$ zu_ice(:,jj) = u_ice(:,jj) ! velocity at previous time step
-!!$ zv_ice(:,jj) = v_ice(:,jj)
-!!$ END DO
-!!$ ENDIF
+ ! convergence test
+ IF( nn_rhg_chkcvg == 1 .OR. nn_rhg_chkcvg == 2 ) THEN
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ 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_10_10
+ DO_2D( 1, 0, 1, 0 )
! shear at F points
@@ -352,7 +368,7 @@
END_2D
- CALL lbc_lnk( 'icedyn_rhg_evp', zds, 'F', 1. )
-
- DO_2D_01_01
+ CALL lbc_lnk( 'icedyn_rhg_evp', zds, 'F', 1.0_wp )
+
+ DO_2D( 0, 1, 0, 1 ) ! loop to jpi,jpj to avoid making a communication for zs1,zs2,zs12 ! no vector loop
! shear**2 at T points (doc eq. A16)
@@ -379,5 +395,5 @@
zp_delt(ji,jj) = strength(ji,jj) / ( zdelta + rn_creepl )
- ! alpha & beta for aEVP
+ ! alpha for aEVP
! gamma = 0.5*P/(delta+creepl) * (c*pi)**2/Area * dt/m
! alpha = beta = sqrt(4*gamma)
@@ -387,4 +403,9 @@
zalph2 = zalph1
z1_alph2 = z1_alph1
+ ! explicit:
+ ! z1_alph1 = 1._wp / zalph1
+ ! z1_alph2 = 1._wp / zalph1
+ ! zalph1 = zalph1 - 1._wp
+ ! zalph2 = zalph1
ENDIF
@@ -394,13 +415,22 @@
END_2D
- CALL lbc_lnk( 'icedyn_rhg_evp', zp_delt, 'T', 1. )
-
- DO_2D_10_10
-
- ! alpha & beta for aEVP
+ CALL lbc_lnk( 'icedyn_rhg_evp', zp_delt, 'T', 1.0_wp )
+
+ ! Save beta at T-points for further computations
+ IF( ln_aEVP ) THEN
+ DO_2D( 1, 1, 1, 1 )
+ 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 )
+
+ ! alpha for aEVP
IF( ln_aEVP ) THEN
- zalph2 = MAX( 50._wp, rpi * SQRT( 0.5_wp * zp_delt(ji,jj) * r1_e1e2t(ji,jj) * zdt_m(ji,jj) ) )
+ zalph2 = MAX( zbeta(ji,jj), zbeta(ji+1,jj), zbeta(ji,jj+1), zbeta(ji+1,jj+1) )
z1_alph2 = 1._wp / ( zalph2 + 1._wp )
- zbeta(ji,jj) = zalph2
+ ! explicit:
+ ! z1_alph2 = 1._wp / zalph2
+ ! zalph2 = zalph2 - 1._wp
ENDIF
@@ -414,5 +444,5 @@
! --- Ice internal stresses (Appendix C of Hunke and Dukowicz, 2002) --- !
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
! !--- U points
zfU(ji,jj) = 0.5_wp * ( ( zs1(ji+1,jj) - zs1(ji,jj) ) * e2u(ji,jj) &
@@ -442,5 +472,5 @@
IF( MOD(jter,2) == 0 ) THEN ! even iterations
!
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
! !--- 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) ) &
@@ -468,20 +498,23 @@
!
IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017)
- v_ice(ji,jj) = ( ( rswitch * ( zmV_t(ji,jj) * ( zbeta(ji,jj) * 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) * ( zbeta(ji,jj) + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast
- & + ( 1._wp - rswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax ) & ! 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
+ 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_lfrelax ) & ! 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)
+ 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)
ENDIF
END_2D
- CALL lbc_lnk( 'icedyn_rhg_evp', v_ice, 'V', -1. )
+ CALL lbc_lnk( 'icedyn_rhg_evp', v_ice, 'V', -1.0_wp )
!
#if defined key_agrif
@@ -491,5 +524,5 @@
IF( ln_bdy ) CALL bdy_ice_dyn( 'V' )
!
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
! !--- 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) ) &
@@ -517,20 +550,23 @@
!
IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017)
- u_ice(ji,jj) = ( ( rswitch * ( zmU_t(ji,jj) * ( zbeta(ji,jj) * 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) * ( zbeta(ji,jj) + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast
- & + ( 1._wp - rswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax ) & ! 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
+ 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)
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_lfrelax ) & ! 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)
+ 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)
ENDIF
END_2D
- CALL lbc_lnk( 'icedyn_rhg_evp', u_ice, 'U', -1. )
+ CALL lbc_lnk( 'icedyn_rhg_evp', u_ice, 'U', -1.0_wp )
!
#if defined key_agrif
@@ -542,5 +578,5 @@
ELSE ! odd iterations
!
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
! !--- 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) ) &
@@ -568,20 +604,23 @@
!
IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017)
- u_ice(ji,jj) = ( ( rswitch * ( zmU_t(ji,jj) * ( zbeta(ji,jj) * 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) * ( zbeta(ji,jj) + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast
- & + ( 1._wp - rswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax ) & ! 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
+ 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)
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_lfrelax ) & ! 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)
+ 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)
ENDIF
END_2D
- CALL lbc_lnk( 'icedyn_rhg_evp', u_ice, 'U', -1. )
+ CALL lbc_lnk( 'icedyn_rhg_evp', u_ice, 'U', -1.0_wp )
!
#if defined key_agrif
@@ -591,5 +630,5 @@
IF( ln_bdy ) CALL bdy_ice_dyn( 'U' )
!
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
! !--- 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) ) &
@@ -617,20 +656,23 @@
!
IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017)
- v_ice(ji,jj) = ( ( rswitch * ( zmV_t(ji,jj) * ( zbeta(ji,jj) * 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) * ( zbeta(ji,jj) + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast
- & + ( 1._wp - rswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax ) & ! 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
+ 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_lfrelax ) & ! 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)
+ 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)
ENDIF
END_2D
- CALL lbc_lnk( 'icedyn_rhg_evp', v_ice, 'V', -1. )
+ CALL lbc_lnk( 'icedyn_rhg_evp', v_ice, 'V', -1.0_wp )
!
#if defined key_agrif
@@ -642,20 +684,16 @@
ENDIF
-!!$ IF(sn_cfctl%l_prtctl) THEN ! Convergence test
-!!$ DO jj = 2 , jpjm1
-!!$ zresr(:,jj) = MAX( ABS( u_ice(:,jj) - zu_ice(:,jj) ), ABS( v_ice(:,jj) - zv_ice(:,jj) ) )
-!!$ END DO
-!!$ zresm = MAXVAL( zresr( 1:jpi, 2:jpjm1 ) )
-!!$ CALL mpp_max( 'icedyn_rhg_evp', zresm ) ! max over the global domain
-!!$ ENDIF
+ ! convergence test
+ IF( nn_rhg_chkcvg == 2 ) CALL rhg_cvg( kt, jter, nn_nevp, u_ice, v_ice, zu_ice, zv_ice )
!
! ! ==================== !
END DO ! end loop over jter !
! ! ==================== !
+ IF( ln_aEVP ) CALL iom_put( 'beta_evp' , zbeta )
!
!------------------------------------------------------------------------------!
! 4) Recompute delta, shear and div (inputs for mechanical redistribution)
!------------------------------------------------------------------------------!
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
! shear at F points
@@ -666,5 +704,5 @@
END_2D
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 ) ! no vector loop
! tension**2 at T points
@@ -693,8 +731,8 @@
END_2D
- CALL lbc_lnk_multi( 'icedyn_rhg_evp', pshear_i, 'T', 1., pdivu_i, 'T', 1., pdelta_i, 'T', 1. )
+ CALL lbc_lnk_multi( 'icedyn_rhg_evp', pshear_i, 'T', 1.0_wp, pdivu_i, 'T', 1.0_wp, pdelta_i, 'T', 1.0_wp )
! --- Store the stress tensor for the next time step --- !
- CALL lbc_lnk_multi( 'icedyn_rhg_evp', zs1, 'T', 1., zs2, 'T', 1., zs12, 'F', 1. )
+ CALL lbc_lnk_multi( 'icedyn_rhg_evp', zs1, 'T', 1.0_wp, zs2, 'T', 1.0_wp, zs12, 'F', 1.0_wp )
pstress1_i (:,:) = zs1 (:,:)
pstress2_i (:,:) = zs2 (:,:)
@@ -705,14 +743,10 @@
! 5) diagnostics
!------------------------------------------------------------------------------!
- DO_2D_11_11
- zmsk00(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi06 ) ) ! 1 if ice, 0 if no ice
- END_2D
-
! --- 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_multi( 'icedyn_rhg_evp', ztaux_oi, 'U', -1., ztauy_oi, 'V', -1., ztaux_ai, 'U', -1., ztauy_ai, 'V', -1., &
- & ztaux_bi, 'U', -1., ztauy_bi, 'V', -1. )
+ CALL lbc_lnk_multi( '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 )
@@ -734,5 +768,5 @@
ALLOCATE( zsig1(jpi,jpj) , zsig2(jpi,jpj) , zsig3(jpi,jpj) )
!
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
zdum1 = ( zmsk00(ji-1,jj) * pstress12_i(ji-1,jj) + zmsk00(ji ,jj-1) * pstress12_i(ji ,jj-1) + & ! stress12_i at T-point
& zmsk00(ji ,jj) * pstress12_i(ji ,jj) + zmsk00(ji-1,jj-1) * pstress12_i(ji-1,jj-1) ) &
@@ -751,5 +785,5 @@
zsig3(ji,jj) = zdum2**2 * ( ( pstress1_i(ji,jj) + strength(ji,jj) )**2 + ( rn_ecc * zshear )**2 )
END_2D
- CALL lbc_lnk_multi( 'icedyn_rhg_evp', zsig1, 'T', 1., zsig2, 'T', 1., zsig3, 'T', 1. )
+ CALL lbc_lnk_multi( 'icedyn_rhg_evp', zsig1, 'T', 1.0_wp, zsig2, 'T', 1.0_wp, zsig3, 'T', 1.0_wp )
!
CALL iom_put( 'isig1' , zsig1 )
@@ -763,11 +797,11 @@
DEALLOCATE( zsig1 , zsig2 , zsig3 )
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_multi( 'icedyn_rhg_evp', zspgU, 'U', -1., zspgV, 'V', -1., &
- & zCorU, 'U', -1., zCorV, 'V', -1., zfU, 'U', -1., zfV, 'V', -1. )
+ CALL lbc_lnk_multi( '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)
@@ -785,5 +819,5 @@
& zdiag_xmtrp_snw(jpi,jpj) , zdiag_ymtrp_snw(jpi,jpj) , zdiag_xatrp(jpi,jpj) , zdiag_yatrp(jpi,jpj) )
!
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
! 2D ice mass, snow mass, area transport arrays (X, Y)
zfac_x = 0.5 * u_ice(ji,jj) * e2u(ji,jj) * zmsk00(ji,jj)
@@ -801,7 +835,7 @@
END_2D
- CALL lbc_lnk_multi( 'icedyn_rhg_evp', zdiag_xmtrp_ice, 'U', -1., zdiag_ymtrp_ice, 'V', -1., &
- & zdiag_xmtrp_snw, 'U', -1., zdiag_ymtrp_snw, 'V', -1., &
- & zdiag_xatrp , 'U', -1., zdiag_yatrp , 'V', -1. )
+ CALL lbc_lnk_multi( '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)
@@ -817,5 +851,88 @@
ENDIF
!
+ ! --- convergence tests --- !
+ 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(:,:) )
+ 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(:,:) )
+ ENDIF
+ ENDIF
+ ENDIF
+ !
+ DEALLOCATE( zmsk00, zmsk15 )
+ !
END SUBROUTINE ice_dyn_rhg_evp
+
+
+ SUBROUTINE rhg_cvg( kt, kiter, kitermax, pu, pv, pub, pvb )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE rhg_cvg ***
+ !!
+ !! ** Purpose : check convergence of oce rheology
+ !!
+ !! ** Method : create a file ice_cvg.nc containing the convergence of ice velocity
+ !! during the sub timestepping of rheology so as:
+ !! uice_cvg = MAX( u(t+1) - u(t) , v(t+1) - v(t) )
+ !! This routine is called every sub-iteration, so it is cpu expensive
+ !!
+ !! ** 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
+ !!
+ INTEGER :: it, idtime, istatus
+ INTEGER :: ji, jj ! dummy loop indices
+ REAL(wp) :: zresm ! local real
+ CHARACTER(len=20) :: clname
+ REAL(wp), DIMENSION(jpi,jpj) :: zres ! check convergence
+ !!----------------------------------------------------------------------
+
+ ! create file
+ IF( kt == nit000 .AND. kiter == 1 ) THEN
+ !
+ IF( lwp ) THEN
+ WRITE(numout,*)
+ WRITE(numout,*) 'rhg_cvg : ice rheology convergence control'
+ WRITE(numout,*) '~~~~~~~'
+ ENDIF
+ !
+ IF( lwm ) THEN
+ clname = 'ice_cvg.nc'
+ 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_ENDDEF(ncvgid)
+ ENDIF
+ !
+ ENDIF
+
+ ! time
+ it = ( kt - 1 ) * kitermax + kiter
+
+ ! convergence
+ IF( kiter == 1 ) THEN ! remove the first iteration for calculations of convergence (always very large)
+ zresm = 0._wp
+ ELSE
+ DO_2D( 1, 1, 1, 1 )
+ zres(ji,jj) = MAX( ABS( pu(ji,jj) - pub(ji,jj) ) * umask(ji,jj,1), &
+ & ABS( pv(ji,jj) - pvb(ji,jj) ) * vmask(ji,jj,1) ) * zmsk15(ji,jj)
+ END_2D
+ zresm = MAXVAL( zres )
+ CALL mpp_max( 'icedyn_rhg_evp', zresm ) ! max over the global domain
+ ENDIF
+
+ IF( lwm ) THEN
+ ! write variables
+ istatus = NF90_PUT_VAR( ncvgid, nvarid, (/zresm/), (/it/), (/1/) )
+ ! close file
+ IF( kt == nitend ) istatus = NF90_CLOSE(ncvgid)
+ ENDIF
+
+ END SUBROUTINE rhg_cvg
@@ -844,7 +961,7 @@
!
IF( MIN( id1, id2, id3 ) > 0 ) THEN ! fields exist
- CALL iom_get( numrir, jpdom_autoglo, 'stress1_i' , stress1_i )
- CALL iom_get( numrir, jpdom_autoglo, 'stress2_i' , stress2_i )
- CALL iom_get( numrir, jpdom_autoglo, 'stress12_i', stress12_i )
+ CALL iom_get( numrir, jpdom_auto, 'stress1_i' , stress1_i , cd_type = 'T' )
+ CALL iom_get( numrir, jpdom_auto, 'stress2_i' , stress2_i , cd_type = 'T' )
+ CALL iom_get( numrir, jpdom_auto, 'stress12_i', stress12_i, cd_type = 'F' )
ELSE ! start rheology from rest
IF(lwp) WRITE(numout,*)
@@ -875,4 +992,5 @@
END SUBROUTINE rhg_evp_rst
+
#else
!!----------------------------------------------------------------------
Index: /NEMO/branches/2020/r12377_ticket2386/src/ICE/iceistate.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/ICE/iceistate.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/ICE/iceistate.F90 (revision 13540)
@@ -33,4 +33,10 @@
USE fldread ! read input fields
+# if defined key_agrif
+ USE agrif_oce
+ USE agrif_ice
+ USE agrif_ice_interp
+# endif
+
IMPLICIT NONE
PRIVATE
@@ -41,13 +47,16 @@
! !! ** namelist (namini) **
LOGICAL, PUBLIC :: ln_iceini !: Ice initialization or not
- LOGICAL, PUBLIC :: ln_iceini_file !: Ice initialization from 2D netcdf file
+ INTEGER, PUBLIC :: nn_iceini_file !: Ice initialization:
+ ! 0 = Initialise sea ice based on SSTs
+ ! 1 = Initialise sea ice from single category netcdf file
+ ! 2 = Initialise sea ice from multi category restart file
REAL(wp) :: rn_thres_sst
REAL(wp) :: rn_hti_ini_n, rn_hts_ini_n, rn_ati_ini_n, rn_smi_ini_n, rn_tmi_ini_n, rn_tsu_ini_n, rn_tms_ini_n
REAL(wp) :: rn_hti_ini_s, rn_hts_ini_s, rn_ati_ini_s, rn_smi_ini_s, rn_tmi_ini_s, rn_tsu_ini_s, rn_tms_ini_s
- REAL(wp) :: rn_apd_ini_n, rn_hpd_ini_n
- REAL(wp) :: rn_apd_ini_s, rn_hpd_ini_s
+ REAL(wp) :: rn_apd_ini_n, rn_hpd_ini_n, rn_hld_ini_n
+ REAL(wp) :: rn_apd_ini_s, rn_hpd_ini_s, rn_hld_ini_s
!
- ! ! if ln_iceini_file = T
- INTEGER , PARAMETER :: jpfldi = 9 ! maximum number of files to read
+ ! ! if nn_iceini_file = 1
+ INTEGER , PARAMETER :: jpfldi = 10 ! maximum number of files to read
INTEGER , PARAMETER :: jp_hti = 1 ! index of ice thickness (m)
INTEGER , PARAMETER :: jp_hts = 2 ! index of snw thickness (m)
@@ -59,6 +68,7 @@
INTEGER , PARAMETER :: jp_apd = 8 ! index of pnd fraction (-)
INTEGER , PARAMETER :: jp_hpd = 9 ! index of pnd depth (m)
+ INTEGER , PARAMETER :: jp_hld = 10 ! index of pnd lid depth (m)
TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: si ! structure of input fields (file informations, fields read)
- !
+
!! * Substitutions
# include "do_loop_substitute.h90"
@@ -83,8 +93,6 @@
!! ** Steps : 1) Set initial surface and basal temperatures
!! 2) Recompute or read sea ice state variables
- !! 3) Fill in the ice thickness distribution using gaussian
- !! 4) Fill in space-dependent arrays for state variables
- !! 5) snow-ice mass computation
- !! 6) store before fields
+ !! 3) Fill in space-dependent arrays for state variables
+ !! 4) snow-ice mass computation
!!
!! ** Notes : o_i, t_su, t_s, t_i, sz_i must be filled everywhere, even
@@ -101,8 +109,8 @@
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 !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(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
+ REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zhi_2d, zhs_2d, zai_2d, zti_2d, zts_2d, ztsu_2d, zsi_2d, zaip_2d, zhip_2d, zhil_2d
!--------------------------------------------------------------------
@@ -158,6 +166,8 @@
a_ip (:,:,:) = 0._wp
v_ip (:,:,:) = 0._wp
- a_ip_frac(:,:,:) = 0._wp
+ v_il (:,:,:) = 0._wp
+ a_ip_eff (:,:,:) = 0._wp
h_ip (:,:,:) = 0._wp
+ h_il (:,:,:) = 0._wp
!
! ice velocities
@@ -169,203 +179,250 @@
!------------------------------------------------------------------------
IF( ln_iceini ) THEN
- ! !---------------!
- IF( ln_iceini_file )THEN ! Read a file !
- ! !---------------!
- WHERE( ff_t(:,:) >= 0._wp ) ; zswitch(:,:) = 1._wp
- ELSEWHERE ; zswitch(:,:) = 0._wp
- END WHERE
+ !
+ IF( Agrif_Root() ) THEN
+ ! !---------------!
+ IF( nn_iceini_file == 1 )THEN ! Read a file !
+ ! !---------------!
+ WHERE( ff_t(:,:) >= 0._wp ) ; zswitch(:,:) = 1._wp
+ ELSEWHERE ; zswitch(:,:) = 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)
+
+ ! -- 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)
+ !
+ ! 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)
+ 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 )
+ IF( TRIM(si(jp_tmi)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tsu)%clrootname) /= 'NOT USED' ) & ! if T_su is read and not T_i, set T_i = (T_su + T_freeze)/2
+ & si(jp_tmi)%fnow(:,:,1) = 0.5_wp * ( si(jp_tsu)%fnow(:,:,1) + 271.15 )
+ IF( TRIM(si(jp_tsu)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tms)%clrootname) /= 'NOT USED' ) & ! if T_s is read and not T_su, set T_su = T_s
+ & si(jp_tsu)%fnow(:,:,1) = si(jp_tms)%fnow(:,:,1)
+ IF( TRIM(si(jp_tsu)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tmi)%clrootname) /= 'NOT USED' ) & ! if T_i is read and not T_su, set T_su = T_i
+ & si(jp_tsu)%fnow(:,:,1) = si(jp_tmi)%fnow(:,:,1)
+ IF( TRIM(si(jp_tms)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tsu)%clrootname) /= 'NOT USED' ) & ! if T_su is read and not T_s, set T_s = T_su
+ & si(jp_tms)%fnow(:,:,1) = si(jp_tsu)%fnow(:,:,1)
+ IF( TRIM(si(jp_tms)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tmi)%clrootname) /= 'NOT USED' ) & ! if T_i is read and not T_s, set T_s = T_i
+ & si(jp_tms)%fnow(:,:,1) = si(jp_tmi)%fnow(:,:,1)
+ !
+ ! 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_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)
+ !
+ ! 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)
+ !
+ 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)
+ !
+ ! 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)
+ 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(:,:)
+ 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(:,:)
+ END WHERE
+ !
+ ENDIF
+
+
+
+ ! make sure ponds = 0 if no ponds scheme
+ IF ( .NOT.ln_pnd ) THEN
+ zapnd_ini(:,:) = 0._wp
+ zhpnd_ini(:,:) = 0._wp
+ zhlid_ini(:,:) = 0._wp
+ ENDIF
+
+ IF ( .NOT.ln_pnd_lids ) THEN
+ zhlid_ini(:,:) = 0._wp
+ ENDIF
+
+ !----------------!
+ ! 3) fill fields !
+ !----------------!
+ ! select ice covered grid points
+ npti = 0 ; nptidx(:) = 0
+ DO_2D( 1, 1, 1, 1 )
+ IF ( zht_i_ini(ji,jj) > 0._wp ) THEN
+ npti = npti + 1
+ nptidx(npti) = (jj - 1) * jpi + ji
+ ENDIF
+ END_2D
+
+ ! move to 1D arrays: (jpi,jpj) -> (jpi*jpj)
+ CALL tab_2d_1d( npti, nptidx(1:npti), h_i_1d (1:npti) , zht_i_ini )
+ CALL tab_2d_1d( npti, nptidx(1:npti), h_s_1d (1:npti) , zht_s_ini )
+ CALL tab_2d_1d( npti, nptidx(1:npti), at_i_1d(1:npti) , zat_i_ini )
+ CALL tab_2d_1d( npti, nptidx(1:npti), t_i_1d (1:npti,1), ztm_i_ini )
+ CALL tab_2d_1d( npti, nptidx(1:npti), t_s_1d (1:npti,1), ztm_s_ini )
+ CALL tab_2d_1d( npti, nptidx(1:npti), t_su_1d(1:npti) , zt_su_ini )
+ CALL tab_2d_1d( npti, nptidx(1:npti), s_i_1d (1:npti) , zsm_i_ini )
+ CALL tab_2d_1d( npti, nptidx(1:npti), a_ip_1d(1:npti) , zapnd_ini )
+ CALL tab_2d_1d( npti, nptidx(1:npti), h_ip_1d(1:npti) , zhpnd_ini )
+ CALL tab_2d_1d( npti, nptidx(1:npti), h_il_1d(1:npti) , zhlid_ini )
+
+ ! allocate temporary arrays
+ ALLOCATE( zhi_2d (npti,jpl), zhs_2d (npti,jpl), zai_2d (npti,jpl), &
+ & zti_2d (npti,jpl), zts_2d (npti,jpl), ztsu_2d(npti,jpl), zsi_2d(npti,jpl), &
+ & zaip_2d(npti,jpl), zhip_2d(npti,jpl), zhil_2d(npti,jpl) )
+
+ ! distribute 1-cat into jpl-cat: (jpi*jpj) -> (jpi*jpj,jpl)
+ CALL ice_var_itd( h_i_1d(1:npti) , h_s_1d(1:npti) , at_i_1d(1:npti), &
+ & zhi_2d , zhs_2d , zai_2d , &
+ & t_i_1d(1:npti,1), t_s_1d(1:npti,1), t_su_1d(1:npti), &
+ & s_i_1d(1:npti) , a_ip_1d(1:npti) , h_ip_1d(1:npti), h_il_1d(1:npti), &
+ & zti_2d , zts_2d , ztsu_2d , &
+ & zsi_2d , zaip_2d , zhip_2d , zhil_2d )
+
+ ! move to 3D arrays: (jpi*jpj,jpl) -> (jpi,jpj,jpl)
+ DO jl = 1, jpl
+ zti_3d(:,:,jl) = rt0 * tmask(:,:,1)
+ zts_3d(:,:,jl) = rt0 * tmask(:,:,1)
+ END DO
+ CALL tab_2d_3d( npti, nptidx(1:npti), zhi_2d , h_i )
+ CALL tab_2d_3d( npti, nptidx(1:npti), zhs_2d , h_s )
+ CALL tab_2d_3d( npti, nptidx(1:npti), zai_2d , a_i )
+ CALL tab_2d_3d( npti, nptidx(1:npti), zti_2d , zti_3d )
+ CALL tab_2d_3d( npti, nptidx(1:npti), zts_2d , zts_3d )
+ CALL tab_2d_3d( npti, nptidx(1:npti), ztsu_2d , t_su )
+ CALL tab_2d_3d( npti, nptidx(1:npti), zsi_2d , s_i )
+ CALL tab_2d_3d( npti, nptidx(1:npti), zaip_2d , a_ip )
+ CALL tab_2d_3d( npti, nptidx(1:npti), zhip_2d , h_ip )
+ CALL tab_2d_3d( npti, nptidx(1:npti), zhil_2d , h_il )
+
+ ! deallocate temporary arrays
+ DEALLOCATE( zhi_2d, zhs_2d, zai_2d , &
+ & zti_2d, zts_2d, ztsu_2d, zsi_2d, zaip_2d, zhip_2d, zhil_2d )
+
+ ! calculate extensive and intensive variables
+ CALL ice_var_salprof ! for sz_i
+ DO jl = 1, jpl
+ DO_2D( 1, 1, 1, 1 )
+ 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) = MIN( MAX( rn_simin , s_i(ji,jj,jl) ) , rn_simax ) * v_i(ji,jj,jl)
+ END_2D
+ END DO
!
- CALL fld_read( kt, 1, si ) ! input fields provided at the current time-step
+ DO jl = 1, jpl
+ DO_3D( 1, 1, 1, 1, 1, nlay_s )
+ t_s(ji,jj,jk,jl) = zts_3d(ji,jj,jl)
+ e_s(ji,jj,jk,jl) = zswitch(ji,jj) * v_s(ji,jj,jl) * r1_nlay_s * &
+ & rhos * ( rcpi * ( rt0 - t_s(ji,jj,jk,jl) ) + rLfus )
+ END_3D
+ END DO
!
- ! -- mandatory fields -- !
- zht_i_ini(:,:) = si(jp_hti)%fnow(:,:,1)
- zht_s_ini(:,:) = si(jp_hts)%fnow(:,:,1)
- zat_i_ini(:,:) = si(jp_ati)%fnow(:,:,1)
-
- ! -- optional fields -- !
- ! if fields do not exist then set them to the values present in the namelist (except for snow and surface temperature)
- !
- ! 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)
- !
- ! 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)
- ELSEIF( TRIM(si(jp_tmi)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tms)%clrootname) /= 'NOT USED' ) THEN ! 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 )
- ELSEIF( TRIM(si(jp_tmi)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tsu)%clrootname) /= 'NOT USED' ) THEN ! if T_su is read and not T_i, set T_i = (T_su + T_freeze)/2
- si(jp_tmi)%fnow(:,:,1) = 0.5_wp * ( si(jp_tsu)%fnow(:,:,1) + 271.15 )
- ELSEIF( TRIM(si(jp_tsu)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tms)%clrootname) /= 'NOT USED' ) THEN ! if T_s is read and not T_su, set T_su = T_s
- si(jp_tsu)%fnow(:,:,1) = si(jp_tms)%fnow(:,:,1)
- ELSEIF( TRIM(si(jp_tsu)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tmi)%clrootname) /= 'NOT USED' ) THEN ! if T_i is read and not T_su, set T_su = T_i
- si(jp_tsu)%fnow(:,:,1) = si(jp_tmi)%fnow(:,:,1)
- ELSEIF( TRIM(si(jp_tms)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tsu)%clrootname) /= 'NOT USED' ) THEN ! if T_su is read and not T_s, set T_s = T_su
- si(jp_tms)%fnow(:,:,1) = si(jp_tsu)%fnow(:,:,1)
- ELSEIF( TRIM(si(jp_tms)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tmi)%clrootname) /= 'NOT USED' ) THEN ! if T_i is read and not T_s, set T_s = T_i
- si(jp_tms)%fnow(:,:,1) = si(jp_tmi)%fnow(:,:,1)
- ENDIF
- !
- ! 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_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)
- !
- zsm_i_ini(:,:) = si(jp_smi)%fnow(:,:,1)
- ztm_i_ini(:,:) = si(jp_tmi)%fnow(:,:,1)
- zt_su_ini(:,:) = si(jp_tsu)%fnow(:,:,1)
- ztm_s_ini(:,:) = si(jp_tms)%fnow(:,:,1)
- zapnd_ini(:,:) = si(jp_apd)%fnow(:,:,1)
- zhpnd_ini(:,:) = si(jp_hpd)%fnow(:,:,1)
- !
- ! 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)
- 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(:,:)
- 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(:,:)
- END WHERE
- !
- ENDIF
-
- ! make sure ponds = 0 if no ponds scheme
- IF ( .NOT.ln_pnd ) THEN
- zapnd_ini(:,:) = 0._wp
- zhpnd_ini(:,:) = 0._wp
- ENDIF
-
- !-------------!
- ! fill fields !
- !-------------!
- ! select ice covered grid points
- npti = 0 ; nptidx(:) = 0
- DO_2D_11_11
- IF ( zht_i_ini(ji,jj) > 0._wp ) THEN
- npti = npti + 1
- nptidx(npti) = (jj - 1) * jpi + ji
- ENDIF
- END_2D
-
- ! move to 1D arrays: (jpi,jpj) -> (jpi*jpj)
- CALL tab_2d_1d( npti, nptidx(1:npti), h_i_1d (1:npti) , zht_i_ini )
- CALL tab_2d_1d( npti, nptidx(1:npti), h_s_1d (1:npti) , zht_s_ini )
- CALL tab_2d_1d( npti, nptidx(1:npti), at_i_1d(1:npti) , zat_i_ini )
- CALL tab_2d_1d( npti, nptidx(1:npti), t_i_1d (1:npti,1), ztm_i_ini )
- CALL tab_2d_1d( npti, nptidx(1:npti), t_s_1d (1:npti,1), ztm_s_ini )
- CALL tab_2d_1d( npti, nptidx(1:npti), t_su_1d(1:npti) , zt_su_ini )
- CALL tab_2d_1d( npti, nptidx(1:npti), s_i_1d (1:npti) , zsm_i_ini )
- CALL tab_2d_1d( npti, nptidx(1:npti), a_ip_1d(1:npti) , zapnd_ini )
- CALL tab_2d_1d( npti, nptidx(1:npti), h_ip_1d(1:npti) , zhpnd_ini )
-
- ! allocate temporary arrays
- ALLOCATE( zhi_2d(npti,jpl), zhs_2d(npti,jpl), zai_2d (npti,jpl), &
- & zti_2d(npti,jpl), zts_2d(npti,jpl), ztsu_2d(npti,jpl), zsi_2d(npti,jpl), zaip_2d(npti,jpl), zhip_2d(npti,jpl) )
-
- ! distribute 1-cat into jpl-cat: (jpi*jpj) -> (jpi*jpj,jpl)
- CALL ice_var_itd( h_i_1d(1:npti) , h_s_1d(1:npti) , at_i_1d(1:npti), &
- & zhi_2d , zhs_2d , zai_2d , &
- & t_i_1d(1:npti,1), t_s_1d(1:npti,1), t_su_1d(1:npti), s_i_1d(1:npti), a_ip_1d(1:npti), h_ip_1d(1:npti), &
- & zti_2d , zts_2d , ztsu_2d , zsi_2d , zaip_2d , zhip_2d )
-
- ! move to 3D arrays: (jpi*jpj,jpl) -> (jpi,jpj,jpl)
- DO jl = 1, jpl
- zti_3d(:,:,jl) = rt0 * tmask(:,:,1)
- zts_3d(:,:,jl) = rt0 * tmask(:,:,1)
- END DO
- CALL tab_2d_3d( npti, nptidx(1:npti), zhi_2d , h_i )
- CALL tab_2d_3d( npti, nptidx(1:npti), zhs_2d , h_s )
- CALL tab_2d_3d( npti, nptidx(1:npti), zai_2d , a_i )
- CALL tab_2d_3d( npti, nptidx(1:npti), zti_2d , zti_3d )
- CALL tab_2d_3d( npti, nptidx(1:npti), zts_2d , zts_3d )
- CALL tab_2d_3d( npti, nptidx(1:npti), ztsu_2d , t_su )
- CALL tab_2d_3d( npti, nptidx(1:npti), zsi_2d , s_i )
- CALL tab_2d_3d( npti, nptidx(1:npti), zaip_2d , a_ip )
- CALL tab_2d_3d( npti, nptidx(1:npti), zhip_2d , h_ip )
-
- ! deallocate temporary arrays
- DEALLOCATE( zhi_2d, zhs_2d, zai_2d , &
- & zti_2d, zts_2d, ztsu_2d, zsi_2d, zaip_2d, zhip_2d )
-
- ! calculate extensive and intensive variables
- CALL ice_var_salprof ! for sz_i
- DO jl = 1, jpl
- DO_2D_11_11
- 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) = MIN( MAX( rn_simin , s_i(ji,jj,jl) ) , rn_simax ) * v_i(ji,jj,jl)
- END_2D
- END DO
- !
- DO jl = 1, jpl
- DO_3D_11_11( 1, nlay_s )
- t_s(ji,jj,jk,jl) = zts_3d(ji,jj,jl)
- e_s(ji,jj,jk,jl) = zswitch(ji,jj) * v_s(ji,jj,jl) * r1_nlay_s * &
- & rhos * ( rcpi * ( rt0 - t_s(ji,jj,jk,jl) ) + rLfus )
- END_3D
- END DO
- !
- DO jl = 1, jpl
- DO_3D_11_11( 1, nlay_i )
- t_i (ji,jj,jk,jl) = zti_3d(ji,jj,jl)
- ztmelts = - rTmlt * sz_i(ji,jj,jk,jl) + rt0 ! melting temperature in K
- e_i(ji,jj,jk,jl) = zswitch(ji,jj) * v_i(ji,jj,jl) * r1_nlay_i * &
- & rhoi * ( rcpi * ( ztmelts - t_i(ji,jj,jk,jl) ) + &
- & rLfus * ( 1._wp - (ztmelts-rt0) / MIN( (t_i(ji,jj,jk,jl)-rt0), -epsi20 ) ) &
- & - rcp * ( ztmelts - rt0 ) )
- END_3D
- END DO
-
+ DO jl = 1, jpl
+ DO_3D( 1, 1, 1, 1, 1, nlay_i )
+ t_i (ji,jj,jk,jl) = zti_3d(ji,jj,jl)
+ ztmelts = - rTmlt * sz_i(ji,jj,jk,jl) + rt0 ! melting temperature in K
+ e_i(ji,jj,jk,jl) = zswitch(ji,jj) * v_i(ji,jj,jl) * r1_nlay_i * &
+ & rhoi * ( rcpi * ( ztmelts - t_i(ji,jj,jk,jl) ) + &
+ & rLfus * ( 1._wp - (ztmelts-rt0) / MIN( (t_i(ji,jj,jk,jl)-rt0), -epsi20 ) ) &
+ & - rcp * ( ztmelts - rt0 ) )
+ END_3D
+ END DO
+
+#if defined key_agrif
+ ELSE
+
+ Agrif_SpecialValue = -9999.
+ Agrif_UseSpecialValue = .TRUE.
+ CALL Agrif_init_variable(tra_iceini_id,procname=interp_tra_ice)
+ use_sign_north = .TRUE.
+ sign_north = -1.
+ CALL Agrif_init_variable(u_iceini_id ,procname=interp_u_ice)
+ CALL Agrif_init_variable(v_iceini_id ,procname=interp_v_ice)
+ Agrif_SpecialValue = 0._wp
+ use_sign_north = .FALSE.
+ Agrif_UseSpecialValue = .FALSE.
+ ! lbc ????
+ ! Here we know : a_i, v_i, v_s, sv_i, oa_i, a_ip, v_ip, v_il, t_su, e_s, e_i
+ CALL ice_var_glo2eqv
+ CALL ice_var_zapsmall
+ CALL ice_var_agg(2)
+#endif
+ ENDIF ! Agrif_Root
+ !
! Melt ponds
- WHERE( a_i > epsi10 )
- a_ip_frac(:,:,:) = a_ip(:,:,:) / a_i(:,:,:)
- ELSEWHERE
- a_ip_frac(:,:,:) = 0._wp
+ WHERE( a_i > epsi10 ) ; a_ip_eff(:,:,:) = a_ip(:,:,:) / a_i(:,:,:)
+ 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,:)
!
+ ! ice concentration should not exceed amax
+ at_i(:,:) = SUM( a_i, dim=3 )
+ DO jl = 1, jpl
+ WHERE( at_i(:,:) > rn_amax_2d(:,:) ) a_i(:,:,jl) = a_i(:,:,jl) * rn_amax_2d(:,:) / at_i(:,:)
+ END DO
+ at_i(:,:) = SUM( a_i, dim=3 )
+ !
ENDIF ! ln_iceini
!
- at_i(:,:) = SUM( a_i, dim=3 )
- !
!----------------------------------------------
- ! 3) Snow-ice mass (case ice is fully embedded)
+ ! 4) Snow-ice mass (case ice is fully embedded)
!----------------------------------------------
snwice_mass (:,:) = tmask(:,:,1) * SUM( rhos * v_s(:,:,:) + rhoi * v_i(:,:,:), dim=3 ) ! snow+ice mass
@@ -377,64 +434,50 @@
ssh(:,:,Kbb) = ssh(:,:,Kbb) - snwice_mass(:,:) * r1_rho0
!
- IF( .NOT.ln_linssh ) THEN
- !
- WHERE( ht_0(:,:) > 0 ) ; z2d(:,:) = 1._wp + ssh(:,:,Kmm)*tmask(:,:,1) / ht_0(:,:)
- ELSEWHERE ; z2d(:,:) = 1._wp ; END WHERE
- !
- DO jk = 1,jpkm1 ! adjust initial vertical scale factors
- e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * z2d(:,:)
- e3t(:,:,jk,Kbb) = e3t(:,:,jk,Kmm)
- e3t(:,:,jk,Kaa) = e3t(:,:,jk,Kmm)
- END DO
- !
- ! 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
- ! ----------------------
- !!gm not sure of that....
- 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) - ssh (:,:,Kmm)
- END DO
- ENDIF
+ IF( .NOT.ln_linssh ) CALL dom_vvl_zgr( Kbb, Kmm, Kaa ) ! interpolation scale factor, depth and water column
+! !!st
+! IF( .NOT.ln_linssh ) THEN
+! !
+! WHERE( ht_0(:,:) > 0 ) ; z2d(:,:) = 1._wp + ssh(:,:,Kmm)*tmask(:,:,1) / ht_0(:,:)
+! ELSEWHERE ; z2d(:,:) = 1._wp ; END WHERE
+! !
+! DO jk = 1,jpkm1 ! adjust initial vertical scale factors
+! e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * z2d(:,:)
+! e3t(:,:,jk,Kbb) = e3t(:,:,jk,Kmm)
+! e3t(:,:,jk,Kaa) = e3t(:,:,jk,Kmm)
+! END DO
+! !
+! ! 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
+! ! ----------------------
+! !!gm not sure of that....
+! 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) - ssh (:,:,Kmm)
+! END DO
+! ENDIF
ENDIF
-
- !------------------------------------
- ! 4) store fields at before time-step
- !------------------------------------
- ! it is only necessary for the 1st interpolation by Agrif
- a_i_b (:,:,:) = a_i (:,:,:)
- e_i_b (:,:,:,:) = e_i (:,:,:,:)
- v_i_b (:,:,:) = v_i (:,:,:)
- v_s_b (:,:,:) = v_s (:,:,:)
- e_s_b (:,:,:,:) = e_s (:,:,:,:)
- sv_i_b (:,:,:) = sv_i (:,:,:)
- oa_i_b (:,:,:) = oa_i (:,:,:)
- u_ice_b(:,:) = u_ice(:,:)
- v_ice_b(:,:) = v_ice(:,:)
- ! total concentration is needed for Lupkes parameterizations
- at_i_b (:,:) = at_i (:,:)
-
-!!clem: output of initial state should be written here but it is impossible because
-!! the ocean and ice are in the same file
-!! CALL dia_wri_state( 'output.init' )
+
+ !!clem: output of initial state should be written here but it is impossible because
+ !! the ocean and ice are in the same file
+ !! CALL dia_wri_state( 'output.init' )
!
END SUBROUTINE ice_istate
@@ -457,13 +500,13 @@
!
CHARACTER(len=256) :: cn_dir ! Root directory for location of ice files
- TYPE(FLD_N) :: sn_hti, sn_hts, sn_ati, sn_smi, sn_tmi, sn_tsu, sn_tms, sn_apd, sn_hpd
+ TYPE(FLD_N) :: sn_hti, sn_hts, sn_ati, sn_smi, sn_tmi, sn_tsu, sn_tms, sn_apd, sn_hpd, sn_hld
TYPE(FLD_N), DIMENSION(jpfldi) :: slf_i ! array of namelist informations on the fields to read
!
- NAMELIST/namini/ ln_iceini, ln_iceini_file, rn_thres_sst, &
+ NAMELIST/namini/ ln_iceini, nn_iceini_file, rn_thres_sst, &
& rn_hti_ini_n, rn_hti_ini_s, rn_hts_ini_n, rn_hts_ini_s, &
& rn_ati_ini_n, rn_ati_ini_s, rn_smi_ini_n, rn_smi_ini_s, &
& rn_tmi_ini_n, rn_tmi_ini_s, rn_tsu_ini_n, rn_tsu_ini_s, rn_tms_ini_n, rn_tms_ini_s, &
- & rn_apd_ini_n, rn_apd_ini_s, rn_hpd_ini_n, rn_hpd_ini_s, &
- & sn_hti, sn_hts, sn_ati, sn_tsu, sn_tmi, sn_smi, sn_tms, sn_apd, sn_hpd, cn_dir
+ & rn_apd_ini_n, rn_apd_ini_s, rn_hpd_ini_n, rn_hpd_ini_s, rn_hld_ini_n, rn_hld_ini_s, &
+ & sn_hti, sn_hts, sn_ati, sn_tsu, sn_tmi, sn_smi, sn_tms, sn_apd, sn_hpd, sn_hld, cn_dir
!!-----------------------------------------------------------------------------
!
@@ -477,5 +520,5 @@
slf_i(jp_ati) = sn_ati ; slf_i(jp_smi) = sn_smi
slf_i(jp_tmi) = sn_tmi ; slf_i(jp_tsu) = sn_tsu ; slf_i(jp_tms) = sn_tms
- slf_i(jp_apd) = sn_apd ; slf_i(jp_hpd) = sn_hpd
+ slf_i(jp_apd) = sn_apd ; slf_i(jp_hpd) = sn_hpd ; slf_i(jp_hld) = sn_hld
!
IF(lwp) THEN ! control print
@@ -485,7 +528,7 @@
WRITE(numout,*) ' Namelist namini:'
WRITE(numout,*) ' ice initialization (T) or not (F) ln_iceini = ', ln_iceini
- WRITE(numout,*) ' ice initialization from a netcdf file ln_iceini_file = ', ln_iceini_file
+ WRITE(numout,*) ' ice initialization from a netcdf file nn_iceini_file = ', nn_iceini_file
WRITE(numout,*) ' max ocean temp. above Tfreeze with initial ice rn_thres_sst = ', rn_thres_sst
- IF( ln_iceini .AND. .NOT.ln_iceini_file ) THEN
+ IF( ln_iceini .AND. nn_iceini_file == 0 ) THEN
WRITE(numout,*) ' initial snw thickness in the north-south rn_hts_ini = ', rn_hts_ini_n,rn_hts_ini_s
WRITE(numout,*) ' initial ice thickness in the north-south rn_hti_ini = ', rn_hti_ini_n,rn_hti_ini_s
@@ -497,8 +540,9 @@
WRITE(numout,*) ' initial pnd fraction in the north-south rn_apd_ini = ', rn_apd_ini_n,rn_apd_ini_s
WRITE(numout,*) ' initial pnd depth in the north-south rn_hpd_ini = ', rn_hpd_ini_n,rn_hpd_ini_s
+ WRITE(numout,*) ' initial pnd lid depth in the north-south rn_hld_ini = ', rn_hld_ini_n,rn_hld_ini_s
ENDIF
ENDIF
!
- IF( ln_iceini_file ) THEN ! Ice initialization using input file
+ IF( nn_iceini_file == 1 ) THEN ! Ice initialization using input file
!
! set si structure
@@ -521,5 +565,10 @@
rn_apd_ini_n = 0. ; rn_apd_ini_s = 0.
rn_hpd_ini_n = 0. ; rn_hpd_ini_s = 0.
- CALL ctl_warn( 'rn_apd_ini & rn_hpd_ini = 0 when no ponds' )
+ rn_hld_ini_n = 0. ; rn_hld_ini_s = 0.
+ CALL ctl_warn( 'rn_apd_ini & rn_hpd_ini = 0 & rn_hld_ini = 0 when no ponds' )
+ ENDIF
+ !
+ IF( .NOT.ln_pnd_lids ) THEN
+ rn_hld_ini_n = 0. ; rn_hld_ini_s = 0.
ENDIF
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/ICE/iceitd.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/ICE/iceitd.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/ICE/iceitd.F90 (revision 13540)
@@ -47,4 +47,5 @@
LOGICAL :: ln_cat_usr ! ice categories are defined by rn_catbnd
REAL(wp), DIMENSION(0:100) :: rn_catbnd ! ice categories bounds
+ REAL(wp) :: rn_himax ! maximum ice thickness allowed
!
!! * Substitutions
@@ -98,5 +99,5 @@
!
npti = 0 ; nptidx(:) = 0
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
IF ( at_i(ji,jj) > epsi10 ) THEN
npti = npti + 1
@@ -148,6 +149,11 @@
! Note: hn(t+1) must not be too close to either HR or HL otherwise a division by nearly 0 is possible
! in itd_glinear in the case (HR-HL) = 3(Hice - HL) or = 3(HR - Hice)
+# if defined key_single
+ IF( a_i_2d(ji,jl ) > epsi10 .AND. h_i_2d(ji,jl ) > ( zhbnew(ji,jl) - epsi06 ) ) nptidx(ji) = 0
+ IF( a_i_2d(ji,jl+1) > epsi10 .AND. h_i_2d(ji,jl+1) < ( zhbnew(ji,jl) + epsi06 ) ) nptidx(ji) = 0
+# else
IF( a_i_2d(ji,jl ) > epsi10 .AND. h_i_2d(ji,jl ) > ( zhbnew(ji,jl) - epsi10 ) ) nptidx(ji) = 0
IF( a_i_2d(ji,jl+1) > epsi10 .AND. h_i_2d(ji,jl+1) < ( zhbnew(ji,jl) + epsi10 ) ) nptidx(ji) = 0
+# endif
!
! 2) Hn-1 < Hn* < Hn+1
@@ -170,6 +176,11 @@
! h1(t) must not be too close to either HR or HL otherwise a division by nearly 0 is possible
! in itd_glinear in the case (HR-HL) = 3(Hice - HL) or = 3(HR - Hice)
+# if defined key_single
+ IF( h_ib_2d(ji,1) < ( hi_max(0) + epsi06 ) ) nptidx(ji) = 0
+ IF( h_ib_2d(ji,1) > ( hi_max(1) - epsi06 ) ) nptidx(ji) = 0
+# else
IF( h_ib_2d(ji,1) < ( hi_max(0) + epsi10 ) ) nptidx(ji) = 0
IF( h_ib_2d(ji,1) > ( hi_max(1) - epsi10 ) ) nptidx(ji) = 0
+# endif
END DO
!
@@ -304,5 +315,5 @@
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_H12 ) a_ip_1d(ji) = a_ip_1d(ji) * h_i_1d(ji) / rn_himin
+ IF( ln_pnd_LEV ) a_ip_1d(ji) = a_ip_1d(ji) * h_i_1d(ji) / rn_himin
h_i_1d(ji) = rn_himin
ENDIF
@@ -410,4 +421,5 @@
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
@@ -474,5 +486,5 @@
zaTsfn(ji,jl2) = zaTsfn(ji,jl2) + ztrans
!
- IF ( ln_pnd_H12 ) THEN
+ IF ( ln_pnd_LEV ) THEN
ztrans = a_ip_2d(ji,jl1) * zworka(ji) ! Pond fraction
a_ip_2d(ji,jl1) = a_ip_2d(ji,jl1) - ztrans
@@ -482,4 +494,10 @@
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) * zworka(ji)
+ v_il_2d(ji,jl1) = v_il_2d(ji,jl1) - ztrans
+ v_il_2d(ji,jl2) = v_il_2d(ji,jl2) + ztrans
+ ENDIF
ENDIF
!
@@ -526,5 +544,5 @@
! 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, 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, ze_s_2d, ze_i_2d )
! at_i must be <= rn_amax
@@ -538,5 +556,9 @@
! 4) Update ice thickness and temperature
!-------------------------------------------------------------------------------
+# if defined key_single
+ WHERE( a_i_2d(1:npti,:) >= epsi06 )
+# else
WHERE( a_i_2d(1:npti,:) >= epsi20 )
+# endif
h_i_2d (1:npti,:) = v_i_2d(1:npti,:) / a_i_2d(1:npti,:)
t_su_2d(1:npti,:) = zaTsfn(1:npti,:) / a_i_2d(1:npti,:)
@@ -554,4 +576,5 @@
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
@@ -597,5 +620,5 @@
! !---------------------------------------
npti = 0 ; nptidx(:) = 0
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
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
@@ -636,5 +659,5 @@
! !-----------------------------------------
npti = 0 ; nptidx(:) = 0
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
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
@@ -679,5 +702,5 @@
REAL(wp) :: zhmax, znum, zden, zalpha ! - -
!
- NAMELIST/namitd/ ln_cat_hfn, rn_himean, ln_cat_usr, rn_catbnd, rn_himin
+ NAMELIST/namitd/ ln_cat_hfn, rn_himean, ln_cat_usr, rn_catbnd, rn_himin, rn_himax
!!------------------------------------------------------------------
!
@@ -696,5 +719,6 @@
WRITE(numout,*) ' mean ice thickness in the domain rn_himean = ', rn_himean
WRITE(numout,*) ' Ice categories are defined by rn_catbnd ln_cat_usr = ', ln_cat_usr
- WRITE(numout,*) ' minimum ice thickness rn_himin = ', rn_himin
+ WRITE(numout,*) ' minimum ice thickness allowed rn_himin = ', rn_himin
+ WRITE(numout,*) ' maximum ice thickness allowed rn_himax = ', rn_himax
ENDIF
!
@@ -733,5 +757,5 @@
END DO
!
- hi_max(jpl) = 99._wp ! set to a big value to ensure that all ice is thinner than hi_max(jpl)
+ hi_max(jpl) = rn_himax ! set to a big value to ensure that all ice is thinner than hi_max(jpl)
!
IF(lwp) WRITE(numout,*)
Index: /NEMO/branches/2020/r12377_ticket2386/src/ICE/icerst.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/ICE/icerst.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/ICE/icerst.F90 (revision 13540)
@@ -18,4 +18,8 @@
USE phycst , ONLY : rt0
USE sbc_oce , ONLY : nn_fsbc, ln_cpl
+ USE sbc_oce , ONLY : nn_components, jp_iam_sas ! SAS ss[st]_m init
+ USE sbc_oce , ONLY : sst_m, sss_m ! SAS ss[st]_m init
+ USE oce , ONLY : ts ! SAS ss[st]_m init
+ USE eosbn2 , ONLY : l_useCT, eos_pt_from_ct ! SAS ss[st]_m init
USE iceistate ! sea-ice: initial state
USE icectl ! sea-ice: control
@@ -80,5 +84,5 @@
ENDIF
!
- CALL iom_open( TRIM(clpath)//TRIM(clname), numriw, ldwrt = .TRUE., kdlev = jpl )
+ CALL iom_open( TRIM(clpath)//TRIM(clname), numriw, ldwrt = .TRUE., kdlev = jpl, cdcomp = 'ICE' )
lrst_ice = .TRUE.
ENDIF
@@ -132,4 +136,5 @@
CALL iom_rstput( iter, nitrst, numriw, 'a_ip' , a_ip )
CALL iom_rstput( iter, nitrst, numriw, 'v_ip' , v_ip )
+ CALL iom_rstput( iter, nitrst, numriw, 'v_il' , v_il )
! Snow enthalpy
DO jk = 1, nlay_s
@@ -172,5 +177,5 @@
INTEGER :: jk
LOGICAL :: llok
- INTEGER :: id0, id1, id2, id3, id4 ! local integer
+ INTEGER :: id0, id1, id2, id3, id4, id5 ! local integer
CHARACTER(len=25) :: znam
CHARACTER(len=2) :: zchar, zchar1
@@ -185,5 +190,5 @@
ENDIF
- CALL iom_open ( TRIM(cn_icerst_indir)//'/'//cn_icerst_in, numrir, kdlev = jpl )
+ CALL iom_open ( TRIM(cn_icerst_indir)//'/'//cn_icerst_in, numrir )
! test if v_i exists
@@ -211,16 +216,16 @@
! --- mandatory fields --- !
- CALL iom_get( numrir, jpdom_autoglo, 'v_i' , v_i )
- CALL iom_get( numrir, jpdom_autoglo, 'v_s' , v_s )
- CALL iom_get( numrir, jpdom_autoglo, 'sv_i' , sv_i )
- CALL iom_get( numrir, jpdom_autoglo, 'a_i' , a_i )
- CALL iom_get( numrir, jpdom_autoglo, 't_su' , t_su )
- CALL iom_get( numrir, jpdom_autoglo, 'u_ice', u_ice )
- CALL iom_get( numrir, jpdom_autoglo, 'v_ice', v_ice )
+ CALL iom_get( numrir, jpdom_auto, 'v_i' , v_i )
+ CALL iom_get( numrir, jpdom_auto, 'v_s' , v_s )
+ CALL iom_get( numrir, jpdom_auto, 'sv_i' , sv_i )
+ CALL iom_get( numrir, jpdom_auto, 'a_i' , a_i )
+ CALL iom_get( numrir, jpdom_auto, 't_su' , t_su )
+ CALL iom_get( numrir, jpdom_auto, 'u_ice', u_ice, cd_type = 'U', psgn = -1._wp )
+ CALL iom_get( numrir, jpdom_auto, 'v_ice', v_ice, cd_type = 'V', psgn = -1._wp )
! Snow enthalpy
DO jk = 1, nlay_s
WRITE(zchar1,'(I2.2)') jk
znam = 'e_s'//'_l'//zchar1
- CALL iom_get( numrir, jpdom_autoglo, znam , z3d )
+ CALL iom_get( numrir, jpdom_auto, znam , z3d )
e_s(:,:,jk,:) = z3d(:,:,:)
END DO
@@ -229,5 +234,5 @@
WRITE(zchar1,'(I2.2)') jk
znam = 'e_i'//'_l'//zchar1
- CALL iom_get( numrir, jpdom_autoglo, znam , z3d )
+ CALL iom_get( numrir, jpdom_auto, znam , z3d )
e_i(:,:,jk,:) = z3d(:,:,:)
END DO
@@ -236,5 +241,5 @@
id1 = iom_varid( numrir, 'oa_i' , ldstop = .FALSE. )
IF( id1 > 0 ) THEN ! fields exist
- CALL iom_get( numrir, jpdom_autoglo, 'oa_i', oa_i )
+ CALL iom_get( numrir, jpdom_auto, 'oa_i', oa_i )
ELSE ! start from rest
IF(lwp) WRITE(numout,*) ' ==>> previous run without ice age output then set it to zero'
@@ -244,6 +249,6 @@
id2 = iom_varid( numrir, 'a_ip' , ldstop = .FALSE. )
IF( id2 > 0 ) THEN ! fields exist
- CALL iom_get( numrir, jpdom_autoglo, 'a_ip' , a_ip )
- CALL iom_get( numrir, jpdom_autoglo, 'v_ip' , v_ip )
+ CALL iom_get( numrir, jpdom_auto, 'a_ip' , a_ip )
+ CALL iom_get( numrir, jpdom_auto, 'v_ip' , v_ip )
ELSE ! start from rest
IF(lwp) WRITE(numout,*) ' ==>> previous run without melt ponds output then set it to zero'
@@ -251,11 +256,19 @@
v_ip(:,:,:) = 0._wp
ENDIF
+ ! melt pond lids
+ id3 = iom_varid( numrir, 'v_il' , ldstop = .FALSE. )
+ IF( id3 > 0 ) THEN
+ CALL iom_get( numrir, jpdom_auto, 'v_il', v_il)
+ ELSE
+ IF(lwp) WRITE(numout,*) ' ==>> previous run without melt ponds lids output then set it to zero'
+ v_il(:,:,:) = 0._wp
+ ENDIF
! fields needed for Met Office (Jules) coupling
IF( ln_cpl ) THEN
- id3 = iom_varid( numrir, 'cnd_ice' , ldstop = .FALSE. )
- id4 = iom_varid( numrir, 't1_ice' , ldstop = .FALSE. )
- IF( id3 > 0 .AND. id4 > 0 ) THEN ! fields exist
- CALL iom_get( numrir, jpdom_autoglo, 'cnd_ice', cnd_ice )
- CALL iom_get( numrir, jpdom_autoglo, 't1_ice' , t1_ice )
+ id4 = iom_varid( numrir, 'cnd_ice' , ldstop = .FALSE. )
+ id5 = iom_varid( numrir, 't1_ice' , ldstop = .FALSE. )
+ IF( id4 > 0 .AND. id5 > 0 ) THEN ! fields exist
+ CALL iom_get( numrir, jpdom_auto, 'cnd_ice', cnd_ice )
+ CALL iom_get( numrir, jpdom_auto, 't1_ice' , t1_ice )
ELSE ! start from rest
IF(lwp) WRITE(numout,*) ' ==>> previous run without conductivity output then set it to zero'
@@ -270,12 +283,23 @@
ELSE ! == case of a simplified restart == !
! ! ---------------------------------- !
- CALL ctl_warn('ice_rst_read: you are using a simplified ice restart')
+ CALL ctl_warn('ice_rst_read: you are attempting to use an unsuitable ice restart')
!
- CALL ice_istate_init
+ IF( .NOT. ln_iceini .OR. nn_iceini_file == 2 ) THEN
+ CALL ctl_stop('STOP', 'ice_rst_read: you need ln_ice_ini=T and nn_iceini_file=0 or 1')
+ ELSE
+ CALL ctl_warn('ice_rst_read: using ice_istate to set initial conditions instead')
+ ENDIF
+ !
+ 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) )
+ ELSE ; sst_m(:,:) = ts(:,:,1,jp_tem, Kmm)
+ ENDIF
+ sss_m(:,:) = ts(:,:,1,jp_sal, Kmm)
+ ENDIF
+ !
CALL ice_istate( nit000, Kbb, Kmm, Kaa )
!
- IF( .NOT.ln_iceini .OR. .NOT.ln_iceini_file ) &
- & CALL ctl_stop('STOP', 'ice_rst_read: you need ln_ice_ini=T and ln_iceini_file=T')
- !
ENDIF
Index: /NEMO/branches/2020/r12377_ticket2386/src/ICE/icesbc.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/ICE/icesbc.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/ICE/icesbc.F90 (revision 13540)
@@ -82,9 +82,9 @@
IF( ln_mixcpl) THEN ! Case of a mixed Bulk/Coupled formulation
CALL sbc_cpl_ice_tau( zutau_ice , zvtau_ice )
- DO_2D_00_00
+ 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_multi( 'icesbc', utau_ice, 'U', -1., vtau_ice, 'V', -1. )
+ CALL lbc_lnk_multi( 'icesbc', utau_ice, 'U', -1.0_wp, vtau_ice, 'V', -1.0_wp )
ENDIF
!
@@ -119,6 +119,5 @@
INTEGER :: ji, jj, jl ! dummy loop index
REAL(wp) :: zmiss_val ! missing value retrieved from xios
- REAL(wp), DIMENSION(jpi,jpj,jpl) :: zalb_os, zalb_cs ! ice albedo under overcast/clear sky
- REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: zalb, zmsk00 ! 2D workspace
+ REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zalb, zmsk00 ! 2D workspace
!!--------------------------------------------------------------------
!
@@ -134,11 +133,7 @@
CALL iom_miss_val( "icetemp", zmiss_val )
- ! --- cloud-sky and overcast-sky ice albedos --- !
- CALL ice_alb( t_su, h_i, h_s, ln_pnd_alb, a_ip_frac, h_ip, zalb_cs, zalb_os )
-
- ! albedo depends on cloud fraction because of non-linear spectral effects
-!!gm cldf_ice is a real, DOCTOR naming rule: start with cd means CHARACTER passed in argument !
- alb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:)
- !
+ ! --- ice albedo --- !
+ CALL ice_alb( t_su, h_i, h_s, ln_pnd_alb, a_ip_eff, h_ip, cloud_fra, alb_ice )
+
!
SELECT CASE( ksbc ) !== fluxes over sea ice ==!
@@ -285,5 +280,5 @@
INTEGER :: ios, ioptio ! Local integer
!!
- NAMELIST/namsbc/ rn_cio, rn_blow_s, nn_flxdist, ln_cndflx, ln_cndemulate
+ NAMELIST/namsbc/ rn_cio, nn_snwfra, rn_snwblow, nn_flxdist, ln_cndflx, ln_cndemulate, nn_qtrice
!!-------------------------------------------------------------------
!
@@ -299,9 +294,13 @@
WRITE(numout,*) '~~~~~~~~~~~~~~~~'
WRITE(numout,*) ' Namelist namsbc:'
- WRITE(numout,*) ' drag coefficient for oceanic stress rn_cio = ', rn_cio
- WRITE(numout,*) ' coefficient for ice-lead partition of snowfall rn_blow_s = ', rn_blow_s
- WRITE(numout,*) ' Multicategory heat flux formulation nn_flxdist = ', nn_flxdist
- WRITE(numout,*) ' Use conduction flux as surface condition ln_cndflx = ', ln_cndflx
- WRITE(numout,*) ' emulate conduction flux ln_cndemulate = ', ln_cndemulate
+ WRITE(numout,*) ' drag coefficient for oceanic stress rn_cio = ', rn_cio
+ WRITE(numout,*) ' fraction of ice covered by snow (options 0,1,2) nn_snwfra = ', nn_snwfra
+ WRITE(numout,*) ' coefficient for ice-lead partition of snowfall rn_snwblow = ', rn_snwblow
+ WRITE(numout,*) ' Multicategory heat flux formulation nn_flxdist = ', nn_flxdist
+ WRITE(numout,*) ' Use conduction flux as surface condition ln_cndflx = ', ln_cndflx
+ WRITE(numout,*) ' emulate conduction flux ln_cndemulate = ', ln_cndemulate
+ WRITE(numout,*) ' solar flux transmitted thru the surface scattering layer nn_qtrice = ', nn_qtrice
+ WRITE(numout,*) ' = 0 Grenfell and Maykut 1977'
+ WRITE(numout,*) ' = 1 Lebrun 2019'
ENDIF
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/ICE/icestp.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/ICE/icestp.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/ICE/icestp.F90 (revision 13540)
@@ -201,5 +201,5 @@
IF( lrst_ice ) CALL ice_rst_write( kt ) ! -- Ice restart file
!
- IF( ln_icectl ) CALL ice_ctl( kt ) ! -- alerts in case of model crash
+ IF( ln_icectl ) CALL ice_ctl( kt ) ! -- Control checks
!
ENDIF ! End sea-ice time step only
@@ -224,5 +224,5 @@
INTEGER, INTENT(in) :: Kbb, Kmm, Kaa
!
- INTEGER :: ji, jj, ierr
+ INTEGER :: ierr
!!----------------------------------------------------------------------
IF(lwp) WRITE(numout,*)
@@ -240,4 +240,8 @@
CALL par_init ! set some ice run parameters
!
+#if defined key_agrif
+ CALL Agrif_Declare_Var_ice ! " " " " " Sea ice
+#endif
+ !
! ! Allocate the ice arrays (sbc_ice already allocated in sbc_init)
ierr = ice_alloc () ! ice variables
@@ -248,36 +252,36 @@
IF( ierr /= 0 ) CALL ctl_stop('STOP', 'ice_init : unable to allocate ice arrays')
!
- CALL ice_itd_init ! ice thickness distribution initialization
- !
- CALL ice_thd_init ! set ice thermodynics parameters (clem: important to call it first for melt ponds)
- !
- ! ! Initial sea-ice state
- IF( .NOT. ln_rstart ) THEN ! start from rest: sea-ice deduced from sst
- CALL ice_istate_init
- CALL ice_istate( nit000, Kbb, Kmm, Kaa )
- ELSE ! start from a restart file
- CALL ice_rst_read( Kbb, Kmm, Kaa )
- ENDIF
- CALL ice_var_glo2eqv
- CALL ice_var_agg(1)
- !
- CALL ice_sbc_init ! set ice-ocean and ice-atm. coupling parameters
- !
- CALL ice_dyn_init ! set ice dynamics parameters
- !
- CALL ice_update_init ! ice surface boundary condition
- !
- CALL ice_alb_init ! ice surface albedo
- !
- CALL ice_dia_init ! initialization for diags
- !
- fr_i (:,:) = at_i(:,:) ! initialisation of sea-ice fraction
- tn_ice(:,:,:) = t_su(:,:,:) ! initialisation of surface temp for coupled simu
- !
! ! set max concentration in both hemispheres
WHERE( gphit(:,:) > 0._wp ) ; rn_amax_2d(:,:) = rn_amax_n ! NH
ELSEWHERE ; rn_amax_2d(:,:) = rn_amax_s ! SH
END WHERE
-
+ !
+ CALL ice_itd_init ! ice thickness distribution initialization
+ !
+ CALL ice_thd_init ! set ice thermodynics parameters (clem: important to call it first for melt ponds)
+ !
+ ! ! Initial sea-ice state
+ CALL ice_istate_init
+ IF ( ln_rstart .OR. nn_iceini_file == 2 ) THEN
+ CALL ice_rst_read( Kbb, Kmm, Kaa ) ! start from a restart file
+ ELSE
+ CALL ice_istate( nit000, Kbb, Kmm, Kaa ) ! start from rest or read a file
+ ENDIF
+ CALL ice_var_glo2eqv
+ CALL ice_var_agg(1)
+ !
+ CALL ice_sbc_init ! set ice-ocean and ice-atm. coupling parameters
+ !
+ CALL ice_dyn_init ! set ice dynamics parameters
+ !
+ CALL ice_update_init ! ice surface boundary condition
+ !
+ CALL ice_alb_init ! ice surface albedo
+ !
+ CALL ice_dia_init ! initialization for diags
+ !
+ fr_i (:,:) = at_i(:,:) ! initialisation of sea-ice fraction
+ tn_ice(:,:,:) = t_su(:,:,:) ! initialisation of surface temp for coupled simu
+ !
IF( ln_rstart ) CALL iom_close( numrir ) ! close input ice restart file
!
@@ -362,5 +366,4 @@
v_s_b (:,:,:) = v_s (:,:,:) ! snow volume
sv_i_b(:,:,:) = sv_i(:,:,:) ! salt content
- oa_i_b(:,:,:) = oa_i(:,:,:) ! areal age content
e_s_b (:,:,:,:) = e_s (:,:,:,:) ! snow thermal energy
e_i_b (:,:,:,:) = e_i (:,:,:,:) ! ice thermal energy
@@ -371,10 +374,4 @@
h_i_b(:,:,:) = 0._wp
h_s_b(:,:,:) = 0._wp
- END WHERE
-
- WHERE( a_ip(:,:,:) >= epsi20 )
- h_ip_b(:,:,:) = v_ip(:,:,:) / a_ip(:,:,:) ! ice pond thickness
- ELSEWHERE
- h_ip_b(:,:,:) = 0._wp
END WHERE
!
@@ -420,5 +417,4 @@
hfx_res(:,:) = 0._wp ; hfx_sub(:,:) = 0._wp
hfx_spr(:,:) = 0._wp ; hfx_dif(:,:) = 0._wp
- hfx_err_rem(:,:) = 0._wp
hfx_err_dif(:,:) = 0._wp
wfx_err_sub(:,:) = 0._wp
@@ -441,5 +437,5 @@
diag_trp_ei(:,:) = 0._wp ; diag_trp_es(:,:) = 0._wp
diag_trp_sv(:,:) = 0._wp
-
+
END SUBROUTINE diag_set0
Index: /NEMO/branches/2020/r12377_ticket2386/src/ICE/icethd.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/ICE/icethd.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/ICE/icethd.F90 (revision 13540)
@@ -35,4 +35,5 @@
!
USE in_out_manager ! I/O manager
+ USE iom ! I/O manager library
USE lib_mpp ! MPP library
USE lib_fortran ! fortran utilities (glob_sum + no signed zero)
@@ -51,4 +52,8 @@
LOGICAL :: ln_icedO ! activate ice growth in open-water (T) or not (F)
LOGICAL :: ln_icedS ! activate gravity drainage and flushing (T) or not (F)
+ LOGICAL :: ln_leadhfx ! heat in the leads is used to melt sea-ice before warming the ocean
+
+ !! for convergence tests
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztice_cvgerr, ztice_cvgstp
!! * Substitutions
@@ -102,4 +107,10 @@
WRITE(numout,*) '~~~~~~~'
ENDIF
+
+ ! convergence tests
+ IF( ln_zdf_chkcvg ) THEN
+ ALLOCATE( ztice_cvgerr(jpi,jpj,jpl) , ztice_cvgstp(jpi,jpj,jpl) )
+ ztice_cvgerr = 0._wp ; ztice_cvgstp = 0._wp
+ ENDIF
!---------------------------------------------!
@@ -109,5 +120,5 @@
zu_io(:,:) = u_ice(:,:) - ssu_m(:,:)
zv_io(:,:) = v_ice(:,:) - ssv_m(:,:)
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
zfric(ji,jj) = rn_cio * ( 0.5_wp * &
& ( zu_io(ji,jj) * zu_io(ji,jj) + zu_io(ji-1,jj) * zu_io(ji-1,jj) &
@@ -115,5 +126,5 @@
END_2D
ELSE ! if no ice dynamics => transmit directly the atmospheric stress to the ocean
- DO_2D_00_00
+ 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) &
@@ -121,10 +132,10 @@
END_2D
ENDIF
- CALL lbc_lnk( 'icethd', zfric, 'T', 1. )
+ CALL lbc_lnk( 'icethd', zfric, 'T', 1.0_wp )
!
!--------------------------------------------------------------------!
! Partial computation of forcing for the thermodynamic sea ice model
!--------------------------------------------------------------------!
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
rswitch = tmask(ji,jj,1) * MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi10 ) ) ! 0 if no ice
!
@@ -159,5 +170,7 @@
! If the grid cell is fully covered by ice (no leads) => transfer energy from the lead budget to the ice bottom budget
IF( ( zqld >= 0._wp .AND. at_i(ji,jj) > 0._wp ) .OR. at_i(ji,jj) >= (1._wp - epsi10) ) THEN
- fhld (ji,jj) = rswitch * zqld * 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
+ IF( ln_leadhfx ) THEN ; fhld(ji,jj) = rswitch * zqld * 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
+ ELSE ; fhld(ji,jj) = 0._wp
+ ENDIF
qlead(ji,jj) = 0._wp
ELSE
@@ -196,5 +209,5 @@
! select ice covered grid points
npti = 0 ; nptidx(:) = 0
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
IF ( a_i(ji,jj,jl) > epsi10 ) THEN
npti = npti + 1
@@ -208,5 +221,5 @@
! ! --- & Change units of e_i, e_s from J/m2 to J/m3 --- !
!
- s_i_new (1:npti) = 0._wp ; dh_s_tot(1:npti) = 0._wp ! --- some init --- ! (important to have them here)
+ s_i_new (1:npti) = 0._wp ; dh_s_tot(1:npti) = 0._wp ! --- some init --- ! (important to have them here)
dh_i_sum (1:npti) = 0._wp ; dh_i_bom(1:npti) = 0._wp ; dh_i_itm (1:npti) = 0._wp
dh_i_sub (1:npti) = 0._wp ; dh_i_bog(1:npti) = 0._wp
@@ -218,5 +231,5 @@
CALL ice_thd_dh ! Ice-Snow thickness
CALL ice_thd_pnd ! Melt ponds formation
- CALL ice_thd_ent( e_i_1d(1:npti,:) ) ! Ice enthalpy remapping
+ CALL ice_thd_ent( e_i_1d(1:npti,:), .true. ) ! Ice enthalpy remapping
ENDIF
CALL ice_thd_sal( ln_icedS ) ! --- Ice salinity --- !
@@ -241,4 +254,10 @@
!
IF( ln_icedO ) CALL ice_thd_do ! --- Frazil ice growth in leads --- !
+ !
+ ! convergence tests
+ IF( ln_zdf_chkcvg ) THEN
+ CALL iom_put( 'tice_cvgerr', ztice_cvgerr ) ; DEALLOCATE( ztice_cvgerr )
+ CALL iom_put( 'tice_cvgstp', ztice_cvgstp ) ; DEALLOCATE( ztice_cvgstp )
+ ENDIF
!
! controls
@@ -347,5 +366,5 @@
CALL tab_2d_1d( npti, nptidx(1:npti), a_ip_1d (1:npti), a_ip (:,:,kl) )
CALL tab_2d_1d( npti, nptidx(1:npti), h_ip_1d (1:npti), h_ip (:,:,kl) )
- CALL tab_2d_1d( npti, nptidx(1:npti), a_ip_frac_1d(1:npti), a_ip_frac(:,:,kl) )
+ CALL tab_2d_1d( npti, nptidx(1:npti), h_il_1d (1:npti), h_il (:,:,kl) )
!
CALL tab_2d_1d( npti, nptidx(1:npti), qprec_ice_1d (1:npti), qprec_ice )
@@ -399,5 +418,4 @@
CALL tab_2d_1d( npti, nptidx(1:npti), hfx_res_1d (1:npti), hfx_res )
CALL tab_2d_1d( npti, nptidx(1:npti), hfx_err_dif_1d(1:npti), hfx_err_dif )
- CALL tab_2d_1d( npti, nptidx(1:npti), hfx_err_rem_1d(1:npti), hfx_err_rem )
CALL tab_2d_1d( npti, nptidx(1:npti), qt_oce_ai_1d (1:npti), qt_oce_ai )
!
@@ -434,4 +452,5 @@
sv_i_1d(1:npti) = s_i_1d (1:npti) * v_i_1d (1:npti)
v_ip_1d(1:npti) = h_ip_1d(1:npti) * a_ip_1d(1:npti)
+ v_il_1d(1:npti) = h_il_1d(1:npti) * a_ip_1d(1:npti)
oa_i_1d(1:npti) = o_i_1d (1:npti) * a_i_1d (1:npti)
@@ -453,5 +472,5 @@
CALL tab_1d_2d( npti, nptidx(1:npti), a_ip_1d (1:npti), a_ip (:,:,kl) )
CALL tab_1d_2d( npti, nptidx(1:npti), h_ip_1d (1:npti), h_ip (:,:,kl) )
- CALL tab_1d_2d( npti, nptidx(1:npti), a_ip_frac_1d(1:npti), a_ip_frac(:,:,kl) )
+ CALL tab_1d_2d( npti, nptidx(1:npti), h_il_1d (1:npti), h_il (:,:,kl) )
!
CALL tab_1d_2d( npti, nptidx(1:npti), wfx_snw_sni_1d(1:npti), wfx_snw_sni )
@@ -491,5 +510,4 @@
CALL tab_1d_2d( npti, nptidx(1:npti), hfx_res_1d (1:npti), hfx_res )
CALL tab_1d_2d( npti, nptidx(1:npti), hfx_err_dif_1d(1:npti), hfx_err_dif )
- CALL tab_1d_2d( npti, nptidx(1:npti), hfx_err_rem_1d(1:npti), hfx_err_rem )
CALL tab_1d_2d( npti, nptidx(1:npti), qt_oce_ai_1d (1:npti), qt_oce_ai )
!
@@ -508,5 +526,11 @@
CALL tab_1d_2d( npti, nptidx(1:npti), sv_i_1d(1:npti), sv_i(:,:,kl) )
CALL tab_1d_2d( npti, nptidx(1:npti), v_ip_1d(1:npti), v_ip(:,:,kl) )
+ CALL tab_1d_2d( npti, nptidx(1:npti), v_il_1d(1:npti), v_il(:,:,kl) )
CALL tab_1d_2d( npti, nptidx(1:npti), oa_i_1d(1:npti), oa_i(:,:,kl) )
+ ! check convergence of heat diffusion scheme
+ IF( ln_zdf_chkcvg ) THEN
+ CALL tab_1d_2d( npti, nptidx(1:npti), tice_cvgerr_1d(1:npti), ztice_cvgerr(:,:,kl) )
+ CALL tab_1d_2d( npti, nptidx(1:npti), tice_cvgstp_1d(1:npti), ztice_cvgstp(:,:,kl) )
+ ENDIF
!
END SELECT
@@ -529,5 +553,5 @@
INTEGER :: ios ! Local integer output status for namelist read
!!
- NAMELIST/namthd/ ln_icedH, ln_icedA, ln_icedO, ln_icedS
+ NAMELIST/namthd/ ln_icedH, ln_icedA, ln_icedO, ln_icedS, ln_leadhfx
!!-------------------------------------------------------------------
!
@@ -543,8 +567,9 @@
WRITE(numout,*) '~~~~~~~~~~~~'
WRITE(numout,*) ' Namelist namthd:'
- WRITE(numout,*) ' activate ice thick change from top/bot (T) or not (F) ln_icedH = ', ln_icedH
- WRITE(numout,*) ' activate lateral melting (T) or not (F) ln_icedA = ', ln_icedA
- WRITE(numout,*) ' activate ice growth in open-water (T) or not (F) ln_icedO = ', ln_icedO
- WRITE(numout,*) ' activate gravity drainage and flushing (T) or not (F) ln_icedS = ', ln_icedS
+ WRITE(numout,*) ' activate ice thick change from top/bot (T) or not (F) ln_icedH = ', ln_icedH
+ WRITE(numout,*) ' activate lateral melting (T) or not (F) ln_icedA = ', ln_icedA
+ WRITE(numout,*) ' activate ice growth in open-water (T) or not (F) ln_icedO = ', ln_icedO
+ WRITE(numout,*) ' activate gravity drainage and flushing (T) or not (F) ln_icedS = ', ln_icedS
+ WRITE(numout,*) ' heat in the leads is used to melt sea-ice before warming the ocean ln_leadhfx = ', ln_leadhfx
ENDIF
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/ICE/icethd_dh.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/ICE/icethd_dh.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/ICE/icethd_dh.F90 (revision 13540)
@@ -13,6 +13,5 @@
!!----------------------------------------------------------------------
!! ice_thd_dh : vertical sea-ice growth and melt
- !! ice_thd_snwblow : distribute snow fall between ice and ocean
- !!----------------------------------------------------------------------
+ !!----------------------------------------------------------------------
USE dom_oce ! ocean space and time domain
USE phycst ! physical constants
@@ -20,4 +19,5 @@
USE ice1D ! sea-ice: thermodynamics variables
USE icethd_sal ! sea-ice: salinity profiles
+ USE icevar ! for CALL ice_var_snwblow
!
USE in_out_manager ! I/O manager
@@ -29,9 +29,4 @@
PUBLIC ice_thd_dh ! called by ice_thd
- PUBLIC ice_thd_snwblow ! called in sbcblk/sbccpl and here
-
- INTERFACE ice_thd_snwblow
- MODULE PROCEDURE ice_thd_snwblow_1d, ice_thd_snwblow_2d
- END INTERFACE
!!----------------------------------------------------------------------
@@ -186,5 +181,5 @@
! Snow precipitation
!-------------------
- CALL ice_thd_snwblow( 1. - at_i_1d(1:npti), zsnw(1:npti) ) ! snow distribution over ice after wind blowing
+ CALL ice_var_snwblow( 1.0_wp - at_i_1d(1:npti), zsnw(1:npti) ) ! snow distribution over ice after wind blowing
zdeltah(1:npti,:) = 0._wp
@@ -442,5 +437,5 @@
zEi = rcpi * ( zt_i_new - (ztmelts+rt0) ) & ! Specific enthalpy of forming ice (J/kg, <0)
- & - rLfus * ( 1.0 - ztmelts / ( zt_i_new - rt0 ) ) + rcp * ztmelts
+ & - rLfus * ( 1.0 - ztmelts / ( MIN( zt_i_new - rt0, -epsi10 ) ) ) + rcp * ztmelts
zEw = rcp * ( t_bo_1d(ji) - rt0 ) ! Specific enthalpy of seawater (J/kg, < 0)
@@ -636,33 +631,4 @@
END SUBROUTINE ice_thd_dh
-
- !!--------------------------------------------------------------------------
- !! INTERFACE ice_thd_snwblow
- !!
- !! ** Purpose : Compute distribution of precip over the ice
- !!
- !! Snow accumulation in one thermodynamic time step
- !! snowfall is partitionned between leads and ice.
- !! If snow fall was uniform, a fraction (1-at_i) would fall into leads
- !! but because of the winds, more snow falls on leads than on sea ice
- !! and a greater fraction (1-at_i)^beta of the total mass of snow
- !! (beta < 1) falls in leads.
- !! In reality, beta depends on wind speed,
- !! and should decrease with increasing wind speed but here, it is
- !! considered as a constant. an average value is 0.66
- !!--------------------------------------------------------------------------
-!!gm I think it can be usefull to set this as a FUNCTION, not a SUBROUTINE....
- SUBROUTINE ice_thd_snwblow_2d( pin, pout )
- REAL(wp), DIMENSION(:,:), INTENT(in ) :: pin ! previous fraction lead ( 1. - a_i_b )
- REAL(wp), DIMENSION(:,:), INTENT(inout) :: pout
- pout = ( 1._wp - ( pin )**rn_blow_s )
- END SUBROUTINE ice_thd_snwblow_2d
-
- SUBROUTINE ice_thd_snwblow_1d( pin, pout )
- REAL(wp), DIMENSION(:), INTENT(in ) :: pin
- REAL(wp), DIMENSION(:), INTENT(inout) :: pout
- pout = ( 1._wp - ( pin )**rn_blow_s )
- END SUBROUTINE ice_thd_snwblow_1d
-
#else
!!----------------------------------------------------------------------
Index: /NEMO/branches/2020/r12377_ticket2386/src/ICE/icethd_do.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/ICE/icethd_do.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/ICE/icethd_do.F90 (revision 13540)
@@ -145,5 +145,5 @@
zgamafr = 0.03
!
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
IF ( qlead(ji,jj) < 0._wp .AND. tau_icebfr(ji,jj) == 0._wp ) THEN ! activated if cooling and no landfast
! -- Wind stress -- !
@@ -191,5 +191,5 @@
END_2D
!
- CALL lbc_lnk_multi( 'icethd_do', zvrel, 'T', 1., ht_i_new, 'T', 1. )
+ CALL lbc_lnk_multi( 'icethd_do', zvrel, 'T', 1.0_wp, ht_i_new, 'T', 1.0_wp )
ENDIF
@@ -202,5 +202,5 @@
! Identify grid points where new ice forms
npti = 0 ; nptidx(:) = 0
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
IF ( qlead(ji,jj) < 0._wp .AND. tau_icebfr(ji,jj) == 0._wp ) THEN
npti = npti + 1
@@ -385,5 +385,5 @@
END DO
! --- Ice enthalpy remapping --- !
- CALL ice_thd_ent( ze_i_2d(1:npti,:,jl) )
+ CALL ice_thd_ent( ze_i_2d(1:npti,:,jl), .false. )
END DO
Index: /NEMO/branches/2020/r12377_ticket2386/src/ICE/icethd_ent.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/ICE/icethd_ent.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/ICE/icethd_ent.F90 (revision 13540)
@@ -38,5 +38,5 @@
CONTAINS
- SUBROUTINE ice_thd_ent( qnew )
+ SUBROUTINE ice_thd_ent( qnew, compute_hfx_err )
!!-------------------------------------------------------------------
!! *** ROUTINE ice_thd_ent ***
@@ -64,4 +64,6 @@
!!-------------------------------------------------------------------
REAL(wp), DIMENSION(:,:), INTENT(inout) :: qnew ! new enthlapies (J.m-3, remapped)
+ LOGICAL, INTENT(in) :: compute_hfx_err ! determines whether to compute diag.
+ ! error or not
!
INTEGER :: ji ! dummy loop indices
@@ -128,8 +130,8 @@
! 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
+ !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
Index: /NEMO/branches/2020/r12377_ticket2386/src/ICE/icethd_pnd.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/ICE/icethd_pnd.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/ICE/icethd_pnd.F90 (revision 13540)
@@ -35,6 +35,6 @@
! ! associated indices:
INTEGER, PARAMETER :: np_pndNO = 0 ! No pond scheme
- INTEGER, PARAMETER :: np_pndCST = 1 ! Constant pond scheme
- INTEGER, PARAMETER :: np_pndH12 = 2 ! Evolutive pond scheme (Holland et al. 2012)
+ INTEGER, PARAMETER :: np_pndCST = 1 ! Constant ice pond scheme
+ INTEGER, PARAMETER :: np_pndLEV = 2 ! Level ice pond scheme
!!----------------------------------------------------------------------
@@ -49,7 +49,6 @@
!! *** ROUTINE ice_thd_pnd ***
!!
- !! ** Purpose : change melt pond fraction
+ !! ** Purpose : change melt pond fraction and thickness
!!
- !! ** Method : brut force
!!-------------------------------------------------------------------
!
@@ -58,5 +57,5 @@
CASE (np_pndCST) ; CALL pnd_CST !== Constant melt ponds ==!
!
- CASE (np_pndH12) ; CALL pnd_H12 !== Holland et al 2012 melt ponds ==!
+ CASE (np_pndLEV) ; CALL pnd_LEV !== Level ice melt ponds ==!
!
END SELECT
@@ -86,11 +85,11 @@
!
IF( a_i_1d(ji) > 0._wp .AND. t_su_1d(ji) >= rt0 ) THEN
- a_ip_frac_1d(ji) = rn_apnd
h_ip_1d(ji) = rn_hpnd
- a_ip_1d(ji) = a_ip_frac_1d(ji) * a_i_1d(ji)
+ a_ip_1d(ji) = rn_apnd * a_i_1d(ji)
+ h_il_1d(ji) = 0._wp ! no pond lids whatsoever
ELSE
- a_ip_frac_1d(ji) = 0._wp
h_ip_1d(ji) = 0._wp
a_ip_1d(ji) = 0._wp
+ h_il_1d(ji) = 0._wp
ENDIF
!
@@ -100,91 +99,204 @@
- SUBROUTINE pnd_H12
- !!-------------------------------------------------------------------
- !! *** ROUTINE pnd_H12 ***
- !!
- !! ** Purpose : Compute melt pond evolution
- !!
- !! ** Method : Empirical method. A fraction of meltwater is accumulated in ponds
- !! and sent to ocean when surface is freezing
- !!
- !! pond growth: Vp = Vp + dVmelt
- !! with dVmelt = R/rhow * ( rhoi*dh_i + rhos*dh_s ) * a_i
- !! pond contraction: Vp = Vp * exp(0.01*MAX(Tp-Tsu,0)/Tp)
- !! with Tp = -2degC
- !!
- !! ** Tunable parameters : (no real expertise yet, ideas?)
+ SUBROUTINE pnd_LEV
+ !!-------------------------------------------------------------------
+ !! *** ROUTINE pnd_LEV ***
+ !!
+ !! ** Purpose : Compute melt pond evolution
+ !!
+ !! ** Method : A fraction of meltwater is accumulated in ponds and sent to ocean when surface is freezing
+ !! We work with volumes and then redistribute changes into thickness and concentration
+ !! assuming linear relationship between the two.
+ !!
+ !! ** Action : - pond growth: Vp = Vp + dVmelt --- from Holland et al 2012 ---
+ !! dVmelt = (1-r)/rhow * ( rhoi*dh_i + rhos*dh_s ) * a_i
+ !! dh_i = meltwater from ice surface melt
+ !! dh_s = meltwater from snow melt
+ !! (1-r) = fraction of melt water that is not flushed
+ !!
+ !! - limtations: a_ip must not exceed (1-r)*a_i
+ !! h_ip must not exceed 0.5*h_i
+ !!
+ !! - pond shrinking:
+ !! if lids: Vp = Vp -dH * a_ip
+ !! dH = lid thickness change. Retrieved from this eq.: --- from Flocco et al 2010 ---
+ !!
+ !! rhoi * Lf * dH/dt = ki * MAX(Tp-Tsu,0) / H
+ !! H = lid thickness
+ !! Lf = latent heat of fusion
+ !! Tp = -2C
+ !!
+ !! And solved implicitely as:
+ !! H(t+dt)**2 -H(t) * H(t+dt) -ki * (Tp-Tsu) * dt / (rhoi*Lf) = 0
+ !!
+ !! if no lids: Vp = Vp * exp(0.01*MAX(Tp-Tsu,0)/Tp) --- from Holland et al 2012 ---
+ !!
+ !! - Flushing: w = -perm/visc * rho_oce * grav * Hp / Hi --- from Flocco et al 2007 ---
+ !! perm = permability of sea-ice
+ !! visc = water viscosity
+ !! Hp = height of top of the pond above sea-level
+ !! Hi = ice thickness thru which there is flushing
+ !!
+ !! - Corrections: remove melt ponds when lid thickness is 10 times the pond thickness
+ !!
+ !! - pond thickness and area is retrieved from pond volume assuming a linear relationship between h_ip and a_ip:
+ !! a_ip/a_i = a_ip_frac = h_ip / zaspect
+ !!
+ !! ** Tunable parameters : ln_pnd_lids, rn_apnd_max, rn_apnd_min
!!
- !! ** Note : Stolen from CICE for quick test of the melt pond
- !! radiation and freshwater interfaces
- !! Coupling can be radiative AND freshwater
- !! Advection, ridging, rafting are called
- !!
- !! ** References : Holland, M. M. et al (J Clim 2012)
- !!-------------------------------------------------------------------
- REAL(wp), PARAMETER :: zrmin = 0.15_wp ! minimum fraction of available meltwater retained for melt ponding
- REAL(wp), PARAMETER :: zrmax = 0.70_wp ! maximum - - - - -
- REAL(wp), PARAMETER :: zpnd_aspect = 0.8_wp ! pond aspect ratio
- REAL(wp), PARAMETER :: zTp = -2._wp ! reference temperature
- !
- REAL(wp) :: zfr_mlt ! fraction of available meltwater retained for melt ponding
- REAL(wp) :: zdv_mlt ! available meltwater for melt ponding
- REAL(wp) :: z1_Tp ! inverse reference temperature
- REAL(wp) :: z1_rhow ! inverse freshwater density
- REAL(wp) :: z1_zpnd_aspect ! inverse pond aspect ratio
- REAL(wp) :: zfac, zdum
- !
- INTEGER :: ji ! loop indices
- !!-------------------------------------------------------------------
- z1_rhow = 1._wp / rhow
- z1_zpnd_aspect = 1._wp / zpnd_aspect
- z1_Tp = 1._wp / zTp
+ !! ** Note : mostly stolen from CICE
+ !!
+ !! ** References : Flocco and Feltham (JGR, 2007)
+ !! Flocco et al (JGR, 2010)
+ !! Holland et al (J. Clim, 2012)
+ !!-------------------------------------------------------------------
+ REAL(wp), DIMENSION(nlay_i) :: ztmp ! temporary array
+ !!
+ REAL(wp), PARAMETER :: zaspect = 0.8_wp ! pond aspect ratio
+ REAL(wp), PARAMETER :: zTp = -2._wp ! reference temperature
+ REAL(wp), PARAMETER :: zvisc = 1.79e-3_wp ! water viscosity
+ !!
+ REAL(wp) :: zfr_mlt, zdv_mlt ! fraction and volume of available meltwater retained for melt ponding
+ REAL(wp) :: zdv_frz, zdv_flush ! Amount of melt pond that freezes, flushes
+ REAL(wp) :: zhp ! heigh of top of pond lid wrt ssh
+ REAL(wp) :: zv_ip_max ! max pond volume allowed
+ REAL(wp) :: zdT ! zTp-t_su
+ REAL(wp) :: zsbr ! Brine salinity
+ REAL(wp) :: zperm ! permeability of sea ice
+ REAL(wp) :: zfac, zdum ! temporary arrays
+ REAL(wp) :: z1_rhow, z1_aspect, z1_Tp ! inverse
+ !!
+ INTEGER :: ji, jk ! loop indices
+ !!-------------------------------------------------------------------
+ z1_rhow = 1._wp / rhow
+ z1_aspect = 1._wp / zaspect
+ z1_Tp = 1._wp / zTp
DO ji = 1, npti
- ! !--------------------------------!
- IF( h_i_1d(ji) < rn_himin) THEN ! Case ice thickness < rn_himin !
- ! !--------------------------------!
- !--- Remove ponds on thin ice
+ ! !----------------------------------------------------!
+ IF( h_i_1d(ji) < rn_himin .OR. a_i_1d(ji) < epsi10 ) THEN ! Case ice thickness < rn_himin or tiny ice fraction !
+ ! !----------------------------------------------------!
+ !--- Remove ponds on thin ice or tiny ice fractions
a_ip_1d(ji) = 0._wp
- a_ip_frac_1d(ji) = 0._wp
h_ip_1d(ji) = 0._wp
- ! !--------------------------------!
- ELSE ! Case ice thickness >= rn_himin !
- ! !--------------------------------!
- v_ip_1d(ji) = h_ip_1d(ji) * a_ip_1d(ji) ! record pond volume at previous time step
- !
- ! available meltwater for melt ponding [m, >0] and fraction
- zdv_mlt = -( dh_i_sum(ji)*rhoi + dh_s_mlt(ji)*rhos ) * z1_rhow * a_i_1d(ji)
- zfr_mlt = zrmin + ( zrmax - zrmin ) * a_i_1d(ji) ! from CICE doc
- !zfr_mlt = zrmin + zrmax * a_i_1d(ji) ! from Holland paper
- !
- !--- Pond gowth ---!
- ! v_ip should never be negative, otherwise code crashes
- v_ip_1d(ji) = MAX( 0._wp, v_ip_1d(ji) + zfr_mlt * zdv_mlt )
- !
- ! melt pond mass flux (<0)
+ h_il_1d(ji) = 0._wp
+ ! !--------------------------------!
+ ELSE ! Case ice thickness >= rn_himin !
+ ! !--------------------------------!
+ v_ip_1d(ji) = h_ip_1d(ji) * a_ip_1d(ji) ! retrieve volume from thickness
+ v_il_1d(ji) = h_il_1d(ji) * a_ip_1d(ji)
+ !
+ !------------------!
+ ! case ice melting !
+ !------------------!
+ !
+ !--- available meltwater for melt ponding ---!
+ zdum = -( dh_i_sum(ji)*rhoi + dh_s_mlt(ji)*rhos ) * z1_rhow * a_i_1d(ji)
+ zfr_mlt = rn_apnd_min + ( rn_apnd_max - rn_apnd_min ) * at_i_1d(ji) ! = ( 1 - r ) = fraction of melt water that is not flushed
+ zdv_mlt = MAX( 0._wp, zfr_mlt * zdum ) ! max for roundoff errors?
+ !
+ !--- overflow ---!
+ ! If pond area exceeds zfr_mlt * a_i_1d(ji) then reduce the pond volume
+ ! a_ip_max = zfr_mlt * a_i
+ ! => from zaspect = h_ip / (a_ip / a_i), set v_ip_max as:
+ zv_ip_max = zfr_mlt**2 * a_i_1d(ji) * zaspect
+ zdv_mlt = MAX( 0._wp, MIN( zdv_mlt, zv_ip_max - v_ip_1d(ji) ) )
+
+ ! If pond depth exceeds half the ice thickness then reduce the pond volume
+ ! h_ip_max = 0.5 * h_i
+ ! => from zaspect = h_ip / (a_ip / a_i), set v_ip_max as:
+ zv_ip_max = z1_aspect * a_i_1d(ji) * 0.25 * h_i_1d(ji) * h_i_1d(ji)
+ zdv_mlt = MAX( 0._wp, MIN( zdv_mlt, zv_ip_max - v_ip_1d(ji) ) )
+
+ !--- Pond growing ---!
+ v_ip_1d(ji) = v_ip_1d(ji) + zdv_mlt
+ !
+ !--- Lid melting ---!
+ IF( ln_pnd_lids ) v_il_1d(ji) = MAX( 0._wp, v_il_1d(ji) - zdv_mlt ) ! must be bounded by 0
+ !
+ !--- mass flux ---!
IF( zdv_mlt > 0._wp ) THEN
- zfac = zfr_mlt * zdv_mlt * rhow * r1_Dt_ice
+ zfac = zdv_mlt * rhow * r1_Dt_ice ! melt pond mass flux < 0 [kg.m-2.s-1]
wfx_pnd_1d(ji) = wfx_pnd_1d(ji) - zfac
!
- ! adjust ice/snow melting flux to balance melt pond flux (>0)
- zdum = zfac / ( wfx_snw_sum_1d(ji) + wfx_sum_1d(ji) )
+ zdum = zfac / ( wfx_snw_sum_1d(ji) + wfx_sum_1d(ji) ) ! adjust ice/snow melting flux > 0 to balance melt pond flux
wfx_snw_sum_1d(ji) = wfx_snw_sum_1d(ji) * (1._wp + zdum)
wfx_sum_1d(ji) = wfx_sum_1d(ji) * (1._wp + zdum)
ENDIF
+
+ !-------------------!
+ ! case ice freezing ! i.e. t_su_1d(ji) < (zTp+rt0)
+ !-------------------!
+ !
+ zdT = MAX( zTp+rt0 - t_su_1d(ji), 0._wp )
!
!--- Pond contraction (due to refreezing) ---!
- v_ip_1d(ji) = v_ip_1d(ji) * EXP( 0.01_wp * MAX( zTp+rt0 - t_su_1d(ji), 0._wp ) * z1_Tp )
- !
- ! Set new pond area and depth assuming linear relation between h_ip and a_ip_frac
- ! h_ip = zpnd_aspect * a_ip_frac = zpnd_aspect * a_ip/a_i
- a_ip_1d(ji) = SQRT( v_ip_1d(ji) * z1_zpnd_aspect * a_i_1d(ji) )
- a_ip_frac_1d(ji) = a_ip_1d(ji) / a_i_1d(ji)
- h_ip_1d(ji) = zpnd_aspect * a_ip_frac_1d(ji)
+ IF( ln_pnd_lids ) THEN
+ !
+ !--- Lid growing and subsequent pond shrinking ---!
+ zdv_frz = 0.5_wp * MAX( 0._wp, -v_il_1d(ji) + & ! Flocco 2010 (eq. 5) solved implicitly as aH**2 + bH + c = 0
+ & SQRT( v_il_1d(ji)**2 + a_ip_1d(ji)**2 * 4._wp * rcnd_i * zdT * rdt_ice / (rLfus * rhow) ) ) ! max for roundoff errors
+
+ ! Lid growing
+ v_il_1d(ji) = MAX( 0._wp, v_il_1d(ji) + zdv_frz )
+
+ ! Pond shrinking
+ v_ip_1d(ji) = MAX( 0._wp, v_ip_1d(ji) - zdv_frz )
+
+ ELSE
+ ! Pond shrinking
+ v_ip_1d(ji) = v_ip_1d(ji) * EXP( 0.01_wp * zdT * z1_Tp ) ! Holland 2012 (eq. 6)
+ ENDIF
+ !
+ !--- Set new pond area and depth ---! assuming linear relation between h_ip and a_ip_frac
+ ! v_ip = h_ip * a_ip
+ ! a_ip/a_i = a_ip_frac = h_ip / zaspect (cf Holland 2012, fitting SHEBA so that knowing v_ip we can distribute it to a_ip and h_ip)
+ a_ip_1d(ji) = MIN( a_i_1d(ji), SQRT( v_ip_1d(ji) * z1_aspect * a_i_1d(ji) ) ) ! make sure a_ip < a_i
+ h_ip_1d(ji) = zaspect * a_ip_1d(ji) / a_i_1d(ji)
+
+ !---------------!
+ ! Pond flushing !
+ !---------------!
+ ! height of top of the pond above sea-level
+ zhp = ( h_i_1d(ji) * ( rho0 - rhoi ) + h_ip_1d(ji) * ( rho0 - rhow * a_ip_1d(ji) / a_i_1d(ji) ) ) * r1_rho0
+
+ ! Calculate the permeability of the ice (Assur 1958, see Flocco 2010)
+ DO jk = 1, nlay_i
+ zsbr = - 1.2_wp &
+ & - 21.8_wp * ( t_i_1d(ji,jk) - rt0 ) &
+ & - 0.919_wp * ( t_i_1d(ji,jk) - rt0 )**2 &
+ & - 0.0178_wp * ( t_i_1d(ji,jk) - rt0 )**3
+ ztmp(jk) = sz_i_1d(ji,jk) / zsbr
+ END DO
+ zperm = MAX( 0._wp, 3.e-08_wp * MINVAL(ztmp)**3 )
+
+ ! Do the drainage using Darcy's law
+ zdv_flush = -zperm * rho0 * grav * zhp * rdt_ice / (zvisc * h_i_1d(ji)) * a_ip_1d(ji)
+ zdv_flush = MAX( zdv_flush, -v_ip_1d(ji) )
+ v_ip_1d(ji) = v_ip_1d(ji) + zdv_flush
+
+ !--- Set new pond area and depth ---! assuming linear relation between h_ip and a_ip_frac
+ a_ip_1d(ji) = MIN( a_i_1d(ji), SQRT( v_ip_1d(ji) * z1_aspect * a_i_1d(ji) ) ) ! make sure a_ip < a_i
+ h_ip_1d(ji) = zaspect * a_ip_1d(ji) / a_i_1d(ji)
+
+ !--- Corrections and lid thickness ---!
+ IF( ln_pnd_lids ) THEN
+ !--- retrieve lid thickness from volume ---!
+ IF( a_ip_1d(ji) > epsi10 ) THEN ; h_il_1d(ji) = v_il_1d(ji) / a_ip_1d(ji)
+ ELSE ; h_il_1d(ji) = 0._wp
+ ENDIF
+ !--- remove ponds if lids are much larger than ponds ---!
+ IF ( h_il_1d(ji) > h_ip_1d(ji) * 10._wp ) THEN
+ a_ip_1d(ji) = 0._wp
+ h_ip_1d(ji) = 0._wp
+ h_il_1d(ji) = 0._wp
+ ENDIF
+ ENDIF
!
ENDIF
+
END DO
!
- END SUBROUTINE pnd_H12
+ END SUBROUTINE pnd_LEV
@@ -203,5 +315,7 @@
INTEGER :: ios, ioptio ! Local integer
!!
- NAMELIST/namthd_pnd/ ln_pnd, ln_pnd_H12, ln_pnd_CST, rn_apnd, rn_hpnd, ln_pnd_alb
+ NAMELIST/namthd_pnd/ ln_pnd, ln_pnd_LEV , rn_apnd_min, rn_apnd_max, &
+ & ln_pnd_CST , rn_apnd, rn_hpnd, &
+ & ln_pnd_lids, ln_pnd_alb
!!-------------------------------------------------------------------
!
@@ -217,10 +331,13 @@
WRITE(numout,*) '~~~~~~~~~~~~~~~~'
WRITE(numout,*) ' Namelist namicethd_pnd:'
- WRITE(numout,*) ' Melt ponds activated or not ln_pnd = ', ln_pnd
- WRITE(numout,*) ' Evolutive melt pond fraction and depth (Holland et al 2012) ln_pnd_H12 = ', ln_pnd_H12
- WRITE(numout,*) ' Prescribed melt pond fraction and depth ln_pnd_CST = ', ln_pnd_CST
- WRITE(numout,*) ' Prescribed pond fraction rn_apnd = ', rn_apnd
- WRITE(numout,*) ' Prescribed pond depth rn_hpnd = ', rn_hpnd
- WRITE(numout,*) ' Melt ponds affect albedo or not ln_pnd_alb = ', ln_pnd_alb
+ WRITE(numout,*) ' Melt ponds activated or not ln_pnd = ', ln_pnd
+ WRITE(numout,*) ' Level ice melt pond scheme ln_pnd_LEV = ', ln_pnd_LEV
+ WRITE(numout,*) ' Minimum ice fraction that contributes to melt ponds rn_apnd_min = ', rn_apnd_min
+ WRITE(numout,*) ' Maximum ice fraction that contributes to melt ponds rn_apnd_max = ', rn_apnd_max
+ WRITE(numout,*) ' Constant ice melt pond scheme ln_pnd_CST = ', ln_pnd_CST
+ WRITE(numout,*) ' Prescribed pond fraction rn_apnd = ', rn_apnd
+ WRITE(numout,*) ' Prescribed pond depth rn_hpnd = ', rn_hpnd
+ WRITE(numout,*) ' Frozen lids on top of melt ponds ln_pnd_lids = ', ln_pnd_lids
+ WRITE(numout,*) ' Melt ponds affect albedo or not ln_pnd_alb = ', ln_pnd_alb
ENDIF
!
@@ -229,11 +346,14 @@
IF( .NOT.ln_pnd ) THEN ; ioptio = ioptio + 1 ; nice_pnd = np_pndNO ; ENDIF
IF( ln_pnd_CST ) THEN ; ioptio = ioptio + 1 ; nice_pnd = np_pndCST ; ENDIF
- IF( ln_pnd_H12 ) THEN ; ioptio = ioptio + 1 ; nice_pnd = np_pndH12 ; ENDIF
+ IF( ln_pnd_LEV ) THEN ; ioptio = ioptio + 1 ; nice_pnd = np_pndLEV ; ENDIF
IF( ioptio /= 1 ) &
- & CALL ctl_stop( 'ice_thd_pnd_init: choose either none (ln_pnd=F) or only one pond scheme (ln_pnd_H12 or ln_pnd_CST)' )
+ & CALL ctl_stop( 'ice_thd_pnd_init: choose either none (ln_pnd=F) or only one pond scheme (ln_pnd_LEV or ln_pnd_CST)' )
!
SELECT CASE( nice_pnd )
CASE( np_pndNO )
- IF( ln_pnd_alb ) THEN ; ln_pnd_alb = .FALSE. ; CALL ctl_warn( 'ln_pnd_alb=false when no ponds' ) ; ENDIF
+ IF( ln_pnd_alb ) THEN ; ln_pnd_alb = .FALSE. ; CALL ctl_warn( 'ln_pnd_alb=false when no ponds' ) ; ENDIF
+ IF( ln_pnd_lids ) THEN ; ln_pnd_lids = .FALSE. ; CALL ctl_warn( 'ln_pnd_lids=false when no ponds' ) ; ENDIF
+ CASE( np_pndCST )
+ IF( ln_pnd_lids ) THEN ; ln_pnd_lids = .FALSE. ; CALL ctl_warn( 'ln_pnd_lids=false when constant ponds' ) ; ENDIF
END SELECT
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/ICE/icethd_sal.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/ICE/icethd_sal.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/ICE/icethd_sal.F90 (revision 13540)
@@ -55,9 +55,8 @@
!! -> nn_icesal = 3 -> Sice = S(z) [multiyear ice]
!!---------------------------------------------------------------------
- LOGICAL, INTENT(in) :: ld_sal ! gravity drainage and flushing or not
+ LOGICAL, INTENT(in) :: ld_sal ! gravity drainage and flushing or not
!
- INTEGER :: ji, jk ! dummy loop indices
- REAL(wp) :: iflush, igravdr ! local scalars
- REAL(wp) :: zs_sni, zs_i_gd, zs_i_fl, zs_i_si, zs_i_bg ! local scalars
+ INTEGER :: ji ! dummy loop indices
+ REAL(wp) :: zs_sni, zds ! local scalars
REAL(wp) :: z1_time_gd, z1_time_fl
!!---------------------------------------------------------------------
@@ -68,36 +67,43 @@
CASE( 2 ) ! time varying salinity with linear profile !
! !---------------------------------------------!
- z1_time_gd = 1._wp / rn_time_gd * rDt_ice
- z1_time_fl = 1._wp / rn_time_fl * rDt_ice
+ z1_time_gd = rDt_ice / rn_time_gd
+ z1_time_fl = rDt_ice / rn_time_fl
!
DO ji = 1, npti
!
- !---------------------------------------------------------
- ! Update ice salinity from snow-ice and bottom growth
- !---------------------------------------------------------
IF( h_i_1d(ji) > 0._wp ) THEN
- zs_sni = sss_1d(ji) * ( rhoi - rhos ) * r1_rhoi ! Salinity of snow ice
- zs_i_si = ( zs_sni - s_i_1d(ji) ) * dh_snowice(ji) / h_i_1d(ji) ! snow-ice
- zs_i_bg = ( s_i_new(ji) - s_i_1d(ji) ) * dh_i_bog (ji) / h_i_1d(ji) ! bottom growth
- ! Update salinity (nb: salt flux already included in icethd_dh)
- s_i_1d(ji) = s_i_1d(ji) + zs_i_bg + zs_i_si
+ !
+ ! --- Update ice salinity from snow-ice and bottom growth --- !
+ zs_sni = sss_1d(ji) * ( rhoi - rhos ) * r1_rhoi ! salinity of snow ice
+ zds = ( zs_sni - s_i_1d(ji) ) * dh_snowice(ji) / h_i_1d(ji) ! snow-ice
+ zds = zds + ( s_i_new(ji) - s_i_1d(ji) ) * dh_i_bog (ji) / h_i_1d(ji) ! bottom growth
+ ! update salinity (nb: salt flux already included in icethd_dh)
+ s_i_1d(ji) = s_i_1d(ji) + zds
+ !
+ ! --- Update ice salinity from brine drainage and flushing --- !
+ IF( ld_sal ) THEN
+ IF( t_su_1d(ji) >= rt0 ) THEN ! flushing (summer time)
+ zds = - MAX( s_i_1d(ji) - rn_sal_fl , 0._wp ) * z1_time_fl
+ ELSEIF( t_su_1d(ji) <= t_bo_1d(ji) ) THEN ! gravity drainage
+ zds = - MAX( s_i_1d(ji) - rn_sal_gd , 0._wp ) * z1_time_gd
+ ELSE
+ zds = 0._wp
+ ENDIF
+ ! update salinity
+ s_i_1d(ji) = s_i_1d(ji) + zds
+ ! salt flux
+ sfx_bri_1d(ji) = sfx_bri_1d(ji) - rhoi * a_i_1d(ji) * h_i_1d(ji) * zds * r1_Dt_ice
+ ENDIF
+ !
+ ! --- salinity must stay inbounds --- !
+ zds = MAX( 0._wp, rn_simin - s_i_1d(ji) ) ! > 0 if s_i < simin
+ zds = zds + MIN( 0._wp, rn_simax - s_i_1d(ji) ) ! < 0 if s_i > simax
+ ! update salinity
+ s_i_1d(ji) = s_i_1d(ji) + zds
+ ! salt flux
+ sfx_res_1d(ji) = sfx_res_1d(ji) - rhoi * a_i_1d(ji) * h_i_1d(ji) * zds * r1_Dt_ice
+ !
ENDIF
!
- IF( ld_sal ) THEN
- !---------------------------------------------------------
- ! Update ice salinity from brine drainage and flushing
- !---------------------------------------------------------
- iflush = MAX( 0._wp , SIGN( 1._wp , t_su_1d(ji) - rt0 ) ) ! =1 if summer
- igravdr = MAX( 0._wp , SIGN( 1._wp , t_bo_1d(ji) - t_su_1d(ji) ) ) ! =1 if t_su < t_bo
-
- zs_i_gd = - igravdr * MAX( s_i_1d(ji) - rn_sal_gd , 0._wp ) * z1_time_gd ! gravity drainage
- zs_i_fl = - iflush * MAX( s_i_1d(ji) - rn_sal_fl , 0._wp ) * z1_time_fl ! flushing
-
- ! Update salinity
- s_i_1d(ji) = s_i_1d(ji) + zs_i_fl + zs_i_gd
-
- ! Salt flux
- sfx_bri_1d(ji) = sfx_bri_1d(ji) - rhoi * a_i_1d(ji) * h_i_1d(ji) * ( zs_i_fl + zs_i_gd ) * r1_Dt_ice
- ENDIF
END DO
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/ICE/icethd_zdf.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/ICE/icethd_zdf.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/ICE/icethd_zdf.F90 (revision 13540)
@@ -85,5 +85,6 @@
INTEGER :: ios, ioptio ! Local integer
!!
- NAMELIST/namthd_zdf/ ln_zdf_BL99, ln_cndi_U64, ln_cndi_P07, rn_cnd_s, rn_kappa_i
+ NAMELIST/namthd_zdf/ ln_zdf_BL99, ln_cndi_U64, ln_cndi_P07, rn_cnd_s, &
+ & rn_kappa_i, rn_kappa_s, rn_kappa_smlt, rn_kappa_sdry, ln_zdf_chkcvg
!!-------------------------------------------------------------------
!
@@ -99,9 +100,13 @@
WRITE(numout,*) '~~~~~~~~~~~~~~~~'
WRITE(numout,*) ' Namelist namthd_zdf:'
- WRITE(numout,*) ' Bitz and Lipscomb (1999) formulation ln_zdf_BL99 = ', ln_zdf_BL99
- WRITE(numout,*) ' thermal conductivity in the ice (Untersteiner 1964) ln_cndi_U64 = ', ln_cndi_U64
- WRITE(numout,*) ' thermal conductivity in the ice (Pringle et al 2007) ln_cndi_P07 = ', ln_cndi_P07
- WRITE(numout,*) ' thermal conductivity in the snow rn_cnd_s = ', rn_cnd_s
- WRITE(numout,*) ' extinction radiation parameter in sea ice rn_kappa_i = ', rn_kappa_i
+ WRITE(numout,*) ' Bitz and Lipscomb (1999) formulation ln_zdf_BL99 = ', ln_zdf_BL99
+ WRITE(numout,*) ' thermal conductivity in the ice (Untersteiner 1964) ln_cndi_U64 = ', ln_cndi_U64
+ WRITE(numout,*) ' thermal conductivity in the ice (Pringle et al 2007) ln_cndi_P07 = ', ln_cndi_P07
+ WRITE(numout,*) ' thermal conductivity in the snow rn_cnd_s = ', rn_cnd_s
+ WRITE(numout,*) ' extinction radiation parameter in sea ice rn_kappa_i = ', rn_kappa_i
+ WRITE(numout,*) ' extinction radiation parameter in snw (nn_qtrice=0) rn_kappa_s = ', rn_kappa_s
+ WRITE(numout,*) ' extinction radiation parameter in melt snw (nn_qtrice=1) rn_kappa_smlt = ', rn_kappa_smlt
+ WRITE(numout,*) ' extinction radiation parameter in dry snw (nn_qtrice=1) rn_kappa_sdry = ', rn_kappa_sdry
+ WRITE(numout,*) ' check convergence of heat diffusion scheme ln_zdf_chkcvg = ', ln_zdf_chkcvg
ENDIF
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/ICE/icethd_zdf_bl99.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/ICE/icethd_zdf_bl99.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/ICE/icethd_zdf_bl99.F90 (revision 13540)
@@ -85,21 +85,21 @@
LOGICAL, DIMENSION(jpij) :: l_T_converged ! true when T converges (per grid point)
-!
+ !
REAL(wp) :: zg1s = 2._wp ! for the tridiagonal system
REAL(wp) :: zg1 = 2._wp !
REAL(wp) :: zgamma = 18009._wp ! for specific heat
REAL(wp) :: zbeta = 0.117_wp ! for thermal conductivity (could be 0.13)
- REAL(wp) :: zraext_s = 10._wp ! extinction coefficient of radiation in the snow
REAL(wp) :: zkimin = 0.10_wp ! minimum ice thermal conductivity
REAL(wp) :: ztsu_err = 1.e-5_wp ! range around which t_su is considered at 0C
REAL(wp) :: zdti_bnd = 1.e-4_wp ! maximal authorized error on temperature
- REAL(wp) :: zhs_min = 0.01_wp ! minimum snow thickness for conductivity calculation
+ REAL(wp) :: zhs_ssl = 0.03_wp ! surface scattering layer in the snow
+ REAL(wp) :: zhi_ssl = 0.10_wp ! surface scattering layer in the ice
+ REAL(wp) :: zh_min = 1.e-3_wp ! minimum ice/snow thickness for conduction
REAL(wp) :: ztmelts ! ice melting temperature
REAL(wp) :: zdti_max ! current maximal error on temperature
REAL(wp) :: zcpi ! Ice specific heat
REAL(wp) :: zhfx_err, zdq ! diag errors on heat
- REAL(wp) :: zfac ! dummy factor
- !
- REAL(wp), DIMENSION(jpij) :: isnow ! switch for presence (1) or absence (0) of snow
+ !
+ REAL(wp), DIMENSION(jpij) :: zraext_s ! extinction coefficient of radiation in the snow
REAL(wp), DIMENSION(jpij) :: ztsub ! surface temperature at previous iteration
REAL(wp), DIMENSION(jpij) :: zh_i, z1_h_i ! ice layer thickness
@@ -124,4 +124,5 @@
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
REAL(wp), DIMENSION(jpij,nlay_i+3) :: zindterm ! 'Ind'ependent term
REAL(wp), DIMENSION(jpij,nlay_i+3) :: zindtbis ! Temporary 'ind'ependent term
@@ -130,4 +131,7 @@
REAL(wp), DIMENSION(jpij) :: zq_ini ! diag errors on heat
REAL(wp), DIMENSION(jpij) :: zghe ! G(he), th. conduct enhancement factor, mono-cat
+ 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
!
! Mono-category
@@ -143,27 +147,52 @@
END DO
+ ! calculate ice fraction covered by snow for radiation
+ CALL ice_var_snwfra( h_s_1d(1:npti), za_s_fra(1:npti) )
+
!------------------
! 1) Initialization
!------------------
+ !
+ ! extinction radiation in the snow
+ IF ( nn_qtrice == 0 ) THEN ! constant
+ zraext_s(1:npti) = rn_kappa_s
+ ELSEIF( nn_qtrice == 1 ) THEN ! depends on melting/freezing conditions
+ WHERE( t_su_1d(1:npti) < rt0 ) ; zraext_s(1:npti) = rn_kappa_sdry ! no surface melting
+ ELSEWHERE ; zraext_s(1:npti) = rn_kappa_smlt ! surface melting
+ END WHERE
+ ENDIF
+ !
+ ! thicknesses
DO ji = 1, npti
- isnow(ji) = 1._wp - MAX( 0._wp , SIGN(1._wp, - h_s_1d(ji) ) ) ! is there snow or not
- ! layer thickness
- zh_i(ji) = h_i_1d(ji) * r1_nlay_i
- zh_s(ji) = h_s_1d(ji) * r1_nlay_s
+ ! ice thickness
+ IF( h_i_1d(ji) > 0._wp ) THEN
+ zh_i (ji) = MAX( zh_min , h_i_1d(ji) ) * r1_nlay_i ! set a minimum thickness for conduction
+ z1_h_i(ji) = 1._wp / zh_i(ji) ! it must be very small
+ ELSE
+ zh_i (ji) = 0._wp
+ z1_h_i(ji) = 0._wp
+ ENDIF
+ ! snow thickness
+ IF( h_s_1d(ji) > 0._wp ) THEN
+ zh_s (ji) = MAX( zh_min , h_s_1d(ji) ) * r1_nlay_s ! set a minimum thickness for conduction
+ z1_h_s(ji) = 1._wp / zh_s(ji) ! it must be very small
+ isnow (ji) = 1._wp
+ ELSE
+ zh_s (ji) = 0._wp
+ z1_h_s(ji) = 0._wp
+ isnow (ji) = 0._wp
+ ENDIF
+ ! for Met-Office
+ IF( h_s_1d(ji) < zh_min ) THEN
+ isnow_comb(ji) = h_s_1d(ji) / zh_min
+ ELSE
+ isnow_comb(ji) = 1._wp
+ ENDIF
END DO
- !
- WHERE( zh_i(1:npti) >= epsi10 ) ; z1_h_i(1:npti) = 1._wp / zh_i(1:npti)
- ELSEWHERE ; z1_h_i(1:npti) = 0._wp
- END WHERE
- !
- WHERE( zh_s(1:npti) > 0._wp ) zh_s(1:npti) = MAX( zhs_min * r1_nlay_s, zh_s(1:npti) )
- !
- WHERE( zh_s(1:npti) > 0._wp ) ; z1_h_s(1:npti) = 1._wp / zh_s(1:npti)
- ELSEWHERE ; z1_h_s(1:npti) = 0._wp
- END WHERE
+ ! clem: we should apply correction on snow thickness to take into account snow fraction
+ ! it must be a distribution, so it is a bit complicated
!
! 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
@@ -185,5 +214,5 @@
DO ji = 1, npti
! ! radiation transmitted below the layer-th snow layer
- zradtr_s(ji,jk) = zradtr_s(ji,0) * EXP( - zraext_s * h_s_1d(ji) * r1_nlay_s * REAL(jk) )
+ zradtr_s(ji,jk) = zradtr_s(ji,0) * EXP( - zraext_s(ji) * MAX( 0._wp, zh_s(ji) * REAL(jk) - zhs_ssl ) )
! ! radiation absorbed by the layer-th snow layer
zradab_s(ji,jk) = zradtr_s(ji,jk-1) - zradtr_s(ji,jk)
@@ -191,9 +220,12 @@
END DO
!
- zradtr_i(1:npti,0) = zradtr_s(1:npti,nlay_s) * isnow(1:npti) + qtr_ice_top_1d(1:npti) * ( 1._wp - isnow(1:npti) )
+ zradtr_i(1:npti,0) = zradtr_s(1:npti,nlay_s) * za_s_fra(1:npti) + qtr_ice_top_1d(1:npti) * ( 1._wp - za_s_fra(1:npti) )
DO jk = 1, nlay_i
DO ji = 1, npti
! ! radiation transmitted below the layer-th ice layer
- zradtr_i(ji,jk) = zradtr_i(ji,0) * EXP( - rn_kappa_i * zh_i(ji) * REAL(jk) )
+ zradtr_i(ji,jk) = za_s_fra(ji) * zradtr_s(ji,nlay_s) & ! part covered by snow
+ & * EXP( - rn_kappa_i * MAX( 0._wp, zh_i(ji) * REAL(jk) - zh_min ) ) &
+ & + ( 1._wp - za_s_fra(ji) ) * qtr_ice_top_1d(ji) & ! part snow free
+ & * EXP( - rn_kappa_i * MAX( 0._wp, zh_i(ji) * REAL(jk) - zhi_ssl ) )
! ! radiation absorbed by the layer-th ice layer
zradab_i(ji,jk) = zradtr_i(ji,jk-1) - zradtr_i(ji,jk)
@@ -203,5 +235,5 @@
qtr_ice_bot_1d(1:npti) = zradtr_i(1:npti,nlay_i) ! record radiation transmitted below the ice
!
- iconv = 0 ! number of iterations
+ iconv = 0 ! number of iterations
!
l_T_converged(:) = .FALSE.
@@ -230,5 +262,5 @@
DO ji = 1, npti
ztcond_i_cp(ji,jk) = rcnd_i + zbeta * 0.5_wp * ( sz_i_1d(ji,jk) + sz_i_1d(ji,jk+1) ) / &
- & MIN( -epsi10, 0.5_wp * (t_i_1d(ji,jk) + t_i_1d(ji,jk+1)) - rt0 )
+ & MIN( -epsi10, 0.5_wp * ( t_i_1d(ji,jk) + t_i_1d(ji,jk+1) ) - rt0 )
END DO
END DO
@@ -238,13 +270,13 @@
DO ji = 1, npti
ztcond_i_cp(ji,0) = rcnd_i + 0.09_wp * sz_i_1d(ji,1) / MIN( -epsi10, t_i_1d(ji,1) - rt0 ) &
- & - 0.011_wp * ( t_i_1d(ji,1) - rt0 )
+ & - 0.011_wp * ( t_i_1d(ji,1) - rt0 )
ztcond_i_cp(ji,nlay_i) = rcnd_i + 0.09_wp * sz_i_1d(ji,nlay_i) / MIN( -epsi10, t_bo_1d(ji) - rt0 ) &
- & - 0.011_wp * ( t_bo_1d(ji) - rt0 )
+ & - 0.011_wp * ( t_bo_1d(ji) - rt0 )
END DO
DO jk = 1, nlay_i-1
DO ji = 1, npti
- ztcond_i_cp(ji,jk) = rcnd_i + 0.09_wp * 0.5_wp * ( sz_i_1d(ji,jk) + sz_i_1d(ji,jk+1) ) / &
- & MIN( -epsi10, 0.5_wp * ( t_i_1d (ji,jk) + t_i_1d (ji,jk+1) ) - rt0 ) &
- & - 0.011_wp * ( 0.5_wp * ( t_i_1d (ji,jk) + t_i_1d (ji,jk+1) ) - rt0 )
+ ztcond_i_cp(ji,jk) = rcnd_i + 0.09_wp * 0.5_wp * ( sz_i_1d(ji,jk) + sz_i_1d(ji,jk+1) ) / &
+ & MIN( -epsi10, 0.5_wp * ( t_i_1d(ji,jk) + t_i_1d(ji,jk+1) ) - rt0 ) &
+ & - 0.011_wp * ( 0.5_wp * ( t_i_1d(ji,jk) + t_i_1d(ji,jk+1) ) - rt0 )
END DO
END DO
@@ -290,12 +322,7 @@
END DO
DO ji = 1, npti ! Snow-ice interface
- IF ( .NOT. l_T_converged(ji) ) THEN
- zfac = 0.5_wp * ( ztcond_i(ji,0) * zh_s(ji) + rn_cnd_s * zh_i(ji) )
- IF( zfac > epsi10 ) THEN
- zkappa_s(ji,nlay_s) = zghe(ji) * rn_cnd_s * ztcond_i(ji,0) / zfac
- ELSE
- zkappa_s(ji,nlay_s) = 0._wp
- ENDIF
- ENDIF
+ IF ( .NOT. l_T_converged(ji) ) &
+ zkappa_s(ji,nlay_s) = isnow(ji) * zghe(ji) * rn_cnd_s * ztcond_i(ji,0) &
+ & / ( 0.5_wp * ( ztcond_i(ji,0) * zh_s(ji) + rn_cnd_s * zh_i(ji) ) )
END DO
@@ -310,6 +337,10 @@
END DO
DO ji = 1, npti ! Snow-ice interface
- IF ( .NOT. l_T_converged(ji) ) &
- zkappa_i(ji,0) = zkappa_s(ji,nlay_s) * isnow(ji) + zkappa_i(ji,0) * ( 1._wp - isnow(ji) )
+ IF ( .NOT. l_T_converged(ji) ) THEN
+ ! 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
END DO
!
@@ -320,5 +351,5 @@
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) / MAX( epsi10, zcpi )
+ zeta_i(ji,jk) = rDt_ice * r1_rhoi * z1_h_i(ji) / zcpi
END DO
END DO
@@ -544,9 +575,10 @@
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(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))
ENDIF
ENDIF
END DO
+ !clem: in order to have several layers of snow, there is a missing loop here for t_s_1d(1:nlay_s-1)
!
!--------------------------------------------------------------
@@ -561,9 +593,14 @@
IF ( .NOT. l_T_converged(ji) ) THEN
+
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) ) )
- t_s_1d(ji,1:nlay_s) = MAX( MIN( t_s_1d(ji,1:nlay_s), rt0 ), rt0 - 100._wp )
- zdti_max = MAX ( zdti_max , MAXVAL( ABS( t_s_1d(ji,1:nlay_s) - ztsb(ji,1:nlay_s) ) ) )
+ 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) ) )
+ END DO
+ ENDIF
DO jk = 1, nlay_i
@@ -572,6 +609,12 @@
zdti_max = MAX( zdti_max, ABS( t_i_1d(ji,jk) - ztib(ji,jk) ) )
END DO
-
- IF ( zdti_max < zdti_bnd ) l_T_converged(ji) = .TRUE.
+
+ ! convergence test
+ IF( ln_zdf_chkcvg ) THEN
+ tice_cvgerr_1d(ji) = zdti_max
+ tice_cvgstp_1d(ji) = REAL(iconv)
+ ENDIF
+
+ IF( zdti_max < zdti_bnd ) l_T_converged(ji) = .TRUE.
ENDIF
@@ -726,4 +769,5 @@
ENDIF
END DO
+ !clem: in order to have several layers of snow, there is a missing loop here for t_s_1d(1:nlay_s-1)
!
!--------------------------------------------------------------
@@ -738,8 +782,12 @@
IF ( .NOT. l_T_converged(ji) ) THEN
- ! t_s
- t_s_1d(ji,1:nlay_s) = MAX( MIN( t_s_1d(ji,1:nlay_s), rt0 ), rt0 - 100._wp )
- zdti_max = MAX ( zdti_max , MAXVAL( ABS( t_s_1d(ji,1:nlay_s) - ztsb(ji,1:nlay_s) ) ) )
- ! t_i
+
+ 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) ) )
+ END DO
+ ENDIF
+
DO jk = 1, nlay_i
ztmelts = -rTmlt * sz_i_1d(ji,jk) + rt0
@@ -748,5 +796,11 @@
END DO
- IF ( zdti_max < zdti_bnd ) l_T_converged(ji) = .TRUE.
+ ! convergence test
+ IF( ln_zdf_chkcvg ) THEN
+ tice_cvgerr_1d(ji) = zdti_max
+ tice_cvgstp_1d(ji) = REAL(iconv)
+ ENDIF
+
+ IF( zdti_max < zdti_bnd ) l_T_converged(ji) = .TRUE.
ENDIF
@@ -755,12 +809,6 @@
ENDIF ! k_cnd
-
+
END DO ! End of the do while iterative procedure
-
- IF( ln_icectl .AND. lwp ) THEN
- WRITE(numout,*) ' zdti_max : ', zdti_max
- WRITE(numout,*) ' iconv : ', iconv
- ENDIF
-
!
!-----------------------------
@@ -771,5 +819,5 @@
! 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) )
+ 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
@@ -777,6 +825,6 @@
!
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) ) &
- & - ( 1._wp - isnow(ji) ) * zkappa_i(ji,0) * zg1 * ( t_i_1d(ji,1) - t_su_1d(ji) )
+ qcn_ice_top_1d(ji) = - isnow(ji) * zkappa_s(ji,0) * zg1s * ( t_s_1d(ji,1) - t_su_1d(ji) ) &
+ & - ( 1._wp - isnow(ji) ) * zkappa_i(ji,0) * zg1 * ( t_i_1d(ji,1) - t_su_1d(ji) )
END DO
!
@@ -792,8 +840,7 @@
!
DO ji = 1, npti
- t_su_1d(ji) = ( qcn_ice_top_1d(ji) & ! calculate surface temperature
- & + 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) = ( 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
@@ -853,13 +900,11 @@
!--------------------------------------------------------------------
! effective conductivity and 1st layer temperature (needed by Met Office)
+ ! this is a conductivity at mid-layer, hence the factor 2
DO ji = 1, npti
- IF( h_s_1d(ji) > 0.1_wp ) THEN
- cnd_ice_1d(ji) = 2._wp * zkappa_s(ji,0)
+ IF( h_i_1d(ji) >= zhi_ssl ) THEN
+ cnd_ice_1d(ji) = 2._wp * zkappa_comb(ji)
+ !!cnd_ice_1d(ji) = 2._wp * zkappa_i(ji,0)
ELSE
- IF( h_i_1d(ji) > 0.1_wp ) THEN
- cnd_ice_1d(ji) = 2._wp * zkappa_i(ji,0)
- ELSE
- cnd_ice_1d(ji) = 2._wp * ztcond_i(ji,0) * 10._wp
- ENDIF
+ cnd_ice_1d(ji) = 2._wp * ztcond_i(ji,0) / zhi_ssl ! cnd_ice is capped by: cond_i/zhi_ssl
ENDIF
t1_ice_1d(ji) = isnow(ji) * t_s_1d(ji,1) + ( 1._wp - isnow(ji) ) * t_i_1d(ji,1)
@@ -877,8 +922,9 @@
DO ji = 1, npti
!--- Snow-ice interfacial temperature (diagnostic SIMIP)
- zfac = rn_cnd_s * zh_i(ji) + ztcond_i(ji,1) * zh_s(ji)
- IF( h_s_1d(ji) >= zhs_min ) THEN
- t_si_1d(ji) = ( rn_cnd_s * zh_i(ji) * t_s_1d(ji,1) + &
- & ztcond_i(ji,1) * zh_s(ji) * t_i_1d(ji,1) ) / MAX( epsi10, zfac )
+ 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,1) &
+ & + ztcond_i(ji,1) * h_s_1d(ji) * r1_nlay_s * t_i_1d(ji,1) ) &
+ & / ( rn_cnd_s * h_i_1d(ji) * r1_nlay_i &
+ & + ztcond_i(ji,1) * h_s_1d(ji) * r1_nlay_s )
ELSE
t_si_1d(ji) = t_su_1d(ji)
Index: /NEMO/branches/2020/r12377_ticket2386/src/ICE/iceupdate.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/ICE/iceupdate.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/ICE/iceupdate.F90 (revision 13540)
@@ -25,4 +25,5 @@
USE icectl ! sea-ice: control prints
USE bdy_oce , ONLY : ln_bdy
+ USE zdfdrg , ONLY : ln_drgice_imp
!
USE in_out_manager ! I/O manager
@@ -93,6 +94,5 @@
REAL(wp) :: zqmass ! Heat flux associated with mass exchange ice->ocean (W.m-2)
REAL(wp) :: zqsr ! New solar flux received by the ocean
- REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace
- REAL(wp), DIMENSION(jpi,jpj,jpl) :: zalb_cs, zalb_os ! 3D workspace
+ REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace
!!---------------------------------------------------------------------
IF( ln_timing ) CALL timing_start('ice_update')
@@ -113,5 +113,5 @@
ENDIF
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
! Solar heat flux reaching the ocean = zqsr (W.m-2)
@@ -182,7 +182,6 @@
! 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_frac, h_ip, zalb_cs, zalb_os ) ! cloud-sky and overcast-sky ice albedos
- !
- alb_ice(:,:,:) = ( 1._wp - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:)
+ CALL ice_alb( t_su, h_i, h_s, ln_pnd_alb, a_ip_eff, h_ip, cloud_fra, alb_ice ) ! ice albedo
+
!
IF( lrst_ice ) THEN !* write snwice_mass fields in the restart file
@@ -320,4 +319,5 @@
REAL(wp) :: zat_u, zutau_ice, zu_t, zmodt ! local scalar
REAL(wp) :: zat_v, zvtau_ice, zv_t, zrhoco ! - -
+ REAL(wp) :: zflagi ! - -
!!---------------------------------------------------------------------
IF( ln_timing ) CALL timing_start('ice_update_tau')
@@ -332,5 +332,5 @@
!
IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN !== Ice time-step only ==! (i.e. surface module time-step)
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 ) !* update the modulus of stress at ocean surface (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)
@@ -342,5 +342,5 @@
tmod_io(ji,jj) = zrhoco * SQRT( zmodt ) ! rhoco * |U_ice-U_oce| at T-point
END_2D
- CALL lbc_lnk_multi( 'iceupdate', taum, 'T', 1., tmod_io, 'T', 1. )
+ CALL lbc_lnk_multi( 'iceupdate', taum, 'T', 1.0_wp, tmod_io, 'T', 1.0_wp )
!
utau_oce(:,:) = utau(:,:) !* save the air-ocean stresses at ice time-step
@@ -350,6 +350,13 @@
!
! !== every ocean time-step ==!
- !
- DO_2D_00_00
+ 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)
+ 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) ) &
@@ -364,5 +371,5 @@
vtau(ji,jj) = ( 1._wp - zat_v ) * vtau_oce(ji,jj) + zat_v * zvtau_ice
END_2D
- CALL lbc_lnk_multi( 'iceupdate', utau, 'U', -1., vtau, 'V', -1. ) ! lateral boundary condition
+ CALL lbc_lnk_multi( 'iceupdate', utau, 'U', -1.0_wp, vtau, 'V', -1.0_wp ) ! lateral boundary condition
!
IF( ln_timing ) CALL timing_stop('ice_update_tau')
@@ -417,6 +424,6 @@
!
IF( id1 > 0 ) THEN ! fields exist
- CALL iom_get( numrir, jpdom_autoglo, 'snwice_mass' , snwice_mass )
- CALL iom_get( numrir, jpdom_autoglo, 'snwice_mass_b', snwice_mass_b )
+ CALL iom_get( numrir, jpdom_auto, 'snwice_mass' , snwice_mass )
+ 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'
Index: /NEMO/branches/2020/r12377_ticket2386/src/ICE/icevar.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/ICE/icevar.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/ICE/icevar.F90 (revision 13540)
@@ -51,4 +51,6 @@
!! ice_var_sshdyn : compute equivalent ssh in lead
!! ice_var_itd : convert N-cat to M-cat
+ !! ice_var_snwfra : fraction of ice covered by snow
+ !! ice_var_snwblow : distribute snow fall between ice and ocean
!!----------------------------------------------------------------------
USE dom_oce ! ocean space and time domain
@@ -77,4 +79,6 @@
PUBLIC ice_var_sshdyn
PUBLIC ice_var_itd
+ PUBLIC ice_var_snwfra
+ PUBLIC ice_var_snwblow
INTERFACE ice_var_itd
@@ -84,4 +88,13 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+
+ INTERFACE ice_var_snwfra
+ MODULE PROCEDURE ice_var_snwfra_1d, ice_var_snwfra_2d, ice_var_snwfra_3d
+ END INTERFACE
+
+ INTERFACE ice_var_snwblow
+ MODULE PROCEDURE ice_var_snwblow_1d, ice_var_snwblow_2d
+ END INTERFACE
+
!!----------------------------------------------------------------------
!! NEMO/ICE 4.0 , NEMO Consortium (2018)
@@ -115,4 +128,5 @@
at_ip(:,:) = SUM( a_ip(:,:,:), dim=3 ) ! melt ponds
vt_ip(:,:) = SUM( v_ip(:,:,:), dim=3 )
+ vt_il(:,:) = SUM( v_il(:,:,:), dim=3 )
!
ato_i(:,:) = 1._wp - at_i(:,:) ! open water fraction
@@ -166,6 +180,6 @@
!
! ! mean melt pond depth
- WHERE( at_ip(:,:) > epsi20 ) ; hm_ip(:,:) = vt_ip(:,:) / at_ip(:,:)
- ELSEWHERE ; hm_ip(:,:) = 0._wp
+ 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
END WHERE
!
@@ -191,5 +205,7 @@
REAL(wp) :: zhmax, z1_zhmax ! - -
REAL(wp) :: zlay_i, zlay_s ! - -
- REAL(wp), DIMENSION(jpi,jpj,jpl) :: z1_a_i, z1_v_i
+ 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
!!-------------------------------------------------------------------
@@ -210,4 +226,8 @@
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(:,:,:)
@@ -224,9 +244,17 @@
! !--- ice age
o_i(:,:,:) = oa_i(:,:,:) * z1_a_i(:,:,:)
- ! !--- pond fraction and thickness
+ ! !--- 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( a_ip_frac(:,:,:) > epsi20 ) ; h_ip(:,:,:) = v_ip(:,:,:) * z1_a_i(:,:,:) / a_ip_frac(:,:,:)
- ELSEWHERE ; h_ip(:,:,:) = 0._wp
- END WHERE
+ 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
+ & ( h_il(:,:,:) - zhl_min ) / ( 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)
@@ -243,5 +271,5 @@
zlay_i = REAL( nlay_i , wp ) ! number of layers
DO jl = 1, jpl
- DO_3D_11_11( 1, nlay_i )
+ DO_3D( 1, 1, 1, 1, 1, nlay_i )
IF ( v_i(ji,jj,jl) > epsi20 ) THEN !--- icy area
!
@@ -292,4 +320,5 @@
sv_i(:,:,:) = s_i (:,:,:) * v_i (:,:,:)
v_ip(:,:,:) = h_ip(:,:,:) * a_ip(:,:,:)
+ v_il(:,:,:) = h_il(:,:,:) * a_ip(:,:,:)
!
END SUBROUTINE ice_var_eqv2glo
@@ -347,5 +376,5 @@
z1_dS = 1._wp / ( zsi1 - zsi0 )
DO jl = 1, jpl
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
zalpha(ji,jj,jl) = MAX( 0._wp , MIN( ( zsi1 - s_i(ji,jj,jl) ) * z1_dS , 1._wp ) )
! ! force a constant profile when SSS too low (Baltic Sea)
@@ -356,5 +385,5 @@
! Computation of the profile
DO jl = 1, jpl
- DO_3D_11_11( 1, nlay_i )
+ DO_3D( 1, 1, 1, 1, 1, nlay_i )
! ! linear profile with 0 surface value
zs0 = z_slope_s(ji,jj,jl) * ( REAL(jk,wp) - 0.5_wp ) * h_i(ji,jj,jl) * r1_nlay_i
@@ -486,5 +515,5 @@
! Zap ice energy and use ocean heat to melt ice
!-----------------------------------------------------------------
- DO_3D_11_11( 1, nlay_i )
+ DO_3D( 1, 1, 1, 1, 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
@@ -493,5 +522,5 @@
END_3D
!
- DO_3D_11_11( 1, nlay_s )
+ DO_3D( 1, 1, 1, 1, 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
@@ -503,5 +532,5 @@
! zap ice and snow volume, add water and salt to ocean
!-----------------------------------------------------------------
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
! 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
@@ -521,4 +550,5 @@
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)
!
END_2D
@@ -542,5 +572,5 @@
- SUBROUTINE ice_var_zapneg( pdt, pato_i, pv_i, pv_s, psv_i, poa_i, pa_i, pa_ip, pv_ip, pe_s, pe_i )
+ 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 )
!!-------------------------------------------------------------------
!! *** ROUTINE ice_var_zapneg ***
@@ -557,4 +587,5 @@
REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: pa_ip ! melt pond fraction
REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: pv_ip ! melt pond volume
+ REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: pv_il ! melt pond lid volume
REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: pe_s ! snw heat content
REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: pe_i ! ice heat content
@@ -574,5 +605,5 @@
! zap ice energy and send it to the ocean
!----------------------------------------
- DO_3D_11_11( 1, nlay_i )
+ DO_3D( 1, 1, 1, 1, 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
@@ -581,5 +612,5 @@
END_3D
!
- DO_3D_11_11( 1, nlay_s )
+ DO_3D( 1, 1, 1, 1, 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
@@ -591,5 +622,5 @@
! zap ice and snow volume, add water and salt to ocean
!-----------------------------------------------------
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
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
@@ -613,10 +644,10 @@
WHERE( pa_ip (:,:,:) < 0._wp ) pa_ip (:,:,:) = 0._wp
WHERE( pv_ip (:,:,:) < 0._wp ) pv_ip (:,:,:) = 0._wp ! in theory one should change wfx_pnd(-) and wfx_sum(+)
- ! but it does not change conservation, so keep it this way is ok
+ WHERE( pv_il (:,:,:) < 0._wp ) pv_il (:,:,:) = 0._wp ! but it does not change conservation, so keep it this way is ok
!
END SUBROUTINE ice_var_zapneg
- SUBROUTINE ice_var_roundoff( pa_i, pv_i, pv_s, psv_i, poa_i, pa_ip, pv_ip, pe_s, pe_i )
+ SUBROUTINE ice_var_roundoff( pa_i, pv_i, pv_s, psv_i, poa_i, pa_ip, pv_ip, pv_il, pe_s, pe_i )
!!-------------------------------------------------------------------
!! *** ROUTINE ice_var_roundoff ***
@@ -631,18 +662,23 @@
REAL(wp), DIMENSION(:,:) , INTENT(inout) :: pa_ip ! melt pond fraction
REAL(wp), DIMENSION(:,:) , INTENT(inout) :: pv_ip ! melt pond volume
+ REAL(wp), DIMENSION(:,:) , INTENT(inout) :: pv_il ! melt pond lid volume
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 .AND. pa_i (1:npti,:) > -epsi10 ) pa_i (1:npti,:) = 0._wp ! a_i must be >= 0
- WHERE( pv_i (1:npti,:) < 0._wp .AND. pv_i (1:npti,:) > -epsi10 ) pv_i (1:npti,:) = 0._wp ! v_i must be >= 0
- WHERE( pv_s (1:npti,:) < 0._wp .AND. pv_s (1:npti,:) > -epsi10 ) pv_s (1:npti,:) = 0._wp ! v_s must be >= 0
- WHERE( psv_i(1:npti,:) < 0._wp .AND. psv_i(1:npti,:) > -epsi10 ) psv_i(1:npti,:) = 0._wp ! sv_i must be >= 0
- WHERE( poa_i(1:npti,:) < 0._wp .AND. poa_i(1:npti,:) > -epsi10 ) poa_i(1:npti,:) = 0._wp ! oa_i must be >= 0
- WHERE( pe_i (1:npti,:,:) < 0._wp .AND. pe_i (1:npti,:,:) > -epsi06 ) pe_i (1:npti,:,:) = 0._wp ! e_i must be >= 0
- WHERE( pe_s (1:npti,:,:) < 0._wp .AND. pe_s (1:npti,:,:) > -epsi06 ) pe_s (1:npti,:,:) = 0._wp ! e_s must be >= 0
- IF( ln_pnd_H12 ) THEN
- WHERE( pa_ip(1:npti,:) < 0._wp .AND. pa_ip(1:npti,:) > -epsi10 ) pa_ip(1:npti,:) = 0._wp ! a_ip must be >= 0
- WHERE( pv_ip(1:npti,:) < 0._wp .AND. pv_ip(1:npti,:) > -epsi10 ) pv_ip(1:npti,:) = 0._wp ! v_ip must be >= 0
+
+ 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
+ WHERE( pv_s (1:npti,:) < 0._wp ) pv_s (1:npti,:) = 0._wp ! v_s must be >= 0
+ WHERE( psv_i(1:npti,:) < 0._wp ) psv_i(1:npti,:) = 0._wp ! sv_i must be >= 0
+ WHERE( poa_i(1:npti,:) < 0._wp ) poa_i(1:npti,:) = 0._wp ! oa_i must be >= 0
+ WHERE( pe_i (1:npti,:,:) < 0._wp ) pe_i (1:npti,:,:) = 0._wp ! e_i must be >= 0
+ WHERE( pe_s (1:npti,:,:) < 0._wp ) pe_s (1:npti,:,:) = 0._wp ! e_s must be >= 0
+ IF( ln_pnd_LEV ) THEN
+ WHERE( pa_ip(1:npti,:) < 0._wp ) pa_ip(1:npti,:) = 0._wp ! a_ip must be >= 0
+ WHERE( pv_ip(1:npti,:) < 0._wp ) pv_ip(1:npti,:) = 0._wp ! v_ip must be >= 0
+ IF( ln_pnd_lids ) THEN
+ WHERE( pv_il(1:npti,:) < 0._wp .AND. pv_il(1:npti,:) > -epsi10 ) pv_il(1:npti,:) = 0._wp ! v_il must be >= 0
+ ENDIF
ENDIF
!
@@ -763,6 +799,6 @@
!! ** Purpose : converting N-cat ice to jpl ice categories
!!-------------------------------------------------------------------
- SUBROUTINE ice_var_itd_1c1c( phti, phts, pati , ph_i, ph_s, pa_i, &
- & ptmi, ptms, ptmsu, psmi, patip, phtip, pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip )
+ SUBROUTINE ice_var_itd_1c1c( phti, phts, pati , ph_i, ph_s, pa_i, &
+ & ptmi, ptms, ptmsu, psmi, patip, phtip, phtil, pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip, ph_il )
!!-------------------------------------------------------------------
!! ** Purpose : converting 1-cat ice to 1 ice category
@@ -770,6 +806,6 @@
REAL(wp), DIMENSION(:), INTENT(in) :: phti, phts, pati ! input ice/snow variables
REAL(wp), DIMENSION(:), INTENT(inout) :: ph_i, ph_s, pa_i ! output ice/snow variables
- REAL(wp), DIMENSION(:), INTENT(in) :: ptmi, ptms, ptmsu, psmi, patip, phtip ! input ice/snow temp & sal & ponds
- REAL(wp), DIMENSION(:), INTENT(inout) :: pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip ! output ice/snow temp & sal & ponds
+ REAL(wp), DIMENSION(:), INTENT(in) :: ptmi, ptms, ptmsu, psmi, patip, phtip, phtil ! input ice/snow temp & sal & ponds
+ REAL(wp), DIMENSION(:), INTENT(inout) :: pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip, ph_il ! output ice/snow temp & sal & ponds
!!-------------------------------------------------------------------
! == thickness and concentration == !
@@ -785,9 +821,10 @@
pa_ip(:) = patip(:)
ph_ip(:) = phtip(:)
+ ph_il(:) = phtil(:)
END SUBROUTINE ice_var_itd_1c1c
- SUBROUTINE ice_var_itd_Nc1c( phti, phts, pati , ph_i, ph_s, pa_i, &
- & ptmi, ptms, ptmsu, psmi, patip, phtip, pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip )
+ SUBROUTINE ice_var_itd_Nc1c( phti, phts, pati , ph_i, ph_s, pa_i, &
+ & ptmi, ptms, ptmsu, psmi, patip, phtip, phtil, pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip, ph_il )
!!-------------------------------------------------------------------
!! ** Purpose : converting N-cat ice to 1 ice category
@@ -795,6 +832,6 @@
REAL(wp), DIMENSION(:,:), INTENT(in) :: phti, phts, pati ! input ice/snow variables
REAL(wp), DIMENSION(:) , INTENT(inout) :: ph_i, ph_s, pa_i ! output ice/snow variables
- REAL(wp), DIMENSION(:,:), INTENT(in) :: ptmi, ptms, ptmsu, psmi, patip, phtip ! input ice/snow temp & sal & ponds
- REAL(wp), DIMENSION(:) , INTENT(inout) :: pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip ! output ice/snow temp & sal & ponds
+ REAL(wp), DIMENSION(:,:), INTENT(in) :: ptmi, ptms, ptmsu, psmi, patip, phtip, phtil ! input ice/snow temp & sal & ponds
+ REAL(wp), DIMENSION(:) , INTENT(inout) :: pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip, ph_il ! output ice/snow temp & sal & ponds
!
REAL(wp), ALLOCATABLE, DIMENSION(:) :: z1_ai, z1_vi, z1_vs
@@ -831,6 +868,10 @@
! == ponds == !
pa_ip(:) = SUM( patip(:,:), dim=2 )
- WHERE( pa_ip(:) /= 0._wp ) ; ph_ip(:) = SUM( phtip(:,:) * patip(:,:), dim=2 ) / pa_ip(:)
- ELSEWHERE ; ph_ip(:) = 0._wp
+ WHERE( pa_ip(:) /= 0._wp )
+ ph_ip(:) = SUM( phtip(:,:) * patip(:,:), dim=2 ) / pa_ip(:)
+ ph_il(:) = SUM( phtil(:,:) * patip(:,:), dim=2 ) / pa_ip(:)
+ ELSEWHERE
+ ph_ip(:) = 0._wp
+ ph_il(:) = 0._wp
END WHERE
!
@@ -839,6 +880,6 @@
END SUBROUTINE ice_var_itd_Nc1c
- SUBROUTINE ice_var_itd_1cMc( phti, phts, pati , ph_i, ph_s, pa_i, &
- & ptmi, ptms, ptmsu, psmi, patip, phtip, pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip )
+ SUBROUTINE ice_var_itd_1cMc( phti, phts, pati , ph_i, ph_s, pa_i, &
+ & ptmi, ptms, ptmsu, psmi, patip, phtip, phtil, pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip, ph_il )
!!-------------------------------------------------------------------
!!
@@ -862,6 +903,6 @@
REAL(wp), DIMENSION(:), INTENT(in) :: phti, phts, pati ! input ice/snow variables
REAL(wp), DIMENSION(:,:), INTENT(inout) :: ph_i, ph_s, pa_i ! output ice/snow variables
- REAL(wp), DIMENSION(:) , INTENT(in) :: ptmi, ptms, ptmsu, psmi, patip, phtip ! input ice/snow temp & sal & ponds
- REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip ! output ice/snow temp & sal & ponds
+ REAL(wp), DIMENSION(:) , INTENT(in) :: ptmi, ptms, ptmsu, psmi, patip, phtip, phtil ! input ice/snow temp & sal & ponds
+ REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip, ph_il ! output ice/snow temp & sal & ponds
!
REAL(wp), ALLOCATABLE, DIMENSION(:) :: zfra, z1_hti
@@ -953,5 +994,4 @@
pt_su(:,jl) = ptmsu(:)
ps_i (:,jl) = psmi (:)
- ps_i (:,jl) = psmi (:)
END DO
!
@@ -974,10 +1014,19 @@
END WHERE
END DO
+ ! keep the same v_il/v_i ratio for each category
+ WHERE( ( phti(:) * pati(:) ) /= 0._wp ) ; zfra(:) = ( phtil(:) * patip(:) ) / ( phti(:) * pati(:) )
+ ELSEWHERE ; zfra(:) = 0._wp
+ END WHERE
+ DO jl = 1, jpl
+ WHERE( pa_ip(:,jl) /= 0._wp ) ; ph_il(:,jl) = zfra(:) * ( ph_i(:,jl) * pa_i(:,jl) ) / pa_ip(:,jl)
+ ELSEWHERE ; ph_il(:,jl) = 0._wp
+ END WHERE
+ END DO
DEALLOCATE( zfra )
!
END SUBROUTINE ice_var_itd_1cMc
- SUBROUTINE ice_var_itd_NcMc( phti, phts, pati , ph_i, ph_s, pa_i, &
- & ptmi, ptms, ptmsu, psmi, patip, phtip, pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip )
+ SUBROUTINE ice_var_itd_NcMc( phti, phts, pati , ph_i, ph_s, pa_i, &
+ & ptmi, ptms, ptmsu, psmi, patip, phtip, phtil, pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip, ph_il )
!!-------------------------------------------------------------------
!!
@@ -994,5 +1043,5 @@
!!
!! 2) Expand the filling to the cat jlmin-1 and jlmax+1
- !! by removing 25% ice area from jlmin and jlmax (resp.)
+ !! by removing 25% ice area from jlmin and jlmax (resp.)
!!
!! 3) Expand the filling to the empty cat between jlmin and jlmax
@@ -1010,6 +1059,6 @@
REAL(wp), DIMENSION(:,:), INTENT(in) :: phti, phts, pati ! input ice/snow variables
REAL(wp), DIMENSION(:,:), INTENT(inout) :: ph_i, ph_s, pa_i ! output ice/snow variables
- REAL(wp), DIMENSION(:,:), INTENT(in) :: ptmi, ptms, ptmsu, psmi, patip, phtip ! input ice/snow temp & sal & ponds
- REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip ! output ice/snow temp & sal & ponds
+ REAL(wp), DIMENSION(:,:), INTENT(in) :: ptmi, ptms, ptmsu, psmi, patip, phtip, phtil ! input ice/snow temp & sal & ponds
+ REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip, ph_il ! output ice/snow temp & sal & ponds
!
INTEGER , ALLOCATABLE, DIMENSION(:,:) :: jlfil, jlfil2
@@ -1040,4 +1089,5 @@
pa_ip(:,:) = patip(:,:)
ph_ip(:,:) = phtip(:,:)
+ ph_il(:,:) = phtil(:,:)
! ! ---------------------- !
ELSEIF( icat == 1 ) THEN ! input cat = 1 !
@@ -1045,6 +1095,6 @@
CALL ice_var_itd_1cMc( phti(:,1), phts(:,1), pati (:,1), &
& ph_i(:,:), ph_s(:,:), pa_i (:,:), &
- & ptmi(:,1), ptms(:,1), ptmsu(:,1), psmi(:,1), patip(:,1), phtip(:,1), &
- & pt_i(:,:), pt_s(:,:), pt_su(:,:), ps_i(:,:), pa_ip(:,:), ph_ip(:,:) )
+ & ptmi(:,1), ptms(:,1), ptmsu(:,1), psmi(:,1), patip(:,1), phtip(:,1), phtil(:,1), &
+ & pt_i(:,:), pt_s(:,:), pt_su(:,:), ps_i(:,:), pa_ip(:,:), ph_ip(:,:), ph_il(:,:) )
! ! ---------------------- !
ELSEIF( jpl == 1 ) THEN ! output cat = 1 !
@@ -1052,6 +1102,6 @@
CALL ice_var_itd_Nc1c( phti(:,:), phts(:,:), pati (:,:), &
& ph_i(:,1), ph_s(:,1), pa_i (:,1), &
- & ptmi(:,:), ptms(:,:), ptmsu(:,:), psmi(:,:), patip(:,:), phtip(:,:), &
- & pt_i(:,1), pt_s(:,1), pt_su(:,1), ps_i(:,1), pa_ip(:,1), ph_ip(:,1) )
+ & ptmi(:,:), ptms(:,:), ptmsu(:,:), psmi(:,:), patip(:,:), phtip(:,:), phtil(:,:), &
+ & pt_i(:,1), pt_s(:,1), pt_su(:,1), ps_i(:,1), pa_ip(:,1), ph_ip(:,1), ph_il(:,1) )
! ! ----------------------- !
ELSE ! input cat /= output cat !
@@ -1195,4 +1245,15 @@
END WHERE
END DO
+ ! keep the same v_il/v_i ratio for each category
+ WHERE( SUM( phti(:,:) * pati(:,:), dim=2 ) /= 0._wp )
+ zfra(:) = SUM( phtil(:,:) * patip(:,:), dim=2 ) / SUM( phti(:,:) * pati(:,:), dim=2 )
+ ELSEWHERE
+ zfra(:) = 0._wp
+ END WHERE
+ DO jl = 1, jpl
+ WHERE( pa_ip(:,jl) /= 0._wp ) ; ph_il(:,jl) = zfra(:) * ( ph_i(:,jl) * pa_i(:,jl) ) / pa_ip(:,jl)
+ ELSEWHERE ; ph_il(:,jl) = 0._wp
+ END WHERE
+ END DO
DEALLOCATE( zfra )
!
@@ -1200,4 +1261,88 @@
!
END SUBROUTINE ice_var_itd_NcMc
+
+ !!-------------------------------------------------------------------
+ !! INTERFACE ice_var_snwfra
+ !!
+ !! ** Purpose : fraction of ice covered by snow
+ !!
+ !! ** Method : In absence of proper snow model on top of sea ice,
+ !! we argue that snow does not cover the whole ice because
+ !! of wind blowing...
+ !!
+ !! ** Arguments : ph_s: snow thickness
+ !!
+ !! ** Output : pa_s_fra: fraction of ice covered by snow
+ !!
+ !!-------------------------------------------------------------------
+ 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
+ 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
+ END WHERE
+ ELSEIF( nn_snwfra == 1 ) THEN ! snow cover depends on hsnow (met-office style)
+ pa_s_fra = 1._wp - EXP( -0.2_wp * rhos * ph_s )
+ ELSEIF( nn_snwfra == 2 ) THEN ! snow cover depends on hsnow (cice style)
+ pa_s_fra = ph_s / ( ph_s + 0.02_wp )
+ ENDIF
+ END SUBROUTINE ice_var_snwfra_3d
+
+ SUBROUTINE ice_var_snwfra_2d( 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
+ 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
+ END WHERE
+ ELSEIF( nn_snwfra == 1 ) THEN ! snow cover depends on hsnow (met-office style)
+ pa_s_fra = 1._wp - EXP( -0.2_wp * rhos * ph_s )
+ ELSEIF( nn_snwfra == 2 ) THEN ! snow cover depends on hsnow (cice style)
+ pa_s_fra = ph_s / ( ph_s + 0.02_wp )
+ ENDIF
+ END SUBROUTINE ice_var_snwfra_2d
+
+ SUBROUTINE ice_var_snwfra_1d( 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
+ 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
+ END WHERE
+ ELSEIF( nn_snwfra == 1 ) THEN ! snow cover depends on hsnow (met-office style)
+ pa_s_fra = 1._wp - EXP( -0.2_wp * rhos * ph_s )
+ ELSEIF( nn_snwfra == 2 ) THEN ! snow cover depends on hsnow (cice style)
+ pa_s_fra = ph_s / ( ph_s + 0.02_wp )
+ ENDIF
+ END SUBROUTINE ice_var_snwfra_1d
+
+ !!--------------------------------------------------------------------------
+ !! INTERFACE ice_var_snwblow
+ !!
+ !! ** Purpose : Compute distribution of precip over the ice
+ !!
+ !! Snow accumulation in one thermodynamic time step
+ !! snowfall is partitionned between leads and ice.
+ !! If snow fall was uniform, a fraction (1-at_i) would fall into leads
+ !! but because of the winds, more snow falls on leads than on sea ice
+ !! and a greater fraction (1-at_i)^beta of the total mass of snow
+ !! (beta < 1) falls in leads.
+ !! In reality, beta depends on wind speed,
+ !! and should decrease with increasing wind speed but here, it is
+ !! considered as a constant. an average value is 0.66
+ !!--------------------------------------------------------------------------
+!!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
+ pout = ( 1._wp - ( pin )**rn_snwblow )
+ END SUBROUTINE ice_var_snwblow_2d
+
+ SUBROUTINE ice_var_snwblow_1d( pin, pout )
+ REAL(wp), DIMENSION(:), INTENT(in ) :: pin
+ REAL(wp), DIMENSION(:), INTENT(inout) :: pout
+ pout = ( 1._wp - ( pin )**rn_snwblow )
+ END SUBROUTINE ice_var_snwblow_1d
#else
Index: /NEMO/branches/2020/r12377_ticket2386/src/ICE/icewri.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/ICE/icewri.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/ICE/icewri.F90 (revision 13540)
@@ -71,5 +71,5 @@
! tresholds for outputs
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
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
@@ -78,5 +78,5 @@
END_2D
DO jl = 1, jpl
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
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 ) )
@@ -114,4 +114,6 @@
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
! salt
IF( iom_use('icesalt' ) ) CALL iom_put( 'icesalt', sm_i * zmsk00 + zmiss_val * ( 1._wp - zmsk00 ) ) ! mean ice salinity
@@ -130,10 +132,10 @@
!
IF( iom_use('icevel') .OR. iom_use('fasticepres') ) THEN ! module of ice velocity
- DO_2D_00_00
+ 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. )
+ CALL lbc_lnk( 'icewri', z2d, 'T', 1.0_wp )
CALL iom_put( 'icevel', z2d )
@@ -158,6 +160,8 @@
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('icehpnd_cat' ) ) CALL iom_put( 'icehpnd_cat' , h_ip * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! melt pond frac 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 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
@@ -173,4 +177,5 @@
IF( iom_use('dmisum') ) CALL iom_put( 'dmisum', - wfx_sum ) ! Sea-ice mass change through surface melting
IF( iom_use('dmibom') ) CALL iom_put( 'dmibom', - wfx_bom ) ! Sea-ice mass change through bottom melting
+ IF( iom_use('dmilam') ) CALL iom_put( 'dmilam', - wfx_lam ) ! Sea-ice mass change through lateral melting
IF( iom_use('dmtsub') ) CALL iom_put( 'dmtsub', - wfx_sub ) ! Sea-ice mass change through evaporation and sublimation
IF( iom_use('dmssub') ) CALL iom_put( 'dmssub', - wfx_snw_sub ) ! Snow mass change through sublimation
Index: /NEMO/branches/2020/r12377_ticket2386/src/NST/agrif_ice.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/NST/agrif_ice.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/NST/agrif_ice.F90 (revision 13540)
@@ -16,4 +16,5 @@
INTEGER, PUBLIC :: u_ice_id, v_ice_id, tra_ice_id
+ INTEGER, PUBLIC :: u_iceini_id, v_iceini_id, tra_iceini_id
INTEGER, PUBLIC :: nbstep_ice = 0 ! child time position in sea-ice model
Index: /NEMO/branches/2020/r12377_ticket2386/src/NST/agrif_ice_interp.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/NST/agrif_ice_interp.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/NST/agrif_ice_interp.F90 (revision 13540)
@@ -14,7 +14,7 @@
!!----------------------------------------------------------------------
!! agrif_interp_ice : interpolation of ice at "after" sea-ice time step
- !! agrif_interp_u_ice : atomic routine to interpolate u_ice
- !! agrif_interp_v_ice : atomic routine to interpolate v_ice
- !! agrif_interp_tra_ice : atomic routine to interpolate ice properties
+ !! interp_u_ice : atomic routine to interpolate u_ice
+ !! interp_v_ice : atomic routine to interpolate v_ice
+ !! interp_tra_ice : atomic routine to interpolate ice properties
!!----------------------------------------------------------------------
USE par_oce
@@ -23,4 +23,5 @@
USE ice
USE agrif_ice
+ USE agrif_oce
USE phycst , ONLY: rt0
@@ -29,4 +30,5 @@
PUBLIC agrif_interp_ice ! called by agrif_user.F90
+ PUBLIC interp_tra_ice, interp_u_ice, interp_v_ice ! called by iceistate.F90
!!----------------------------------------------------------------------
@@ -68,4 +70,9 @@
Agrif_SpecialValue = -9999.
Agrif_UseSpecialValue = .TRUE.
+
+ use_sign_north = .TRUE.
+ sign_north = -1.
+ if (cd_type == 'T') use_sign_north = .FALSE.
+
SELECT CASE( cd_type )
CASE('U') ; CALL Agrif_Bc_variable( u_ice_id , procname=interp_u_ice , calledweight=zbeta )
@@ -75,4 +82,6 @@
Agrif_SpecialValue = 0._wp
Agrif_UseSpecialValue = .FALSE.
+
+ use_sign_north = .FALSE.
!
END SUBROUTINE agrif_interp_ice
@@ -156,5 +165,5 @@
! and it is ok since we conserve tracers (same as in the ocean).
ALLOCATE( ztab(SIZE(a_i,1),SIZE(a_i,2),SIZE(ptab,3)) )
-
+
IF( before ) THEN ! parent grid
jm = 1
@@ -167,6 +176,7 @@
ptab(i1:i2,j1:j2,jm+5) = a_ip(i1:i2,j1:j2,jl)
ptab(i1:i2,j1:j2,jm+6) = v_ip(i1:i2,j1:j2,jl)
- ptab(i1:i2,j1:j2,jm+7) = t_su(i1:i2,j1:j2,jl)
- jm = jm + 8
+ ptab(i1:i2,j1:j2,jm+7) = v_il(i1:i2,j1:j2,jl)
+ ptab(i1:i2,j1:j2,jm+8) = t_su(i1:i2,j1:j2,jl)
+ jm = jm + 9
DO jk = 1, nlay_s
ptab(i1:i2,j1:j2,jm) = e_s(i1:i2,j1:j2,jk,jl) ; jm = jm + 1
@@ -197,8 +207,9 @@
a_ip(ji,jj,jl) = ptab(ji,jj,jm+5) * tmask(ji,jj,1)
v_ip(ji,jj,jl) = ptab(ji,jj,jm+6) * tmask(ji,jj,1)
- t_su(ji,jj,jl) = ptab(ji,jj,jm+7) * tmask(ji,jj,1)
+ v_il(ji,jj,jl) = ptab(ji,jj,jm+7) * tmask(ji,jj,1)
+ t_su(ji,jj,jl) = ptab(ji,jj,jm+8) * tmask(ji,jj,1)
END DO
END DO
- jm = jm + 8
+ jm = jm + 9
!
DO jk = 1, nlay_s
@@ -230,6 +241,7 @@
! ztab(:,:,jm+5) = a_ip(:,:,jl)
! ztab(:,:,jm+6) = v_ip(:,:,jl)
-! ztab(:,:,jm+7) = t_su(:,:,jl)
-! jm = jm + 8
+! ztab(:,:,jm+7) = v_il(:,:,jl)
+! ztab(:,:,jm+8) = t_su(:,:,jl)
+! jm = jm + 9
! DO jk = 1, nlay_s
! ztab(:,:,jm) = e_s(:,:,jk,jl)
@@ -260,32 +272,32 @@
! imin = i1 ; imax = i2 ; jmin = j1 ; jmax = j2
! IF( (nbondj == -1) .OR. (nbondj == 2) ) jmin = 3
-! IF( (nbondj == +1) .OR. (nbondj == 2) ) jmax = nlcj-2
+! IF( (nbondj == +1) .OR. (nbondj == 2) ) jmax = jpj-2
! IF( (nbondi == -1) .OR. (nbondi == 2) ) imin = 3
-! IF( (nbondi == +1) .OR. (nbondi == 2) ) imax = nlci-2
+! IF( (nbondi == +1) .OR. (nbondi == 2) ) imax = jpi-2
!
! ! smoothed fields
! IF( eastern_side ) THEN
-! ztab(nlci,j1:j2,:) = z1 * ptab(nlci,j1:j2,:) + z2 * ptab(nlci-1,j1:j2,:)
+! ztab(jpi,j1:j2,:) = z1 * ptab(jpi,j1:j2,:) + z2 * ptab(jpi-1,j1:j2,:)
! DO jj = jmin, jmax
! rswitch = 0.
-! IF( u_ice(nlci-2,jj) > 0._wp ) rswitch = 1.
-! ztab(nlci-1,jj,:) = ( 1. - umask(nlci-2,jj,1) ) * ztab(nlci,jj,:) &
-! & + umask(nlci-2,jj,1) * &
-! & ( ( 1. - rswitch ) * ( z4 * ztab(nlci,jj,:) + z3 * ztab(nlci-2,jj,:) ) &
-! & + rswitch * ( z6 * ztab(nlci-2,jj,:) + z5 * ztab(nlci,jj,:) + z7 * ztab(nlci-3,jj,:) ) )
-! ztab(nlci-1,jj,:) = ztab(nlci-1,jj,:) * tmask(nlci-1,jj,1)
+! IF( u_ice(jpi-2,jj) > 0._wp ) rswitch = 1.
+! ztab(jpi-1,jj,:) = ( 1. - umask(jpi-2,jj,1) ) * ztab(jpi,jj,:) &
+! & + umask(jpi-2,jj,1) * &
+! & ( (1. - rswitch) * ( z4 * ztab(jpi ,jj,:) + z3 * ztab(jpi-2,jj,:) ) &
+! & + rswitch * ( z6 * ztab(jpi-2,jj,:) + z5 * ztab(jpi ,jj,:) + z7 * ztab(jpi-3,jj,:) ) )
+! ztab(jpi-1,jj,:) = ztab(jpi-1,jj,:) * tmask(jpi-1,jj,1)
! END DO
! ENDIF
! !
! IF( northern_side ) THEN
-! ztab(i1:i2,nlcj,:) = z1 * ptab(i1:i2,nlcj,:) + z2 * ptab(i1:i2,nlcj-1,:)
+! ztab(i1:i2,jpj,:) = z1 * ptab(i1:i2,jpj,:) + z2 * ptab(i1:i2,jpj-1,:)
! DO ji = imin, imax
! rswitch = 0.
-! IF( v_ice(ji,nlcj-2) > 0._wp ) rswitch = 1.
-! ztab(ji,nlcj-1,:) = ( 1. - vmask(ji,nlcj-2,1) ) * ztab(ji,nlcj,:) &
-! & + vmask(ji,nlcj-2,1) * &
-! & ( ( 1. - rswitch ) * ( z4 * ztab(ji,nlcj,:) + z3 * ztab(ji,nlcj-2,:) ) &
-! & + rswitch * ( z6 * ztab(ji,nlcj-2,:) + z5 * ztab(ji,nlcj,:) + z7 * ztab(ji,nlcj-3,:) ) )
-! ztab(ji,nlcj-1,:) = ztab(ji,nlcj-1,:) * tmask(ji,nlcj-1,1)
+! IF( v_ice(ji,jpj-2) > 0._wp ) rswitch = 1.
+! ztab(ji,jpj-1,:) = ( 1. - vmask(ji,jpj-2,1) ) * ztab(ji,jpj,:) &
+! & + vmask(ji,jpj-2,1) * &
+! & ( (1. - rswitch) * ( z4 * ztab(ji,jpj ,:) + z3 * ztab(ji,jpj-2,:) ) &
+! & + rswitch * ( z6 * ztab(ji,jpj-2,:) + z5 * ztab(ji,jpj ,:) + z7 * ztab(ji,jpj-3,:) ) )
+! ztab(ji,jpj-1,:) = ztab(ji,jpj-1,:) * tmask(ji,jpj-1,1)
! END DO
! END IF
@@ -318,8 +330,8 @@
! !
! ! Treatment of corners
-! IF( (eastern_side) .AND. ((nbondj == -1).OR.(nbondj == 2)) ) ztab(nlci-1,2,:) = ptab(nlci-1,2,:) ! East south
-! IF( (eastern_side) .AND. ((nbondj == 1).OR.(nbondj == 2)) ) ztab(nlci-1,nlcj-1,:) = ptab(nlci-1,nlcj-1,:) ! East north
-! IF( (western_side) .AND. ((nbondj == -1).OR.(nbondj == 2)) ) ztab(2,2,:) = ptab(2,2,:) ! West south
-! IF( (western_side) .AND. ((nbondj == 1).OR.(nbondj == 2)) ) ztab(2,nlcj-1,:) = ptab(2,nlcj-1,:) ! West north
+! IF( (eastern_side) .AND. ((nbondj == -1).OR.(nbondj == 2)) ) ztab(jpi-1,2 ,:) = ptab(jpi-1, 2,:) ! East south
+! IF( (eastern_side) .AND. ((nbondj == 1).OR.(nbondj == 2)) ) ztab(jpi-1,jpj-1,:) = ptab(jpi-1,jpj-1,:) ! East north
+! IF( (western_side) .AND. ((nbondj == -1).OR.(nbondj == 2)) ) ztab( 2, 2,:) = ptab( 2, 2,:) ! West south
+! IF( (western_side) .AND. ((nbondj == 1).OR.(nbondj == 2)) ) ztab( 2,jpj-1,:) = ptab( 2,jpj-1,:) ! West north
!
! ! retrieve ice tracers
@@ -336,8 +348,9 @@
! a_ip(ji,jj,jl) = ztab(ji,jj,jm+5) * tmask(ji,jj,1)
! v_ip(ji,jj,jl) = ztab(ji,jj,jm+6) * tmask(ji,jj,1)
-! t_su(ji,jj,jl) = ztab(ji,jj,jm+7) * tmask(ji,jj,1)
+! v_il(ji,jj,jl) = ztab(ji,jj,jm+7) * tmask(ji,jj,1)
+! t_su(ji,jj,jl) = ztab(ji,jj,jm+8) * tmask(ji,jj,1)
! END DO
! END DO
-! jm = jm + 8
+! jm = jm + 9
! !
! DO jk = 1, nlay_s
Index: /NEMO/branches/2020/r12377_ticket2386/src/NST/agrif_ice_update.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/NST/agrif_ice_update.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/NST/agrif_ice_update.F90 (revision 13540)
@@ -66,4 +66,7 @@
CALL Agrif_Update_Variable( tra_ice_id , locupdate=(/1,0/), procname = update_tra_ice )
#endif
+ use_sign_north = .TRUE.
+ sign_north = -1.
+
# if ! defined DECAL_FEEDBACK
CALL Agrif_Update_Variable( u_ice_id , procname = update_u_ice )
@@ -73,4 +76,5 @@
CALL Agrif_Update_Variable( v_ice_id , locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname=update_v_ice)
#endif
+ use_sign_north = .FALSE.
! CALL Agrif_Update_Variable( tra_ice_id , locupdate=(/0,2/), procname = update_tra_ice )
! CALL Agrif_Update_Variable( u_ice_id , locupdate=(/0,1/), procname = update_u_ice )
@@ -105,6 +109,7 @@
ptab(i1:i2,j1:j2,jm+5) = a_ip(i1:i2,j1:j2,jl)
ptab(i1:i2,j1:j2,jm+6) = v_ip(i1:i2,j1:j2,jl)
- ptab(i1:i2,j1:j2,jm+7) = t_su(i1:i2,j1:j2,jl)
- jm = jm + 8
+ ptab(i1:i2,j1:j2,jm+7) = v_il(i1:i2,j1:j2,jl)
+ ptab(i1:i2,j1:j2,jm+8) = t_su(i1:i2,j1:j2,jl)
+ jm = jm + 9
DO jk = 1, nlay_s
ptab(i1:i2,j1:j2,jm) = e_s(i1:i2,j1:j2,jk,jl) ; jm = jm + 1
@@ -134,9 +139,10 @@
a_ip(ji,jj,jl) = ptab(ji,jj,jm+5) * tmask(ji,jj,1)
v_ip(ji,jj,jl) = ptab(ji,jj,jm+6) * tmask(ji,jj,1)
- t_su(ji,jj,jl) = ptab(ji,jj,jm+7) * tmask(ji,jj,1)
+ v_il(ji,jj,jl) = ptab(ji,jj,jm+7) * tmask(ji,jj,1)
+ t_su(ji,jj,jl) = ptab(ji,jj,jm+8) * tmask(ji,jj,1)
ENDIF
END DO
END DO
- jm = jm + 8
+ jm = jm + 9
!
DO jk = 1, nlay_s
Index: /NEMO/branches/2020/r12377_ticket2386/src/NST/agrif_oce.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/NST/agrif_oce.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/NST/agrif_oce.F90 (revision 13540)
@@ -19,4 +19,5 @@
! !!* Namelist namagrif: AGRIF parameters
+ LOGICAL , PUBLIC :: ln_init_chfrpar = .FALSE. !: set child grids initial state from parent
LOGICAL , PUBLIC :: ln_agrif_2way = .TRUE. !: activate two way nesting
LOGICAL , PUBLIC :: ln_spc_dyn = .FALSE. !: use zeros (.false.) or not (.true.) in
@@ -29,4 +30,5 @@
!
INTEGER , PUBLIC, PARAMETER :: nn_sponge_len = 2 !: Sponge width (in number of parent grid points)
+
LOGICAL , PUBLIC :: spongedoneT = .FALSE. !: tracer sponge layer indicator
LOGICAL , PUBLIC :: spongedoneU = .FALSE. !: dynamics sponge layer indicator
@@ -49,8 +51,6 @@
INTEGER , PUBLIC, SAVE :: Kbb_a, Kmm_a, Krhs_a !: AGRIF module-specific copies of time-level indices
-# if defined key_vertical
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ht0_parent, hu0_parent, hv0_parent
INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mbkt_parent, mbku_parent, mbkv_parent
-# endif
INTEGER, PUBLIC :: tsn_id ! AGRIF profile for tracers interpolation and update
@@ -58,4 +58,5 @@
INTEGER, PUBLIC :: un_update_id, vn_update_id ! AGRIF profiles for udpates
INTEGER, PUBLIC :: tsn_sponge_id, un_sponge_id, vn_sponge_id ! AGRIF profiles for sponge layers
+ INTEGER, PUBLIC :: tsini_id, uini_id, vini_id, sshini_id ! AGRIF profile for initialization
# if defined key_top
INTEGER, PUBLIC :: trn_id, trn_sponge_id
@@ -67,5 +68,18 @@
INTEGER, PUBLIC :: avt_id, avm_id, en_id ! TKE related identificators
INTEGER, PUBLIC :: mbkt_id, ht0_id
+ INTEGER, PUBLIC :: glamt_id, gphit_id
INTEGER, PUBLIC :: kindic_agr
+
+ ! North fold
+!$AGRIF_DO_NOT_TREAT
+ LOGICAL, PUBLIC :: use_sign_north
+ REAL, PUBLIC :: sign_north
+ LOGICAL, PUBLIC :: l_ini_child = .FALSE.
+# if defined key_vertical
+ LOGICAL, PUBLIC :: l_vremap = .TRUE.
+# else
+ LOGICAL, PUBLIC :: l_vremap = .FALSE.
+# endif
+!$AGRIF_END_DO_NOT_TREAT
!!----------------------------------------------------------------------
@@ -91,9 +105,7 @@
& tabspongedone_trn(jpi,jpj), &
# endif
-# if defined key_vertical
& ht0_parent(jpi,jpj), mbkt_parent(jpi,jpj), &
& hu0_parent(jpi,jpj), mbku_parent(jpi,jpj), &
& hv0_parent(jpi,jpj), mbkv_parent(jpi,jpj), &
-# endif
& tabspongedone_u (jpi,jpj), &
& tabspongedone_v (jpi,jpj), STAT = ierr(1) )
Index: /NEMO/branches/2020/r12377_ticket2386/src/NST/agrif_oce_interp.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/NST/agrif_oce_interp.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/NST/agrif_oce_interp.F90 (revision 13540)
@@ -34,4 +34,5 @@
USE lib_mpp
USE vremap
+ USE lbclnk
IMPLICIT NONE
@@ -43,8 +44,8 @@
PUBLIC interptsn, interpsshn, interpavm
PUBLIC interpunb, interpvnb , interpub2b, interpvb2b
- PUBLIC interpe3t
-#if defined key_vertical
+ PUBLIC interpe3t, interpglamt, interpgphit
PUBLIC interpht0, interpmbkt
-# endif
+ PUBLIC agrif_initts, agrif_initssh
+
INTEGER :: bdy_tinterp = 0
@@ -86,254 +87,245 @@
IF( Agrif_Root() ) RETURN
!
- Agrif_SpecialValue = 0._wp
+ Agrif_SpecialValue = 0.0_wp
Agrif_UseSpecialValue = ln_spc_dyn
!
+ use_sign_north = .TRUE.
+ sign_north = -1.0_wp
CALL Agrif_Bc_variable( un_interp_id, procname=interpun )
CALL Agrif_Bc_variable( vn_interp_id, procname=interpvn )
+ use_sign_north = .FALSE.
!
Agrif_UseSpecialValue = .FALSE.
!
! --- West --- !
- ibdy1 = 2
- ibdy2 = 1+nbghostcells
- !
- IF( .NOT.ln_dynspg_ts ) THEN ! Store transport
+ IF( lk_west ) THEN
+ ibdy1 = nn_hls + 2 ! halo + land + 1
+ ibdy2 = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells
+ !
+ IF( .NOT.ln_dynspg_ts ) THEN ! Store transport
+ DO ji = mi0(ibdy1), mi1(ibdy2)
+ uu_b(ji,:,Krhs_a) = 0._wp
+ DO jk = 1, jpkm1
+ DO jj = 1, jpj
+ uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
+ END DO
+ END DO
+ DO jj = 1, jpj
+ uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) * r1_hu(ji,jj,Krhs_a)
+ END DO
+ END DO
+ ENDIF
+ !
DO ji = mi0(ibdy1), mi1(ibdy2)
- uu_b(ji,:,Krhs_a) = 0._wp
-
+ zub(ji,:) = 0._wp ! Correct transport
DO jk = 1, jpkm1
DO jj = 1, jpj
- uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
- END DO
- END DO
-
- DO jj = 1, jpj
- uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) * r1_hu(ji,jj,Krhs_a)
- END DO
- END DO
- ENDIF
- !
- DO ji = mi0(ibdy1), mi1(ibdy2)
- zub(ji,:) = 0._wp ! Correct transport
- DO jk = 1, jpkm1
- DO jj = 1, jpj
- zub(ji,jj) = zub(ji,jj) &
- & + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a)*umask(ji,jj,jk)
- END DO
- END DO
- DO jj=1,jpj
- zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a)
- END DO
-
- DO jk = 1, jpkm1
- DO jj = 1, jpj
- uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) + uu_b(ji,jj,Krhs_a)-zub(ji,jj)) * umask(ji,jj,jk)
- END DO
- END DO
- END DO
-
- IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate
- DO ji = mi0(ibdy1), mi1(ibdy2)
- zvb(ji,:) = 0._wp
+ zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
+ END DO
+ END DO
+ DO jj=1,jpj
+ zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a)
+ END DO
DO jk = 1, jpkm1
DO jj = 1, jpj
- zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
- END DO
- END DO
- DO jj = 1, jpj
- zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a)
- END DO
+ uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) + uu_b(ji,jj,Krhs_a) - zub(ji,jj) ) * umask(ji,jj,jk)
+ END DO
+ END DO
+ END DO
+ !
+ IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate
+ DO ji = mi0(ibdy1), mi1(ibdy2)
+ zvb(ji,:) = 0._wp
+ DO jk = 1, jpkm1
+ DO jj = 1, jpj
+ zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
+ END DO
+ END DO
+ DO jj = 1, jpj
+ zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a)
+ END DO
+ DO jk = 1, jpkm1
+ DO jj = 1, jpj
+ vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) + vv_b(ji,jj,Krhs_a) - zvb(ji,jj) )*vmask(ji,jj,jk)
+ END DO
+ END DO
+ END DO
+ ENDIF
+ !
+ ENDIF
+
+ ! --- East --- !
+ IF( lk_east) THEN
+ ibdy1 = jpiglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells
+ ibdy2 = jpiglo - ( nn_hls + 2 ) ! halo + land + 1
+ !
+ IF( .NOT.ln_dynspg_ts ) THEN ! Store transport
+ DO ji = mi0(ibdy1), mi1(ibdy2)
+ uu_b(ji,:,Krhs_a) = 0._wp
+ DO jk = 1, jpkm1
+ DO jj = 1, jpj
+ uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
+ END DO
+ END DO
+ DO jj = 1, jpj
+ uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) * r1_hu(ji,jj,Krhs_a)
+ END DO
+ END DO
+ ENDIF
+ !
+ DO ji = mi0(ibdy1), mi1(ibdy2)
+ zub(ji,:) = 0._wp ! Correct transport
DO jk = 1, jpkm1
DO jj = 1, jpj
- vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) + vv_b(ji,jj,Krhs_a)-zvb(ji,jj))*vmask(ji,jj,jk)
- END DO
- END DO
- END DO
- ENDIF
-
- ! --- East --- !
- ibdy1 = jpiglo-1-nbghostcells
- ibdy2 = jpiglo-2
- !
- IF( .NOT.ln_dynspg_ts ) THEN ! Store transport
- DO ji = mi0(ibdy1), mi1(ibdy2)
- uu_b(ji,:,Krhs_a) = 0._wp
+ zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
+ END DO
+ END DO
+ DO jj=1,jpj
+ zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a)
+ END DO
DO jk = 1, jpkm1
DO jj = 1, jpj
- uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) &
- & + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
- END DO
- END DO
- DO jj = 1, jpj
- uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) * r1_hu(ji,jj,Krhs_a)
- END DO
- END DO
- ENDIF
- !
- DO ji = mi0(ibdy1), mi1(ibdy2)
- zub(ji,:) = 0._wp ! Correct transport
- DO jk = 1, jpkm1
- DO jj = 1, jpj
- zub(ji,jj) = zub(ji,jj) &
- & + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
- END DO
- END DO
- DO jj=1,jpj
- zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a)
- END DO
-
- DO jk = 1, jpkm1
- DO jj = 1, jpj
- uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) &
- & + uu_b(ji,jj,Krhs_a)-zub(ji,jj))*umask(ji,jj,jk)
- END DO
- END DO
- END DO
-
- IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate
- ibdy1 = jpiglo-nbghostcells
- ibdy2 = jpiglo-1
- DO ji = mi0(ibdy1), mi1(ibdy2)
- zvb(ji,:) = 0._wp
- DO jk = 1, jpkm1
+ uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) + uu_b(ji,jj,Krhs_a) - zub(ji,jj) ) * umask(ji,jj,jk)
+ END DO
+ END DO
+ END DO
+ !
+ IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate
+ ibdy1 = jpiglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1
+ ibdy2 = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
+ DO ji = mi0(ibdy1), mi1(ibdy2)
+ zvb(ji,:) = 0._wp
+ DO jk = 1, jpkm1
+ DO jj = 1, jpj
+ zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
+ END DO
+ END DO
DO jj = 1, jpj
- zvb(ji,jj) = zvb(ji,jj) &
- & + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
- END DO
- END DO
- DO jj = 1, jpj
+ zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a)
+ END DO
+ DO jk = 1, jpkm1
+ DO jj = 1, jpj
+ vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) + vv_b(ji,jj,Krhs_a) - zvb(ji,jj) ) * vmask(ji,jj,jk)
+ END DO
+ END DO
+ END DO
+ ENDIF
+ !
+ ENDIF
+
+ ! --- South --- !
+ IF( lk_south ) THEN
+ jbdy1 = nn_hls + 2 ! halo + land + 1
+ jbdy2 = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells
+ !
+ IF( .NOT.ln_dynspg_ts ) THEN ! Store transport
+ DO jj = mj0(jbdy1), mj1(jbdy2)
+ vv_b(:,jj,Krhs_a) = 0._wp
+ DO jk = 1, jpkm1
+ DO ji = 1, jpi
+ vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
+ END DO
+ END DO
+ DO ji=1,jpi
+ vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) * r1_hv(ji,jj,Krhs_a)
+ END DO
+ END DO
+ ENDIF
+ !
+ DO jj = mj0(jbdy1), mj1(jbdy2)
+ zvb(:,jj) = 0._wp ! Correct transport
+ DO jk=1,jpkm1
+ DO ji=1,jpi
+ zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
+ END DO
+ END DO
+ DO ji = 1, jpi
zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a)
END DO
- DO jk = 1, jpkm1
- DO jj = 1, jpj
- vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) &
- & + vv_b(ji,jj,Krhs_a)-zvb(ji,jj)) * vmask(ji,jj,jk)
- END DO
- END DO
- END DO
- ENDIF
-
- ! --- South --- !
- jbdy1 = 2
- jbdy2 = 1+nbghostcells
- !
- IF( .NOT.ln_dynspg_ts ) THEN ! Store transport
- DO jj = mj0(jbdy1), mj1(jbdy2)
- vv_b(:,jj,Krhs_a) = 0._wp
DO jk = 1, jpkm1
DO ji = 1, jpi
- vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) &
- & + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
- END DO
- END DO
- DO ji=1,jpi
- vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) * r1_hv(ji,jj,Krhs_a)
- END DO
- END DO
- ENDIF
- !
- DO jj = mj0(jbdy1), mj1(jbdy2)
- zvb(:,jj) = 0._wp ! Correct transport
- DO jk=1,jpkm1
- DO ji=1,jpi
- zvb(ji,jj) = zvb(ji,jj) &
- & + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
- END DO
- END DO
- DO ji = 1, jpi
- zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a)
- END DO
-
- DO jk = 1, jpkm1
+ vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) + vv_b(ji,jj,Krhs_a) - zvb(ji,jj) ) * vmask(ji,jj,jk)
+ END DO
+ END DO
+ END DO
+ !
+ IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate
+ DO jj = mj0(jbdy1), mj1(jbdy2)
+ zub(:,jj) = 0._wp
+ DO jk = 1, jpkm1
+ DO ji = 1, jpi
+ zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
+ END DO
+ END DO
+ DO ji = 1, jpi
+ zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a)
+ END DO
+ DO jk = 1, jpkm1
+ DO ji = 1, jpi
+ uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) + uu_b(ji,jj,Krhs_a) - zub(ji,jj) ) * umask(ji,jj,jk)
+ END DO
+ END DO
+ END DO
+ ENDIF
+ !
+ ENDIF
+
+ ! --- North --- !
+ IF( lk_north ) THEN
+ jbdy1 = jpjglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells
+ jbdy2 = jpjglo - ( nn_hls + 2 ) ! halo + land + 1
+ !
+ IF( .NOT.ln_dynspg_ts ) THEN ! Store transport
+ DO jj = mj0(jbdy1), mj1(jbdy2)
+ vv_b(:,jj,Krhs_a) = 0._wp
+ DO jk = 1, jpkm1
+ DO ji = 1, jpi
+ vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
+ END DO
+ END DO
+ DO ji=1,jpi
+ vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) * r1_hv(ji,jj,Krhs_a)
+ END DO
+ END DO
+ ENDIF
+ !
+ DO jj = mj0(jbdy1), mj1(jbdy2)
+ zvb(:,jj) = 0._wp ! Correct transport
+ DO jk=1,jpkm1
+ DO ji=1,jpi
+ zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
+ END DO
+ END DO
DO ji = 1, jpi
- vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) &
- & + vv_b(ji,jj,Krhs_a) - zvb(ji,jj) ) * vmask(ji,jj,jk)
- END DO
- END DO
- END DO
-
- IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate
- DO jj = mj0(jbdy1), mj1(jbdy2)
- zub(:,jj) = 0._wp
+ zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a)
+ END DO
DO jk = 1, jpkm1
DO ji = 1, jpi
- zub(ji,jj) = zub(ji,jj) &
- & + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
- END DO
- END DO
- DO ji = 1, jpi
- zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a)
- END DO
-
- DO jk = 1, jpkm1
+ vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) + vv_b(ji,jj,Krhs_a) - zvb(ji,jj) ) * vmask(ji,jj,jk)
+ END DO
+ END DO
+ END DO
+ !
+ IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate
+ jbdy1 = jpjglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1
+ jbdy2 = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
+ DO jj = mj0(jbdy1), mj1(jbdy2)
+ zub(:,jj) = 0._wp
+ DO jk = 1, jpkm1
+ DO ji = 1, jpi
+ zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
+ END DO
+ END DO
DO ji = 1, jpi
- uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) &
- & + uu_b(ji,jj,Krhs_a) - zub(ji,jj) ) * umask(ji,jj,jk)
- END DO
- END DO
- END DO
- ENDIF
-
- ! --- North --- !
- jbdy1 = jpjglo-1-nbghostcells
- jbdy2 = jpjglo-2
- !
- IF( .NOT.ln_dynspg_ts ) THEN ! Store transport
- DO jj = mj0(jbdy1), mj1(jbdy2)
- vv_b(:,jj,Krhs_a) = 0._wp
- DO jk = 1, jpkm1
- DO ji = 1, jpi
- vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) &
- & + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
- END DO
- END DO
- DO ji=1,jpi
- vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) * r1_hv(ji,jj,Krhs_a)
- END DO
- END DO
- ENDIF
- !
- DO jj = mj0(jbdy1), mj1(jbdy2)
- zvb(:,jj) = 0._wp ! Correct transport
- DO jk=1,jpkm1
- DO ji=1,jpi
- zvb(ji,jj) = zvb(ji,jj) &
- & + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
- END DO
- END DO
- DO ji = 1, jpi
- zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a)
- END DO
-
- DO jk = 1, jpkm1
- DO ji = 1, jpi
- vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) &
- & + vv_b(ji,jj,Krhs_a) - zvb(ji,jj) ) * vmask(ji,jj,jk)
- END DO
- END DO
- END DO
-
- IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate
- jbdy1 = jpjglo-nbghostcells
- jbdy2 = jpjglo-1
- DO jj = mj0(jbdy1), mj1(jbdy2)
- zub(:,jj) = 0._wp
- DO jk = 1, jpkm1
- DO ji = 1, jpi
- zub(ji,jj) = zub(ji,jj) &
- & + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
- END DO
- END DO
- DO ji = 1, jpi
- zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a)
- END DO
-
- DO jk = 1, jpkm1
- DO ji = 1, jpi
- uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) &
- & + uu_b(ji,jj,Krhs_a) - zub(ji,jj) ) * umask(ji,jj,jk)
- END DO
- END DO
- END DO
+ zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a)
+ END DO
+ DO jk = 1, jpkm1
+ DO ji = 1, jpi
+ uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) + uu_b(ji,jj,Krhs_a) - zub(ji,jj) ) * umask(ji,jj,jk)
+ END DO
+ END DO
+ END DO
+ ENDIF
+ !
ENDIF
!
@@ -354,57 +346,68 @@
!
!--- West ---!
- istart = 2
- iend = nbghostcells+1
- DO ji = mi0(istart), mi1(iend)
- 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)
- END DO
- END DO
+ IF( lk_west ) THEN
+ istart = nn_hls + 2 ! halo + land + 1
+ iend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells
+ DO ji = mi0(istart), mi1(iend)
+ 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)
+ END DO
+ END DO
+ ENDIF
!
!--- East ---!
- istart = jpiglo-nbghostcells
- iend = jpiglo-1
- DO ji = mi0(istart), mi1(iend)
- DO jj=1,jpj
- va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj)
- END DO
- END DO
- istart = jpiglo-nbghostcells-1
- iend = jpiglo-2
- DO ji = mi0(istart), mi1(iend)
- DO jj=1,jpj
- ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj)
- END DO
- END DO
+ IF( lk_east ) THEN
+ istart = jpiglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1
+ iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
+ DO ji = mi0(istart), mi1(iend)
+
+ DO jj=1,jpj
+ va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj)
+ END DO
+ END DO
+ istart = jpiglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells
+ iend = jpiglo - ( nn_hls + 2 ) ! halo + land + 1
+ DO ji = mi0(istart), mi1(iend)
+ DO jj=1,jpj
+ ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj)
+ END DO
+ END DO
+ ENDIF
!
!--- South ---!
- jstart = 2
- jend = nbghostcells+1
- DO jj = mj0(jstart), mj1(jend)
- DO ji=1,jpi
- ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj)
- va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj)
- END DO
- END DO
+ IF( lk_south ) THEN
+ jstart = nn_hls + 2 ! halo + land + 1
+ jend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells
+ DO jj = mj0(jstart), mj1(jend)
+
+ DO ji=1,jpi
+ ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj)
+ va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj)
+ END DO
+ END DO
+ ENDIF
!
!--- North ---!
- jstart = jpjglo-nbghostcells
- jend = jpjglo-1
- DO jj = mj0(jstart), mj1(jend)
- DO ji=1,jpi
- ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj)
- END DO
- END DO
- jstart = jpjglo-nbghostcells-1
- jend = jpjglo-2
- DO jj = mj0(jstart), mj1(jend)
- DO ji=1,jpi
- va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj)
- END DO
- END DO
+ IF( lk_north ) THEN
+ jstart = jpjglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1
+ jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
+ DO jj = mj0(jstart), mj1(jend)
+ DO ji=1,jpi
+ ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj)
+ END DO
+ END DO
+ jstart = jpjglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells
+ jend = jpjglo - ( nn_hls + 2 ) ! halo + land + 1
+ DO jj = mj0(jstart), mj1(jend)
+ DO ji=1,jpi
+ va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj)
+ END DO
+ END DO
+ ENDIF
!
END SUBROUTINE Agrif_dyn_ts
+
SUBROUTINE Agrif_dyn_ts_flux( jn, zu, zv )
!!----------------------------------------------------------------------
@@ -421,57 +424,66 @@
!
!--- West ---!
- istart = 2
- iend = nbghostcells+1
- DO ji = mi0(istart), mi1(iend)
- DO jj=1,jpj
- zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
- zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
- END DO
- END DO
+ IF( lk_west ) THEN
+ istart = nn_hls + 2 ! halo + land + 1
+ iend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells
+ DO ji = mi0(istart), mi1(iend)
+ DO jj=1,jpj
+ zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
+ zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
+ END DO
+ END DO
+ ENDIF
!
!--- East ---!
- istart = jpiglo-nbghostcells
- iend = jpiglo-1
- DO ji = mi0(istart), mi1(iend)
- DO jj=1,jpj
- zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
- END DO
- END DO
- istart = jpiglo-nbghostcells-1
- iend = jpiglo-2
- DO ji = mi0(istart), mi1(iend)
- DO jj=1,jpj
- zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
- END DO
- END DO
+ IF( lk_east ) THEN
+ istart = jpiglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1
+ iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
+ DO ji = mi0(istart), mi1(iend)
+ DO jj=1,jpj
+ zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
+ END DO
+ END DO
+ istart = jpiglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells
+ iend = jpiglo - ( nn_hls + 2 ) ! halo + land + 1
+ DO ji = mi0(istart), mi1(iend)
+ DO jj=1,jpj
+ zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
+ END DO
+ END DO
+ ENDIF
!
!--- South ---!
- jstart = 2
- jend = nbghostcells+1
- DO jj = mj0(jstart), mj1(jend)
- DO ji=1,jpi
- zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
- zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
- END DO
- END DO
+ IF( lk_south ) THEN
+ jstart = nn_hls + 2 ! halo + land + 1
+ jend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells
+ DO jj = mj0(jstart), mj1(jend)
+ DO ji=1,jpi
+ zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
+ zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
+ END DO
+ END DO
+ ENDIF
!
!--- North ---!
- jstart = jpjglo-nbghostcells
- jend = jpjglo-1
- DO jj = mj0(jstart), mj1(jend)
- DO ji=1,jpi
- zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
- END DO
- END DO
- jstart = jpjglo-nbghostcells-1
- jend = jpjglo-2
- DO jj = mj0(jstart), mj1(jend)
- DO ji=1,jpi
- zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
- END DO
- END DO
+ IF( lk_north ) THEN
+ jstart = jpjglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1
+ jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
+ DO jj = mj0(jstart), mj1(jend)
+ DO ji=1,jpi
+ zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
+ END DO
+ END DO
+ jstart = jpjglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells
+ jend = jpjglo - ( nn_hls + 2 ) ! halo + land + 1
+ DO jj = mj0(jstart), mj1(jend)
+ DO ji=1,jpi
+ zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
+ END DO
+ END DO
+ ENDIF
!
END SUBROUTINE Agrif_dyn_ts_flux
+
SUBROUTINE Agrif_dta_ts( kt )
!!----------------------------------------------------------------------
@@ -494,4 +506,8 @@
Agrif_SpecialValue = 0._wp
Agrif_UseSpecialValue = ln_spc_dyn
+
+ use_sign_north = .TRUE.
+ sign_north = -1.
+
!
! Set bdy time interpolation stage to 0 (latter incremented locally do deal with corners)
@@ -518,4 +534,5 @@
ENDIF
Agrif_UseSpecialValue = .FALSE.
+ use_sign_north = .FALSE.
!
END SUBROUTINE Agrif_dta_ts
@@ -542,38 +559,46 @@
!
! --- West --- !
- istart = 2
- iend = 1 + nbghostcells
- DO ji = mi0(istart), mi1(iend)
- DO jj = 1, jpj
- ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
- ENDDO
- ENDDO
+ IF(lk_west) THEN
+ istart = nn_hls + 2 ! halo + land + 1
+ iend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells
+ DO ji = mi0(istart), mi1(iend)
+ DO jj = 1, jpj
+ ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
+ END DO
+ END DO
+ ENDIF
!
! --- East --- !
- istart = jpiglo - nbghostcells
- iend = jpiglo - 1
- DO ji = mi0(istart), mi1(iend)
- DO jj = 1, jpj
- ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
- ENDDO
- ENDDO
+ IF(lk_east) THEN
+ istart = jpiglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1
+ iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
+ DO ji = mi0(istart), mi1(iend)
+ DO jj = 1, jpj
+ ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
+ END DO
+ END DO
+ ENDIF
!
! --- South --- !
- jstart = 2
- jend = 1 + nbghostcells
- DO jj = mj0(jstart), mj1(jend)
- DO ji = 1, jpi
- ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
- ENDDO
- ENDDO
+ IF(lk_south) THEN
+ jstart = nn_hls + 2 ! halo + land + 1
+ jend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells
+ DO jj = mj0(jstart), mj1(jend)
+ DO ji = 1, jpi
+ ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
+ END DO
+ END DO
+ ENDIF
!
! --- North --- !
- jstart = jpjglo - nbghostcells
- jend = jpjglo - 1
- DO jj = mj0(jstart), mj1(jend)
- DO ji = 1, jpi
- ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
- ENDDO
- ENDDO
+ IF(lk_north) THEN
+ jstart = jpjglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1
+ jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
+ DO jj = mj0(jstart), mj1(jend)
+ DO ji = 1, jpi
+ ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
+ END DO
+ END DO
+ ENDIF
!
END SUBROUTINE Agrif_ssh
@@ -593,41 +618,50 @@
!
! --- West --- !
- istart = 2
- iend = 1+nbghostcells
- DO ji = mi0(istart), mi1(iend)
- DO jj = 1, jpj
- ssha_e(ji,jj) = hbdy(ji,jj)
- ENDDO
- ENDDO
+ IF(lk_west) THEN
+ istart = nn_hls + 2 ! halo + land + 1
+ iend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells
+ DO ji = mi0(istart), mi1(iend)
+ DO jj = 1, jpj
+ ssha_e(ji,jj) = hbdy(ji,jj)
+ END DO
+ END DO
+ ENDIF
!
! --- East --- !
- istart = jpiglo - nbghostcells
- iend = jpiglo - 1
- DO ji = mi0(istart), mi1(iend)
- DO jj = 1, jpj
- ssha_e(ji,jj) = hbdy(ji,jj)
- ENDDO
- ENDDO
+ IF(lk_east) THEN
+ istart = jpiglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1
+ iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
+ DO ji = mi0(istart), mi1(iend)
+ DO jj = 1, jpj
+ ssha_e(ji,jj) = hbdy(ji,jj)
+ END DO
+ END DO
+ ENDIF
!
! --- South --- !
- jstart = 2
- jend = 1+nbghostcells
- DO jj = mj0(jstart), mj1(jend)
- DO ji = 1, jpi
- ssha_e(ji,jj) = hbdy(ji,jj)
- ENDDO
- ENDDO
+ IF(lk_south) THEN
+ jstart = nn_hls + 2 ! halo + land + 1
+ jend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells
+ DO jj = mj0(jstart), mj1(jend)
+ DO ji = 1, jpi
+ ssha_e(ji,jj) = hbdy(ji,jj)
+ END DO
+ END DO
+ ENDIF
!
! --- North --- !
- jstart = jpjglo - nbghostcells
- jend = jpjglo - 1
- DO jj = mj0(jstart), mj1(jend)
- DO ji = 1, jpi
- ssha_e(ji,jj) = hbdy(ji,jj)
- ENDDO
- ENDDO
+ IF(lk_north) THEN
+ jstart = jpjglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1
+ jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
+ DO jj = mj0(jstart), mj1(jend)
+ DO ji = 1, jpi
+ ssha_e(ji,jj) = hbdy(ji,jj)
+ END DO
+ END DO
+ ENDIF
!
END SUBROUTINE Agrif_ssh_ts
+
SUBROUTINE Agrif_avm
!!----------------------------------------------------------------------
@@ -650,5 +684,5 @@
!
END SUBROUTINE Agrif_avm
-
+
SUBROUTINE interptsn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before )
@@ -662,12 +696,17 @@
INTEGER :: ji, jj, jk, jn ! dummy loop indices
INTEGER :: N_in, N_out
+ INTEGER :: item
! vertical interpolation:
REAL(wp) :: zhtot
REAL(wp), DIMENSION(k1:k2,1:jpts) :: tabin
- REAL(wp), DIMENSION(k1:k2) :: h_in
- REAL(wp), DIMENSION(1:jpk) :: h_out
- !!----------------------------------------------------------------------
-
- IF( before ) THEN
+ REAL(wp), DIMENSION(k1:k2) :: h_in, z_in
+ REAL(wp), DIMENSION(1:jpk) :: h_out, z_out
+ !!----------------------------------------------------------------------
+
+ IF( before ) THEN
+
+ item = Kmm_a
+ IF( l_ini_child ) Kmm_a = Kbb_a
+
DO jn = 1,jpts
DO jk=k1,k2
@@ -678,71 +717,96 @@
END DO
END DO
- END DO
-
-# if defined key_vertical
- ! Interpolate thicknesses
- ! Warning: these are masked, hence extrapolated prior interpolation.
- DO jk=k1,k2
- DO jj=j1,j2
- DO ji=i1,i2
- ptab(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a)
- END DO
- END DO
- END DO
-
- ! Extrapolate thicknesses in partial bottom cells:
- ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on
- IF (ln_zps) THEN
- DO jj=j1,j2
- DO ji=i1,i2
- jk = mbkt(ji,jj)
- ptab(ji,jj,jk,jpts+1) = 0._wp
- END DO
- END DO
- END IF
-
- ! Save ssh at last level:
- IF (.NOT.ln_linssh) THEN
- ptab(i1:i2,j1:j2,k2,jpts+1) = ssh(i1:i2,j1:j2,Kmm_a)*tmask(i1:i2,j1:j2,1)
- ELSE
- ptab(i1:i2,j1:j2,k2,jpts+1) = 0._wp
- END IF
-# endif
+ END DO
+
+ IF( l_vremap .OR. l_ini_child) THEN
+ ! Interpolate thicknesses
+ ! Warning: these are masked, hence extrapolated prior interpolation.
+ DO jk=k1,k2
+ DO jj=j1,j2
+ DO ji=i1,i2
+ ptab(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a)
+
+ END DO
+ END DO
+ END DO
+
+ ! Extrapolate thicknesses in partial bottom cells:
+ ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on
+ IF (ln_zps) THEN
+ DO jj=j1,j2
+ DO ji=i1,i2
+ jk = mbkt(ji,jj)
+ ptab(ji,jj,jk,jpts+1) = 0._wp
+ END DO
+ END DO
+ END IF
+
+ ! Save ssh at last level:
+ IF (.NOT.ln_linssh) THEN
+ ptab(i1:i2,j1:j2,k2,jpts+1) = ssh(i1:i2,j1:j2,Kmm_a)*tmask(i1:i2,j1:j2,1)
+ ELSE
+ ptab(i1:i2,j1:j2,k2,jpts+1) = 0._wp
+ END IF
+ ENDIF
+ Kmm_a = item
+
ELSE
-
-# if defined key_vertical
- IF (ln_linssh) ptab(i1:i2,j1:j2,k2,n2) = 0._wp
-
- DO jj=j1,j2
- DO ji=i1,i2
- ts(ji,jj,:,:,Krhs_a) = 0._wp
- N_in = mbkt_parent(ji,jj)
- zhtot = 0._wp
- DO jk=1,N_in !k2 = jpk of parent grid
- IF (jk==N_in) THEN
- h_in(jk) = ht0_parent(ji,jj) + ptab(ji,jj,k2,n2) - zhtot
- ELSE
- h_in(jk) = ptab(ji,jj,jk,n2)
+ item = Krhs_a
+ IF( l_ini_child ) Krhs_a = Kbb_a
+
+ IF( l_vremap .OR. l_ini_child ) THEN
+ IF (ln_linssh) ptab(i1:i2,j1:j2,k2,n2) = 0._wp
+
+ DO jj=j1,j2
+ DO ji=i1,i2
+ ts(ji,jj,:,:,Krhs_a) = 0.
+ ! IF( l_ini_child) ts(ji,jj,:,:,Krhs_a) = ptab(ji,jj,:,1:jpts)
+ N_in = mbkt_parent(ji,jj)
+ zhtot = 0._wp
+ DO jk=1,N_in !k2 = jpk of parent grid
+ IF (jk==N_in) THEN
+ h_in(jk) = ht0_parent(ji,jj) + ptab(ji,jj,k2,n2) - zhtot
+ ELSE
+ h_in(jk) = ptab(ji,jj,jk,n2)
+ ENDIF
+ zhtot = zhtot + h_in(jk)
+ tabin(jk,:) = ptab(ji,jj,jk,n1:n2-1)
+ END DO
+ z_in(1) = 0.5_wp * h_in(1) - zhtot + ht0_parent(ji,jj)
+ DO jk=2,N_in
+ z_in(jk) = z_in(jk-1) + 0.5_wp * h_in(jk)
+ END DO
+
+ N_out = 0
+ DO jk=1,jpk ! jpk of child grid
+ IF (tmask(ji,jj,jk) == 0._wp) EXIT
+ N_out = N_out + 1
+ h_out(jk) = e3t(ji,jj,jk,Krhs_a)
+ END DO
+
+ z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + ht_0(ji,jj)
+ DO jk=2,N_out
+ z_out(jk) = z_out(jk-1) + 0.5_wp * h_out(jk)
+ END DO
+
+ IF (N_in*N_out > 0) THEN
+ IF( l_ini_child ) THEN
+ CALL remap_linear(tabin(1:N_in,1:jpts),z_in(1:N_in),ts(ji,jj,1:N_out,1:jpts,Krhs_a), &
+ & z_out(1:N_out),N_in,N_out,jpts)
+ ELSE
+ CALL reconstructandremap(tabin(1:N_in,1:jpts),h_in(1:N_in),ts(ji,jj,1:N_out,1:jpts,Krhs_a), &
+ & h_out(1:N_out),N_in,N_out,jpts)
+ ENDIF
ENDIF
- zhtot = zhtot + h_in(jk)
- tabin(jk,:) = ptab(ji,jj,jk,n1:n2-1)
- END DO
- N_out = 0
- DO jk=1,jpk ! jpk of child grid
- IF (tmask(ji,jj,jk) == 0._wp) EXIT
- N_out = N_out + 1
- h_out(jk) = e3t(ji,jj,jk,Krhs_a)
- ENDDO
- IF (N_in*N_out > 0) THEN
- CALL reconstructandremap(tabin(1:N_in,1:jpts),h_in(1:N_in),ts(ji,jj,1:N_out,1:jpts,Krhs_a),h_out(1:N_out),N_in,N_out,jpts)
- ENDIF
- ENDDO
- ENDDO
-# else
- !
- DO jn=1, jpts
- ts(i1:i2,j1:j2,1:jpk,jn,Krhs_a)=ptab(i1:i2,j1:j2,1:jpk,jn)*tmask(i1:i2,j1:j2,1:jpk)
- END DO
-# endif
+ END DO
+ END DO
+ Krhs_a = item
+
+ ELSE
+
+ DO jn=1, jpts
+ ts(i1:i2,j1:j2,1:jpk,jn,Krhs_a)=ptab(i1:i2,j1:j2,1:jpk,jn)*tmask(i1:i2,j1:j2,1:jpk)
+ END DO
+ ENDIF
ENDIF
@@ -750,4 +814,5 @@
END SUBROUTINE interptsn
+
SUBROUTINE interpsshn( ptab, i1, i2, j1, j2, before )
!!----------------------------------------------------------------------
@@ -768,4 +833,5 @@
END SUBROUTINE interpsshn
+
SUBROUTINE interpun( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before )
!!----------------------------------------------------------------------
@@ -780,85 +846,111 @@
REAL(wp) :: zrhoy, zhtot
! vertical interpolation:
- REAL(wp), DIMENSION(k1:k2) :: tabin, h_in
- REAL(wp), DIMENSION(1:jpk) :: h_out
- INTEGER :: N_in, N_out
+ REAL(wp), DIMENSION(k1:k2) :: tabin, h_in, z_in
+ REAL(wp), DIMENSION(1:jpk) :: h_out, z_out
+ INTEGER :: N_in, N_out,item
REAL(wp) :: h_diff
!!---------------------------------------------
!
IF (before) THEN
+
+ item = Kmm_a
+ IF( l_ini_child ) Kmm_a = Kbb_a
+
DO jk=1,jpk
DO jj=j1,j2
DO ji=i1,i2
ptab(ji,jj,jk,1) = (e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) * uu(ji,jj,jk,Kmm_a)*umask(ji,jj,jk))
-# if defined key_vertical
- ! Interpolate thicknesses (masked for subsequent extrapolation)
- ptab(ji,jj,jk,2) = umask(ji,jj,jk) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a)
-# endif
- END DO
- END DO
- END DO
-# if defined key_vertical
+ IF( l_vremap .OR. l_ini_child) THEN
+ ! Interpolate thicknesses (masked for subsequent extrapolation)
+ ptab(ji,jj,jk,2) = umask(ji,jj,jk) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a)
+ ENDIF
+ END DO
+ END DO
+ END DO
+
+ IF( l_vremap .OR. l_ini_child) THEN
! Extrapolate thicknesses in partial bottom cells:
! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on
- IF (ln_zps) THEN
- DO jj=j1,j2
- DO ji=i1,i2
- jk = mbku(ji,jj)
- ptab(ji,jj,jk,2) = 0._wp
- END DO
- END DO
- END IF
- ! Save ssh at last level:
- ptab(i1:i2,j1:j2,k2,2) = 0._wp
- IF (.NOT.ln_linssh) THEN
- ! This vertical sum below should be replaced by the sea-level at U-points (optimization):
- DO jk=1,jpk
- ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) + e3u(i1:i2,j1:j2,jk,Kmm_a) * umask(i1:i2,j1:j2,jk)
- END DO
- ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) - hu_0(i1:i2,j1:j2)
- END IF
-# endif
+ IF (ln_zps) THEN
+ DO jj=j1,j2
+ DO ji=i1,i2
+ jk = mbku(ji,jj)
+ ptab(ji,jj,jk,2) = 0._wp
+ END DO
+ END DO
+ END IF
+
+ ! Save ssh at last level:
+ ptab(i1:i2,j1:j2,k2,2) = 0._wp
+ IF (.NOT.ln_linssh) THEN
+ ! This vertical sum below should be replaced by the sea-level at U-points (optimization):
+ DO jk=1,jpk
+ ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) + e3u(i1:i2,j1:j2,jk,Kmm_a) * umask(i1:i2,j1:j2,jk)
+ END DO
+ ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) - hu_0(i1:i2,j1:j2)
+ END IF
+ ENDIF
+
+ Kmm_a = item
!
ELSE
zrhoy = Agrif_rhoy()
-# if defined key_vertical
+
+ IF( l_vremap .OR. l_ini_child) THEN
! VERTICAL REFINEMENT BEGIN
- IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp
-
- DO ji=i1,i2
- DO jj=j1,j2
- uu(ji,jj,:,Krhs_a) = 0._wp
- N_in = mbku_parent(ji,jj)
- zhtot = 0._wp
- DO jk=1,N_in
- IF (jk==N_in) THEN
- h_in(jk) = hu0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot
- ELSE
- h_in(jk) = ptab(ji,jj,jk,2)/(e2u(ji,jj)*zrhoy)
- ENDIF
- zhtot = zhtot + h_in(jk)
- tabin(jk) = ptab(ji,jj,jk,1)/(e2u(ji,jj)*zrhoy*h_in(jk))
- ENDDO
-
- N_out = 0
- DO jk=1,jpk
- if (umask(ji,jj,jk) == 0) EXIT
- N_out = N_out + 1
- h_out(N_out) = e3u(ji,jj,jk,Krhs_a)
- ENDDO
- IF (N_in*N_out > 0) THEN
- CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),uu(ji,jj,1:N_out,Krhs_a),h_out(1:N_out),N_in,N_out,1)
- ENDIF
- ENDDO
- ENDDO
-
-# else
- DO jk = 1, jpkm1
- DO jj=j1,j2
- uu(i1:i2,jj,jk,Krhs_a) = ptab(i1:i2,jj,jk,1) / ( zrhoy * e2u(i1:i2,jj) * e3u(i1:i2,jj,jk,Krhs_a) )
- END DO
- END DO
-# endif
+ IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp
+
+ DO ji=i1,i2
+ DO jj=j1,j2
+ uu(ji,jj,:,Krhs_a) = 0._wp
+ N_in = mbku_parent(ji,jj)
+ zhtot = 0._wp
+ DO jk=1,N_in
+ IF (jk==N_in) THEN
+ h_in(jk) = hu0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot
+ ELSE
+ h_in(jk) = ptab(ji,jj,jk,2)/(e2u(ji,jj)*zrhoy)
+ ENDIF
+ zhtot = zhtot + h_in(jk)
+ IF( h_in(jk) .GT. 0. ) THEN
+ tabin(jk) = ptab(ji,jj,jk,1)/(e2u(ji,jj)*zrhoy*h_in(jk))
+ ELSE
+ tabin(jk) = 0.
+ ENDIF
+ END DO
+ z_in(1) = 0.5_wp * h_in(1) - zhtot + hu0_parent(ji,jj)
+ DO jk=2,N_in
+ z_in(jk) = z_in(jk-1) + 0.5_wp * h_in(jk)
+ END DO
+
+ N_out = 0
+ DO jk=1,jpk
+ IF (umask(ji,jj,jk) == 0) EXIT
+ N_out = N_out + 1
+ h_out(N_out) = e3u(ji,jj,jk,Krhs_a)
+ END DO
+
+ z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + hu_0(ji,jj)
+ DO jk=2,N_out
+ z_out(jk) = z_out(jk-1) + 0.5_wp * h_out(jk)
+ END DO
+
+ IF (N_in*N_out > 0) THEN
+ IF( l_ini_child ) THEN
+ CALL remap_linear (tabin(1:N_in),z_in(1:N_in),uu(ji,jj,1:N_out,Krhs_a),z_out(1:N_out),N_in,N_out,1)
+ ELSE
+ CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),uu(ji,jj,1:N_out,Krhs_a),h_out(1:N_out),N_in,N_out,1)
+ ENDIF
+ ENDIF
+ END DO
+ END DO
+ ELSE
+ DO jk = 1, jpkm1
+ DO jj=j1,j2
+ uu(i1:i2,jj,jk,Krhs_a) = ptab(i1:i2,jj,jk,1) / ( zrhoy * e2u(i1:i2,jj) * e3u(i1:i2,jj,jk,Krhs_a) )
+ END DO
+ END DO
+ ENDIF
ENDIF
@@ -866,4 +958,5 @@
END SUBROUTINE interpun
+
SUBROUTINE interpvn( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before )
!!----------------------------------------------------------------------
@@ -878,80 +971,107 @@
REAL(wp) :: zrhox
! vertical interpolation:
- REAL(wp), DIMENSION(k1:k2) :: tabin, h_in
- REAL(wp), DIMENSION(1:jpk) :: h_out
- INTEGER :: N_in, N_out
+ REAL(wp), DIMENSION(k1:k2) :: tabin, h_in, z_in
+ REAL(wp), DIMENSION(1:jpk) :: h_out, z_out
+ INTEGER :: N_in, N_out, item
REAL(wp) :: h_diff, zhtot
!!---------------------------------------------
!
- IF (before) THEN
+ IF (before) THEN
+
+ item = Kmm_a
+ IF( l_ini_child ) Kmm_a = Kbb_a
+
DO jk=k1,k2
DO jj=j1,j2
DO ji=i1,i2
ptab(ji,jj,jk,1) = (e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a) * vv(ji,jj,jk,Kmm_a)*vmask(ji,jj,jk))
-# if defined key_vertical
- ! Interpolate thicknesses (masked for subsequent extrapolation)
- ptab(ji,jj,jk,2) = vmask(ji,jj,jk) * e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a)
-# endif
- END DO
- END DO
- END DO
-# if defined key_vertical
+ IF( l_vremap .OR. l_ini_child) THEN
+ ! Interpolate thicknesses (masked for subsequent extrapolation)
+ ptab(ji,jj,jk,2) = vmask(ji,jj,jk) * e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a)
+ ENDIF
+ END DO
+ END DO
+ END DO
+
+ IF( l_vremap .OR. l_ini_child) THEN
! Extrapolate thicknesses in partial bottom cells:
! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on
- IF (ln_zps) THEN
+ IF (ln_zps) THEN
+ DO jj=j1,j2
+ DO ji=i1,i2
+ jk = mbkv(ji,jj)
+ ptab(ji,jj,jk,2) = 0._wp
+ END DO
+ END DO
+ END IF
+ ! Save ssh at last level:
+ ptab(i1:i2,j1:j2,k2,2) = 0._wp
+ IF (.NOT.ln_linssh) THEN
+ ! This vertical sum below should be replaced by the sea-level at V-points (optimization):
+ DO jk=1,jpk
+ ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) + e3v(i1:i2,j1:j2,jk,Kmm_a) * vmask(i1:i2,j1:j2,jk)
+ END DO
+ ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) - hv_0(i1:i2,j1:j2)
+ END IF
+ ENDIF
+ item = Kmm_a
+
+ ELSE
+ zrhox = Agrif_rhox()
+
+ IF( l_vremap .OR. l_ini_child ) THEN
+
+ IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp
+
DO jj=j1,j2
DO ji=i1,i2
- jk = mbkv(ji,jj)
- ptab(ji,jj,jk,2) = 0._wp
- END DO
- END DO
- END IF
- ! Save ssh at last level:
- ptab(i1:i2,j1:j2,k2,2) = 0._wp
- IF (.NOT.ln_linssh) THEN
- ! This vertical sum below should be replaced by the sea-level at V-points (optimization):
- DO jk=1,jpk
- ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) + e3v(i1:i2,j1:j2,jk,Kmm_a) * vmask(i1:i2,j1:j2,jk)
- END DO
- ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) - hv_0(i1:i2,j1:j2)
- END IF
-# endif
- ELSE
- zrhox = Agrif_rhox()
-# if defined key_vertical
-
- IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp
-
- DO jj=j1,j2
- DO ji=i1,i2
- vv(ji,jj,:,Krhs_a) = 0._wp
- N_in = mbkv_parent(ji,jj)
- zhtot = 0._wp
- DO jk=1,N_in
- IF (jk==N_in) THEN
- h_in(jk) = hv0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot
- ELSE
- h_in(jk) = ptab(ji,jj,jk,2)/(e1v(ji,jj)*zrhox)
+ vv(ji,jj,:,Krhs_a) = 0._wp
+ N_in = mbkv_parent(ji,jj)
+ zhtot = 0._wp
+ DO jk=1,N_in
+ IF (jk==N_in) THEN
+ h_in(jk) = hv0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot
+ ELSE
+ h_in(jk) = ptab(ji,jj,jk,2)/(e1v(ji,jj)*zrhox)
+ ENDIF
+ zhtot = zhtot + h_in(jk)
+ IF( h_in(jk) .GT. 0. ) THEN
+ tabin(jk) = ptab(ji,jj,jk,1)/(e1v(ji,jj)*zrhox*h_in(jk))
+ ELSE
+ tabin(jk) = 0.
+ ENDIF
+ END DO
+
+ z_in(1) = 0.5_wp * h_in(1) - zhtot + hv0_parent(ji,jj)
+ DO jk=2,N_in
+ z_in(jk) = z_in(jk-1) + 0.5_wp * h_in(jk)
+ END DO
+
+ N_out = 0
+ DO jk=1,jpk
+ IF (vmask(ji,jj,jk) == 0) EXIT
+ N_out = N_out + 1
+ h_out(N_out) = e3v(ji,jj,jk,Krhs_a)
+ END DO
+
+ z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + hv_0(ji,jj)
+ DO jk=2,N_out
+ z_out(jk) = z_out(jk-1) + 0.5_wp * h_out(jk)
+ END DO
+
+ IF (N_in*N_out > 0) THEN
+ IF( l_ini_child ) THEN
+ CALL remap_linear (tabin(1:N_in),z_in(1:N_in),vv(ji,jj,1:N_out,Krhs_a),z_out(1:N_out),N_in,N_out,1)
+ ELSE
+ CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),vv(ji,jj,1:N_out,Krhs_a),h_out(1:N_out),N_in,N_out,1)
+ ENDIF
ENDIF
- zhtot = zhtot + h_in(jk)
- tabin(jk) = ptab(ji,jj,jk,1)/(e1v(ji,jj)*zrhox*h_in(jk))
- ENDDO
-
- N_out = 0
- DO jk=1,jpk
- if (vmask(ji,jj,jk) == 0) EXIT
- N_out = N_out + 1
- h_out(N_out) = e3v(ji,jj,jk,Krhs_a)
- END DO
- IF (N_in*N_out > 0) THEN
- call reconstructandremap(tabin(1:N_in),h_in(1:N_in),vv(ji,jj,1:N_out,Krhs_a),h_out(1:N_out),N_in,N_out,1)
- ENDIF
- END DO
- END DO
-# else
- DO jk = 1, jpkm1
- vv(i1:i2,j1:j2,jk,Krhs_a) = ptab(i1:i2,j1:j2,jk,1) / ( zrhox * e1v(i1:i2,j1:j2) * e3v(i1:i2,j1:j2,jk,Krhs_a) )
- END DO
-# endif
+ END DO
+ END DO
+ ELSE
+ DO jk = 1, jpkm1
+ vv(i1:i2,j1:j2,jk,Krhs_a) = ptab(i1:i2,j1:j2,jk,1) / ( zrhox * e1v(i1:i2,j1:j2) * e3v(i1:i2,j1:j2,jk,Krhs_a) )
+ END DO
+ ENDIF
ENDIF
!
@@ -1152,6 +1272,6 @@
WRITE(numout,*) ' Agrif error for e3t_0: parent , child, i, j, k ', &
& ptab(ji,jj,jk), tmask(ji,jj,jk) * e3t_0(ji,jj,jk), &
- & ji+nimpp-1, jj+njmpp-1, jk
- kindic_agr = kindic_agr + 1
+ & mig0(ji), mig0(jj), jk
+ ! kindic_agr = kindic_agr + 1
ENDIF
END DO
@@ -1162,4 +1282,61 @@
!
END SUBROUTINE interpe3t
+
+ SUBROUTINE interpglamt( ptab, i1, i2, j1, j2, before )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE interpglamt ***
+ !!----------------------------------------------------------------------
+ INTEGER , INTENT(in ) :: i1, i2, j1, j2
+ REAL(wp),DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
+ LOGICAL , INTENT(in ) :: before
+ !
+ INTEGER :: ji, jj, jk
+ REAL(wp):: ztst
+ !!----------------------------------------------------------------------
+ !
+ IF( before ) THEN
+ ptab(i1:i2,j1:j2) = glamt(i1:i2,j1:j2)
+ ELSE
+ ztst = MAXVAL(ABS(glamt(i1:i2,j1:j2)))*1.e-4
+ 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)
+! kindic_agr = kindic_agr + 1
+ ENDIF
+ END DO
+ END DO
+ ENDIF
+ !
+ END SUBROUTINE interpglamt
+
+
+ SUBROUTINE interpgphit( ptab, i1, i2, j1, j2, before )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE interpgphit ***
+ !!----------------------------------------------------------------------
+ INTEGER , INTENT(in ) :: i1, i2, j1, j2
+ REAL(wp),DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
+ LOGICAL , INTENT(in ) :: before
+ !
+ INTEGER :: ji, jj, jk
+ REAL(wp):: ztst
+ !!----------------------------------------------------------------------
+ !
+ IF( before ) THEN
+ ptab(i1:i2,j1:j2) = gphit(i1:i2,j1:j2)
+ ELSE
+ ztst = MAXVAL(ABS(gphit(i1:i2,j1:j2)))*1.e-4
+ 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)
+! kindic_agr = kindic_agr + 1
+ ENDIF
+ END DO
+ END DO
+ ENDIF
+ !
+ END SUBROUTINE interpgphit
@@ -1185,66 +1362,68 @@
END DO
END DO
- END DO
-
-# if defined key_vertical
- ! Interpolate thicknesses
- ! Warning: these are masked, hence extrapolated prior interpolation.
- DO jk=k1,k2
- DO jj=j1,j2
- DO ji=i1,i2
- ptab(ji,jj,jk,2) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a)
- END DO
- END DO
- END DO
-
- ! Extrapolate thicknesses in partial bottom cells:
- ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on
- IF (ln_zps) THEN
- DO jj=j1,j2
- DO ji=i1,i2
- jk = mbkt(ji,jj)
- ptab(ji,jj,jk,2) = 0._wp
- END DO
- END DO
- END IF
-
- ! 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)
- ELSE
- ptab(i1:i2,j1:j2,k2,2) = 0._wp
- END IF
-# endif
+ END DO
+
+ IF( l_vremap ) THEN
+ ! Interpolate thicknesses
+ ! Warning: these are masked, hence extrapolated prior interpolation.
+ DO jk=k1,k2
+ DO jj=j1,j2
+ DO ji=i1,i2
+ ptab(ji,jj,jk,2) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a)
+ END DO
+ END DO
+ END DO
+
+ ! Extrapolate thicknesses in partial bottom cells:
+ ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on
+ IF (ln_zps) THEN
+ DO jj=j1,j2
+ DO ji=i1,i2
+ jk = mbkt(ji,jj)
+ ptab(ji,jj,jk,2) = 0._wp
+ END DO
+ END DO
+ END IF
+
+ ! 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)
+ ELSE
+ ptab(i1:i2,j1:j2,k2,2) = 0._wp
+ END IF
+ ENDIF
+
ELSE
-#ifdef key_vertical
- IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp
- avm_k(i1:i2,j1:j2,k1:k2) = 0._wp
-
- DO jj = j1, j2
- DO ji =i1, i2
- N_in = mbkt_parent(ji,jj)
- IF ( tmask(ji,jj,1) == 0._wp) N_in = 0
- z_in(N_in+1) = ht0_parent(ji,jj) + ptab(ji,jj,k2,2)
- DO jk = N_in, 1, -1 ! Parent vertical grid
- z_in(jk) = z_in(jk+1) - ptab(ji,jj,jk,2)
- tabin(jk) = ptab(ji,jj,jk,1)
- END DO
- N_out = mbkt(ji,jj)
- DO jk = 1, N_out ! Child vertical grid
- z_out(jk) = gdepw(ji,jj,jk,Kmm_a)
- ENDDO
- IF (N_in*N_out > 0) THEN
- CALL remap_linear(tabin(1:N_in),z_in(1:N_in),avm_k(ji,jj,1:N_out),z_out(1:N_out),N_in,N_out,1)
- ENDIF
- ENDDO
- ENDDO
-#else
- avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2,1)
-#endif
+
+ IF( l_vremap ) THEN
+ IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp
+ avm_k(i1:i2,j1:j2,k1:k2) = 0._wp
+
+ DO jj = j1, j2
+ DO ji =i1, i2
+ N_in = mbkt_parent(ji,jj)
+ IF ( tmask(ji,jj,1) == 0._wp) N_in = 0
+ z_in(N_in+1) = ht0_parent(ji,jj) + ptab(ji,jj,k2,2)
+ DO jk = N_in, 1, -1 ! Parent vertical grid
+ z_in(jk) = z_in(jk+1) - ptab(ji,jj,jk,2)
+ tabin(jk) = ptab(ji,jj,jk,1)
+ END DO
+ N_out = mbkt(ji,jj)
+ DO jk = 1, N_out ! Child vertical grid
+ z_out(jk) = gdepw(ji,jj,jk,Kmm_a)
+ END DO
+ IF (N_in*N_out > 0) THEN
+ CALL remap_linear(tabin(1:N_in),z_in(1:N_in),avm_k(ji,jj,1:N_out),z_out(1:N_out),N_in,N_out,1)
+ ENDIF
+ END DO
+ END DO
+ ELSE
+ avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2,1)
+ ENDIF
ENDIF
!
END SUBROUTINE interpavm
-# if defined key_vertical
+
SUBROUTINE interpmbkt( ptab, i1, i2, j1, j2, before )
!!----------------------------------------------------------------------
@@ -1265,4 +1444,5 @@
END SUBROUTINE interpmbkt
+
SUBROUTINE interpht0( ptab, i1, i2, j1, j2, before )
!!----------------------------------------------------------------------
@@ -1282,6 +1462,43 @@
!
END SUBROUTINE interpht0
-#endif
-
+
+
+ SUBROUTINE agrif_initts(tabres,i1,i2,j1,j2,k1,k2,m1,m2,before)
+ INTEGER :: i1, i2, j1, j2, k1, k2, m1, m2
+ REAL(wp):: tabres(i1:i2,j1:j2,k1:k2,m1:m2)
+ LOGICAL :: before
+
+ INTEGER :: jm
+
+ IF (before) THEN
+ DO jm=1,jpts
+ tabres(i1:i2,j1:j2,k1:k2,jm) = ts(i1:i2,j1:j2,k1:k2,jm,Kbb_a)
+ END DO
+ ELSE
+ DO jm=1,jpts
+ ts(i1:i2,j1:j2,k1:k2,jm,Kbb_a)=tabres(i1:i2,j1:j2,k1:k2,jm)
+ END DO
+ ENDIF
+ END SUBROUTINE agrif_initts
+
+
+ SUBROUTINE agrif_initssh( ptab, i1, i2, j1, j2, before )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE interpsshn ***
+ !!----------------------------------------------------------------------
+ INTEGER , INTENT(in ) :: i1, i2, j1, j2
+ REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
+ LOGICAL , INTENT(in ) :: before
+ !
+ !!----------------------------------------------------------------------
+ !
+ IF( before) THEN
+ ptab(i1:i2,j1:j2) = ssh(i1:i2,j1:j2,Kbb_a)
+ ELSE
+ ssh(i1:i2,j1:j2,Kbb_a) = ptab(i1:i2,j1:j2)*tmask(i1:i2,j1:j2,1)
+ ENDIF
+ !
+ END SUBROUTINE agrif_initssh
+
#else
!!----------------------------------------------------------------------
Index: /NEMO/branches/2020/r12377_ticket2386/src/NST/agrif_oce_sponge.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/NST/agrif_oce_sponge.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/NST/agrif_oce_sponge.F90 (revision 13540)
@@ -78,6 +78,8 @@
zcoef = REAL(Agrif_rhot()-1,wp)/REAL(Agrif_rhot())
- Agrif_SpecialValue=0.
+ Agrif_SpecialValue = 0._wp
Agrif_UseSpecialValue = ln_spc_dyn
+ use_sign_north = .TRUE.
+ sign_north = -1._wp
!
tabspongedone_u = .FALSE.
@@ -90,4 +92,5 @@
!
Agrif_UseSpecialValue = .FALSE.
+ use_sign_north = .FALSE.
#endif
!
@@ -106,4 +109,8 @@
REAL(wp) :: z1_ispongearea, z1_jspongearea
REAL(wp), DIMENSION(jpi,jpj) :: ztabramp
+#if defined key_vertical
+ REAL(wp), DIMENSION(jpi,jpj) :: ztabrampu
+ REAL(wp), DIMENSION(jpi,jpj) :: ztabrampv
+#endif
REAL(wp), DIMENSION(jpjmax) :: zmskwest, zmskeast
REAL(wp), DIMENSION(jpimax) :: zmsknorth, zmsksouth
@@ -126,48 +133,46 @@
! Retrieve masks at open boundaries:
- ! --- West --- !
- ztabramp(:,:) = 0._wp
- ind1 = 1+nbghostcells
- DO ji = mi0(ind1), mi1(ind1)
- ztabramp(ji,:) = ssumask(ji,:)
- END DO
- !
- zmskwest(:) = 0._wp
- zmskwest(1:jpj) = MAXVAL(ztabramp(:,:), dim=1)
-
- ! --- East --- !
- ztabramp(:,:) = 0._wp
- ind1 = jpiglo - nbghostcells - 1
- DO ji = mi0(ind1), mi1(ind1)
- ztabramp(ji,:) = ssumask(ji,:)
- END DO
- !
- zmskeast(:) = 0._wp
- zmskeast(1:jpj) = MAXVAL(ztabramp(:,:), dim=1)
-
- ! --- South --- !
- ztabramp(:,:) = 0._wp
- ind1 = 1+nbghostcells
- DO jj = mj0(ind1), mj1(ind1)
- ztabramp(:,jj) = ssvmask(:,jj)
- END DO
- !
- zmsksouth(:) = 0._wp
- zmsksouth(1:jpi) = MAXVAL(ztabramp(:,:), dim=2)
-
- ! --- North --- !
- ztabramp(:,:) = 0._wp
- ind1 = jpjglo - nbghostcells - 1
- DO jj = mj0(ind1), mj1(ind1)
- ztabramp(:,jj) = ssvmask(:,jj)
- END DO
- !
- zmsknorth(:) = 0._wp
- zmsknorth(1:jpi) = MAXVAL(ztabramp(:,:), dim=2)
+ IF( lk_west ) THEN ! --- West --- !
+ ztabramp(:,:) = 0._wp
+ ind1 = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells
+ DO ji = mi0(ind1), mi1(ind1)
+ ztabramp(ji,:) = ssumask(ji,:)
+ END DO
+ zmskwest( 1:jpj ) = MAXVAL(ztabramp(:,:), dim=1)
+ zmskwest(jpj+1:jpjmax) = 0._wp
+ ENDIF
+ IF( lk_east ) THEN ! --- East --- !
+ ztabramp(:,:) = 0._wp
+ ind1 = jpiglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells
+ DO ji = mi0(ind1), mi1(ind1)
+ ztabramp(ji,:) = ssumask(ji,:)
+ END DO
+ zmskeast( 1:jpj ) = MAXVAL(ztabramp(:,:), dim=1)
+ zmskeast(jpj+1:jpjmax) = 0._wp
+ ENDIF
+ IF( lk_south ) THEN ! --- South --- !
+ ztabramp(:,:) = 0._wp
+ ind1 = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells
+ DO jj = mj0(ind1), mj1(ind1)
+ ztabramp(:,jj) = ssvmask(:,jj)
+ END DO
+ zmsksouth( 1:jpi ) = MAXVAL(ztabramp(:,:), dim=2)
+ zmsksouth(jpi+1:jpimax) = 0._wp
+ ENDIF
+ IF( lk_north ) THEN ! --- North --- !
+ ztabramp(:,:) = 0._wp
+ ind1 = jpjglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells
+ DO jj = mj0(ind1), mj1(ind1)
+ ztabramp(:,jj) = ssvmask(:,jj)
+ END DO
+ zmsknorth( 1:jpi ) = MAXVAL(ztabramp(:,:), dim=2)
+ zmsknorth(jpi+1:jpimax) = 0._wp
+ ENDIF
+
! JC: SPONGE MASKING TO BE SORTED OUT:
zmskwest(:) = 1._wp
zmskeast(:) = 1._wp
+ zmsksouth(:) = 1._wp
zmsknorth(:) = 1._wp
- zmsksouth(:) = 1._wp
#if defined key_mpp_mpi
! CALL mpp_max( 'AGRIF_sponge', zmskwest(:) , jpjmax )
@@ -180,8 +185,8 @@
! Store it in ztabramp
- ispongearea = nn_sponge_len * Agrif_irhox()
- z1_ispongearea = 1._wp / REAL( ispongearea )
- jspongearea = nn_sponge_len * Agrif_irhoy()
- z1_jspongearea = 1._wp / REAL( jspongearea )
+ ispongearea = nn_sponge_len * Agrif_irhox()
+ z1_ispongearea = 1._wp / REAL( ispongearea, wp )
+ jspongearea = nn_sponge_len * Agrif_irhoy()
+ z1_jspongearea = 1._wp / REAL( jspongearea, wp )
ztabramp(:,:) = 0._wp
@@ -191,76 +196,73 @@
IF ( nbcellsy <= 3 ) jspongearea = -1
- ! --- West --- !
- ind1 = 1+nbghostcells
- ind2 = 1+nbghostcells + ispongearea
- DO ji = mi0(ind1), mi1(ind2)
- DO jj = 1, jpj
- ztabramp(ji,jj) = REAL( ind2 - mig(ji) ) * z1_ispongearea * zmskwest(jj)
- END DO
- END DO
-
- ! ghost cells:
- ind1 = 1
- ind2 = nbghostcells + 1
- DO ji = mi0(ind1), mi1(ind2)
- DO jj = 1, jpj
- ztabramp(ji,jj) = zmskwest(jj)
- END DO
- END DO
-
- ! --- East --- !
- ind1 = jpiglo - nbghostcells - ispongearea
- ind2 = jpiglo - nbghostcells
- DO ji = mi0(ind1), mi1(ind2)
- DO jj = 1, jpj
- ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( mig(ji) - ind1 ) * z1_ispongearea) * zmskeast(jj)
- ENDDO
- END DO
-
- ! ghost cells:
- ind1 = jpiglo - nbghostcells
- ind2 = jpiglo
- DO ji = mi0(ind1), mi1(ind2)
- DO jj = 1, jpj
- ztabramp(ji,jj) = zmskeast(jj)
- ENDDO
- END DO
-
- ! --- South --- !
- ind1 = 1+nbghostcells
- ind2 = 1+nbghostcells + jspongearea
- DO jj = mj0(ind1), mj1(ind2)
- DO ji = 1, jpi
- ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( ind2 - mjg(jj) ) * z1_jspongearea) * zmsksouth(ji)
- END DO
- END DO
-
- ! ghost cells:
- ind1 = 1
- ind2 = nbghostcells + 1
- DO jj = mj0(ind1), mj1(ind2)
- DO ji = 1, jpi
- ztabramp(ji,jj) = zmsksouth(ji)
- END DO
- END DO
-
- ! --- North --- !
- ind1 = jpjglo - nbghostcells - jspongearea
- ind2 = jpjglo - nbghostcells
- DO jj = mj0(ind1), mj1(ind2)
- DO ji = 1, jpi
- ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( mjg(jj) - ind1 ) * z1_jspongearea) * zmsknorth(ji)
- END DO
- END DO
-
- ! ghost cells:
- ind1 = jpjglo - nbghostcells
- ind2 = jpjglo
- DO jj = mj0(ind1), mj1(ind2)
- DO ji = 1, jpi
- ztabramp(ji,jj) = zmsknorth(ji)
- END DO
- END DO
-
+ IF( lk_west ) THEN ! --- West --- !
+ ind1 = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells
+ ind2 = nn_hls + 1 + nbghostcells + ispongearea
+ DO ji = mi0(ind1), mi1(ind2)
+ DO jj = 1, jpj
+ ztabramp(ji,jj) = REAL(ind2 - mig(ji), wp) * z1_ispongearea * zmskwest(jj)
+ END DO
+ END DO
+ ! ghost cells:
+ ind1 = 1
+ ind2 = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells
+ DO ji = mi0(ind1), mi1(ind2)
+ DO jj = 1, jpj
+ ztabramp(ji,jj) = zmskwest(jj)
+ END DO
+ END DO
+ ENDIF
+ IF( lk_east ) THEN ! --- East --- !
+ ind1 = jpiglo - ( nn_hls + nbghostcells ) - ispongearea
+ ind2 = jpiglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1
+ DO ji = mi0(ind1), mi1(ind2)
+ DO jj = 1, jpj
+ ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL(mig(ji) - ind1, wp) * z1_ispongearea ) * zmskeast(jj)
+ END DO
+ END DO
+ ! ghost cells:
+ ind1 = jpiglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1
+ ind2 = jpiglo
+ DO ji = mi0(ind1), mi1(ind2)
+ DO jj = 1, jpj
+ ztabramp(ji,jj) = zmskeast(jj)
+ END DO
+ END DO
+ ENDIF
+ IF( lk_south ) THEN ! --- South --- !
+ ind1 = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells
+ ind2 = nn_hls + 1 + nbghostcells + jspongearea
+ DO jj = mj0(ind1), mj1(ind2)
+ DO ji = 1, jpi
+ ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL(ind2 - mjg(jj), wp) * z1_jspongearea ) * zmsksouth(ji)
+ END DO
+ END DO
+ ! ghost cells:
+ ind1 = 1
+ ind2 = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells
+ DO jj = mj0(ind1), mj1(ind2)
+ DO ji = 1, jpi
+ ztabramp(ji,jj) = zmsksouth(ji)
+ END DO
+ END DO
+ ENDIF
+ IF( lk_north ) THEN ! --- North --- !
+ ind1 = jpjglo - ( nn_hls + nbghostcells ) - jspongearea
+ ind2 = jpjglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1
+ DO jj = mj0(ind1), mj1(ind2)
+ DO ji = 1, jpi
+ ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL(mjg(jj) - ind1, wp) * z1_jspongearea ) * zmsknorth(ji)
+ END DO
+ END DO
+ ! ghost cells:
+ ind1 = jpjglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1
+ ind2 = jpjglo
+ DO jj = mj0(ind1), mj1(ind2)
+ DO ji = 1, jpi
+ ztabramp(ji,jj) = zmsknorth(ji)
+ END DO
+ END DO
+ ENDIF
+ !
ENDIF
@@ -269,12 +271,8 @@
fspu(:,:) = 0._wp
fspv(:,:) = 0._wp
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
fspu(ji,jj) = 0.5_wp * ( ztabramp(ji,jj) + ztabramp(ji+1,jj ) ) * ssumask(ji,jj)
fspv(ji,jj) = 0.5_wp * ( ztabramp(ji,jj) + ztabramp(ji ,jj+1) ) * ssvmask(ji,jj)
END_2D
- CALL lbc_lnk( 'agrif_Sponge', fspu, 'U', 1. ) ! Lateral boundary conditions
- CALL lbc_lnk( 'agrif_Sponge', fspv, 'V', 1. )
-
- spongedoneT = .TRUE.
ENDIF
@@ -283,5 +281,5 @@
fspt(:,:) = 0._wp
fspf(:,:) = 0._wp
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
fspt(ji,jj) = ztabramp(ji,jj) * ssmask(ji,jj)
fspf(ji,jj) = 0.25_wp * ( ztabramp(ji ,jj ) + ztabramp(ji ,jj+1) &
@@ -289,13 +287,23 @@
& * ssvmask(ji,jj) * ssvmask(ji,jj+1)
END_2D
- CALL lbc_lnk( 'agrif_Sponge', fspt, 'T', 1. ) ! Lateral boundary conditions
- CALL lbc_lnk( 'agrif_Sponge', fspf, 'F', 1. )
-
+ ENDIF
+
+ IF( .NOT. spongedoneT .AND. .NOT. spongedoneU ) THEN
+ CALL lbc_lnk_multi( 'agrif_Sponge', fspu, 'U', 1._wp, fspv, 'V', 1._wp, fspt, 'T', 1._wp, fspf, 'F', 1._wp )
+ spongedoneT = .TRUE.
spongedoneU = .TRUE.
ENDIF
+ IF( .NOT. spongedoneT ) THEN
+ CALL lbc_lnk_multi( 'agrif_Sponge', fspu, 'U', 1._wp, fspv, 'V', 1._wp )
+ spongedoneT = .TRUE.
+ ENDIF
+ IF( .NOT. spongedoneT .AND. .NOT. spongedoneU ) THEN
+ CALL lbc_lnk_multi( 'agrif_Sponge', fspt, 'T', 1._wp, fspf, 'F', 1._wp )
+ spongedoneU = .TRUE.
+ ENDIF
#if defined key_vertical
! Remove vertical interpolation where not needed:
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
IF ((fspu(ji-1,jj)==0._wp).AND.(fspu(ji,jj)==0._wp).AND. &
& (fspv(ji,jj-1)==0._wp).AND.(fspv(ji,jj)==0._wp)) mbkt_parent(ji,jj) = 0
@@ -312,10 +320,11 @@
END_2D
!
- ztabramp(:,:) = REAL( mbkt_parent(:,:), wp ) ; CALL lbc_lnk( 'Agrif_Sponge', ztabramp, 'T', 1. )
- mbkt_parent(:,:) = NINT( ztabramp(:,:) )
- ztabramp(:,:) = REAL( mbku_parent(:,:), wp ) ; CALL lbc_lnk( 'Agrif_Sponge', ztabramp, 'U', 1. )
- mbku_parent(:,:) = NINT( ztabramp(:,:) )
- ztabramp(:,:) = REAL( mbkv_parent(:,:), wp ) ; CALL lbc_lnk( 'Agrif_Sponge', ztabramp, 'V', 1. )
- mbkv_parent(:,:) = NINT( ztabramp(:,:) )
+ ztabramp (:,:) = REAL( mbkt_parent(:,:), wp )
+ ztabrampu(:,:) = REAL( mbku_parent(:,:), wp )
+ ztabrampv(:,:) = REAL( mbkv_parent(:,:), wp )
+ CALL lbc_lnk_multi( 'Agrif_Sponge', ztabramp, 'T', 1._wp, ztabrampu, 'U', 1._wp, ztabrampv, 'V', 1._wp )
+ mbkt_parent(:,:) = NINT( ztabramp (:,:) )
+ mbku_parent(:,:) = NINT( ztabrampu(:,:) )
+ mbkv_parent(:,:) = NINT( ztabrampv(:,:) )
#endif
!
@@ -324,4 +333,5 @@
END SUBROUTINE Agrif_Sponge
+
SUBROUTINE interptsn_sponge( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )
!!----------------------------------------------------------------------
@@ -334,5 +344,5 @@
INTEGER :: ji, jj, jk, jn ! dummy loop indices
INTEGER :: iku, ikv
- REAL(wp) :: ztsa, zabe1, zabe2, zbtr, zhtot, ztrelax
+ REAL(wp) :: ztsa, zabe1, zabe2, zbtr, zhtot
REAL(wp), DIMENSION(i1:i2,j1:j2,jpk) :: ztu, ztv
REAL(wp), DIMENSION(i1:i2,j1:j2,jpk,n1:n2) ::tsbdiff
@@ -411,5 +421,5 @@
N_out = N_out + 1
h_out(jk) = e3t(ji,jj,jk,Kbb_a) !Child grid scale factors. Could multiply by e1e2t here instead of division above
- ENDDO
+ END DO
! Account for small differences in free-surface
@@ -422,6 +432,6 @@
CALL reconstructandremap(tabin(1:N_in,1:jpts),h_in(1:N_in),tabres_child(ji,jj,1:N_out,1:jpts),h_out(1:N_out),N_in,N_out,jpts)
ENDIF
- ENDDO
- ENDDO
+ END DO
+ END DO
# endif
@@ -434,12 +444,7 @@
tsbdiff(ji,jj,jk,1:jpts) = (ts(ji,jj,jk,1:jpts,Kbb_a) - tabres(ji,jj,jk,1:jpts))*tmask(ji,jj,jk)
# endif
- ENDDO
- ENDDO
- ENDDO
-
- !* set relaxation time scale
- IF( l_1st_euler .AND. lk_agrif_fstep ) THEN ; ztrelax = rn_trelax_tra / ( rn_Dt )
- ELSE ; ztrelax = rn_trelax_tra / (2._wp * rn_Dt )
- ENDIF
+ END DO
+ END DO
+ END DO
DO jn = 1, jpts
@@ -448,5 +453,5 @@
DO jj = j1,j2
DO ji = i1,i2-1
- zabe1 = rn_sponge_tra * fspu(ji,jj) * umask(ji,jj,jk) * e2_e1u(ji,jj) * e3u(ji,jj,jk,Kmm_a)
+ zabe1 = rn_sponge_tra * r1_Dt * fspu(ji,jj) * umask(ji,jj,jk) * e1e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a)
ztu(ji,jj,jk) = zabe1 * ( tsbdiff(ji+1,jj ,jk,jn) - tsbdiff(ji,jj,jk,jn) )
END DO
@@ -455,5 +460,5 @@
DO ji = i1,i2
DO jj = j1,j2-1
- zabe2 = rn_sponge_tra * fspv(ji,jj) * vmask(ji,jj,jk) * e1_e2v(ji,jj) * e3v(ji,jj,jk,Kmm_a)
+ zabe2 = rn_sponge_tra * r1_Dt * fspv(ji,jj) * vmask(ji,jj,jk) * e1e2v(ji,jj) * e3v(ji,jj,jk,Kmm_a)
ztv(ji,jj,jk) = zabe2 * ( tsbdiff(ji ,jj+1,jk,jn) - tsbdiff(ji,jj,jk,jn) )
END DO
@@ -480,5 +485,5 @@
! horizontal diffusive trends
ztsa = zbtr * ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) + ztv(ji,jj,jk) - ztv(ji,jj-1,jk) ) &
- & - ztrelax * fspt(ji,jj) * tsbdiff(ji,jj,jk,jn)
+ & - 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
@@ -496,4 +501,5 @@
END SUBROUTINE interptsn_sponge
+
SUBROUTINE interpun_sponge(tabres,i1,i2,j1,j2,k1,k2,m1,m2, before)
!!---------------------------------------------
@@ -504,8 +510,8 @@
LOGICAL, INTENT(in) :: before
- INTEGER :: ji,jj,jk,jmax
-
+ INTEGER :: ji,jj,jk,jmax
+ INTEGER :: ind1
! sponge parameters
- REAL(wp) :: ze2u, ze1v, zua, zva, zbtr, zhtot, ztrelax
+ REAL(wp) :: ze2u, ze1v, zua, zva, zbtr, zhtot
REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: ubdiff
REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: rotdiff, hdivdiff
@@ -569,5 +575,5 @@
zhtot = zhtot + h_in(jk)
tabin(jk) = tabres(ji,jj,jk,m1)
- ENDDO
+ END DO
!
N_out = 0
@@ -576,5 +582,5 @@
N_out = N_out + 1
h_out(N_out) = e3u(ji,jj,jk,Kbb_a)
- ENDDO
+ END DO
! Account for small differences in free-surface
@@ -588,6 +594,6 @@
CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out,1)
ENDIF
- ENDDO
- ENDDO
+ END DO
+ END DO
ubdiff(i1:i2,j1:j2,:) = (uu(i1:i2,j1:j2,:,Kbb_a) - tabres_child(i1:i2,j1:j2,:))*umask(i1:i2,j1:j2,:)
@@ -595,8 +601,4 @@
ubdiff(i1:i2,j1:j2,:) = (uu(i1:i2,j1:j2,:,Kbb_a) - tabres(i1:i2,j1:j2,:,1))*umask(i1:i2,j1:j2,:)
#endif
- !* set relaxation time scale
- IF( l_1st_euler .AND. lk_agrif_fstep ) THEN ; ztrelax = rn_trelax_dyn / ( rn_Dt )
- ELSE ; ztrelax = rn_trelax_dyn / (2._wp * rn_Dt )
- ENDIF
!
DO jk = 1, jpkm1 ! Horizontal slab
@@ -608,5 +610,5 @@
DO jj = j1,j2
DO ji = i1+1,i2 ! vector opt.
- zbtr = r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kbb_a) * rn_sponge_dyn * fspt(ji,jj)
+ zbtr = rn_sponge_dyn * r1_Dt * fspt(ji,jj) / e3t(ji,jj,jk,Kbb_a)
hdivdiff(ji,jj,jk) = ( e2u(ji ,jj)*e3u(ji ,jj,jk,Kbb_a) * ubdiff(ji ,jj,jk) &
& -e2u(ji-1,jj)*e3u(ji-1,jj,jk,Kbb_a) * ubdiff(ji-1,jj,jk) ) * zbtr
@@ -616,5 +618,5 @@
DO jj = j1,j2-1
DO ji = i1,i2 ! vector opt.
- zbtr = r1_e1e2f(ji,jj) * e3f(ji,jj,jk) * rn_sponge_dyn * fspf(ji,jj)
+ zbtr = rn_sponge_dyn * r1_Dt * fspf(ji,jj) * e3f(ji,jj,jk)
rotdiff(ji,jj,jk) = ( -e1u(ji,jj+1) * ubdiff(ji,jj+1,jk) &
& +e1u(ji,jj ) * ubdiff(ji,jj ,jk) ) * fmask(ji,jj,jk) * zbtr
@@ -633,5 +635,5 @@
zua = - ( ze2u - rotdiff (ji,jj-1,jk) ) / ( e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) ) &
& + ( hdivdiff(ji+1,jj,jk) - ze1v ) * r1_e1u(ji,jj) &
- & - ztrelax * fspu(ji,jj) * ubdiff(ji,jj,jk)
+ & - rn_trelax_dyn * r1_Dt * fspu(ji,jj) * ubdiff(ji,jj,jk)
! add it to the general momentum trends
@@ -646,5 +648,8 @@
jmax = j2-1
- IF ((nbondj == 1).OR.(nbondj == 2)) jmax = MIN(jmax,nlcj-nbghostcells-2) ! North
+ ind1 = jpjglo - ( nn_hls + nbghostcells + 2 ) ! North
+ DO jj = mj0(ind1), mj1(ind1)
+ jmax = MIN(jmax,jj)
+ END DO
DO jj = j1+1, jmax
@@ -674,5 +679,6 @@
END SUBROUTINE interpun_sponge
- SUBROUTINE interpvn_sponge(tabres,i1,i2,j1,j2,k1,k2,m1,m2, before,nb,ndir)
+
+ SUBROUTINE interpvn_sponge(tabres,i1,i2,j1,j2,k1,k2,m1,m2, before)
!!---------------------------------------------
!! *** ROUTINE interpvn_sponge ***
@@ -681,8 +687,8 @@
REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: tabres
LOGICAL, INTENT(in) :: before
- INTEGER, INTENT(in) :: nb , ndir
!
INTEGER :: ji, jj, jk, imax
- REAL(wp) :: ze2u, ze1v, zua, zva, zbtr, zhtot, ztrelax
+ INTEGER :: ind1
+ REAL(wp) :: ze2u, ze1v, zua, zva, zbtr, zhtot
REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: vbdiff
REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: rotdiff, hdivdiff
@@ -745,5 +751,5 @@
zhtot = zhtot + h_in(jk)
tabin(jk) = tabres(ji,jj,jk,m1)
- ENDDO
+ END DO
!
N_out = 0
@@ -752,5 +758,5 @@
N_out = N_out + 1
h_out(N_out) = e3v(ji,jj,jk,Kbb_a)
- ENDDO
+ END DO
! Account for small differences in free-surface
@@ -764,6 +770,6 @@
CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out,1)
ENDIF
- ENDDO
- ENDDO
+ END DO
+ END DO
vbdiff(i1:i2,j1:j2,:) = (vv(i1:i2,j1:j2,:,Kbb_a) - tabres_child(i1:i2,j1:j2,:))*vmask(i1:i2,j1:j2,:)
@@ -771,8 +777,4 @@
vbdiff(i1:i2,j1:j2,:) = (vv(i1:i2,j1:j2,:,Kbb_a) - tabres(i1:i2,j1:j2,:,1))*vmask(i1:i2,j1:j2,:)
# endif
- !* set relaxation time scale
- IF( l_1st_euler .AND. lk_agrif_fstep ) THEN ; ztrelax = rn_trelax_dyn / ( rn_Dt )
- ELSE ; ztrelax = rn_trelax_dyn / (2._wp * rn_Dt )
- ENDIF
!
DO jk = 1, jpkm1 ! Horizontal slab
@@ -784,5 +786,5 @@
DO jj = j1+1,j2
DO ji = i1,i2 ! vector opt.
- zbtr = r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kbb_a) * rn_sponge_dyn * fspt(ji,jj)
+ zbtr = rn_sponge_dyn * r1_Dt * fspt(ji,jj) / e3t(ji,jj,jk,Kbb_a)
hdivdiff(ji,jj,jk) = ( e1v(ji,jj ) * e3v(ji,jj ,jk,Kbb_a) * vbdiff(ji,jj ,jk) &
& -e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kbb_a) * vbdiff(ji,jj-1,jk) ) * zbtr
@@ -791,5 +793,5 @@
DO jj = j1,j2
DO ji = i1,i2-1 ! vector opt.
- zbtr = r1_e1e2f(ji,jj) * e3f(ji,jj,jk) * rn_sponge_dyn * fspf(ji,jj)
+ zbtr = rn_sponge_dyn * r1_Dt * fspf(ji,jj) * e3f(ji,jj,jk)
rotdiff(ji,jj,jk) = ( e2v(ji+1,jj) * vbdiff(ji+1,jj,jk) &
& -e2v(ji ,jj) * vbdiff(ji ,jj,jk) ) * fmask(ji,jj,jk) * zbtr
@@ -802,11 +804,14 @@
imax = i2 - 1
- IF ((nbondi == 1).OR.(nbondi == 2)) imax = MIN(imax,nlci-nbghostcells-2) ! East
-
+ ind1 = jpiglo - ( nn_hls + nbghostcells + 2 ) ! East
+ DO ji = mi0(ind1), mi1(ind1)
+ imax = MIN(imax,ji)
+ END DO
+
DO jj = j1+1, j2
DO ji = i1+1, imax ! vector opt.
IF( .NOT. tabspongedone_u(ji,jj) ) THEN
DO jk = 1, jpkm1
- uu(ji,jj,jk,Krhs_a) = uu(ji,jj,jk,Krhs_a) &
+ uu(ji,jj,jk,Krhs_a) = uu(ji,jj,jk,Krhs_a) &
& - ( rotdiff (ji ,jj,jk) - rotdiff (ji,jj-1,jk)) / ( e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) ) &
& + ( hdivdiff(ji+1,jj,jk) - hdivdiff(ji,jj ,jk)) * r1_e1u(ji,jj)
@@ -822,8 +827,8 @@
IF( .NOT. tabspongedone_v(ji,jj) ) THEN
DO jk = 1, jpkm1
- vv(ji,jj,jk,Krhs_a) = vv(ji,jj,jk,Krhs_a) &
+ vv(ji,jj,jk,Krhs_a) = vv(ji,jj,jk,Krhs_a) &
& + ( rotdiff (ji,jj ,jk) - rotdiff (ji-1,jj,jk) ) / ( e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a) ) &
- & + ( hdivdiff(ji,jj+1,jk) - hdivdiff(ji ,jj,jk) ) * r1_e2v(ji,jj) &
- & - ztrelax * fspv(ji,jj) * vbdiff(ji,jj,jk)
+ & + ( hdivdiff(ji,jj+1,jk) - hdivdiff(ji ,jj,jk) ) * r1_e2v(ji,jj) &
+ & - rn_trelax_dyn * r1_Dt * fspv(ji,jj) * vbdiff(ji,jj,jk)
END DO
ENDIF
Index: /NEMO/branches/2020/r12377_ticket2386/src/NST/agrif_oce_update.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/NST/agrif_oce_update.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/NST/agrif_oce_update.F90 (revision 13540)
@@ -26,4 +26,5 @@
USE domvvl ! Need interpolation routines
USE vremap ! Vertical remapping
+ USE lbclnk
IMPLICIT NONE
@@ -84,5 +85,9 @@
Agrif_UseSpecialValueInUpdate = .FALSE.
- Agrif_SpecialValueFineGrid = 0.
+ Agrif_SpecialValueFineGrid = 0._wp
+
+ use_sign_north = .TRUE.
+ sign_north = -1._wp
+
!
# if ! defined DECAL_FEEDBACK
@@ -127,4 +132,6 @@
END IF
!
+ use_sign_north = .FALSE.
+ !
END SUBROUTINE Agrif_Update_Dyn
@@ -137,5 +144,5 @@
!
Agrif_UseSpecialValueInUpdate = .TRUE.
- Agrif_SpecialValueFineGrid = 0.
+ Agrif_SpecialValueFineGrid = 0._wp
# if ! defined DECAL_FEEDBACK_2D
CALL Agrif_Update_Variable(sshn_id,procname = updateSSH)
@@ -148,4 +155,6 @@
# if defined VOL_REFLUX
IF ( ln_dynspg_ts.AND.ln_bt_fw ) THEN
+ use_sign_north = .TRUE.
+ sign_north = -1._wp
! Refluxing on ssh:
# if defined DECAL_FEEDBACK_2D
@@ -156,4 +165,5 @@
CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/ 0, 0/),locupdate2=(/-1,-1/),procname = reflux_sshv)
# endif
+ use_sign_north = .FALSE.
END IF
# endif
@@ -826,5 +836,5 @@
SUBROUTINE correct_v_bdy( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir )
!!---------------------------------------------
- !! *** ROUTINE correct_u_bdy ***
+ !! *** ROUTINE correct_v_bdy ***
!!---------------------------------------------
INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2
Index: /NEMO/branches/2020/r12377_ticket2386/src/NST/agrif_top_interp.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/NST/agrif_top_interp.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/NST/agrif_top_interp.F90 (revision 13540)
@@ -119,5 +119,4 @@
tr(i1:i2,j1:j2,1:jpk,jn,Krhs_a)=ptab_child(i1:i2,j1:j2,1:jpk,jn)*tmask(i1:i2,j1:j2,1:jpk)
END DO
-
ENDIF
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/NST/agrif_user.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/NST/agrif_user.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/NST/agrif_user.F90 (revision 13540)
@@ -11,10 +11,13 @@
END SUBROUTINE agrif_user
+
SUBROUTINE agrif_before_regridding
END SUBROUTINE agrif_before_regridding
+
SUBROUTINE Agrif_InitWorkspace
END SUBROUTINE Agrif_InitWorkspace
+
SUBROUTINE Agrif_InitValues
!!----------------------------------------------------------------------
@@ -28,6 +31,4 @@
!
! !* Agrif initialization
- CALL agrif_nemo_init
- CALL Agrif_InitValues_cont_dom
CALL Agrif_InitValues_cont
# if defined key_top
@@ -40,131 +41,347 @@
END SUBROUTINE Agrif_initvalues
- SUBROUTINE Agrif_InitValues_cont_dom
- !!----------------------------------------------------------------------
- !! *** ROUTINE Agrif_InitValues_cont_dom ***
- !!----------------------------------------------------------------------
- !
- CALL agrif_declare_var_dom
- !
- END SUBROUTINE Agrif_InitValues_cont_dom
-
- SUBROUTINE agrif_declare_var_dom
- !!----------------------------------------------------------------------
- !! *** ROUTINE agrif_declare_var_dom ***
- !!----------------------------------------------------------------------
- USE par_oce, ONLY: nbghostcells
+
+ SUBROUTINE Agrif_Istate( Kbb, Kmm, Kaa )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE agrif_istate ***
+ !!----------------------------------------------------------------------
+ USE domvvl
+ USE domain
+ USE par_oce
+ USE agrif_oce
+ USE agrif_oce_interp
+ USE oce
+ USE lib_mpp
+ USE lbclnk
+ !
+ IMPLICIT NONE
+ !
+ INTEGER, INTENT(in) :: Kbb, Kmm, Kaa
+ INTEGER :: jn
+ !!----------------------------------------------------------------------
+ IF(lwp) WRITE(numout,*) ' '
+ IF(lwp) WRITE(numout,*) 'AGRIF: interp child initial state from parent'
+ IF(lwp) WRITE(numout,*) ' '
+
+ l_ini_child = .TRUE.
+ Agrif_SpecialValue = 0.0_wp
+ Agrif_UseSpecialValue = .TRUE.
+ uu(:,:,:,:) = 0.0_wp ; vv(:,:,:,:) = 0.0_wp ; ts(:,:,:,:,:) = 0.0_wp
+
+ Krhs_a = Kbb ; Kmm_a = Kbb
+
+ ! Brutal fix to pas 1x1 refinment.
+ ! IF(Agrif_Irhox() == 1) THEN
+ ! CALL Agrif_Init_Variable(tsini_id, procname=agrif_initts)
+ ! ELSE
+ CALL Agrif_Init_Variable(tsini_id, procname=interptsn)
+
+ ! ENDIF
+! just for VORTEX because Parent velocities can actually be exactly zero
+! Agrif_UseSpecialValue = .FALSE.
+ Agrif_UseSpecialValue = ln_spc_dyn
+ use_sign_north = .TRUE.
+ sign_north = -1.
+ CALL Agrif_Init_Variable(uini_id , procname=interpun )
+ CALL Agrif_Init_Variable(vini_id , procname=interpvn )
+ use_sign_north = .FALSE.
+
+ Agrif_UseSpecialValue = .FALSE.
+ l_ini_child = .FALSE.
+
+ Krhs_a = Kaa ; Kmm_a = Kmm
+
+ DO jn = 1, jpts
+ ts(:,:,:,jn,Kbb) = ts(:,:,:,jn,Kbb)*tmask(:,:,:)
+ END DO
+ uu(:,:,:,Kbb) = uu(:,:,:,Kbb) * umask(:,:,:)
+ vv(:,:,:,Kbb) = vv(:,:,:,Kbb) * vmask(:,:,:)
+
+
+ CALL lbc_lnk_multi( 'agrif_istate', uu(:,:,: ,Kbb), 'U', -1.0_wp , vv(:,:,:,Kbb), 'V', -1.0_wp )
+ CALL lbc_lnk( 'agrif_istate', ts(:,:,:,:,Kbb), 'T', 1.0_wp )
+
+ END SUBROUTINE Agrif_Istate
+
+
+ SUBROUTINE agrif_declare_var_ini
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE agrif_declare_var_ini ***
+ !!----------------------------------------------------------------------
+ USE agrif_util
+ USE agrif_oce
+ USE par_oce
+ USE zdf_oce
+ USE oce
+ USE dom_oce
!
IMPLICIT NONE
!
INTEGER :: ind1, ind2, ind3
- !!----------------------------------------------------------------------
+ INTEGER :: its
+ External :: nemo_mapping
+ !!----------------------------------------------------------------------
+
+! In case of East-West periodicity, prevent AGRIF interpolation at east and west boundaries
+! The procnames will not be called at these boundaries
+ IF (jperio == 1) THEN
+ CALL Agrif_Set_NearCommonBorderX(.TRUE.)
+ CALL Agrif_Set_DistantCommonBorderX(.TRUE.)
+ ENDIF
+
+ IF ( .NOT. lk_south ) THEN
+ CALL Agrif_Set_NearCommonBorderY(.TRUE.)
+ ENDIF
! 1. Declaration of the type of variable which have to be interpolated
!---------------------------------------------------------------------
- ind1 = nbghostcells
- ind2 = 1 + nbghostcells
- ind3 = 2 + nbghostcells
- CALL agrif_declare_variable((/1,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),e1u_id)
- CALL agrif_declare_variable((/2,1/),(/ind3,ind2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),e2v_id)
-
+ ind1 = nbghostcells
+ ind2 = nn_hls + 2 + nbghostcells_x
+ ind3 = nn_hls + 2 + nbghostcells_y_s
+
+ CALL agrif_declare_variable((/2,2,0 /),(/ind2 ,ind3,0 /),(/'x','y','N' /),(/1,1,1 /),(/jpi,jpj,jpk /), e3t_id)
+ CALL agrif_declare_variable((/2,2 /),(/ind2 ,ind3 /),(/'x','y' /),(/1,1 /),(/jpi,jpj /), mbkt_id)
+ CALL agrif_declare_variable((/2,2 /),(/ind2 ,ind3 /),(/'x','y' /),(/1,1 /),(/jpi,jpj /), ht0_id)
+
+ CALL agrif_declare_variable((/1,2 /),(/ind2-1,ind3 /),(/'x','y' /),(/1,1 /),(/jpi,jpj /), e1u_id)
+ CALL agrif_declare_variable((/2,1 /),(/ind2 ,ind3-1 /),(/'x','y' /),(/1,1 /),(/jpi,jpj /), e2v_id)
+
+ ! Initial or restart velues
+ its = jpts+1
+ CALL agrif_declare_variable((/2,2,0,0/),(/ind2 ,ind3 ,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,its/), tsini_id)
+ CALL agrif_declare_variable((/1,2,0,0/),(/ind2-1,ind3 ,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,2 /), uini_id)
+ CALL agrif_declare_variable((/2,1,0,0/),(/ind2 ,ind3-1,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,2 /), vini_id)
+ CALL agrif_declare_variable((/2,2 /),(/ind2 ,ind3 /),(/'x','y' /),(/1,1 /),(/jpi,jpj /),sshini_id)
+ !
+
! 2. Type of interpolation
!-------------------------
- CALL Agrif_Set_bcinterp( e1u_id, interp1=Agrif_linear, interp2=AGRIF_ppm )
- CALL Agrif_Set_bcinterp( e2v_id, interp1=AGRIF_ppm , interp2=Agrif_linear )
-
- ! 3. Location of interpolation
+ CALL Agrif_Set_bcinterp( e3t_id,interp =AGRIF_constant)
+
+ CALL Agrif_Set_bcinterp( mbkt_id,interp =AGRIF_constant)
+ CALL Agrif_Set_interp ( mbkt_id,interp =AGRIF_constant)
+ CALL Agrif_Set_bcinterp( ht0_id,interp =AGRIF_constant)
+ CALL Agrif_Set_interp ( ht0_id,interp =AGRIF_constant)
+
+ CALL Agrif_Set_bcinterp( e1u_id,interp1=Agrif_linear, interp2=AGRIF_ppm )
+ CALL Agrif_Set_bcinterp( e2v_id,interp1=AGRIF_ppm , interp2=Agrif_linear )
+
+ ! Initial fields
+ CALL Agrif_Set_bcinterp( tsini_id,interp =AGRIF_linear )
+ CALL Agrif_Set_interp ( tsini_id,interp =AGRIF_linear )
+ CALL Agrif_Set_bcinterp( uini_id,interp =AGRIF_linear )
+ CALL Agrif_Set_interp ( uini_id,interp =AGRIF_linear )
+ CALL Agrif_Set_bcinterp( vini_id,interp =AGRIF_linear )
+ CALL Agrif_Set_interp ( vini_id,interp =AGRIF_linear )
+ CALL Agrif_Set_bcinterp(sshini_id,interp =AGRIF_linear )
+ CALL Agrif_Set_interp (sshini_id,interp =AGRIF_linear )
+
+ ! 3. Location of interpolation
!-----------------------------
- CALL Agrif_Set_bc(e1u_id,(/0,ind1-1/))
- CALL Agrif_Set_bc(e2v_id,(/0,ind1-1/))
+! CALL Agrif_Set_bc( e3t_id, (/-nn_sponge_len*Agrif_irhox(),ind1-1/) )
+! JC: check near the boundary only until matching in sponge has been sorted out:
+ CALL Agrif_Set_bc( e3t_id, (/0,ind1-1/) )
+
+ ! extend the interpolation zone by 1 more point than necessary:
+ ! RB check here
+ CALL Agrif_Set_bc( mbkt_id, (/-nn_sponge_len*Agrif_irhox()-2,ind1/) )
+ CALL Agrif_Set_bc( ht0_id, (/-nn_sponge_len*Agrif_irhox()-2,ind1/) )
+
+ CALL Agrif_Set_bc( e1u_id, (/0,ind1-1/) )
+ CALL Agrif_Set_bc( e2v_id, (/0,ind1-1/) )
+
+ CALL Agrif_Set_bc( tsini_id, (/0,ind1-1/) ) ! if west, rhox=3 and nbghost=3: columns 2 to 4
+ CALL Agrif_Set_bc( uini_id, (/0,ind1-1/) )
+ CALL Agrif_Set_bc( vini_id, (/0,ind1-1/) )
+ CALL Agrif_Set_bc( sshini_id, (/0,ind1-1/) )
! 4. Update type
!---------------
# if defined UPD_HIGH
- CALL Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Average, update2=Agrif_Update_Full_Weighting)
- CALL Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Full_Weighting, update2=Agrif_Update_Average)
+ CALL Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Average , update2=Agrif_Update_Full_Weighting)
+ CALL Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Full_Weighting, update2=Agrif_Update_Average )
#else
- CALL Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Copy, update2=Agrif_Update_Average)
- CALL Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Average, update2=Agrif_Update_Copy)
+ CALL Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Copy , update2=Agrif_Update_Average )
+ CALL Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Average , update2=Agrif_Update_Copy )
#endif
-
- END SUBROUTINE agrif_declare_var_dom
-
- SUBROUTINE Agrif_InitValues_cont
- !!----------------------------------------------------------------------
- !! *** ROUTINE Agrif_InitValues_cont ***
- !!----------------------------------------------------------------------
- USE agrif_oce
+
+ ! CALL Agrif_Set_ExternalMapping(nemo_mapping)
+ !
+ END SUBROUTINE agrif_declare_var_ini
+
+
+ SUBROUTINE Agrif_Init_Domain( Kbb, Kmm, Kaa )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE Agrif_Init_Domain ***
+ !!----------------------------------------------------------------------
+ USE agrif_oce_update
USE agrif_oce_interp
USE agrif_oce_sponge
+ USE Agrif_Util
+ USE oce
USE dom_oce
- USE oce
+ USE zdf_oce
+ USE nemogcm
+ USE agrif_oce
+ !
+ USE lbclnk
USE lib_mpp
- USE lbclnk
- !
- IMPLICIT NONE
- !
- INTEGER :: ji, jj
+ USE in_out_manager
+ !
+ IMPLICIT NONE
+ !
+ INTEGER, INTENT(in) :: Kbb, Kmm, Kaa
+ !
LOGICAL :: check_namelist
CHARACTER(len=15) :: cl_check1, cl_check2, cl_check3, cl_check4
-#if defined key_vertical
REAL(wp), DIMENSION(jpi,jpj) :: zk ! workspace
-#endif
- !!----------------------------------------------------------------------
-
- ! 1. Declaration of the type of variable which have to be interpolated
- !---------------------------------------------------------------------
- CALL agrif_declare_var
-
- ! 2. First interpolations of potentially non zero fields
- !-------------------------------------------------------
-
-#if defined key_vertical
+ INTEGER :: ji, jj, jk
+ !!----------------------------------------------------------------------
+
+ ! CALL Agrif_Declare_Var_ini
+
+ IF( agrif_oce_alloc() > 0 ) CALL ctl_warn('agrif agrif_oce_alloc: allocation of arrays failed')
+
! Build consistent parent bathymetry and number of levels
! on the child grid
Agrif_UseSpecialValue = .FALSE.
- ht0_parent(:,:) = 0._wp
+ ht0_parent( :,:) = 0._wp
mbkt_parent(:,:) = 0
!
- CALL Agrif_Bc_variable(ht0_id ,calledweight=1.,procname=interpht0 )
- CALL Agrif_Bc_variable(mbkt_id,calledweight=1.,procname=interpmbkt)
+ ! CALL Agrif_Bc_variable(ht0_id ,calledweight=1.,procname=interpht0 )
+ ! CALL Agrif_Bc_variable(mbkt_id,calledweight=1.,procname=interpmbkt)
+ CALL Agrif_Init_Variable(ht0_id , procname=interpht0 )
+ CALL Agrif_Init_Variable(mbkt_id, procname=interpmbkt)
!
! Assume step wise change of bathymetry near interface
! TODO: Switch to linear interpolation of bathymetry in the s-coordinate case
! and no refinement
- DO_2D_10_10
- 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) )
+ DO_2D( 1, 0, 1, 0 )
+ 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
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
hu0_parent(ji,jj) = 0.5_wp * ( ht0_parent(ji,jj)+ht0_parent(ji+1,jj) )
hv0_parent(ji,jj) = 0.5_wp * ( ht0_parent(ji,jj)+ht0_parent(ji,jj+1) )
END_2D
ELSE
- DO_2D_10_10
- hu0_parent(ji,jj) = MIN( ht0_parent(ji,jj), ht0_parent(ji+1,jj))
- hv0_parent(ji,jj) = MIN( ht0_parent(ji,jj), ht0_parent(ji,jj+1))
+ DO_2D( 1, 0, 1, 0 )
+ hu0_parent(ji,jj) = MIN( ht0_parent(ji,jj), ht0_parent(ji+1,jj) )
+ hv0_parent(ji,jj) = MIN( ht0_parent(ji,jj), ht0_parent(ji,jj+1) )
END_2D
-
- ENDIF
- !
- CALL lbc_lnk( 'Agrif_InitValues_cont', hu0_parent, 'U', 1. )
- CALL lbc_lnk( 'Agrif_InitValues_cont', hv0_parent, 'V', 1. )
- zk(:,:) = REAL( mbku_parent(:,:), wp ) ; CALL lbc_lnk( 'Agrif_InitValues_cont', zk, 'U', 1. )
+ ENDIF
+ !
+ CALL lbc_lnk_multi( 'Agrif_Init_Domain', hu0_parent, 'U', 1.0_wp, hv0_parent, 'V', 1.0_wp )
+ DO_2D( 0, 0, 0, 0 )
+ zk(ji,jj) = REAL( mbku_parent(ji,jj), wp )
+ END_2D
+ CALL lbc_lnk( 'Agrif_InitValues_cont', zk, 'U', 1.0_wp )
mbku_parent(:,:) = MAX( NINT( zk(:,:) ), 1 )
- zk(:,:) = REAL( mbkv_parent(:,:), wp ) ; CALL lbc_lnk( 'Agrif_InitValues_cont', zk, 'V', 1. )
+ DO_2D( 0, 0, 0, 0 )
+ zk(ji,jj) = REAL( mbkv_parent(ji,jj), wp )
+ END_2D
+ CALL lbc_lnk( 'Agrif_InitValues_cont', zk, 'V', 1.0_wp )
mbkv_parent(:,:) = MAX( NINT( zk(:,:) ), 1 )
-#endif
-
+
+ IF ( ln_init_chfrpar ) THEN
+ CALL Agrif_Init_Variable(sshini_id, procname=agrif_initssh)
+ CALL lbc_lnk( 'Agrif_Init_Domain', ssh(:,:,Kbb), 'T', 1. )
+ DO jk = 1, jpk
+ e3t(:,:,jk,Kbb) = e3t_0(:,:,jk) * ( ht_0(:,:) + ssh(:,:,Kbb) ) &
+ & / ( ht_0(:,:) + 1._wp - ssmask(:,:) ) * tmask(:,:,jk) &
+ & + e3t_0(:,:,jk) * ( 1._wp - tmask(:,:,jk) )
+ END DO
+ ENDIF
+
+ ! check if masks and bathymetries match
+ IF(ln_chk_bathy) THEN
+ Agrif_UseSpecialValue = .FALSE.
+ !
+ IF(lwp) WRITE(numout,*) ' '
+ IF(lwp) WRITE(numout,*) 'AGRIF: Check Bathymetry and masks near bdys. Level: ', Agrif_Level()
+ !
+ kindic_agr = 0
+ IF( .NOT. l_vremap ) THEN
+ !
+ ! check if tmask and vertical scale factors agree with parent in sponge area:
+ CALL Agrif_Bc_variable(e3t_id,calledweight=1.,procname=interpe3t)
+ !
+ ELSE
+ !
+ ! In case of vertical interpolation, check only that total depths agree between child and parent:
+ DO ji = 1, jpi
+ DO jj = 1, jpj
+ IF ((mbkt_parent(ji,jj)/=0).AND.(ABS(ht0_parent(ji,jj)-ht_0(ji,jj))>1.e-3)) kindic_agr = kindic_agr + 1
+ IF ((mbku_parent(ji,jj)/=0).AND.(ABS(hu0_parent(ji,jj)-hu_0(ji,jj))>1.e-3)) kindic_agr = kindic_agr + 1
+ IF ((mbkv_parent(ji,jj)/=0).AND.(ABS(hv0_parent(ji,jj)-hv_0(ji,jj))>1.e-3)) kindic_agr = kindic_agr + 1
+ END DO
+ END DO
+
+ CALL mpp_sum( 'agrif_user', kindic_agr )
+ IF( kindic_agr /= 0 ) THEN
+ CALL ctl_stop('==> Child Bathymetry is NOT correct near boundaries.')
+ ELSE
+ IF(lwp) WRITE(numout,*) '==> Child Bathymetry is ok near boundaries.'
+ IF(lwp) WRITE(numout,*) ' '
+ ENDIF
+ ENDIF
+ ENDIF
+
+ IF( l_vremap ) THEN
+ ! Additional constrain that should be removed someday:
+ IF ( Agrif_Parent(jpk).GT.jpk ) THEN
+ CALL ctl_stop( ' With l_vremap, child grids must have jpk greater or equal to the parent value' )
+ ENDIF
+ ENDIF
+ !
+ END SUBROUTINE Agrif_Init_Domain
+
+
+ SUBROUTINE Agrif_InitValues_cont
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE Agrif_InitValues_cont ***
+ !!
+ !! ** Purpose :: Declaration of variables to be interpolated
+ !!----------------------------------------------------------------------
+ USE agrif_oce_update
+ USE agrif_oce_interp
+ USE agrif_oce_sponge
+ USE Agrif_Util
+ USE oce
+ USE dom_oce
+ USE zdf_oce
+ USE nemogcm
+ USE agrif_oce
+ !
+ USE lbclnk
+ USE lib_mpp
+ USE in_out_manager
+ !
+ IMPLICIT NONE
+ !
+ LOGICAL :: check_namelist
+ CHARACTER(len=15) :: cl_check1, cl_check2, cl_check3, cl_check4
+ REAL(wp), DIMENSION(jpi,jpj) :: zk ! workspace
+ INTEGER :: ji, jj
+
+ ! 1. Declaration of the type of variable which have to be interpolated
+ !---------------------------------------------------------------------
+ CALL agrif_declare_var
+
+ ! 2. First interpolations of potentially non zero fields
+ !-------------------------------------------------------
Agrif_SpecialValue = 0._wp
Agrif_UseSpecialValue = .TRUE.
- CALL Agrif_Bc_variable(tsn_id,calledweight=1.,procname=interptsn)
+ CALL Agrif_Bc_variable( tsn_id,calledweight=1.,procname=interptsn)
CALL Agrif_Sponge
tabspongedone_tsn = .FALSE.
CALL Agrif_Bc_variable(tsn_sponge_id,calledweight=1.,procname=interptsn_sponge)
- ! reset ts(:,:,:,:,Krhs_a) to zero
+ ! reset tsa to zero
ts(:,:,:,:,Krhs_a) = 0._wp
Agrif_UseSpecialValue = ln_spc_dyn
+ use_sign_north = .TRUE.
+ sign_north = -1.
CALL Agrif_Bc_variable(un_interp_id,calledweight=1.,procname=interpun)
CALL Agrif_Bc_variable(vn_interp_id,calledweight=1.,procname=interpvn)
@@ -175,4 +392,5 @@
tabspongedone_v = .FALSE.
CALL Agrif_Bc_variable(vn_sponge_id,calledweight=1.,procname=interpvn_sponge)
+ use_sign_north = .FALSE.
uu(:,:,:,Krhs_a) = 0._wp
vv(:,:,:,Krhs_a) = 0._wp
@@ -185,43 +403,20 @@
IF ( ln_dynspg_ts ) THEN
Agrif_UseSpecialValue = ln_spc_dyn
- CALL Agrif_Bc_variable(unb_id,calledweight=1.,procname=interpunb)
- CALL Agrif_Bc_variable(vnb_id,calledweight=1.,procname=interpvnb)
+ use_sign_north = .TRUE.
+ sign_north = -1.
+ CALL Agrif_Bc_variable( unb_id,calledweight=1.,procname=interpunb )
+ CALL Agrif_Bc_variable( vnb_id,calledweight=1.,procname=interpvnb )
CALL Agrif_Bc_variable(ub2b_interp_id,calledweight=1.,procname=interpub2b)
CALL Agrif_Bc_variable(vb2b_interp_id,calledweight=1.,procname=interpvb2b)
+ use_sign_north = .FALSE.
ubdy(:,:) = 0._wp
vbdy(:,:) = 0._wp
ENDIF
-
- Agrif_UseSpecialValue = .FALSE.
-
- ! 3. Some controls
+ Agrif_UseSpecialValue = .FALSE.
+
!-----------------
check_namelist = .TRUE.
IF( check_namelist ) THEN
-
- ! Check time steps
- IF( NINT(Agrif_Rhot()) * NINT(rn_Dt) .NE. Agrif_Parent(rn_Dt) ) THEN
- WRITE(cl_check1,*) NINT(Agrif_Parent(rn_Dt))
- WRITE(cl_check2,*) NINT(rn_Dt)
- WRITE(cl_check3,*) NINT(Agrif_Parent(rn_Dt)/Agrif_Rhot())
- CALL ctl_stop( 'Incompatible time step between ocean grids', &
- & 'parent grid value : '//cl_check1 , &
- & 'child grid value : '//cl_check2 , &
- & 'value on child grid should be changed to : '//cl_check3 )
- ENDIF
-
- ! Check run length
- IF( Agrif_IRhot() * (Agrif_Parent(nitend)- &
- Agrif_Parent(nit000)+1) .NE. (nitend-nit000+1) ) THEN
- WRITE(cl_check1,*) (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1
- WRITE(cl_check2,*) Agrif_Parent(nitend) *Agrif_IRhot()
- CALL ctl_warn( 'Incompatible run length between grids' , &
- & 'nit000 on fine grid will be changed to : '//cl_check1, &
- & 'nitend on fine grid will be changed to : '//cl_check2 )
- nit000 = (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1
- nitend = Agrif_Parent(nitend) *Agrif_IRhot()
- ENDIF
-
! Check free surface scheme
IF ( ( Agrif_Parent(ln_dynspg_ts ).AND.ln_dynspg_exp ).OR.&
@@ -251,48 +446,6 @@
STOP
ENDIF
-
- ENDIF
-
- ! check if masks and bathymetries match
- IF(ln_chk_bathy) THEN
- Agrif_UseSpecialValue = .FALSE.
- !
- IF(lwp) WRITE(numout,*) ' '
- IF(lwp) WRITE(numout,*) 'AGRIF: Check Bathymetry and masks near bdys. Level: ', Agrif_Level()
- !
- kindic_agr = 0
-# if ! defined key_vertical
- !
- ! check if tmask and vertical scale factors agree with parent in sponge area:
- CALL Agrif_Bc_variable(e3t_id,calledweight=1.,procname=interpe3t)
- !
-# else
- !
- ! In case of vertical interpolation, check only that total depths agree between child and parent:
- DO ji = 1, jpi
- DO jj = 1, jpj
- IF ((mbkt_parent(ji,jj)/=0).AND.(ABS(ht0_parent(ji,jj)-ht_0(ji,jj))>1.e-3)) kindic_agr = kindic_agr + 1
- IF ((mbku_parent(ji,jj)/=0).AND.(ABS(hu0_parent(ji,jj)-hu_0(ji,jj))>1.e-3)) kindic_agr = kindic_agr + 1
- IF ((mbkv_parent(ji,jj)/=0).AND.(ABS(hv0_parent(ji,jj)-hv_0(ji,jj))>1.e-3)) kindic_agr = kindic_agr + 1
- END DO
- END DO
-# endif
- CALL mpp_sum( 'agrif_user', kindic_agr )
- IF( kindic_agr /= 0 ) THEN
- CALL ctl_stop('==> Child Bathymetry is NOT correct near boundaries.')
- ELSE
- IF(lwp) WRITE(numout,*) '==> Child Bathymetry is ok near boundaries.'
- IF(lwp) WRITE(numout,*) ' '
- END IF
- !
- ENDIF
-
-# if defined key_vertical
- ! Additional constrain that should be removed someday:
- IF ( Agrif_Parent(jpk).GT.jpk ) THEN
- CALL ctl_stop( ' With key_vertical, child grids must have jpk greater or equal to the parent value' )
- ENDIF
-# endif
- !
+ ENDIF
+
END SUBROUTINE Agrif_InitValues_cont
@@ -314,71 +467,63 @@
! 1. Declaration of the type of variable which have to be interpolated
!---------------------------------------------------------------------
- ind1 = nbghostcells
- ind2 = 1 + nbghostcells
- ind3 = 2 + nbghostcells
+ ind1 = nbghostcells
+ ind2 = nn_hls + 2 + nbghostcells_x
+ ind3 = nn_hls + 2 + nbghostcells_y_s
# if defined key_vertical
- CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts+1/),tsn_id)
- CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts+1/),tsn_sponge_id)
-
- CALL agrif_declare_variable((/1,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),un_interp_id)
- CALL agrif_declare_variable((/2,1,0,0/),(/ind3,ind2,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),vn_interp_id)
- CALL agrif_declare_variable((/1,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),un_update_id)
- CALL agrif_declare_variable((/2,1,0,0/),(/ind3,ind2,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),vn_update_id)
- CALL agrif_declare_variable((/1,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),un_sponge_id)
- CALL agrif_declare_variable((/2,1,0,0/),(/ind3,ind2,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),vn_sponge_id)
+ CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts+1/),tsn_id)
+ CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts+1/),tsn_sponge_id)
+ CALL agrif_declare_variable((/1,2,0,0/),(/ind2-1,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,2/),un_interp_id)
+ CALL agrif_declare_variable((/2,1,0,0/),(/ind2,ind3-1,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,2/),vn_interp_id)
+ CALL agrif_declare_variable((/1,2,0,0/),(/ind2-1,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,2/),un_update_id)
+ CALL agrif_declare_variable((/2,1,0,0/),(/ind2,ind3-1,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,2/),vn_update_id)
+ CALL agrif_declare_variable((/1,2,0,0/),(/ind2-1,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,2/),un_sponge_id)
+ CALL agrif_declare_variable((/2,1,0,0/),(/ind2,ind3-1,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,2/),vn_sponge_id)
# else
- CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts/),tsn_id)
- CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts/),tsn_sponge_id)
-
- CALL agrif_declare_variable((/1,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),un_interp_id)
- CALL agrif_declare_variable((/2,1,0,0/),(/ind3,ind2,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),vn_interp_id)
- CALL agrif_declare_variable((/1,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),un_update_id)
- CALL agrif_declare_variable((/2,1,0,0/),(/ind3,ind2,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),vn_update_id)
- CALL agrif_declare_variable((/1,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),un_sponge_id)
- CALL agrif_declare_variable((/2,1,0,0/),(/ind3,ind2,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),vn_sponge_id)
+ CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts/),tsn_id)
+ CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts/),tsn_sponge_id)
+ CALL agrif_declare_variable((/1,2,0,0/),(/ind2-1,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,1/),un_interp_id)
+ CALL agrif_declare_variable((/2,1,0,0/),(/ind2,ind3-1,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,1/),vn_interp_id)
+ CALL agrif_declare_variable((/1,2,0,0/),(/ind2-1,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,1/),un_update_id)
+ CALL agrif_declare_variable((/2,1,0,0/),(/ind2,ind3-1,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,1/),vn_update_id)
+ CALL agrif_declare_variable((/1,2,0,0/),(/ind2-1,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,1/),un_sponge_id)
+ CALL agrif_declare_variable((/2,1,0,0/),(/ind2,ind3-1,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,1/),vn_sponge_id)
# endif
-
- CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),e3t_id)
-
+ CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),unb_id)
+ CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/jpi,jpj/),vnb_id)
+ CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),ub2b_interp_id)
+ CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/jpi,jpj/),vb2b_interp_id)
+ CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),ub2b_update_id)
+ CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/jpi,jpj/),vb2b_update_id)
+
+! CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),glamt_id)
+! CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),gphit_id)
+ CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),sshn_id)
+
+
+ IF( ln_zdftke.OR.ln_zdfgls ) THEN ! logical not known at this point
+! CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/), en_id)
+! CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avt_id)
# if defined key_vertical
- CALL agrif_declare_variable((/2,2/),(/ind3,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),mbkt_id)
- CALL agrif_declare_variable((/2,2/),(/ind3,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ht0_id)
+ CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,2/),avm_id)
+# else
+ CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,1/),avm_id)
# endif
-
- CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,3/),scales_t_id)
-
- CALL agrif_declare_variable((/1,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),unb_id)
- CALL agrif_declare_variable((/2,1/),(/ind3,ind2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vnb_id)
- CALL agrif_declare_variable((/1,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ub2b_interp_id)
- CALL agrif_declare_variable((/2,1/),(/ind3,ind2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vb2b_interp_id)
- CALL agrif_declare_variable((/1,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ub2b_update_id)
- CALL agrif_declare_variable((/2,1/),(/ind3,ind2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vb2b_update_id)
-
- CALL agrif_declare_variable((/2,2/),(/ind3,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),sshn_id)
-
- IF( ln_zdftke.OR.ln_zdfgls ) THEN
-! CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/), en_id)
-! CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),avt_id)
-# if defined key_vertical
- CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),avm_id)
-# else
- CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),avm_id)
-# endif
- ENDIF
-
+ ENDIF
+
! 2. Type of interpolation
!-------------------------
- CALL Agrif_Set_bcinterp(tsn_id,interp=AGRIF_linear)
-
- CALL Agrif_Set_bcinterp(un_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm)
- CALL Agrif_Set_bcinterp(vn_interp_id,interp1=AGRIF_ppm,interp2=Agrif_linear)
-
- CALL Agrif_Set_bcinterp(tsn_sponge_id,interp=AGRIF_linear)
-
- CALL Agrif_Set_bcinterp(sshn_id,interp=AGRIF_linear)
- CALL Agrif_Set_bcinterp(unb_id,interp1=Agrif_linear,interp2=AGRIF_ppm)
- CALL Agrif_Set_bcinterp(vnb_id,interp1=AGRIF_ppm,interp2=Agrif_linear)
- CALL Agrif_Set_bcinterp(ub2b_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm)
- CALL Agrif_Set_bcinterp(vb2b_interp_id,interp1=AGRIF_ppm,interp2=Agrif_linear)
+ CALL Agrif_Set_bcinterp( tsn_id,interp =AGRIF_linear)
+ CALL Agrif_Set_bcinterp( un_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm )
+ CALL Agrif_Set_bcinterp( vn_interp_id,interp1=AGRIF_ppm ,interp2=Agrif_linear)
+
+ CALL Agrif_Set_bcinterp( tsn_sponge_id,interp =AGRIF_linear)
+ CALL Agrif_Set_bcinterp( un_sponge_id,interp1=Agrif_linear,interp2=AGRIF_ppm )
+ CALL Agrif_Set_bcinterp( vn_sponge_id,interp1=AGRIF_ppm ,interp2=Agrif_linear)
+
+ CALL Agrif_Set_bcinterp( sshn_id,interp =AGRIF_linear)
+ CALL Agrif_Set_bcinterp( unb_id,interp1=Agrif_linear,interp2=AGRIF_ppm )
+ CALL Agrif_Set_bcinterp( vnb_id,interp1=AGRIF_ppm ,interp2=Agrif_linear)
+ CALL Agrif_Set_bcinterp(ub2b_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm )
+ CALL Agrif_Set_bcinterp(vb2b_interp_id,interp1=AGRIF_ppm ,interp2=Agrif_linear)
!
! > Divergence conserving alternative:
@@ -390,15 +535,9 @@
!<
- CALL Agrif_Set_bcinterp(un_sponge_id,interp1=Agrif_linear,interp2=AGRIF_ppm)
- CALL Agrif_Set_bcinterp(vn_sponge_id,interp1=AGRIF_ppm,interp2=Agrif_linear)
-
- CALL Agrif_Set_bcinterp(e3t_id,interp=AGRIF_constant)
-
-# if defined key_vertical
- CALL Agrif_Set_bcinterp(mbkt_id,interp=AGRIF_constant)
- CALL Agrif_Set_bcinterp(ht0_id ,interp=AGRIF_constant)
-# endif
-
- IF( ln_zdftke.OR.ln_zdfgls ) CALL Agrif_Set_bcinterp( avm_id, interp=AGRIF_linear )
+ IF( ln_zdftke.OR.ln_zdfgls ) CALL Agrif_Set_bcinterp( avm_id, interp=AGRIF_linear )
+
+
+! CALL Agrif_Set_bcinterp(gphit_id,interp=AGRIF_constant)
+! CALL Agrif_Set_bcinterp(glamt_id,interp=AGRIF_constant)
! 3. Location of interpolation
@@ -418,51 +557,42 @@
CALL Agrif_Set_bc( vb2b_interp_id, (/0,ind1-1/) )
-! CALL Agrif_Set_bc( e3t_id, (/-nn_sponge_len*Agrif_irhox(),ind1-1/) )
-! JC: check near the boundary only until matching in sponge has been sorted out:
- CALL Agrif_Set_bc( e3t_id, (/0,ind1-1/) )
-
-# if defined key_vertical
- ! extend the interpolation zone by 1 more point than necessary:
- CALL Agrif_Set_bc( mbkt_id, (/-nn_sponge_len*Agrif_irhox()-2,ind1/) )
- CALL Agrif_Set_bc( ht0_id, (/-nn_sponge_len*Agrif_irhox()-2,ind1/) )
-# endif
-
- IF( ln_zdftke.OR.ln_zdfgls ) CALL Agrif_Set_bc( avm_id, (/0,ind1/) )
+ IF( ln_zdftke.OR.ln_zdfgls ) CALL Agrif_Set_bc( avm_id, (/0,ind1/) )
+!!$ CALL Agrif_Set_bc(glamt_id, (/0,ind1-1/) )
+!!$ CALL Agrif_Set_bc(gphit_id, (/0,ind1-1/) )
! 4. Update type
!---------------
- CALL Agrif_Set_Updatetype(scales_t_id, update = AGRIF_Update_Average)
# if defined UPD_HIGH
- CALL Agrif_Set_Updatetype(tsn_id, update = Agrif_Update_Full_Weighting)
- CALL Agrif_Set_Updatetype(un_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Full_Weighting)
- CALL Agrif_Set_Updatetype(vn_update_id,update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average)
-
- CALL Agrif_Set_Updatetype(ub2b_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Full_Weighting)
- CALL Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average)
- CALL Agrif_Set_Updatetype(sshn_id,update = Agrif_Update_Full_Weighting)
- CALL Agrif_Set_Updatetype(e3t_id, update = Agrif_Update_Full_Weighting)
-
- IF( ln_zdftke.OR.ln_zdfgls ) THEN
+ CALL Agrif_Set_Updatetype( tsn_id,update = Agrif_Update_Full_Weighting)
+ CALL Agrif_Set_Updatetype(un_update_id,update1 = Agrif_Update_Average , update2 = Agrif_Update_Full_Weighting)
+ CALL Agrif_Set_Updatetype(vn_update_id,update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average )
+
+ CALL Agrif_Set_Updatetype(ub2b_update_id,update1 = Agrif_Update_Average , update2 = Agrif_Update_Full_Weighting)
+ CALL Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average )
+ CALL Agrif_Set_Updatetype( sshn_id,update = Agrif_Update_Full_Weighting)
+ CALL Agrif_Set_Updatetype( e3t_id,update = Agrif_Update_Full_Weighting)
+
+ ! IF( ln_zdftke.OR.ln_zdfgls ) THEN
! CALL Agrif_Set_Updatetype( en_id, update = AGRIF_Update_Full_Weighting)
! CALL Agrif_Set_Updatetype(avt_id, update = AGRIF_Update_Full_Weighting)
! CALL Agrif_Set_Updatetype(avm_id, update = AGRIF_Update_Full_Weighting)
- ENDIF
+ ! ENDIF
#else
- CALL Agrif_Set_Updatetype(tsn_id, update = AGRIF_Update_Average)
- CALL Agrif_Set_Updatetype(un_update_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average)
- CALL Agrif_Set_Updatetype(vn_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy)
-
- CALL Agrif_Set_Updatetype(ub2b_update_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average)
- CALL Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy)
- CALL Agrif_Set_Updatetype(sshn_id,update = AGRIF_Update_Average)
- CALL Agrif_Set_Updatetype(e3t_id, update = AGRIF_Update_Average)
-
- IF( ln_zdftke.OR.ln_zdfgls ) THEN
+ CALL Agrif_Set_Updatetype( tsn_id, update = AGRIF_Update_Average)
+ CALL Agrif_Set_Updatetype(un_update_id,update1 = Agrif_Update_Copy , update2 = Agrif_Update_Average)
+ CALL Agrif_Set_Updatetype(vn_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy )
+
+ CALL Agrif_Set_Updatetype(ub2b_update_id,update1 = Agrif_Update_Copy , update2 = Agrif_Update_Average)
+ CALL Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy )
+ CALL Agrif_Set_Updatetype( sshn_id,update = AGRIF_Update_Average)
+ CALL Agrif_Set_Updatetype( e3t_id,update = AGRIF_Update_Average)
+
+ ! IF( ln_zdftke.OR.ln_zdfgls ) THEN
! CALL Agrif_Set_Updatetype( en_id, update = AGRIF_Update_Average)
! CALL Agrif_Set_Updatetype(avt_id, update = AGRIF_Update_Average)
! CALL Agrif_Set_Updatetype(avm_id, update = AGRIF_Update_Average)
- ENDIF
+ ! ENDIF
#endif
@@ -471,5 +601,5 @@
#if defined key_si3
-SUBROUTINE Agrif_InitValues_cont_ice
+ SUBROUTINE Agrif_InitValues_cont_ice
!!----------------------------------------------------------------------
!! *** ROUTINE Agrif_InitValues_cont_ice ***
@@ -484,10 +614,6 @@
!
IMPLICIT NONE
- !!----------------------------------------------------------------------
- !
- ! Declaration of the type of variable which have to be interpolated (parent=>child)
- !----------------------------------------------------------------------------------
- CALL agrif_declare_var_ice
-
+ !
+ !!----------------------------------------------------------------------
! Controls
@@ -495,5 +621,5 @@
! the run must satisfy CFL=Uice/(dx/dt) < 0.6/nn_fsbc(child)
! therefore, if nn_fsbc(child)>1 one must reduce the time-step in proportion to nn_fsbc(child), which is not acceptable
- ! If a solution is found, the following stop could be removed because the rest of the code take nn_fsbc(child) into account
+ ! If a solution is found, the following stop could be removed because the rest of the code take nn_fsbc(child) into account
IF( nn_fsbc > 1 ) CALL ctl_stop('nn_fsbc(child) must be set to 1 otherwise agrif and sea-ice may not work properly')
@@ -512,4 +638,5 @@
END SUBROUTINE Agrif_InitValues_cont_ice
+
SUBROUTINE agrif_declare_var_ice
!!----------------------------------------------------------------------
@@ -518,9 +645,10 @@
USE Agrif_Util
USE ice
- USE par_oce, ONLY : nbghostcells
+ USE par_oce, ONLY : nbghostcells, nbghostcells_x, nbghostcells_y_s
!
IMPLICIT NONE
!
INTEGER :: ind1, ind2, ind3
+ INTEGER :: ipl
!!----------------------------------------------------------------------
!
@@ -532,10 +660,15 @@
! 2,2 = two ghost lines
!-------------------------------------------------------------------------------------
- ind1 = nbghostcells
- ind2 = 1 + nbghostcells
- ind3 = 2 + nbghostcells
- CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpl*(8+nlay_s+nlay_i)/),tra_ice_id)
- CALL agrif_declare_variable((/1,2/) ,(/ind2,ind3/) ,(/'x','y'/) ,(/1,1/) ,(/nlci,nlcj/) ,u_ice_id )
- CALL agrif_declare_variable((/2,1/) ,(/ind3,ind2/) ,(/'x','y'/) ,(/1,1/) ,(/nlci,nlcj/) ,v_ice_id )
+ ind1 = nbghostcells
+ ind2 = nn_hls + 2 + nbghostcells_x
+ ind3 = nn_hls + 2 + nbghostcells_y_s
+ ipl = jpl*(9+nlay_s+nlay_i)
+ CALL agrif_declare_variable((/2,2,0/),(/ind2,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,ipl/),tra_ice_id)
+ CALL agrif_declare_variable((/1,2/) ,(/ind2-1,ind3/),(/'x','y' /),(/1,1 /),(/jpi,jpj /), u_ice_id)
+ CALL agrif_declare_variable((/2,1/) ,(/ind2,ind3-1/),(/'x','y' /),(/1,1 /),(/jpi,jpj /), v_ice_id)
+
+ CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,ipl/),tra_iceini_id)
+ CALL agrif_declare_variable((/1,2/) ,(/ind2-1,ind3/),(/'x','y' /),(/1,1 /),(/jpi,jpj /), u_iceini_id)
+ CALL agrif_declare_variable((/2,1/) ,(/ind2,ind3-1/),(/'x','y' /),(/1,1 /),(/jpi,jpj /), v_iceini_id)
! 2. Set interpolations (normal & tangent to the grid cell for velocities)
@@ -545,4 +678,11 @@
CALL Agrif_Set_bcinterp(v_ice_id , interp1 = AGRIF_ppm ,interp2 = Agrif_linear)
+ CALL Agrif_Set_bcinterp(tra_iceini_id, interp = AGRIF_linear)
+ CALL Agrif_Set_interp (tra_iceini_id, interp = AGRIF_linear)
+ CALL Agrif_Set_bcinterp(u_iceini_id , interp = AGRIF_linear )
+ CALL Agrif_Set_interp (u_iceini_id , interp = AGRIF_linear )
+ CALL Agrif_Set_bcinterp(v_iceini_id , interp = AGRIF_linear)
+ CALL Agrif_Set_interp (v_iceini_id , interp = AGRIF_linear)
+
! 3. Set location of interpolations
!----------------------------------
@@ -550,4 +690,8 @@
CALL Agrif_Set_bc(u_ice_id ,(/0,ind1/))
CALL Agrif_Set_bc(v_ice_id ,(/0,ind1/))
+
+ CALL Agrif_Set_bc(tra_iceini_id,(/0,ind1/))
+ CALL Agrif_Set_bc(u_iceini_id ,(/0,ind1/))
+ CALL Agrif_Set_bc(v_iceini_id ,(/0,ind1/))
! 4. Set update type in case 2 ways (child=>parent) (normal & tangent to the grid cell for velocities)
@@ -557,9 +701,9 @@
CALL Agrif_Set_Updatetype(u_ice_id , update1 = Agrif_Update_Average , update2 = Agrif_Update_Full_Weighting)
CALL Agrif_Set_Updatetype(v_ice_id , update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average )
-#else
+# else
CALL Agrif_Set_Updatetype(tra_ice_id, update = AGRIF_Update_Average)
CALL Agrif_Set_Updatetype(u_ice_id , update1 = Agrif_Update_Copy , update2 = Agrif_Update_Average)
CALL Agrif_Set_Updatetype(v_ice_id , update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy )
-#endif
+# endif
END SUBROUTINE agrif_declare_var_ice
@@ -584,5 +728,5 @@
USE agrif_top_interp
USE agrif_top_sponge
- !!
+ !
IMPLICIT NONE
!
@@ -604,6 +748,6 @@
tabspongedone_trn = .FALSE.
CALL Agrif_Bc_variable(trn_sponge_id,calledweight=1.,procname=interptrn_sponge)
- ! reset ts(:,:,:,:,Krhs_a) to zero
- tr(:,:,:,:,Krhs_a) = 0._wp
+ ! reset tsa to zero
+ tra(:,:,:,:) = 0._wp
! 3. Some controls
@@ -613,29 +757,28 @@
IF( check_namelist ) THEN
! Check time steps
- IF( NINT(Agrif_Rhot()) * NINT(rn_Dt) .NE. Agrif_Parent(rn_Dt) ) THEN
- WRITE(cl_check1,*) Agrif_Parent(rn_Dt)
- WRITE(cl_check2,*) rn_Dt
- WRITE(cl_check3,*) rn_Dt*Agrif_Rhot()
- CALL ctl_stop( 'incompatible time step between grids', &
+ IF( NINT(Agrif_Rhot()) * NINT(rdt) .NE. Agrif_Parent(rdt) ) THEN
+ WRITE(cl_check1,*) Agrif_Parent(rdt)
+ WRITE(cl_check2,*) rdt
+ WRITE(cl_check3,*) rdt*Agrif_Rhot()
+ CALL ctl_stop( 'incompatible time step between grids', &
& 'parent grid value : '//cl_check1 , &
& 'child grid value : '//cl_check2 , &
& 'value on child grid should be changed to &
& :'//cl_check3 )
- ENDIF
-
- ! Check run length
- IF( Agrif_IRhot() * (Agrif_Parent(nitend)- &
+ ENDIF
+
+ ! Check run length
+ IF( Agrif_IRhot() * (Agrif_Parent(nitend)- &
Agrif_Parent(nit000)+1) .NE. (nitend-nit000+1) ) THEN
- WRITE(cl_check1,*) (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1
- WRITE(cl_check2,*) Agrif_Parent(nitend) *Agrif_IRhot()
- CALL ctl_warn( 'incompatible run length between grids' , &
+ WRITE(cl_check1,*) (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1
+ WRITE(cl_check2,*) Agrif_Parent(nitend) *Agrif_IRhot()
+ CALL ctl_warn( 'incompatible run length between grids' , &
& ' nit000 on fine grid will be change to : '//cl_check1, &
& ' nitend on fine grid will be change to : '//cl_check2 )
- nit000 = (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1
- nitend = Agrif_Parent(nitend) *Agrif_IRhot()
- ENDIF
-
- ENDIF
- !
+ nit000 = (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1
+ nitend = Agrif_Parent(nitend) *Agrif_IRhot()
+ ENDIF
+ ENDIF
+ !
END SUBROUTINE Agrif_InitValues_cont_top
@@ -654,16 +797,17 @@
INTEGER :: ind1, ind2, ind3
!!----------------------------------------------------------------------
-
+!RB_CMEMS : declare here init for top
! 1. Declaration of the type of variable which have to be interpolated
!---------------------------------------------------------------------
- ind1 = nbghostcells
- ind2 = 1 + nbghostcells
- ind3 = 2 + nbghostcells
+ ind1 = nbghostcells
+ ind2 = nn_hls + 2 + nbghostcells_x
+ ind3 = nn_hls + 2 + nbghostcells_y_s
# if defined key_vertical
- CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra+1/),trn_id)
- CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra+1/),trn_sponge_id)
+ CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra+1/),trn_id)
+ CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra+1/),trn_sponge_id)
# else
- CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra/),trn_id)
- CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra/),trn_sponge_id)
+! LAURENT: STRANGE why (3,3) here ?
+ CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra/),trn_id)
+ CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra/),trn_sponge_id)
# endif
@@ -688,4 +832,5 @@
END SUBROUTINE agrif_declare_var_top
# endif
+
SUBROUTINE Agrif_detect( kg, ksizex )
@@ -701,4 +846,5 @@
END SUBROUTINE Agrif_detect
+
SUBROUTINE agrif_nemo_init
!!----------------------------------------------------------------------
@@ -707,11 +853,12 @@
USE agrif_oce
USE agrif_ice
+ USE dom_oce
USE in_out_manager
USE lib_mpp
- !!
+ !
IMPLICIT NONE
!
INTEGER :: ios ! Local integer output status for namelist read
- NAMELIST/namagrif/ ln_agrif_2way, rn_sponge_tra, rn_sponge_dyn, rn_trelax_tra, rn_trelax_dyn, &
+ NAMELIST/namagrif/ ln_agrif_2way, ln_init_chfrpar, rn_sponge_tra, rn_sponge_dyn, rn_trelax_tra, rn_trelax_dyn, &
& ln_spc_dyn, ln_chk_bathy
!!--------------------------------------------------------------------------------------
@@ -729,19 +876,37 @@
WRITE(numout,*) ' Namelist namagrif : set AGRIF parameters'
WRITE(numout,*) ' Two way nesting activated ln_agrif_2way = ', ln_agrif_2way
- WRITE(numout,*) ' sponge coefficient for tracers rn_sponge_tra = ', rn_sponge_tra, ' m^2/s'
- WRITE(numout,*) ' sponge coefficient for dynamics rn_sponge_tra = ', rn_sponge_dyn, ' m^2/s'
- WRITE(numout,*) ' time relaxation for tracers rn_trelax_tra = ', rn_trelax_tra, ' ad.'
- WRITE(numout,*) ' time relaxation for dynamics rn_trelax_dyn = ', rn_trelax_dyn, ' ad.'
+ WRITE(numout,*) ' child initial state from parent ln_init_chfrpar = ', ln_init_chfrpar
+ WRITE(numout,*) ' ad. sponge coeft for tracers rn_sponge_tra = ', rn_sponge_tra
+ WRITE(numout,*) ' ad. sponge coeft for dynamics rn_sponge_tra = ', rn_sponge_dyn
+ WRITE(numout,*) ' ad. time relaxation for tracers rn_trelax_tra = ', rn_trelax_tra
+ WRITE(numout,*) ' ad. time relaxation for dynamics rn_trelax_dyn = ', rn_trelax_dyn
WRITE(numout,*) ' use special values for dynamics ln_spc_dyn = ', ln_spc_dyn
WRITE(numout,*) ' check bathymetry ln_chk_bathy = ', ln_chk_bathy
ENDIF
- !
- !
- IF( agrif_oce_alloc() > 0 ) CALL ctl_warn('agrif agrif_oce_alloc: allocation of arrays failed')
+
+ lk_west = .NOT. ( Agrif_Ix() == 1 )
+ lk_east = .NOT. ( Agrif_Ix() + nbcellsx/AGRIF_Irhox() == Agrif_Parent(jpiglo) -1 )
+ lk_south = .NOT. ( Agrif_Iy() == 1 )
+ lk_north = .NOT. ( Agrif_Iy() + nbcellsy/AGRIF_Irhoy() == Agrif_Parent(jpjglo) -1 )
+
+ !
+ ! Set the number of ghost cells according to periodicity
+ nbghostcells_x = nbghostcells
+ nbghostcells_y_s = nbghostcells
+ nbghostcells_y_n = nbghostcells
+ !
+ IF( jperio == 1 ) nbghostcells_x = 0
+ IF( .NOT. lk_south ) nbghostcells_y_s = 0
+ ! Some checks
+ IF( jpiglo /= nbcellsx + 2 + 2*nn_hls + nbghostcells_x + nbghostcells_x ) CALL ctl_stop( 'STOP', &
+ & 'agrif_nemo_init: Agrif children requires jpiglo == nbcellsx + 2 + 2*nn_hls + 2*nbghostcells_x' )
+ IF( jpjglo /= nbcellsy + 2 + 2*nn_hls + nbghostcells_y_s + nbghostcells_y_n ) CALL ctl_stop( 'STOP', &
+ & 'agrif_nemo_init: Agrif children requires jpjglo == nbcellsy + 2 + 2*nn_hls + nbghostcells_y_s + nbghostcells_y_n' )
+ IF( ln_use_jattr ) CALL ctl_stop( 'STOP', 'agrif_nemo_init:Agrif children requires ln_use_jattr = .false. ' )
!
END SUBROUTINE agrif_nemo_init
+
# if defined key_mpp_mpi
-
SUBROUTINE Agrif_InvLoc( indloc, nprocloc, i, indglob )
!!----------------------------------------------------------------------
@@ -756,12 +921,12 @@
!
SELECT CASE( i )
- CASE(1) ; indglob = indloc + nimppt(nprocloc+1) - 1
- CASE(2) ; indglob = indloc + njmppt(nprocloc+1) - 1
- CASE DEFAULT
- indglob = indloc
+ CASE(1) ; indglob = mig(indloc)
+ CASE(2) ; indglob = mjg(indloc)
+ CASE DEFAULT ; indglob = indloc
END SELECT
!
END SUBROUTINE Agrif_InvLoc
+
SUBROUTINE Agrif_get_proc_info( imin, imax, jmin, jmax )
!!----------------------------------------------------------------------
@@ -776,11 +941,12 @@
!!----------------------------------------------------------------------
!
- imin = nimppt(Agrif_Procrank+1) ! ?????
- jmin = njmppt(Agrif_Procrank+1) ! ?????
- imax = imin + jpi - 1
- jmax = jmin + jpj - 1
+ imin = mig( 1 )
+ jmin = mjg( 1 )
+ imax = mig(jpi)
+ jmax = mjg(jpj)
!
END SUBROUTINE Agrif_get_proc_info
+
SUBROUTINE Agrif_estimate_parallel_cost(imin, imax,jmin, jmax, nbprocs, grid_cost)
!!----------------------------------------------------------------------
@@ -803,4 +969,236 @@
# endif
+ SUBROUTINE nemo_mapping(ndim,ptx,pty,bounds,bounds_chunks,correction_required,nb_chunks)
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE Nemo_mapping ***
+ !!----------------------------------------------------------------------
+ USE dom_oce
+ !!
+ IMPLICIT NONE
+ !
+ INTEGER :: ndim
+ INTEGER :: ptx, pty
+ INTEGER, DIMENSION(ndim,2,2) :: bounds
+ INTEGER, DIMENSION(:,:,:,:), ALLOCATABLE :: bounds_chunks
+ LOGICAL, DIMENSION(:), ALLOCATABLE :: correction_required
+ INTEGER :: nb_chunks
+ !
+ INTEGER :: i
+
+ IF (agrif_debug_interp) THEN
+ DO i=1,ndim
+ WRITE(*,*) 'direction = ',i,bounds(i,1,2),bounds(i,2,2)
+ ENDDO
+ ENDIF
+
+ IF( bounds(2,2,2) > jpjglo) THEN
+ IF( bounds(2,1,2) <=jpjglo) THEN
+ nb_chunks = 2
+ ALLOCATE(bounds_chunks(nb_chunks,ndim,2,2))
+ ALLOCATE(correction_required(nb_chunks))
+ DO i = 1,nb_chunks
+ bounds_chunks(i,:,:,:) = bounds
+ END DO
+
+ ! FIRST CHUNCK (for j<=jpjglo)
+
+ ! Original indices
+ bounds_chunks(1,1,1,1) = bounds(1,1,2)
+ bounds_chunks(1,1,2,1) = bounds(1,2,2)
+ bounds_chunks(1,2,1,1) = bounds(2,1,2)
+ bounds_chunks(1,2,2,1) = jpjglo
+
+ bounds_chunks(1,1,1,2) = bounds(1,1,2)
+ bounds_chunks(1,1,2,2) = bounds(1,2,2)
+ bounds_chunks(1,2,1,2) = bounds(2,1,2)
+ bounds_chunks(1,2,2,2) = jpjglo
+
+ ! Correction required or not
+ correction_required(1)=.FALSE.
+
+ ! SECOND CHUNCK (for j>jpjglo)
+
+ ! Original indices
+ bounds_chunks(2,1,1,1) = bounds(1,1,2)
+ bounds_chunks(2,1,2,1) = bounds(1,2,2)
+ bounds_chunks(2,2,1,1) = jpjglo-2
+ bounds_chunks(2,2,2,1) = bounds(2,2,2)
+
+ ! Where to find them
+ ! We use the relation TAB(ji,jj)=TAB(jpiglo-ji+2,jpjglo-2-(jj-jpjglo))
+
+ IF( ptx == 2) THEN ! T, V points
+ bounds_chunks(2,1,1,2) = jpiglo-bounds(1,2,2)+2
+ bounds_chunks(2,1,2,2) = jpiglo-bounds(1,1,2)+2
+ ELSE ! U, F points
+ bounds_chunks(2,1,1,2) = jpiglo-bounds(1,2,2)+1
+ bounds_chunks(2,1,2,2) = jpiglo-bounds(1,1,2)+1
+ ENDIF
+
+ IF( pty == 2) THEN ! T, U points
+ bounds_chunks(2,2,1,2) = jpjglo-2-(bounds(2,2,2) -jpjglo)
+ bounds_chunks(2,2,2,2) = jpjglo-2-(jpjglo-2 -jpjglo)
+ ELSE ! V, F points
+ bounds_chunks(2,2,1,2) = jpjglo-3-(bounds(2,2,2) -jpjglo)
+ bounds_chunks(2,2,2,2) = jpjglo-3-(jpjglo-2 -jpjglo)
+ ENDIF
+ ! Correction required or not
+ correction_required(2)=.TRUE.
+
+ ELSE
+ nb_chunks = 1
+ ALLOCATE(bounds_chunks(nb_chunks,ndim,2,2))
+ ALLOCATE(correction_required(nb_chunks))
+ DO i=1,nb_chunks
+ bounds_chunks(i,:,:,:) = bounds
+ END DO
+
+ bounds_chunks(1,1,1,1) = bounds(1,1,2)
+ bounds_chunks(1,1,2,1) = bounds(1,2,2)
+ bounds_chunks(1,2,1,1) = bounds(2,1,2)
+ bounds_chunks(1,2,2,1) = bounds(2,2,2)
+
+ bounds_chunks(1,1,1,2) = jpiglo-bounds(1,2,2)+2
+ bounds_chunks(1,1,2,2) = jpiglo-bounds(1,1,2)+2
+
+ bounds_chunks(1,2,1,2) = jpjglo-2-(bounds(2,2,2)-jpjglo)
+ bounds_chunks(1,2,2,2) = jpjglo-2-(bounds(2,1,2)-jpjglo)
+
+ IF( ptx == 2) THEN ! T, V points
+ bounds_chunks(1,1,1,2) = jpiglo-bounds(1,2,2)+2
+ bounds_chunks(1,1,2,2) = jpiglo-bounds(1,1,2)+2
+ ELSE ! U, F points
+ bounds_chunks(1,1,1,2) = jpiglo-bounds(1,2,2)+1
+ bounds_chunks(1,1,2,2) = jpiglo-bounds(1,1,2)+1
+ ENDIF
+
+ IF (pty == 2) THEN ! T, U points
+ bounds_chunks(1,2,1,2) = jpjglo-2-(bounds(2,2,2) -jpjglo)
+ bounds_chunks(1,2,2,2) = jpjglo-2-(bounds(2,1,2) -jpjglo)
+ ELSE ! V, F points
+ bounds_chunks(1,2,1,2) = jpjglo-3-(bounds(2,2,2) -jpjglo)
+ bounds_chunks(1,2,2,2) = jpjglo-3-(bounds(2,1,2) -jpjglo)
+ ENDIF
+
+ correction_required(1)=.TRUE.
+ ENDIF
+
+ ELSE IF (bounds(1,1,2) < 1) THEN
+ IF (bounds(1,2,2) > 0) THEN
+ nb_chunks = 2
+ ALLOCATE(correction_required(nb_chunks))
+ correction_required=.FALSE.
+ ALLOCATE(bounds_chunks(nb_chunks,ndim,2,2))
+ DO i=1,nb_chunks
+ bounds_chunks(i,:,:,:) = bounds
+ END DO
+
+ bounds_chunks(1,1,1,2) = bounds(1,1,2)+jpiglo-2
+ bounds_chunks(1,1,2,2) = 1+jpiglo-2
+
+ bounds_chunks(1,1,1,1) = bounds(1,1,2)
+ bounds_chunks(1,1,2,1) = 1
+
+ bounds_chunks(2,1,1,2) = 2
+ bounds_chunks(2,1,2,2) = bounds(1,2,2)
+
+ bounds_chunks(2,1,1,1) = 2
+ bounds_chunks(2,1,2,1) = bounds(1,2,2)
+
+ ELSE
+ nb_chunks = 1
+ ALLOCATE(correction_required(nb_chunks))
+ correction_required=.FALSE.
+ ALLOCATE(bounds_chunks(nb_chunks,ndim,2,2))
+ DO i=1,nb_chunks
+ bounds_chunks(i,:,:,:) = bounds
+ END DO
+ bounds_chunks(1,1,1,2) = bounds(1,1,2)+jpiglo-2
+ bounds_chunks(1,1,2,2) = bounds(1,2,2)+jpiglo-2
+
+ bounds_chunks(1,1,1,1) = bounds(1,1,2)
+ bounds_chunks(1,1,2,1) = bounds(1,2,2)
+ ENDIF
+ ELSE
+ nb_chunks=1
+ ALLOCATE(correction_required(nb_chunks))
+ correction_required=.FALSE.
+ ALLOCATE(bounds_chunks(nb_chunks,ndim,2,2))
+ DO i=1,nb_chunks
+ bounds_chunks(i,:,:,:) = bounds
+ END DO
+ bounds_chunks(1,1,1,2) = bounds(1,1,2)
+ bounds_chunks(1,1,2,2) = bounds(1,2,2)
+ bounds_chunks(1,2,1,2) = bounds(2,1,2)
+ bounds_chunks(1,2,2,2) = bounds(2,2,2)
+
+ bounds_chunks(1,1,1,1) = bounds(1,1,2)
+ bounds_chunks(1,1,2,1) = bounds(1,2,2)
+ bounds_chunks(1,2,1,1) = bounds(2,1,2)
+ bounds_chunks(1,2,2,1) = bounds(2,2,2)
+ ENDIF
+
+ END SUBROUTINE nemo_mapping
+
+ FUNCTION agrif_external_switch_index(ptx,pty,i1,isens)
+
+ USE dom_oce
+ !
+ IMPLICIT NONE
+
+ INTEGER :: ptx, pty, i1, isens
+ INTEGER :: agrif_external_switch_index
+ !!----------------------------------------------------------------------
+
+ IF( isens == 1 ) THEN
+ IF( ptx == 2 ) THEN ! T, V points
+ agrif_external_switch_index = jpiglo-i1+2
+ ELSE ! U, F points
+ agrif_external_switch_index = jpiglo-i1+1
+ ENDIF
+ ELSE IF( isens ==2 ) THEN
+ IF ( pty == 2 ) THEN ! T, U points
+ agrif_external_switch_index = jpjglo-2-(i1 -jpjglo)
+ ELSE ! V, F points
+ agrif_external_switch_index = jpjglo-3-(i1 -jpjglo)
+ ENDIF
+ ENDIF
+
+ END FUNCTION agrif_external_switch_index
+
+ SUBROUTINE Correct_field(tab2d,i1,i2,j1,j2)
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE Correct_field ***
+ !!----------------------------------------------------------------------
+ USE dom_oce
+ USE agrif_oce
+ !
+ IMPLICIT NONE
+ !
+ INTEGER :: i1,i2,j1,j2
+ REAL(wp), DIMENSION(i1:i2,j1:j2) :: tab2d
+ !
+ INTEGER :: i,j
+ REAL(wp), DIMENSION(i1:i2,j1:j2) :: tab2dtemp
+ !!----------------------------------------------------------------------
+
+ tab2dtemp = tab2d
+
+ IF( .NOT. use_sign_north ) THEN
+ DO j=j1,j2
+ DO i=i1,i2
+ tab2d(i,j)=tab2dtemp(i2-(i-i1),j2-(j-j1))
+ END DO
+ END DO
+ ELSE
+ DO j=j1,j2
+ DO i=i1,i2
+ tab2d(i,j)=sign_north * tab2dtemp(i2-(i-i1),j2-(j-j1))
+ END DO
+ END DO
+ ENDIF
+
+ END SUBROUTINE Correct_field
+
#else
SUBROUTINE Subcalledbyagrif
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/ASM/asminc.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/ASM/asminc.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/ASM/asminc.F90 (revision 13540)
@@ -95,4 +95,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -359,6 +360,6 @@
IF ( ln_trainc ) THEN
- CALL iom_get( inum, jpdom_autoglo, 'bckint', t_bkginc, 1 )
- CALL iom_get( inum, jpdom_autoglo, 'bckins', s_bkginc, 1 )
+ CALL iom_get( inum, jpdom_auto, 'bckint', t_bkginc, 1 )
+ CALL iom_get( inum, jpdom_auto, 'bckins', s_bkginc, 1 )
! Apply the masks
t_bkginc(:,:,:) = t_bkginc(:,:,:) * tmask(:,:,:)
@@ -371,6 +372,6 @@
IF ( ln_dyninc ) THEN
- CALL iom_get( inum, jpdom_autoglo, 'bckinu', u_bkginc, 1 )
- CALL iom_get( inum, jpdom_autoglo, 'bckinv', v_bkginc, 1 )
+ CALL iom_get( inum, jpdom_auto, 'bckinu', u_bkginc, 1 )
+ CALL iom_get( inum, jpdom_auto, 'bckinv', v_bkginc, 1 )
! Apply the masks
u_bkginc(:,:,:) = u_bkginc(:,:,:) * umask(:,:,:)
@@ -383,5 +384,5 @@
IF ( ln_sshinc ) THEN
- CALL iom_get( inum, jpdom_autoglo, 'bckineta', ssh_bkginc, 1 )
+ CALL iom_get( inum, jpdom_auto, 'bckineta', ssh_bkginc, 1 )
! Apply the masks
ssh_bkginc(:,:) = ssh_bkginc(:,:) * tmask(:,:,1)
@@ -392,5 +393,5 @@
IF ( ln_seaiceinc ) THEN
- CALL iom_get( inum, jpdom_autoglo, 'bckinseaice', seaice_bkginc, 1 )
+ CALL iom_get( inum, jpdom_auto, 'bckinseaice', seaice_bkginc, 1 )
! Apply the masks
seaice_bkginc(:,:) = seaice_bkginc(:,:) * tmask(:,:,1)
@@ -413,13 +414,14 @@
DO jk = 1, jpkm1 ! zhdiv = e1e1 * div
zhdiv(:,:) = 0._wp
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
zhdiv(ji,jj) = ( e2u(ji ,jj) * e3u(ji ,jj,jk,Kmm) * u_bkginc(ji ,jj,jk) &
& - e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm) * u_bkginc(ji-1,jj,jk) &
& + e1v(ji,jj ) * e3v(ji,jj ,jk,Kmm) * v_bkginc(ji,jj ,jk) &
- & - e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) * v_bkginc(ji,jj-1,jk) ) / e3t(ji,jj,jk,Kmm)
+ & - e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) * v_bkginc(ji,jj-1,jk) ) &
+ & / e3t(ji,jj,jk,Kmm)
END_2D
- CALL lbc_lnk( 'asminc', zhdiv, 'T', 1. ) ! lateral boundary cond. (no sign change)
+ CALL lbc_lnk( 'asminc', zhdiv, 'T', 1.0_wp ) ! lateral boundary cond. (no sign change)
!
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
u_bkginc(ji,jj,jk) = u_bkginc(ji,jj,jk) &
& + 0.2_wp * ( zhdiv(ji+1,jj) - zhdiv(ji ,jj) ) * r1_e1u(ji,jj) * umask(ji,jj,jk)
@@ -465,6 +467,6 @@
!
IF ( ln_trainc ) THEN
- CALL iom_get( inum, jpdom_autoglo, 'tn', t_bkg )
- CALL iom_get( inum, jpdom_autoglo, 'sn', s_bkg )
+ CALL iom_get( inum, jpdom_auto, 'tn', t_bkg )
+ CALL iom_get( inum, jpdom_auto, 'sn', s_bkg )
t_bkg(:,:,:) = t_bkg(:,:,:) * tmask(:,:,:)
s_bkg(:,:,:) = s_bkg(:,:,:) * tmask(:,:,:)
@@ -472,6 +474,6 @@
!
IF ( ln_dyninc ) THEN
- CALL iom_get( inum, jpdom_autoglo, 'un', u_bkg )
- CALL iom_get( inum, jpdom_autoglo, 'vn', v_bkg )
+ CALL iom_get( inum, jpdom_auto, 'un', u_bkg, cd_type = 'U', psgn = 1._wp )
+ CALL iom_get( inum, jpdom_auto, 'vn', v_bkg, cd_type = 'V', psgn = 1._wp )
u_bkg(:,:,:) = u_bkg(:,:,:) * umask(:,:,:)
v_bkg(:,:,:) = v_bkg(:,:,:) * vmask(:,:,:)
@@ -479,5 +481,5 @@
!
IF ( ln_sshinc ) THEN
- CALL iom_get( inum, jpdom_autoglo, 'sshn', ssh_bkg )
+ CALL iom_get( inum, jpdom_auto, 'sshn', ssh_bkg )
ssh_bkg(:,:) = ssh_bkg(:,:) * tmask(:,:,1)
ENDIF
@@ -758,5 +760,7 @@
!
ssh(:,:,Kbb) = ssh(:,:,Kmm) ! Update before fields
+#if ! defined key_qco
e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm)
+#endif
!!gm why not e3u(:,:,:,Kbb), e3v(:,:,:,Kbb), gdept(:,:,:,Kbb) ????
!
@@ -896,5 +900,5 @@
IF ( kt == nitdin_r ) THEN
!
- l_1st_euler = 0 ! Force Euler forward step
+ l_1st_euler = .TRUE. ! Force Euler forward step
!
! Sea-ice : SI3 case
@@ -970,6 +974,6 @@
! ! set to bottom of a level
! DO jk = jpk-1, 2, -1
-! IF ((mld > gdepw(ji,jj,jk)) .and. (mld < gdepw(ji,jj,jk+1))) THEN
-! mld=gdepw(ji,jj,jk+1)
+! IF ((mld > gdepw(ji,jj,jk,Kmm)) .and. (mld < gdepw(ji,jj,jk+1,Kmm))) THEN
+! mld=gdepw(ji,jj,jk+1,Kmm)
! jkmax=jk
! ENDIF
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/BDY/bdy_oce.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/BDY/bdy_oce.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/BDY/bdy_oce.F90 (revision 13540)
@@ -63,4 +63,5 @@
REAL(wp), POINTER, DIMENSION(:,:) :: aip !: now ice pond concentration
REAL(wp), POINTER, DIMENSION(:,:) :: hip !: now ice pond depth
+ REAL(wp), POINTER, DIMENSION(:,:) :: hil !: now ice pond lid depth
#if defined key_top
CHARACTER(LEN=20) :: cn_obc !: type of boundary condition to apply
@@ -115,4 +116,5 @@
REAL(wp), DIMENSION(jp_bdy) :: rice_apnd !: pond conc. of incoming sea ice
REAL(wp), DIMENSION(jp_bdy) :: rice_hpnd !: pond thick. of incoming sea ice
+ REAL(wp), DIMENSION(jp_bdy) :: rice_hlid !: pond lid thick. of incoming sea ice
!
!!----------------------------------------------------------------------
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/BDY/bdydta.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/BDY/bdydta.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/BDY/bdydta.F90 (revision 13540)
@@ -43,5 +43,5 @@
PUBLIC bdy_dta_init ! routine called by nemogcm.F90
- INTEGER , PARAMETER :: jpbdyfld = 16 ! maximum number of files to read
+ INTEGER , PARAMETER :: jpbdyfld = 17 ! maximum number of files to read
INTEGER , PARAMETER :: jp_bdyssh = 1 !
INTEGER , PARAMETER :: jp_bdyu2d = 2 !
@@ -60,4 +60,5 @@
INTEGER , PARAMETER :: jp_bdyaip = 15 !
INTEGER , PARAMETER :: jp_bdyhip = 16 !
+ INTEGER , PARAMETER :: jp_bdyhil = 17 !
#if ! defined key_si3
INTEGER , PARAMETER :: jpl = 1
@@ -70,4 +71,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -91,6 +93,4 @@
INTEGER :: jbdy, jfld, jstart, jend, ib, jl ! dummy loop indices
INTEGER :: ii, ij, ik, igrd, ipl ! local integers
- INTEGER, DIMENSION(jpbgrd) :: ilen1
- INTEGER, DIMENSION(:), POINTER :: nblen, nblenrim ! short cuts
TYPE(OBC_DATA) , POINTER :: dta_alias ! short cut
TYPE(FLD), DIMENSION(:), POINTER :: bf_alias
@@ -108,12 +108,8 @@
DO jbdy = 1, nb_bdy
!
- nblen => idx_bdy(jbdy)%nblen
- nblenrim => idx_bdy(jbdy)%nblenrim
- !
IF( nn_dyn2d_dta(jbdy) == 0 ) THEN
- ilen1(:) = nblen(:)
IF( dta_bdy(jbdy)%lneed_ssh ) THEN
igrd = 1
- DO ib = 1, ilen1(igrd)
+ DO ib = 1, idx_bdy(jbdy)%nblenrim(igrd) ! ssh is allocated and used only on the rim
ii = idx_bdy(jbdy)%nbi(ib,igrd)
ij = idx_bdy(jbdy)%nbj(ib,igrd)
@@ -121,13 +117,15 @@
END DO
ENDIF
- IF( dta_bdy(jbdy)%lneed_dyn2d) THEN
+ IF( ASSOCIATED(dta_bdy(jbdy)%u2d) ) THEN ! no SIZE with a unassociated pointer. v2d and u2d can differ on subdomain
igrd = 2
- DO ib = 1, ilen1(igrd)
+ DO ib = 1, SIZE(dta_bdy(jbdy)%u2d) ! u2d is used either over the whole bdy or only on the rim
ii = idx_bdy(jbdy)%nbi(ib,igrd)
ij = idx_bdy(jbdy)%nbj(ib,igrd)
dta_bdy(jbdy)%u2d(ib) = uu_b(ii,ij,Kmm) * umask(ii,ij,1)
END DO
+ ENDIF
+ IF( ASSOCIATED(dta_bdy(jbdy)%v2d) ) THEN ! no SIZE with a unassociated pointer. v2d and u2d can differ on subdomain
igrd = 3
- DO ib = 1, ilen1(igrd)
+ DO ib = 1, SIZE(dta_bdy(jbdy)%v2d) ! v2d is used either over the whole bdy or only on the rim
ii = idx_bdy(jbdy)%nbi(ib,igrd)
ij = idx_bdy(jbdy)%nbj(ib,igrd)
@@ -138,8 +136,7 @@
!
IF( nn_dyn3d_dta(jbdy) == 0 ) THEN
- ilen1(:) = nblen(:)
IF( dta_bdy(jbdy)%lneed_dyn3d ) THEN
igrd = 2
- DO ib = 1, ilen1(igrd)
+ DO ib = 1, idx_bdy(jbdy)%nblen(igrd)
DO ik = 1, jpkm1
ii = idx_bdy(jbdy)%nbi(ib,igrd)
@@ -149,5 +146,5 @@
END DO
igrd = 3
- DO ib = 1, ilen1(igrd)
+ DO ib = 1, idx_bdy(jbdy)%nblen(igrd)
DO ik = 1, jpkm1
ii = idx_bdy(jbdy)%nbi(ib,igrd)
@@ -160,8 +157,7 @@
IF( nn_tra_dta(jbdy) == 0 ) THEN
- ilen1(:) = nblen(:)
IF( dta_bdy(jbdy)%lneed_tra ) THEN
igrd = 1
- DO ib = 1, ilen1(igrd)
+ DO ib = 1, idx_bdy(jbdy)%nblen(igrd)
DO ik = 1, jpkm1
ii = idx_bdy(jbdy)%nbi(ib,igrd)
@@ -176,9 +172,8 @@
#if defined key_si3
IF( nn_ice_dta(jbdy) == 0 ) THEN ! set ice to initial values
- ilen1(:) = nblen(:)
IF( dta_bdy(jbdy)%lneed_ice ) THEN
igrd = 1
DO jl = 1, jpl
- DO ib = 1, ilen1(igrd)
+ DO ib = 1, idx_bdy(jbdy)%nblen(igrd)
ii = idx_bdy(jbdy)%nbi(ib,igrd)
ij = idx_bdy(jbdy)%nbj(ib,igrd)
@@ -193,4 +188,5 @@
dta_bdy(jbdy)%aip(ib,jl) = a_ip(ii,ij,jl) * tmask(ii,ij,1)
dta_bdy(jbdy)%hip(ib,jl) = h_ip(ii,ij,jl) * tmask(ii,ij,1)
+ dta_bdy(jbdy)%hil(ib,jl) = h_il(ii,ij,jl) * tmask(ii,ij,1)
END DO
END DO
@@ -218,25 +214,29 @@
!
! if runoff condition: change river flow we read (in m3/s) into barotropic velocity (m/s)
- IF( cn_tra(jbdy) == 'runoff' .AND. TRIM(bf_alias(jp_bdyu2d)%clrootname) /= 'NOT USED' ) THEN ! runoff and we read u/v2d
+ IF( cn_tra(jbdy) == 'runoff' ) THEN ! runoff
!
- igrd = 2 ! zonal flow (m3/s) to barotropic zonal velocity (m/s)
- DO ib = 1, idx_bdy(jbdy)%nblen(igrd)
- ii = idx_bdy(jbdy)%nbi(ib,igrd)
- ij = idx_bdy(jbdy)%nbj(ib,igrd)
- dta_alias%u2d(ib) = dta_alias%u2d(ib) / ( e2u(ii,ij) * hu_0(ii,ij) )
- END DO
- igrd = 3 ! meridional flow (m3/s) to barotropic meridional velocity (m/s)
- DO ib = 1, idx_bdy(jbdy)%nblen(igrd)
- ii = idx_bdy(jbdy)%nbi(ib,igrd)
- ij = idx_bdy(jbdy)%nbj(ib,igrd)
- dta_alias%v2d(ib) = dta_alias%v2d(ib) / ( e1v(ii,ij) * hv_0(ii,ij) )
- END DO
+ IF( ASSOCIATED(dta_bdy(jbdy)%u2d) ) THEN ! no SIZE with a unassociated pointer. v2d and u2d can differ on subdomain
+ igrd = 2 ! zonal flow (m3/s) to barotropic zonal velocity (m/s)
+ DO ib = 1, SIZE(dta_alias%u2d) ! u2d is used either over the whole bdy or only on the rim
+ ii = idx_bdy(jbdy)%nbi(ib,igrd)
+ ij = idx_bdy(jbdy)%nbj(ib,igrd)
+ dta_alias%u2d(ib) = dta_alias%u2d(ib) / ( e2u(ii,ij) * hu_0(ii,ij) )
+ END DO
+ ENDIF
+ IF( ASSOCIATED(dta_bdy(jbdy)%v2d) ) THEN ! no SIZE with a unassociated pointer. v2d and u2d can differ on subdomain
+ igrd = 3 ! meridional flow (m3/s) to barotropic meridional velocity (m/s)
+ DO ib = 1, SIZE(dta_alias%v2d) ! v2d is used either over the whole bdy or only on the rim
+ ii = idx_bdy(jbdy)%nbi(ib,igrd)
+ ij = idx_bdy(jbdy)%nbj(ib,igrd)
+ dta_alias%v2d(ib) = dta_alias%v2d(ib) / ( e1v(ii,ij) * hv_0(ii,ij) )
+ END DO
+ ENDIF
ENDIF
! tidal harmonic forcing ONLY: initialise arrays
IF( nn_dyn2d_dta(jbdy) == 2 ) THEN ! we did not read ssh, u/v2d
- IF( dta_alias%lneed_ssh ) dta_alias%ssh(:) = 0._wp
- IF( dta_alias%lneed_dyn2d ) dta_alias%u2d(:) = 0._wp
- IF( dta_alias%lneed_dyn2d ) dta_alias%v2d(:) = 0._wp
+ IF( ASSOCIATED(dta_alias%ssh) ) dta_alias%ssh(:) = 0._wp
+ IF( ASSOCIATED(dta_alias%u2d) ) dta_alias%u2d(:) = 0._wp
+ IF( ASSOCIATED(dta_alias%v2d) ) dta_alias%v2d(:) = 0._wp
ENDIF
@@ -245,10 +245,11 @@
!
igrd = 2 ! zonal velocity
- dta_alias%u2d(:) = 0._wp ! compute barotrope zonal velocity and put it in u2d
DO ib = 1, idx_bdy(jbdy)%nblen(igrd)
ii = idx_bdy(jbdy)%nbi(ib,igrd)
ij = idx_bdy(jbdy)%nbj(ib,igrd)
+ dta_alias%u2d(ib) = 0._wp ! compute barotrope zonal velocity and put it in u2d
DO ik = 1, jpkm1
- dta_alias%u2d(ib) = dta_alias%u2d(ib) + e3u(ii,ij,ik,Kmm) * umask(ii,ij,ik) * dta_alias%u3d(ib,ik)
+ dta_alias%u2d(ib) = dta_alias%u2d(ib) &
+ & + e3u(ii,ij,ik,Kmm) * umask(ii,ij,ik) * dta_alias%u3d(ib,ik)
END DO
dta_alias%u2d(ib) = dta_alias%u2d(ib) * r1_hu(ii,ij,Kmm)
@@ -258,10 +259,11 @@
END DO
igrd = 3 ! meridional velocity
- dta_alias%v2d(:) = 0._wp ! compute barotrope meridional velocity and put it in v2d
DO ib = 1, idx_bdy(jbdy)%nblen(igrd)
ii = idx_bdy(jbdy)%nbi(ib,igrd)
ij = idx_bdy(jbdy)%nbj(ib,igrd)
+ dta_alias%v2d(ib) = 0._wp ! compute barotrope meridional velocity and put it in v2d
DO ik = 1, jpkm1
- dta_alias%v2d(ib) = dta_alias%v2d(ib) + e3v(ii,ij,ik,Kmm) * vmask(ii,ij,ik) * dta_alias%v3d(ib,ik)
+ dta_alias%v2d(ib) = dta_alias%v2d(ib) &
+ & + e3v(ii,ij,ik,Kmm) * vmask(ii,ij,ik) * dta_alias%v3d(ib,ik)
END DO
dta_alias%v2d(ib) = dta_alias%v2d(ib) * r1_hv(ii,ij,Kmm)
@@ -283,5 +285,5 @@
#if defined key_si3
- IF( dta_alias%lneed_ice ) THEN
+ IF( dta_alias%lneed_ice .AND. idx_bdy(jbdy)%nblen(1) > 0 ) THEN
! fill temperature and salinity arrays
IF( TRIM(bf_alias(jp_bdyt_i)%clrootname) == 'NOT USED' ) bf_alias(jp_bdyt_i)%fnow(:,1,:) = rice_tem (jbdy)
@@ -289,8 +291,9 @@
IF( TRIM(bf_alias(jp_bdytsu)%clrootname) == 'NOT USED' ) bf_alias(jp_bdytsu)%fnow(:,1,:) = rice_tem (jbdy)
IF( TRIM(bf_alias(jp_bdys_i)%clrootname) == 'NOT USED' ) bf_alias(jp_bdys_i)%fnow(:,1,:) = rice_sal (jbdy)
- IF( TRIM(bf_alias(jp_bdyaip)%clrootname) == 'NOT USED' ) bf_alias(jp_bdyaip)%fnow(:,1,:) = rice_apnd(jbdy) * & ! rice_apnd is the pond fraction
- & bf_alias(jp_bdya_i)%fnow(:,1,:) ! ( a_ip = rice_apnd * a_i )
+ IF( TRIM(bf_alias(jp_bdyaip)%clrootname) == 'NOT USED' ) & ! rice_apnd is the pond fraction
+ & bf_alias(jp_bdyaip)%fnow(:,1,:) = rice_apnd(jbdy) * bf_alias(jp_bdya_i)%fnow(:,1,:) ! ( a_ip = rice_apnd*a_i )
IF( TRIM(bf_alias(jp_bdyhip)%clrootname) == 'NOT USED' ) bf_alias(jp_bdyhip)%fnow(:,1,:) = rice_hpnd(jbdy)
-
+ IF( TRIM(bf_alias(jp_bdyhil)%clrootname) == 'NOT USED' ) bf_alias(jp_bdyhil)%fnow(:,1,:) = rice_hlid(jbdy)
+
! if T_i is read and not T_su, set T_su = T_i
IF( TRIM(bf_alias(jp_bdyt_i)%clrootname) /= 'NOT USED' .AND. TRIM(bf_alias(jp_bdytsu)%clrootname) == 'NOT USED' ) &
@@ -316,4 +319,8 @@
bf_alias(jp_bdyaip)%fnow(:,1,:) = 0._wp
bf_alias(jp_bdyhip)%fnow(:,1,:) = 0._wp
+ bf_alias(jp_bdyhil)%fnow(:,1,:) = 0._wp
+ ENDIF
+ IF ( .NOT.ln_pnd_lids ) THEN
+ bf_alias(jp_bdyhil)%fnow(:,1,:) = 0._wp
ENDIF
@@ -321,12 +328,12 @@
ipl = SIZE(bf_alias(jp_bdya_i)%fnow, 3)
IF( ipl /= jpl ) THEN ! ice: convert N-cat fields (input) into jpl-cat (output)
- CALL ice_var_itd( bf_alias(jp_bdyh_i)%fnow(:,1,:), bf_alias(jp_bdyh_s)%fnow(:,1,:), bf_alias(jp_bdya_i)%fnow(:,1,:), &
- & dta_alias%h_i , dta_alias%h_s , dta_alias%a_i , &
- & bf_alias(jp_bdyt_i)%fnow(:,1,:), bf_alias(jp_bdyt_s)%fnow(:,1,:), &
- & bf_alias(jp_bdytsu)%fnow(:,1,:), bf_alias(jp_bdys_i)%fnow(:,1,:), &
- & bf_alias(jp_bdyaip)%fnow(:,1,:), bf_alias(jp_bdyhip)%fnow(:,1,:), &
- & dta_alias%t_i , dta_alias%t_s , &
- & dta_alias%tsu , dta_alias%s_i , &
- & dta_alias%aip , dta_alias%hip )
+ CALL ice_var_itd( bf_alias(jp_bdyh_i)%fnow(:,1,:), bf_alias(jp_bdyh_s)%fnow(:,1,:), bf_alias(jp_bdya_i)%fnow(:,1,:), & ! in
+ & dta_alias%h_i , dta_alias%h_s , dta_alias%a_i , & ! out
+ & bf_alias(jp_bdyt_i)%fnow(:,1,:), bf_alias(jp_bdyt_s)%fnow(:,1,:), & ! in (optional)
+ & bf_alias(jp_bdytsu)%fnow(:,1,:), bf_alias(jp_bdys_i)%fnow(:,1,:), & ! in -
+ & bf_alias(jp_bdyaip)%fnow(:,1,:), bf_alias(jp_bdyhip)%fnow(:,1,:), bf_alias(jp_bdyhil)%fnow(:,1,:), & ! in -
+ & dta_alias%t_i , dta_alias%t_s , & ! out -
+ & dta_alias%tsu , dta_alias%s_i , & ! out -
+ & dta_alias%aip , dta_alias%hip , dta_alias%hil ) ! out -
ENDIF
ENDIF
@@ -338,17 +345,11 @@
DO jbdy = 1, nb_bdy ! Tidal component added in ts loop
IF ( nn_dyn2d_dta(jbdy) .GE. 2 ) THEN
- nblen => idx_bdy(jbdy)%nblen
- nblenrim => idx_bdy(jbdy)%nblenrim
- IF( cn_dyn2d(jbdy) == 'frs' ) THEN ; ilen1(:)=nblen(:)
- ELSE ; ilen1(:)=nblenrim(:)
- ENDIF
- IF ( dta_bdy(jbdy)%lneed_ssh ) dta_bdy_s(jbdy)%ssh(1:ilen1(1)) = dta_bdy(jbdy)%ssh(1:ilen1(1))
- IF ( dta_bdy(jbdy)%lneed_dyn2d ) dta_bdy_s(jbdy)%u2d(1:ilen1(2)) = dta_bdy(jbdy)%u2d(1:ilen1(2))
- IF ( dta_bdy(jbdy)%lneed_dyn2d ) dta_bdy_s(jbdy)%v2d(1:ilen1(3)) = dta_bdy(jbdy)%v2d(1:ilen1(3))
+ IF( ASSOCIATED(dta_bdy(jbdy)%ssh) ) dta_bdy_s(jbdy)%ssh(:) = dta_bdy(jbdy)%ssh(:)
+ IF( ASSOCIATED(dta_bdy(jbdy)%u2d) ) dta_bdy_s(jbdy)%u2d(:) = dta_bdy(jbdy)%u2d(:)
+ IF( ASSOCIATED(dta_bdy(jbdy)%v2d) ) dta_bdy_s(jbdy)%v2d(:) = dta_bdy(jbdy)%v2d(:)
ENDIF
END DO
ELSE ! Add tides if not split-explicit free surface else this is done in ts loop
!
- ! BDY: use pt_offset=1.0 as applied at the end of the step and bdy_dta_tides is referenced at the middle of the step
CALL bdy_dta_tides( kt=kt, pt_offset = 1._wp )
ENDIF
@@ -358,5 +359,5 @@
!
END SUBROUTINE bdy_dta
-
+
SUBROUTINE bdy_dta_init
@@ -380,5 +381,5 @@
! ! =F => baroclinic velocities in 3D boundary data
LOGICAL :: ln_zinterp ! =T => requires a vertical interpolation of the bdydta
- REAL(wp) :: rn_ice_tem, rn_ice_sal, rn_ice_age, rn_ice_apnd, rn_ice_hpnd
+ REAL(wp) :: rn_ice_tem, rn_ice_sal, rn_ice_age, rn_ice_apnd, rn_ice_hpnd, rn_ice_hlid
INTEGER :: ipk,ipl !
INTEGER :: idvar ! variable ID
@@ -390,14 +391,15 @@
LOGICAL :: llneed !
LOGICAL :: llread !
+ LOGICAL :: llfullbdy !
TYPE(FLD_N), DIMENSION(1), TARGET :: bn_tem, bn_sal, bn_u3d, bn_v3d ! must be an array to be used with fld_fill
TYPE(FLD_N), DIMENSION(1), TARGET :: bn_ssh, bn_u2d, bn_v2d ! informations about the fields to be read
- TYPE(FLD_N), DIMENSION(1), TARGET :: bn_a_i, bn_h_i, bn_h_s, bn_t_i, bn_t_s, bn_tsu, bn_s_i, bn_aip, bn_hip
+ TYPE(FLD_N), DIMENSION(1), TARGET :: bn_a_i, bn_h_i, bn_h_s, bn_t_i, bn_t_s, bn_tsu, bn_s_i, bn_aip, bn_hip, bn_hil
TYPE(FLD_N), DIMENSION(:), POINTER :: bn_alias ! must be an array to be used with fld_fill
TYPE(FLD ), DIMENSION(:), POINTER :: bf_alias
!
- NAMELIST/nambdy_dta/ cn_dir, bn_tem, bn_sal, bn_u3d, bn_v3d, bn_ssh, bn_u2d, bn_v2d
- NAMELIST/nambdy_dta/ bn_a_i, bn_h_i, bn_h_s, bn_t_i, bn_t_s, bn_tsu, bn_s_i, bn_aip, bn_hip
- NAMELIST/nambdy_dta/ rn_ice_tem, rn_ice_sal, rn_ice_age, rn_ice_apnd, rn_ice_hpnd
- NAMELIST/nambdy_dta/ ln_full_vel, ln_zinterp
+ NAMELIST/nambdy_dta/ cn_dir, bn_tem, bn_sal, bn_u3d, bn_v3d, bn_ssh, bn_u2d, bn_v2d, &
+ & bn_a_i, bn_h_i, bn_h_s, bn_t_i, bn_t_s, bn_tsu, bn_s_i, bn_aip, bn_hip, bn_hil, &
+ & rn_ice_tem, rn_ice_sal, rn_ice_age, rn_ice_apnd, rn_ice_hpnd, rn_ice_hlid, &
+ & ln_full_vel, ln_zinterp
!!---------------------------------------------------------------------------
!
@@ -469,6 +471,9 @@
#if defined key_si3
IF( .NOT.ln_pnd ) THEN
- rn_ice_apnd = 0. ; rn_ice_hpnd = 0.
- CALL ctl_warn( 'rn_ice_apnd & rn_ice_hpnd = 0 when no ponds' )
+ rn_ice_apnd = 0. ; rn_ice_hpnd = 0. ; rn_ice_hlid = 0.
+ CALL ctl_warn( 'rn_ice_apnd & rn_ice_hpnd = 0 & rn_ice_hlid = 0 when no ponds' )
+ ENDIF
+ IF( .NOT.ln_pnd_lids ) THEN
+ rn_ice_hlid = 0.
ENDIF
#endif
@@ -480,5 +485,6 @@
rice_apnd(jbdy) = rn_ice_apnd
rice_hpnd(jbdy) = rn_ice_hpnd
-
+ rice_hlid(jbdy) = rn_ice_hlid
+
DO jfld = 1, jpbdyfld
@@ -504,10 +510,11 @@
igrd = 2 ! U point
ipk = 1 ! surface data
- llneed = dta_bdy(jbdy)%lneed_dyn2d ! dta_bdy(jbdy)%ssh will be needed
+ llneed = dta_bdy(jbdy)%lneed_dyn2d ! dta_bdy(jbdy)%u2d will be needed
llread = .NOT. ln_full_vel .AND. MOD(nn_dyn2d_dta(jbdy),2) == 1 ! don't get u2d from u3d and read NetCDF file
bf_alias => bf(jp_bdyu2d,jbdy:jbdy) ! alias for u2d structure of bdy number jbdy
bn_alias => bn_u2d ! alias for u2d structure of nambdy_dta
- IF( ln_full_vel ) THEN ; iszdim = idx_bdy(jbdy)%nblen(igrd) ! will be computed from u3d -> need on the full bdy
- ELSE ; iszdim = idx_bdy(jbdy)%nblenrim(igrd) ! used only on the rim
+ llfullbdy = ln_full_vel .OR. cn_dyn2d(jbdy) == 'frs' ! need u2d over the whole bdy or only over the rim?
+ IF( llfullbdy ) THEN ; iszdim = idx_bdy(jbdy)%nblen(igrd)
+ ELSE ; iszdim = idx_bdy(jbdy)%nblenrim(igrd)
ENDIF
ENDIF
@@ -516,10 +523,11 @@
igrd = 3 ! V point
ipk = 1 ! surface data
- llneed = dta_bdy(jbdy)%lneed_dyn2d ! dta_bdy(jbdy)%ssh will be needed
+ llneed = dta_bdy(jbdy)%lneed_dyn2d ! dta_bdy(jbdy)%v2d will be needed
llread = .NOT. ln_full_vel .AND. MOD(nn_dyn2d_dta(jbdy),2) == 1 ! don't get v2d from v3d and read NetCDF file
bf_alias => bf(jp_bdyv2d,jbdy:jbdy) ! alias for v2d structure of bdy number jbdy
bn_alias => bn_v2d ! alias for v2d structure of nambdy_dta
- IF( ln_full_vel ) THEN ; iszdim = idx_bdy(jbdy)%nblen(igrd) ! will be computed from v3d -> need on the full bdy
- ELSE ; iszdim = idx_bdy(jbdy)%nblenrim(igrd) ! used only on the rim
+ llfullbdy = ln_full_vel .OR. cn_dyn2d(jbdy) == 'frs' ! need v2d over the whole bdy or only over the rim?
+ IF( llfullbdy ) THEN ; iszdim = idx_bdy(jbdy)%nblen(igrd)
+ ELSE ; iszdim = idx_bdy(jbdy)%nblenrim(igrd)
ENDIF
ENDIF
@@ -579,5 +587,5 @@
IF( jfld == jp_bdya_i .OR. jfld == jp_bdyh_i .OR. jfld == jp_bdyh_s .OR. &
& jfld == jp_bdyt_i .OR. jfld == jp_bdyt_s .OR. jfld == jp_bdytsu .OR. &
- & jfld == jp_bdys_i .OR. jfld == jp_bdyaip .OR. jfld == jp_bdyhip ) THEN
+ & jfld == jp_bdys_i .OR. jfld == jp_bdyaip .OR. jfld == jp_bdyhip .OR. jfld == jp_bdyhil ) THEN
igrd = 1 ! T point
ipk = ipl ! jpl-cat data
@@ -630,4 +638,9 @@
bf_alias => bf(jp_bdyhip,jbdy:jbdy) ! alias for hip structure of bdy number jbdy
bn_alias => bn_hip ! alias for hip structure of nambdy_dta
+ ENDIF
+ IF( jfld == jp_bdyhil ) THEN
+ cl3 = 'hil'
+ bf_alias => bf(jp_bdyhil,jbdy:jbdy) ! alias for hil structure of bdy number jbdy
+ bn_alias => bn_hil ! alias for hil structure of nambdy_dta
ENDIF
@@ -699,4 +712,9 @@
ENDIF
ENDIF
+ IF( jfld == jp_bdyhil ) THEN
+ IF( ipk == jpl ) THEN ; dta_bdy(jbdy)%hil => bf_alias(1)%fnow(:,1,:)
+ ELSE ; ALLOCATE( dta_bdy(jbdy)%hil(iszdim,jpl) )
+ ENDIF
+ ENDIF
ENDIF
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/BDY/bdydyn.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/BDY/bdydyn.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/BDY/bdydyn.F90 (revision 13540)
@@ -30,4 +30,6 @@
PUBLIC bdy_dyn ! routine called in dyn_nxt
+ !! * Substitutions
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/BDY/bdydyn2d.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/BDY/bdydyn2d.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/BDY/bdydyn2d.F90 (revision 13540)
@@ -102,8 +102,8 @@
END DO
IF( ANY(llsend2) .OR. ANY(llrecv2) ) THEN ! if need to send/recv in at least one direction
- CALL lbc_lnk( 'bdydyn2d', pua2d, 'U', -1., kfillmode=jpfillnothing ,lsend=llsend2, lrecv=llrecv2 )
+ CALL lbc_lnk( 'bdydyn2d', pua2d, 'U', -1.0_wp, kfillmode=jpfillnothing ,lsend=llsend2, lrecv=llrecv2 )
END IF
IF( ANY(llsend3) .OR. ANY(llrecv3) ) THEN ! if need to send/recv in at least one direction
- CALL lbc_lnk( 'bdydyn2d', pva2d, 'V', -1., kfillmode=jpfillnothing ,lsend=llsend3, lrecv=llrecv3 )
+ CALL lbc_lnk( 'bdydyn2d', pva2d, 'V', -1.0_wp, kfillmode=jpfillnothing ,lsend=llsend3, lrecv=llrecv3 )
END IF
!
@@ -324,5 +324,5 @@
IF( nn_hls > 1 .AND. ir == 1 ) CYCLE ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0
IF( ANY(llsend1) .OR. ANY(llrecv1) ) THEN ! if need to send/recv in at least one direction
- CALL lbc_lnk( 'bdydyn2d', zssh(:,:,1), 'T', 1., kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 )
+ CALL lbc_lnk( 'bdydyn2d', zssh(:,:,1), 'T', 1.0_wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 )
END IF
END DO
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/BDY/bdydyn3d.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/BDY/bdydyn3d.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/BDY/bdydyn3d.F90 (revision 13540)
@@ -99,8 +99,8 @@
!
IF( ANY(llsend2) .OR. ANY(llrecv2) ) THEN ! if need to send/recv in at least one direction
- CALL lbc_lnk( 'bdydyn2d', puu(:,:,:,Kaa), 'U', -1., kfillmode=jpfillnothing ,lsend=llsend2, lrecv=llrecv2 )
+ CALL lbc_lnk( 'bdydyn2d', puu(:,:,:,Kaa), 'U', -1.0_wp, kfillmode=jpfillnothing ,lsend=llsend2, lrecv=llrecv2 )
END IF
IF( ANY(llsend3) .OR. ANY(llrecv3) ) THEN ! if need to send/recv in at least one direction
- CALL lbc_lnk( 'bdydyn2d', pvv(:,:,:,Kaa), 'V', -1., kfillmode=jpfillnothing ,lsend=llsend3, lrecv=llrecv3 )
+ CALL lbc_lnk( 'bdydyn2d', pvv(:,:,:,Kaa), 'V', -1.0_wp, kfillmode=jpfillnothing ,lsend=llsend3, lrecv=llrecv3 )
END IF
END DO ! ir
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/BDY/bdyice.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/BDY/bdyice.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/BDY/bdyice.F90 (revision 13540)
@@ -94,11 +94,11 @@
IF( ANY(llsend1) .OR. ANY(llrecv1) ) THEN ! if need to send/recv in at least one direction
! exchange 3d arrays
- CALL lbc_lnk_multi( 'bdyice', a_i , 'T', 1., h_i , 'T', 1., h_s , 'T', 1., oa_i, 'T', 1. &
- & , a_ip, 'T', 1., v_ip, 'T', 1., s_i , 'T', 1., t_su, 'T', 1. &
- & , v_i , 'T', 1., v_s , 'T', 1., sv_i, 'T', 1. &
- & , kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 )
+ CALL lbc_lnk_multi('bdyice', a_i , 'T', 1._wp, h_i , 'T', 1._wp, h_s , 'T', 1._wp, oa_i, 'T', 1._wp &
+ & , s_i , 'T', 1._wp, t_su, 'T', 1._wp, v_i , 'T', 1._wp, v_s , 'T', 1._wp, sv_i, 'T', 1._wp &
+ & , 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_multi( 'bdyice', t_s , 'T', 1., e_s , 'T', 1., kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 )
- CALL lbc_lnk_multi( 'bdyice', t_i , 'T', 1., e_i , 'T', 1., kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 )
+ CALL lbc_lnk_multi('bdyice', t_s , 'T', 1._wp, e_s , 'T', 1._wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 )
+ CALL lbc_lnk_multi('bdyice', t_i , 'T', 1._wp, e_i , 'T', 1._wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 )
END IF
END DO ! ir
@@ -163,4 +163,5 @@
a_ip(ji,jj, jl) = ( a_ip(ji,jj, jl) * zwgt1 + dta%aip(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Ice pond concentration
h_ip(ji,jj, jl) = ( h_ip(ji,jj, jl) * zwgt1 + dta%hip(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Ice pond depth
+ h_il(ji,jj, jl) = ( h_il(ji,jj, jl) * zwgt1 + dta%hil(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Ice pond lid depth
!
sz_i(ji,jj,:,jl) = s_i(ji,jj,jl)
@@ -170,4 +171,9 @@
a_ip(ji,jj,jl) = 0._wp
h_ip(ji,jj,jl) = 0._wp
+ h_il(ji,jj,jl) = 0._wp
+ ENDIF
+
+ IF( .NOT.ln_pnd_lids ) THEN
+ h_il(ji,jj,jl) = 0._wp
ENDIF
!
@@ -231,4 +237,5 @@
a_ip(ji,jj, jl) = a_ip(ib,jb, jl)
h_ip(ji,jj, jl) = h_ip(ib,jb, jl)
+ h_il(ji,jj, jl) = h_il(ib,jb, jl)
!
sz_i(ji,jj,:,jl) = sz_i(ib,jb,:,jl)
@@ -265,10 +272,6 @@
!
! melt ponds
- IF( a_i(ji,jj,jl) > epsi10 ) 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
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)
!
ELSE ! no ice at the boundary
@@ -278,14 +281,11 @@
h_s (ji,jj, jl) = 0._wp
oa_i(ji,jj, jl) = 0._wp
- a_ip(ji,jj, jl) = 0._wp
- v_ip(ji,jj, jl) = 0._wp
t_su(ji,jj, jl) = rt0
t_s (ji,jj,:,jl) = rt0
t_i (ji,jj,:,jl) = rt0
- a_ip_frac(ji,jj,jl) = 0._wp
- h_ip (ji,jj,jl) = 0._wp
- a_ip (ji,jj,jl) = 0._wp
- v_ip (ji,jj,jl) = 0._wp
+ a_ip(ji,jj,jl) = 0._wp
+ h_ip(ji,jj,jl) = 0._wp
+ h_il(ji,jj,jl) = 0._wp
IF( nn_icesal == 1 ) THEN ! if constant salinity
@@ -303,4 +303,6 @@
e_s (ji,jj,:,jl) = 0._wp
e_i (ji,jj,:,jl) = 0._wp
+ v_ip(ji,jj, jl) = 0._wp
+ v_il(ji,jj, jl) = 0._wp
ENDIF
@@ -436,5 +438,5 @@
END DO
IF( ANY(llsend2) .OR. ANY(llrecv2) ) THEN ! if need to send/recv in at least one direction
- CALL lbc_lnk( 'bdyice', u_ice, 'U', -1., kfillmode=jpfillnothing ,lsend=llsend2, lrecv=llrecv2 )
+ CALL lbc_lnk( 'bdyice', u_ice, 'U', -1.0_wp, kfillmode=jpfillnothing ,lsend=llsend2, lrecv=llrecv2 )
END IF
CASE ( 'V' )
@@ -450,5 +452,5 @@
END DO
IF( ANY(llsend3) .OR. ANY(llrecv3) ) THEN ! if need to send/recv in at least one direction
- CALL lbc_lnk( 'bdyice', v_ice, 'V', -1., kfillmode=jpfillnothing ,lsend=llsend3, lrecv=llrecv3 )
+ CALL lbc_lnk( 'bdyice', v_ice, 'V', -1.0_wp, kfillmode=jpfillnothing ,lsend=llsend3, lrecv=llrecv3 )
END IF
END SELECT
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/BDY/bdyini.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/BDY/bdyini.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/BDY/bdyini.F90 (revision 13540)
@@ -19,9 +19,10 @@
USE oce ! ocean dynamics and tracers variables
USE dom_oce ! ocean space and time domain
+ USE sbc_oce , ONLY: nn_ice
USE bdy_oce ! unstructured open boundary conditions
USE bdydta ! open boundary cond. setting (bdy_dta_init routine)
USE bdytides ! open boundary cond. setting (bdytide_init routine)
USE tide_mod, ONLY: ln_tide ! tidal forcing
- USE phycst , ONLY: rday
+ USE phycst , ONLY: rday
!
USE in_out_manager ! I/O units
@@ -316,4 +317,9 @@
dta_bdy(ib_bdy)%lneed_ice = cn_ice(ib_bdy) /= 'none'
+ IF( dta_bdy(ib_bdy)%lneed_ice .AND. nn_ice /= 2 ) THEN
+ WRITE(ctmp1,*) 'bdy number ', ib_bdy,', needs ice model but nn_ice = ', nn_ice
+ CALL ctl_stop( ctmp1 )
+ ENDIF
+
IF( lwp .AND. dta_bdy(ib_bdy)%lneed_ice ) THEN
SELECT CASE( nn_ice_dta(ib_bdy) ) !
@@ -410,9 +416,9 @@
CALL iom_get( inum, jpdom_unknown, 'nbi'//cgrid(igrd), zz_read(1:nblendta(igrd,ib_bdy),:) )
DO ii = 1,nblendta(igrd,ib_bdy)
- nbidta(ii,igrd,ib_bdy) = NINT( zz_read(ii,1) )
+ nbidta(ii,igrd,ib_bdy) = NINT( zz_read(ii,1) ) + nn_hls
END DO
CALL iom_get( inum, jpdom_unknown, 'nbj'//cgrid(igrd), zz_read(1:nblendta(igrd,ib_bdy),:) )
DO ii = 1,nblendta(igrd,ib_bdy)
- nbjdta(ii,igrd,ib_bdy) = NINT( zz_read(ii,1) )
+ nbjdta(ii,igrd,ib_bdy) = NINT( zz_read(ii,1) ) + nn_hls
END DO
CALL iom_get( inum, jpdom_unknown, 'nbr'//cgrid(igrd), zz_read(1:nblendta(igrd,ib_bdy),:) )
@@ -632,5 +638,5 @@
END DO
END DO
- CALL lbc_lnk( 'bdyini', zfmask, 'F', 1. )
+ CALL lbc_lnk( 'bdyini', zfmask, 'F', 1.0_wp )
! Read global 2D mask at T-points: bdytmask
@@ -648,5 +654,5 @@
END DO
END DO
- CALL lbc_lnk_multi( 'bdyini', bdyumask, 'U', 1., bdyvmask, 'V', 1. ) ! Lateral boundary cond.
+ CALL lbc_lnk_multi( 'bdyini', bdyumask, 'U', 1.0_wp , bdyvmask, 'V', 1.0_wp ) ! Lateral boundary cond.
! bdy masks are now set to zero on rim 0 points:
@@ -689,5 +695,5 @@
END DO
END DO
- CALL lbc_lnk( 'bdyini', zfmask, 'F', 1. )
+ CALL lbc_lnk( 'bdyini', zfmask, 'F', 1.0_wp )
! bdy masks are now set to zero on rim1 points:
@@ -865,7 +871,7 @@
ENDIF
SELECT CASE( igrd )
- CASE( 1 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'T', 1. )
- CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1. )
- CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1. )
+ CASE( 1 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'T', 1.0_wp )
+ CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1.0_wp )
+ CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1.0_wp )
END SELECT
DO ib = ibeg, iend
@@ -913,7 +919,7 @@
ENDIF
SELECT CASE( igrd )
- CASE( 1 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'T', 1. )
- CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1. )
- CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1. )
+ CASE( 1 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'T', 1.0_wp )
+ CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1.0_wp )
+ CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1.0_wp )
END SELECT
DO ib = ibeg, iend
@@ -1001,7 +1007,7 @@
END DO
SELECT CASE( igrd )
- CASE( 1 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'T', 1. )
- CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1. )
- CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1. )
+ CASE( 1 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'T', 1.0_wp )
+ CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1.0_wp )
+ CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1.0_wp )
END SELECT
DO ib = ibeg, iend
@@ -1105,13 +1111,13 @@
CASE( 'N' )
IF( nbdyind == -1 ) THEN ! Automatic boundary definition: if nbdysegX = -1
- nbdyind = jpjglo - 2 ! set boundary to whole side of model domain.
+ nbdyind = Nj0glo - 2 ! set boundary to whole side of model domain.
nbdybeg = 2
- nbdyend = jpiglo - 1
+ nbdyend = Ni0glo -1
ENDIF
nbdysegn = nbdysegn + 1
npckgn(nbdysegn) = kb_bdy ! Save bdy package number
- jpjnob(nbdysegn) = nbdyind
- jpindt(nbdysegn) = nbdybeg
- jpinft(nbdysegn) = nbdyend
+ jpjnob(nbdysegn) = nbdyind + nn_hls
+ jpindt(nbdysegn) = nbdybeg + nn_hls
+ jpinft(nbdysegn) = nbdyend + nn_hls
!
CASE( 'S' )
@@ -1119,23 +1125,23 @@
nbdyind = 2 ! set boundary to whole side of model domain.
nbdybeg = 2
- nbdyend = jpiglo - 1
+ nbdyend = Ni0glo - 1
ENDIF
nbdysegs = nbdysegs + 1
npckgs(nbdysegs) = kb_bdy ! Save bdy package number
- jpjsob(nbdysegs) = nbdyind
- jpisdt(nbdysegs) = nbdybeg
- jpisft(nbdysegs) = nbdyend
+ jpjsob(nbdysegs) = nbdyind + nn_hls
+ jpisdt(nbdysegs) = nbdybeg + nn_hls
+ jpisft(nbdysegs) = nbdyend + nn_hls
!
CASE( 'E' )
IF( nbdyind == -1 ) THEN ! Automatic boundary definition: if nbdysegX = -1
- nbdyind = jpiglo - 2 ! set boundary to whole side of model domain.
+ nbdyind = Ni0glo - 2 ! set boundary to whole side of model domain.
nbdybeg = 2
- nbdyend = jpjglo - 1
+ nbdyend = Nj0glo - 1
ENDIF
nbdysege = nbdysege + 1
npckge(nbdysege) = kb_bdy ! Save bdy package number
- jpieob(nbdysege) = nbdyind
- jpjedt(nbdysege) = nbdybeg
- jpjeft(nbdysege) = nbdyend
+ jpieob(nbdysege) = nbdyind + nn_hls
+ jpjedt(nbdysege) = nbdybeg + nn_hls
+ jpjeft(nbdysege) = nbdyend + nn_hls
!
CASE( 'W' )
@@ -1143,11 +1149,11 @@
nbdyind = 2 ! set boundary to whole side of model domain.
nbdybeg = 2
- nbdyend = jpjglo - 1
+ nbdyend = Nj0glo - 1
ENDIF
nbdysegw = nbdysegw + 1
npckgw(nbdysegw) = kb_bdy ! Save bdy package number
- jpiwob(nbdysegw) = nbdyind
- jpjwdt(nbdysegw) = nbdybeg
- jpjwft(nbdysegw) = nbdyend
+ jpiwob(nbdysegw) = nbdyind + nn_hls
+ jpjwdt(nbdysegw) = nbdybeg + nn_hls
+ jpjwft(nbdysegw) = nbdyend + nn_hls
!
CASE DEFAULT ; CALL ctl_stop( 'ctypebdy must be N, S, E or W' )
@@ -1186,4 +1192,5 @@
IF(lwp) WRITE(numout,*) 'Number of north segments : ', nbdysegn
IF(lwp) WRITE(numout,*) 'Number of south segments : ', nbdysegs
+ !
! 1. Check bounds
!----------------
@@ -1223,5 +1230,4 @@
IF (jpjwft(ib).gt.jpjglo) CALL ctl_stop( 'End index out of domain' )
ENDDO
- !
!
! 2. Look for segment crossings
@@ -1372,8 +1378,6 @@
DO ji = 1, jpi
DO jj = 1, jpj
- IF (((ji + nimpp - 1) == jpiwob(ib)).AND. &
- & ((jj + njmpp - 1) == jpjwdt(ib))) ztestmask(1)=tmask(ji,jj,1)
- IF (((ji + nimpp - 1) == jpiwob(ib)).AND. &
- & ((jj + njmpp - 1) == jpjwft(ib))) ztestmask(2)=tmask(ji,jj,1)
+ IF( mig(ji) == jpiwob(ib) .AND. mjg(jj) == jpjwdt(ib) ) ztestmask(1) = tmask(ji,jj,1)
+ IF( mig(ji) == jpiwob(ib) .AND. mjg(jj) == jpjwft(ib) ) ztestmask(2) = tmask(ji,jj,1)
END DO
END DO
@@ -1410,8 +1414,6 @@
DO ji = 1, jpi
DO jj = 1, jpj
- IF (((ji + nimpp - 1) == jpieob(ib)+1).AND. &
- & ((jj + njmpp - 1) == jpjedt(ib))) ztestmask(1)=tmask(ji,jj,1)
- IF (((ji + nimpp - 1) == jpieob(ib)+1).AND. &
- & ((jj + njmpp - 1) == jpjeft(ib))) ztestmask(2)=tmask(ji,jj,1)
+ IF( mig(ji) == jpieob(ib)+1 .AND. mjg(jj) == jpjedt(ib) ) ztestmask(1) = tmask(ji,jj,1)
+ IF( mig(ji) == jpieob(ib)+1 .AND. mjg(jj) == jpjeft(ib) ) ztestmask(2) = tmask(ji,jj,1)
END DO
END DO
@@ -1448,8 +1450,6 @@
DO ji = 1, jpi
DO jj = 1, jpj
- IF (((jj + njmpp - 1) == jpjsob(ib)).AND. &
- & ((ji + nimpp - 1) == jpisdt(ib))) ztestmask(1)=tmask(ji,jj,1)
- IF (((jj + njmpp - 1) == jpjsob(ib)).AND. &
- & ((ji + nimpp - 1) == jpisft(ib))) ztestmask(2)=tmask(ji,jj,1)
+ IF( mjg(jj) == jpjsob(ib) .AND. mig(ji) == jpisdt(ib) ) ztestmask(1) = tmask(ji,jj,1)
+ IF( mjg(jj) == jpjsob(ib) .AND. mig(ji) == jpisft(ib) ) ztestmask(2) = tmask(ji,jj,1)
END DO
END DO
@@ -1472,8 +1472,6 @@
DO ji = 1, jpi
DO jj = 1, jpj
- IF (((jj + njmpp - 1) == jpjnob(ib)+1).AND. &
- & ((ji + nimpp - 1) == jpindt(ib))) ztestmask(1)=tmask(ji,jj,1)
- IF (((jj + njmpp - 1) == jpjnob(ib)+1).AND. &
- & ((ji + nimpp - 1) == jpinft(ib))) ztestmask(2)=tmask(ji,jj,1)
+ IF( mjg(jj) == jpjnob(ib)+1 .AND. mig(ji) == jpindt(ib) ) ztestmask(1) = tmask(ji,jj,1)
+ IF( mjg(jj) == jpjnob(ib)+1 .AND. mig(ji) == jpinft(ib) ) ztestmask(2) = tmask(ji,jj,1)
END DO
END DO
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/BDY/bdylib.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/BDY/bdylib.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/BDY/bdylib.F90 (revision 13540)
@@ -44,5 +44,5 @@
!!----------------------------------------------------------------------
TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices
- REAL(wp), DIMENSION(:,:), INTENT(in) :: dta ! OBC external data
+ REAL(wp), DIMENSION(:,:), POINTER, INTENT(in) :: dta ! OBC external data
REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: phia ! tracer trend
!!
@@ -73,5 +73,5 @@
!!----------------------------------------------------------------------
TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices
- REAL(wp), DIMENSION(:,:), INTENT(in) :: dta ! OBC external data
+ REAL(wp), DIMENSION(:,:), POINTER, INTENT(in) :: dta ! OBC external data
REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: phia ! tracer trend
!!
@@ -100,10 +100,10 @@
!!
!!----------------------------------------------------------------------
- TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices
- REAL(wp), DIMENSION(:,:), INTENT(in) :: dta ! OBC external data
- REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: phib ! before tracer field
- REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: phia ! tracer trend
- LOGICAL , OPTIONAL, INTENT(in) :: lrim0 ! indicate if rim 0 is treated
- LOGICAL, INTENT(in) :: ll_npo ! switch for NPO version
+ TYPE(OBC_INDEX), INTENT(in ) :: idx ! OBC indices
+ REAL(wp), DIMENSION(:,:), POINTER, INTENT(in ) :: dta ! OBC external data
+ REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: phib ! before tracer field
+ REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: phia ! tracer trend
+ LOGICAL , INTENT(in ) :: lrim0 ! indicate if rim 0 is treated
+ LOGICAL , INTENT(in ) :: ll_npo ! switch for NPO version
!!
INTEGER :: igrd ! grid index
@@ -128,11 +128,11 @@
!! References: Marchesiello, McWilliams and Shchepetkin, Ocean Modelling vol. 3 (2001)
!!----------------------------------------------------------------------
- TYPE(OBC_INDEX), INTENT(in ) :: idx ! BDY indices
- INTEGER , INTENT(in ) :: igrd ! grid index
- REAL(wp), DIMENSION(:,:), INTENT(in ) :: phib ! model before 2D field
- REAL(wp), DIMENSION(:,:), INTENT(inout) :: phia ! model after 2D field (to be updated)
- REAL(wp), DIMENSION(:) , INTENT(in ) :: phi_ext ! external forcing data
- LOGICAL, OPTIONAL, INTENT(in ) :: lrim0 ! indicate if rim 0 is treated
- LOGICAL , INTENT(in ) :: ll_npo ! switch for NPO version
+ TYPE(OBC_INDEX), INTENT(in ) :: idx ! BDY indices
+ INTEGER , INTENT(in ) :: igrd ! grid index
+ REAL(wp), DIMENSION(:,:), INTENT(in ) :: phib ! model before 2D field
+ REAL(wp), DIMENSION(:,:), INTENT(inout) :: phia ! model after 2D field (to be updated)
+ REAL(wp), DIMENSION(: ), POINTER, INTENT(in ) :: phi_ext ! external forcing data
+ LOGICAL , INTENT(in ) :: lrim0 ! indicate if rim 0 is treated
+ LOGICAL , INTENT(in ) :: ll_npo ! switch for NPO version
!
INTEGER :: jb ! dummy loop indices
@@ -188,10 +188,7 @@
END SELECT
!
- IF( PRESENT(lrim0) ) THEN
- IF( lrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) ! rim 0
- ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) ! rim 1
- END IF
- ELSE ; ibeg = 1 ; iend = idx%nblenrim(igrd) ! both
- END IF
+ IF( lrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) ! rim 0
+ ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) ! rim 1
+ ENDIF
!
DO jb = ibeg, iend
@@ -249,5 +246,5 @@
!!$ zdy_centred = phib(iibm1jp1,ijbm1jp1) - phib(iibm1jm1,ijbm1jm1)
! upstream differencing for tangential derivatives
- zsign_ups = sign( 1., zdt * zdy_centred )
+ zsign_ups = sign( 1.0_wp, zdt * zdy_centred )
zsign_ups = 0.5*( zsign_ups + abs(zsign_ups) )
zdy = zsign_ups * zdy_1 + (1. - zsign_ups) * zdy_2
@@ -257,5 +254,5 @@
zrx = zdt * zdx / ( zex1 * znor2 )
!!$ zrx = min(zrx,2.0_wp)
- zout = sign( 1., zrx )
+ zout = sign( 1.0_wp, zrx )
zout = 0.5*( zout + abs(zout) )
zwgt = 2.*rn_Dt*( (1.-zout) * idx%nbd(jb,igrd) + zout * idx%nbdout(jb,igrd) )
@@ -266,5 +263,5 @@
& + zwgt * ( phi_ext(jb) - phib(ii,ij) ) ) / ( 1. + zrx )
else !! full oblique radiation !!
- zsign_ups = sign( 1., zdt * zdy )
+ zsign_ups = sign( 1.0_wp, zdt * zdy )
zsign_ups = 0.5*( zsign_ups + abs(zsign_ups) )
zey = zsign_ups * zey1 + (1.-zsign_ups) * zey2
@@ -275,5 +272,5 @@
& - (1.-zsign_ups) * zry * ( phib(iijp1,ijjp1) - phib(ii ,ij ) ) &
& + zwgt * ( phi_ext(jb) - phib(ii,ij) ) ) / ( 1. + zrx )
- end if
+ endif
phia(ii,ij) = phia(ii,ij) * zmask(ii,ij)
END DO
@@ -293,11 +290,11 @@
!! References: Marchesiello, McWilliams and Shchepetkin, Ocean Modelling vol. 3 (2001)
!!----------------------------------------------------------------------
- TYPE(OBC_INDEX), INTENT(in ) :: idx ! BDY indices
- INTEGER , INTENT(in ) :: igrd ! grid index
- REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: phib ! model before 3D field
- REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: phia ! model after 3D field (to be updated)
- REAL(wp), DIMENSION(:,:) , INTENT(in ) :: phi_ext ! external forcing data
- LOGICAL, OPTIONAL, INTENT(in ) :: lrim0 ! indicate if rim 0 is treated
- LOGICAL , INTENT(in ) :: ll_npo ! switch for NPO version
+ TYPE(OBC_INDEX), INTENT(in ) :: idx ! BDY indices
+ INTEGER , INTENT(in ) :: igrd ! grid index
+ REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: phib ! model before 3D field
+ REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: phia ! model after 3D field (to be updated)
+ REAL(wp), DIMENSION(:,: ), POINTER, INTENT(in ) :: phi_ext ! external forcing data
+ LOGICAL , INTENT(in ) :: lrim0 ! indicate if rim 0 is treated
+ LOGICAL , INTENT(in ) :: ll_npo ! switch for NPO version
!
INTEGER :: jb, jk ! dummy loop indices
@@ -353,10 +350,7 @@
END SELECT
!
- IF( PRESENT(lrim0) ) THEN
- IF( lrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) ! rim 0
- ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) ! rim 1
- END IF
- ELSE ; ibeg = 1 ; iend = idx%nblenrim(igrd) ! both
- END IF
+ IF( lrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) ! rim 0
+ ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) ! rim 1
+ ENDIF
!
DO jk = 1, jpk
@@ -414,5 +408,5 @@
!!$ zdy_centred = phib(iibm1jp1,ijbm1jp1,jk) - phib(iibm1jm1,ijbm1jm1,jk)
! upstream differencing for tangential derivatives
- zsign_ups = sign( 1., zdt * zdy_centred )
+ zsign_ups = sign( 1.0_wp, zdt * zdy_centred )
zsign_ups = 0.5*( zsign_ups + abs(zsign_ups) )
zdy = zsign_ups * zdy_1 + (1. - zsign_ups) * zdy_2
@@ -423,5 +417,5 @@
zrx = zdt * zdx / ( zex1 * znor2 )
!!$ zrx = min(zrx,2.0_wp)
- zout = sign( 1., zrx )
+ zout = sign( 1.0_wp, zrx )
zout = 0.5*( zout + abs(zout) )
zwgt = 2.*rn_Dt*( (1.-zout) * idx%nbd(jb,igrd) + zout * idx%nbdout(jb,igrd) )
@@ -432,5 +426,5 @@
& + zwgt * ( phi_ext(jb,jk) - phib(ii,ij,jk) ) ) / ( 1. + zrx )
else !! full oblique radiation !!
- zsign_ups = sign( 1., zdt * zdy )
+ zsign_ups = sign( 1.0_wp, zdt * zdy )
zsign_ups = 0.5*( zsign_ups + abs(zsign_ups) )
zey = zsign_ups * zey1 + (1.-zsign_ups) * zey2
@@ -441,5 +435,5 @@
& - (1.-zsign_ups) * zry * ( phib(iijp1,ijjp1,jk) - phib(ii ,ij ,jk) ) &
& + zwgt * ( phi_ext(jb,jk) - phib(ii,ij,jk) ) ) / ( 1. + zrx )
- end if
+ endif
phia(ii,ij,jk) = phia(ii,ij,jk) * zmask(ii,ij,jk)
END DO
@@ -466,5 +460,5 @@
REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: phia ! model after 3D field (to be updated), must be masked
TYPE(OBC_INDEX), INTENT(in ) :: idx ! OBC indices
- LOGICAL, OPTIONAL, INTENT(in ) :: lrim0 ! indicate if rim 0 is treated
+ LOGICAL , INTENT(in ) :: lrim0 ! indicate if rim 0 is treated
!!
REAL(wp) :: zweight
@@ -486,10 +480,7 @@
END SELECT
!
- IF( PRESENT(lrim0) ) THEN
- IF( lrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) ! rim 0
- ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) ! rim 1
- END IF
- ELSE ; ibeg = 1 ; iend = idx%nblenrim(igrd) ! both
- END IF
+ IF( lrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) ! rim 0
+ ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) ! rim 1
+ ENDIF
!
DO ib = ibeg, iend
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/BDY/bdytides.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/BDY/bdytides.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/BDY/bdytides.F90 (revision 13540)
@@ -65,19 +65,20 @@
!! namelist variables
!!-------------------
- CHARACTER(len=80) :: filtide !: Filename root for tidal input files
- LOGICAL :: ln_bdytide_2ddta !: If true, read 2d harmonic data
+ CHARACTER(len=80) :: filtide ! Filename root for tidal input files
+ LOGICAL :: ln_bdytide_2ddta ! If true, read 2d harmonic data
!!
- INTEGER :: ib_bdy, itide, ib !: dummy loop indices
- INTEGER :: ii, ij !: dummy loop indices
+ INTEGER :: ib_bdy, itide, ib ! dummy loop indices
+ INTEGER :: ii, ij ! dummy loop indices
INTEGER :: inum, igrd
- INTEGER, DIMENSION(3) :: ilen0 !: length of boundary data (from OBC arrays)
+ INTEGER :: isz ! bdy data size
INTEGER :: ios ! Local integer output status for namelist read
INTEGER :: nbdy_rdstart, nbdy_loc
- CHARACTER(LEN=50) :: cerrmsg !: error string
- CHARACTER(len=80) :: clfile !: full file name for tidal input file
- REAL(wp),ALLOCATABLE, DIMENSION(:,:,:) :: dta_read !: work space to read in tidal harmonics data
- REAL(wp),ALLOCATABLE, DIMENSION(:,:) :: ztr, zti !: " " " " " " " "
+ CHARACTER(LEN=50) :: cerrmsg ! error string
+ CHARACTER(len=80) :: clfile ! full file name for tidal input file
+ REAL(wp),ALLOCATABLE, DIMENSION(:,:,:) :: dta_read ! work space to read in tidal harmonics data
+ REAL(wp),ALLOCATABLE, DIMENSION(:,:) :: ztr, zti ! " " " " " " " "
!!
- TYPE(TIDES_DATA), POINTER :: td !: local short cut
+ TYPE(TIDES_DATA), POINTER :: td ! local short cut
+ TYPE( OBC_DATA), POINTER :: dta ! local short cut
!!
NAMELIST/nambdy_tide/filtide, ln_bdytide_2ddta
@@ -93,6 +94,7 @@
IF( nn_dyn2d_dta(ib_bdy) >= 2 ) THEN
!
- td => tides(ib_bdy)
-
+ td => tides(ib_bdy)
+ dta => dta_bdy(ib_bdy)
+
! Namelist nambdy_tide : tidal harmonic forcing at open boundaries
filtide(:) = ''
@@ -130,30 +132,28 @@
IF(lwp) WRITE(numout,*) ' '
- ! Allocate space for tidal harmonics data - get size from OBC data arrays
+ ! Allocate space for tidal harmonics data - get size from BDY data arrays
+ ! Allocate also slow varying data in the case of time splitting:
+ ! Do it anyway because at this stage knowledge of free surface scheme is unknown
! -----------------------------------------------------------------------
-
- ! JC: If FRS scheme is used, we assume that tidal is needed over the whole
- ! relaxation area
- IF( cn_dyn2d(ib_bdy) == 'frs' ) THEN ; ilen0(:) = idx_bdy(ib_bdy)%nblen (:)
- ELSE ; ilen0(:) = idx_bdy(ib_bdy)%nblenrim(:)
- ENDIF
-
- ALLOCATE( td%ssh0( ilen0(1), nb_harmo, 2 ) )
- ALLOCATE( td%ssh ( ilen0(1), nb_harmo, 2 ) )
-
- ALLOCATE( td%u0( ilen0(2), nb_harmo, 2 ) )
- ALLOCATE( td%u ( ilen0(2), nb_harmo, 2 ) )
-
- ALLOCATE( td%v0( ilen0(3), nb_harmo, 2 ) )
- ALLOCATE( td%v ( ilen0(3), nb_harmo, 2 ) )
-
- td%ssh0(:,:,:) = 0._wp
- td%ssh (:,:,:) = 0._wp
- td%u0 (:,:,:) = 0._wp
- td%u (:,:,:) = 0._wp
- td%v0 (:,:,:) = 0._wp
- td%v (:,:,:) = 0._wp
-
+ IF( ASSOCIATED(dta%ssh) ) THEN ! we use bdy ssh on this mpi subdomain
+ isz = SIZE(dta%ssh)
+ ALLOCATE( td%ssh0( isz, nb_harmo, 2 ), td%ssh( isz, nb_harmo, 2 ), dta_bdy_s(ib_bdy)%ssh( isz ) )
+ dta_bdy_s(ib_bdy)%ssh(:) = 0._wp ! needed?
+ ENDIF
+ IF( ASSOCIATED(dta%u2d) ) THEN ! we use bdy u2d on this mpi subdomain
+ isz = SIZE(dta%u2d)
+ ALLOCATE( td%u0 ( isz, nb_harmo, 2 ), td%u ( isz, nb_harmo, 2 ), dta_bdy_s(ib_bdy)%u2d( isz ) )
+ dta_bdy_s(ib_bdy)%u2d(:) = 0._wp ! needed?
+ ENDIF
+ IF( ASSOCIATED(dta%v2d) ) THEN ! we use bdy v2d on this mpi subdomain
+ isz = SIZE(dta%v2d)
+ ALLOCATE( td%v0 ( isz, nb_harmo, 2 ), td%v ( isz, nb_harmo, 2 ), dta_bdy_s(ib_bdy)%v2d( isz ) )
+ dta_bdy_s(ib_bdy)%v2d(:) = 0._wp ! needed?
+ ENDIF
+
+ ! fill td%ssh0, td%u0, td%v0
+ ! -----------------------------------------------------------------------
IF( ln_bdytide_2ddta ) THEN
+ !
! It is assumed that each data file contains all complex harmonic amplitudes
! given on the global domain (ie global, jpiglo x jpjglo)
@@ -162,53 +162,56 @@
!
! SSH fields
- clfile = TRIM(filtide)//'_grid_T.nc'
- CALL iom_open( clfile , inum )
- igrd = 1 ! Everything is at T-points here
- DO itide = 1, nb_harmo
- CALL iom_get( inum, jpdom_autoglo, TRIM(tide_harmonics(itide)%cname_tide)//'_z1', ztr(:,:) )
- CALL iom_get( inum, jpdom_autoglo, TRIM(tide_harmonics(itide)%cname_tide)//'_z2', zti(:,:) )
- DO ib = 1, ilen0(igrd)
- ii = idx_bdy(ib_bdy)%nbi(ib,igrd)
- ij = idx_bdy(ib_bdy)%nbj(ib,igrd)
- IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE ! to remove?
- td%ssh0(ib,itide,1) = ztr(ii,ij)
- td%ssh0(ib,itide,2) = zti(ii,ij)
- END DO
- END DO
- CALL iom_close( inum )
+ IF( ASSOCIATED(dta%ssh) ) THEN ! we use bdy ssh on this mpi subdomain
+ clfile = TRIM(filtide)//'_grid_T.nc'
+ CALL iom_open( clfile , inum )
+ igrd = 1 ! Everything is at T-points here
+ DO itide = 1, nb_harmo
+ CALL iom_get( inum, jpdom_auto, TRIM(tide_harmonics(itide)%cname_tide)//'_z1', ztr(:,:) )
+ CALL iom_get( inum, jpdom_auto, TRIM(tide_harmonics(itide)%cname_tide)//'_z2', zti(:,:) )
+ DO ib = 1, SIZE(dta%ssh)
+ ii = idx_bdy(ib_bdy)%nbi(ib,igrd)
+ ij = idx_bdy(ib_bdy)%nbj(ib,igrd)
+ td%ssh0(ib,itide,1) = ztr(ii,ij)
+ td%ssh0(ib,itide,2) = zti(ii,ij)
+ END DO
+ END DO
+ CALL iom_close( inum )
+ ENDIF
!
! U fields
- clfile = TRIM(filtide)//'_grid_U.nc'
- CALL iom_open( clfile , inum )
- igrd = 2 ! Everything is at U-points here
- DO itide = 1, nb_harmo
- CALL iom_get ( inum, jpdom_autoglo, TRIM(tide_harmonics(itide)%cname_tide)//'_u1', ztr(:,:) )
- CALL iom_get ( inum, jpdom_autoglo, TRIM(tide_harmonics(itide)%cname_tide)//'_u2', zti(:,:) )
- DO ib = 1, ilen0(igrd)
- ii = idx_bdy(ib_bdy)%nbi(ib,igrd)
- ij = idx_bdy(ib_bdy)%nbj(ib,igrd)
- IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE ! to remove?
- td%u0(ib,itide,1) = ztr(ii,ij)
- td%u0(ib,itide,2) = zti(ii,ij)
- END DO
- END DO
- CALL iom_close( inum )
+ IF( ASSOCIATED(dta%u2d) ) THEN ! we use bdy u2d on this mpi subdomain
+ clfile = TRIM(filtide)//'_grid_U.nc'
+ CALL iom_open( clfile , inum )
+ igrd = 2 ! Everything is at U-points here
+ DO itide = 1, nb_harmo
+ CALL iom_get(inum, jpdom_auto, TRIM(tide_harmonics(itide)%cname_tide)//'_u1', ztr(:,:),cd_type='U',psgn=-1._wp)
+ CALL iom_get(inum, jpdom_auto, TRIM(tide_harmonics(itide)%cname_tide)//'_u2', zti(:,:),cd_type='U',psgn=-1._wp)
+ DO ib = 1, SIZE(dta%u2d)
+ ii = idx_bdy(ib_bdy)%nbi(ib,igrd)
+ ij = idx_bdy(ib_bdy)%nbj(ib,igrd)
+ td%u0(ib,itide,1) = ztr(ii,ij)
+ td%u0(ib,itide,2) = zti(ii,ij)
+ END DO
+ END DO
+ CALL iom_close( inum )
+ ENDIF
!
! V fields
- clfile = TRIM(filtide)//'_grid_V.nc'
- CALL iom_open( clfile , inum )
- igrd = 3 ! Everything is at V-points here
- DO itide = 1, nb_harmo
- CALL iom_get ( inum, jpdom_autoglo, TRIM(tide_harmonics(itide)%cname_tide)//'_v1', ztr(:,:) )
- CALL iom_get ( inum, jpdom_autoglo, TRIM(tide_harmonics(itide)%cname_tide)//'_v2', zti(:,:) )
- DO ib = 1, ilen0(igrd)
- ii = idx_bdy(ib_bdy)%nbi(ib,igrd)
- ij = idx_bdy(ib_bdy)%nbj(ib,igrd)
- IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE ! to remove?
- td%v0(ib,itide,1) = ztr(ii,ij)
- td%v0(ib,itide,2) = zti(ii,ij)
- END DO
- END DO
- CALL iom_close( inum )
+ IF( ASSOCIATED(dta%v2d) ) THEN ! we use bdy v2d on this mpi subdomain
+ clfile = TRIM(filtide)//'_grid_V.nc'
+ CALL iom_open( clfile , inum )
+ igrd = 3 ! Everything is at V-points here
+ DO itide = 1, nb_harmo
+ CALL iom_get(inum, jpdom_auto, TRIM(tide_harmonics(itide)%cname_tide)//'_v1', ztr(:,:),cd_type='V',psgn=-1._wp)
+ CALL iom_get(inum, jpdom_auto, TRIM(tide_harmonics(itide)%cname_tide)//'_v2', zti(:,:),cd_type='V',psgn=-1._wp)
+ DO ib = 1, SIZE(dta%v2d)
+ ii = idx_bdy(ib_bdy)%nbi(ib,igrd)
+ ij = idx_bdy(ib_bdy)%nbj(ib,igrd)
+ td%v0(ib,itide,1) = ztr(ii,ij)
+ td%v0(ib,itide,2) = zti(ii,ij)
+ END DO
+ END DO
+ CALL iom_close( inum )
+ ENDIF
!
DEALLOCATE( ztr, zti )
@@ -218,5 +221,5 @@
! Read tidal data only on bdy segments
!
- ALLOCATE( dta_read( MAXVAL(ilen0(1:3)), 1, 1 ) )
+ ALLOCATE( dta_read( MAXVAL( idx_bdy(ib_bdy)%nblen(:) ), 1, 1 ) )
!
! Open files and read in tidal forcing data
@@ -225,27 +228,36 @@
DO itide = 1, nb_harmo
! ! SSH fields
- clfile = TRIM(filtide)//TRIM(tide_harmonics(itide)%cname_tide)//'_grid_T.nc'
- CALL iom_open( clfile, inum )
- CALL fld_map( inum, 'z1' , dta_read(1:ilen0(1),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,1) )
- td%ssh0(:,itide,1) = dta_read(1:ilen0(1),1,1)
- CALL fld_map( inum, 'z2' , dta_read(1:ilen0(1),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,1) )
- td%ssh0(:,itide,2) = dta_read(1:ilen0(1),1,1)
- CALL iom_close( inum )
+ IF( ASSOCIATED(dta%ssh) ) THEN ! we use bdy ssh on this mpi subdomain
+ isz = SIZE(dta%ssh)
+ clfile = TRIM(filtide)//TRIM(tide_harmonics(itide)%cname_tide)//'_grid_T.nc'
+ CALL iom_open( clfile, inum )
+ CALL fld_map( inum, 'z1', dta_read(1:isz,1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,1) )
+ td%ssh0(:,itide,1) = dta_read(1:isz,1,1)
+ CALL fld_map( inum, 'z2', dta_read(1:isz,1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,1) )
+ td%ssh0(:,itide,2) = dta_read(1:isz,1,1)
+ CALL iom_close( inum )
+ ENDIF
! ! U fields
- clfile = TRIM(filtide)//TRIM(tide_harmonics(itide)%cname_tide)//'_grid_U.nc'
- CALL iom_open( clfile, inum )
- CALL fld_map( inum, 'u1' , dta_read(1:ilen0(2),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,2) )
- td%u0(:,itide,1) = dta_read(1:ilen0(2),1,1)
- CALL fld_map( inum, 'u2' , dta_read(1:ilen0(2),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,2) )
- td%u0(:,itide,2) = dta_read(1:ilen0(2),1,1)
- CALL iom_close( inum )
+ IF( ASSOCIATED(dta%u2d) ) THEN ! we use bdy u2d on this mpi subdomain
+ isz = SIZE(dta%u2d)
+ clfile = TRIM(filtide)//TRIM(tide_harmonics(itide)%cname_tide)//'_grid_U.nc'
+ CALL iom_open( clfile, inum )
+ CALL fld_map( inum, 'u1', dta_read(1:isz,1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,2) )
+ td%u0(:,itide,1) = dta_read(1:isz,1,1)
+ CALL fld_map( inum, 'u2', dta_read(1:isz,1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,2) )
+ td%u0(:,itide,2) = dta_read(1:isz,1,1)
+ CALL iom_close( inum )
+ ENDIF
! ! V fields
- clfile = TRIM(filtide)//TRIM(tide_harmonics(itide)%cname_tide)//'_grid_V.nc'
- CALL iom_open( clfile, inum )
- CALL fld_map( inum, 'v1' , dta_read(1:ilen0(3),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,3) )
- td%v0(:,itide,1) = dta_read(1:ilen0(3),1,1)
- CALL fld_map( inum, 'v2' , dta_read(1:ilen0(3),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,3) )
- td%v0(:,itide,2) = dta_read(1:ilen0(3),1,1)
- CALL iom_close( inum )
+ IF( ASSOCIATED(dta%v2d) ) THEN ! we use bdy v2d on this mpi subdomain
+ isz = SIZE(dta%v2d)
+ clfile = TRIM(filtide)//TRIM(tide_harmonics(itide)%cname_tide)//'_grid_V.nc'
+ CALL iom_open( clfile, inum )
+ CALL fld_map( inum, 'v1', dta_read(1:isz,1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,3) )
+ td%v0(:,itide,1) = dta_read(1:isz,1,1)
+ CALL fld_map( inum, 'v2', dta_read(1:isz,1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,3) )
+ td%v0(:,itide,2) = dta_read(1:isz,1,1)
+ CALL iom_close( inum )
+ ENDIF
!
END DO ! end loop on tidal components
@@ -254,13 +266,4 @@
!
ENDIF ! ln_bdytide_2ddta=.true.
- !
- ! Allocate slow varying data in the case of time splitting:
- ! Do it anyway because at this stage knowledge of free surface scheme is unknown
- ALLOCATE( dta_bdy_s(ib_bdy)%ssh ( ilen0(1) ) )
- ALLOCATE( dta_bdy_s(ib_bdy)%u2d ( ilen0(2) ) )
- ALLOCATE( dta_bdy_s(ib_bdy)%v2d ( ilen0(3) ) )
- dta_bdy_s(ib_bdy)%ssh(:) = 0._wp
- dta_bdy_s(ib_bdy)%u2d(:) = 0._wp
- dta_bdy_s(ib_bdy)%v2d(:) = 0._wp
!
ENDIF ! nn_dyn2d_dta(ib_bdy) >= 2
@@ -283,7 +286,5 @@
!
LOGICAL :: lk_first_btstp ! =.TRUE. if time splitting and first barotropic step
- INTEGER :: itide, ib_bdy, ib, igrd ! loop indices
- INTEGER, DIMENSION(jpbgrd) :: ilen0
- INTEGER, DIMENSION(1:jpbgrd) :: nblen, nblenrim ! short cuts
+ INTEGER :: itide, ib_bdy, ib ! loop indices
REAL(wp) :: z_arg, z_sarg, zramp, zoff, z_cost, z_sist, zt_offset
!!----------------------------------------------------------------------
@@ -310,11 +311,4 @@
IF( nn_dyn2d_dta(ib_bdy) >= 2 ) THEN
!
- nblen(1:jpbgrd) = idx_bdy(ib_bdy)%nblen(1:jpbgrd)
- nblenrim(1:jpbgrd) = idx_bdy(ib_bdy)%nblenrim(1:jpbgrd)
- !
- IF( cn_dyn2d(ib_bdy) == 'frs' ) THEN ; ilen0(:) = nblen (:)
- ELSE ; ilen0(:) = nblenrim(:)
- ENDIF
- !
! We refresh nodal factors every day below
! This should be done somewhere else
@@ -337,7 +331,7 @@
! If time splitting, initialize arrays from slow varying open boundary data:
IF ( PRESENT(kit) ) THEN
- IF ( dta_bdy(ib_bdy)%lneed_ssh ) dta_bdy(ib_bdy)%ssh(1:ilen0(1)) = dta_bdy_s(ib_bdy)%ssh(1:ilen0(1))
- IF ( dta_bdy(ib_bdy)%lneed_dyn2d ) dta_bdy(ib_bdy)%u2d(1:ilen0(2)) = dta_bdy_s(ib_bdy)%u2d(1:ilen0(2))
- IF ( dta_bdy(ib_bdy)%lneed_dyn2d ) dta_bdy(ib_bdy)%v2d(1:ilen0(3)) = dta_bdy_s(ib_bdy)%v2d(1:ilen0(3))
+ IF ( ASSOCIATED(dta_bdy(ib_bdy)%ssh) ) dta_bdy(ib_bdy)%ssh(:) = dta_bdy_s(ib_bdy)%ssh(:)
+ IF ( ASSOCIATED(dta_bdy(ib_bdy)%u2d) ) dta_bdy(ib_bdy)%u2d(:) = dta_bdy_s(ib_bdy)%u2d(:)
+ IF ( ASSOCIATED(dta_bdy(ib_bdy)%v2d) ) dta_bdy(ib_bdy)%v2d(:) = dta_bdy_s(ib_bdy)%v2d(:)
ENDIF
!
@@ -349,7 +343,6 @@
z_sist = zramp * SIN( z_sarg )
!
- IF ( dta_bdy(ib_bdy)%lneed_ssh ) THEN
- igrd=1 ! SSH on tracer grid
- DO ib = 1, ilen0(igrd)
+ IF ( ASSOCIATED(dta_bdy(ib_bdy)%ssh) ) THEN ! SSH on tracer grid
+ DO ib = 1, SIZE(dta_bdy(ib_bdy)%ssh)
dta_bdy(ib_bdy)%ssh(ib) = dta_bdy(ib_bdy)%ssh(ib) + &
& ( tides(ib_bdy)%ssh(ib,itide,1)*z_cost + &
@@ -358,13 +351,14 @@
ENDIF
!
- IF ( dta_bdy(ib_bdy)%lneed_dyn2d ) THEN
- igrd=2 ! U grid
- DO ib = 1, ilen0(igrd)
+ IF ( ASSOCIATED(dta_bdy(ib_bdy)%u2d) ) THEN ! U grid
+ DO ib = 1, SIZE(dta_bdy(ib_bdy)%u2d)
dta_bdy(ib_bdy)%u2d(ib) = dta_bdy(ib_bdy)%u2d(ib) + &
& ( tides(ib_bdy)%u(ib,itide,1)*z_cost + &
& tides(ib_bdy)%u(ib,itide,2)*z_sist )
END DO
- igrd=3 ! V grid
- DO ib = 1, ilen0(igrd)
+ ENDIF
+ !
+ IF ( ASSOCIATED(dta_bdy(ib_bdy)%v2d) ) THEN ! V grid
+ DO ib = 1, SIZE(dta_bdy(ib_bdy)%v2d)
dta_bdy(ib_bdy)%v2d(ib) = dta_bdy(ib_bdy)%v2d(ib) + &
& ( tides(ib_bdy)%v(ib,itide,1)*z_cost + &
@@ -372,6 +366,7 @@
END DO
ENDIF
+ !
END DO
- END IF
+ ENDIF
END DO
!
@@ -386,31 +381,31 @@
TYPE(TIDES_DATA), INTENT(inout) :: td ! tidal harmonics data
!
- INTEGER :: itide, igrd, ib ! dummy loop indices
- INTEGER, DIMENSION(1) :: ilen0 ! length of boundary data (from OBC arrays)
+ INTEGER :: itide, isz, ib ! dummy loop indices
REAL(wp),ALLOCATABLE, DIMENSION(:) :: mod_tide, phi_tide
!!----------------------------------------------------------------------
!
- igrd=1
- ! SSH on tracer grid.
- ilen0(1) = SIZE(td%ssh0(:,1,1))
- !
- ALLOCATE( mod_tide(ilen0(igrd)), phi_tide(ilen0(igrd)) )
- !
- DO itide = 1, nb_harmo
- DO ib = 1, ilen0(igrd)
- mod_tide(ib)=SQRT(td%ssh0(ib,itide,1)**2.+td%ssh0(ib,itide,2)**2.)
- phi_tide(ib)=ATAN2(-td%ssh0(ib,itide,2),td%ssh0(ib,itide,1))
+ IF( ASSOCIATED(td%ssh0) ) THEN ! SSH on tracer grid.
+ !
+ isz = SIZE( td%ssh0, dim = 1 )
+ ALLOCATE( mod_tide(isz), phi_tide(isz) )
+ !
+ DO itide = 1, nb_harmo
+ DO ib = 1, isz
+ mod_tide(ib)=SQRT( td%ssh0(ib,itide,1)*td%ssh0(ib,itide,1) + td%ssh0(ib,itide,2)*td%ssh0(ib,itide,2) )
+ phi_tide(ib)=ATAN2(-td%ssh0(ib,itide,2),td%ssh0(ib,itide,1))
+ END DO
+ DO ib = 1, isz
+ mod_tide(ib)=mod_tide(ib)*tide_harmonics(itide)%f
+ phi_tide(ib)=phi_tide(ib)+tide_harmonics(itide)%v0+tide_harmonics(itide)%u
+ END DO
+ DO ib = 1, isz
+ td%ssh(ib,itide,1)= mod_tide(ib)*COS(phi_tide(ib))
+ td%ssh(ib,itide,2)=-mod_tide(ib)*SIN(phi_tide(ib))
+ END DO
END DO
- DO ib = 1 , ilen0(igrd)
- mod_tide(ib)=mod_tide(ib)*tide_harmonics(itide)%f
- phi_tide(ib)=phi_tide(ib)+tide_harmonics(itide)%v0+tide_harmonics(itide)%u
- ENDDO
- DO ib = 1 , ilen0(igrd)
- td%ssh(ib,itide,1)= mod_tide(ib)*COS(phi_tide(ib))
- td%ssh(ib,itide,2)=-mod_tide(ib)*SIN(phi_tide(ib))
- ENDDO
- END DO
- !
- DEALLOCATE( mod_tide, phi_tide )
+ !
+ DEALLOCATE( mod_tide, phi_tide )
+ !
+ ENDIF
!
END SUBROUTINE tide_init_elevation
@@ -424,55 +419,57 @@
TYPE(TIDES_DATA), INTENT(inout) :: td ! tidal harmonics data
!
- INTEGER :: itide, igrd, ib ! dummy loop indices
- INTEGER, DIMENSION(3) :: ilen0 ! length of boundary data (from OBC arrays)
+ INTEGER :: itide, isz, ib ! dummy loop indices
REAL(wp),ALLOCATABLE, DIMENSION(:) :: mod_tide, phi_tide
!!----------------------------------------------------------------------
!
- ilen0(2) = SIZE(td%u0(:,1,1))
- ilen0(3) = SIZE(td%v0(:,1,1))
- !
- igrd=2 ! U grid.
- !
- ALLOCATE( mod_tide(ilen0(igrd)) , phi_tide(ilen0(igrd)) )
- !
- DO itide = 1, nb_harmo
- DO ib = 1, ilen0(igrd)
- mod_tide(ib)=SQRT(td%u0(ib,itide,1)**2.+td%u0(ib,itide,2)**2.)
- phi_tide(ib)=ATAN2(-td%u0(ib,itide,2),td%u0(ib,itide,1))
+ IF( ASSOCIATED(td%u0) ) THEN ! U grid. we use bdy u2d on this mpi subdomain
+ !
+ isz = SIZE( td%u0, dim = 1 )
+ ALLOCATE( mod_tide(isz), phi_tide(isz) )
+ !
+ DO itide = 1, nb_harmo
+ DO ib = 1, isz
+ mod_tide(ib)=SQRT( td%u0(ib,itide,1)*td%u0(ib,itide,1) + td%u0(ib,itide,2)*td%u0(ib,itide,2) )
+ phi_tide(ib)=ATAN2(-td%u0(ib,itide,2),td%u0(ib,itide,1))
+ END DO
+ DO ib = 1, isz
+ mod_tide(ib)=mod_tide(ib)*tide_harmonics(itide)%f
+ phi_tide(ib)=phi_tide(ib)+tide_harmonics(itide)%v0 + tide_harmonics(itide)%u
+ END DO
+ DO ib = 1, isz
+ td%u(ib,itide,1)= mod_tide(ib)*COS(phi_tide(ib))
+ td%u(ib,itide,2)=-mod_tide(ib)*SIN(phi_tide(ib))
+ END DO
END DO
- DO ib = 1, ilen0(igrd)
- mod_tide(ib)=mod_tide(ib)*tide_harmonics(itide)%f
- phi_tide(ib)=phi_tide(ib)+tide_harmonics(itide)%v0 + tide_harmonics(itide)%u
- ENDDO
- DO ib = 1, ilen0(igrd)
- td%u(ib,itide,1)= mod_tide(ib)*COS(phi_tide(ib))
- td%u(ib,itide,2)=-mod_tide(ib)*SIN(phi_tide(ib))
- ENDDO
- END DO
- !
- DEALLOCATE( mod_tide , phi_tide )
- !
- igrd=3 ! V grid.
- !
- ALLOCATE( mod_tide(ilen0(igrd)) , phi_tide(ilen0(igrd)) )
-
- DO itide = 1, nb_harmo
- DO ib = 1, ilen0(igrd)
- mod_tide(ib)=SQRT(td%v0(ib,itide,1)**2.+td%v0(ib,itide,2)**2.)
- phi_tide(ib)=ATAN2(-td%v0(ib,itide,2),td%v0(ib,itide,1))
+ !
+ DEALLOCATE( mod_tide, phi_tide )
+ !
+ ENDIF
+ !
+ IF( ASSOCIATED(td%v0) ) THEN ! V grid. we use bdy u2d on this mpi subdomain
+ !
+ isz = SIZE( td%v0, dim = 1 )
+ ALLOCATE( mod_tide(isz), phi_tide(isz) )
+ !
+ DO itide = 1, nb_harmo
+ DO ib = 1, isz
+ mod_tide(ib)=SQRT( td%v0(ib,itide,1)*td%v0(ib,itide,1) + td%v0(ib,itide,2)*td%v0(ib,itide,2) )
+ phi_tide(ib)=ATAN2(-td%v0(ib,itide,2),td%v0(ib,itide,1))
+ END DO
+ DO ib = 1, isz
+ mod_tide(ib)=mod_tide(ib)*tide_harmonics(itide)%f
+ phi_tide(ib)=phi_tide(ib)+tide_harmonics(itide)%v0 + tide_harmonics(itide)%u
+ END DO
+ DO ib = 1, isz
+ td%v(ib,itide,1)= mod_tide(ib)*COS(phi_tide(ib))
+ td%v(ib,itide,2)=-mod_tide(ib)*SIN(phi_tide(ib))
+ END DO
END DO
- DO ib = 1, ilen0(igrd)
- mod_tide(ib)=mod_tide(ib)*tide_harmonics(itide)%f
- phi_tide(ib)=phi_tide(ib)+tide_harmonics(itide)%v0 + tide_harmonics(itide)%u
- ENDDO
- DO ib = 1, ilen0(igrd)
- td%v(ib,itide,1)= mod_tide(ib)*COS(phi_tide(ib))
- td%v(ib,itide,2)=-mod_tide(ib)*SIN(phi_tide(ib))
- ENDDO
- END DO
- !
- DEALLOCATE( mod_tide, phi_tide )
- !
- END SUBROUTINE tide_init_velocities
+ !
+ DEALLOCATE( mod_tide, phi_tide )
+ !
+ ENDIF
+ !
+ END SUBROUTINE tide_init_velocities
!!======================================================================
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/BDY/bdytra.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/BDY/bdytra.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/BDY/bdytra.F90 (revision 13540)
@@ -61,5 +61,5 @@
IF( ir == 0 ) THEN ; llrim0 = .TRUE.
ELSE ; llrim0 = .FALSE.
- END IF
+ ENDIF
DO ib_bdy=1, nb_bdy
!
@@ -69,16 +69,16 @@
DO jn = 1, jpts
!
- SELECT CASE( TRIM(cn_tra(ib_bdy)) )
+ SELECT CASE( cn_tra(ib_bdy) )
CASE('none' ) ; CYCLE
CASE('frs' ) ! treat the whole boundary at once
- IF( ir == 0 ) CALL bdy_frs ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kaa), zdta(jn)%tra )
+ IF( ir == 0 ) CALL bdy_frs ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kaa), zdta(jn)%tra )
CASE('specified' ) ! treat the whole rim at once
- IF( ir == 0 ) CALL bdy_spe ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kaa), zdta(jn)%tra )
- CASE('neumann' ) ; CALL bdy_nmn ( idx_bdy(ib_bdy), igrd , pts(:,:,:,jn,Kaa), llrim0 ) ! tsa masked
- CASE('orlanski' ) ; CALL bdy_orl ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kbb), pts(:,:,:,jn,Kaa), &
- & zdta(jn)%tra, llrim0, ll_npo=.false. )
- CASE('orlanski_npo') ; CALL bdy_orl ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kbb), pts(:,:,:,jn,Kaa), &
- & zdta(jn)%tra, llrim0, ll_npo=.true. )
- CASE('runoff' ) ; CALL bdy_rnf ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kaa), jn, llrim0 )
+ IF( ir == 0 ) CALL bdy_spe ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kaa), zdta(jn)%tra )
+ CASE('neumann' ) ; CALL bdy_nmn ( idx_bdy(ib_bdy), igrd , pts(:,:,:,jn,Kaa), llrim0 ) ! tsa masked
+ CASE('orlanski' ) ; CALL bdy_orl ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kbb), pts(:,:,:,jn,Kaa), zdta(jn)%tra, &
+ & llrim0, ll_npo=.FALSE. )
+ CASE('orlanski_npo') ; CALL bdy_orl ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kbb), pts(:,:,:,jn,Kaa), zdta(jn)%tra, &
+ & llrim0, ll_npo=.TRUE. )
+ CASE('runoff' ) ; CALL bdy_rnf ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kaa), jn, llrim0 )
CASE DEFAULT ; CALL ctl_stop( 'bdy_tra : unrecognised option for open boundaries for T and S' )
END SELECT
@@ -88,7 +88,7 @@
!
IF( nn_hls > 1 .AND. ir == 1 ) CYCLE ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0
- IF( nn_hls == 1 ) THEN ; llsend1(:) = .false. ; llrecv1(:) = .false. ; END IF
+ IF( nn_hls == 1 ) THEN ; llsend1(:) = .false. ; llrecv1(:) = .false. ; ENDIF
DO ib_bdy=1, nb_bdy
- SELECT CASE( TRIM(cn_tra(ib_bdy)) )
+ SELECT CASE( cn_tra(ib_bdy) )
CASE('neumann','runoff')
llsend1(:) = llsend1(:) .OR. lsend_bdyint(ib_bdy,1,:,ir) ! possibly every direction, T points
@@ -100,6 +100,6 @@
END DO
IF( ANY(llsend1) .OR. ANY(llrecv1) ) THEN ! if need to send/recv in at least one direction
- CALL lbc_lnk( 'bdytra', pts(:,:,:,jn,Kaa), 'T', 1., kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 )
- END IF
+ CALL lbc_lnk( 'bdytra', pts(:,:,:,jn,Kaa), 'T', 1.0_wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 )
+ ENDIF
!
END DO ! ir
@@ -135,5 +135,5 @@
pt(ii,ij,1:jpkm1) = 0.1 * tmask(ii,ij,1:jpkm1)
END DO
- END IF
+ ENDIF
!
END SUBROUTINE bdy_rnf
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/C1D/dtauvd.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/C1D/dtauvd.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/C1D/dtauvd.F90 (revision 13540)
@@ -158,5 +158,5 @@
ENDIF
!
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 ) ! vertical interpolation of U & V current:
DO jk = 1, jpk
zl = gdept(ji,jj,jk,Kmm)
@@ -193,5 +193,5 @@
!
IF( ln_zps ) THEN ! zps-coordinate (partial steps) interpolation at the last ocean level
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
ik = mbkt(ji,jj)
IF( ik > 1 ) THEN
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/C1D/dyncor_c1d.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/C1D/dyncor_c1d.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/C1D/dyncor_c1d.F90 (revision 13540)
@@ -77,10 +77,10 @@
!
IF( ln_stcor ) THEN
- DO_3D_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + ff_t(ji,jj) * (pvv(ji,jj,jk,Kmm) + vsd(ji,jj,jk))
pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ff_t(ji,jj) * (puu(ji,jj,jk,Kmm) + usd(ji,jj,jk))
END_3D
ELSE
- DO_3D_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + ff_t(ji,jj) * pvv(ji,jj,jk,Kmm)
pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ff_t(ji,jj) * puu(ji,jj,jk,Kmm)
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/C1D/dyndmp.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/C1D/dyndmp.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/C1D/dyndmp.F90 (revision 13540)
@@ -121,5 +121,5 @@
!Read in mask from file
CALL iom_open ( cn_resto, imask)
- CALL iom_get ( imask, jpdom_autoglo, 'resto', resto)
+ CALL iom_get ( imask, jpdom_auto, 'resto', resto)
CALL iom_close( imask )
ENDIF
@@ -165,5 +165,5 @@
!
CASE( 0 ) ! Newtonian damping throughout the water column
- DO_3D_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
zua = resto_uv(ji,jj,jk) * ( zuv_dta(ji,jj,jk,1) - puu(ji,jj,jk,Kbb) )
zva = resto_uv(ji,jj,jk) * ( zuv_dta(ji,jj,jk,2) - pvv(ji,jj,jk,Kbb) )
@@ -175,5 +175,5 @@
!
CASE ( 1 ) ! no damping above the turbocline (avt > 5 cm2/s)
- DO_3D_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
IF( avt(ji,jj,jk) <= avt_c ) THEN
zua = resto_uv(ji,jj,jk) * ( zuv_dta(ji,jj,jk,1) - puu(ji,jj,jk,Kbb) )
@@ -190,5 +190,5 @@
!
CASE ( 2 ) ! no damping in the mixed layer
- DO_3D_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
IF( gdept(ji,jj,jk,Kmm) >= hmlp (ji,jj) ) THEN
zua = resto_uv(ji,jj,jk) * ( zuv_dta(ji,jj,jk,1) - puu(ji,jj,jk,Kbb) )
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/C1D/step_c1d.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/C1D/step_c1d.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/C1D/step_c1d.F90 (revision 13540)
@@ -27,5 +27,5 @@
PRIVATE
- PUBLIC stp_c1d ! called by opa.F90
+ PUBLIC stp_c1d ! called by nemogcm.F90
!!----------------------------------------------------------------------
@@ -56,8 +56,5 @@
!
INTEGER :: jk ! dummy loop indice
- INTEGER :: indic ! error indicator if < 0
!! ---------------------------------------------------------------------
-
- indic = 0 ! reset to no error condition
IF( kstp == nit000 ) CALL iom_init( "nemo") ! iom_put initialization (must be done after nemo_init for AGRIF+XIOS+OASIS)
IF( kstp /= nit000 ) CALL day( kstp ) ! Calendar (day was already called at nit000 in day_init)
@@ -83,10 +80,10 @@
IF(.NOT.ln_linssh ) CALL dom_vvl_sf_nxt( kstp, Nbb, Nnn, Naa ) ! after vertical scale factors
- IF(.NOT.ln_linssh ) CALL wzv ( kstp, Nbb, Nnn, ww, Naa ) ! now cross-level velocity
+ IF(.NOT.ln_linssh ) CALL wzv ( kstp, Nbb, Nnn, Naa, ww ) ! now cross-level velocity
!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
! diagnostics and outputs
!<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
CALL dia_wri( kstp, Nnn ) ! ocean model: outputs
- IF( lk_diahth ) CALL dia_hth( kstp, Nnn ) ! Thermocline depth (20°C)
+ CALL dia_hth( kstp, Nnn ) ! Thermocline depth (20°C)
@@ -111,7 +108,5 @@
CALL eos( ts(:,:,:,:,Nnn), rhd, rhop, gdept_0(:,:,:) ) ! now potential density for zdfmxl
IF( ln_zdfnpc ) CALL tra_npc( kstp, Nnn, Nrhs, ts, Naa ) ! applied non penetrative convective adjustment on (t,s)
- CALL tra_atf( kstp, Nbb, Nnn, Nrhs, Naa, ts ) ! time filtering of "now" tracer fields
-
-
+ CALL tra_atf( kstp, Nbb, Nnn, Naa, ts ) ! time filtering of "now" tracer arrays
!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
@@ -139,10 +134,10 @@
! Control and restarts
!<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
- CALL stp_ctl( kstp, Nnn, indic )
+ CALL stp_ctl( kstp, Nnn )
IF( kstp == nit000 ) CALL iom_close( numror ) ! close input ocean restart file
IF( lrst_oce ) CALL rst_write( kstp, Nbb, Nnn ) ! write output ocean restart file
!
#if defined key_iomput
- IF( kstp == nitend .OR. indic < 0 ) CALL xios_context_finalize() ! needed for XIOS
+ IF( kstp == nitend .OR. nstop > 0 ) CALL xios_context_finalize() ! needed for XIOS
!
#endif
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/CRS/crs.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/CRS/crs.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/CRS/crs.F90 (revision 13540)
@@ -36,10 +36,8 @@
INTEGER :: jpiglo_full, jpjglo_full !: jpiglo / jpjglo
INTEGER :: npiglo, npjglo !: jpjglo
- INTEGER :: nlci_full, nlcj_full !: i-, j-dimension of local or sub domain on parent grid
- INTEGER :: nldi_full, nldj_full !: starting indices of internal sub-domain on parent grid
- INTEGER :: nlei_full, nlej_full !: ending indices of internal sub-domain on parent grid
- INTEGER :: nlci_crs, nlcj_crs !: i-, j-dimension of local or sub domain on coarse grid
- INTEGER :: nldi_crs, nldj_crs !: starting indices of internal sub-domain on coarse grid
- INTEGER :: nlei_crs, nlej_crs !: ending indices of internal sub-domain on coarse grid
+ INTEGER :: Nis0_full, Njs0_full !: starting indices of internal sub-domain on parent grid
+ INTEGER :: Nie0_full, Nje0_full !: ending indices of internal sub-domain on parent grid
+ INTEGER :: Nis0_crs , Njs0_crs !: starting indices of internal sub-domain on coarse grid
+ INTEGER :: Nie0_crs , Nje0_crs !: ending indices of internal sub-domain on coarse grid
INTEGER :: narea_full, narea_crs !: node
@@ -48,6 +46,4 @@
INTEGER :: nimpp_full, njmpp_full !: global position of point (1,1) of subdomain on parent grid
INTEGER :: nimpp_crs, njmpp_crs !: set to 1,1 for now . Valid only for monoproc
- INTEGER :: nreci_full, nrecj_full
- INTEGER :: nreci_crs, nrecj_crs
!cc
INTEGER :: noea_full, nowe_full !: index of the local neighboring processors in
@@ -76,20 +72,18 @@
INTEGER, DIMENSION(:), ALLOCATABLE :: mi0_crs, mi1_crs, mj0_crs, mj1_crs
INTEGER :: mxbinctr, mybinctr ! central point in grid box
- INTEGER, DIMENSION(:), ALLOCATABLE :: nlcit_crs, nlcit_full !: dimensions of every subdomain
- INTEGER, DIMENSION(:), ALLOCATABLE :: nldit_crs, nldit_full !: first, last indoor index for each i-domain
- INTEGER, DIMENSION(:), ALLOCATABLE :: nleit_crs, nleit_full !: first, last indoor index for each j-domain
- INTEGER, DIMENSION(:), ALLOCATABLE :: nimppt_crs, nimppt_full !: first, last indoor index for each j-domain
- INTEGER, DIMENSION(:), ALLOCATABLE :: nlcjt_crs, nlcjt_full !: dimensions of every subdomain
- INTEGER, DIMENSION(:), ALLOCATABLE :: nldjt_crs, nldjt_full !: first, last indoor index for each i-domain
- INTEGER, DIMENSION(:), ALLOCATABLE :: nlejt_crs, nlejt_full !: first, last indoor index for each j-domain
- INTEGER, DIMENSION(:), ALLOCATABLE :: njmppt_crs, njmppt_full !: first, last indoor index for each j-domain
+ INTEGER, DIMENSION(:), ALLOCATABLE :: jpiall_crs, jpiall_full !: dimensions of every subdomain
+ INTEGER, DIMENSION(:), ALLOCATABLE :: nis0all_crs, nis0all_full !: first, last indoor index for each i-domain
+ INTEGER, DIMENSION(:), ALLOCATABLE :: nie0all_crs, nie0all_full !: first, last indoor index for each j-domain
+ INTEGER, DIMENSION(:), ALLOCATABLE :: nimppt_crs, nimppt_full !: first, last indoor index for each j-domain
+ INTEGER, DIMENSION(:), ALLOCATABLE :: jpjall_crs, jpjall_full !: dimensions of every subdomain
+ INTEGER, DIMENSION(:), ALLOCATABLE :: njs0all_crs, njs0all_full !: first, last indoor index for each i-domain
+ INTEGER, DIMENSION(:), ALLOCATABLE :: nje0all_crs, nje0all_full !: first, last indoor index for each j-domain
+ INTEGER, DIMENSION(:), ALLOCATABLE :: njmppt_crs, njmppt_full !: first, last indoor index for each j-domain
! Masks
REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: tmask_crs, umask_crs, vmask_crs, fmask_crs
- REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: tmask_i_crs, rnfmsk_crs, tpol_crs, fpol_crs
-
- ! REAL(wp), DIMENSION(:,:), ALLOCATABLE :: tmask_i_crs, tpol, fpol
-
+ REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: rnfmsk_crs
+
! Scale factors
REAL(wp), DIMENSION(:,:), ALLOCATABLE :: e1t_crs, e2t_crs, e1e2t_crs ! horizontal scale factors grid type T
@@ -182,6 +176,5 @@
& umask_crs(jpi_crs,jpj_crs,jpk) , vmask_crs(jpi_crs,jpj_crs,jpk) , STAT=ierr(2))
- ALLOCATE( tmask_i_crs(jpi_crs,jpj_crs) , rnfmsk_crs(jpi_crs,jpj_crs), &
- & tpol_crs(jpiglo_crs,jpjglo_crs), fpol_crs(jpiglo_crs,jpjglo_crs), STAT=ierr(3) )
+ ALLOCATE( rnfmsk_crs(jpi_crs,jpj_crs), STAT=ierr(3) )
ALLOCATE( gphit_crs(jpi_crs,jpj_crs) , glamt_crs(jpi_crs,jpj_crs) , &
@@ -238,8 +231,8 @@
& hmlp_crs(jpi_crs,jpj_crs) , hmlpt_crs(jpi_crs,jpj_crs) , STAT=ierr(14) )
- ALLOCATE( nimppt_crs (jpnij) , nlcit_crs (jpnij) , nldit_crs (jpnij) , nleit_crs (jpnij), &
- & nimppt_full(jpnij) , nlcit_full(jpnij) , nldit_full(jpnij) , nleit_full(jpnij), &
- njmppt_crs (jpnij) , nlcjt_crs (jpnij) , nldjt_crs (jpnij) , nlejt_crs (jpnij), &
- & njmppt_full(jpnij) , nlcjt_full(jpnij) , nldjt_full(jpnij) , nlejt_full(jpnij) , STAT=ierr(15) )
+ 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), &
+ njmppt_crs (jpnij) , jpjall_crs (jpnij) , njs0all_crs (jpnij) , nje0all_crs (jpnij), &
+ & njmppt_full(jpnij) , jpjall_full(jpnij) , njs0all_full(jpnij) , nje0all_full(jpnij) , STAT=ierr(15) )
crs_dom_alloc = MAXVAL(ierr)
@@ -258,5 +251,5 @@
ierr(:) = 0
- ALLOCATE( mjs_crs(nlej_crs) , mje_crs(nlej_crs), mis_crs(nlei_crs) , mie_crs(nlei_crs), STAT=ierr(1) )
+ ALLOCATE( mjs_crs(Nje0_crs) , mje_crs(Nje0_crs), mis_crs(Nie0_crs) , mie_crs(Nie0_crs), STAT=ierr(1) )
crs_dom_alloc2 = MAXVAL(ierr)
@@ -282,21 +275,21 @@
jpjglo = jpjglo_full
- nlci = nlci_full
- nlcj = nlcj_full
- nldi = nldi_full
- nldj = nldj_full
- nlei = nlei_full
- nlej = nlej_full
- nimpp = nimpp_full
- njmpp = njmpp_full
-
- nlcit(:) = nlcit_full(:)
- nldit(:) = nldit_full(:)
- nleit(:) = nleit_full(:)
- nimppt(:) = nimppt_full(:)
- nlcjt(:) = nlcjt_full(:)
- nldjt(:) = nldjt_full(:)
- nlejt(:) = nlejt_full(:)
- njmppt(:) = njmppt_full(:)
+ jpi = jpi_full
+ jpj = jpj_full
+ Nis0 = Nis0_full
+ Njs0 = Njs0_full
+ Nie0 = Nie0_full
+ Nje0 = Nje0_full
+ nimpp = nimpp_full
+ njmpp = njmpp_full
+
+ jpiall (:) = jpiall_full (:)
+ nis0all(:) = nis0all_full(:)
+ nie0all(:) = nie0all_full(:)
+ nimppt (:) = nimppt_full (:)
+ jpjall (:) = jpjall_full (:)
+ njs0all(:) = njs0all_full(:)
+ nje0all(:) = nje0all_full(:)
+ njmppt (:) = njmppt_full (:)
END SUBROUTINE dom_grid_glo
@@ -322,21 +315,21 @@
- nlci = nlci_crs
- nlcj = nlcj_crs
- nldi = nldi_crs
- nlei = nlei_crs
- nlej = nlej_crs
- nldj = nldj_crs
- nimpp = nimpp_crs
- njmpp = njmpp_crs
-
- nlcit(:) = nlcit_crs(:)
- nldit(:) = nldit_crs(:)
- nleit(:) = nleit_crs(:)
- nimppt(:) = nimppt_crs(:)
- nlcjt(:) = nlcjt_crs(:)
- nldjt(:) = nldjt_crs(:)
- nlejt(:) = nlejt_crs(:)
- njmppt(:) = njmppt_crs(:)
+ jpi = jpi_crs
+ jpj = jpj_crs
+ Nis0 = Nis0_crs
+ Nie0 = Nie0_crs
+ Nje0 = Nje0_crs
+ Njs0 = Njs0_crs
+ nimpp = nimpp_crs
+ njmpp = njmpp_crs
+
+ jpiall (:) = jpiall_crs (:)
+ nis0all(:) = nis0all_crs(:)
+ nie0all(:) = nie0all_crs(:)
+ nimppt (:) = nimppt_crs (:)
+ jpjall (:) = jpjall_crs (:)
+ njs0all(:) = njs0all_crs(:)
+ nje0all(:) = nje0all_crs(:)
+ njmppt (:) = njmppt_crs (:)
!
END SUBROUTINE dom_grid_crs
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/CRS/crsdom.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/CRS/crsdom.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/CRS/crsdom.F90 (revision 13540)
@@ -73,5 +73,5 @@
- IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
+ IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
je_2 = mje_crs(2) ; ij = je_2
@@ -81,18 +81,18 @@
ENDIF
DO jk = 1, jpkm1
- DO ji = 2, nlei_crs
+ DO ji = 2, Nie0_crs
ijis = mis_crs(ji) ; ijie = mie_crs(ji)
!
zmask = 0.0
zmask = SUM( tmask(ijis:ijie,ij:je_2,jk) )
- IF ( zmask > 0.0 ) tmask_crs(ji,2,jk) = 1.0
+ IF ( zmask > 0.0 ) tmask_crs(ji,2,jk) = 1.0_wp
zmask = 0.0
zmask = SUM( vmask(ijis:ijie,je_2 ,jk) )
- IF ( zmask > 0.0 ) vmask_crs(ji,2,jk) = 1.0
+ IF ( zmask > 0.0 ) vmask_crs(ji,2,jk) = 1.0_wp
zmask = 0.0
zmask = SUM(umask(ijie,ij:je_2,jk))
- IF ( zmask > 0.0 ) umask_crs(ji,2,jk) = 1.0
+ IF ( zmask > 0.0 ) umask_crs(ji,2,jk) = 1.0_wp
fmask_crs(ji,je_2,jk) = fmask(ijie,2,jk)
@@ -101,20 +101,20 @@
!
DO jk = 1, jpkm1
- DO ji = 2, nlei_crs
+ DO ji = 2, Nie0_crs
ijis = mis_crs(ji) ; ijie = mie_crs(ji)
- DO jj = 3, nlej_crs
+ DO jj = 3, Nje0_crs
ijjs = mjs_crs(jj) ; ijje = mje_crs(jj)
zmask = 0.0
zmask = SUM( tmask(ijis:ijie,ijjs:ijje,jk) )
- IF ( zmask > 0.0 ) tmask_crs(ji,jj,jk) = 1.0
+ IF ( zmask > 0.0 ) tmask_crs(ji,jj,jk) = 1.0_wp
zmask = 0.0
zmask = SUM( vmask(ijis:ijie,ijje ,jk) )
- IF ( zmask > 0.0 ) vmask_crs(ji,jj,jk) = 1.0
+ IF ( zmask > 0.0 ) vmask_crs(ji,jj,jk) = 1.0_wp
zmask = 0.0
zmask = SUM( umask(ijie ,ijjs:ijje,jk) )
- IF ( zmask > 0.0 ) umask_crs(ji,jj,jk) = 1.0
+ IF ( zmask > 0.0 ) umask_crs(ji,jj,jk) = 1.0_wp
fmask_crs(ji,jj,jk) = fmask(ijie,ijje,jk)
@@ -124,8 +124,8 @@
!
- CALL crs_lbc_lnk( tmask_crs, 'T', 1.0 )
- CALL crs_lbc_lnk( vmask_crs, 'V', 1.0 )
- CALL crs_lbc_lnk( umask_crs, 'U', 1.0 )
- CALL crs_lbc_lnk( fmask_crs, 'F', 1.0 )
+ CALL crs_lbc_lnk( tmask_crs, 'T', 1.0_wp )
+ CALL crs_lbc_lnk( vmask_crs, 'V', 1.0_wp )
+ CALL crs_lbc_lnk( umask_crs, 'U', 1.0_wp )
+ CALL crs_lbc_lnk( fmask_crs, 'F', 1.0_wp )
!
END SUBROUTINE crs_dom_msk
@@ -168,7 +168,7 @@
SELECT CASE ( cd_type )
CASE ( 'T' )
- DO jj = nldj_crs, nlej_crs
+ DO jj = Njs0_crs, Nje0_crs
ijjs = mjs_crs(jj) + mybinctr
- DO ji = 2, nlei_crs
+ DO ji = 2, Nie0_crs
ijis = mis_crs(ji) + mxbinctr
p_gphi_crs(ji,jj) = p_gphi(ijis,ijjs)
@@ -177,7 +177,7 @@
ENDDO
CASE ( 'U' )
- DO jj = nldj_crs, nlej_crs
+ DO jj = Njs0_crs, Nje0_crs
ijjs = mjs_crs(jj) + mybinctr
- DO ji = 2, nlei_crs
+ DO ji = 2, Nie0_crs
ijis = mis_crs(ji)
p_gphi_crs(ji,jj) = p_gphi(ijis,ijjs)
@@ -186,7 +186,7 @@
ENDDO
CASE ( 'V' )
- DO jj = nldj_crs, nlej_crs
+ DO jj = Njs0_crs, Nje0_crs
ijjs = mjs_crs(jj)
- DO ji = 2, nlei_crs
+ DO ji = 2, Nie0_crs
ijis = mis_crs(ji) + mxbinctr
p_gphi_crs(ji,jj) = p_gphi(ijis,ijjs)
@@ -195,7 +195,7 @@
ENDDO
CASE ( 'F' )
- DO jj = nldj_crs, nlej_crs
+ DO jj = Njs0_crs, Nje0_crs
ijjs = mjs_crs(jj)
- DO ji = 2, nlei_crs
+ DO ji = 2, Nie0_crs
ijis = mis_crs(ji)
p_gphi_crs(ji,jj) = p_gphi(ijis,ijjs)
@@ -206,11 +206,11 @@
! Retroactively add back the boundary halo cells.
- CALL crs_lbc_lnk( p_gphi_crs, cd_type, 1.0 )
- CALL crs_lbc_lnk( p_glam_crs, cd_type, 1.0 )
+ CALL crs_lbc_lnk( p_gphi_crs, cd_type, 1.0_wp )
+ CALL crs_lbc_lnk( p_glam_crs, cd_type, 1.0_wp )
! Fill up jrow=1 which is zeroed out or not handled by lbc_lnk and lbc_nfd
SELECT CASE ( cd_type )
CASE ( 'T', 'V' )
- DO ji = 2, nlei_crs
+ DO ji = 2, Nie0_crs
ijis = mis_crs(ji) + mxbinctr
p_gphi_crs(ji,1) = p_gphi(ijis,1)
@@ -218,5 +218,5 @@
ENDDO
CASE ( 'U', 'F' )
- DO ji = 2, nlei_crs
+ DO ji = 2, Nie0_crs
ijis = mis_crs(ji)
p_gphi_crs(ji,1) = p_gphi(ijis,1)
@@ -261,7 +261,7 @@
DO jk = 1, jpk
- DO ji = 2, nlei_crs
+ DO ji = 2, Nie0_crs
ijie = mie_crs(ji)
- DO jj = nldj_crs, nlej_crs
+ DO jj = Njs0_crs, Nje0_crs
ijje = mje_crs(jj) ; ijrs = mje_crs(jj) - mjs_crs(jj)
! Only for a factro 3 coarsening
@@ -296,6 +296,6 @@
ENDDO
- CALL crs_lbc_lnk( p_e1_crs, cd_type, 1.0, pfillval=1.0 )
- CALL crs_lbc_lnk( p_e2_crs, cd_type, 1.0, pfillval=1.0 )
+ CALL crs_lbc_lnk( p_e1_crs, cd_type, 1.0_wp, pfillval=1.0_wp )
+ CALL crs_lbc_lnk( p_e2_crs, cd_type, 1.0_wp, pfillval=1.0_wp )
END SUBROUTINE crs_dom_hgr
@@ -374,5 +374,5 @@
ENDIF
- IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
+ IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
je_2 = mje_crs(2)
@@ -440,6 +440,6 @@
ENDDO
! ! Retroactively add back the boundary halo cells.
- CALL crs_lbc_lnk( p_fld1_crs, cd_type, 1.0 )
- CALL crs_lbc_lnk( p_fld2_crs, cd_type, 1.0 )
+ CALL crs_lbc_lnk( p_fld1_crs, cd_type, 1.0_wp )
+ CALL crs_lbc_lnk( p_fld2_crs, cd_type, 1.0_wp )
!
!
@@ -512,5 +512,5 @@
ENDIF
- IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
+ IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
je_2 = mje_crs(2)
@@ -617,5 +617,5 @@
CASE( 'T', 'W' )
- IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
+ IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
je_2 = mje_crs(2)
@@ -674,5 +674,5 @@
CASE( 'V' )
- IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
+ IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
ijje = mje_crs(2)
@@ -711,5 +711,5 @@
CASE( 'U' )
- IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
+ IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
je_2 = mje_crs(2)
@@ -782,5 +782,5 @@
CASE( 'T', 'W' )
- IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
+ IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
je_2 = mje_crs(2)
@@ -842,5 +842,5 @@
CASE( 'V' )
- IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
+ IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
ijje = mje_crs(2)
@@ -883,5 +883,5 @@
CASE( 'U' )
- IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
+ IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
je_2 = mje_crs(2)
@@ -953,5 +953,5 @@
CASE( 'T', 'W' )
- IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
+ IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
je_2 = mje_crs(2)
@@ -1013,5 +1013,5 @@
CASE( 'V' )
- IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
+ IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
ijje = mje_crs(2)
@@ -1053,5 +1053,5 @@
CASE( 'U' )
- IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
+ IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
je_2 = mje_crs(2)
@@ -1158,5 +1158,5 @@
zsurfmsk(:,:) = p_e12(:,:) * p_e3(:,:,1) * p_mask(:,:,1)
- IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
+ IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
je_2 = mje_crs(2)
@@ -1234,5 +1234,5 @@
CASE( 'T', 'W' )
- IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
+ IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
je_2 = mje_crs(2)
@@ -1285,5 +1285,5 @@
CASE( 'V' )
- IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
+ IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
ijje = mje_crs(2)
@@ -1318,5 +1318,5 @@
CASE( 'U' )
- IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
+ IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
je_2 = mje_crs(2)
@@ -1369,5 +1369,5 @@
CASE( 'T', 'W' )
- IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
+ IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
je_2 = mje_crs(2)
@@ -1420,5 +1420,5 @@
CASE( 'V' )
- IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
+ IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
ijje = mje_crs(2)
@@ -1453,5 +1453,5 @@
CASE( 'U' )
- IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
+ IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
je_2 = mje_crs(2)
@@ -1497,5 +1497,5 @@
CASE( 'T', 'W' )
- IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
+ IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
je_2 = mje_crs(2)
@@ -1548,5 +1548,5 @@
CASE( 'V' )
- IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
+ IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
ijje = mje_crs(2)
@@ -1581,5 +1581,5 @@
CASE( 'U' )
- IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
+ IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
je_2 = mje_crs(2)
@@ -1665,5 +1665,5 @@
ENDDO
- IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
+ IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
je_2 = mje_crs(2)
@@ -1748,6 +1748,6 @@
ENDDO
- CALL crs_lbc_lnk( p_e3_crs , cd_type, 1.0, pfillval=1.0 )
- CALL crs_lbc_lnk( p_e3_max_crs, cd_type, 1.0, pfillval=1.0 )
+ CALL crs_lbc_lnk( p_e3_crs , cd_type, 1.0_wp, pfillval=1.0_wp )
+ CALL crs_lbc_lnk( p_e3_max_crs, cd_type, 1.0_wp, pfillval=1.0_wp )
!
!
@@ -1808,5 +1808,5 @@
END SELECT
- IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
+ IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2
IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
je_2 = mje_crs(2)
@@ -1857,6 +1857,6 @@
ENDDO
- CALL crs_lbc_lnk( p_surf_crs , cd_type, 1.0, pfillval=1.0 )
- CALL crs_lbc_lnk( p_surf_crs_msk, cd_type, 1.0, pfillval=1.0 )
+ CALL crs_lbc_lnk( p_surf_crs , cd_type, 1.0_wp, pfillval=1.0_wp )
+ CALL crs_lbc_lnk( p_surf_crs_msk, cd_type, 1.0_wp, pfillval=1.0_wp )
END SUBROUTINE crs_dom_sfc
@@ -1899,57 +1899,53 @@
! 2.a Define processor domain
IF( .NOT. lk_mpp ) THEN
- nimpp_crs = 1
- njmpp_crs = 1
- nlci_crs = jpi_crs
- nlcj_crs = jpj_crs
- nldi_crs = 1
- nldj_crs = 1
- nlei_crs = jpi_crs
- nlej_crs = jpj_crs
+ nimpp_crs = 1
+ njmpp_crs = 1
+ Nis0_crs = 1
+ Njs0_crs = 1
+ Nie0_crs = jpi_crs
+ Nje0_crs = jpj_crs
ELSE
! Initialisation of most local variables -
- nimpp_crs = 1
- njmpp_crs = 1
- nlci_crs = jpi_crs
- nlcj_crs = jpj_crs
- nldi_crs = 1
- nldj_crs = 1
- nlei_crs = jpi_crs
- nlej_crs = jpj_crs
+ nimpp_crs = 1
+ njmpp_crs = 1
+ Nis0_crs = 1
+ Njs0_crs = 1
+ Nie0_crs = jpi_crs
+ Nje0_crs = jpj_crs
! Calculs suivant une découpage en j
DO jn = 1, jpnij, jpni
IF( jn < ( jpnij - jpni + 1 ) ) THEN
- nlejt_crs(jn) = AINT( REAL( ( jpjglo - (njmppt(jn ) - 1) ) / nn_facty, wp ) ) &
+ nje0all_crs(jn) = AINT( REAL( ( jpjglo - (njmppt(jn ) - 1) ) / nn_facty, wp ) ) &
& - AINT( REAL( ( jpjglo - (njmppt(jn+jpni) - 1) ) / nn_facty, wp ) )
ELSE
- nlejt_crs(jn) = AINT( REAL( nlejt(jn) / nn_facty, wp ) ) + 1
+ nje0all_crs(jn) = AINT( REAL( nje0all(jn) / nn_facty, wp ) ) + 1
ENDIF
- IF( noso < 0 ) nlejt_crs(jn) = nlejt_crs(jn) + 1
+ IF( noso < 0 ) nje0all_crs(jn) = nje0all_crs(jn) + 1
SELECT CASE( ibonjt(jn) )
CASE ( -1 )
- IF( MOD( jpjglo - njmppt(jn), nn_facty) > 0 ) nlejt_crs(jn) = nlejt_crs(jn) + 1
- nlcjt_crs(jn) = nlejt_crs(jn) + nn_hls
- nldjt_crs(jn) = nldjt(jn)
+ IF( MOD( jpjglo - njmppt(jn), nn_facty) > 0 ) nje0all_crs(jn) = nje0all_crs(jn) + 1
+ jpjall_crs (jn) = nje0all_crs(jn) + nn_hls
+ njs0all_crs(jn) = njs0all(jn)
CASE ( 0 )
- nldjt_crs(jn) = nldjt(jn)
- IF( nldjt(jn) == 1 ) nlejt_crs(jn) = nlejt_crs(jn) + 1
- nlejt_crs(jn) = nlejt_crs(jn) + nn_hls
- nlcjt_crs(jn) = nlejt_crs(jn) + nn_hls
+ njs0all_crs(jn) = njs0all(jn)
+ IF( njs0all(jn) == 1 ) nje0all_crs(jn) = nje0all_crs(jn) + 1
+ nje0all_crs(jn) = nje0all_crs(jn) + nn_hls
+ jpjall_crs (jn) = nje0all_crs(jn) + nn_hls
CASE ( 1, 2 )
- nlejt_crs(jn) = nlejt_crs(jn) + nn_hls
- nlcjt_crs(jn) = nlejt_crs(jn)
- nldjt_crs(jn) = nldjt(jn)
+ nje0all_crs(jn) = nje0all_crs(jn) + nn_hls
+ jpjall_crs (jn) = nje0all_crs(jn)
+ njs0all_crs(jn) = njs0all(jn)
CASE DEFAULT
CALL ctl_stop( 'STOP', 'error from crs_dom_def, you should not be there (1) ...' )
END SELECT
- IF( nlcjt_crs(jn) > jpj_crs ) jpj_crs = jpj_crs + 1
-
- IF(nldjt_crs(jn) == 1 ) THEN
+ IF( jpjall_crs(jn) > jpj_crs ) jpj_crs = jpj_crs + 1
+
+ IF(njs0all_crs(jn) == 1 ) THEN
njmppt_crs(jn) = 1
ELSE
@@ -1958,40 +1954,40 @@
DO jj = jn + 1, jn + jpni - 1
- nlejt_crs(jj) = nlejt_crs(jn)
- nlcjt_crs(jj) = nlcjt_crs(jn)
- nldjt_crs(jj) = nldjt_crs(jn)
- njmppt_crs(jj)= njmppt_crs(jn)
+ nje0all_crs(jj) = nje0all_crs(jn)
+ jpjall_crs (jj) = jpjall_crs(jn)
+ njs0all_crs(jj) = njs0all_crs(jn)
+ njmppt_crs (jj) = njmppt_crs(jn)
ENDDO
ENDDO
- nlej_crs = nlejt_crs(nproc + 1)
- nlcj_crs = nlcjt_crs(nproc + 1)
- nldj_crs = nldjt_crs(nproc + 1)
- njmpp_crs = njmppt_crs(nproc + 1)
+ Nje0_crs = nje0all_crs(nproc + 1)
+ jpj_crs = jpjall_crs (nproc + 1)
+ Njs0_crs = njs0all_crs(nproc + 1)
+ njmpp_crs = njmppt_crs (nproc + 1)
! Calcul suivant un decoupage en i
DO jn = 1, jpni
IF( jn == 1 ) THEN
- nleit_crs(jn) = AINT( REAL( ( nimppt(jn ) - 1 + nlcit(jn ) ) / nn_factx, wp) )
+ nie0all_crs(jn) = AINT( REAL( ( nimppt(jn ) - 1 + jpiall(jn ) ) / nn_factx, wp) )
ELSE
- nleit_crs(jn) = AINT( REAL( ( nimppt(jn ) - 1 + nlcit(jn ) ) / nn_factx, wp) ) &
- & - AINT( REAL( ( nimppt(jn-1) - 1 + nlcit(jn-1) ) / nn_factx, wp) )
+ nie0all_crs(jn) = AINT( REAL( ( nimppt(jn ) - 1 + jpiall(jn ) ) / nn_factx, wp) ) &
+ & - AINT( REAL( ( nimppt(jn-1) - 1 + jpiall(jn-1) ) / nn_factx, wp) )
ENDIF
SELECT CASE( ibonit(jn) )
CASE ( -1 )
- nleit_crs(jn) = nleit_crs(jn) + nn_hls
- nlcit_crs(jn) = nleit_crs(jn) + nn_hls
- nldit_crs(jn) = nldit(jn)
+ nie0all_crs(jn) = nie0all_crs(jn) + nn_hls
+ jpiall_crs (jn) = nie0all_crs(jn) + nn_hls
+ nis0all_crs(jn) = nis0all(jn)
CASE ( 0 )
- nleit_crs(jn) = nleit_crs(jn) + nn_hls
- nlcit_crs(jn) = nleit_crs(jn) + nn_hls
- nldit_crs(jn) = nldit(jn)
+ nie0all_crs(jn) = nie0all_crs(jn) + nn_hls
+ jpiall_crs (jn) = nie0all_crs(jn) + nn_hls
+ nis0all_crs(jn) = nis0all(jn)
CASE ( 1, 2 )
- IF( MOD( jpiglo - nimppt(jn), nn_factx) > 0 ) nleit_crs(jn) = nleit_crs(jn) + 1
- nleit_crs(jn) = nleit_crs(jn) + nn_hls
- nlcit_crs(jn) = nleit_crs(jn)
- nldit_crs(jn) = nldit(jn)
+ IF( MOD( jpiglo - nimppt(jn), nn_factx) > 0 ) nie0all_crs(jn) = nie0all_crs(jn) + 1
+ nie0all_crs(jn) = nie0all_crs(jn) + nn_hls
+ jpiall_crs (jn) = nie0all_crs(jn)
+ nis0all_crs(jn) = nis0all(jn)
CASE DEFAULT
@@ -2001,15 +1997,15 @@
nimppt_crs(jn) = ANINT( REAL( (nimppt(jn) + 1 ) / nn_factx, wp ) ) + 1
DO jj = jn + jpni , jpnij, jpni
- nleit_crs(jj) = nleit_crs(jn)
- nlcit_crs(jj) = nlcit_crs(jn)
- nldit_crs(jj) = nldit_crs(jn)
- nimppt_crs(jj)= nimppt_crs(jn)
+ nie0all_crs(jj) = nie0all_crs(jn)
+ jpiall_crs (jj) = jpiall_crs (jn)
+ nis0all_crs(jj) = nis0all_crs(jn)
+ nimppt_crs (jj) = nimppt_crs (jn)
ENDDO
ENDDO
- nlei_crs = nleit_crs(nproc + 1)
- nlci_crs = nlcit_crs(nproc + 1)
- nldi_crs = nldit_crs(nproc + 1)
- nimpp_crs = nimppt_crs(nproc + 1)
+ Nie0_crs = nie0all_crs(nproc + 1)
+ jpi_crs = jpiall_crs (nproc + 1)
+ Nis0_crs = nis0all_crs(nproc + 1)
+ nimpp_crs = nimppt_crs (nproc + 1)
DO ji = 1, jpi_crs
@@ -2043,21 +2039,21 @@
jpjglo_full = jpjglo
- nlcj_full = nlcj
- nlci_full = nlci
- nldi_full = nldi
- nldj_full = nldj
- nlei_full = nlei
- nlej_full = nlej
- nimpp_full = nimpp
- njmpp_full = njmpp
+ jpj_full = jpj
+ jpi_full = jpi
+ Nis0_full = Nis0
+ Njs0_full = Njs0
+ Nie0_full = Nie0
+ Nje0_full = Nje0
+ nimpp_full = nimpp
+ njmpp_full = njmpp
- nlcit_full(:) = nlcit(:)
- nldit_full(:) = nldit(:)
- nleit_full(:) = nleit(:)
- nimppt_full(:) = nimppt(:)
- nlcjt_full(:) = nlcjt(:)
- nldjt_full(:) = nldjt(:)
- nlejt_full(:) = nlejt(:)
- njmppt_full(:) = njmppt(:)
+ jpiall_full (:) = jpiall (:)
+ nis0all_full(:) = nis0all(:)
+ nie0all_full(:) = nie0all(:)
+ nimppt_full (:) = nimppt (:)
+ jpjall_full (:) = jpjall (:)
+ njs0all_full(:) = njs0all(:)
+ nje0all_full(:) = nje0all(:)
+ njmppt_full (:) = njmppt (:)
CALL dom_grid_crs !swich de grille
@@ -2073,12 +2069,12 @@
WRITE(numout,*)
WRITE(numout,*) ' nproc = ' , nproc
- WRITE(numout,*) ' nlci = ' , nlci
- WRITE(numout,*) ' nlcj = ' , nlcj
- WRITE(numout,*) ' nldi = ' , nldi
- WRITE(numout,*) ' nldj = ' , nldj
- WRITE(numout,*) ' nlei = ' , nlei
- WRITE(numout,*) ' nlej = ' , nlej
- WRITE(numout,*) ' nlei_full=' , nlei_full
- WRITE(numout,*) ' nldi_full=' , nldi_full
+ WRITE(numout,*) ' jpi = ' , jpi
+ WRITE(numout,*) ' jpj = ' , jpj
+ WRITE(numout,*) ' Nis0 = ' , Nis0
+ WRITE(numout,*) ' Njs0 = ' , Njs0
+ WRITE(numout,*) ' Nie0 = ' , Nie0
+ WRITE(numout,*) ' Nje0 = ' , Nje0
+ WRITE(numout,*) ' Nie0_full=' , Nie0_full
+ WRITE(numout,*) ' Nis0_full=' , Nis0_full
WRITE(numout,*) ' nimpp = ' , nimpp
WRITE(numout,*) ' njmpp = ' , njmpp
@@ -2203,9 +2199,9 @@
mje_crs(:) = mje2_crs(:)
ELSE
- DO jj = 1, nlej_crs
+ DO jj = 1, Nje0_crs
mjs_crs(jj) = mjs2_crs(mjg_crs(jj)) - njmpp + 1
mje_crs(jj) = mje2_crs(mjg_crs(jj)) - njmpp + 1
ENDDO
- DO ji = 1, nlei_crs
+ DO ji = 1, Nie0_crs
mis_crs(ji) = mis2_crs(mig_crs(ji)) - nimpp + 1
mie_crs(ji) = mie2_crs(mig_crs(ji)) - nimpp + 1
@@ -2213,6 +2209,6 @@
ENDIF
!
- nistr = mis_crs(2) ; niend = mis_crs(nlci_crs - 1)
- njstr = mjs_crs(3) ; njend = mjs_crs(nlcj_crs - 1)
+ nistr = mis_crs(2) ; niend = mis_crs(jpi_crs - 1)
+ njstr = mjs_crs(3) ; njend = mjs_crs(jpj_crs - 1)
!
END SUBROUTINE crs_dom_def
@@ -2246,5 +2242,5 @@
zmbk(:,:) = 0.0
- zmbk(:,:) = REAL( mbathy_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'T',1.0) ; mbathy_crs(:,:) = NINT( zmbk(:,:) )
+ zmbk(:,:) = REAL( mbathy_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'T',1.0_wp) ; mbathy_crs(:,:) = NINT( zmbk(:,:) )
@@ -2266,6 +2262,6 @@
! convert into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk
zmbk(:,:) = 1.e0;
- zmbk(:,:) = REAL( mbku_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'U',1.0) ; mbku_crs (:,:) = MAX( NINT( zmbk(:,:) ), 1 )
- zmbk(:,:) = REAL( mbkv_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'V',1.0) ; mbkv_crs (:,:) = MAX( NINT( zmbk(:,:) ), 1 )
+ zmbk(:,:) = REAL( mbku_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'U',1.0_wp) ; mbku_crs (:,:) = MAX( NINT( zmbk(:,:) ), 1 )
+ zmbk(:,:) = REAL( mbkv_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'V',1.0_wp) ; mbkv_crs (:,:) = MAX( NINT( zmbk(:,:) ), 1 )
!
END SUBROUTINE crs_dom_bat
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/CRS/crsdomwri.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/CRS/crsdomwri.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/CRS/crsdomwri.F90 (revision 13540)
@@ -50,5 +50,4 @@
INTEGER :: ji, jj, jk ! dummy loop indices
INTEGER :: inum ! local units for 'mesh_mask.nc' file
- INTEGER :: iif, iil, ijf, ijl
CHARACTER(len=21) :: clnam ! filename (mesh and mask informations)
! ! workspace
@@ -76,36 +75,7 @@
CALL iom_rstput( 0, 0, inum, 'fmask', fmask_crs, ktype = jp_i1 )
-
- tmask_i_crs(:,:) = tmask_crs(:,:,1)
- iif = nn_hls
- iil = nlci_crs - nn_hls + 1
- ijf = nn_hls
- ijl = nlcj_crs - nn_hls + 1
-
- tmask_i_crs( 1:iif , : ) = 0._wp
- tmask_i_crs(iil:jpi_crs, : ) = 0._wp
- tmask_i_crs( : , 1:ijf ) = 0._wp
- tmask_i_crs( : ,ijl:jpj_crs) = 0._wp
-
-
- tpol_crs(1:jpiglo_crs,:) = 1._wp
- fpol_crs(1:jpiglo_crs,:) = 1._wp
- IF( jperio == 3 .OR. jperio == 4 ) THEN
- tpol_crs(jpiglo_crs/2+1:jpiglo_crs,:) = 0._wp
- fpol_crs( 1 :jpiglo_crs,:) = 0._wp
- IF( mjg_crs(nlej_crs) == jpiglo_crs ) THEN
- DO ji = iif+1, iil-1
- tmask_i_crs(ji,nlej_crs-1) = tmask_i_crs(ji,nlej_crs-1) &
- & * tpol_crs(mig_crs(ji),1)
- ENDDO
- ENDIF
- ENDIF
- IF( jperio == 5 .OR. jperio == 6 ) THEN
- tpol_crs( 1 :jpiglo_crs,:)=0._wp
- fpol_crs(jpiglo_crs/2+1:jpiglo_crs,:)=0._wp
- ENDIF
-
- CALL iom_rstput( 0, 0, inum, 'tmaskutil', tmask_i_crs, ktype = jp_i1 )
- ! ! unique point mask
+ CALL dom_uniq_crs( zprw, 'T' )
+ zprt = tmask_crs(:,:,1) * zprw
+ CALL iom_rstput( 0, 0, inum, 'tmaskutil', zprt, ktype = jp_i1 )
CALL dom_uniq_crs( zprw, 'U' )
zprt = umask_crs(:,:,1) * zprw
@@ -161,5 +131,5 @@
END DO
END DO
- CALL crs_lbc_lnk( zdepu,'U', 1. ) ; CALL crs_lbc_lnk( zdepv,'V', 1. )
+ CALL crs_lbc_lnk( zdepu,'U', 1.0_wp ) ; CALL crs_lbc_lnk( zdepv,'V', 1.0_wp )
!
CALL iom_rstput( 0, 0, inum, 'gdepu', zdepu, ktype = jp_r4 )
@@ -211,6 +181,6 @@
REAL(wp) :: zshift ! shift value link to the process number
INTEGER :: ji ! dummy loop indices
- LOGICAL, DIMENSION(SIZE(puniq,1),SIZE(puniq,2),1) :: lldbl ! store whether each point is unique or not
- REAL(wp), DIMENSION(jpi_crs,jpj_crs) :: ztstref
+ LOGICAL , DIMENSION(jpi_crs,jpj_crs,1) :: lluniq ! store whether each point is unique or not
+ REAL(wp), DIMENSION(jpi_crs,jpj_crs ) :: ztstref
!!----------------------------------------------------------------------
!
@@ -218,14 +188,12 @@
! in mpp: make sure that these values are different even between process
! -> apply a shift value according to the process number
- zshift = jpi_crs * jpj_crs * ( narea - 1 )
+ zshift = (jpi_crs+1.) * (jpj_crs+1.) * ( narea - 1 ) ! we should use jpimax_crs but not existing
ztstref(:,:) = RESHAPE( (/ (zshift + REAL(ji,wp), ji = 1, jpi_crs*jpj_crs) /), (/ jpi_crs, jpj_crs /) )
!
puniq(:,:) = ztstref(:,:) ! default definition
- CALL crs_lbc_lnk( puniq,cdgrd, 1. ) ! apply boundary conditions
- lldbl(:,:,1) = puniq(:,:) == ztstref(:,:) ! check which values have been changed
- !
- puniq(:,:) = 1. ! default definition
- ! fill only the inner part of the cpu with llbl converted into real
- puniq(nldi_crs:nlei_crs,nldj_crs:nlej_crs) = REAL( COUNT( lldbl(nldi_crs:nlei_crs,nldj_crs:nlej_crs,:), dim = 3 ) , wp )
+ CALL crs_lbc_lnk( puniq,cdgrd, 1.0_wp ) ! apply boundary conditions
+ lluniq(:,:,1) = puniq(:,:) == ztstref(:,:) ! check which values have been changed
+ !
+ puniq(:,:) = REAL( COUNT( lluniq(:,:,:), dim = 3 ), wp )
!
END SUBROUTINE dom_uniq_crs
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/CRS/crsfld.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/CRS/crsfld.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/CRS/crsfld.F90 (revision 13540)
@@ -33,4 +33,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -68,8 +69,10 @@
! Depth work arrrays
- ze3t(:,:,:) = e3t(:,:,:,Kmm)
- ze3u(:,:,:) = e3u(:,:,:,Kmm)
- ze3v(:,:,:) = e3v(:,:,:,Kmm)
- ze3w(:,:,:) = e3w(:,:,:,Kmm)
+ DO jk = 1 , jpk
+ ze3t(:,:,jk) = e3t(:,:,jk,Kmm)
+ ze3u(:,:,jk) = e3u(:,:,jk,Kmm)
+ ze3v(:,:,jk) = e3v(:,:,jk,Kmm)
+ ze3w(:,:,jk) = e3w(:,:,jk,Kmm)
+ END DO
IF( kt == nit000 ) THEN
@@ -98,5 +101,5 @@
! Temperature
zt(:,:,:) = ts(:,:,:,jp_tem,Kmm) ; zt_crs(:,:,:) = 0._wp
- CALL crs_dom_ope( zt, 'VOL', 'T', tmask, zt_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0 )
+ CALL crs_dom_ope( zt, 'VOL', 'T', tmask, zt_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0_wp )
tsn_crs(:,:,:,jp_tem) = zt_crs(:,:,:)
@@ -107,5 +110,5 @@
! Salinity
zs(:,:,:) = ts(:,:,:,jp_sal,Kmm) ; zs_crs(:,:,:) = 0._wp
- CALL crs_dom_ope( zs, 'VOL', 'T', tmask, zs_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0 )
+ CALL crs_dom_ope( zs, 'VOL', 'T', tmask, zs_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0_wp )
tsn_crs(:,:,:,jp_sal) = zt_crs(:,:,:)
@@ -114,13 +117,13 @@
! U-velocity
- CALL crs_dom_ope( uu(:,:,:,Kmm), 'SUM', 'U', umask, un_crs, p_e12=e2u, p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0 )
+ CALL crs_dom_ope( uu(:,:,:,Kmm), 'SUM', 'U', umask, un_crs, p_e12=e2u, p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0_wp )
!
zt(:,:,:) = 0._wp ; zs(:,:,:) = 0._wp ; zt_crs(:,:,:) = 0._wp ; zs_crs(:,:,:) = 0._wp
- DO_3D_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
zt(ji,jj,jk) = uu(ji,jj,jk,Kmm) * 0.5 * ( ts(ji,jj,jk,jp_tem,Kmm) + ts(ji+1,jj,jk,jp_tem,Kmm) )
zs(ji,jj,jk) = uu(ji,jj,jk,Kmm) * 0.5 * ( ts(ji,jj,jk,jp_sal,Kmm) + ts(ji+1,jj,jk,jp_sal,Kmm) )
END_3D
- CALL crs_dom_ope( zt, 'SUM', 'U', umask, zt_crs, p_e12=e2u, p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0 )
- CALL crs_dom_ope( zs, 'SUM', 'U', umask, zs_crs, p_e12=e2u, p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0 )
+ CALL crs_dom_ope( zt, 'SUM', 'U', umask, zt_crs, p_e12=e2u, p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0_wp )
+ CALL crs_dom_ope( zs, 'SUM', 'U', umask, zs_crs, p_e12=e2u, p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0_wp )
CALL iom_put( "uoce" , un_crs ) ! i-current
@@ -129,13 +132,13 @@
! V-velocity
- CALL crs_dom_ope( vv(:,:,:,Kmm), 'SUM', 'V', vmask, vn_crs, p_e12=e1v, p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0 )
+ CALL crs_dom_ope( vv(:,:,:,Kmm), 'SUM', 'V', vmask, vn_crs, p_e12=e1v, p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0_wp )
!
zt(:,:,:) = 0._wp ; zs(:,:,:) = 0._wp ; zt_crs(:,:,:) = 0._wp ; zs_crs(:,:,:) = 0._wp
- DO_3D_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
zt(ji,jj,jk) = vv(ji,jj,jk,Kmm) * 0.5 * ( ts(ji,jj,jk,jp_tem,Kmm) + ts(ji,jj+1,jk,jp_tem,Kmm) )
zs(ji,jj,jk) = vv(ji,jj,jk,Kmm) * 0.5 * ( ts(ji,jj,jk,jp_sal,Kmm) + ts(ji,jj+1,jk,jp_sal,Kmm) )
END_3D
- CALL crs_dom_ope( zt, 'SUM', 'V', vmask, zt_crs, p_e12=e1v, p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0 )
- CALL crs_dom_ope( zs, 'SUM', 'V', vmask, zs_crs, p_e12=e1v, p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0 )
+ CALL crs_dom_ope( zt, 'SUM', 'V', vmask, zt_crs, p_e12=e1v, p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0_wp )
+ CALL crs_dom_ope( zs, 'SUM', 'V', vmask, zs_crs, p_e12=e1v, p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0_wp )
CALL iom_put( "voce" , vn_crs ) ! i-current
@@ -143,7 +146,7 @@
CALL iom_put( "voces" , zs_crs ) ! vS
- IF( iom_use( "eken") ) THEN ! kinetic energy
+ IF( iom_use( "ke") ) THEN ! kinetic energy
z3d(:,:,jk) = 0._wp
- DO_3D_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
zztmp = r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm)
z3d(ji,jj,jk) = 0.25_wp * zztmp * ( &
@@ -153,8 +156,8 @@
& + vv(ji,jj ,jk,Kmm)**2 * e1v(ji,jj ) * e3v(ji,jj ,jk,Kmm) )
END_3D
- CALL lbc_lnk( 'crsfld', z3d, 'T', 1. )
+ CALL lbc_lnk( 'crsfld', z3d, 'T', 1.0_wp )
!
- CALL crs_dom_ope( z3d, 'VOL', 'T', tmask, zt_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0 )
- CALL iom_put( "eken", zt_crs )
+ CALL crs_dom_ope( z3d, 'VOL', 'T', tmask, zt_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0_wp )
+ CALL iom_put( "ke", zt_crs )
ENDIF
! Horizontal divergence ( following OCE/DYN/divhor.F90 )
@@ -173,5 +176,5 @@
END DO
END DO
- CALL crs_lbc_lnk( hdivn_crs, 'T', 1.0 )
+ CALL crs_lbc_lnk( hdivn_crs, 'T', 1.0_wp )
!
CALL iom_put( "hdiv", hdivn_crs )
@@ -180,5 +183,5 @@
! W-velocity
IF( ln_crs_wn ) THEN
- CALL crs_dom_ope( ww, 'SUM', 'W', tmask, wn_crs, p_e12=e1e2t, p_surf_crs=e1e2w_msk, psgn=1.0 )
+ CALL crs_dom_ope( ww, 'SUM', 'W', tmask, wn_crs, p_e12=e1e2t, p_surf_crs=e1e2w_msk, psgn=1.0_wp )
! CALL crs_dom_ope( ww, 'VOL', 'W', tmask, wn_crs, p_e12=e1e2t, p_e3=ze3w )
ELSE
@@ -194,12 +197,12 @@
SELECT CASE ( nn_crs_kz )
CASE ( 0 )
- CALL crs_dom_ope( avt, 'VOL', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0 )
- CALL crs_dom_ope( avs, 'VOL', 'W', tmask, avs_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0 )
+ CALL crs_dom_ope( avt, 'VOL', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0_wp )
+ CALL crs_dom_ope( avs, 'VOL', 'W', tmask, avs_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0_wp )
CASE ( 1 )
- CALL crs_dom_ope( avt, 'MAX', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0 )
- CALL crs_dom_ope( avs, 'MAX', 'W', tmask, avs_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0 )
+ CALL crs_dom_ope( avt, 'MAX', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0_wp )
+ CALL crs_dom_ope( avs, 'MAX', 'W', tmask, avs_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0_wp )
CASE ( 2 )
- CALL crs_dom_ope( avt, 'MIN', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0 )
- CALL crs_dom_ope( avs, 'MIN', 'W', tmask, avs_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0 )
+ CALL crs_dom_ope( avt, 'MIN', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0_wp )
+ CALL crs_dom_ope( avs, 'MIN', 'W', tmask, avs_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0_wp )
END SELECT
!
@@ -208,14 +211,14 @@
! sbc fields
- CALL crs_dom_ope( ssh(:,:,Kmm) , 'VOL', 'T', tmask, sshn_crs , p_e12=e1e2t, p_e3=ze3t , psgn=1.0 )
- CALL crs_dom_ope( utau , 'SUM', 'U', umask, utau_crs , p_e12=e2u , p_surf_crs=e2u_crs , psgn=1.0 )
- CALL crs_dom_ope( vtau , 'SUM', 'V', vmask, vtau_crs , p_e12=e1v , p_surf_crs=e1v_crs , psgn=1.0 )
- CALL crs_dom_ope( wndm , 'SUM', 'T', tmask, wndm_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 )
- CALL crs_dom_ope( rnf , 'MAX', 'T', tmask, rnf_crs , psgn=1.0 )
- CALL crs_dom_ope( qsr , 'SUM', 'T', tmask, qsr_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 )
- CALL crs_dom_ope( emp_b, 'SUM', 'T', tmask, emp_b_crs, p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 )
- CALL crs_dom_ope( emp , 'SUM', 'T', tmask, emp_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 )
- CALL crs_dom_ope( sfx , 'SUM', 'T', tmask, sfx_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 )
- CALL crs_dom_ope( fr_i , 'SUM', 'T', tmask, fr_i_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 )
+ 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( 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 )
+ CALL crs_dom_ope( emp_b, 'SUM', 'T', tmask, emp_b_crs, p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp )
+ CALL crs_dom_ope( emp , 'SUM', 'T', tmask, emp_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp )
+ CALL crs_dom_ope( sfx , 'SUM', 'T', tmask, sfx_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp )
+ CALL crs_dom_ope( fr_i , 'SUM', 'T', tmask, fr_i_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp )
CALL iom_put( "ssh" , sshn_crs ) ! ssh output
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/CRS/crsini.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/CRS/crsini.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/CRS/crsini.F90 (revision 13540)
@@ -28,4 +28,6 @@
PUBLIC crs_init ! called by nemogcm.F90 module
+ !! * Substitutions
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -174,8 +176,10 @@
!
- ze3t(:,:,:) = e3t(:,:,:,Kmm)
- ze3u(:,:,:) = e3u(:,:,:,Kmm)
- ze3v(:,:,:) = e3v(:,:,:,Kmm)
- ze3w(:,:,:) = e3w(:,:,:,Kmm)
+ DO jk = 1, jpk
+ ze3t(:,:,jk) = e3t(:,:,jk,Kmm)
+ ze3u(:,:,jk) = e3u(:,:,jk,Kmm)
+ ze3v(:,:,jk) = e3v(:,:,jk,Kmm)
+ ze3w(:,:,jk) = e3w(:,:,jk,Kmm)
+ END DO
! 3.d.2 Surfaces
@@ -207,6 +211,6 @@
! 3.d.3 Vertical depth (meters)
- CALL crs_dom_ope( gdept_0, 'MAX', 'T', tmask, gdept_crs, p_e3=ze3t, psgn=1.0 )
- CALL crs_dom_ope( gdepw_0, 'MAX', 'W', tmask, gdepw_crs, p_e3=ze3w, psgn=1.0 )
+ 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 )
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/DIA/diaar5.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/DIA/diaar5.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/DIA/diaar5.F90 (revision 13540)
@@ -32,5 +32,4 @@
REAL(wp) :: vol0 ! ocean volume (interior domain)
REAL(wp) :: area_tot ! total ocean surface (interior domain)
- REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,: ) :: area ! cell surface (interior domain)
REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,: ) :: thick0 ! ocean thickness (interior domain)
REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sn0 ! initial salinity
@@ -40,4 +39,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -54,5 +54,5 @@
!!----------------------------------------------------------------------
!
- ALLOCATE( area(jpi,jpj), thick0(jpi,jpj) , sn0(jpi,jpj,jpk) , STAT=dia_ar5_alloc )
+ ALLOCATE( thick0(jpi,jpj) , sn0(jpi,jpj,jpk) , STAT=dia_ar5_alloc )
!
CALL mpp_sum ( 'diaar5', dia_ar5_alloc )
@@ -77,6 +77,6 @@
!
REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zarea_ssh , zbotpres ! 2D workspace
- REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zpe, z2d ! 2D workspace
- REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zrhd , zrhop, ztpot ! 3D 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
@@ -88,24 +88,27 @@
IF( l_ar5 ) THEN
ALLOCATE( zarea_ssh(jpi,jpj), zbotpres(jpi,jpj), z2d(jpi,jpj) )
- ALLOCATE( zrhd(jpi,jpj,jpk) , zrhop(jpi,jpj,jpk) )
+ ALLOCATE( zrhd(jpi,jpj,jpk) )
ALLOCATE( ztsn(jpi,jpj,jpk,jpts) )
- zarea_ssh(:,:) = area(:,:) * ssh(:,:,Kmm)
- ENDIF
- !
- CALL iom_put( 'e2u' , e2u (:,:) )
- CALL iom_put( 'e1v' , e1v (:,:) )
- CALL iom_put( 'areacello', area(:,:) )
+ zarea_ssh(:,:) = e1e2t(:,:) * ssh(:,:,Kmm)
+ ENDIF
+ !
+ CALL iom_put( 'e2u' , e2u (:,:) )
+ CALL iom_put( 'e1v' , e1v (:,:) )
+ 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) = area(:,:) * e3t(:,:,jk,Kmm) * tmask(:,:,jk)
+ 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
- CALL iom_put( 'masscello' , rho0 * e3t(:,:,:,Kmm) * tmask(:,:,:) ) ! ocean mass
+ CALL iom_put( 'masscello' , z3d (:,:,:) ) ! ocean mass
ENDIF
!
IF( iom_use( 'e3tb' ) ) THEN ! bottom layer thickness
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
ikb = mbkt(ji,jj)
z2d(ji,jj) = e3t(ji,jj,ikb,Kmm)
@@ -129,5 +132,9 @@
ztsn(:,:,:,jp_tem) = ts(:,:,:,jp_tem,Kmm) ! thermosteric ssh
ztsn(:,:,:,jp_sal) = sn0(:,:,:)
- CALL eos( ztsn, zrhd, gdept(:,:,:,Kmm) ) ! now in situ density using initial salinity
+ 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
!
zbotpres(:,:) = 0._wp ! no atmospheric surface pressure, levitating sea-ice
@@ -137,10 +144,8 @@
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) * zrhd(ji,jj,iks) + riceload(ji,jj)
- END DO
- END DO
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ iks = mikt(ji,jj)
+ zbotpres(ji,jj) = zbotpres(ji,jj) + ssh(ji,jj,Kmm) * zrhd(ji,jj,iks) + riceload(ji,jj)
+ END_2D
ELSE
zbotpres(:,:) = zbotpres(:,:) + ssh(:,:,Kmm) * zrhd(:,:,1)
@@ -151,16 +156,12 @@
END IF
!
- zarho = glob_sum( 'diaar5', area(:,:) * zbotpres(:,:) )
+ zarho = glob_sum( 'diaar5', e1e2t(:,:) * zbotpres(:,:) )
zssh_steric = - zarho / area_tot
CALL iom_put( 'sshthster', zssh_steric )
! ! steric sea surface height
- CALL eos( ts(:,:,:,:,Kmm), zrhd, zrhop, gdept(:,:,:,Kmm) ) ! now in situ and potential density
- zrhop(:,:,jpk) = 0._wp
- CALL iom_put( 'rhop', zrhop )
- !
zbotpres(:,:) = 0._wp ! no atmospheric surface pressure, levitating sea-ice
DO jk = 1, jpkm1
- zbotpres(:,:) = zbotpres(:,:) + e3t(:,:,jk,Kmm) * zrhd(:,:,jk)
+ zbotpres(:,:) = zbotpres(:,:) + e3t(:,:,jk,Kmm) * rhd(:,:,jk)
END DO
IF( ln_linssh ) THEN
@@ -169,13 +170,13 @@
DO jj = 1,jpj
iks = mikt(ji,jj)
- zbotpres(ji,jj) = zbotpres(ji,jj) + ssh(ji,jj,Kmm) * zrhd(ji,jj,iks) + riceload(ji,jj)
+ zbotpres(ji,jj) = zbotpres(ji,jj) + ssh(ji,jj,Kmm) * rhd(ji,jj,iks) + riceload(ji,jj)
END DO
END DO
ELSE
- zbotpres(:,:) = zbotpres(:,:) + ssh(:,:,Kmm) * zrhd(:,:,1)
+ zbotpres(:,:) = zbotpres(:,:) + ssh(:,:,Kmm) * rhd(:,:,1)
END IF
END IF
!
- zarho = glob_sum( 'diaar5', area(:,:) * zbotpres(:,:) )
+ zarho = glob_sum( 'diaar5', e1e2t(:,:) * zbotpres(:,:) )
zssh_steric = - zarho / area_tot
CALL iom_put( 'sshsteric', zssh_steric )
@@ -185,4 +186,6 @@
CALL iom_put( 'botpres', zbotpres )
!
+ DEALLOCATE( zgdept )
+ !
ENDIF
@@ -190,6 +193,6 @@
! ! 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_11_11( 1, jpkm1 )
- zztmp = area(ji,jj) * e3t(ji,jj,jk,Kmm)
+ DO_3D( 1, 1, 1, 1, 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)
@@ -237,5 +240,5 @@
z2d(:,:) = 0._wp
DO jk = 1, jpkm1
- z2d(:,:) = z2d(:,:) + area(:,:) * e3t(:,:,jk,Kmm) * ztpot(:,:,jk)
+ z2d(:,:) = z2d(:,:) + e1e2t(:,:) * e3t(:,:,jk,Kmm) * ztpot(:,:,jk)
END DO
ztemp = glob_sum( 'diaar5', z2d(:,:) )
@@ -244,5 +247,5 @@
!
IF( iom_use( 'ssttot' ) ) THEN ! Output potential temperature in case we use TEOS-10
- zsst = glob_sum( 'diaar5', area(:,:) * ztpot(:,:,1) )
+ zsst = glob_sum( 'diaar5', e1e2t(:,:) * ztpot(:,:,1) )
CALL iom_put( 'ssttot', zsst / area_tot )
ENDIF
@@ -250,5 +253,5 @@
IF( iom_use( 'tosmint_pot') ) THEN
z2d(:,:) = 0._wp
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
z2d(ji,jj) = z2d(ji,jj) + rho0 * e3t(ji,jj,jk,Kmm) * ztpot(ji,jj,jk)
END_3D
@@ -259,5 +262,5 @@
ELSE
IF( iom_use('ssttot') ) THEN ! Output sst in case we use EOS-80
- zsst = glob_sum( 'diaar5', area(:,:) * ts(:,:,1,jp_tem,Kmm) )
+ zsst = glob_sum( 'diaar5', e1e2t(:,:) * ts(:,:,1,jp_tem,Kmm) )
CALL iom_put('ssttot', zsst / area_tot )
ENDIF
@@ -271,5 +274,5 @@
zpe(:,:) = 0._wp
IF( ln_zdfddm ) THEN
- DO_3D_11_11( 2, jpk )
+ DO_3D( 1, 1, 1, 1, 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)
@@ -284,5 +287,5 @@
END_3D
ELSE
- DO_3D_11_11( 1, jpk )
+ 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)
END_3D
@@ -294,5 +297,4 @@
IF( l_ar5 ) THEN
DEALLOCATE( zarea_ssh , zbotpres, z2d )
- DEALLOCATE( zrhd , zrhop )
DEALLOCATE( ztsn )
ENDIF
@@ -320,8 +322,8 @@
z2d(:,:) = puflx(:,:,1)
- DO_3D_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
z2d(ji,jj) = z2d(ji,jj) + puflx(ji,jj,jk)
END_3D
- CALL lbc_lnk( 'diaar5', z2d, 'U', -1. )
+ CALL lbc_lnk( 'diaar5', z2d, 'U', -1.0_wp )
IF( cptr == 'adv' ) THEN
IF( ktra == jp_tem ) CALL iom_put( 'uadv_heattr' , rho0_rcp * z2d ) ! advective heat transport in i-direction
@@ -334,8 +336,8 @@
!
z2d(:,:) = pvflx(:,:,1)
- DO_3D_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
z2d(ji,jj) = z2d(ji,jj) + pvflx(ji,jj,jk)
END_3D
- CALL lbc_lnk( 'diaar5', z2d, 'V', -1. )
+ CALL lbc_lnk( 'diaar5', z2d, 'V', -1.0_wp )
IF( cptr == 'adv' ) THEN
IF( ktra == jp_tem ) CALL iom_put( 'vadv_heattr' , rho0_rcp * z2d ) ! advective heat transport in j-direction
@@ -368,5 +370,6 @@
IF( iom_use( 'voltot' ) .OR. iom_use( 'sshtot' ) .OR. iom_use( 'sshdyn' ) .OR. &
& iom_use( 'masstot' ) .OR. iom_use( 'temptot' ) .OR. iom_use( 'saltot' ) .OR. &
- & iom_use( 'botpres' ) .OR. iom_use( 'sshthster' ) .OR. iom_use( 'sshsteric' ) ) L_ar5 = .TRUE.
+ & iom_use( 'botpres' ) .OR. iom_use( 'sshthster' ) .OR. iom_use( 'sshsteric' ) .OR. &
+ & iom_use( 'rhop' ) ) L_ar5 = .TRUE.
IF( l_ar5 ) THEN
@@ -375,13 +378,12 @@
IF( dia_ar5_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'dia_ar5_init : unable to allocate arrays' )
- area(:,:) = e1e2t(:,:)
- area_tot = glob_sum( 'diaar5', area(:,:) )
+ area_tot = glob_sum( 'diaar5', e1e2t(:,:) )
ALLOCATE( zvol0(jpi,jpj) )
zvol0 (:,:) = 0._wp
thick0(:,:) = 0._wp
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 ) ! interpolation of salinity at the last ocean level (i.e. the partial step)
idep = tmask(ji,jj,jk) * e3t_0(ji,jj,jk)
- zvol0 (ji,jj) = zvol0 (ji,jj) + idep * area(ji,jj)
+ zvol0 (ji,jj) = zvol0 (ji,jj) + idep * e1e2t(ji,jj)
thick0(ji,jj) = thick0(ji,jj) + idep
END_3D
@@ -392,6 +394,6 @@
ALLOCATE( zsaldta(jpi,jpj,jpk,jpts) )
CALL iom_open ( 'sali_ref_clim_monthly', inum )
- CALL iom_get ( inum, jpdom_data, 'vosaline' , zsaldta(:,:,:,1), 1 )
- CALL iom_get ( inum, jpdom_data, 'vosaline' , zsaldta(:,:,:,2), 12 )
+ CALL iom_get ( inum, jpdom_global, 'vosaline' , zsaldta(:,:,:,1), 1 )
+ CALL iom_get ( inum, jpdom_global, 'vosaline' , zsaldta(:,:,:,2), 12 )
CALL iom_close( inum )
@@ -399,5 +401,5 @@
sn0(:,:,:) = sn0(:,:,:) * tmask(:,:,:)
IF( ln_zps ) THEN ! z-coord. partial steps
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 ) ! interpolation of salinity at the last ocean level (i.e. the partial step)
ik = mbkt(ji,jj)
IF( ik > 1 ) THEN
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/DIA/diacfl.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/DIA/diacfl.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/DIA/diacfl.F90 (revision 13540)
@@ -34,4 +34,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -55,46 +56,43 @@
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
!!----------------------------------------------------------------------
!
IF( ln_timing ) CALL timing_start('dia_cfl')
!
- DO_3D_11_11( 1, jpk )
+ llmsk( 1:Nis1,:,:) = .FALSE. ! exclude halos from the checked region
+ llmsk(Nie1: jpi,:,:) = .FALSE.
+ llmsk(:, 1:Njs1,:) = .FALSE.
+ llmsk(:,Nje1: 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
zCv_cfl(ji,jj,jk) = ABS( vv(ji,jj,jk,Kmm) ) * rDt / e2v (ji,jj) ! for j-direction
- zCw_cfl(ji,jj,jk) = ABS( ww(ji,jj,jk) ) * rDt / e3w(ji,jj,jk,Kmm) ! for k-direction
+ zCw_cfl(ji,jj,jk) = ABS( ww(ji,jj,jk) ) * rDt / e3w(ji,jj,jk,Kmm) ! for k-direction
END_3D
!
! write outputs
- IF( iom_use('cfl_cu') ) CALL iom_put( 'cfl_cu', MAXVAL( zCu_cfl, dim=3 ) )
- IF( iom_use('cfl_cv') ) CALL iom_put( 'cfl_cv', MAXVAL( zCv_cfl, dim=3 ) )
- IF( iom_use('cfl_cw') ) CALL iom_put( 'cfl_cw', MAXVAL( zCw_cfl, dim=3 ) )
+ IF( iom_use('cfl_cu') ) THEN
+ llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain
+ CALL iom_put( 'cfl_cu', MAXVAL( zCu_cfl, mask = llmsk, dim=3 ) )
+ ENDIF
+ IF( iom_use('cfl_cv') ) THEN
+ llmsk(Nis0:Nie0,Njs0:Nje0,:) = vmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain
+ CALL iom_put( 'cfl_cv', MAXVAL( zCv_cfl, mask = llmsk, dim=3 ) )
+ ENDIF
+ IF( iom_use('cfl_cw') ) THEN
+ llmsk(Nis0:Nie0,Njs0:Nje0,:) = wmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain
+ CALL iom_put( 'cfl_cw', MAXVAL( zCw_cfl, mask = llmsk, dim=3 ) )
+ ENDIF
! ! calculate maximum values and locations
- IF( lk_mpp ) THEN
- CALL mpp_maxloc( 'diacfl', zCu_cfl, umask, zCu_max, iloc_u )
- CALL mpp_maxloc( 'diacfl', zCv_cfl, vmask, zCv_max, iloc_v )
- CALL mpp_maxloc( 'diacfl', zCw_cfl, wmask, zCw_max, iloc_w )
- ELSE
- iloc = MAXLOC( ABS( zcu_cfl(:,:,:) ) )
- iloc_u(1) = iloc(1) + nimpp - 1
- iloc_u(2) = iloc(2) + njmpp - 1
- iloc_u(3) = iloc(3)
- zCu_max = zCu_cfl(iloc(1),iloc(2),iloc(3))
- !
- iloc = MAXLOC( ABS( zcv_cfl(:,:,:) ) )
- iloc_v(1) = iloc(1) + nimpp - 1
- iloc_v(2) = iloc(2) + njmpp - 1
- iloc_v(3) = iloc(3)
- zCv_max = zCv_cfl(iloc(1),iloc(2),iloc(3))
- !
- iloc = MAXLOC( ABS( zcw_cfl(:,:,:) ) )
- iloc_w(1) = iloc(1) + nimpp - 1
- iloc_w(2) = iloc(2) + njmpp - 1
- iloc_w(3) = iloc(3)
- zCw_max = zCw_cfl(iloc(1),iloc(2),iloc(3))
- ENDIF
+ llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain
+ CALL mpp_maxloc( 'diacfl', zCu_cfl, llmsk, zCu_max, iloc_u )
+ llmsk(Nis0:Nie0,Njs0:Nje0,:) = vmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain
+ CALL mpp_maxloc( 'diacfl', zCv_cfl, llmsk, zCv_max, iloc_v )
+ llmsk(Nis0:Nie0,Njs0:Nje0,:) = wmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain
+ CALL mpp_maxloc( 'diacfl', zCw_cfl, llmsk, zCw_max, iloc_w )
!
- ! ! write out to file
- IF( lwp ) THEN
+ IF( lwp ) THEN ! write out to file
WRITE(numcfl,FMT='(2x,i6,3x,a6,4x,f7.4,1x,i4,1x,i4,1x,i4)') kt, 'Max Cu', zCu_max, iloc_u(1), iloc_u(2), iloc_u(3)
WRITE(numcfl,FMT='(11x, a6,4x,f7.4,1x,i4,1x,i4,1x,i4)') 'Max Cv', zCv_max, iloc_v(1), iloc_v(2), iloc_v(3)
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/DIA/diadct.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/DIA/diadct.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/DIA/diadct.F90 (revision 13540)
@@ -11,6 +11,6 @@
!! 3.4 ! 09/2011 (C Bricaud)
!!----------------------------------------------------------------------
- !! does not work with agrif
#if ! defined key_agrif
+ !! ==>> CAUTION: does not work with agrif
!!----------------------------------------------------------------------
!! dia_dct : Compute the transport through a sec.
@@ -66,6 +66,5 @@
TYPE SECTION
CHARACTER(len=60) :: name ! name of the sec
- LOGICAL :: llstrpond ! true if you want the computation of salt and
- ! heat transports
+ LOGICAL :: llstrpond ! true if you want the computation of salt and heat transports
LOGICAL :: ll_ice_section ! ice surface and ice volume computation
LOGICAL :: ll_date_line ! = T if the section crosses the date-line
@@ -74,9 +73,9 @@
INTEGER, DIMENSION(nb_point_max) :: direction ! vector direction of the point in the section
CHARACTER(len=40),DIMENSION(nb_class_max) :: classname ! characteristics of the class
- REAL(wp), DIMENSION(nb_class_max) :: zsigi ,&! in-situ density classes (99 if you don't want)
- zsigp ,&! potential density classes (99 if you don't want)
- zsal ,&! salinity classes (99 if you don't want)
- ztem ,&! temperature classes(99 if you don't want)
- zlay ! level classes (99 if you don't want)
+ REAL(wp), DIMENSION(nb_class_max) :: zsigi ! in-situ density classes (99 if you don't want)
+ REAL(wp), DIMENSION(nb_class_max) :: zsigp ! potential density classes (99 if you don't want)
+ REAL(wp), DIMENSION(nb_class_max) :: zsal ! salinity classes (99 if you don't want)
+ REAL(wp), DIMENSION(nb_class_max) :: ztem ! temperature classes(99 if you don't want)
+ REAL(wp), DIMENSION(nb_class_max) :: zlay ! level classes (99 if you don't want)
REAL(wp), DIMENSION(nb_type_class,nb_class_max) :: transport ! transport output
REAL(wp) :: slopeSection ! slope of the section
@@ -90,4 +89,7 @@
REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: transports_2d
+
+ !! * Substitutions
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -95,4 +97,5 @@
!! Software governed by the CeCILL license (see ./LICENSE)
!!----------------------------------------------------------------------
+
CONTAINS
@@ -409,7 +412,7 @@
ijloc=ijglo-njmpp+1 ! "
- !verify if the point is on the local domain:(1,nlei)*(1,nlej)
- IF( iiloc >= 1 .AND. iiloc <= nlei .AND. &
- ijloc >= 1 .AND. ijloc <= nlej )THEN
+ !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
@@ -516,6 +519,6 @@
!which coordinate shall we verify ?
- IF ( cdind=='I' )THEN ; itest=nlei ; iind=1
- ELSE IF ( cdind=='J' )THEN ; itest=nlej ; iind=2
+ IF ( cdind=='I' )THEN ; itest=Nie0 ; iind=1
+ ELSE IF ( cdind=='J' )THEN ; itest=Nje0 ; iind=2
ELSE ; CALL ctl_stop("removepoints :Wrong value for cdind")
ENDIF
@@ -1119,6 +1122,6 @@
!! | | | interpolation between ptab(I,J,K) and ptab(I,J,K+1)
!! | | | zbis =
- !! | | | [ e3w(I+1,J,K)*ptab(I,J,K) + ( e3w(I,J,K) - e3w(I+1,J,K) ) * ptab(I,J,K-1) ]
- !! | | | /[ e3w(I+1,J,K) + e3w(I,J,K) - e3w(I+1,J,K) ]
+ !! | | | [ e3w_n(I+1,J,K,NOW)*ptab(I,J,K) + ( e3w_n(I,J,K,NOW) - e3w_n(I+1,J,K,NOW) ) * ptab(I,J,K-1) ]
+ !! | | | /[ e3w_n(I+1,J,K,NOW) + e3w_n(I,J,K,NOW) - e3w_n(I+1,J,K,NOW) ]
!! | | |
!! | | | 2. Horizontal interpolation: compute value at U/V point
@@ -1213,6 +1216,8 @@
ze3t = e3t(ii2,ij2,kk,Kmm) - e3t(ii1,ij1,kk,Kmm)
- zwgt1 = ( e3w(ii2,ij2,kk,Kmm) - e3w(ii1,ij1,kk,Kmm) ) / e3w(ii2,ij2,kk,Kmm)
- zwgt2 = ( e3w(ii1,ij1,kk,Kmm) - e3w(ii2,ij2,kk,Kmm) ) / e3w(ii1,ij1,kk,Kmm)
+ zwgt1 = ( e3w(ii2,ij2,kk,Kmm) - e3w(ii1,ij1,kk,Kmm) ) &
+ & / e3w(ii2,ij2,kk,Kmm)
+ zwgt2 = ( e3w(ii1,ij1,kk,Kmm) - e3w(ii2,ij2,kk,Kmm) ) &
+ & / e3w(ii1,ij1,kk,Kmm)
IF(kk .NE. 1)THEN
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/DIA/diahsb.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/DIA/diahsb.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/DIA/diahsb.F90 (revision 13540)
@@ -50,4 +50,6 @@
REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: tmask_ini
+ !! * Substitutions
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -156,13 +158,16 @@
!
DO jk = 1, jpkm1 ! volume variation (calculated with scale factors)
- zwrk(:,:,jk) = surf(:,:)*e3t(:,:,jk,Kmm)*tmask(:,:,jk) - surf_ini(:,:)*e3t_ini(:,:,jk)*tmask_ini(:,:,jk)
+ zwrk(:,:,jk) = surf (:,:) * e3t (:,:,jk,Kmm)*tmask (:,:,jk) &
+ & - surf_ini(:,:) * e3t_ini(:,:,jk )*tmask_ini(:,:,jk)
END DO
zdiff_v2 = glob_sum_full( 'diahsb', zwrk(:,:,:) ) ! glob_sum_full needed as tmask and tmask_ini could be different
DO jk = 1, jpkm1 ! heat content variation
- zwrk(:,:,jk) = ( surf(:,:)*e3t(:,:,jk,Kmm)*ts(:,:,jk,jp_tem,Kmm) - surf_ini(:,:)*hc_loc_ini(:,:,jk) )
+ zwrk(:,:,jk) = ( surf (:,:) * e3t(:,:,jk,Kmm)*ts(:,:,jk,jp_tem,Kmm) &
+ & - surf_ini(:,:) * hc_loc_ini(:,:,jk) )
END DO
zdiff_hc = glob_sum_full( 'diahsb', zwrk(:,:,:) )
DO jk = 1, jpkm1 ! salt content variation
- zwrk(:,:,jk) = ( surf(:,:)*e3t(:,:,jk,Kmm)*ts(:,:,jk,jp_sal,Kmm) - surf_ini(:,:)*sc_loc_ini(:,:,jk) )
+ zwrk(:,:,jk) = ( surf (:,:) * e3t(:,:,jk,Kmm)*ts(:,:,jk,jp_sal,Kmm) &
+ & - surf_ini(:,:) * sc_loc_ini(:,:,jk) )
END DO
zdiff_sc = glob_sum_full( 'diahsb', zwrk(:,:,:) )
@@ -269,13 +274,13 @@
CALL iom_get( numror, 'frc_wn_s', frc_wn_s, ldxios = lrxios )
ENDIF
- CALL iom_get( numror, jpdom_autoglo, 'surf_ini' , surf_ini , ldxios = lrxios ) ! ice sheet coupling
- CALL iom_get( numror, jpdom_autoglo, 'ssh_ini' , ssh_ini , ldxios = lrxios )
- CALL iom_get( numror, jpdom_autoglo, 'e3t_ini' , e3t_ini , ldxios = lrxios )
- CALL iom_get( numror, jpdom_autoglo, 'tmask_ini' , tmask_ini , ldxios = lrxios )
- CALL iom_get( numror, jpdom_autoglo, 'hc_loc_ini', hc_loc_ini, ldxios = lrxios )
- CALL iom_get( numror, jpdom_autoglo, 'sc_loc_ini', sc_loc_ini, ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'surf_ini' , surf_ini , ldxios = lrxios ) ! ice sheet coupling
+ CALL iom_get( numror, jpdom_auto, 'ssh_ini' , ssh_ini , ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'e3t_ini' , e3t_ini , ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'tmask_ini' , tmask_ini , ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'hc_loc_ini', hc_loc_ini, ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'sc_loc_ini', sc_loc_ini, ldxios = lrxios )
IF( ln_linssh ) THEN
- CALL iom_get( numror, jpdom_autoglo, 'ssh_hc_loc_ini', ssh_hc_loc_ini, ldxios = lrxios )
- CALL iom_get( numror, jpdom_autoglo, 'ssh_sc_loc_ini', ssh_sc_loc_ini, ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'ssh_hc_loc_ini', ssh_hc_loc_ini, ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'ssh_sc_loc_ini', ssh_sc_loc_ini, ldxios = lrxios )
ENDIF
ELSE
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/DIA/diahth.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/DIA/diahth.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/DIA/diahth.F90 (revision 13540)
@@ -42,4 +42,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -129,5 +130,5 @@
zdepinv(:,:) = 0._wp
zmaxdzT(:,:) = 0._wp
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
zztmp = gdepw(ji,jj,mbkt(ji,jj)+1,Kmm)
hth (ji,jj) = zztmp
@@ -138,5 +139,5 @@
END_2D
IF( nla10 > 1 ) THEN
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
zztmp = gdepw(ji,jj,mbkt(ji,jj)+1,Kmm)
zrho0_3(ji,jj) = zztmp
@@ -147,5 +148,5 @@
! Preliminary computation
! computation of zdelr = (dr/dT)(T,S,10m)*(-0.2 degC)
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
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) &
@@ -169,5 +170,5 @@
! MLD: rho = rho(1) + zrho1 !
! ------------------------------------------------------------- !
- DO_3DS_11_11( jpkm1, 2, -1 )
+ DO_3DS( 1, 1, 1, 1, jpkm1, 2, -1 ) ! loop from bottom to 2
!
zzdep = gdepw(ji,jj,jk,Kmm)
@@ -206,5 +207,5 @@
! depth of temperature inversion !
! ------------------------------------------------------------- !
- DO_3DS_11_11( jpkm1, nlb10, -1 )
+ DO_3DS( 1, 1, 1, 1, jpkm1, nlb10, -1 ) ! loop from bottom to nlb10
!
zzdep = gdepw(ji,jj,jk,Kmm) * tmask(ji,jj,1)
@@ -304,5 +305,5 @@
! --------------------------------------- !
iktem(:,:) = 1
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 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
@@ -312,5 +313,5 @@
! Depth of ptem isotherm !
! ------------------------------- !
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
!
zzdep = gdepw(ji,jj,mbkt(ji,jj)+1,Kmm) ! depth of the ocean bottom
@@ -350,5 +351,5 @@
!
ilevel(:,:) = 1
- DO_3D_11_11( 2, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 2, jpkm1 )
IF( ( gdept(ji,jj,jk,Kmm) < pdep ) .AND. ( tmask(ji,jj,jk) == 1 ) ) THEN
ilevel(ji,jj) = jk
@@ -358,8 +359,9 @@
END_3D
!
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
ik = ilevel(ji,jj)
zthick(ji,jj) = pdep - zthick(ji,jj) ! remaining thickness to reach depht pdep
- phtc(ji,jj) = phtc(ji,jj) + pt(ji,jj,ik+1) * MIN( e3t(ji,jj,ik+1,Kmm), zthick(ji,jj) ) &
+ phtc(ji,jj) = phtc(ji,jj) &
+ & + pt (ji,jj,ik+1) * MIN( e3t(ji,jj,ik+1,Kmm), zthick(ji,jj) ) &
* tmask(ji,jj,ik+1)
END_2D
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/DIA/diamlr.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/DIA/diamlr.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/DIA/diamlr.F90 (revision 13540)
@@ -4,22 +4,24 @@
!! Management of the IOM context for multiple-linear-regression analysis
!!======================================================================
- !! History : ! 2019 (S. Mueller)
+ !! History : 4.0 ! 2019 (S. Mueller) Original code
!!----------------------------------------------------------------------
USE par_oce , ONLY : wp, jpi, jpj
USE phycst , ONLY : rpi
+ USE dom_oce , ONLY : adatrj
+ USE tide_mod
+ !
USE in_out_manager , ONLY : lwp, numout, ln_timing
USE iom , ONLY : iom_put, iom_use, iom_update_file_name
- USE dom_oce , ONLY : adatrj
USE timing , ONLY : timing_start, timing_stop
#if defined key_iomput
USE xios
#endif
- USE tide_mod
IMPLICIT NONE
PRIVATE
- LOGICAL, PUBLIC :: lk_diamlr = .FALSE.
+ LOGICAL, PUBLIC :: lk_diamlr = .FALSE. !: ===>>> NOT a DOCTOR norm name : use l_diamlr
+ ! lk_ is used only for logical controlled by a CPP key
PUBLIC :: dia_mlr_init, dia_mlr_iom_init, dia_mlr
@@ -42,7 +44,7 @@
!!
!!----------------------------------------------------------------------
-
+ !
lk_diamlr = .TRUE.
-
+ !
IF(lwp) THEN
WRITE(numout, *)
@@ -50,6 +52,7 @@
WRITE(numout, *) '~~~~~~~~~~~~ multiple-linear-regression analysis'
END IF
-
+ !
END SUBROUTINE dia_mlr_init
+
SUBROUTINE dia_mlr_iom_init
@@ -84,5 +87,5 @@
INTEGER :: itide ! Number of available tidal components
REAL(wp) :: ztide_phase ! Tidal-constituent phase at adatrj=0
- CHARACTER (LEN=4), DIMENSION(jpmax_harmo) :: ctide_selected = ' n/a '
+ CHARACTER (LEN=4), DIMENSION(jpmax_harmo) :: ctide_selected = 'n/a '
TYPE(tide_harmonic), DIMENSION(:), POINTER :: stideconst
@@ -145,11 +148,12 @@
! Retrieve information (frequency, phase, nodal correction) about all
! available tidal constituents for placeholder substitution below
- ctide_selected(1:34) = (/ 'Mf', 'Mm', 'Ssa', 'Mtm', 'Msf', &
- & 'Msqm', 'Sa', 'K1', 'O1', 'P1', &
- & 'Q1', 'J1', 'S1', 'M2', 'S2', 'N2', &
- & 'K2', 'nu2', 'mu2', '2N2', 'L2', &
- & 'T2', 'eps2', 'lam2', 'R2', 'M3', &
- & 'MKS2', 'MN4', 'MS4', 'M4', 'N4', &
- & 'S4', 'M6', 'M8' /)
+ ! Warning: we must use the same character length in an array constructor (at least for gcc compiler)
+ ctide_selected(1:34) = (/ 'Mf ', 'Mm ', 'Ssa ', 'Mtm ', 'Msf ', &
+ & 'Msqm', 'Sa ', 'K1 ', 'O1 ', 'P1 ', &
+ & 'Q1 ', 'J1 ', 'S1 ', 'M2 ', 'S2 ', 'N2 ', &
+ & 'K2 ', 'nu2 ', 'mu2 ', '2N2 ', 'L2 ', &
+ & 'T2 ', 'eps2', 'lam2', 'R2 ', 'M3 ', &
+ & 'MKS2', 'MN4 ', 'MS4 ', 'M4 ', 'N4 ', &
+ & 'S4 ', 'M6 ', 'M8 ' /)
CALL tide_init_harmonics(ctide_selected, stideconst)
itide = size(stideconst)
@@ -396,4 +400,5 @@
END SUBROUTINE dia_mlr_iom_init
+
SUBROUTINE dia_mlr
!!----------------------------------------------------------------------
@@ -403,6 +408,6 @@
!!
!!----------------------------------------------------------------------
-
REAL(wp), DIMENSION(jpi,jpj) :: zadatrj2d
+ !!----------------------------------------------------------------------
IF( ln_timing ) CALL timing_start('dia_mlr')
@@ -411,13 +416,13 @@
! (value of adatrj converted to time in units of seconds)
!
- ! 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.
+ ! 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
IF ( iom_use('diamlr_time') ) CALL iom_put('diamlr_time', zadatrj2d)
-
+ !
IF( ln_timing ) CALL timing_stop('dia_mlr')
-
+ !
END SUBROUTINE dia_mlr
+ !!======================================================================
END MODULE diamlr
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/DIA/diaptr.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/DIA/diaptr.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/DIA/diaptr.F90 (revision 13540)
@@ -60,6 +60,8 @@
LOGICAL :: ll_init = .TRUE. !: tracers trend flag (set from namelist in trdini)
+
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -117,5 +119,5 @@
zmask(:,:,:) = 0._wp
zts(:,:,:,:) = 0._wp
- DO_3D_10_11( 1, jpkm1 )
+ DO_3D( 1, 0, 1, 1, 1, jpkm1 )
zvfc = e1v(ji,jj) * e3v(ji,jj,jk,Kmm)
zmask(ji,jj,jk) = vmask(ji,jj,jk) * zvfc
@@ -188,5 +190,5 @@
zts(:,:,:,:) = 0._wp
IF( iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. iom_use( 'zosrf' ) ) THEN ! i-mean i-k-surface
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
zsfc = e1t(ji,jj) * e3t(ji,jj,jk,Kmm)
zmask(ji,jj,jk) = tmask(ji,jj,jk) * zsfc
@@ -278,5 +280,5 @@
IF( iom_use( 'sopstvtr' ) .OR. iom_use( 'sophtvtr' ) ) THEN
zts(:,:,:,:) = 0._wp
- DO_3D_10_11( 1, jpkm1 )
+ DO_3D( 1, 0, 1, 1, 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
@@ -353,7 +355,7 @@
btmsk(:,:,1) = tmask_i(:,:)
CALL iom_open( 'subbasins', inum, ldstop = .FALSE. )
- CALL iom_get( inum, jpdom_data, 'atlmsk', btmsk(:,:,2) ) ! Atlantic basin
- CALL iom_get( inum, jpdom_data, 'pacmsk', btmsk(:,:,3) ) ! Pacific basin
- CALL iom_get( inum, jpdom_data, 'indmsk', btmsk(:,:,4) ) ! Indian basin
+ CALL iom_get( inum, jpdom_global, 'atlmsk', btmsk(:,:,2) ) ! Atlantic basin
+ CALL iom_get( inum, jpdom_global, 'pacmsk', btmsk(:,:,3) ) ! Pacific basin
+ CALL iom_get( inum, jpdom_global, 'indmsk', btmsk(:,:,4) ) ! Indian basin
CALL iom_close( inum )
btmsk(:,:,5) = MAX ( btmsk(:,:,3), btmsk(:,:,4) ) ! Indo-Pacific basin
@@ -503,5 +505,5 @@
ijpj = jpj
p_fval(:) = 0._wp
- DO_3D_00_00( 1, jpkm1 )
+ 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
@@ -536,5 +538,5 @@
ijpj = jpj
p_fval(:) = 0._wp
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
p_fval(jj) = p_fval(jj) + pvflx(ji,jj) * pmsk(ji,jj) * tmask_i(ji,jj)
END_2D
@@ -565,8 +567,8 @@
p_fval(:,:) = 0._wp
DO jc = 1, jpnj ! looping over all processors in j axis
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
p_fval(ji,jj) = p_fval(ji,jj-1) + pva(ji,jj) * tmask_i(ji,jj)
END_2D
- CALL lbc_lnk( 'diaptr', p_fval, 'U', -1. )
+ CALL lbc_lnk( 'diaptr', p_fval, 'U', -1.0_wp )
END DO
!
@@ -604,5 +606,5 @@
p_fval(:,:) = 0._wp
!
- DO_3D_00_00( 1, jpkm1 )
+ 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
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/DIA/diawri.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/DIA/diawri.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/DIA/diawri.F90 (revision 13540)
@@ -85,4 +85,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -117,4 +118,5 @@
INTEGER :: ji, jj, jk ! dummy loop indices
INTEGER :: ikbot ! local integer
+ REAL(wp):: ze3
REAL(wp):: zztmp , zztmpx ! local scalar
REAL(wp):: zztmp2, zztmpy ! - -
@@ -136,13 +138,32 @@
CALL iom_put("e3v_0", e3v_0(:,:,:) )
!
- CALL iom_put( "e3t" , e3t(:,:,:,Kmm) )
- CALL iom_put( "e3u" , e3u(:,:,:,Kmm) )
- CALL iom_put( "e3v" , e3v(:,:,:,Kmm) )
- CALL iom_put( "e3w" , e3w(:,:,:,Kmm) )
- IF( iom_use("e3tdef") ) &
- CALL iom_put( "e3tdef" , ( ( e3t(:,:,:,Kmm) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 )
-
- IF( ll_wd ) THEN
- CALL iom_put( "ssh" , (ssh(:,:,Kmm)+ssh_ref)*tmask(:,:,1) ) ! sea surface height (brought back to the reference used for wetting and drying)
+ IF ( iom_use("e3t") .OR. iom_use("e3tdef") ) THEN ! time-varying e3t
+ DO jk = 1, jpk
+ z3d(:,:,jk) = e3t(:,:,jk,Kmm)
+ END DO
+ CALL iom_put( "e3t" , z3d(:,:,:) )
+ CALL iom_put( "e3tdef" , ( ( z3d(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 )
+ 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(:,:,:) )
+ 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(:,:,:) )
+ ENDIF
+ IF ( iom_use("e3w") ) THEN ! time-varying e3w
+ DO jk = 1, jpk
+ z3d(:,:,jk) = e3w(:,:,jk,Kmm)
+ END DO
+ CALL iom_put( "e3w" , z3d(:,:,:) )
+ ENDIF
+
+ IF( ll_wd ) THEN ! sea surface height (brought back to the reference used for wetting and drying)
+ CALL iom_put( "ssh" , (ssh(:,:,Kmm)+ssh_ref)*tmask(:,:,1) )
ELSE
CALL iom_put( "ssh" , ssh(:,:,Kmm) ) ! sea surface height
@@ -155,5 +176,5 @@
CALL iom_put( "sst", ts(:,:,1,jp_tem,Kmm) ) ! surface temperature
IF ( iom_use("sbt") ) THEN
- DO_2D_11_11
+ DO_2D( 0, 0, 0, 0 )
ikbot = mbkt(ji,jj)
z2d(ji,jj) = ts(ji,jj,ikbot,jp_tem,Kmm)
@@ -165,5 +186,5 @@
CALL iom_put( "sss", ts(:,:,1,jp_sal,Kmm) ) ! surface salinity
IF ( iom_use("sbs") ) THEN
- DO_2D_11_11
+ DO_2D( 0, 0, 0, 0 )
ikbot = mbkt(ji,jj)
z2d(ji,jj) = ts(ji,jj,ikbot,jp_sal,Kmm)
@@ -172,8 +193,12 @@
ENDIF
+#if ! defined key_qco
+ CALL iom_put( "rhop", rhop(:,:,:) ) ! 3D potential density (sigma0)
+#endif
+
IF ( iom_use("taubot") ) THEN ! bottom stress
zztmp = rho0 * 0.25
z2d(:,:) = 0._wp
- DO_2D_00_00
+ 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 &
@@ -183,5 +208,4 @@
!
END_2D
- CALL lbc_lnk( 'diawri', z2d, 'T', 1. )
CALL iom_put( "taubot", z2d )
ENDIF
@@ -190,5 +214,5 @@
CALL iom_put( "ssu", uu(:,:,1,Kmm) ) ! surface i-current
IF ( iom_use("sbu") ) THEN
- DO_2D_11_11
+ DO_2D( 0, 0, 0, 0 )
ikbot = mbku(ji,jj)
z2d(ji,jj) = uu(ji,jj,ikbot,Kmm)
@@ -200,5 +224,5 @@
CALL iom_put( "ssv", vv(:,:,1,Kmm) ) ! surface j-current
IF ( iom_use("sbv") ) THEN
- DO_2D_11_11
+ DO_2D( 0, 0, 0, 0 )
ikbot = mbkv(ji,jj)
z2d(ji,jj) = vv(ji,jj,ikbot,Kmm)
@@ -208,6 +232,6 @@
IF( ln_zad_Aimp ) ww = ww + wi ! Recombine explicit and implicit parts of vertical velocity for diagnostic output
- !
CALL iom_put( "woce", ww ) ! vertical velocity
+
IF( iom_use('w_masstr') .OR. iom_use('w_masstr2') ) THEN ! vertical mass transport & its square value
! Caution: in the VVL case, it only correponds to the baroclinic mass transport.
@@ -229,6 +253,22 @@
IF( iom_use('logavs') ) CALL iom_put( "logavs", LOG( MAX( 1.e-20_wp, avs(:,:,:) ) ) )
+ IF ( iom_use("socegrad") .OR. iom_use("socegrad2") ) THEN
+ z3d(:,:,jpk) = 0.
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ zztmp = ts(ji,jj,jk,jp_sal,Kmm)
+ zztmpx = (ts(ji+1,jj,jk,jp_sal,Kmm) - zztmp) * r1_e1u(ji,jj) + (zztmp - ts(ji-1,jj ,jk,jp_sal,Kmm)) * r1_e1u(ji-1,jj)
+ zztmpy = (ts(ji,jj+1,jk,jp_sal,Kmm) - zztmp) * r1_e2v(ji,jj) + (zztmp - ts(ji ,jj-1,jk,jp_sal,Kmm)) * r1_e2v(ji,jj-1)
+ z3d(ji,jj,jk) = 0.25 * ( zztmpx * zztmpx + zztmpy * zztmpy ) &
+ & * umask(ji,jj,jk) * umask(ji-1,jj,jk) * vmask(ji,jj,jk) * umask(ji,jj-1,jk)
+ END_3D
+ CALL iom_put( "socegrad2", z3d ) ! square of module of sal gradient
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ z3d(ji,jj,jk) = SQRT( z3d(ji,jj,jk) )
+ END_3D
+ CALL iom_put( "socegrad" , z3d ) ! module of sal gradient
+ ENDIF
+
IF ( iom_use("sstgrad") .OR. iom_use("sstgrad2") ) THEN
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 ) ! sst gradient
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)
@@ -237,7 +277,8 @@
& * umask(ji,jj,1) * umask(ji-1,jj,1) * vmask(ji,jj,1) * umask(ji,jj-1,1)
END_2D
- CALL lbc_lnk( 'diawri', z2d, 'T', 1. )
CALL iom_put( "sstgrad2", z2d ) ! square of module of sst gradient
- z2d(:,:) = SQRT( z2d(:,:) )
+ DO_2D( 0, 0, 0, 0 )
+ z2d(ji,jj) = SQRT( z2d(ji,jj) )
+ END_2D
CALL iom_put( "sstgrad" , z2d ) ! module of sst gradient
ENDIF
@@ -246,5 +287,5 @@
IF( iom_use("heatc") ) THEN
z2d(:,:) = 0._wp
- DO_3D_11_11( 1, jpkm1 )
+ 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)
END_3D
@@ -254,5 +295,5 @@
IF( iom_use("saltc") ) THEN
z2d(:,:) = 0._wp
- DO_3D_11_11( 1, jpkm1 )
+ 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)
END_3D
@@ -260,18 +301,55 @@
ENDIF
!
- IF ( iom_use("eken") ) THEN
+ IF( iom_use("salt2c") ) THEN
+ z2d(:,:) = 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)
+ END_3D
+ CALL iom_put( "salt2c", rho0 * z2d ) ! vertically integrated salt content (PSU*kg/m2)
+ ENDIF
+ !
+ IF ( iom_use("ke") .OR. iom_use("ke_int") ) THEN
z3d(:,:,jpk) = 0._wp
- DO_3D_00_00( 1, jpkm1 )
- zztmp = 0.25_wp * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm)
- z3d(ji,jj,jk) = zztmp * ( uu(ji-1,jj,jk,Kmm)**2 * e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm) &
- & + uu(ji ,jj,jk,Kmm)**2 * e2u(ji ,jj) * e3u(ji ,jj,jk,Kmm) &
- & + vv(ji,jj-1,jk,Kmm)**2 * e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) &
- & + vv(ji,jj ,jk,Kmm)**2 * e1v(ji,jj ) * e3v(ji,jj ,jk,Kmm) )
- END_3D
- CALL lbc_lnk( 'diawri', z3d, 'T', 1. )
- CALL iom_put( "eken", z3d ) ! kinetic energy
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ zztmpx = 0.5 * ( uu(ji-1,jj ,jk,Kmm) + uu(ji,jj,jk,Kmm) )
+ zztmpy = 0.5 * ( vv(ji ,jj-1,jk,Kmm) + vv(ji,jj,jk,Kmm) )
+ z3d(ji,jj,jk) = 0.5 * ( zztmpx*zztmpx + zztmpy*zztmpy )
+ END_3D
+ CALL iom_put( "ke", z3d ) ! kinetic energy
+
+ z2d(:,:) = 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)
+ END_3D
+ CALL iom_put( "ke_int", z2d ) ! vertically integrated kinetic energy
ENDIF
!
CALL iom_put( "hdiv", hdiv ) ! Horizontal divergence
+
+ IF ( iom_use("relvor") .OR. iom_use("absvor") .OR. iom_use("potvor") ) THEN
+
+ z3d(:,:,jpk) = 0._wp
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ z3d(ji,jj,jk) = ( e2v(ji+1,jj ) * vv(ji+1,jj ,jk,Kmm) - e2v(ji,jj) * vv(ji,jj,jk,Kmm) &
+ & - e1u(ji ,jj+1) * uu(ji ,jj+1,jk,Kmm) + e1u(ji,jj) * uu(ji,jj,jk,Kmm) ) * r1_e1e2f(ji,jj)
+ END_3D
+ CALL iom_put( "relvor", z3d ) ! relative vorticity
+
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ z3d(ji,jj,jk) = ff_f(ji,jj) + z3d(ji,jj,jk)
+ END_3D
+ CALL iom_put( "absvor", z3d ) ! absolute vorticity
+
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ ze3 = ( 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) )
+ IF( ze3 /= 0._wp ) THEN ; ze3 = 4._wp / ze3
+ ELSE ; ze3 = 0._wp
+ ENDIF
+ z3d(ji,jj,jk) = ze3 * z3d(ji,jj,jk)
+ END_3D
+ CALL iom_put( "potvor", z3d ) ! potential vorticity
+
+ ENDIF
!
IF( iom_use("u_masstr") .OR. iom_use("u_masstr_vint") .OR. iom_use("u_heattr") .OR. iom_use("u_salttr") ) THEN
@@ -288,8 +366,7 @@
IF( iom_use("u_heattr") ) THEN
z2d(:,:) = 0._wp
- DO_3D_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( ts(ji,jj,jk,jp_tem,Kmm) + ts(ji+1,jj,jk,jp_tem,Kmm) )
END_3D
- CALL lbc_lnk( 'diawri', z2d, 'U', -1. )
CALL iom_put( "u_heattr", 0.5*rcp * z2d ) ! heat transport in i-direction
ENDIF
@@ -297,8 +374,7 @@
IF( iom_use("u_salttr") ) THEN
z2d(:,:) = 0.e0
- DO_3D_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( ts(ji,jj,jk,jp_sal,Kmm) + ts(ji+1,jj,jk,jp_sal,Kmm) )
END_3D
- CALL lbc_lnk( 'diawri', z2d, 'U', -1. )
CALL iom_put( "u_salttr", 0.5 * z2d ) ! heat transport in i-direction
ENDIF
@@ -315,8 +391,7 @@
IF( iom_use("v_heattr") ) THEN
z2d(:,:) = 0.e0
- DO_3D_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( ts(ji,jj,jk,jp_tem,Kmm) + ts(ji,jj+1,jk,jp_tem,Kmm) )
END_3D
- CALL lbc_lnk( 'diawri', z2d, 'V', -1. )
CALL iom_put( "v_heattr", 0.5*rcp * z2d ) ! heat transport in j-direction
ENDIF
@@ -324,8 +399,7 @@
IF( iom_use("v_salttr") ) THEN
z2d(:,:) = 0._wp
- DO_3D_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( ts(ji,jj,jk,jp_sal,Kmm) + ts(ji,jj+1,jk,jp_sal,Kmm) )
END_3D
- CALL lbc_lnk( 'diawri', z2d, 'V', -1. )
CALL iom_put( "v_salttr", 0.5 * z2d ) ! heat transport in j-direction
ENDIF
@@ -333,16 +407,14 @@
IF( iom_use("tosmint") ) THEN
z2d(:,:) = 0._wp
- DO_3D_00_00( 1, jpkm1 )
+ 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)
END_3D
- CALL lbc_lnk( 'diawri', z2d, 'T', -1. )
CALL iom_put( "tosmint", rho0 * z2d ) ! Vertical integral of temperature
ENDIF
IF( iom_use("somint") ) THEN
z2d(:,:)=0._wp
- DO_3D_00_00( 1, jpkm1 )
+ 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)
END_3D
- CALL lbc_lnk( 'diawri', z2d, 'T', -1. )
CALL iom_put( "somint", rho0 * z2d ) ! Vertical integral of salinity
ENDIF
@@ -415,5 +487,5 @@
!
REAL(wp), DIMENSION(jpi,jpj) :: zw2d ! 2D workspace
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zw3d ! 3D workspace
+ REAL(wp), DIMENSION(jpi,jpj,jpk) :: zw3d, ze3t, zgdept ! 3D workspace
REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zw3d_abl ! ABL 3D workspace
!!----------------------------------------------------------------------
@@ -447,6 +519,6 @@
! Define indices of the horizontal output zoom and vertical limit storage
- iimi = 1 ; iima = jpi
- ijmi = 1 ; ijma = jpj
+ iimi = Nis0 ; iima = Nie0
+ ijmi = Njs0 ; ijma = Nje0
ipk = jpk
IF(ln_abl) ipka = jpkam1
@@ -455,4 +527,10 @@
it = kt
itmod = kt - nit000 + 1
+
+ ! store e3t for subsitute
+ DO jk = 1, jpk
+ ze3t (:,:,jk) = e3t (:,:,jk,Kmm)
+ zgdept(:,:,jk) = gdept(:,:,jk,Kmm)
+ END DO
@@ -569,4 +647,5 @@
DEALLOCATE(zw3d_abl)
ENDIF
+ !
! Declare all the output fields as NETCDF variables
@@ -578,9 +657,9 @@
& jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout )
IF( .NOT.ln_linssh ) THEN
- CALL histdef( nid_T, "vovvle3t", "Level thickness" , "m" ,& ! e3t(:,:,:,Kmm)
+ CALL histdef( nid_T, "vovvle3t", "Level thickness" , "m" ,& ! e3t n
& jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout )
- CALL histdef( nid_T, "vovvldep", "T point depth" , "m" ,& ! e3t(:,:,:,Kmm)
+ CALL histdef( nid_T, "vovvldep", "T point depth" , "m" ,& ! e3t n
& jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout )
- CALL histdef( nid_T, "vovvldef", "Squared level deformation" , "%^2" ,& ! e3t(:,:,:,Kmm)
+ CALL histdef( nid_T, "vovvldef", "Squared level deformation" , "%^2" ,& ! e3t n
& jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout )
ENDIF
@@ -766,8 +845,8 @@
IF( .NOT.ln_linssh ) THEN
- CALL histwrite( nid_T, "votemper", it, ts(:,:,:,jp_tem,Kmm) * e3t(:,:,:,Kmm) , ndim_T , ndex_T ) ! heat content
- CALL histwrite( nid_T, "vosaline", it, ts(:,:,:,jp_sal,Kmm) * e3t(:,:,:,Kmm) , ndim_T , ndex_T ) ! salt content
- CALL histwrite( nid_T, "sosstsst", it, ts(:,:,1,jp_tem,Kmm) * e3t(:,:,1,Kmm) , ndim_hT, ndex_hT ) ! sea surface heat content
- CALL histwrite( nid_T, "sosaline", it, ts(:,:,1,jp_sal,Kmm) * e3t(:,:,1,Kmm) , ndim_hT, ndex_hT ) ! sea surface salinity content
+ CALL histwrite( nid_T, "votemper", it, ts(:,:,:,jp_tem,Kmm) * ze3t(:,:,:) , ndim_T , ndex_T ) ! heat content
+ CALL histwrite( nid_T, "vosaline", it, ts(:,:,:,jp_sal,Kmm) * ze3t(:,:,:) , ndim_T , ndex_T ) ! salt content
+ CALL histwrite( nid_T, "sosstsst", it, ts(:,:,1,jp_tem,Kmm) * ze3t(:,:,1) , ndim_hT, ndex_hT ) ! sea surface heat content
+ CALL histwrite( nid_T, "sosaline", it, ts(:,:,1,jp_sal,Kmm) * ze3t(:,:,1) , ndim_hT, ndex_hT ) ! sea surface salinity content
ELSE
CALL histwrite( nid_T, "votemper", it, ts(:,:,:,jp_tem,Kmm) , ndim_T , ndex_T ) ! temperature
@@ -777,7 +856,7 @@
ENDIF
IF( .NOT.ln_linssh ) THEN
- zw3d(:,:,:) = ( ( e3t(:,:,:,Kmm) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2
- CALL histwrite( nid_T, "vovvle3t", it, e3t (:,:,:,Kmm) , ndim_T , ndex_T ) ! level thickness
- CALL histwrite( nid_T, "vovvldep", it, gdept(:,:,:,Kmm) , ndim_T , ndex_T ) ! t-point depth
+ zw3d(:,:,:) = ( ( ze3t(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2
+ CALL histwrite( nid_T, "vovvle3t", it, ze3t (:,:,:) , ndim_T , ndex_T ) ! level thickness
+ CALL histwrite( nid_T, "vovvldep", it, zgdept , ndim_T , ndex_T ) ! t-point depth
CALL histwrite( nid_T, "vovvldef", it, zw3d , ndim_T , ndex_T ) ! level thickness deformation
ENDIF
@@ -918,17 +997,21 @@
!!
INTEGER :: inum, jk
+ REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t, zgdept ! 3D workspace !!st patch to use substitution
!!----------------------------------------------------------------------
!
- IF(lwp) WRITE(numout,*)
- IF(lwp) WRITE(numout,*) 'dia_wri_state : single instantaneous ocean state'
- IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~ and forcing fields file created '
- IF(lwp) WRITE(numout,*) ' and named :', cdfile_name, '...nc'
-
-#if defined key_si3
- CALL iom_open( TRIM(cdfile_name), inum, ldwrt = .TRUE., kdlev = jpl )
-#else
- CALL iom_open( TRIM(cdfile_name), inum, ldwrt = .TRUE. )
-#endif
-
+ IF(lwp) THEN
+ WRITE(numout,*)
+ WRITE(numout,*) 'dia_wri_state : single instantaneous ocean state'
+ WRITE(numout,*) '~~~~~~~~~~~~~ and forcing fields file created '
+ WRITE(numout,*) ' and named :', cdfile_name, '...nc'
+ ENDIF
+ !
+ DO jk = 1, jpk
+ ze3t(:,:,jk) = e3t(:,:,jk,Kmm)
+ zgdept(:,:,jk) = gdept(:,:,jk,Kmm)
+ END DO
+ !
+ CALL iom_open( TRIM(cdfile_name), inum, ldwrt = .TRUE. )
+ !
CALL iom_rstput( 0, 0, inum, 'votemper', ts(:,:,:,jp_tem,Kmm) ) ! now temperature
CALL iom_rstput( 0, 0, inum, 'vosaline', ts(:,:,:,jp_sal,Kmm) ) ! now salinity
@@ -942,6 +1025,6 @@
ENDIF
CALL iom_rstput( 0, 0, inum, 'risfdep', risfdep ) ! now k-velocity
- CALL iom_rstput( 0, 0, inum, 'ht' , ht ) ! now water column height
-
+ CALL iom_rstput( 0, 0, inum, 'ht' , ht(:,:) ) ! now water column height
+ !
IF ( ln_isf ) THEN
IF (ln_isfcav_mlt) THEN
@@ -949,19 +1032,19 @@
CALL iom_rstput( 0, 0, inum, 'rhisf_cav_tbl', rhisf_tbl_cav ) ! now k-velocity
CALL iom_rstput( 0, 0, inum, 'rfrac_cav_tbl', rfrac_tbl_cav ) ! now k-velocity
- CALL iom_rstput( 0, 0, inum, 'misfkb_cav', REAL(misfkb_cav,8) ) ! now k-velocity
- CALL iom_rstput( 0, 0, inum, 'misfkt_cav', REAL(misfkt_cav,8) ) ! now k-velocity
- CALL iom_rstput( 0, 0, inum, 'mskisf_cav', REAL(mskisf_cav,8), ktype = jp_i1 )
+ CALL iom_rstput( 0, 0, inum, 'misfkb_cav', REAL(misfkb_cav,wp) ) ! now k-velocity
+ CALL iom_rstput( 0, 0, inum, 'misfkt_cav', REAL(misfkt_cav,wp) ) ! now k-velocity
+ CALL iom_rstput( 0, 0, inum, 'mskisf_cav', REAL(mskisf_cav,wp), ktype = jp_i1 )
END IF
IF (ln_isfpar_mlt) THEN
- CALL iom_rstput( 0, 0, inum, 'isfmsk_par', REAL(mskisf_par,8) ) ! now k-velocity
+ CALL iom_rstput( 0, 0, inum, 'isfmsk_par', REAL(mskisf_par,wp) ) ! now k-velocity
CALL iom_rstput( 0, 0, inum, 'fwfisf_par', fwfisf_par ) ! now k-velocity
CALL iom_rstput( 0, 0, inum, 'rhisf_par_tbl', rhisf_tbl_par ) ! now k-velocity
CALL iom_rstput( 0, 0, inum, 'rfrac_par_tbl', rfrac_tbl_par ) ! now k-velocity
- CALL iom_rstput( 0, 0, inum, 'misfkb_par', REAL(misfkb_par,8) ) ! now k-velocity
- CALL iom_rstput( 0, 0, inum, 'misfkt_par', REAL(misfkt_par,8) ) ! now k-velocity
- CALL iom_rstput( 0, 0, inum, 'mskisf_par', REAL(mskisf_par,8), ktype = jp_i1 )
+ CALL iom_rstput( 0, 0, inum, 'misfkb_par', REAL(misfkb_par,wp) ) ! now k-velocity
+ CALL iom_rstput( 0, 0, inum, 'misfkt_par', REAL(misfkt_par,wp) ) ! now k-velocity
+ CALL iom_rstput( 0, 0, inum, 'mskisf_par', REAL(mskisf_par,wp), ktype = jp_i1 )
END IF
END IF
-
+ !
IF( ALLOCATED(ahtu) ) THEN
CALL iom_rstput( 0, 0, inum, 'ahtu', ahtu ) ! aht at u-point
@@ -979,6 +1062,6 @@
CALL iom_rstput( 0, 0, inum, 'sometauy', vtau ) ! j-wind stress
IF( .NOT.ln_linssh ) THEN
- CALL iom_rstput( 0, 0, inum, 'vovvldep', gdept(:,:,:,Kmm) ) ! T-cell depth
- CALL iom_rstput( 0, 0, inum, 'vovvle3t', e3t(:,:,:,Kmm) ) ! T-cell thickness
+ CALL iom_rstput( 0, 0, inum, 'vovvldep', zgdept ) ! T-cell depth
+ CALL iom_rstput( 0, 0, inum, 'vovvle3t', ze3t ) ! T-cell thickness
END IF
IF( ln_wave .AND. ln_sdw ) THEN
@@ -993,13 +1076,15 @@
CALL iom_rstput ( 0, 0, inum, "qz1_abl", tq_abl(:,:,2,nt_a,2) ) ! now first level humidity
ENDIF
-
+ !
+ CALL iom_close( inum )
+ !
#if defined key_si3
IF( nn_ice == 2 ) THEN ! condition needed in case agrif + ice-model but no-ice in child grid
+ CALL iom_open( TRIM(cdfile_name)//'_ice', inum, ldwrt = .TRUE., kdlev = jpl, cdcomp = 'ICE' )
CALL ice_wri_state( inum )
- ENDIF
+ CALL iom_close( inum )
+ ENDIF
+ !
#endif
- !
- CALL iom_close( inum )
- !
END SUBROUTINE dia_wri_state
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/DIU/diu_bulk.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/DIU/diu_bulk.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/DIU/diu_bulk.F90 (revision 13540)
@@ -130,5 +130,5 @@
! If not done already, calculate the solar fraction
IF ( kt==nit000 ) THEN
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
IF( ( x_solfrac(ji,jj) == 0._wp ) .AND. ( tmask(ji,jj,1) == 1._wp ) ) &
& x_solfrac(ji,jj) = solfrac( zcoolthick(ji,jj),zthick(ji,jj) )
@@ -199,5 +199,5 @@
INTEGER :: ji,jj
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
! Only calculate outside tmask
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/DIU/diu_coolskin.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/DIU/diu_coolskin.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/DIU/diu_coolskin.F90 (revision 13540)
@@ -97,5 +97,5 @@
IF( .NOT. ln_blk ) CALL ctl_stop("diu_coolskin.f90: diurnal flux processing only implemented for bulk forcing")
!
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
!
! Calcualte wind speed from wind stress and friction velocity
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/DOM/closea.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/DOM/closea.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/DOM/closea.F90 (revision 13540)
@@ -22,5 +22,5 @@
!
USE diu_bulk , ONLY: ln_diurnal_only ! used for sanity check
- USE iom , ONLY: iom_open, iom_get, iom_close, jpdom_data ! I/O routines
+ USE iom , ONLY: iom_open, iom_get, iom_close, jpdom_global ! I/O routines
USE lib_fortran , ONLY: glob_sum ! fortran library
USE lib_mpp , ONLY: mpp_max, ctl_nam, ctl_stop ! MPP library
@@ -236,5 +236,5 @@
!
CALL iom_open ( cd_file, ics )
- CALL iom_get ( ics, jpdom_data, TRIM(cd_var), zdta )
+ CALL iom_get ( ics, jpdom_global, TRIM(cd_var), zdta )
CALL iom_close( ics )
k_mskout(:,:) = NINT(zdta(:,:))
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/DOM/daymod.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/DOM/daymod.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/DOM/daymod.F90 (revision 13540)
@@ -115,5 +115,5 @@
!compute number of days between last Monday and today
- CALL ymds2ju( 1900, 01, 01, 0.0, zjul ) ! compute julian day value of 01.01.1900 (our reference that was a Monday)
+ CALL ymds2ju( 1900, 01, 01, 0.0_wp, zjul ) ! compute julian day value of 01.01.1900 (our reference that was a Monday)
inbday = FLOOR(fjulday - zjul) ! compute nb day between 01.01.1900 and start of current day
imonday = MOD(inbday, 7) ! compute nb day between last monday and current day
@@ -267,5 +267,5 @@
!
!compute first day of the year in julian days
- CALL ymds2ju( nyear, 01, 01, 0.0, fjulstartyear )
+ CALL ymds2ju( nyear, 01, 01, 0.0_wp, fjulstartyear )
!
IF(lwp) WRITE(numout,'(a,i8,a,i4.4,a,i2.2,a,i2.2,a,i3.3)') '======>> time-step =', kt, &
@@ -279,5 +279,5 @@
IF(sn_cfctl%l_prtctl) THEN
WRITE(charout,FMT="('kt =', I4,' d/m/y =',I2,I2,I4)") kt, nday, nmonth, nyear
- CALL prt_ctl_info(charout)
+ CALL prt_ctl_info( charout )
ENDIF
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/DOM/dom_oce.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/DOM/dom_oce.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/DOM/dom_oce.F90 (revision 13540)
@@ -2,5 +2,4 @@
!!======================================================================
!! *** MODULE dom_oce ***
- !!
!! ** Purpose : Define in memory all the ocean space domain variables
!!======================================================================
@@ -13,8 +12,10 @@
!! - ! 2015-11 (G. Madec, A. Coward) time varying zgr by default
!! 4.1 ! 2019-08 (A. Coward, D. Storkey) rename prognostic variables in preparation for new time scheme.
+ !! 4.x ! 2020-02 (G. Madec, S. Techene) introduce ssh to h0 ratio
!!----------------------------------------------------------------------
!!----------------------------------------------------------------------
!! Agrif_Root : dummy function used when lk_agrif=F
+ !! Agrif_Fixed : dummy function used when lk_agrif=F
!! Agrif_CFixed : dummy function used when lk_agrif=F
!! dom_oce_alloc : dynamical allocation of dom_oce arrays
@@ -73,7 +74,6 @@
LOGICAL, PUBLIC :: l_Iperio, l_Jperio ! should we explicitely take care I/J periodicity
- ! ! domain MPP decomposition parameters
+ ! !: domain MPP decomposition parameters
INTEGER , PUBLIC :: nimpp, njmpp !: i- & j-indexes for mpp-subdomain left bottom
- INTEGER , PUBLIC :: nreci, nrecj !: overlap region in i and j
INTEGER , PUBLIC :: nproc !: number for local processor
INTEGER , PUBLIC :: narea !: number for local area
@@ -85,22 +85,24 @@
INTEGER, PUBLIC :: npolj !: north fold mark (0, 3 or 4)
- INTEGER, PUBLIC :: nlci, nldi, nlei !: i-dimensions of the local subdomain and its first and last indoor indices
- INTEGER, PUBLIC :: nlcj, nldj, nlej !: i-dimensions of the local subdomain and its first and last indoor indices
INTEGER, PUBLIC :: noea, nowe !: index of the local neighboring processors in
INTEGER, PUBLIC :: noso, nono !: east, west, south and north directions
INTEGER, PUBLIC :: nidom !: ???
- INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mig !: local ==> global domain i-index
- INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mjg !: local ==> global domain j-index
- INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mi0, mi1 !: global ==> local domain i-index (mi0=1 and mi1=0 if the global index
- ! ! is not in the local domain)
- INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mj0, mj1 !: global ==> local domain j-index (mj0=1 and mj1=0 if the global index
- ! ! is not in the local domain)
- INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nimppt, njmppt !: i-, j-indexes for each processor
- INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ibonit, ibonjt !: i-, j- processor neighbour existence
- INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nlcit , nlcjt !: dimensions of every subdomain
- INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nldit , nldjt !: first, last indoor index for each i-domain
- INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nleit , nlejt !: first, last indoor index for each j-domain
- INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: nfiimpp, nfipproc, nfilcit
+ 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(:) :: mig0_oldcmp !: local ==> global domain, excluding halos (Ni0glo), i-index
+ INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mjg0_oldcmp !: local ==> global domain, excluding halos (Nj0glo), j-index
+ INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mi0, mi1 !: global, including halos (jpiglo) ==> 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
+ ! !: (mj0=1 and mj1=0 if global index not in local domain)
+ INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nimppt, njmppt !: i-, j-indexes for each processor
+ INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ibonit, ibonjt !: i-, j- processor neighbour existence
+ INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: jpiall, jpjall !: dimensions of all subdomain
+ INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nis0all, njs0all !: first, last indoor index for all i-subdomain
+ INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nie0all, nje0all !: first, last indoor index for all j-subdomain
+ INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nfimpp, nfproc, nfjpi
!!----------------------------------------------------------------------
@@ -115,6 +117,6 @@
!
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(:,:) :: e1e2u , e2_e1u, r1_e1e2u !: associated metrics at u-point
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2v , e1_e2v, r1_e1e2v !: associated metrics at v-point
REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2f , r1_e1e2f !: associated metrics at f-point
!
@@ -136,6 +138,12 @@
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3vw_0 !: vw-vert. scale factor [m]
! ! time-dependent scale factors
+#if ! defined key_qco
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]
+#endif
+ ! ! time-dependent ratio ssh / h_0
+ 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
@@ -147,11 +155,15 @@
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gde3w
- ! ! reference heights of water column
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ht_0 !: t-depth [m]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hu_0 !: u-depth [m]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hv_0 !: v-depth [m]
- ! time-dependent heights of water column
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ht !: height of water column at T-points [m]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hu, hv, r1_hu, r1_hv !: height of water column [m] and reciprocal [1/m]
+ ! ! 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
+#if ! defined key_qco
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ht !: t-points [m]
+#endif
+ 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]
INTEGER, PUBLIC :: nla10 !: deepest W level Above ~10m (nlb10 - 1)
@@ -169,6 +181,6 @@
!! ---------------------------------------------------------------------
!!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-, V-, F-level (ISF)
-! INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mbk_t, mbk_u, mbk_v !: bottom last wet T-, U- and V-level
+! 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
!!gm
INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mbkt, mbku, mbkv !: bottom last wet T-, U- and V-level
@@ -176,11 +188,9 @@
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tmask_h !: internal domain T-point mask (Figure 8.5 NEMO book)
- INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mikt, miku, mikv, mikf !: top first wet T-, U-, V-, F-level (ISF)
-
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ssmask, ssumask, ssvmask !: surface mask at T-,U-, V- and F-pts
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: tmask, umask, vmask, fmask !: land/ocean mask at T-, U-, V- and F-pts
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: wmask, wumask, wvmask !: land/ocean mask at WT-, WU- and WV-pts
-
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: tpol, fpol !: north fold mask (jperio= 3 or 4)
+ INTEGER , PUBLIC, ALLOCATABLE, SAVE, 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 WT-, WU- and WV-pts
!!----------------------------------------------------------------------
@@ -214,4 +224,5 @@
#if defined key_agrif
LOGICAL, PUBLIC, PARAMETER :: lk_agrif = .TRUE. !: agrif flag
+ LOGICAL, PUBLIC :: lk_south, lk_north, lk_west, lk_east !: Child grid boundaries (interpolation or not)
#else
LOGICAL, PUBLIC, PARAMETER :: lk_agrif = .FALSE. !: agrif flag
@@ -233,4 +244,8 @@
END FUNCTION Agrif_Root
+ INTEGER FUNCTION Agrif_Fixed()
+ Agrif_Fixed = 0
+ END FUNCTION Agrif_Fixed
+
CHARACTER(len=3) FUNCTION Agrif_CFixed()
Agrif_CFixed = '0'
@@ -240,13 +255,16 @@
INTEGER FUNCTION dom_oce_alloc()
!!----------------------------------------------------------------------
- INTEGER, DIMENSION(12) :: ierr
+ INTEGER :: ii
+ INTEGER, DIMENSION(30) :: ierr
!!----------------------------------------------------------------------
- ierr(:) = 0
+ ii = 0 ; ierr(:) = 0
!
- ALLOCATE( mig(jpi), mjg(jpj), STAT=ierr(1) )
- !
- ALLOCATE( mi0(jpiglo) , mi1 (jpiglo), mj0(jpjglo) , mj1 (jpjglo) , &
- & tpol(jpiglo) , fpol(jpiglo) , STAT=ierr(2) )
- !
+ ii = ii+1
+ ALLOCATE( mig(jpi), mjg(jpj), mig0(jpi), mjg0(jpj), mig0_oldcmp(jpi), mjg0_oldcmp(jpj), STAT=ierr(ii) )
+ !
+ ii = ii+1
+ ALLOCATE( mi0(jpiglo), mi1(jpiglo), mj0(jpjglo), mj1(jpjglo), STAT=ierr(ii) )
+ !
+ ii = ii+1
ALLOCATE( glamt(jpi,jpj) , glamu(jpi,jpj) , glamv(jpi,jpj) , glamf(jpi,jpj) , &
& gphit(jpi,jpj) , gphiu(jpi,jpj) , gphiv(jpi,jpj) , gphif(jpi,jpj) , &
@@ -259,32 +277,58 @@
& 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(3) )
- !
+ & ff_f (jpi,jpj) , ff_t (jpi,jpj) , STAT=ierr(ii) )
+ !
+ ii = ii+1
ALLOCATE( gdept_0(jpi,jpj,jpk) , gdepw_0(jpi,jpj,jpk) , gde3w_0(jpi,jpj,jpk) , &
- & gdept (jpi,jpj,jpk,jpt) , gdepw (jpi,jpj,jpk,jpt) , gde3w (jpi,jpj,jpk) , STAT=ierr(4) )
- !
- 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) , &
- & 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_0(jpi,jpj,jpk) , e3vw_0(jpi,jpj,jpk) , &
- & e3uw (jpi,jpj,jpk,jpt) , e3vw (jpi,jpj,jpk,jpt) , STAT=ierr(5) )
- !
- ALLOCATE( ht_0(jpi,jpj) , hu_0(jpi,jpj) , hv_0(jpi,jpj) , &
- & ht (jpi,jpj) , hu( jpi,jpj,jpt), hv( jpi,jpj,jpt) , r1_hu(jpi,jpj,jpt) , r1_hv(jpi,jpj,jpt) , &
- & STAT=ierr(6) )
- !
- ALLOCATE( risfdep(jpi,jpj) , bathy(jpi,jpj) , STAT=ierr(7) )
- !
- ALLOCATE( gdept_1d(jpk) , gdepw_1d(jpk) , e3t_1d(jpk) , e3w_1d(jpk) , STAT=ierr(8) )
- !
+ & gdept (jpi,jpj,jpk,jpt) , gdepw (jpi,jpj,jpk,jpt) , gde3w (jpi,jpj,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) , STAT=ierr(ii) )
+ !
+#if ! defined key_qco
+ 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) )
+#endif
+ !
+ 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) )
+ !
+ 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
+ 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) )
+#else
+ ii = ii+1
+ ALLOCATE( hu (jpi,jpj,jpt), hv (jpi,jpj,jpt) , &
+ & r1_hu (jpi,jpj,jpt), r1_hv (jpi,jpj,jpt) , STAT=ierr(ii) )
+#endif
+ !
+ ii = ii+1
+ ALLOCATE( risfdep(jpi,jpj) , bathy(jpi,jpj) , STAT=ierr(ii) )
+ !
+ ii = ii+1
+ ALLOCATE( gdept_1d(jpk) , gdepw_1d(jpk) , e3t_1d(jpk) , e3w_1d(jpk) , STAT=ierr(ii) )
+ !
+ ii = ii+1
ALLOCATE( tmask_i(jpi,jpj) , tmask_h(jpi,jpj) , &
- & ssmask (jpi,jpj) , ssumask(jpi,jpj) , ssvmask(jpi,jpj) , &
- & mbkt (jpi,jpj) , mbku (jpi,jpj) , mbkv (jpi,jpj) , STAT=ierr(9) )
- !
- ALLOCATE( mikt(jpi,jpj), miku(jpi,jpj), mikv(jpi,jpj), mikf(jpi,jpj), STAT=ierr(10) )
- !
+ & ssmask (jpi,jpj) , ssumask(jpi,jpj) , ssvmask(jpi,jpj) , ssfmask(jpi,jpj) , &
+ & mbkt (jpi,jpj) , mbku (jpi,jpj) , mbkv (jpi,jpj) , STAT=ierr(ii) )
+ !
+ ii = ii+1
+ ALLOCATE( mikt(jpi,jpj), miku(jpi,jpj), mikv(jpi,jpj), mikf(jpi,jpj), STAT=ierr(ii) )
+ !
+ ii = ii+1
ALLOCATE( tmask(jpi,jpj,jpk) , umask(jpi,jpj,jpk) , &
- & vmask(jpi,jpj,jpk) , fmask(jpi,jpj,jpk) , STAT=ierr(11) )
- !
- ALLOCATE( wmask(jpi,jpj,jpk) , wumask(jpi,jpj,jpk), wvmask(jpi,jpj,jpk) , STAT=ierr(12) )
+ & vmask(jpi,jpj,jpk) , fmask(jpi,jpj,jpk) , STAT=ierr(ii) )
+ !
+ ii = ii+1
+ ALLOCATE( wmask(jpi,jpj,jpk) , wumask(jpi,jpj,jpk), wvmask(jpi,jpj,jpk) , STAT=ierr(ii) )
!
dom_oce_alloc = MAXVAL(ierr)
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/DOM/domain.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/DOM/domain.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/DOM/domain.F90 (revision 13540)
@@ -15,4 +15,5 @@
!! 3.7 ! 2015-11 (G. Madec, A. Coward) time varying zgr by default
!! 4.0 ! 2016-10 (G. Madec, S. Flavoni) domain configuration / user defined interface
+ !! 4.x ! 2020-02 (G. Madec, S. Techene) introduce ssh to h0 ratio
!!----------------------------------------------------------------------
@@ -34,5 +35,9 @@
USE dommsk ! domain: set the mask system
USE domwri ! domain: write the meshmask file
+#if ! defined key_qco
USE domvvl ! variable volume
+#else
+ USE domqco ! variable volume
+#endif
USE c1d ! 1D configuration
USE dyncor_c1d ! 1D configuration: Coriolis term (cor_c1d routine)
@@ -76,5 +81,5 @@
CHARACTER (len=*), INTENT(in) :: cdstr ! model: NEMO or SAS. Determines core restart variables
!
- INTEGER :: ji, jj, jk, ik ! dummy loop indices
+ INTEGER :: ji, jj, jk, jt ! dummy loop indices
INTEGER :: iconf = 0 ! local integers
CHARACTER (len=64) :: cform = "(A12, 3(A13, I7))"
@@ -110,5 +115,5 @@
CASE( 7 ) ; WRITE(numout,*) ' (i.e. cyclic east-west and north-south)'
CASE DEFAULT
- CALL ctl_stop( 'jperio is out of range' )
+ CALL ctl_stop( 'dom_init: jperio is out of range' )
END SELECT
WRITE(numout,*) ' Ocean model configuration used:'
@@ -140,5 +145,5 @@
IF( ln_closea ) CALL dom_clo ! Read in masks to define closed seas and lakes
- CALL dom_zgr( ik_top, ik_bot ) ! Vertical mesh and bathymetry
+ CALL dom_zgr( ik_top, ik_bot ) ! Vertical mesh and bathymetry (return top and bottom ocean t-level indices)
CALL dom_msk( ik_top, ik_bot ) ! Masks
@@ -147,46 +152,69 @@
hu_0(:,:) = 0._wp
hv_0(:,:) = 0._wp
+ hf_0(:,:) = 0._wp
DO jk = 1, jpk
ht_0(:,:) = ht_0(:,:) + e3t_0(:,:,jk) * tmask(:,:,jk)
hu_0(:,:) = hu_0(:,:) + e3u_0(:,:,jk) * umask(:,:,jk)
hv_0(:,:) = hv_0(:,:) + e3v_0(:,:,jk) * vmask(:,:,jk)
+ hf_0(:,:) = hf_0(:,:) + e3f_0(:,:,jk) * fmask(:,:,jk)
END DO
!
+ r1_ht_0(:,:) = ssmask (:,:) / ( ht_0(:,:) + 1._wp - ssmask (:,:) )
+ r1_hu_0(:,:) = ssumask(:,:) / ( hu_0(:,:) + 1._wp - ssumask(:,:) )
+ r1_hv_0(:,:) = ssvmask(:,:) / ( hv_0(:,:) + 1._wp - ssvmask(:,:) )
+ r1_hf_0(:,:) = ssfmask(:,:) / ( hf_0(:,:) + 1._wp - ssfmask(:,:) )
+
+ !
+#if defined key_qco
+ ! !== initialisation of time varying coordinate ==! Quasi-Euerian coordinate case
+ !
+ IF( .NOT.l_offline ) CALL dom_qco_init( Kbb, Kmm, Kaa )
+ !
+ IF( ln_linssh ) CALL ctl_stop('STOP','domain: key_qco and ln_linssh = T are incompatible')
+ !
+#else
! !== time varying part of coordinate system ==!
!
IF( ln_linssh ) THEN != Fix in time : set to the reference one for all
- !
- ! before ! now ! after !
- gdept(:,:,:,Kbb) = gdept_0 ; gdept(:,:,:,Kmm) = gdept_0 ; gdept(:,:,:,Kaa) = gdept_0 ! depth of grid-points
- gdepw(:,:,:,Kbb) = gdepw_0 ; gdepw(:,:,:,Kmm) = gdepw_0 ; gdepw(:,:,:,Kaa) = gdepw_0 !
- gde3w = gde3w_0 ! --- !
- !
- e3t(:,:,:,Kbb) = e3t_0 ; e3t(:,:,:,Kmm) = e3t_0 ; e3t(:,:,:,Kaa) = e3t_0 ! scale factors
- e3u(:,:,:,Kbb) = e3u_0 ; e3u(:,:,:,Kmm) = e3u_0 ; e3u(:,:,:,Kaa) = e3u_0 !
- e3v(:,:,:,Kbb) = e3v_0 ; e3v(:,:,:,Kmm) = e3v_0 ; e3v(:,:,:,Kaa) = e3v_0 !
- e3f = e3f_0 ! --- !
- e3w(:,:,:,Kbb) = e3w_0 ; e3w(:,:,:,Kmm) = e3w_0 ; e3w(:,:,:,Kaa) = e3w_0 !
- e3uw(:,:,:,Kbb) = e3uw_0 ; e3uw(:,:,:,Kmm) = e3uw_0 ; e3uw(:,:,:,Kaa) = e3uw_0 !
- e3vw(:,:,:,Kbb) = e3vw_0 ; e3vw(:,:,:,Kmm) = e3vw_0 ; e3vw(:,:,:,Kaa) = e3vw_0 !
- !
- z1_hu_0(:,:) = ssumask(:,:) / ( hu_0(:,:) + 1._wp - ssumask(:,:) ) ! _i mask due to ISF
- z1_hv_0(:,:) = ssvmask(:,:) / ( hv_0(:,:) + 1._wp - ssvmask(:,:) )
- !
- ! before ! now ! after !
- ht = ht_0 ! ! water column thickness
- hu(:,:,Kbb) = hu_0 ; hu(:,:,Kmm) = hu_0 ; hu(:,:,Kaa) = hu_0 !
- hv(:,:,Kbb) = hv_0 ; hv(:,:,Kmm) = hv_0 ; hv(:,:,Kaa) = hv_0 !
- r1_hu(:,:,Kbb) = z1_hu_0 ; r1_hu(:,:,Kmm) = z1_hu_0 ; r1_hu(:,:,Kaa) = z1_hu_0 ! inverse of water column thickness
- r1_hv(:,:,Kbb) = z1_hv_0 ; r1_hv(:,:,Kmm) = z1_hv_0 ; r1_hv(:,:,Kaa) = z1_hv_0 !
- !
+ !
+ 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
- !
+ IF( .NOT.l_offline ) CALL dom_vvl_init( Kbb, Kmm, Kaa )
+ !
+ ENDIF
+#endif
+
+ !
+
IF( lk_c1d ) CALL cor_c1d ! 1D configuration: Coriolis set at T-point
!
+
+#if defined key_agrif
+ IF( .NOT. Agrif_Root() ) CALL Agrif_Init_Domain( Kbb, Kmm, Kaa )
+#endif
IF( ln_meshmask ) CALL dom_wri ! Create a domain file
IF( .NOT.ln_rstart ) CALL dom_ctl ! Domain control
@@ -212,12 +240,13 @@
!! ** Method :
!!
- !! ** Action : - mig , mjg : local domain indices ==> global domain indices
+ !! ** Action : - mig , mjg : local domain indices ==> global domain, including halos, indices
+ !! - mig0, mjg0: local domain indices ==> global domain, excluding halos, indices
!! - mi0 , mi1 : global domain indices ==> local domain indices
- !! - mj0,, mj1 (global point not in the local domain ==> mi0>mi1 and/or mj0>mj1)
+ !! - mj0 , mj1 (if global point not in the local domain ==> mi0>mi1 and/or mj0>mj1)
!!----------------------------------------------------------------------
INTEGER :: ji, jj ! dummy loop argument
!!----------------------------------------------------------------------
!
- DO ji = 1, jpi ! local domain indices ==> global domain indices
+ DO ji = 1, jpi ! local domain indices ==> global domain indices, including halos
mig(ji) = ji + nimpp - 1
END DO
@@ -225,5 +254,15 @@
mjg(jj) = jj + njmpp - 1
END DO
- ! ! global domain indices ==> local domain indices
+ ! ! local domain indices ==> global domain indices, excluding halos
+ !
+ mig0(:) = mig(:) - nn_hls
+ mjg0(:) = mjg(:) - nn_hls
+ ! WARNING: to keep compatibility with the trunk that was including periodocity into the input data,
+ ! we must define mig0 and mjg0 as bellow.
+ ! Once we decide to forget trunk compatibility, we must simply define mig0 and mjg0 as:
+ mig0_oldcmp(:) = mig0(:) + COUNT( (/ jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7 /) )
+ mjg0_oldcmp(:) = mjg0(:) + COUNT( (/ jperio == 2 .OR. jperio == 7 /) )
+ !
+ ! ! 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.
@@ -243,27 +282,5 @@
WRITE(numout,*) ' local domain: jpi = ', jpi , ' jpj = ', jpj , ' jpk = ', jpk
WRITE(numout,*)
- WRITE(numout,*) ' conversion from local to global domain indices (and vise versa) done'
- IF( nn_print >= 1 ) THEN
- WRITE(numout,*)
- WRITE(numout,*) ' conversion local ==> global i-index domain (mig)'
- WRITE(numout,25) (mig(ji),ji = 1,jpi)
- WRITE(numout,*)
- WRITE(numout,*) ' conversion global ==> local i-index domain'
- WRITE(numout,*) ' starting index (mi0)'
- WRITE(numout,25) (mi0(ji),ji = 1,jpiglo)
- WRITE(numout,*) ' ending index (mi1)'
- WRITE(numout,25) (mi1(ji),ji = 1,jpiglo)
- WRITE(numout,*)
- WRITE(numout,*) ' conversion local ==> global j-index domain (mjg)'
- WRITE(numout,25) (mjg(jj),jj = 1,jpj)
- WRITE(numout,*)
- WRITE(numout,*) ' conversion global ==> local j-index domain'
- WRITE(numout,*) ' starting index (mj0)'
- WRITE(numout,25) (mj0(jj),jj = 1,jpjglo)
- WRITE(numout,*) ' ending index (mj1)'
- WRITE(numout,25) (mj1(jj),jj = 1,jpjglo)
- ENDIF
- ENDIF
- 25 FORMAT( 100(10x,19i4,/) )
+ ENDIF
!
END SUBROUTINE dom_glo
@@ -307,4 +324,11 @@
902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namrun in configuration namelist' )
IF(lwm) WRITE ( numond, namrun )
+
+#if defined key_agrif
+ IF( .NOT. Agrif_Root() ) THEN
+ nn_it000 = (Agrif_Parent(nn_it000)-1)*Agrif_IRhot() + 1
+ nn_itend = Agrif_Parent(nn_itend) *Agrif_IRhot()
+ ENDIF
+#endif
!
IF(lwp) THEN ! control print
@@ -378,22 +402,18 @@
#endif
-#if defined key_agrif
IF( Agrif_Root() ) THEN
-#endif
- IF(lwp) WRITE(numout,*)
- SELECT CASE ( nleapy ) ! Choose calendar for IOIPSL
- CASE ( 1 )
- CALL ioconf_calendar('gregorian')
- IF(lwp) WRITE(numout,*) ' ==>>> The IOIPSL calendar is "gregorian", i.e. leap year'
- CASE ( 0 )
- CALL ioconf_calendar('noleap')
- IF(lwp) WRITE(numout,*) ' ==>>> The IOIPSL calendar is "noleap", i.e. no leap year'
- CASE ( 30 )
- CALL ioconf_calendar('360d')
- IF(lwp) WRITE(numout,*) ' ==>>> The IOIPSL calendar is "360d", i.e. 360 days in a year'
- END SELECT
-#if defined key_agrif
- ENDIF
-#endif
+ IF(lwp) WRITE(numout,*)
+ SELECT CASE ( nleapy ) ! Choose calendar for IOIPSL
+ CASE ( 1 )
+ CALL ioconf_calendar('gregorian')
+ IF(lwp) WRITE(numout,*) ' ==>>> The IOIPSL calendar is "gregorian", i.e. leap year'
+ CASE ( 0 )
+ CALL ioconf_calendar('noleap')
+ IF(lwp) WRITE(numout,*) ' ==>>> The IOIPSL calendar is "noleap", i.e. no leap year'
+ CASE ( 30 )
+ CALL ioconf_calendar('360d')
+ IF(lwp) WRITE(numout,*) ' ==>>> The IOIPSL calendar is "360d", i.e. 360 days in a year'
+ END SELECT
+ ENDIF
READ ( numnam_ref, namdom, IOSTAT = ios, ERR = 903)
@@ -402,4 +422,10 @@
904 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdom in configuration namelist' )
IF(lwm) WRITE( numond, namdom )
+ !
+#if defined key_agrif
+ IF( .NOT. Agrif_Root() ) THEN
+ rn_Dt = Agrif_Parent(rn_Dt) / Agrif_Rhot()
+ ENDIF
+#endif
!
IF(lwp) THEN
@@ -462,41 +488,32 @@
!! ** Method : compute and print extrema of masked scale factors
!!----------------------------------------------------------------------
- INTEGER, DIMENSION(2) :: imi1, imi2, ima1, ima2
- INTEGER, DIMENSION(2) :: iloc !
- REAL(wp) :: ze1min, ze1max, ze2min, ze2max
- !!----------------------------------------------------------------------
- !
- IF(lk_mpp) THEN
- CALL mpp_minloc( 'domain', e1t(:,:), tmask_i(:,:), ze1min, imi1 )
- CALL mpp_minloc( 'domain', e2t(:,:), tmask_i(:,:), ze2min, imi2 )
- CALL mpp_maxloc( 'domain', e1t(:,:), tmask_i(:,:), ze1max, ima1 )
- CALL mpp_maxloc( 'domain', e2t(:,:), tmask_i(:,:), ze2max, ima2 )
- ELSE
- ze1min = MINVAL( e1t(:,:), mask = tmask_i(:,:) == 1._wp )
- ze2min = MINVAL( e2t(:,:), mask = tmask_i(:,:) == 1._wp )
- ze1max = MAXVAL( e1t(:,:), mask = tmask_i(:,:) == 1._wp )
- ze2max = MAXVAL( e2t(:,:), mask = tmask_i(:,:) == 1._wp )
- !
- iloc = MINLOC( e1t(:,:), mask = tmask_i(:,:) == 1._wp )
- imi1(1) = iloc(1) + nimpp - 1
- imi1(2) = iloc(2) + njmpp - 1
- iloc = MINLOC( e2t(:,:), mask = tmask_i(:,:) == 1._wp )
- imi2(1) = iloc(1) + nimpp - 1
- imi2(2) = iloc(2) + njmpp - 1
- iloc = MAXLOC( e1t(:,:), mask = tmask_i(:,:) == 1._wp )
- ima1(1) = iloc(1) + nimpp - 1
- ima1(2) = iloc(2) + njmpp - 1
- iloc = MAXLOC( e2t(:,:), mask = tmask_i(:,:) == 1._wp )
- ima2(1) = iloc(1) + nimpp - 1
- ima2(2) = iloc(2) + njmpp - 1
- ENDIF
+ LOGICAL, DIMENSION(jpi,jpj) :: llmsk
+ INTEGER, DIMENSION(2) :: imil, imip, imi1, imi2, imal, imap, ima1, ima2
+ REAL(wp) :: zglmin, zglmax, zgpmin, zgpmax, ze1min, ze1max, ze2min, ze2max
+ !!----------------------------------------------------------------------
+ !
+ llmsk = tmask_h(:,:) == 1._wp
+ !
+ CALL mpp_minloc( 'domain', glamt(:,:), llmsk, zglmin, imil )
+ CALL mpp_minloc( 'domain', gphit(:,:), llmsk, zgpmin, imip )
+ CALL mpp_minloc( 'domain', e1t(:,:), llmsk, ze1min, imi1 )
+ CALL mpp_minloc( 'domain', e2t(:,:), llmsk, ze2min, imi2 )
+ CALL mpp_maxloc( 'domain', glamt(:,:), llmsk, zglmax, imal )
+ CALL mpp_maxloc( 'domain', gphit(:,:), llmsk, zgpmax, imap )
+ CALL mpp_maxloc( 'domain', e1t(:,:), llmsk, ze1max, ima1 )
+ CALL mpp_maxloc( 'domain', e2t(:,:), llmsk, ze2max, ima2 )
+ !
IF(lwp) THEN
WRITE(numout,*)
WRITE(numout,*) 'dom_ctl : extrema of the masked scale factors'
WRITE(numout,*) '~~~~~~~'
- WRITE(numout,"(14x,'e1t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1max, ima1(1), ima1(2)
- WRITE(numout,"(14x,'e1t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1min, imi1(1), imi1(2)
- WRITE(numout,"(14x,'e2t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2max, ima2(1), ima2(2)
- WRITE(numout,"(14x,'e2t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2min, imi2(1), imi2(2)
+ WRITE(numout,"(14x,'glamt mini: ',1f10.2,' at i = ',i5,' j= ',i5)") zglmin, imil(1), imil(2)
+ WRITE(numout,"(14x,'glamt maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") zglmax, imal(1), imal(2)
+ WRITE(numout,"(14x,'gphit mini: ',1f10.2,' at i = ',i5,' j= ',i5)") zgpmin, imip(1), imip(2)
+ WRITE(numout,"(14x,'gphit maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") zgpmax, imap(1), imap(2)
+ WRITE(numout,"(14x,' e1t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1min, imi1(1), imi1(2)
+ WRITE(numout,"(14x,' e1t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1max, ima1(1), ima1(2)
+ WRITE(numout,"(14x,' e2t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2min, imi2(1), imi2(2)
+ WRITE(numout,"(14x,' e2t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2max, ima2(1), ima2(2)
ENDIF
!
@@ -565,6 +582,6 @@
IF(lwp) THEN
WRITE(numout,*) ' cn_cfg = ', TRIM(cd_cfg), ' nn_cfg = ', kk_cfg
- WRITE(numout,*) ' jpiglo = ', kpi
- WRITE(numout,*) ' jpjglo = ', kpj
+ WRITE(numout,*) ' Ni0glo = ', kpi
+ WRITE(numout,*) ' Nj0glo = ', kpj
WRITE(numout,*) ' jpkglo = ', kpk
WRITE(numout,*) ' type of global domain lateral boundary jperio = ', kperio
@@ -590,5 +607,4 @@
!!----------------------------------------------------------------------
INTEGER :: ji, jj, jk ! dummy loop indices
- INTEGER :: izco, izps, isco, icav
INTEGER :: inum ! local units
CHARACTER(len=21) :: clnam ! filename (mesh and mask informations)
@@ -605,19 +621,12 @@
!
clnam = cn_domcfg_out ! filename (configuration information)
- CALL iom_open( TRIM(clnam), inum, ldwrt = .TRUE. )
-
+ CALL iom_open( TRIM(clnam), inum, ldwrt = .TRUE. )
!
! !== ORCA family specificities ==!
- IF( cn_cfg == "ORCA" ) THEN
+ IF( TRIM(cn_cfg) == "orca" .OR. TRIM(cn_cfg) == "ORCA" ) THEN
CALL iom_rstput( 0, 0, inum, 'ORCA' , 1._wp , ktype = jp_i4 )
CALL iom_rstput( 0, 0, inum, 'ORCA_index', REAL( nn_cfg, wp), ktype = jp_i4 )
ENDIF
!
- ! !== global domain size ==!
- !
- CALL iom_rstput( 0, 0, inum, 'jpiglo', REAL( jpiglo, wp), ktype = jp_i4 )
- CALL iom_rstput( 0, 0, inum, 'jpjglo', REAL( jpjglo, wp), ktype = jp_i4 )
- CALL iom_rstput( 0, 0, inum, 'jpkglo', REAL( jpk , wp), ktype = jp_i4 )
- !
! !== domain characteristics ==!
!
@@ -626,14 +635,10 @@
!
! ! type of vertical coordinate
- IF( ln_zco ) THEN ; izco = 1 ; ELSE ; izco = 0 ; ENDIF
- IF( ln_zps ) THEN ; izps = 1 ; ELSE ; izps = 0 ; ENDIF
- IF( ln_sco ) THEN ; isco = 1 ; ELSE ; isco = 0 ; ENDIF
- CALL iom_rstput( 0, 0, inum, 'ln_zco' , REAL( izco, wp), ktype = jp_i4 )
- CALL iom_rstput( 0, 0, inum, 'ln_zps' , REAL( izps, wp), ktype = jp_i4 )
- CALL iom_rstput( 0, 0, inum, 'ln_sco' , REAL( isco, wp), ktype = jp_i4 )
+ CALL iom_rstput( 0, 0, inum, 'ln_zco', REAL(COUNT((/ln_zco/)), wp), ktype = jp_i4 )
+ CALL iom_rstput( 0, 0, inum, 'ln_zps', REAL(COUNT((/ln_zps/)), wp), ktype = jp_i4 )
+ CALL iom_rstput( 0, 0, inum, 'ln_sco', REAL(COUNT((/ln_sco/)), wp), ktype = jp_i4 )
!
! ! ocean cavities under iceshelves
- IF( ln_isfcav ) THEN ; icav = 1 ; ELSE ; icav = 0 ; ENDIF
- CALL iom_rstput( 0, 0, inum, 'ln_isfcav', REAL( icav, wp), ktype = jp_i4 )
+ CALL iom_rstput( 0, 0, inum, 'ln_isfcav', REAL(COUNT((/ln_isfcav/)), wp), ktype = jp_i4 )
!
! !== horizontal mesh !
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/DOM/domhgr.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/DOM/domhgr.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/DOM/domhgr.F90 (revision 13540)
@@ -31,4 +31,5 @@
USE iom ! I/O library
USE lib_mpp ! MPP library
+ USE lbclnk ! lateal boundary condition / mpp exchanges
USE timing ! Timing
@@ -88,6 +89,6 @@
ENDIF
!
- !
IF( ln_read_cfg ) THEN !== read in mesh_mask.nc file ==!
+ !
IF(lwp) WRITE(numout,*)
IF(lwp) WRITE(numout,*) ' ==>>> read horizontal mesh in ', TRIM( cn_domcfg ), ' file'
@@ -112,5 +113,4 @@
!
ENDIF
- !
! !== Coriolis parameter ==! (if necessary)
!
@@ -126,5 +126,4 @@
ENDIF
ENDIF
-
!
! !== associated horizontal metrics ==!
@@ -150,5 +149,4 @@
e2_e1u(:,:) = e2u(:,:) / e1u(:,:)
e1_e2v(:,:) = e1v(:,:) / e2v(:,:)
- !
!
IF( ln_timing ) CALL timing_stop('dom_hgr')
@@ -189,29 +187,29 @@
CALL iom_open( cn_domcfg, inum )
!
- CALL iom_get( inum, jpdom_data, 'glamt', plamt, lrowattr=ln_use_jattr )
- CALL iom_get( inum, jpdom_data, 'glamu', plamu, lrowattr=ln_use_jattr )
- CALL iom_get( inum, jpdom_data, 'glamv', plamv, lrowattr=ln_use_jattr )
- CALL iom_get( inum, jpdom_data, 'glamf', plamf, lrowattr=ln_use_jattr )
- !
- CALL iom_get( inum, jpdom_data, 'gphit', pphit, lrowattr=ln_use_jattr )
- CALL iom_get( inum, jpdom_data, 'gphiu', pphiu, lrowattr=ln_use_jattr )
- CALL iom_get( inum, jpdom_data, 'gphiv', pphiv, lrowattr=ln_use_jattr )
- CALL iom_get( inum, jpdom_data, 'gphif', pphif, lrowattr=ln_use_jattr )
- !
- CALL iom_get( inum, jpdom_data, 'e1t' , pe1t , lrowattr=ln_use_jattr )
- CALL iom_get( inum, jpdom_data, 'e1u' , pe1u , lrowattr=ln_use_jattr )
- CALL iom_get( inum, jpdom_data, 'e1v' , pe1v , lrowattr=ln_use_jattr )
- CALL iom_get( inum, jpdom_data, 'e1f' , pe1f , lrowattr=ln_use_jattr )
- !
- CALL iom_get( inum, jpdom_data, 'e2t' , pe2t , lrowattr=ln_use_jattr )
- CALL iom_get( inum, jpdom_data, 'e2u' , pe2u , lrowattr=ln_use_jattr )
- CALL iom_get( inum, jpdom_data, 'e2v' , pe2v , lrowattr=ln_use_jattr )
- CALL iom_get( inum, jpdom_data, 'e2f' , pe2f , lrowattr=ln_use_jattr )
+ CALL iom_get( inum, jpdom_global, 'glamt', plamt, cd_type = 'T', psgn = 1._wp )
+ CALL iom_get( inum, jpdom_global, 'glamu', plamu, cd_type = 'U', psgn = 1._wp )
+ CALL iom_get( inum, jpdom_global, 'glamv', plamv, cd_type = 'V', psgn = 1._wp )
+ CALL iom_get( inum, jpdom_global, 'glamf', plamf, cd_type = 'F', psgn = 1._wp )
+ !
+ CALL iom_get( inum, jpdom_global, 'gphit', pphit, cd_type = 'T', psgn = 1._wp )
+ CALL iom_get( inum, jpdom_global, 'gphiu', pphiu, cd_type = 'U', psgn = 1._wp )
+ CALL iom_get( inum, jpdom_global, 'gphiv', pphiv, cd_type = 'V', psgn = 1._wp )
+ CALL iom_get( inum, jpdom_global, 'gphif', pphif, cd_type = 'F', psgn = 1._wp )
+ !
+ CALL iom_get( inum, jpdom_global, 'e1t' , pe1t , cd_type = 'T', psgn = 1._wp, kfill = jpfillcopy )
+ CALL iom_get( inum, jpdom_global, 'e1u' , pe1u , cd_type = 'U', psgn = 1._wp, kfill = jpfillcopy )
+ CALL iom_get( inum, jpdom_global, 'e1v' , pe1v , cd_type = 'V', psgn = 1._wp, kfill = jpfillcopy )
+ CALL iom_get( inum, jpdom_global, 'e1f' , pe1f , cd_type = 'F', psgn = 1._wp, kfill = jpfillcopy )
+ !
+ CALL iom_get( inum, jpdom_global, 'e2t' , pe2t , cd_type = 'T', psgn = 1._wp, kfill = jpfillcopy )
+ CALL iom_get( inum, jpdom_global, 'e2u' , pe2u , cd_type = 'U', psgn = 1._wp, kfill = jpfillcopy )
+ CALL iom_get( inum, jpdom_global, 'e2v' , pe2v , cd_type = 'V', psgn = 1._wp, kfill = jpfillcopy )
+ CALL iom_get( inum, jpdom_global, 'e2f' , pe2f , cd_type = 'F', psgn = 1._wp, kfill = jpfillcopy )
!
IF( iom_varid( inum, 'ff_f', ldstop = .FALSE. ) > 0 .AND. &
& iom_varid( inum, 'ff_t', ldstop = .FALSE. ) > 0 ) THEN
IF(lwp) WRITE(numout,*) ' Coriolis factor at f- and t-points read in ', TRIM( cn_domcfg ), ' file'
- CALL iom_get( inum, jpdom_data, 'ff_f' , pff_f , lrowattr=ln_use_jattr )
- CALL iom_get( inum, jpdom_data, 'ff_t' , pff_t , lrowattr=ln_use_jattr )
+ CALL iom_get( inum, jpdom_global, 'ff_f', pff_f, cd_type = 'F', psgn = 1._wp )
+ CALL iom_get( inum, jpdom_global, 'ff_t', pff_t, cd_type = 'T', psgn = 1._wp )
kff = 1
ELSE
@@ -221,6 +219,6 @@
IF( iom_varid( inum, 'e1e2u', ldstop = .FALSE. ) > 0 ) THEN
IF(lwp) WRITE(numout,*) ' e1e2u & e1e2v read in ', TRIM( cn_domcfg ), ' file'
- CALL iom_get( inum, jpdom_data, 'e1e2u' , pe1e2u , lrowattr=ln_use_jattr )
- CALL iom_get( inum, jpdom_data, 'e1e2v' , pe1e2v , lrowattr=ln_use_jattr )
+ CALL iom_get( inum, jpdom_global, 'e1e2u', pe1e2u, cd_type = 'U', psgn = 1._wp, kfill = jpfillcopy )
+ CALL iom_get( inum, jpdom_global, 'e1e2v', pe1e2v, cd_type = 'V', psgn = 1._wp, kfill = jpfillcopy )
ke1e2u_v = 1
ELSE
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/DOM/dommsk.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/DOM/dommsk.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/DOM/dommsk.F90 (revision 13540)
@@ -18,4 +18,5 @@
!! 3.6 ! 2015-05 (P. Mathiot) ISF: add wmask,wumask and wvmask
!! 4.0 ! 2016-06 (G. Madec, S. Flavoni) domain configuration / user defined interface
+ !! 4.x ! 2020-02 (G. Madec, S. Techene) introduce ssh to h0 ratio
!!----------------------------------------------------------------------
@@ -25,4 +26,5 @@
USE oce ! ocean dynamics and tracers
USE dom_oce ! ocean space and time domain
+ USE domutl !
USE usrdef_fmask ! user defined fmask
USE bdy_oce ! open boundary
@@ -88,9 +90,6 @@
!
INTEGER :: ji, jj, jk ! dummy loop indices
- INTEGER :: iif, iil ! local integers
- INTEGER :: ijf, ijl ! - -
INTEGER :: iktop, ikbot ! - -
INTEGER :: ios, inum
- REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zwf ! 2D workspace
!!
NAMELIST/namlbc/ rn_shlat, ln_vorlat
@@ -131,17 +130,13 @@
!
tmask(:,:,:) = 0._wp
- DO_2D_11_11
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
iktop = k_top(ji,jj)
ikbot = k_bot(ji,jj)
IF( iktop /= 0 ) THEN ! water in the column
- tmask(ji,jj,iktop:ikbot ) = 1._wp
+ tmask(ji,jj,iktop:ikbot) = 1._wp
ENDIF
END_2D
!
- ! the following call is mandatory
- ! it masks boundaries (bathy=0) where needed depending on the configuration (closed, periodic...)
- CALL lbc_lnk( 'dommsk', tmask , 'T', 1._wp ) ! Lateral boundary conditions
-
- ! Mask corrections for bdy (read in mppini2)
+ ! Mask corrections for bdy (read in mppini2)
READ ( numnam_ref, nambdy, IOSTAT = ios, ERR = 903)
903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy in reference namelist' )
@@ -151,7 +146,7 @@
IF ( ln_bdy .AND. ln_mask_file ) THEN
CALL iom_open( cn_mask_file, inum )
- CALL iom_get ( inum, jpdom_data, 'bdy_msk', bdytmask(:,:) )
+ CALL iom_get ( inum, jpdom_global, 'bdy_msk', bdytmask(:,:) )
CALL iom_close( inum )
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
tmask(ji,jj,jk) = tmask(ji,jj,jk) * bdytmask(ji,jj)
END_3D
@@ -161,17 +156,11 @@
! ----------------------------------------
! NB: at this point, fmask is designed for free slip lateral boundary condition
- DO jk = 1, jpk
- DO jj = 1, jpjm1
- DO ji = 1, jpim1 ! vector loop
- umask(ji,jj,jk) = tmask(ji,jj ,jk) * tmask(ji+1,jj ,jk)
- vmask(ji,jj,jk) = tmask(ji,jj ,jk) * tmask(ji ,jj+1,jk)
- END DO
- DO ji = 1, jpim1 ! NO vector opt.
- fmask(ji,jj,jk) = tmask(ji,jj ,jk) * tmask(ji+1,jj ,jk) &
- & * tmask(ji,jj+1,jk) * tmask(ji+1,jj+1,jk)
- END DO
- END DO
- END DO
- CALL lbc_lnk_multi( 'dommsk', umask, 'U', 1., vmask, 'V', 1., fmask, 'F', 1. ) ! Lateral boundary conditions
+ DO_3D( 0, 0, 0, 0, 1, jpk )
+ umask(ji,jj,jk) = tmask(ji,jj ,jk) * tmask(ji+1,jj ,jk)
+ vmask(ji,jj,jk) = tmask(ji,jj ,jk) * tmask(ji ,jj+1,jk)
+ fmask(ji,jj,jk) = tmask(ji,jj ,jk) * tmask(ji+1,jj ,jk) &
+ & * tmask(ji,jj+1,jk) * tmask(ji+1,jj+1,jk)
+ END_3D
+ CALL lbc_lnk_multi( 'dommsk', umask, 'U', 1.0_wp, vmask, 'V', 1.0_wp, fmask, 'F', 1.0_wp ) ! Lateral boundary conditions
! Ocean/land mask at wu-, wv- and w points (computed from tmask)
@@ -186,5 +175,4 @@
END DO
-
! Ocean/land column mask at t-, u-, and v-points (i.e. at least 1 wet cell in the vertical)
! ----------------------------------------------
@@ -192,40 +180,13 @@
ssumask(:,:) = MAXVAL( umask(:,:,:), DIM=3 )
ssvmask(:,:) = MAXVAL( vmask(:,:,:), DIM=3 )
-
+ ssfmask(:,:) = MAXVAL( fmask(:,:,:), DIM=3 )
! Interior domain mask (used for global sum)
! --------------------
!
- iif = nn_hls ; iil = nlci - nn_hls + 1
- ijf = nn_hls ; ijl = nlcj - nn_hls + 1
- !
- ! ! halo mask : 0 on the halo and 1 elsewhere
- tmask_h(:,:) = 1._wp
- tmask_h( 1 :iif, : ) = 0._wp ! first columns
- tmask_h(iil:jpi, : ) = 0._wp ! last columns (including mpp extra columns)
- tmask_h( : , 1 :ijf) = 0._wp ! first rows
- tmask_h( : ,ijl:jpj) = 0._wp ! last rows (including mpp extra rows)
- !
- ! ! north fold mask
- tpol(1:jpiglo) = 1._wp
- fpol(1:jpiglo) = 1._wp
- IF( jperio == 3 .OR. jperio == 4 ) THEN ! T-point pivot
- tpol(jpiglo/2+1:jpiglo) = 0._wp
- fpol( 1 :jpiglo) = 0._wp
- IF( mjg(nlej) == jpjglo ) THEN ! only half of the nlcj-1 row for tmask_h
- DO ji = iif+1, iil-1
- tmask_h(ji,nlej-1) = tmask_h(ji,nlej-1) * tpol(mig(ji))
- END DO
- ENDIF
- ENDIF
- !
- IF( jperio == 5 .OR. jperio == 6 ) THEN ! F-point pivot
- tpol( 1 :jpiglo) = 0._wp
- fpol(jpiglo/2+1:jpiglo) = 0._wp
- ENDIF
+ CALL dom_uniq( tmask_h, 'T' )
!
! ! interior mask : 2D ocean mask x halo mask
tmask_i(:,:) = ssmask(:,:) * tmask_h(:,:)
-
! Lateral boundary conditions on velocity (modify fmask)
@@ -233,41 +194,28 @@
IF( rn_shlat /= 0 ) THEN ! Not free-slip lateral boundary condition
!
- ALLOCATE( zwf(jpi,jpj) )
- !
DO jk = 1, jpk
- zwf(:,:) = fmask(:,:,jk)
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
IF( fmask(ji,jj,jk) == 0._wp ) THEN
- fmask(ji,jj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(ji+1,jj), zwf(ji,jj+1), &
- & zwf(ji-1,jj), zwf(ji,jj-1) ) )
+ fmask(ji,jj,jk) = rn_shlat * MIN( 1._wp , MAX( umask(ji,jj,jk), umask(ji,jj+1,jk), &
+ & vmask(ji,jj,jk), vmask(ji+1,jj,jk) ) )
ENDIF
END_2D
DO jj = 2, jpjm1
IF( fmask(1,jj,jk) == 0._wp ) THEN
- fmask(1 ,jj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(2,jj), zwf(1,jj+1), zwf(1,jj-1) ) )
+ fmask(1 ,jj,jk) = rn_shlat * MIN( 1._wp , MAX( vmask(2,jj,jk), umask(1,jj+1,jk), umask(1,jj,jk) ) )
ENDIF
IF( fmask(jpi,jj,jk) == 0._wp ) THEN
- fmask(jpi,jj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(jpi,jj+1), zwf(jpim1,jj), zwf(jpi,jj-1) ) )
+ fmask(jpi,jj,jk) = rn_shlat * MIN( 1._wp , MAX( umask(jpi,jj+1,jk), vmask(jpim1,jj,jk), umask(jpi,jj-1,jk) ) )
ENDIF
END DO
DO ji = 2, jpim1
IF( fmask(ji,1,jk) == 0._wp ) THEN
- fmask(ji, 1 ,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(ji+1,1), zwf(ji,2), zwf(ji-1,1) ) )
+ fmask(ji, 1 ,jk) = rn_shlat * MIN( 1._wp , MAX( vmask(ji+1,1,jk), umask(ji,2,jk), vmask(ji,1,jk) ) )
ENDIF
IF( fmask(ji,jpj,jk) == 0._wp ) THEN
- fmask(ji,jpj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(ji+1,jpj), zwf(ji-1,jpj), zwf(ji,jpjm1) ) )
+ fmask(ji,jpj,jk) = rn_shlat * MIN( 1._wp , MAX( vmask(ji+1,jpj,jk), vmask(ji-1,jpj,jk), umask(ji,jpjm1,jk) ) )
ENDIF
END DO
-#if defined key_agrif
- IF( .NOT. AGRIF_Root() ) THEN
- IF ((nbondi == 1).OR.(nbondi == 2)) fmask(nlci-1 , : ,jk) = 0.e0 ! east
- IF ((nbondi == -1).OR.(nbondi == 2)) fmask(1 , : ,jk) = 0.e0 ! west
- IF ((nbondj == 1).OR.(nbondj == 2)) fmask(: ,nlcj-1 ,jk) = 0.e0 ! north
- IF ((nbondj == -1).OR.(nbondj == 2)) fmask(: ,1 ,jk) = 0.e0 ! south
- ENDIF
-#endif
END DO
- !
- DEALLOCATE( zwf )
!
CALL lbc_lnk( 'dommsk', fmask, 'F', 1._wp ) ! Lateral boundary conditions on fmask
Index: MO/branches/2020/r12377_ticket2386/src/OCE/DOM/domngb.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/DOM/domngb.F90 (revision 13539)
+++ (revision )
@@ -1,80 +1,0 @@
-MODULE domngb
- !!======================================================================
- !! *** MODULE domngb ***
- !! Grid search: find the closest grid point from a given on/lat position
- !!======================================================================
- !! History : 3.2 ! 2009-11 (S. Masson) Original code
- !!----------------------------------------------------------------------
-
- !!----------------------------------------------------------------------
- !! dom_ngb : find the closest grid point from a given lon/lat position
- !!----------------------------------------------------------------------
- USE dom_oce ! ocean space and time domain
- !
- USE in_out_manager ! I/O manager
- USE lib_mpp ! for mppsum
-
- IMPLICIT NONE
- PRIVATE
-
- PUBLIC dom_ngb ! routine called in iom.F90 module
-
- !!----------------------------------------------------------------------
- !! NEMO/OCE 4.0 , NEMO Consortium (2018)
- !! $Id$
- !! Software governed by the CeCILL license (see ./LICENSE)
- !!----------------------------------------------------------------------
-CONTAINS
-
- SUBROUTINE dom_ngb( plon, plat, kii, kjj, cdgrid, kkk )
- !!----------------------------------------------------------------------
- !! *** ROUTINE dom_ngb ***
- !!
- !! ** Purpose : find the closest grid point from a given lon/lat position
- !!
- !! ** Method : look for minimum distance in cylindrical projection
- !! -> not good if located at too high latitude...
- !!----------------------------------------------------------------------
- REAL(wp) , INTENT(in ) :: plon, plat ! longitude,latitude of the point
- INTEGER , INTENT( out) :: kii, kjj ! i-,j-index of the closes grid point
- INTEGER , INTENT(in ), OPTIONAL :: kkk ! k-index of the mask level used
- CHARACTER(len=1), INTENT(in ) :: cdgrid ! grid name 'T', 'U', 'V', 'W'
- !
- INTEGER :: ik ! working level
- INTEGER , DIMENSION(2) :: iloc
- REAL(wp) :: zlon, zmini
- REAL(wp), DIMENSION(jpi,jpj) :: zglam, zgphi, zmask, zdist
- !!--------------------------------------------------------------------
- !
- zmask(:,:) = 0._wp
- ik = 1
- IF ( PRESENT(kkk) ) ik=kkk
- SELECT CASE( cdgrid )
- CASE( 'U' ) ; zglam(:,:) = glamu(:,:) ; zgphi(:,:) = gphiu(:,:) ; zmask(nldi:nlei,nldj:nlej) = umask(nldi:nlei,nldj:nlej,ik)
- CASE( 'V' ) ; zglam(:,:) = glamv(:,:) ; zgphi(:,:) = gphiv(:,:) ; zmask(nldi:nlei,nldj:nlej) = vmask(nldi:nlei,nldj:nlej,ik)
- CASE( 'F' ) ; zglam(:,:) = glamf(:,:) ; zgphi(:,:) = gphif(:,:) ; zmask(nldi:nlei,nldj:nlej) = fmask(nldi:nlei,nldj:nlej,ik)
- CASE DEFAULT ; zglam(:,:) = glamt(:,:) ; zgphi(:,:) = gphit(:,:) ; zmask(nldi:nlei,nldj:nlej) = tmask(nldi:nlei,nldj:nlej,ik)
- END SELECT
-
- zlon = MOD( plon + 720., 360. ) ! plon between 0 and 360
- zglam(:,:) = MOD( zglam(:,:) + 720., 360. ) ! glam between 0 and 360
- IF( zlon > 270. ) zlon = zlon - 360. ! zlon between -90 and 270
- IF( zlon < 90. ) WHERE( zglam(:,:) > 180. ) zglam(:,:) = zglam(:,:) - 360. ! glam between -180 and 180
- zglam(:,:) = zglam(:,:) - zlon
-
- zgphi(:,:) = zgphi(:,:) - plat
- zdist(:,:) = zglam(:,:) * zglam(:,:) + zgphi(:,:) * zgphi(:,:)
-
- IF( lk_mpp ) THEN
- CALL mpp_minloc( 'domngb', zdist(:,:), zmask, zmini, iloc)
- kii = iloc(1) ; kjj = iloc(2)
- ELSE
- iloc(:) = MINLOC( zdist(:,:), mask = zmask(:,:) == 1.e0 )
- kii = iloc(1) + nimpp - 1
- kjj = iloc(2) + njmpp - 1
- ENDIF
- !
- END SUBROUTINE dom_ngb
-
- !!======================================================================
-END MODULE domngb
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/DOM/domqco.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/DOM/domqco.F90 (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/DOM/domqco.F90 (revision 13540)
@@ -0,0 +1,367 @@
+MODULE domqco
+ !!======================================================================
+ !! *** MODULE domqco ***
+ !! 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
+ !! 4.x ! 2020-02 (G. Madec, S. Techene) pure z* (quasi-eulerian) coordinate
+ !!----------------------------------------------------------------------
+
+ !!----------------------------------------------------------------------
+ !! dom_qe_init : define initial vertical scale factors, depths and column thickness
+ !! dom_qe_r3c : Compute ssh/h_0 ratioat t-, u-, v-, and optionally f-points
+ !! qe_rst_read : read/write restart file
+ !! dom_qe_ctl : Check the vvl options
+ !!----------------------------------------------------------------------
+ USE oce ! ocean dynamics and tracers
+ USE phycst ! physical constant
+ USE dom_oce ! ocean space and time domain
+ USE dynadv , ONLY : ln_dynadv_vec
+ USE isf_oce ! iceshelf cavities
+ 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
+
+ PUBLIC dom_qco_init ! called by domain.F90
+ PUBLIC dom_qco_zgr ! called by isfcpl.F90
+ PUBLIC dom_qco_r3c ! called by steplf.F90
+
+ ! !!* 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
+ ! ! 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
+
+ !! * Substitutions
+# include "do_loop_substitute.h90"
+ !!----------------------------------------------------------------------
+ !! NEMO/OCE 4.0 , NEMO Consortium (2018)
+ !! $Id: domvvl.F90 12377 2020-02-12 14:39:06Z acc $
+ !! Software governed by the CeCILL license (see ./LICENSE)
+ !!----------------------------------------------------------------------
+CONTAINS
+
+ SUBROUTINE dom_qco_init( Kbb, Kmm, Kaa )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE dom_qco_init ***
+ !!
+ !! ** Purpose : Initialization of all ssh. to h._0 ratio
+ !!
+ !! ** Method : - use restart file and/or initialize
+ !! - compute ssh. to h._0 ratio
+ !!
+ !! ** Action : - r3(t/u/v)_b
+ !! - r3(t/u/v/f)_n
+ !!
+ !!----------------------------------------------------------------------
+ INTEGER, INTENT(in) :: Kbb, Kmm, Kaa
+ !
+ IF(lwp) WRITE(numout,*)
+ IF(lwp) WRITE(numout,*) 'dom_qco_init : Variable volume activated'
+ IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~'
+ !
+ CALL dom_qco_ctl ! choose vertical coordinate (z_star, z_tilde or layer)
+ !
+ ! ! Read or initialize e3t_(b/n), tilde_e3t_(b/n) and hdiv_lf
+ CALL qe_rst_read( nit000, Kbb, Kmm )
+ !
+ CALL dom_qco_zgr(Kbb, Kmm, Kaa) ! interpolation scale factor, depth and water column
+ !
+ ! IF(lwxios) THEN ! define variables in restart file when writing with XIOS
+ ! CALL iom_set_rstw_var_active('e3t_b')
+ ! CALL iom_set_rstw_var_active('e3t_n')
+ ! ENDIF
+ !
+ END SUBROUTINE dom_qco_init
+
+
+ SUBROUTINE dom_qco_zgr(Kbb, Kmm, Kaa)
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE dom_qco_init ***
+ !!
+ !! ** Purpose : Initialization of all ssh. to h._0 ratio
+ !!
+ !! ** Method : - interpolate scale factors
+ !!
+ !! ** Action : - r3(t/u/v)_b
+ !! - r3(t/u/v/f)_n
+ !!
+ !! Reference : Leclair, M., and G. Madec, 2011, Ocean Modelling.
+ !!----------------------------------------------------------------------
+ INTEGER, INTENT(in) :: Kbb, Kmm, Kaa
+ !!----------------------------------------------------------------------
+ !
+ ! !== Set of all other vertical scale factors ==! (now and before)
+ ! ! Horizontal interpolation of e3t
+ CALL dom_qco_r3c( ssh(:,:,Kbb), r3t(:,:,Kbb), r3u(:,:,Kbb), r3v(:,:,Kbb) )
+ CALL dom_qco_r3c( ssh(:,:,Kmm), r3t(:,:,Kmm), r3u(:,:,Kmm), r3v(:,:,Kmm), r3f(:,:) )
+ !
+ END SUBROUTINE dom_qco_zgr
+
+
+ SUBROUTINE dom_qco_r3c( pssh, pr3t, pr3u, pr3v, pr3f )
+ !!---------------------------------------------------------------------
+ !! *** ROUTINE r3c ***
+ !!
+ !! ** Purpose : compute the filtered ratio ssh/h_0 at t-,u-,v-,f-points
+ !!
+ !! ** Method : - compute the ssh at u- and v-points (f-point optional)
+ !! Vector Form : surface weighted averaging
+ !! Flux Form : simple averaging
+ !! - compute the ratio ssh/h_0 at t-,u-,v-pts, (f-pt optional)
+ !!----------------------------------------------------------------------
+ REAL(wp), DIMENSION(:,:) , INTENT(in ) :: pssh ! sea surface height [m]
+ REAL(wp), DIMENSION(:,:) , INTENT( out) :: pr3t, pr3u, pr3v ! ssh/h0 ratio at t-, u-, v-,points [-]
+ REAL(wp), DIMENSION(:,:), OPTIONAL, INTENT( out) :: pr3f ! ssh/h0 ratio at f-point [-]
+ !
+ INTEGER :: ji, jj ! dummy loop indices
+ !!----------------------------------------------------------------------
+ !
+ !
+ pr3t(:,:) = pssh(:,:) * r1_ht_0(:,:) !== ratio at t-point ==!
+ !
+ !
+ ! !== ratio at u-,v-point ==!
+ !
+ IF( ln_dynadv_vec ) THEN !- Vector Form (thickness weighted averaging)
+ DO_2D( 0, 0, 0, 0 )
+ pr3u(ji,jj) = 0.5_wp * ( e1e2t(ji ,jj) * pssh(ji ,jj) &
+ & + e1e2t(ji+1,jj) * pssh(ji+1,jj) ) * r1_hu_0(ji,jj) * r1_e1e2u(ji,jj)
+ pr3v(ji,jj) = 0.5_wp * ( e1e2t(ji,jj ) * pssh(ji,jj ) &
+ & + e1e2t(ji,jj+1) * pssh(ji,jj+1) ) * r1_hv_0(ji,jj) * r1_e1e2v(ji,jj)
+ END_2D
+ ELSE !- Flux Form (simple averaging)
+ DO_2D( 0, 0, 0, 0 )
+ pr3u(ji,jj) = 0.5_wp * ( pssh(ji ,jj) + pssh(ji+1,jj) ) * r1_hu_0(ji,jj)
+ pr3v(ji,jj) = 0.5_wp * ( pssh(ji,jj ) + pssh(ji,jj+1) ) * r1_hv_0(ji,jj)
+ END_2D
+ ENDIF
+ !
+ IF( .NOT.PRESENT( pr3f ) ) THEN !- lbc on ratio at u-, v-points only
+ CALL lbc_lnk_multi( 'dom_qco_r3c', pr3u, 'U', 1._wp, pr3v, 'V', 1._wp )
+ !
+ !
+ ELSE !== ratio at f-point ==!
+ !
+ IF( ln_dynadv_vec ) THEN !- Vector Form (thickness weighted averaging)
+ DO_2D( 1, 0, 1, 0 ) ! start from 1 since lbc_lnk('F') doesn't update the 1st row/line
+ pr3f(ji,jj) = 0.25_wp * ( e1e2t(ji ,jj ) * pssh(ji ,jj ) &
+ & + e1e2t(ji+1,jj ) * pssh(ji+1,jj ) &
+ & + e1e2t(ji ,jj+1) * pssh(ji ,jj+1) &
+ & + e1e2t(ji+1,jj+1) * pssh(ji+1,jj+1) ) * r1_hf_0(ji,jj) * r1_e1e2f(ji,jj)
+ END_2D
+ ELSE !- Flux Form (simple averaging)
+ DO_2D( 1, 0, 1, 0 ) ! start from 1 since lbc_lnk('F') doesn't update the 1st row/line
+ pr3f(ji,jj) = 0.25_wp * ( pssh(ji ,jj ) + pssh(ji+1,jj ) &
+ & + pssh(ji ,jj+1) + pssh(ji+1,jj+1) ) * r1_hf_0(ji,jj)
+ END_2D
+ ENDIF
+ ! ! lbc on ratio at u-,v-,f-points
+ CALL lbc_lnk_multi( 'dom_qco_r3c', pr3u, 'U', 1._wp, pr3v, 'V', 1._wp, pr3f, 'F', 1._wp )
+ !
+ ENDIF
+ !
+ END SUBROUTINE dom_qco_r3c
+
+
+ SUBROUTINE qe_rst_read( kt, Kbb, Kmm )
+ !!---------------------------------------------------------------------
+ !! *** ROUTINE qe_rst_read ***
+ !!
+ !! ** Purpose : Read ssh in restart file
+ !!
+ !! ** Method : use of IOM library
+ !! if the restart does not contain ssh,
+ !! it is set to the _0 values.
+ !!----------------------------------------------------------------------
+ INTEGER , INTENT(in) :: kt ! ocean time-step
+ INTEGER , INTENT(in) :: Kbb, Kmm ! ocean time level indices
+ !
+ INTEGER :: ji, jj, jk
+ INTEGER :: id1, id2 ! local integers
+ !!----------------------------------------------------------------------
+ !
+ IF( ln_rstart ) THEN !* Read the restart file
+ CALL rst_read_open ! open the restart file if necessary
+ !
+ id1 = iom_varid( numror, 'sshb', ldstop = .FALSE. )
+ id2 = iom_varid( numror, 'sshn', ldstop = .FALSE. )
+ !
+ ! ! --------- !
+ ! ! all cases !
+ ! ! --------- !
+ !
+ IF( MIN( id1, id2 ) > 0 ) THEN ! all required arrays exist
+ CALL iom_get( numror, jpdom_auto, 'sshb' , ssh(:,:,Kbb), ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'sshn' , ssh(:,:,Kmm), ldxios = lrxios )
+ ! needed to restart if land processor not computed
+ IF(lwp) write(numout,*) 'qe_rst_read : ssh(:,:,Kbb) and ssh(:,:,Kmm) found in restart files'
+ WHERE ( ssmask(:,:) == 0.0_wp ) !!gm/st ==> sm should not be necessary on ssh when it was required on e3
+ ssh(:,:,Kmm) = 0._wp
+ ssh(:,:,Kbb) = 0._wp
+ END WHERE
+ IF( l_1st_euler ) THEN
+ ssh(:,:,Kbb) = ssh(:,:,Kmm)
+ ENDIF
+ ELSE IF( id1 > 0 ) THEN
+ IF(lwp) write(numout,*) 'qe_rst_read WARNING : ssh(:,:,Kmm) not found in restart files'
+ IF(lwp) write(numout,*) 'sshn set equal to sshb.'
+ IF(lwp) write(numout,*) 'neuler is forced to 0'
+ CALL iom_get( numror, jpdom_auto, 'sshb', ssh(:,:,Kbb), ldxios = lrxios )
+ ssh(:,:,Kmm) = ssh(:,:,Kbb)
+ l_1st_euler = .TRUE.
+ ELSE IF( id2 > 0 ) THEN
+ IF(lwp) write(numout,*) 'qe_rst_read WARNING : ssh(:,:,Kbb) not found in restart files'
+ IF(lwp) write(numout,*) 'sshb set equal to sshn.'
+ IF(lwp) write(numout,*) 'neuler is forced to 0'
+ CALL iom_get( numror, jpdom_auto, 'sshn', ssh(:,:,Kmm), ldxios = lrxios )
+ ssh(:,:,Kbb) = ssh(:,:,Kmm)
+ l_1st_euler = .TRUE.
+ ELSE
+ IF(lwp) write(numout,*) 'qe_rst_read WARNING : ssh(:,:,Kmm) not found in restart file'
+ IF(lwp) write(numout,*) 'ssh_b and ssh_n set to zero'
+ IF(lwp) write(numout,*) 'neuler is forced to 0'
+ ssh(:,:,:) = 0._wp
+ l_1st_euler = .TRUE.
+ ENDIF
+ !
+ ELSE !* Initialize at "rest"
+ !
+ IF( ll_wd ) THEN ! MJB ll_wd edits start here - these are essential
+ !
+ IF( cn_cfg == 'wad' ) THEN ! Wetting and drying test case
+ CALL usr_def_istate( gdept(:,:,:,Kbb), tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb), ssh(:,:,Kbb) )
+ ts (:,:,:,:,Kmm) = ts (:,:,:,:,Kbb) ! set now values from to before ones
+ ssh(:,: ,Kmm) = ssh(:,: ,Kbb)
+ uu (:,:,: ,Kmm) = uu (:,:,: ,Kbb)
+ vv (:,:,: ,Kmm) = vv (:,:,: ,Kbb)
+ ELSE ! if not test case
+ ssh(:,:,Kmm) = -ssh_ref
+ ssh(:,:,Kbb) = -ssh_ref
+ !
+ DO_2D( 1, 1, 1, 1 )
+ IF( ht_0(ji,jj)-ssh_ref < rn_wdmin1 ) THEN ! if total depth is less than min depth
+ ssh(ji,jj,Kbb) = rn_wdmin1 - (ht_0(ji,jj) )
+ ssh(ji,jj,Kmm) = rn_wdmin1 - (ht_0(ji,jj) )
+ ENDIF
+ END_2D
+ ENDIF
+
+ DO ji = 1, jpi
+ DO jj = 1, jpj
+ IF ( ht_0(ji,jj) .LE. 0.0 .AND. NINT( ssmask(ji,jj) ) .EQ. 1) THEN
+ CALL ctl_stop( 'qe_rst_read: ht_0 must be positive at potentially wet points' )
+ ENDIF
+ END DO
+ END DO
+ !
+ ELSE
+ !
+ ! Just to read set ssh in fact, called latter once vertical grid
+ ! is set up:
+! CALL usr_def_istate( gdept_0, tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb), ssh(:,:,Kbb) )
+! !
+ ssh(:,:,:) = 0._wp
+ !
+ ENDIF ! end of ll_wd edits
+ !
+ ENDIF
+ !
+ END SUBROUTINE qe_rst_read
+
+
+ SUBROUTINE dom_qco_ctl
+ !!---------------------------------------------------------------------
+ !! *** ROUTINE dom_qco_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
+ !!----------------------------------------------------------------------
+ !
+ 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_qco_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
+ 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(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_qco_ctl
+
+ !!======================================================================
+END MODULE domqco
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/DOM/domutl.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/DOM/domutl.F90 (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/DOM/domutl.F90 (revision 13540)
@@ -0,0 +1,113 @@
+MODULE domutl
+ !!======================================================================
+ !! *** MODULE domutl ***
+ !! Grid utilities:
+ !!======================================================================
+ !! History : 4.2 ! 2020-04 (S. Masson) Original code
+ !!----------------------------------------------------------------------
+
+ !!----------------------------------------------------------------------
+ !! dom_ngb : find the closest grid point from a given lon/lat position
+ !! dom_uniq : identify unique point of a grid (TUVF)
+ !!----------------------------------------------------------------------
+ !
+ USE dom_oce ! ocean space and time domain
+ !
+ USE in_out_manager ! I/O manager
+ USE lbclnk ! ocean lateral boundary conditions (or mpp link)
+ USE lib_mpp ! for mppsum
+
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC dom_ngb ! routine called in iom.F90 module
+ PUBLIC dom_uniq ! Called by dommsk and domwri
+
+ !!----------------------------------------------------------------------
+ !! NEMO/OCE 4.2 , NEMO Consortium (2020)
+ !! $Id$
+ !! Software governed by the CeCILL license (see ./LICENSE)
+ !!----------------------------------------------------------------------
+CONTAINS
+
+ SUBROUTINE dom_ngb( plon, plat, kii, kjj, cdgrid, kkk )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE dom_ngb ***
+ !!
+ !! ** Purpose : find the closest grid point from a given lon/lat position
+ !!
+ !! ** Method : look for minimum distance in cylindrical projection
+ !! -> not good if located at too high latitude...
+ !!----------------------------------------------------------------------
+ REAL(wp) , INTENT(in ) :: plon, plat ! longitude,latitude of the point
+ INTEGER , INTENT( out) :: kii, kjj ! i-,j-index of the closes grid point
+ INTEGER , INTENT(in ), OPTIONAL :: kkk ! k-index of the mask level used
+ CHARACTER(len=1), INTENT(in ) :: cdgrid ! grid name 'T', 'U', 'V', 'W'
+ !
+ INTEGER :: ik ! working level
+ INTEGER , DIMENSION(2) :: iloc
+ REAL(wp) :: zlon, zmini
+ REAL(wp), DIMENSION(jpi,jpj) :: zglam, zgphi, zdist
+ LOGICAL , DIMENSION(jpi,jpj) :: llmsk
+ !!--------------------------------------------------------------------
+ !
+ ik = 1
+ IF ( PRESENT(kkk) ) ik=kkk
+ !
+ SELECT CASE( cdgrid )
+ CASE( 'U' ) ; zglam(:,:) = glamu(:,:) ; zgphi(:,:) = gphiu(:,:) ; llmsk(:,:) = tmask_h(:,:) * umask(:,:,ik) == 1._wp
+ CASE( 'V' ) ; zglam(:,:) = glamv(:,:) ; zgphi(:,:) = gphiv(:,:) ; llmsk(:,:) = tmask_h(:,:) * vmask(:,:,ik) == 1._wp
+ CASE( 'F' ) ; zglam(:,:) = glamf(:,:) ; zgphi(:,:) = gphif(:,:) ; llmsk(:,:) = tmask_h(:,:) * fmask(:,:,ik) == 1._wp
+ CASE DEFAULT; zglam(:,:) = glamt(:,:) ; zgphi(:,:) = gphit(:,:) ; llmsk(:,:) = tmask_h(:,:) * tmask(:,:,ik) == 1._wp
+ END SELECT
+ !
+ zlon = MOD( plon + 720., 360. ) ! plon between 0 and 360
+ zglam(:,:) = MOD( zglam(:,:) + 720., 360. ) ! glam between 0 and 360
+ IF( zlon > 270. ) zlon = zlon - 360. ! zlon between -90 and 270
+ IF( zlon < 90. ) WHERE( zglam(:,:) > 180. ) zglam(:,:) = zglam(:,:) - 360. ! glam between -180 and 180
+ zglam(:,:) = zglam(:,:) - zlon
+ !
+ zgphi(:,:) = zgphi(:,:) - plat
+ zdist(:,:) = zglam(:,:) * zglam(:,:) + zgphi(:,:) * zgphi(:,:)
+ !
+ CALL mpp_minloc( 'domngb', zdist(:,:), llmsk, zmini, iloc, ldhalo = .TRUE. )
+ kii = iloc(1)
+ kjj = iloc(2)
+ !
+ END SUBROUTINE dom_ngb
+
+
+ SUBROUTINE dom_uniq( puniq, cdgrd )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE dom_uniq ***
+ !!
+ !! ** Purpose : identify unique point of a grid (TUVF)
+ !!
+ !! ** Method : 1) aplly lbc_lnk on an array with different values for each element
+ !! 2) check which elements have been changed
+ !!----------------------------------------------------------------------
+ CHARACTER(len=1) , INTENT(in ) :: cdgrd !
+ REAL(wp), DIMENSION(:,:), INTENT(inout) :: puniq !
+ !
+ REAL(wp) :: zshift ! shift value link to the process number
+ INTEGER :: ji ! dummy loop indices
+ LOGICAL , DIMENSION(jpi,jpj,1) :: lluniq ! store whether each point is unique or not
+ REAL(wp), DIMENSION(jpi,jpj ) :: ztstref
+ !!----------------------------------------------------------------------
+ !
+ ! build an array with different values for each element
+ ! in mpp: make sure that these values are different even between process
+ ! -> apply a shift value according to the process number
+ zshift = jpimax * jpjmax * ( narea - 1 )
+ ztstref(:,:) = RESHAPE( (/ (zshift + REAL(ji,wp), ji = 1, jpi*jpj) /), (/ jpi, jpj /) )
+ !
+ puniq(:,:) = ztstref(:,:) ! default definition
+ CALL lbc_lnk( 'domwri', puniq, cdgrd, 1. ) ! apply boundary conditions
+ lluniq(:,:,1) = puniq(:,:) == ztstref(:,:) ! check which values have not been changed
+ !
+ puniq(:,:) = REAL( COUNT( lluniq(:,:,:), dim = 3 ), wp )
+ !
+ END SUBROUTINE dom_uniq
+
+ !!======================================================================
+END MODULE domutl
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/DOM/domvvl.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/DOM/domvvl.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/DOM/domvvl.F90 (revision 13540)
@@ -9,14 +9,7 @@
!! 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
+ !! 4.x ! 2020-02 (G. Madec, S. Techene) introduce ssh to h0 ratio
!!----------------------------------------------------------------------
- !!----------------------------------------------------------------------
- !! 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
- !!----------------------------------------------------------------------
USE oce ! ocean dynamics and tracers
USE phycst ! physical constant
@@ -36,10 +29,4 @@
PRIVATE
- 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
-
! !!* Namelist nam_vvl
LOGICAL , PUBLIC :: ln_vvl_zstar = .FALSE. ! zstar vertical coordinate
@@ -63,4 +50,28 @@
REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:) :: frq_rst_hdv ! retoring period for low freq. divergence
+#if defined key_qco
+ !!----------------------------------------------------------------------
+ !! 'key_qco' EMPTY MODULE Quasi-Eulerian vertical coordonate
+ !!----------------------------------------------------------------------
+#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"
@@ -135,5 +146,6 @@
!
END SUBROUTINE dom_vvl_init
- !
+
+
SUBROUTINE dom_vvl_zgr(Kbb, Kmm, Kaa)
!!----------------------------------------------------------------------
@@ -190,5 +202,5 @@
gdept(:,:,1,Kbb) = 0.5_wp * e3w(:,:,1,Kbb)
gdepw(:,:,1,Kbb) = 0.0_wp
- DO_3D_11_11( 2, jpk )
+ DO_3D( 1, 1, 1, 1, 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)
@@ -238,5 +250,5 @@
ENDIF
IF ( ln_vvl_zstar_at_eqtor ) THEN ! use z-star in vicinity of the Equator
- DO_2D_11_11
+ 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
@@ -261,6 +273,6 @@
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 ; ii1 = 111
- ij0 = 128 ; ij1 = 135 ;
+ 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
@@ -322,5 +334,6 @@
LOGICAL :: ll_do_bclinic ! local logical
REAL(wp), DIMENSION(jpi,jpj) :: zht, z_scale, zwu, zwv, zhdiv
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t
+ REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ze3t
+ LOGICAL , DIMENSION(:,:,:), ALLOCATABLE :: llmsk
!!----------------------------------------------------------------------
!
@@ -407,5 +420,5 @@
zwu(:,:) = 0._wp
zwv(:,:) = 0._wp
- DO_3D_10_10( 1, jpkm1 )
+ DO_3D( 1, 0, 1, 0, 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) )
@@ -415,14 +428,14 @@
zwv(ji,jj) = zwv(ji,jj) + vn_td(ji,jj,jk)
END_3D
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 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_00_00( 1, jpkm1 )
+ 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
+ ! ! d - thickness diffusion transport: boundary conditions
! (stored for tracer advction and continuity equation)
CALL lbc_lnk_multi( 'domvvl', un_td , 'U' , -1._wp, vn_td , 'V' , -1._wp)
@@ -435,25 +448,21 @@
! Maximum deformation control
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~
- ze3t(:,:,jpk) = 0._wp
- DO jk = 1, jpkm1
- ze3t(:,:,jk) = tilde_e3t_a(:,:,jk) / e3t_0(:,:,jk) * tmask(:,:,jk) * tmask_i(:,:)
- END DO
- z_tmax = MAXVAL( ze3t(:,:,:) )
- CALL mpp_max( 'domvvl', z_tmax ) ! max over the global domain
- z_tmin = MINVAL( ze3t(:,:,:) )
- CALL mpp_min( 'domvvl', z_tmin ) ! min over the global domain
+ 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:Nis1,:,:) = .FALSE. ! exclude halos from the checked region
+ llmsk(Nie1: jpi,:,:) = .FALSE.
+ llmsk(:, 1:Njs1,:) = .FALSE.
+ llmsk(:,Nje1: 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
- IF( lk_mpp ) THEN
- CALL mpp_maxloc( 'domvvl', ze3t, tmask, z_tmax, ijk_max )
- CALL mpp_minloc( 'domvvl', ze3t, tmask, z_tmin, ijk_min )
- ELSE
- ijk_max = MAXLOC( ze3t(:,:,:) )
- ijk_max(1) = ijk_max(1) + nimpp - 1
- ijk_max(2) = ijk_max(2) + njmpp - 1
- ijk_min = MINLOC( ze3t(:,:,:) )
- ijk_min(1) = ijk_min(1) + nimpp - 1
- ijk_min(2) = ijk_min(2) + njmpp - 1
- ENDIF
+ 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
@@ -464,4 +473,5 @@
ENDIF
ENDIF
+ DEALLOCATE( ze3t, llmsk )
! - ML - end test
! - ML - Imposing these limits will cause a baroclinicity error which is corrected for below
@@ -647,5 +657,5 @@
gdepw(:,:,1,Kmm) = 0.0_wp
gde3w(:,:,1) = gdept(:,:,1,Kmm) - ssh(:,:,Kmm)
- DO_3D_11_11( 2, jpk )
+ DO_3D( 1, 1, 1, 1, 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
@@ -702,5 +712,5 @@
!
CASE( 'U' ) !* from T- to U-point : hor. surface weighted mean
- DO_3D_10_10( 1, jpk )
+ 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) ) &
@@ -711,5 +721,5 @@
!
CASE( 'V' ) !* from T- to V-point : hor. surface weighted mean
- DO_3D_10_10( 1, jpk )
+ 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) ) &
@@ -720,5 +730,5 @@
!
CASE( 'F' ) !* from U-point to F-point : hor. surface weighted mean
- DO_3D_10_10( 1, jpk )
+ DO_3D( 1, 0, 1, 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) &
@@ -793,5 +803,5 @@
IF( ln_rstart ) THEN !* Read the restart file
CALL rst_read_open ! open the restart file if necessary
- CALL iom_get( numror, jpdom_autoglo, 'sshn' , ssh(:,:,Kmm), ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'sshn' , ssh(:,:,Kmm), ldxios = lrxios )
!
id1 = iom_varid( numror, 'e3t_b', ldstop = .FALSE. )
@@ -806,6 +816,6 @@
!
IF( MIN( id1, id2 ) > 0 ) THEN ! all required arrays exist
- CALL iom_get( numror, jpdom_autoglo, 'e3t_b', e3t(:,:,:,Kbb), ldxios = lrxios )
- CALL iom_get( numror, jpdom_autoglo, 'e3t_n', e3t(:,:,:,Kmm), ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb), ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm), ldxios = lrxios )
! needed to restart if land processor not computed
IF(lwp) write(numout,*) 'dom_vvl_rst : e3t(:,:,:,Kbb) and e3t(:,:,:,Kmm) found in restart files'
@@ -821,5 +831,5 @@
IF(lwp) write(numout,*) 'e3t_n set equal to e3t_b.'
IF(lwp) write(numout,*) 'l_1st_euler is forced to true'
- CALL iom_get( numror, jpdom_autoglo, 'e3t_b', e3t(:,:,:,Kbb), ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb), ldxios = lrxios )
e3t(:,:,:,Kmm) = e3t(:,:,:,Kbb)
l_1st_euler = .true.
@@ -828,5 +838,5 @@
IF(lwp) write(numout,*) 'e3t_b set equal to e3t_n.'
IF(lwp) write(numout,*) 'l_1st_euler is forced to true'
- CALL iom_get( numror, jpdom_autoglo, 'e3t_n', e3t(:,:,:,Kmm), ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm), ldxios = lrxios )
e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm)
l_1st_euler = .true.
@@ -853,6 +863,6 @@
! ! ----------------------- !
IF( MIN( id3, id4 ) > 0 ) THEN ! all required arrays exist
- CALL iom_get( numror, jpdom_autoglo, 'tilde_e3t_b', tilde_e3t_b(:,:,:), ldxios = lrxios )
- CALL iom_get( numror, jpdom_autoglo, 'tilde_e3t_n', tilde_e3t_n(:,:,:), ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'tilde_e3t_b', tilde_e3t_b(:,:,:), ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'tilde_e3t_n', tilde_e3t_n(:,:,:), ldxios = lrxios )
ELSE ! one at least array is missing
tilde_e3t_b(:,:,:) = 0.0_wp
@@ -863,5 +873,5 @@
! ! ------------ !
IF( id5 > 0 ) THEN ! required array exists
- CALL iom_get( numror, jpdom_autoglo, 'hdiv_lf', hdiv_lf(:,:,:), ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'hdiv_lf', hdiv_lf(:,:,:), ldxios = lrxios )
ELSE ! array is missing
hdiv_lf(:,:,:) = 0.0_wp
@@ -887,5 +897,5 @@
ssh(:,:,Kbb) = -ssh_ref
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
IF( ht_0(ji,jj)-ssh_ref < rn_wdmin1 ) THEN ! if total depth is less than min depth
ssh(ji,jj,Kbb) = rn_wdmin1 - (ht_0(ji,jj) )
@@ -903,11 +913,9 @@
e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm)
- DO ji = 1, jpi
- DO jj = 1, jpj
- IF ( ht_0(ji,jj) .LE. 0.0 .AND. NINT( ssmask(ji,jj) ) .EQ. 1) THEN
- CALL ctl_stop( 'dom_vvl_rst: ht_0 must be positive at potentially wet points' )
- ENDIF
- END DO
- END DO
+ DO_2D( 1, 1, 1, 1 )
+ IF ( ht_0(ji,jj) .LE. 0.0 .AND. NINT( ssmask(ji,jj) ) .EQ. 1) THEN
+ CALL ctl_stop( 'dom_vvl_rst: ht_0 must be positive at potentially wet points' )
+ ENDIF
+ END_2D
!
ELSE
@@ -1031,4 +1039,6 @@
END SUBROUTINE dom_vvl_ctl
+#endif
+
!!======================================================================
END MODULE domvvl
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/DOM/domwri.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/DOM/domwri.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/DOM/domwri.F90 (revision 13540)
@@ -13,9 +13,9 @@
!!----------------------------------------------------------------------
!! dom_wri : create and write mesh and mask file(s)
- !! dom_uniq : identify unique point of a grid (TUVF)
!! dom_stiff : diagnose maximum grid stiffness/hydrostatic consistency (s-coordinate)
!!----------------------------------------------------------------------
!
USE dom_oce ! ocean space and time domain
+ USE domutl !
USE phycst , ONLY : rsmall
USE wet_dry, ONLY : ll_wd ! Wetting and drying
@@ -74,10 +74,4 @@
! ! ============================
CALL iom_open( TRIM(clnam), inum, ldwrt = .TRUE. )
- !
- ! ! global domain size
- CALL iom_rstput( 0, 0, inum, 'jpiglo', REAL( jpiglo, wp), ktype = jp_i4 )
- CALL iom_rstput( 0, 0, inum, 'jpjglo', REAL( jpjglo, wp), ktype = jp_i4 )
- CALL iom_rstput( 0, 0, inum, 'jpkglo', REAL( jpkglo, wp), ktype = jp_i4 )
-
! ! domain characteristics
CALL iom_rstput( 0, 0, inum, 'jperio', REAL( jperio, wp), ktype = jp_i4 )
@@ -100,15 +94,15 @@
CALL dom_uniq( zprw, 'T' )
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
zprt(ji,jj) = ssmask(ji,jj) * zprw(ji,jj) ! ! unique point mask
END_2D
CALL iom_rstput( 0, 0, inum, 'tmaskutil', zprt, ktype = jp_i1 )
CALL dom_uniq( zprw, 'U' )
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
zprt(ji,jj) = ssumask(ji,jj) * zprw(ji,jj) ! ! unique point mask
END_2D
CALL iom_rstput( 0, 0, inum, 'umaskutil', zprt, ktype = jp_i1 )
CALL dom_uniq( zprw, 'V' )
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
zprt(ji,jj) = ssvmask(ji,jj) * zprw(ji,jj) ! ! unique point mask
END_2D
@@ -182,39 +176,4 @@
! ! ============================
END SUBROUTINE dom_wri
-
-
- SUBROUTINE dom_uniq( puniq, cdgrd )
- !!----------------------------------------------------------------------
- !! *** ROUTINE dom_uniq ***
- !!
- !! ** Purpose : identify unique point of a grid (TUVF)
- !!
- !! ** Method : 1) aplly lbc_lnk on an array with different values for each element
- !! 2) check which elements have been changed
- !!----------------------------------------------------------------------
- CHARACTER(len=1) , INTENT(in ) :: cdgrd !
- REAL(wp), DIMENSION(:,:), INTENT(inout) :: puniq !
- !
- REAL(wp) :: zshift ! shift value link to the process number
- INTEGER :: ji ! dummy loop indices
- LOGICAL, DIMENSION(SIZE(puniq,1),SIZE(puniq,2),1) :: lldbl ! store whether each point is unique or not
- REAL(wp), DIMENSION(jpi,jpj) :: ztstref
- !!----------------------------------------------------------------------
- !
- ! build an array with different values for each element
- ! in mpp: make sure that these values are different even between process
- ! -> apply a shift value according to the process number
- zshift = jpi * jpj * ( narea - 1 )
- ztstref(:,:) = RESHAPE( (/ (zshift + REAL(ji,wp), ji = 1, jpi*jpj) /), (/ jpi, jpj /) )
- !
- puniq(:,:) = ztstref(:,:) ! default definition
- CALL lbc_lnk( 'domwri', puniq, cdgrd, 1. ) ! apply boundary conditions
- lldbl(:,:,1) = puniq(:,:) == ztstref(:,:) ! check which values have been changed
- !
- puniq(:,:) = 1. ! default definition
- ! fill only the inner part of the cpu with llbl converted into real
- puniq(nldi:nlei,nldj:nlej) = REAL( COUNT( lldbl(nldi:nlei,nldj:nlej,:), dim = 3 ) , wp )
- !
- END SUBROUTINE dom_uniq
@@ -270,5 +229,5 @@
END DO
END DO
- CALL lbc_lnk( 'domwri', zx1, 'T', 1. )
+ CALL lbc_lnk( 'domwri', zx1, 'T', 1.0_wp )
!
IF( PRESENT( px1 ) ) px1 = zx1
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/DOM/domzgr.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/DOM/domzgr.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/DOM/domzgr.F90 (revision 13540)
@@ -75,4 +75,5 @@
INTEGER :: ioptio, ibat, ios ! local integer
REAL(wp) :: zrefdep ! depth of the reference level (~10m)
+ REAL(wp), DIMENSION(jpi,jpj) :: zmsk
!!----------------------------------------------------------------------
!
@@ -109,4 +110,21 @@
!
ENDIF
+ !
+ ! the following is mandatory
+ ! make sure that closed boundaries are correctly defined in k_top that will be used to compute all mask arrays
+ !
+ zmsk(:,:) = 1._wp ! default: no closed boundaries
+ IF( jperio == 0 .OR. jperio == 2 .OR. jperio == 3 .OR. jperio == 5 ) 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
+ ENDIF
+ IF( .NOT. ( jperio == 2 .OR. jperio == 7 ) ) THEN ! S closed
+ zmsk(:,mj0( 1+nn_hls):mj1( 1+nn_hls) ) = 0._wp ! first line of inner global domain at 0
+ ENDIF
+ IF( jperio == 0 .OR. jperio == 1 ) THEN ! N closed
+ zmsk(:,mj0(jpjglo-nn_hls):mj1(jpjglo-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(:,:) )
!
!!gm to be remove when removing the OLD definition of e3 scale factors so that gde3w disappears
@@ -150,5 +168,5 @@
!
! ! ice shelf draft and bathymetry
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
ikt = mikt(ji,jj)
ikb = mbkt(ji,jj)
@@ -164,5 +182,5 @@
!!gm end bug
!
- IF( nprint == 1 .AND. lwp ) THEN
+ 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(:,:) )
@@ -236,11 +254,11 @@
CALL iom_get( inum, jpdom_unknown, 'e3w_1d' , pe3w_1d )
!
- CALL iom_get( inum, jpdom_data, 'e3t_0' , pe3t , lrowattr=ln_use_jattr ) ! 3D coordinate
- CALL iom_get( inum, jpdom_data, 'e3u_0' , pe3u , lrowattr=ln_use_jattr )
- CALL iom_get( inum, jpdom_data, 'e3v_0' , pe3v , lrowattr=ln_use_jattr )
- CALL iom_get( inum, jpdom_data, 'e3f_0' , pe3f , lrowattr=ln_use_jattr )
- CALL iom_get( inum, jpdom_data, 'e3w_0' , pe3w , lrowattr=ln_use_jattr )
- CALL iom_get( inum, jpdom_data, 'e3uw_0' , pe3uw , lrowattr=ln_use_jattr )
- CALL iom_get( inum, jpdom_data, 'e3vw_0' , pe3vw , lrowattr=ln_use_jattr )
+ CALL iom_get( inum, jpdom_global, 'e3t_0' , pe3t , cd_type = 'T', psgn = 1._wp, kfill = jpfillcopy ) ! 3D coordinate
+ CALL iom_get( inum, jpdom_global, 'e3u_0' , pe3u , cd_type = 'U', psgn = 1._wp, kfill = jpfillcopy )
+ CALL iom_get( inum, jpdom_global, 'e3v_0' , pe3v , cd_type = 'V', psgn = 1._wp, kfill = jpfillcopy )
+ CALL iom_get( inum, jpdom_global, 'e3f_0' , pe3f , cd_type = 'F', psgn = 1._wp, kfill = jpfillcopy )
+ CALL iom_get( inum, jpdom_global, 'e3w_0' , pe3w , cd_type = 'W', psgn = 1._wp, kfill = jpfillcopy )
+ CALL iom_get( inum, jpdom_global, 'e3uw_0' , pe3uw, cd_type = 'U', psgn = 1._wp, kfill = jpfillcopy )
+ CALL iom_get( inum, jpdom_global, 'e3vw_0' , pe3vw, cd_type = 'V', psgn = 1._wp, kfill = jpfillcopy )
!
! !* depths
@@ -254,6 +272,6 @@
CALL iom_get( inum, jpdom_unknown, 'gdept_1d', pdept_1d )
CALL iom_get( inum, jpdom_unknown, 'gdepw_1d', pdepw_1d )
- CALL iom_get( inum, jpdom_data , 'gdept_0' , pdept , lrowattr=ln_use_jattr )
- CALL iom_get( inum, jpdom_data , 'gdepw_0' , pdepw , lrowattr=ln_use_jattr )
+ CALL iom_get( inum, jpdom_global , 'gdept_0' , pdept, kfill = jpfillcopy )
+ CALL iom_get( inum, jpdom_global , 'gdepw_0' , pdepw, kfill = jpfillcopy )
!
ELSE !- depths computed from e3. scale factors
@@ -269,7 +287,7 @@
!
! !* ocean top and bottom level
- CALL iom_get( inum, jpdom_data, 'top_level' , z2d , lrowattr=ln_use_jattr ) ! 1st wet T-points (ISF)
+ CALL iom_get( inum, jpdom_global, 'top_level' , z2d ) ! 1st wet T-points (ISF)
k_top(:,:) = NINT( z2d(:,:) )
- CALL iom_get( inum, jpdom_data, 'bottom_level' , z2d , lrowattr=ln_use_jattr ) ! last wet T-points
+ CALL iom_get( inum, jpdom_global, 'bottom_level' , z2d ) ! last wet T-points
k_bot(:,:) = NINT( z2d(:,:) )
!
@@ -313,5 +331,5 @@
! ! N.B. top k-index of W-level = mikt
! ! bottom k-index of W-level = mbkt+1
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
miku(ji,jj) = MAX( mikt(ji+1,jj ) , mikt(ji,jj) )
mikv(ji,jj) = MAX( mikt(ji ,jj+1) , mikt(ji,jj) )
@@ -322,10 +340,10 @@
END_2D
! converte into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk
- zk(:,:) = REAL( miku(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'U', 1. ) ; miku(:,:) = MAX( NINT( zk(:,:) ), 1 )
- zk(:,:) = REAL( mikv(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'V', 1. ) ; mikv(:,:) = MAX( NINT( zk(:,:) ), 1 )
- zk(:,:) = REAL( mikf(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'F', 1. ) ; mikf(:,:) = MAX( NINT( zk(:,:) ), 1 )
- !
- zk(:,:) = REAL( mbku(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'U', 1. ) ; mbku(:,:) = MAX( NINT( zk(:,:) ), 1 )
- zk(:,:) = REAL( mbkv(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'V', 1. ) ; mbkv(:,:) = MAX( NINT( zk(:,:) ), 1 )
+ zk(:,:) = REAL( miku(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'U', 1.0_wp ) ; miku(:,:) = MAX( NINT( zk(:,:) ), 1 )
+ zk(:,:) = REAL( mikv(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'V', 1.0_wp ) ; mikv(:,:) = MAX( NINT( zk(:,:) ), 1 )
+ zk(:,:) = REAL( mikf(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'F', 1.0_wp ) ; mikf(:,:) = MAX( NINT( zk(:,:) ), 1 )
+ !
+ zk(:,:) = REAL( mbku(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'U', 1.0_wp ) ; mbku(:,:) = MAX( NINT( zk(:,:) ), 1 )
+ zk(:,:) = REAL( mbkv(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'V', 1.0_wp ) ; mbkv(:,:) = MAX( NINT( zk(:,:) ), 1 )
!
END SUBROUTINE zgr_top_bot
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/DOM/domzgr_substitute.h90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/DOM/domzgr_substitute.h90 (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/DOM/domzgr_substitute.h90 (revision 13540)
@@ -0,0 +1,30 @@
+!!----------------------------------------------------------------------
+!! *** domzgr_substitute.h90 ***
+!!----------------------------------------------------------------------
+!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale
+!! factors depending on the vertical coord. used, using CPP macro.
+!!----------------------------------------------------------------------
+!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate
+!!----------------------------------------------------------------------
+!! 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)*fmask(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)+ssh(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)))
+# 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))
+#endif
+!!----------------------------------------------------------------------
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/DOM/dtatsd.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/DOM/dtatsd.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/DOM/dtatsd.F90 (revision 13540)
@@ -153,6 +153,6 @@
IF( nn_cfg == 2 .AND. ln_tsd_dmp ) THEN ! some hand made alterations
!
- ij0 = 101 ; ij1 = 109 ! Reduced T & S in the Alboran Sea
- ii0 = 141 ; ii1 = 155
+ 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
DO jj = mj0(ij0), mj1(ij1)
DO ji = mi0(ii0), mi1(ii1)
@@ -167,6 +167,6 @@
END DO
END DO
- ij0 = 87 ; ij1 = 96 ! Reduced temperature in Red Sea
- ii0 = 148 ; ii1 = 160
+ 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
@@ -186,5 +186,5 @@
ENDIF
!
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 ) ! 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)
@@ -219,5 +219,5 @@
!
IF( ln_zps ) THEN ! zps-coordinate (partial steps) interpolation at the last ocean level
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
ik = mbkt(ji,jj)
IF( ik > 1 ) THEN
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/DOM/istate.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/DOM/istate.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/DOM/istate.F90 (revision 13540)
@@ -24,5 +24,4 @@
USE dom_oce ! ocean space and time domain
USE daymod ! calendar
- USE divhor ! horizontal divergence (div_hor routine)
USE dtatsd ! data temperature and salinity (dta_tsd routine)
USE dtauvd ! data: U & V current (dta_uvd routine)
@@ -35,4 +34,8 @@
USE lib_mpp ! MPP library
USE restart ! restart
+#if defined key_agrif
+ USE agrif_oce_interp
+ USE agrif_oce
+#endif
IMPLICIT NONE
@@ -43,4 +46,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -59,4 +63,5 @@
!
INTEGER :: ji, jj, jk ! dummy loop indices
+ REAL(wp), DIMENSION(jpi,jpj,jpk) :: zgdept ! 3D table !!st patch to use gdept subtitute
!!gm see comment further down
REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: zuvd ! U & V data workspace
@@ -70,5 +75,5 @@
!!gm Why not include in the first call of dta_tsd ?
!!gm probably associated with the use of internal damping...
- CALL dta_tsd_init ! Initialisation of T & S input data
+ CALL dta_tsd_init ! Initialisation of T & S input data
!!gm to be moved in usrdef of C1D case
! IF( lk_c1d ) CALL dta_uvd_init ! Initialization of U & V input data
@@ -84,4 +89,17 @@
#endif
+#if defined key_agrif
+ IF ( (.NOT.Agrif_root()).AND.ln_init_chfrpar ) THEN
+ numror = 0 ! define numror = 0 -> no restart file to read
+ ln_1st_euler = .true. ! Set time-step indicator at nit000 (euler forward)
+ CALL day_init
+ CALL agrif_istate( Kbb, Kmm, Kaa ) ! Interp from parent
+ !
+ ts (:,:,:,:,Kmm) = ts (:,:,:,:,Kbb)
+ ssh (:,:,Kmm) = ssh(:,:,Kbb)
+ uu (:,:,:,Kmm) = uu (:,:,:,Kbb)
+ vv (:,:,:,Kmm) = vv (:,:,:,Kbb)
+ ELSE
+#endif
IF( ln_rstart ) THEN ! Restart from a file
! ! -------------------
@@ -100,4 +118,7 @@
!
ssh(:,:,Kbb) = 0._wp ! set the ocean at rest
+ uu (:,:,:,Kbb) = 0._wp
+ vv (:,:,:,Kbb) = 0._wp
+ !
IF( ll_wd ) THEN
ssh(:,:,Kbb) = -ssh_ref ! Added in 30 here for bathy that adds 30 as Iterative test CEOD
@@ -105,5 +126,5 @@
! Apply minimum wetdepth criterion
!
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
IF( ht_0(ji,jj) + ssh(ji,jj,Kbb) < rn_wdmin1 ) THEN
ssh(ji,jj,Kbb) = tmask(ji,jj,1)*( rn_wdmin1 - (ht_0(ji,jj)) )
@@ -111,9 +132,10 @@
END_2D
ENDIF
- uu (:,:,:,Kbb) = 0._wp
- vv (:,:,:,Kbb) = 0._wp
- !
+ !
ELSE ! user defined initial T and S
- CALL usr_def_istate( gdept(:,:,:,Kbb), tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb), ssh(:,:,Kbb) )
+ DO jk = 1, jpk
+ zgdept(:,:,jk) = gdept(:,:,jk,Kbb)
+ END DO
+ CALL usr_def_istate( zgdept, tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb), ssh(:,:,Kbb) )
ENDIF
ts (:,:,:,:,Kmm) = ts (:,:,:,:,Kbb) ! set now values from to before ones
@@ -121,11 +143,8 @@
uu (:,:,:,Kmm) = uu (:,:,:,Kbb)
vv (:,:,:,Kmm) = vv (:,:,:,Kbb)
- hdiv(:,:,jpk) = 0._wp ! bottom divergence set one for 0 to zero at jpk level
- CALL div_hor( 0, Kbb, Kmm ) ! compute interior hdiv value
-!!gm hdiv(:,:,:) = 0._wp
!!gm POTENTIAL BUG :
!!gm ISSUE : if ssh(:,:,Kbb) /= 0 then, in non linear free surface, the e3._n, e3._b should be recomputed
-!! as well as gdept and gdepw.... !!!!!
+!! as well as gdept_ and gdepw_.... !!!!!
!! ===>>>> probably a call to domvvl initialisation here....
@@ -151,4 +170,7 @@
!
ENDIF
+#if defined key_agrif
+ ENDIF
+#endif
!
! Initialize "now" and "before" barotropic velocities:
@@ -159,5 +181,5 @@
!
!!gm the use of umsak & vmask is not necessary below as uu(:,:,:,Kmm), vv(:,:,:,Kmm), uu(:,:,:,Kbb), vv(:,:,:,Kbb) are always masked
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 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)
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/divhor.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/divhor.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/divhor.F90 (revision 13540)
@@ -40,4 +40,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -76,5 +77,5 @@
ENDIF
!
- DO_3D_00_00( 1, jpkm1 )
+ 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) &
& - e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm) * uu(ji-1,jj,jk,Kmm) &
@@ -83,13 +84,4 @@
& * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm)
END_3D
- !
-#if defined key_agrif
- IF( .NOT. Agrif_Root() ) THEN
- IF( nbondi == -1 .OR. nbondi == 2 ) hdiv( 2 , : ,:) = 0._wp ! west
- IF( nbondi == 1 .OR. nbondi == 2 ) hdiv( nlci-1, : ,:) = 0._wp ! east
- IF( nbondj == -1 .OR. nbondj == 2 ) hdiv( : , 2 ,:) = 0._wp ! south
- IF( nbondj == 1 .OR. nbondj == 2 ) hdiv( : ,nlcj-1,:) = 0._wp ! north
- ENDIF
-#endif
!
IF( ln_rnf ) CALL sbc_rnf_div( hdiv, Kmm ) !== runoffs ==! (update hdiv field)
@@ -102,5 +94,5 @@
IF( ln_isf ) CALL isf_hdiv( kt, Kmm, hdiv ) !== ice shelf ==! (update hdiv field)
!
- CALL lbc_lnk( 'divhor', hdiv, 'T', 1. ) ! (no sign change)
+ CALL lbc_lnk( 'divhor', hdiv, 'T', 1.0_wp ) ! (no sign change)
!
IF( ln_timing ) CALL timing_stop('div_hor')
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/dynadv_cen2.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/dynadv_cen2.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/dynadv_cen2.F90 (revision 13540)
@@ -28,4 +28,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -71,5 +72,5 @@
zfu(:,:,jk) = 0.25_wp * e2u(:,:) * e3u(:,:,jk,Kmm) * puu(:,:,jk,Kmm)
zfv(:,:,jk) = 0.25_wp * e1v(:,:) * e3v(:,:,jk,Kmm) * pvv(:,:,jk,Kmm)
- DO_2D_10_10
+ 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) )
@@ -77,9 +78,11 @@
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) )
END_2D
- DO_2D_00_00
+ 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)
+ & + 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)
+ & + zfv_t(ji,jj+1,jk) - zfv_t(ji ,jj,jk) ) * r1_e1e2v(ji,jj) &
+ & / e3v(ji,jj,jk,Kmm)
END_2D
END DO
@@ -95,10 +98,10 @@
! !== Vertical advection ==!
!
- DO_2D_00_00
+ 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
END_2D
IF( ln_linssh ) THEN ! linear free surface: advection through the surface
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
zfu_uw(ji,jj,1) = 0.5_wp * ( e1e2t(ji,jj) * ww(ji,jj,1) + e1e2t(ji+1,jj) * ww(ji+1,jj,1) ) * puu(ji,jj,1,Kmm)
zfv_vw(ji,jj,1) = 0.5_wp * ( e1e2t(ji,jj) * ww(ji,jj,1) + e1e2t(ji,jj+1) * ww(ji,jj+1,1) ) * pvv(ji,jj,1,Kmm)
@@ -106,15 +109,17 @@
ENDIF
DO jk = 2, jpkm1 ! interior advective fluxes
- DO_2D_01_01
+ DO_2D( 0, 1, 0, 1 ) ! 1/4 * Vertical transport
zfw(ji,jj,jk) = 0.25_wp * e1e2t(ji,jj) * ww(ji,jj,jk)
END_2D
- DO_2D_00_00
+ 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_00_00( 1, jpkm1 )
- 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)
+ 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
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/dynadv_ubs.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/dynadv_ubs.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/dynadv_ubs.F90 (revision 13540)
@@ -34,4 +34,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -107,5 +108,5 @@
zfv(:,:,jk) = e1v(:,:) * e3v(:,:,jk,Kmm) * pvv(:,:,jk,Kmm)
!
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 ) ! laplacian
zlu_uu(ji,jj,jk,1) = ( puu (ji+1,jj ,jk,Kbb) - 2.*puu (ji,jj,jk,Kbb) + puu (ji-1,jj ,jk,Kbb) ) * umask(ji,jj,jk)
zlv_vv(ji,jj,jk,1) = ( pvv (ji ,jj+1,jk,Kbb) - 2.*pvv (ji,jj,jk,Kbb) + pvv (ji ,jj-1,jk,Kbb) ) * vmask(ji,jj,jk)
@@ -123,8 +124,8 @@
END_2D
END DO
- CALL lbc_lnk_multi( 'dynadv_ubs', zlu_uu(:,:,:,1), 'U', 1. , zlu_uv(:,:,:,1), 'U', 1., &
- & zlu_uu(:,:,:,2), 'U', 1. , zlu_uv(:,:,:,2), 'U', 1., &
- & zlv_vv(:,:,:,1), 'V', 1. , zlv_vu(:,:,:,1), 'V', 1., &
- & zlv_vv(:,:,:,2), 'V', 1. , zlv_vu(:,:,:,2), 'V', 1. )
+ CALL lbc_lnk_multi( '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 )
!
! ! ====================== !
@@ -135,5 +136,5 @@
zfv(:,:,jk) = 0.25_wp * e1v(:,:) * e3v(:,:,jk,Kmm) * pvv(:,:,jk,Kmm)
!
- DO_2D_10_10
+ 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) )
@@ -167,9 +168,11 @@
& * ( pvv(ji,jj,jk,Kmm) + pvv(ji+1,jj ,jk,Kmm) - gamma1 * zl_v )
END_2D
- DO_2D_00_00
+ 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)
+ & + 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)
+ & + zfv_t(ji,jj+1,jk) - zfv_t(ji ,jj,jk) ) * r1_e1e2v(ji,jj) &
+ & / e3v(ji,jj,jk,Kmm)
END_2D
END DO
@@ -184,5 +187,5 @@
! ! Vertical advection !
! ! ==================== !
- DO_2D_00_00
+ 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
@@ -191,5 +194,5 @@
END_2D
IF( ln_linssh ) THEN ! constant volume : advection through the surface
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
zfu_uw(ji,jj,1) = 0.5_wp * ( e1e2t(ji,jj) * ww(ji,jj,1) + e1e2t(ji+1,jj) * ww(ji+1,jj,1) ) * puu(ji,jj,1,Kmm)
zfv_vw(ji,jj,1) = 0.5_wp * ( e1e2t(ji,jj) * ww(ji,jj,1) + e1e2t(ji,jj+1) * ww(ji,jj+1,1) ) * pvv(ji,jj,1,Kmm)
@@ -197,15 +200,17 @@
ENDIF
DO jk = 2, jpkm1 ! interior fluxes
- DO_2D_01_01
+ DO_2D( 0, 1, 0, 1 )
zfw(ji,jj,jk) = 0.25_wp * e1e2t(ji,jj) * ww(ji,jj,jk)
END_2D
- DO_2D_00_00
+ 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_00_00( 1, jpkm1 )
- 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)
+ 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
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/dynatf.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/dynatf.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/dynatf.F90 (revision 13540)
@@ -34,5 +34,5 @@
USE dynspg_ts ! surface pressure gradient: split-explicit scheme
USE domvvl ! variable volume
- USE bdy_oce , ONLY: ln_bdy
+ USE bdy_oce , ONLY : ln_bdy
USE bdydta ! ocean open boundary conditions
USE bdydyn ! ocean open boundary conditions
@@ -50,4 +50,5 @@
USE prtctl ! Print control
USE timing ! Timing
+ USE zdfdrg , ONLY : ln_drgice_imp, rCdU_top
#if defined key_agrif
USE agrif_oce_interp
@@ -58,4 +59,21 @@
PUBLIC dyn_atf ! routine called by step.F90
+
+#if defined key_qco
+ !!----------------------------------------------------------------------
+ !! 'key_qco' EMPTY ROUTINE Quasi-Eulerian vertical coordonate
+ !!----------------------------------------------------------------------
+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
@@ -103,4 +121,5 @@
REAL(wp) :: zve3a, zve3n, zve3b, z1_2dt ! - -
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
!!----------------------------------------------------------------------
@@ -148,5 +167,5 @@
# endif
!
- CALL lbc_lnk_multi( 'dynatf', puu(:,:,:,Kaa), 'U', -1., pvv(:,:,:,Kaa), 'V', -1. ) !* local domain boundaries
+ CALL lbc_lnk_multi( 'dynatf', puu(:,:,:,Kaa), 'U', -1.0_wp, pvv(:,:,:,Kaa), 'V', -1.0_wp ) !* local domain boundaries
!
! !* BDY open boundaries
@@ -180,5 +199,5 @@
IF( ln_linssh ) THEN ! Fixed volume !
! ! =============!
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 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) )
@@ -198,4 +217,5 @@
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) &
@@ -215,5 +235,5 @@
CALL dom_vvl_interpol( pe3t(:,:,:,Kmm), pe3u(:,:,:,Kmm), 'U' )
CALL dom_vvl_interpol( pe3t(:,:,:,Kmm), pe3v(:,:,:,Kmm), 'V' )
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 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) )
@@ -226,5 +246,5 @@
CALL dom_vvl_interpol( pe3t(:,:,:,Kmm), ze3u_f, 'U' )
CALL dom_vvl_interpol( pe3t(:,:,:,Kmm), ze3v_f, 'V' )
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
zue3a = pe3u(ji,jj,jk,Kaa) * puu(ji,jj,jk,Kaa)
zve3a = pe3v(ji,jj,jk,Kaa) * pvv(ji,jj,jk,Kaa)
@@ -303,4 +323,32 @@
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 )
@@ -312,4 +360,6 @@
END SUBROUTINE dyn_atf
+#endif
+
!!=========================================================================
END MODULE dynatf
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/dynatf_qco.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/dynatf_qco.F90 (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/dynatf_qco.F90 (revision 13540)
@@ -0,0 +1,237 @@
+MODULE dynatfqco
+ !!=========================================================================
+ !! *** MODULE dynatfqco ***
+ !! 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 -> dynatfLF.F90. Now just does time filtering.
+ !!-------------------------------------------------------------------------
+
+ !!----------------------------------------------------------------------------------------------
+ !! dyn_atf_qco : 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
+#if defined key_agrif
+ USE agrif_oce_interp
+#endif
+
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC dyn_atf_qco ! routine called by step.F90
+
+ !! * Substitutions
+# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
+ !!----------------------------------------------------------------------
+ !! NEMO/OCE 4.0 , NEMO Consortium (2018)
+ !! $Id$
+ !! Software governed by the CeCILL license (see ./LICENSE)
+ !!----------------------------------------------------------------------
+CONTAINS
+
+ SUBROUTINE dyn_atf_qco ( kt, Kbb, Kmm, Kaa, puu, pvv )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE dyn_atf_qco ***
+ !!
+ !! ** 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))
+ !! + 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_lf 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
+ !
+ INTEGER :: ji, jj, jk ! dummy loop indices
+ REAL(wp) :: zue3a, zue3n, zue3b, zcoef ! local scalars
+ REAL(wp) :: zve3a, zve3n, zve3b, z1_2dt ! - -
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zue, zve
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zua, zva
+ !!----------------------------------------------------------------------
+ !
+ IF( ln_timing ) CALL timing_start('dyn_atf_qco')
+ 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_qco : Asselin time filtering'
+ IF(lwp) WRITE(numout,*) '~~~~~~~'
+ ENDIF
+ !
+ 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( 1, 1, 1, 1, 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 !
+ ! ! ================!
+ !
+ IF( ln_dynadv_vec ) THEN ! Asselin filter applied on velocity
+ ! Before filtered scale factor at (u/v)-points
+ DO_3D( 1, 1, 1, 1, 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
+ !
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
+ zue3a = ( 1._wp + r3u(ji,jj,Kaa) * umask(ji,jj,jk) ) * puu(ji,jj,jk,Kaa)
+ zve3a = ( 1._wp + r3v(ji,jj,Kaa) * vmask(ji,jj,jk) ) * pvv(ji,jj,jk,Kaa)
+ zue3n = ( 1._wp + r3u(ji,jj,Kmm) * umask(ji,jj,jk) ) * puu(ji,jj,jk,Kmm)
+ zve3n = ( 1._wp + r3v(ji,jj,Kmm) * vmask(ji,jj,jk) ) * pvv(ji,jj,jk,Kmm)
+ zue3b = ( 1._wp + r3u(ji,jj,Kbb) * umask(ji,jj,jk) ) * puu(ji,jj,jk,Kbb)
+ zve3b = ( 1._wp + r3v(ji,jj,Kbb) * vmask(ji,jj,jk) ) * pvv(ji,jj,jk,Kbb)
+ ! ! filtered scale factor at U-,V-points
+ puu(ji,jj,jk,Kmm) = ( zue3n + rn_atfp * ( zue3b - 2._wp * zue3n + zue3a ) ) / ( 1._wp + r3u_f(ji,jj)*umask(ji,jj,jk) )
+ pvv(ji,jj,jk,Kmm) = ( zve3n + rn_atfp * ( zve3b - 2._wp * zve3n + zve3a ) ) / ( 1._wp + r3v_f(ji,jj)*vmask(ji,jj,jk) )
+ END_3D
+ !
+ ENDIF
+ !
+ 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
+ zue(:,:) = e3u(:,:,1,Kmm) * puu(:,:,1,Kmm) * umask(:,:,1)
+ zve(:,:) = e3v(:,:,1,Kmm) * pvv(:,:,1,Kmm) * vmask(:,:,1)
+ DO jk = 2, jpkm1
+ zue(:,:) = zue(:,:) + e3u(:,:,jk,Kmm) * puu(:,:,jk,Kmm) * umask(:,:,jk)
+ zve(:,:) = zve(:,:) + e3v(:,:,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
+ !
+ ! 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
+ !
+ uu_b(:,:,Kaa) = e3u(:,:,1,Kaa) * puu(:,:,1,Kaa) * umask(:,:,1)
+ uu_b(:,:,Kmm) = e3u(:,:,1,Kmm) * puu(:,:,1,Kmm) * umask(:,:,1)
+ vv_b(:,:,Kaa) = e3v(:,:,1,Kaa) * pvv(:,:,1,Kaa) * vmask(:,:,1)
+ vv_b(:,:,Kmm) = e3v(:,:,1,Kmm) * pvv(:,:,1,Kmm) * vmask(:,:,1)
+ DO jk = 2, jpkm1
+ uu_b(:,:,Kaa) = uu_b(:,:,Kaa) + e3u(:,:,jk,Kaa) * puu(:,:,jk,Kaa) * umask(:,:,jk)
+ uu_b(:,:,Kmm) = uu_b(:,:,Kmm) + e3u(:,:,jk,Kmm) * puu(:,:,jk,Kmm) * umask(:,:,jk)
+ vv_b(:,:,Kaa) = vv_b(:,:,Kaa) + e3v(:,:,jk,Kaa) * pvv(:,:,jk,Kaa) * vmask(:,:,jk)
+ vv_b(:,:,Kmm) = vv_b(:,:,Kmm) + e3v(:,:,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(:,:,:) ) * z1_2dt
+ zva(:,:,:) = ( pvv(:,:,:,Kmm) - zva(:,:,:) ) * z1_2dt
+ CALL trd_dyn( zua, zva, jpdyn_atf, kt, Kmm )
+ 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_qco')
+ !
+ END SUBROUTINE dyn_atf_qco
+
+ !!=========================================================================
+END MODULE dynatfqco
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/dynhpg.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/dynhpg.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/dynhpg.F90 (revision 13540)
@@ -76,4 +76,6 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
+
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -255,5 +257,5 @@
! Surface value
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
zcoef1 = zcoef0 * e3w(ji,jj,1,Kmm)
! hydrostatic pressure gradient
@@ -267,5 +269,5 @@
!
! interior value (2= &
& MAX( -ht_0(ji,jj) , -ht_0(ji+1,jj) ) .AND. &
@@ -446,14 +448,18 @@
END IF
END_2D
- CALL lbc_lnk_multi( 'dynhpg', zcpx, 'U', 1., zcpy, 'V', 1. )
+ CALL lbc_lnk_multi( 'dynhpg', zcpx, 'U', 1.0_wp, zcpy, 'V', 1.0_wp )
END IF
! Surface value
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
! hydrostatic pressure gradient along s-surfaces
- zhpi(ji,jj,1) = zcoef0 * ( e3w(ji+1,jj ,1,Kmm) * ( znad + rhd(ji+1,jj ,1) ) &
- & - e3w(ji ,jj ,1,Kmm) * ( znad + rhd(ji ,jj ,1) ) ) * r1_e1u(ji,jj)
- zhpj(ji,jj,1) = zcoef0 * ( e3w(ji ,jj+1,1,Kmm) * ( znad + rhd(ji ,jj+1,1) ) &
- & - e3w(ji ,jj ,1,Kmm) * ( znad + rhd(ji ,jj ,1) ) ) * r1_e2v(ji,jj)
+ zhpi(ji,jj,1) = &
+ & zcoef0 * ( e3w(ji+1,jj ,1,Kmm) * ( znad + rhd(ji+1,jj ,1) ) &
+ & - e3w(ji ,jj ,1,Kmm) * ( znad + rhd(ji ,jj ,1) ) ) &
+ & * r1_e1u(ji,jj)
+ zhpj(ji,jj,1) = &
+ & zcoef0 * ( e3w(ji ,jj+1,1,Kmm) * ( znad + rhd(ji ,jj+1,1) ) &
+ & - e3w(ji ,jj ,1,Kmm) * ( znad + rhd(ji ,jj ,1) ) ) &
+ & * r1_e2v(ji,jj)
! s-coordinate pressure gradient correction
zuap = -zcoef0 * ( rhd (ji+1,jj,1) + rhd (ji,jj,1) + 2._wp * znad ) &
@@ -475,5 +481,5 @@
! interior value (2= &
& MAX( -ht_0(ji,jj) , -ht_0(ji+1,jj) ) .AND. &
@@ -669,5 +679,5 @@
END IF
END_2D
- CALL lbc_lnk_multi( 'dynhpg', zcpx, 'U', 1., zcpy, 'V', 1. )
+ CALL lbc_lnk_multi( 'dynhpg', zcpx, 'U', 1.0_wp, zcpy, 'V', 1.0_wp )
END IF
@@ -689,5 +699,5 @@
!!bug gm Not a true bug, but... dzz=e3w for dzx, dzy verify what it is really
- DO_3D_00_00( 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
drhoz(ji,jj,jk) = rhd (ji ,jj ,jk) - rhd (ji,jj,jk-1)
dzz (ji,jj,jk) = gde3w(ji ,jj ,jk) - gde3w(ji,jj,jk-1)
@@ -706,5 +716,5 @@
!!bug gm idem for drhox, drhoy et ji=jpi and jj=jpj
- DO_3D_00_00( 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
cffw = 2._wp * drhoz(ji ,jj ,jk) * drhoz(ji,jj,jk-1)
@@ -771,8 +781,8 @@
!-------------------------------------------------------------
-!!bug gm : e3w-gde3w = 0.5*e3w .... and gde3w(2)-gde3w(1)=e3w(2) .... to be verified
-! true if gde3w is really defined as the sum of the e3w scale factors as, it seems to me, it should be
-
- DO_2D_00_00
+!!bug gm : e3w-gde3w(:,:,:) = 0.5*e3w .... and gde3w(:,:,2)-gde3w(:,:,1)=e3w(:,:,2,Kmm) .... to be verified
+! true if gde3w(:,:,:) is really defined as the sum of the e3w scale factors as, it seems to me, it should be
+
+ DO_2D( 0, 0, 0, 0 )
rho_k(ji,jj,1) = -grav * ( e3w(ji,jj,1,Kmm) - gde3w(ji,jj,1) ) &
& * ( rhd(ji,jj,1) &
@@ -785,5 +795,5 @@
!!bug gm : optimisation: 1/10 and 1/12 the division should be done before the loop
- DO_3D_00_00( 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
rho_k(ji,jj,jk) = zcoef0 * ( rhd (ji,jj,jk) + rhd (ji,jj,jk-1) ) &
@@ -815,10 +825,10 @@
END_3D
- CALL lbc_lnk_multi( 'dynhpg', rho_k, 'W', 1., rho_i, 'U', 1., rho_j, 'V', 1. )
+ CALL lbc_lnk_multi( 'dynhpg', rho_k, 'W', 1.0_wp, rho_i, 'U', 1.0_wp, rho_j, 'V', 1.0_wp )
! ---------------
! Surface value
! ---------------
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
zhpi(ji,jj,1) = ( rho_k(ji+1,jj ,1) - rho_k(ji,jj,1) - rho_i(ji,jj,1) ) * r1_e1u(ji,jj)
zhpj(ji,jj,1) = ( rho_k(ji ,jj+1,1) - rho_k(ji,jj,1) - rho_j(ji,jj,1) ) * r1_e2v(ji,jj)
@@ -835,5 +845,5 @@
! interior value (2= &
& MAX( -ht_0(ji,jj) , -ht_0(ji+1,jj) ) .AND. &
@@ -942,5 +952,5 @@
ENDIF
END_2D
- CALL lbc_lnk_multi( 'dynhpg', zcpx, 'U', 1., zcpy, 'V', 1. )
+ CALL lbc_lnk_multi( 'dynhpg', zcpx, 'U', 1.0_wp, zcpy, 'V', 1.0_wp )
ENDIF
@@ -950,12 +960,12 @@
! Preparing vertical density profile "zrhh(:,:,:)" for hybrid-sco coordinate
- DO_2D_11_11
- jk = mbkt(ji,jj)+1
- IF( jk <= 0 ) THEN ; zrhh(ji,jj, : ) = 0._wp
- ELSEIF( jk == 1 ) THEN ; zrhh(ji,jj,jk+1:jpk) = rhd(ji,jj,jk)
+ DO_2D( 1, 1, 1, 1 )
+ jk = mbkt(ji,jj)
+ IF( jk <= 1 ) THEN ; zrhh(ji,jj, : ) = 0._wp
+ 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), rhd (ji,jj,jkk-1), rhd(ji,jj,jkk-2))
+ & gde3w(ji,jj,jkk-2), zrhh (ji,jj,jkk-1), zrhh(ji,jj,jkk-2))
END DO
ENDIF
@@ -963,9 +973,9 @@
! Transfer the depth of "T(:,:,:)" to vertical coordinate "zdept(:,:,:)"
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
zdept(ji,jj,1) = 0.5_wp * e3w(ji,jj,1,Kmm) - ssh(ji,jj,Kmm) * znad
END_2D
- DO_3D_11_11( 2, jpk )
+ DO_3D( 1, 1, 1, 1, 2, jpk )
zdept(ji,jj,jk) = zdept(ji,jj,jk-1) + e3w(ji,jj,jk,Kmm)
END_3D
@@ -980,5 +990,5 @@
! Integrate the hydrostatic pressure "zhpi(:,:,:)" at "T(ji,jj,1)"
- DO_2D_01_01
+ DO_2D( 0, 1, 0, 1 )
zrhdt1 = zrhh(ji,jj,1) - interp3( zdept(ji,jj,1), asp(ji,jj,1), bsp(ji,jj,1), &
& csp(ji,jj,1), dsp(ji,jj,1) ) * 0.25_wp * e3w(ji,jj,1,Kmm)
@@ -989,5 +999,5 @@
! Calculate the pressure "zhpi(:,:,:)" at "T(ji,jj,2:jpkm1)"
- DO_3D_01_01( 2, jpkm1 )
+ DO_3D( 0, 1, 0, 1, 2, jpkm1 )
zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1) + &
& integ_spline( zdept(ji,jj,jk-1), zdept(ji,jj,jk), &
@@ -999,5 +1009,5 @@
! Prepare zsshu_n and zsshv_n
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
!!gm BUG ? if it is ssh at u- & v-point then it should be:
! zsshu_n(ji,jj) = (e1e2t(ji,jj) * ssh(ji,jj,Kmm) + e1e2t(ji+1,jj) * ssh(ji+1,jj,Kmm)) * &
@@ -1012,22 +1022,22 @@
END_2D
- CALL lbc_lnk_multi ('dynhpg', zsshu_n, 'U', 1., zsshv_n, 'V', 1. )
-
- DO_2D_00_00
+ CALL lbc_lnk_multi ('dynhpg', zsshu_n, 'U', 1.0_wp, zsshv_n, 'V', 1.0_wp )
+
+ DO_2D( 0, 0, 0, 0 )
zu(ji,jj,1) = - ( e3u(ji,jj,1,Kmm) - zsshu_n(ji,jj) * znad)
zv(ji,jj,1) = - ( e3v(ji,jj,1,Kmm) - zsshv_n(ji,jj) * znad)
END_2D
- DO_3D_00_00( 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
zu(ji,jj,jk) = zu(ji,jj,jk-1) - e3u(ji,jj,jk,Kmm)
zv(ji,jj,jk) = zv(ji,jj,jk-1) - e3v(ji,jj,jk,Kmm)
END_3D
- DO_3D_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
zu(ji,jj,jk) = zu(ji,jj,jk) + 0.5_wp * e3u(ji,jj,jk,Kmm)
zv(ji,jj,jk) = zv(ji,jj,jk) + 0.5_wp * e3v(ji,jj,jk,Kmm)
END_3D
- DO_3D_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
zu(ji,jj,jk) = MIN( zu(ji,jj,jk) , MAX( -zdept(ji,jj,jk) , -zdept(ji+1,jj,jk) ) )
zu(ji,jj,jk) = MAX( zu(ji,jj,jk) , MIN( -zdept(ji,jj,jk) , -zdept(ji+1,jj,jk) ) )
@@ -1037,5 +1047,5 @@
- DO_3D_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
zpwes = 0._wp; zpwed = 0._wp
zpnss = 0._wp; zpnsd = 0._wp
@@ -1359,3 +1369,2 @@
!!======================================================================
END MODULE dynhpg
-
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/dynkeg.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/dynkeg.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/dynkeg.F90 (revision 13540)
@@ -101,5 +101,5 @@
!
CASE ( nkeg_C2 ) !-- Standard scheme --!
- DO_3D_01_01( 1, jpkm1 )
+ 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)
@@ -109,5 +109,5 @@
END_3D
CASE ( nkeg_HW ) !-- Hollingsworth scheme --!
- DO_3D_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
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) ) &
@@ -121,9 +121,9 @@
zhke(ji,jj,jk) = r1_48 * ( zv + zu )
END_3D
- CALL lbc_lnk( 'dynkeg', zhke, 'T', 1. )
+ CALL lbc_lnk( 'dynkeg', zhke, 'T', 1.0_wp )
!
END SELECT
!
- DO_3D_00_00( 1, jpkm1 )
+ 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)
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/dynldf_iso.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/dynldf_iso.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/dynldf_iso.F90 (revision 13540)
@@ -42,4 +42,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -127,5 +128,5 @@
IF( ln_dynldf_hor .AND. ln_traldf_iso ) THEN
!
- DO_3D_00_00( 1, jpk )
+ DO_3D( 0, 0, 0, 0, 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)
@@ -134,5 +135,5 @@
END_3D
! Lateral boundary conditions on the slopes
- CALL lbc_lnk_multi( 'dynldf_iso', uslp , 'U', -1., vslp , 'V', -1., wslpi, 'W', -1., wslpj, 'W', -1. )
+ CALL lbc_lnk_multi( 'dynldf_iso', uslp , 'U', -1.0_wp, vslp , 'V', -1.0_wp, wslpi, 'W', -1.0_wp, wslpj, 'W', -1.0_wp )
!
ENDIF
@@ -167,6 +168,8 @@
IF( ln_zps ) THEN ! z-coordinate - partial steps : min(e3u)
- DO_2D_00_01
- 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)
+ DO_2D( 0, 0, 0, 1 )
+ 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) &
@@ -180,6 +183,7 @@
END_2D
ELSE ! other coordinate system (zco or sco) : e3t
- DO_2D_00_01
- zabe1 = ( ahmt(ji,jj,jk)+rn_ahm_b ) * e2t(ji,jj) * e3t(ji,jj,jk,Kmm) * r1_e1t(ji,jj)
+ DO_2D( 0, 0, 0, 1 )
+ 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) &
@@ -195,6 +199,7 @@
! j-flux at f-point
- DO_2D_10_10
- zabe2 = ( ahmf(ji,jj,jk) + rn_ahm_b ) * e1f(ji,jj) * e3f(ji,jj,jk) * r1_e2f(ji,jj)
+ 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) &
@@ -214,6 +219,7 @@
! i-flux at f-point | t |
- DO_2D_00_10
- zabe1 = ( ahmf(ji,jj,jk) + rn_ahm_b ) * e2f(ji,jj) * e3f(ji,jj,jk) * r1_e1f(ji,jj)
+ DO_2D( 0, 0, 1, 0 )
+ 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) &
@@ -229,6 +235,8 @@
! j-flux at t-point
IF( ln_zps ) THEN ! z-coordinate - partial steps : min(e3u)
- DO_2D_01_10
- 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)
+ DO_2D( 0, 1, 1, 0 )
+ 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) &
@@ -242,6 +250,7 @@
END_2D
ELSE ! other coordinate system (zco or sco) : e3t
- DO_2D_01_10
- zabe2 = ( ahmt(ji,jj,jk)+rn_ahm_b ) * e1t(ji,jj) * e3t(ji,jj,jk,Kmm) * r1_e2t(ji,jj)
+ DO_2D( 0, 1, 1, 0 )
+ 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) &
@@ -259,9 +268,11 @@
! Second derivative (divergence) and add to the general trend
! -----------------------------------------------------------
- DO_2D_00_00
+ 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)
+ & + 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)
+ & + zjvt(ji,jj+1) - zjvt(ji,jj ) ) * r1_e1e2v(ji,jj) &
+ & / e3v(ji,jj,jk,Kmm)
END_2D
! ! ===============
@@ -375,6 +386,8 @@
DO jk = 1, jpkm1
DO ji = 2, jpim1
- 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
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/dynldf_lap_blp.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/dynldf_lap_blp.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/dynldf_lap_blp.F90 (revision 13540)
@@ -28,4 +28,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -72,26 +73,23 @@
DO jk = 1, jpkm1 ! Horizontal slab
! ! ===============
- DO_2D_01_01
+ DO_2D( 0, 1, 0, 1 )
! ! ahm * e3 * curl (computed from 1 to jpim1/jpjm1)
-!!gm open question here : e3f at before or now ? probably now...
-!!gm note that ahmf has already been multiplied by fmask
- zcur(ji-1,jj-1) = ahmf(ji-1,jj-1,jk) * e3f(ji-1,jj-1,jk) * r1_e1e2f(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 (computed from 2 to jpi/jpj)
-!!gm note that ahmt has already been multiplied by tmask
- zdiv(ji,jj) = ahmt(ji,jj,jk) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kbb) &
+ 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_00_00
- pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zsign * ( &
+ DO_2D( 0, 0, 0, 0 ) ! - 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) )
+ & + ( zdiv(ji+1,jj) - zdiv(ji,jj ) ) * r1_e1u(ji,jj) )
!
- pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zsign * ( &
+ 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) )
+ & + ( zdiv(ji,jj+1) - zdiv(ji ,jj) ) * r1_e2v(ji,jj) )
END_2D
! ! ===============
@@ -134,5 +132,5 @@
CALL dyn_ldf_lap( kt, Kbb, Kmm, pu, pv, zulap, zvlap, 1 ) ! rotated laplacian applied to pt (output in zlap,Kbb)
!
- CALL lbc_lnk_multi( 'dynldf_lap_blp', zulap, 'U', -1., zvlap, 'V', -1. ) ! Lateral boundary conditions
+ CALL lbc_lnk_multi( '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))
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/dynspg.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/dynspg.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/dynspg.F90 (revision 13540)
@@ -95,5 +95,5 @@
.OR. ln_ice_embd ) THEN ! embedded sea-ice
!
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
spgu(ji,jj) = 0._wp
spgv(ji,jj) = 0._wp
@@ -102,5 +102,5 @@
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_00_00
+ DO_2D( 0, 0, 0, 0 ) ! gradient of Patm using inverse barometer ssh
spgu(ji,jj) = spgu(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)
@@ -117,5 +117,5 @@
CALL upd_tide(zt0step, Kmm)
!
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 ) ! add tide potential forcing
spgu(ji,jj) = spgu(ji,jj) + grav * ( pot_astro(ji+1,jj) - pot_astro(ji,jj) ) * r1_e1u(ji,jj)
spgv(ji,jj) = spgv(ji,jj) + grav * ( pot_astro(ji,jj+1) - pot_astro(ji,jj) ) * r1_e2v(ji,jj)
@@ -124,5 +124,5 @@
IF (ln_scal_load) THEN
zld = rn_scal_load * grav
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 ) ! add scalar approximation for load potential
spgu(ji,jj) = spgu(ji,jj) + zld * ( pssh(ji+1,jj,Kmm) - pssh(ji,jj,Kmm) ) * r1_e1u(ji,jj)
spgv(ji,jj) = spgv(ji,jj) + zld * ( pssh(ji,jj+1,Kmm) - pssh(ji,jj,Kmm) ) * r1_e2v(ji,jj)
@@ -136,5 +136,5 @@
zgrho0r = - grav * r1_rho0
zpice(:,:) = ( zintp * snwice_mass(:,:) + ( 1.- zintp ) * snwice_mass_b(:,:) ) * zgrho0r
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
spgu(ji,jj) = spgu(ji,jj) + ( zpice(ji+1,jj) - zpice(ji,jj) ) * r1_e1u(ji,jj)
spgv(ji,jj) = spgv(ji,jj) + ( zpice(ji,jj+1) - zpice(ji,jj) ) * r1_e2v(ji,jj)
@@ -143,5 +143,5 @@
ENDIF
!
- DO_3D_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !== Add all terms to the general trend
puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + spgu(ji,jj)
pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + spgv(ji,jj)
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/dynspg_exp.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/dynspg_exp.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/dynspg_exp.F90 (revision 13540)
@@ -74,10 +74,10 @@
IF( ln_linssh ) THEN !* linear free surface : add the surface pressure gradient trend
!
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 ) ! now surface pressure gradient
spgu(ji,jj) = - grav * ( ssh(ji+1,jj,Kmm) - ssh(ji,jj,Kmm) ) * r1_e1u(ji,jj)
spgv(ji,jj) = - grav * ( ssh(ji,jj+1,Kmm) - ssh(ji,jj,Kmm) ) * r1_e2v(ji,jj)
END_2D
!
- DO_3D_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! Add it to the general trend
puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + spgu(ji,jj)
pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + spgv(ji,jj)
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/dynspg_ts.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/dynspg_ts.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/dynspg_ts.F90 (revision 13540)
@@ -87,4 +87,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -161,4 +162,5 @@
REAL(wp), DIMENSION(jpi,jpj) :: zCdU_u, zCdU_v ! top/bottom stress at u- & v-points
REAL(wp), DIMENSION(jpi,jpj) :: zhU, zhV ! fluxes
+ REAL(wp), DIMENSION(jpi, jpj, jpk) :: ze3u, ze3v
!
REAL(wp) :: zwdramp ! local scalar - only used if ln_wd_dl = .True.
@@ -227,6 +229,11 @@
! != zu_frc = 1/H e3*d/dt(Ua) =! (Vertical mean of Ua, the 3D trends)
! ! --------------------------- !
- zu_frc(:,:) = SUM( e3u(:,:,:,Kmm) * uu(:,:,:,Krhs) * umask(:,:,:) , DIM=3 ) * r1_hu(:,:,Kmm)
- zv_frc(:,:) = SUM( e3v(:,:,:,Kmm) * vv(:,:,:,Krhs) * vmask(:,:,:) , DIM=3 ) * r1_hv(:,:,Kmm)
+ DO jk = 1 , jpk
+ ze3u(:,:,jk) = e3u(:,:,jk,Kmm)
+ ze3v(:,:,jk) = e3v(:,:,jk,Kmm)
+ END DO
+ !
+ zu_frc(:,:) = SUM( ze3u(:,:,:) * uu(:,:,:,Krhs) * umask(:,:,:) , DIM=3 ) * r1_hu(:,:,Kmm)
+ zv_frc(:,:) = SUM( ze3v(:,:,:) * vv(:,:,:,Krhs) * vmask(:,:,:) , DIM=3 ) * r1_hv(:,:,Kmm)
!
!
@@ -250,5 +257,5 @@
zhV(:,:) = pvv_b(:,:,Kmm) * hv(:,:,Kmm) * e1v(:,:) ! NB: FULL domain : put a value in last row and column
!
- CALL dyn_cor_2d( hu(:,:,Kmm), hv(:,:,Kmm), puu_b(:,:,Kmm), pvv_b(:,:,Kmm), zhU, zhV, & ! <<== in
+ CALL dyn_cor_2d( ht(:,:), hu(:,:,Kmm), hv(:,:,Kmm), puu_b(:,:,Kmm), pvv_b(:,:,Kmm), zhU, zhV, & ! <<== in
& zu_trd, zv_trd ) ! ==>> out
!
@@ -257,5 +264,5 @@
IF( ln_wd_il ) THEN ! W/D : limiter applied to spgspg
CALL wad_spg( pssh(:,:,Kmm), zcpx, zcpy ) ! Calculating W/D gravity filters, zcpx and zcpy
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 ) ! SPG with the application of W/D gravity filters
zu_trd(ji,jj) = zu_trd(ji,jj) - grav * ( pssh(ji+1,jj ,Kmm) - pssh(ji ,jj ,Kmm) ) &
& * r1_e1u(ji,jj) * zcpx(ji,jj) * wdrampu(ji,jj) !jth
@@ -264,5 +271,5 @@
END_2D
ELSE ! now suface pressure gradient
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
zu_trd(ji,jj) = zu_trd(ji,jj) - grav * ( pssh(ji+1,jj ,Kmm) - pssh(ji ,jj ,Kmm) ) * r1_e1u(ji,jj)
zv_trd(ji,jj) = zv_trd(ji,jj) - grav * ( pssh(ji ,jj+1,Kmm) - pssh(ji ,jj ,Kmm) ) * r1_e2v(ji,jj)
@@ -272,5 +279,5 @@
ENDIF
!
- DO_2D_00_00
+ 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)
zv_frc(ji,jj) = zv_frc(ji,jj) - zv_trd(ji,jj) * ssvmask(ji,jj)
@@ -284,5 +291,5 @@
IF( ln_apr_dyn ) THEN
IF( ln_bt_fw ) THEN ! FORWARD integration: use kt+1/2 pressure (NOW+1/2)
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
zu_frc(ji,jj) = zu_frc(ji,jj) + grav * ( ssh_ib (ji+1,jj ) - ssh_ib (ji,jj) ) * r1_e1u(ji,jj)
zv_frc(ji,jj) = zv_frc(ji,jj) + grav * ( ssh_ib (ji ,jj+1) - ssh_ib (ji,jj) ) * r1_e2v(ji,jj)
@@ -290,5 +297,5 @@
ELSE ! CENTRED integration: use kt-1/2 + kt+1/2 pressure (NOW)
zztmp = grav * r1_2
- DO_2D_00_00
+ 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)
@@ -302,5 +309,5 @@
! ! ---------------------------------- !
IF( ln_bt_fw ) THEN ! Add wind forcing
- DO_2D_00_00
+ 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)
@@ -308,5 +315,5 @@
ELSE
zztmp = r1_rho0 * r1_2
- DO_2D_00_00
+ 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)
@@ -468,10 +475,10 @@
!
! ! ocean u- and v-depth at mid-step (separate DO-loops remove the need of a lbc_lnk)
- DO_2D_11_10
+ DO_2D( 1, 1, 1, 0 ) ! not jpi-column
zhup2_e(ji,jj) = hu_0(ji,jj) + r1_2 * r1_e1e2u(ji,jj) &
& * ( e1e2t(ji ,jj) * zsshp2_e(ji ,jj) &
& + e1e2t(ji+1,jj) * zsshp2_e(ji+1,jj) ) * ssumask(ji,jj)
END_2D
- DO_2D_10_11
+ DO_2D( 1, 0, 1, 1 ) ! not jpj-row
zhvp2_e(ji,jj) = hv_0(ji,jj) + r1_2 * r1_e1e2v(ji,jj) &
& * ( e1e2t(ji,jj ) * zsshp2_e(ji,jj ) &
@@ -508,5 +515,5 @@
!-- ssh = ssh - delta_t' * [ frc + div( flux ) ] --!
!-------------------------------------------------------------------------!
- DO_2D_00_00
+ 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)
ssha_e(ji,jj) = ( sshn_e(ji,jj) - rDt_e * ( zssh_frc(ji,jj) + zhdiv ) ) * ssmask(ji,jj)
@@ -514,4 +521,10 @@
!
CALL lbc_lnk_multi( 'dynspg_ts', ssha_e, 'T', 1._wp, zhU, 'U', -1._wp, zhV, 'V', -1._wp )
+ !
+ ! Duplicate sea level across open boundaries (this is only cosmetic if linssh=T)
+ IF( ln_bdy ) CALL bdy_ssh( ssha_e )
+#if defined key_agrif
+ IF( .NOT.Agrif_Root() ) CALL agrif_ssh_ts( jn )
+#endif
!
! ! Sum over sub-time-steps to compute advective velocities
@@ -525,13 +538,8 @@
END IF
!
- ! Duplicate sea level across open boundaries (this is only cosmetic if linssh=T)
- IF( ln_bdy ) CALL bdy_ssh( ssha_e )
-#if defined key_agrif
- IF( .NOT.Agrif_Root() ) CALL agrif_ssh_ts( jn )
-#endif
!
! Sea Surface Height at u-,v-points (vvl case only)
IF( .NOT.ln_linssh ) THEN
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
zsshu_a(ji,jj) = r1_2 * ssumask(ji,jj) * r1_e1e2u(ji,jj) &
& * ( e1e2t(ji ,jj ) * ssha_e(ji ,jj ) &
@@ -553,5 +561,5 @@
! ! Surface pressure gradient
zldg = ( 1._wp - rn_scal_load ) * grav ! local factor
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
zu_spg(ji,jj) = - zldg * ( zsshp2_e(ji+1,jj) - zsshp2_e(ji,jj) ) * r1_e1u(ji,jj)
zv_spg(ji,jj) = - zldg * ( zsshp2_e(ji,jj+1) - zsshp2_e(ji,jj) ) * r1_e2v(ji,jj)
@@ -567,9 +575,9 @@
! at each time step. We however keep them constant here for optimization.
! Recall that zhU and zhV hold fluxes at jn+0.5 (extrapolated not backward interpolated)
- CALL dyn_cor_2d( zhup2_e, zhvp2_e, ua_e, va_e, zhU, zhV, zu_trd, zv_trd )
+ CALL dyn_cor_2d( zhtp2_e, zhup2_e, zhvp2_e, ua_e, va_e, zhU, zhV, zu_trd, zv_trd )
!
! Add tidal astronomical forcing if defined
IF ( ln_tide .AND. ln_tide_pot ) THEN
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
zu_trd(ji,jj) = zu_trd(ji,jj) + grav * ( pot_astro(ji+1,jj) - pot_astro(ji,jj) ) * r1_e1u(ji,jj)
zv_trd(ji,jj) = zv_trd(ji,jj) + grav * ( pot_astro(ji,jj+1) - pot_astro(ji,jj) ) * r1_e2v(ji,jj)
@@ -580,5 +588,5 @@
!jth do implicitly instead
IF ( .NOT. ll_wd ) THEN ! Revert to explicit for bit comparison tests in non wad runs
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
zu_trd(ji,jj) = zu_trd(ji,jj) + zCdU_u(ji,jj) * un_e(ji,jj) * hur_e(ji,jj)
zv_trd(ji,jj) = zv_trd(ji,jj) + zCdU_v(ji,jj) * vn_e(ji,jj) * hvr_e(ji,jj)
@@ -598,5 +606,5 @@
!------------------------------------------------------------------------------------------------------------------------!
IF( ln_dynadv_vec .OR. ln_linssh ) THEN !* Vector form
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
ua_e(ji,jj) = ( un_e(ji,jj) &
& + rDt_e * ( zu_spg(ji,jj) &
@@ -613,5 +621,5 @@
!
ELSE !* Flux form
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
! ! hu_e, hv_e hold depth at jn, zhup2_e, zhvp2_e hold extrapolated depth at jn+1/2
! ! backward interpolated depth used in spg terms at jn+1/2
@@ -637,5 +645,5 @@
!jth implicit bottom friction:
IF ( ll_wd ) THEN ! revert to explicit for bit comparison tests in non wad runs
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
ua_e(ji,jj) = ua_e(ji,jj) /(1.0 - rDt_e * zCdU_u(ji,jj) * hur_e(ji,jj))
va_e(ji,jj) = va_e(ji,jj) /(1.0 - rDt_e * zCdU_v(ji,jj) * hvr_e(ji,jj))
@@ -643,9 +651,12 @@
ENDIF
- IF( .NOT.ln_linssh ) THEN !* Update ocean depth (variable volume case only)
+ IF( .NOT.ln_linssh ) THEN !* Update ocean depth (variable volume case only)
hu_e (2:jpim1,2:jpjm1) = hu_0(2:jpim1,2:jpjm1) + zsshu_a(2:jpim1,2:jpjm1)
hur_e(2:jpim1,2:jpjm1) = ssumask(2:jpim1,2:jpjm1) / ( hu_e(2:jpim1,2:jpjm1) + 1._wp - ssumask(2:jpim1,2:jpjm1) )
hv_e (2:jpim1,2:jpjm1) = hv_0(2:jpim1,2:jpjm1) + zsshv_a(2:jpim1,2:jpjm1)
hvr_e(2:jpim1,2:jpjm1) = ssvmask(2:jpim1,2:jpjm1) / ( hv_e(2:jpim1,2:jpjm1) + 1._wp - ssvmask(2:jpim1,2:jpjm1) )
+ ENDIF
+ !
+ IF( .NOT.ln_linssh ) THEN !* Update ocean depth (variable volume case only)
CALL lbc_lnk_multi( 'dynspg_ts', ua_e , 'U', -1._wp, va_e , 'V', -1._wp &
& , hu_e , 'U', 1._wp, hv_e , 'V', 1._wp &
@@ -654,6 +665,4 @@
CALL lbc_lnk_multi( 'dynspg_ts', ua_e , 'U', -1._wp, va_e , 'V', -1._wp )
ENDIF
- !
- !
! ! open boundaries
IF( ln_bdy ) CALL bdy_dyn2d( jn, ua_e, va_e, un_e, vn_e, hur_e, hvr_e, ssha_e )
@@ -703,5 +712,5 @@
IF (ln_bt_fw) THEN
IF( .NOT.( kt == nit000 .AND. l_1st_euler ) ) THEN
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
zun_save = un_adv(ji,jj)
zvn_save = vn_adv(ji,jj)
@@ -734,5 +743,5 @@
ELSE
! At this stage, pssh(:,:,:,Krhs) has been corrected: compute new depths at velocity points
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
zsshu_a(ji,jj) = r1_2 * ssumask(ji,jj) * r1_e1e2u(ji,jj) &
& * ( e1e2t(ji ,jj) * pssh(ji ,jj,Kaa) &
@@ -891,21 +900,21 @@
! ! ---------------
IF( ln_rstart .AND. ln_bt_fw .AND. (.NOT.l_1st_euler) ) THEN !* Read the restart file
- CALL iom_get( numror, jpdom_autoglo, 'ub2_b' , ub2_b (:,:), ldxios = lrxios )
- CALL iom_get( numror, jpdom_autoglo, 'vb2_b' , vb2_b (:,:), ldxios = lrxios )
- CALL iom_get( numror, jpdom_autoglo, 'un_bf' , un_bf (:,:), ldxios = lrxios )
- CALL iom_get( numror, jpdom_autoglo, 'vn_bf' , vn_bf (:,:), ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'ub2_b' , ub2_b (:,:), cd_type = 'U', psgn = -1._wp, ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'vb2_b' , vb2_b (:,:), cd_type = 'V', psgn = -1._wp, ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'un_bf' , un_bf (:,:), cd_type = 'U', psgn = -1._wp, ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'vn_bf' , vn_bf (:,:), cd_type = 'V', psgn = -1._wp, ldxios = lrxios )
IF( .NOT.ln_bt_av ) THEN
- CALL iom_get( numror, jpdom_autoglo, 'sshbb_e' , sshbb_e(:,:), ldxios = lrxios )
- CALL iom_get( numror, jpdom_autoglo, 'ubb_e' , ubb_e(:,:), ldxios = lrxios )
- CALL iom_get( numror, jpdom_autoglo, 'vbb_e' , vbb_e(:,:), ldxios = lrxios )
- CALL iom_get( numror, jpdom_autoglo, 'sshb_e' , sshb_e(:,:), ldxios = lrxios )
- CALL iom_get( numror, jpdom_autoglo, 'ub_e' , ub_e(:,:), ldxios = lrxios )
- CALL iom_get( numror, jpdom_autoglo, 'vb_e' , vb_e(:,:), ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'sshbb_e' , sshbb_e(:,:), cd_type = 'T', psgn = 1._wp, ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'ubb_e' , ubb_e(:,:), cd_type = 'U', psgn = -1._wp, ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'vbb_e' , vbb_e(:,:), cd_type = 'V', psgn = -1._wp, ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'sshb_e' , sshb_e(:,:), cd_type = 'T', psgn = 1._wp, ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'ub_e' , ub_e(:,:), cd_type = 'U', psgn = -1._wp, ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'vb_e' , vb_e(:,:), cd_type = 'V', psgn = -1._wp, ldxios = lrxios )
ENDIF
#if defined key_agrif
! Read time integrated fluxes
IF ( .NOT.Agrif_Root() ) THEN
- CALL iom_get( numror, jpdom_autoglo, 'ub2_i_b' , ub2_i_b(:,:), ldxios = lrxios )
- CALL iom_get( numror, jpdom_autoglo, 'vb2_i_b' , vb2_i_b(:,:), ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'ub2_i_b' , ub2_i_b(:,:), cd_type = 'U', psgn = -1._wp, ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'vb2_i_b' , vb2_i_b(:,:), cd_type = 'V', psgn = -1._wp, ldxios = lrxios )
ENDIF
#endif
@@ -966,5 +975,5 @@
! Max courant number for ext. grav. waves
!
- DO_2D_11_11
+ DO_2D( 0, 0, 0, 0 )
zxr2 = r1_e1t(ji,jj) * r1_e1t(ji,jj)
zyr2 = r1_e2t(ji,jj) * r1_e2t(ji,jj)
@@ -972,5 +981,5 @@
END_2D
!
- zcmax = MAXVAL( zcu(:,:) )
+ zcmax = MAXVAL( zcu(Nis0:Nie0,Njs0:Nje0) )
CALL mpp_max( 'dynspg_ts', zcmax )
@@ -1088,8 +1097,8 @@
!
SELECT CASE( nvor_scheme )
- CASE( np_EEN ) != EEN scheme using e3f (energy & enstrophy scheme)
+ CASE( np_EEN ) != EEN scheme using e3f energy & enstrophy scheme
SELECT CASE( nn_een_e3f ) !* ff_f/e3 at F-point
CASE ( 0 ) ! original formulation (masked averaging of e3t divided by 4)
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
zwz(ji,jj) = ( ht(ji ,jj+1) + ht(ji+1,jj+1) + &
& ht(ji ,jj ) + ht(ji+1,jj ) ) * 0.25_wp
@@ -1097,5 +1106,5 @@
END_2D
CASE ( 1 ) ! new formulation (masked averaging of e3t divided by the sum of mask)
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
zwz(ji,jj) = ( ht (ji ,jj+1) + ht (ji+1,jj+1) &
& + ht (ji ,jj ) + ht (ji+1,jj ) ) &
@@ -1108,5 +1117,5 @@
!
ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp
- DO_2D_01_01
+ DO_2D( 0, 1, 0, 1 )
ftne(ji,jj) = zwz(ji-1,jj ) + zwz(ji ,jj ) + zwz(ji ,jj-1)
ftnw(ji,jj) = zwz(ji-1,jj-1) + zwz(ji-1,jj ) + zwz(ji ,jj )
@@ -1115,7 +1124,7 @@
END_2D
!
- CASE( np_EET ) != EEN scheme using e3t (energy conserving scheme)
+ 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_01_01
+ DO_2D( 0, 1, 0, 1 )
z1_ht = ssmask(ji,jj) / ( ht(ji,jj) + 1._wp - ssmask(ji,jj) )
ftne(ji,jj) = ( ff_f(ji-1,jj ) + ff_f(ji ,jj ) + ff_f(ji ,jj-1) ) * z1_ht
@@ -1150,5 +1159,5 @@
!
!zhf(:,:) = hbatf(:,:)
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
zhf(ji,jj) = ( ht_0 (ji,jj ) + ht_0 (ji+1,jj ) &
& + ht_0 (ji,jj+1) + ht_0 (ji+1,jj+1) ) &
@@ -1169,5 +1178,5 @@
CALL lbc_lnk( 'dynspg_ts', zhf, 'F', 1._wp )
! JC: TBC. hf should be greater than 0
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
IF( zhf(ji,jj) /= 0._wp ) zwz(ji,jj) = 1._wp / zhf(ji,jj)
END_2D
@@ -1179,5 +1188,5 @@
- SUBROUTINE dyn_cor_2d( phu, phv, punb, pvnb, zhU, zhV, zu_trd, zv_trd )
+ SUBROUTINE dyn_cor_2d( pht, phu, phv, punb, pvnb, zhU, zhV, zu_trd, zv_trd )
!!---------------------------------------------------------------------
!! *** ROUTINE dyn_cor_2d ***
@@ -1187,23 +1196,23 @@
INTEGER :: ji ,jj ! dummy loop indices
REAL(wp) :: zx1, zx2, zy1, zy2, z1_hu, z1_hv ! - -
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: phu, phv, punb, pvnb, zhU, zhV
+ REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pht, phu, phv, punb, pvnb, zhU, zhV
REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: zu_trd, zv_trd
!!----------------------------------------------------------------------
SELECT CASE( nvor_scheme )
CASE( np_ENT ) ! enstrophy conserving scheme (f-point)
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
z1_hu = ssumask(ji,jj) / ( phu(ji,jj) + 1._wp - ssumask(ji,jj) )
z1_hv = ssvmask(ji,jj) / ( phv(ji,jj) + 1._wp - ssvmask(ji,jj) )
zu_trd(ji,jj) = + r1_4 * r1_e1e2u(ji,jj) * z1_hu &
- & * ( e1e2t(ji+1,jj)*ht(ji+1,jj)*ff_t(ji+1,jj) * ( pvnb(ji+1,jj) + pvnb(ji+1,jj-1) ) &
- & + e1e2t(ji ,jj)*ht(ji ,jj)*ff_t(ji ,jj) * ( pvnb(ji ,jj) + pvnb(ji ,jj-1) ) )
+ & * ( e1e2t(ji+1,jj)*pht(ji+1,jj)*ff_t(ji+1,jj) * ( pvnb(ji+1,jj) + pvnb(ji+1,jj-1) ) &
+ & + e1e2t(ji ,jj)*pht(ji ,jj)*ff_t(ji ,jj) * ( pvnb(ji ,jj) + pvnb(ji ,jj-1) ) )
!
zv_trd(ji,jj) = - r1_4 * r1_e1e2v(ji,jj) * z1_hv &
- & * ( e1e2t(ji,jj+1)*ht(ji,jj+1)*ff_t(ji,jj+1) * ( punb(ji,jj+1) + punb(ji-1,jj+1) ) &
- & + e1e2t(ji,jj )*ht(ji,jj )*ff_t(ji,jj ) * ( punb(ji,jj ) + punb(ji-1,jj ) ) )
+ & * ( e1e2t(ji,jj+1)*pht(ji,jj+1)*ff_t(ji,jj+1) * ( punb(ji,jj+1) + punb(ji-1,jj+1) ) &
+ & + e1e2t(ji,jj )*pht(ji,jj )*ff_t(ji,jj ) * ( punb(ji,jj ) + punb(ji-1,jj ) ) )
END_2D
!
CASE( np_ENE , np_MIX ) ! energy conserving scheme (t-point) ENE or MIX
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
zy1 = ( zhV(ji,jj-1) + zhV(ji+1,jj-1) ) * r1_e1u(ji,jj)
zy2 = ( zhV(ji,jj ) + zhV(ji+1,jj ) ) * r1_e1u(ji,jj)
@@ -1216,5 +1225,5 @@
!
CASE( np_ENS ) ! enstrophy conserving scheme (f-point)
- DO_2D_00_00
+ 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)
@@ -1226,5 +1235,5 @@
!
CASE( np_EET , np_EEN ) ! energy & enstrophy scheme (using e3t or e3f)
- DO_2D_00_00
+ 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 ) &
@@ -1260,5 +1269,5 @@
!
IF( ln_wd_dl_rmp ) THEN
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
IF ( pssh(ji,jj) + ht_0(ji,jj) > 2._wp * rn_wdmin1 ) THEN
! IF ( pssh(ji,jj) + ht_0(ji,jj) > rn_wdmin2 ) THEN
@@ -1271,5 +1280,5 @@
END_2D
ELSE
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
IF ( pssh(ji,jj) + ht_0(ji,jj) > rn_wdmin1 ) THEN ; ptmsk(ji,jj) = 1._wp
ELSE ; ptmsk(ji,jj) = 0._wp
@@ -1299,5 +1308,5 @@
!!----------------------------------------------------------------------
!
- DO_2D_11_10
+ DO_2D( 1, 1, 1, 0 ) ! not jpi-column
IF ( phU(ji,jj) > 0._wp ) THEN ; pUmsk(ji,jj) = pTmsk(ji ,jj)
ELSE ; pUmsk(ji,jj) = pTmsk(ji+1,jj)
@@ -1307,5 +1316,5 @@
END_2D
!
- DO_2D_10_11
+ DO_2D( 1, 0, 1, 1 ) ! not jpj-row
IF ( phV(ji,jj) > 0._wp ) THEN ; pVmsk(ji,jj) = pTmsk(ji,jj )
ELSE ; pVmsk(ji,jj) = pTmsk(ji,jj+1)
@@ -1329,5 +1338,5 @@
REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: zcpx, zcpy
!!----------------------------------------------------------------------
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
ll_tmp1 = MIN( pshn(ji,jj) , pshn(ji+1,jj) ) > &
& MAX( -ht_0(ji,jj) , -ht_0(ji+1,jj) ) .AND. &
@@ -1396,12 +1405,12 @@
! !== Set the barotropic drag coef. ==!
!
- IF( ln_isfcav ) THEN ! top+bottom friction (ocean cavities)
+ IF( ln_isfcav.OR.ln_drgice_imp ) THEN ! top+bottom friction (ocean cavities)
- DO_2D_00_00
+ 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) )
END_2D
ELSE ! bottom friction only
- DO_2D_00_00
+ 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) )
@@ -1413,5 +1422,5 @@
IF( ln_bt_fw ) THEN ! FORWARD integration: use NOW bottom baroclinic velocities
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
ikbu = mbku(ji,jj)
ikbv = mbkv(ji,jj)
@@ -1421,5 +1430,5 @@
ELSE ! CENTRED integration: use BEFORE bottom baroclinic velocities
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
ikbu = mbku(ji,jj)
ikbv = mbkv(ji,jj)
@@ -1431,5 +1440,5 @@
IF( ln_wd_il ) THEN ! W/D : use the "clipped" bottom friction !!gm explain WHY, please !
zztmp = -1._wp / rDt_e
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
pu_RHSi(ji,jj) = pu_RHSi(ji,jj) + zu_i(ji,jj) * wdrampu(ji,jj) * MAX( &
& r1_hu(ji,jj,Kmm) * r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) , zztmp )
@@ -1439,5 +1448,5 @@
ELSE ! use "unclipped" drag (even if explicit friction is used in 3D calculation)
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
pu_RHSi(ji,jj) = pu_RHSi(ji,jj) + r1_hu(ji,jj,Kmm) * r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) * zu_i(ji,jj)
pv_RHSi(ji,jj) = pv_RHSi(ji,jj) + r1_hv(ji,jj,Kmm) * r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) * zv_i(ji,jj)
@@ -1447,9 +1456,9 @@
! !== TOP stress contribution from baroclinic velocities ==! (no W/D case)
!
- IF( ln_isfcav ) THEN
+ IF( ln_isfcav.OR.ln_drgice_imp ) THEN
!
IF( ln_bt_fw ) THEN ! FORWARD integration: use NOW top baroclinic velocity
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
iktu = miku(ji,jj)
iktv = mikv(ji,jj)
@@ -1459,5 +1468,5 @@
ELSE ! CENTRED integration: use BEFORE top baroclinic velocity
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
iktu = miku(ji,jj)
iktv = mikv(ji,jj)
@@ -1469,5 +1478,5 @@
! ! use "unclipped" top drag (even if explicit friction is used in 3D calculation)
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
pu_RHSi(ji,jj) = pu_RHSi(ji,jj) + r1_hu(ji,jj,Kmm) * r1_2*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * zu_i(ji,jj)
pv_RHSi(ji,jj) = pv_RHSi(ji,jj) + r1_hv(ji,jj,Kmm) * r1_2*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) * zv_i(ji,jj)
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/dynvor.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/dynvor.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/dynvor.F90 (revision 13540)
@@ -80,6 +80,6 @@
REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: di_e2u_2 ! = di(e2u)/2 used in T-point metric term calculation
REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: dj_e1v_2 ! = dj(e1v)/2 - - - -
- REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: di_e2v_2e1e2f ! = di(e2u)/(2*e1e2f) used in F-point metric term calculation
- REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: dj_e1u_2e1e2f ! = dj(e1v)/(2*e1e2f) - - - -
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: di_e2v_2e1e2f ! = di(e2v)/(2*e1e2f) used in F-point metric term calculation
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: dj_e1u_2e1e2f ! = dj(e1u)/(2*e1e2f) - - - -
REAL(wp) :: r1_4 = 0.250_wp ! =1/4
@@ -89,4 +89,6 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
+
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -229,10 +231,10 @@
CASE ( np_RVO ) !* relative vorticity
DO jk = 1, jpkm1 ! Horizontal slab
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
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)
END_2D
IF( ln_dynvor_msk ) THEN ! mask/unmask relative vorticity
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk)
END_2D
@@ -240,14 +242,14 @@
END DO
- CALL lbc_lnk( 'dynvor', zwz, 'F', 1. )
+ CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp )
CASE ( np_CRV ) !* Coriolis + relative vorticity
DO jk = 1, jpkm1 ! Horizontal slab
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 ) ! relative vorticity
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)
END_2D
IF( ln_dynvor_msk ) THEN ! mask/unmask relative vorticity
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk)
END_2D
@@ -255,5 +257,5 @@
END DO
- CALL lbc_lnk( 'dynvor', zwz, 'F', 1. )
+ CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp )
END SELECT
@@ -267,23 +269,27 @@
zwt(:,:) = ff_t(:,:) * e1e2t(:,:)*e3t(:,:,jk,Kmm)
CASE ( np_RVO ) !* relative vorticity
- DO_2D_01_01
+ 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) ) * e1e2t(ji,jj)*e3t(ji,jj,jk,Kmm)
+ & + zwz(ji-1,jj-1,jk) + zwz(ji,jj-1,jk) ) &
+ & * e1e2t(ji,jj)*e3t(ji,jj,jk,Kmm)
END_2D
CASE ( np_MET ) !* metric term
- DO_2D_01_01
+ DO_2D( 0, 1, 0, 1 )
zwt(ji,jj) = ( ( pv(ji,jj,jk) + pv(ji,jj-1,jk) ) * di_e2u_2(ji,jj) &
- & - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj) ) * e3t(ji,jj,jk,Kmm)
+ & - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj) ) &
+ & * e3t(ji,jj,jk,Kmm)
END_2D
CASE ( np_CRV ) !* Coriolis + relative vorticity
- DO_2D_01_01
+ 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) ) ) * e1e2t(ji,jj)*e3t(ji,jj,jk,Kmm)
+ & + zwz(ji-1,jj-1,jk) + zwz(ji,jj-1,jk) ) ) &
+ & * e1e2t(ji,jj)*e3t(ji,jj,jk,Kmm)
END_2D
CASE ( np_CME ) !* Coriolis + metric
- DO_2D_01_01
+ DO_2D( 0, 1, 0, 1 )
zwt(ji,jj) = ( ff_t(ji,jj) * e1e2t(ji,jj) &
& + ( pv(ji,jj,jk) + pv(ji,jj-1,jk) ) * di_e2u_2(ji,jj) &
- & - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj) ) * e3t(ji,jj,jk,Kmm)
+ & - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj) ) &
+ & * e3t(ji,jj,jk,Kmm)
END_2D
CASE DEFAULT ! error
@@ -292,5 +298,5 @@
!
! !== compute and add the vorticity term trend =!
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + r1_4 * r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm) &
& * ( zwt(ji+1,jj) * ( pv(ji+1,jj,jk) + pv(ji+1,jj-1,jk) ) &
@@ -352,20 +358,20 @@
zwz(:,:) = ff_f(:,:)
CASE ( np_RVO ) !* relative vorticity
- DO_2D_10_10
+ 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)
END_2D
CASE ( np_MET ) !* metric term
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
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_10_10
+ 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)
END_2D
CASE ( np_CME ) !* Coriolis + metric
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
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)
@@ -376,5 +382,5 @@
!
IF( ln_dynvor_msk ) THEN !== mask/unmask vorticity ==!
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
zwz(ji,jj) = zwz(ji,jj) * fmask(ji,jj,jk)
END_2D
@@ -390,5 +396,5 @@
ENDIF
! !== compute and add the vorticity term trend =!
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
zy1 = zwy(ji,jj-1) + zwy(ji+1,jj-1)
zy2 = zwy(ji,jj ) + zwy(ji+1,jj )
@@ -448,20 +454,20 @@
zwz(:,:) = ff_f(:,:)
CASE ( np_RVO ) !* relative vorticity
- DO_2D_10_10
+ 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)
END_2D
CASE ( np_MET ) !* metric term
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
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_10_10
+ 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)
END_2D
CASE ( np_CME ) !* Coriolis + metric
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
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)
@@ -472,5 +478,5 @@
!
IF( ln_dynvor_msk ) THEN !== mask/unmask vorticity ==!
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
zwz(ji,jj) = zwz(ji,jj) * fmask(ji,jj,jk)
END_2D
@@ -486,5 +492,5 @@
ENDIF
! !== compute and add the vorticity term trend =!
- DO_2D_00_00
+ 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 ) )
@@ -544,7 +550,9 @@
SELECT CASE( nn_een_e3f ) ! == reciprocal of e3 at F-point
CASE ( 0 ) ! original formulation (masked averaging of e3t divided by 4)
- DO_2D_10_10
- 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, 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) )
IF( ze3f /= 0._wp ) THEN ; z1_e3f(ji,jj) = 4._wp / ze3f
ELSE ; z1_e3f(ji,jj) = 0._wp
@@ -552,7 +560,9 @@
END_2D
CASE ( 1 ) ! new formulation (masked averaging of e3t divided by the sum of mask)
- DO_2D_10_10
- 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, 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) )
@@ -565,19 +575,19 @@
SELECT CASE( kvor ) !== vorticity considered ==!
CASE ( np_COR ) !* Coriolis (planetary vorticity)
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
zwz(ji,jj,jk) = ff_f(ji,jj) * z1_e3f(ji,jj)
END_2D
CASE ( np_RVO ) !* relative vorticity
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
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)
END_2D
CASE ( np_MET ) !* metric term
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
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)
END_2D
CASE ( np_CRV ) !* Coriolis + relative vorticity
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
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) ) &
@@ -585,5 +595,5 @@
END_2D
CASE ( np_CME ) !* Coriolis + metric
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
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)
@@ -594,5 +604,5 @@
!
IF( ln_dynvor_msk ) THEN !== mask/unmask vorticity ==!
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk)
END_2D
@@ -600,5 +610,5 @@
END DO ! End of slab
!
- CALL lbc_lnk( 'dynvor', zwz, 'F', 1. )
+ CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp )
DO jk = 1, jpkm1 ! Horizontal slab
@@ -625,5 +635,5 @@
END DO
END DO
- DO_2D_00_00
+ 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) )
@@ -685,9 +695,9 @@
SELECT CASE( kvor ) !== vorticity considered ==!
CASE ( np_COR ) !* Coriolis (planetary vorticity)
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
zwz(ji,jj,jk) = ff_f(ji,jj)
END_2D
CASE ( np_RVO ) !* relative vorticity
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
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) ) &
@@ -695,10 +705,10 @@
END_2D
CASE ( np_MET ) !* metric term
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
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)
END_2D
CASE ( np_CRV ) !* Coriolis + relative vorticity
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
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) ) &
@@ -706,5 +716,5 @@
END_2D
CASE ( np_CME ) !* Coriolis + metric
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
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)
@@ -715,5 +725,5 @@
!
IF( ln_dynvor_msk ) THEN !== mask/unmask vorticity ==!
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk)
END_2D
@@ -721,5 +731,5 @@
END DO
!
- CALL lbc_lnk( 'dynvor', zwz, 'F', 1. )
+ CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp )
!
DO jk = 1, jpkm1 ! Horizontal slab
@@ -748,5 +758,5 @@
END DO
END DO
- DO_2D_00_00
+ 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) )
@@ -808,7 +818,7 @@
IF(lwp) WRITE(numout,*) ' change fmask value in the angles (T) ln_vorlat = ', ln_vorlat
IF( ln_vorlat .AND. ( ln_dynvor_ene .OR. ln_dynvor_ens .OR. ln_dynvor_mix ) ) THEN
- DO_3D_10_10( 1, jpk )
+ DO_3D( 1, 0, 1, 0, 1, jpk )
IF( tmask(ji,jj+1,jk) + tmask(ji+1,jj+1,jk) &
- & + tmask(ji,jj ,jk) + tmask(ji+1,jj+1,jk) == 3._wp ) fmask(ji,jj,jk) = 1._wp
+ & + tmask(ji,jj ,jk) + tmask(ji+1,jj ,jk) == 3._wp ) fmask(ji,jj,jk) = 1._wp
END_3D
!
@@ -847,17 +857,17 @@
CASE( np_ENT ) !* T-point metric term : pre-compute di(e2u)/2 and dj(e1v)/2
ALLOCATE( di_e2u_2(jpi,jpj), dj_e1v_2(jpi,jpj) )
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
di_e2u_2(ji,jj) = ( e2u(ji,jj) - e2u(ji-1,jj ) ) * 0.5_wp
dj_e1v_2(ji,jj) = ( e1v(ji,jj) - e1v(ji ,jj-1) ) * 0.5_wp
END_2D
- CALL lbc_lnk_multi( 'dynvor', di_e2u_2, 'T', -1. , dj_e1v_2, 'T', -1. ) ! Lateral boundary conditions
+ CALL lbc_lnk_multi( 'dynvor', di_e2u_2, 'T', -1.0_wp , dj_e1v_2, 'T', -1.0_wp ) ! Lateral boundary conditions
!
CASE DEFAULT !* F-point metric term : pre-compute di(e2u)/(2*e1e2f) and dj(e1v)/(2*e1e2f)
ALLOCATE( di_e2v_2e1e2f(jpi,jpj), dj_e1u_2e1e2f(jpi,jpj) )
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
di_e2v_2e1e2f(ji,jj) = ( e2v(ji+1,jj ) - e2v(ji,jj) ) * 0.5 * r1_e1e2f(ji,jj)
dj_e1u_2e1e2f(ji,jj) = ( e1u(ji ,jj+1) - e1u(ji,jj) ) * 0.5 * r1_e1e2f(ji,jj)
END_2D
- CALL lbc_lnk_multi( 'dynvor', di_e2v_2e1e2f, 'F', -1. , dj_e1u_2e1e2f, 'F', -1. ) ! Lateral boundary conditions
+ CALL lbc_lnk_multi( 'dynvor', di_e2v_2e1e2f, 'F', -1.0_wp , dj_e1u_2e1e2f, 'F', -1.0_wp ) ! Lateral boundary conditions
END SELECT
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/dynzad.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/dynzad.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/dynzad.F90 (revision 13540)
@@ -29,4 +29,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -70,5 +71,5 @@
ENDIF
- IF( l_trddyn ) THEN ! Save puu(:,:,:,Krhs) and pvv(:,:,:,Krhs) trends
+ IF( l_trddyn ) THEN ! Save puu(:,:,:,Krhs) and pvv(:,:,:,Krhs) trends
ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) )
ztrdu(:,:,:) = puu(:,:,:,Krhs)
@@ -76,9 +77,9 @@
ENDIF
- DO jk = 2, jpkm1 ! Vertical momentum advection at level w and u- and v- vertical
- DO_2D_01_01
+ DO jk = 2, jpkm1 ! Vertical momentum advection at level w and u- and v- vertical
+ DO_2D( 0, 1, 0, 1 ) ! vertical fluxes
zww(ji,jj) = 0.25_wp * e1e2t(ji,jj) * ww(ji,jj,jk)
END_2D
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 ) ! vertical momentum advection at w-point
zwuw(ji,jj,jk) = ( zww(ji+1,jj ) + zww(ji,jj) ) * ( puu(ji,jj,jk-1,Kmm) - puu(ji,jj,jk,Kmm) )
zwvw(ji,jj,jk) = ( zww(ji ,jj+1) + zww(ji,jj) ) * ( pvv(ji,jj,jk-1,Kmm) - pvv(ji,jj,jk,Kmm) )
@@ -87,5 +88,5 @@
!
! Surface and bottom advective fluxes set to zero
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
zwuw(ji,jj, 1 ) = 0._wp
zwvw(ji,jj, 1 ) = 0._wp
@@ -94,10 +95,12 @@
END_2D
!
- DO_3D_00_00( 1, jpkm1 )
- puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zwuw(ji,jj,jk) + zwuw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm)
- pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( zwvw(ji,jj,jk) + zwvw(ji,jj,jk+1) ) * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! Vertical momentum advection at u- and v-points
+ puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zwuw(ji,jj,jk) + zwuw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj) &
+ & / e3u(ji,jj,jk,Kmm)
+ pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( zwvw(ji,jj,jk) + zwvw(ji,jj,jk+1) ) * r1_e1e2v(ji,jj) &
+ & / e3v(ji,jj,jk,Kmm)
END_3D
- IF( l_trddyn ) THEN ! save the vertical advection trends for diagnostic
+ IF( l_trddyn ) THEN ! save the vertical advection trends for diagnostic
ztrdu(:,:,:) = puu(:,:,:,Krhs) - ztrdu(:,:,:)
ztrdv(:,:,:) = pvv(:,:,:,Krhs) - ztrdv(:,:,:)
@@ -105,5 +108,5 @@
DEALLOCATE( ztrdu, ztrdv )
ENDIF
- ! ! Control print
+ ! ! Control print
IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' zad - Ua: ', mask1=umask, &
& tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' )
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/dynzdf.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/dynzdf.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/dynzdf.F90 (revision 13540)
@@ -38,4 +38,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -55,8 +56,8 @@
!! ** Method : - Leap-Frog time stepping on all trends but the vertical mixing
!! u(after) = u(before) + 2*dt * u(rhs) vector form or linear free surf.
- !! u(after) = ( e3u_b*u(before) + 2*dt * e3u_n*u(rhs) ) / e3u(after) otherwise
+ !! u(after) = ( e3u_b*u(before) + 2*dt * e3u_n*u(rhs) ) / e3u_after otherwise
!! - update the after velocity with the implicit vertical mixing.
!! This requires to solver the following system:
- !! u(after) = u(after) + 1/e3u(after) dk+1[ mi(avm) / e3uw(after) dk[ua] ]
+ !! u(after) = u(after) + 1/e3u_after dk+1[ mi(avm) / e3uw_after dk[ua] ]
!! with the following surface/top/bottom boundary condition:
!! surface: wind stress input (averaged over kt-1/2 & kt+1/2)
@@ -106,15 +107,17 @@
! ! time stepping except vertical diffusion
IF( ln_dynadv_vec .OR. ln_linssh ) THEN ! applied on velocity
- DO jk = 1, jpkm1
- puu(:,:,jk,Kaa) = ( puu(:,:,jk,Kbb) + rDt * puu(:,:,jk,Krhs) ) * umask(:,:,jk)
- pvv(:,:,jk,Kaa) = ( pvv(:,:,jk,Kbb) + rDt * pvv(:,:,jk,Krhs) ) * vmask(:,:,jk)
- END DO
+ 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 jk = 1, jpkm1
- puu(:,:,jk,Kaa) = ( e3u(:,:,jk,Kbb) * puu(:,:,jk,Kbb) &
- & + rDt * e3u(:,:,jk,Kmm) * puu(:,:,jk,Krhs) ) / e3u(:,:,jk,Kaa) * umask(:,:,jk)
- pvv(:,:,jk,Kaa) = ( e3v(:,:,jk,Kbb) * pvv(:,:,jk,Kbb) &
- & + rDt * e3v(:,:,jk,Kmm) * pvv(:,:,jk,Krhs) ) / e3v(:,:,jk,Kaa) * vmask(:,:,jk)
- END DO
+ 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
@@ -124,22 +127,26 @@
! 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 jk = 1, jpkm1 ! remove barotropic velocities
- puu(:,:,jk,Kaa) = ( puu(:,:,jk,Kaa) - uu_b(:,:,Kaa) ) * umask(:,:,jk)
- pvv(:,:,jk,Kaa) = ( pvv(:,:,jk,Kaa) - vv_b(:,:,Kaa) ) * vmask(:,:,jk)
- END DO
- DO_2D_00_00
+ 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)
- ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,iku,Kmm) + r_vvl * e3u(ji,jj,iku,Kaa)
- ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,ikv,Kmm) + r_vvl * e3v(ji,jj,ikv,Kaa)
+ ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,iku,Kmm) &
+ & + r_vvl * e3u(ji,jj,iku,Kaa)
+ ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,ikv,Kmm) &
+ & + r_vvl * e3v(ji,jj,ikv,Kaa)
puu(ji,jj,iku,Kaa) = puu(ji,jj,iku,Kaa) + rDt * 0.5*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) * uu_b(ji,jj,Kaa) / ze3ua
pvv(ji,jj,ikv,Kaa) = pvv(ji,jj,ikv,Kaa) + rDt * 0.5*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) * vv_b(ji,jj,Kaa) / ze3va
END_2D
- IF( ln_isfcav ) THEN ! Ocean cavities (ISF)
- DO_2D_00_00
+ 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)
- ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,iku,Kmm) + r_vvl * e3u(ji,jj,iku,Kaa)
- ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,ikv,Kmm) + r_vvl * e3v(ji,jj,ikv,Kaa)
+ ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,iku,Kmm) &
+ & + r_vvl * e3u(ji,jj,iku,Kaa)
+ ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,ikv,Kmm) &
+ & + r_vvl * e3v(ji,jj,ikv,Kaa)
puu(ji,jj,iku,Kaa) = puu(ji,jj,iku,Kaa) + rDt * 0.5*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * uu_b(ji,jj,Kaa) / ze3ua
pvv(ji,jj,ikv,Kaa) = pvv(ji,jj,ikv,Kaa) + rDt * 0.5*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) * vv_b(ji,jj,Kaa) / ze3va
@@ -155,6 +162,7 @@
SELECT CASE( nldf_dyn )
CASE( np_lap_i ) ! rotated lateral mixing: add its vertical mixing (akzu)
- DO_3D_00_00( 1, jpkm1 )
- ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,jk,Kmm) + r_vvl * e3u(ji,jj,jk,Kaa) ! after scale factor at U-point
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,jk,Kmm) &
+ & + r_vvl * e3u(ji,jj,jk,Kaa) ! after scale factor at U-point
zzwi = - zdt * ( avm(ji+1,jj,jk ) + avm(ji,jj,jk ) + akzu(ji,jj,jk ) ) &
& / ( ze3ua * e3uw(ji,jj,jk ,Kmm) ) * wumask(ji,jj,jk )
@@ -168,8 +176,11 @@
END_3D
CASE DEFAULT ! iso-level lateral mixing
- DO_3D_00_00( 1, jpkm1 )
- ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,jk,Kmm) + r_vvl * e3u(ji,jj,jk,Kaa) ! after scale factor at U-point
- zzwi = - zdt * ( avm(ji+1,jj,jk ) + avm(ji,jj,jk ) ) / ( ze3ua * e3uw(ji,jj,jk ,Kmm) ) * wumask(ji,jj,jk )
- zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) ) / ( ze3ua * e3uw(ji,jj,jk+1,Kmm) ) * wumask(ji,jj,jk+1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,jk,Kmm) & ! after scale factor at U-point
+ & + r_vvl * e3u(ji,jj,jk,Kaa)
+ zzwi = - zdt * ( avm(ji+1,jj,jk ) + avm(ji,jj,jk ) ) &
+ & / ( ze3ua * e3uw(ji,jj,jk ,Kmm) ) * wumask(ji,jj,jk )
+ zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) ) &
+ & / ( ze3ua * e3uw(ji,jj,jk+1,Kmm) ) * wumask(ji,jj,jk+1)
zWui = ( wi(ji,jj,jk ) + wi(ji+1,jj,jk ) ) / ze3ua
zWus = ( wi(ji,jj,jk+1) + wi(ji+1,jj,jk+1) ) / ze3ua
@@ -179,8 +190,10 @@
END_3D
END SELECT
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 ) !* Surface boundary conditions
zwi(ji,jj,1) = 0._wp
- ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,1,Kmm) + r_vvl * e3u(ji,jj,1,Kaa)
- zzws = - zdt * ( avm(ji+1,jj,2) + avm(ji ,jj,2) ) / ( ze3ua * e3uw(ji,jj,2,Kmm) ) * wumask(ji,jj,2)
+ ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,1,Kmm) &
+ & + r_vvl * e3u(ji,jj,1,Kaa)
+ zzws = - zdt * ( avm(ji+1,jj,2) + avm(ji ,jj,2) ) &
+ & / ( ze3ua * e3uw(ji,jj,2,Kmm) ) * wumask(ji,jj,2)
zWus = ( wi(ji ,jj,2) + wi(ji+1,jj,2) ) / ze3ua
zws(ji,jj,1 ) = zzws - zdt * MAX( zWus, 0._wp )
@@ -190,6 +203,7 @@
SELECT CASE( nldf_dyn )
CASE( np_lap_i ) ! rotated lateral mixing: add its vertical mixing (akzu)
- DO_3D_00_00( 1, jpkm1 )
- ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,jk,Kmm) + r_vvl * e3u(ji,jj,jk,Kaa) ! after scale factor at U-point
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,jk,Kmm) &
+ & + r_vvl * e3u(ji,jj,jk,Kaa) ! after scale factor at U-point
zzwi = - zdt * ( avm(ji+1,jj,jk ) + avm(ji,jj,jk ) + akzu(ji,jj,jk ) ) &
& / ( ze3ua * e3uw(ji,jj,jk ,Kmm) ) * wumask(ji,jj,jk )
@@ -201,8 +215,11 @@
END_3D
CASE DEFAULT ! iso-level lateral mixing
- DO_3D_00_00( 1, jpkm1 )
- ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,jk,Kmm) + r_vvl * e3u(ji,jj,jk,Kaa) ! after scale factor at U-point
- zzwi = - zdt * ( avm(ji+1,jj,jk ) + avm(ji,jj,jk ) ) / ( ze3ua * e3uw(ji,jj,jk ,Kmm) ) * wumask(ji,jj,jk )
- zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) ) / ( ze3ua * e3uw(ji,jj,jk+1,Kmm) ) * wumask(ji,jj,jk+1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,jk,Kmm) &
+ & + r_vvl * e3u(ji,jj,jk,Kaa) ! after scale factor at U-point
+ zzwi = - zdt * ( avm(ji+1,jj,jk ) + avm(ji,jj,jk ) ) &
+ & / ( ze3ua * e3uw(ji,jj,jk ,Kmm) ) * wumask(ji,jj,jk )
+ zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) ) &
+ & / ( ze3ua * e3uw(ji,jj,jk+1,Kmm) ) * wumask(ji,jj,jk+1)
zwi(ji,jj,jk) = zzwi
zws(ji,jj,jk) = zzws
@@ -210,5 +227,5 @@
END_3D
END SELECT
- DO_2D_00_00
+ 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)
@@ -224,14 +241,16 @@
!
IF ( ln_drgimp ) THEN ! implicit bottom friction
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
iku = mbku(ji,jj) ! ocean bottom level at u- and v-points
- ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,iku,Kmm) + r_vvl * e3u(ji,jj,iku,Kaa) ! after scale factor at T-point
+ ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,iku,Kmm) &
+ & + r_vvl * e3u(ji,jj,iku,Kaa) ! after scale factor at T-point
zwd(ji,jj,iku) = zwd(ji,jj,iku) - rDt * 0.5*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) / ze3ua
END_2D
- IF ( ln_isfcav ) THEN ! top friction (always implicit)
- DO_2D_00_00
+ IF ( ln_isfcav.OR.ln_drgice_imp ) THEN ! top friction (always implicit)
+ DO_2D( 0, 0, 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
- ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,iku,Kmm) + r_vvl * e3u(ji,jj,iku,Kaa) ! after scale factor at T-point
+ ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,iku,Kmm) &
+ & + r_vvl * e3u(ji,jj,iku,Kaa) ! after scale factor at T-point
zwd(ji,jj,iku) = zwd(ji,jj,iku) - rDt * 0.5*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) / ze3ua
END_2D
@@ -254,21 +273,22 @@
!-----------------------------------------------------------------------
!
- DO_3D_00_00( 2, jpkm1 )
+ 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_00_00
- ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,1,Kmm) + r_vvl * e3u(ji,jj,1,Kaa)
+ DO_2D( 0, 0, 0, 0 ) !== second recurrence: SOLk = RHSk - Lk / Dk-1 Lk-1 ==!
+ ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,1,Kmm) &
+ & + r_vvl * e3u(ji,jj,1,Kaa)
puu(ji,jj,1,Kaa) = puu(ji,jj,1,Kaa) + rDt * 0.5_wp * ( utau_b(ji,jj) + utau(ji,jj) ) &
& / ( ze3ua * rho0 ) * umask(ji,jj,1)
END_2D
- DO_3D_00_00( 2, jpkm1 )
+ 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_00_00
+ 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_00_00( jpk-2, 1, -1 )
+ 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
@@ -281,6 +301,7 @@
SELECT CASE( nldf_dyn )
CASE( np_lap_i ) ! rotated lateral mixing: add its vertical mixing (akzv)
- DO_3D_00_00( 1, jpkm1 )
- ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,jk,Kmm) + r_vvl * e3v(ji,jj,jk,Kaa) ! after scale factor at V-point
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,jk,Kmm) &
+ & + r_vvl * e3v(ji,jj,jk,Kaa) ! after scale factor at V-point
zzwi = - zdt * ( avm(ji,jj+1,jk ) + avm(ji,jj,jk ) + akzv(ji,jj,jk ) ) &
& / ( ze3va * e3vw(ji,jj,jk ,Kmm) ) * wvmask(ji,jj,jk )
@@ -294,8 +315,11 @@
END_3D
CASE DEFAULT ! iso-level lateral mixing
- DO_3D_00_00( 1, jpkm1 )
- ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,jk,Kmm) + r_vvl * e3v(ji,jj,jk,Kaa) ! after scale factor at V-point
- zzwi = - zdt * ( avm(ji,jj+1,jk ) + avm(ji,jj,jk ) ) / ( ze3va * e3vw(ji,jj,jk ,Kmm) ) * wvmask(ji,jj,jk )
- zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) ) / ( ze3va * e3vw(ji,jj,jk+1,Kmm) ) * wvmask(ji,jj,jk+1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,jk,Kmm) &
+ & + r_vvl * e3v(ji,jj,jk,Kaa) ! after scale factor at V-point
+ zzwi = - zdt * ( avm(ji,jj+1,jk ) + avm(ji,jj,jk ) ) &
+ & / ( ze3va * e3vw(ji,jj,jk ,Kmm) ) * wvmask(ji,jj,jk )
+ zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) ) &
+ & / ( ze3va * e3vw(ji,jj,jk+1,Kmm) ) * wvmask(ji,jj,jk+1)
zWvi = ( wi(ji,jj,jk ) + wi(ji,jj+1,jk ) ) / ze3va
zWvs = ( wi(ji,jj,jk+1) + wi(ji,jj+1,jk+1) ) / ze3va
@@ -305,8 +329,10 @@
END_3D
END SELECT
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 ) !* Surface boundary conditions
zwi(ji,jj,1) = 0._wp
- ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,1,Kmm) + r_vvl * e3v(ji,jj,1,Kaa)
- zzws = - zdt * ( avm(ji,jj+1,2) + avm(ji,jj,2) ) / ( ze3va * e3vw(ji,jj,2,Kmm) ) * wvmask(ji,jj,2)
+ ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,1,Kmm) &
+ & + r_vvl * e3v(ji,jj,1,Kaa)
+ zzws = - zdt * ( avm(ji,jj+1,2) + avm(ji,jj,2) ) &
+ & / ( ze3va * e3vw(ji,jj,2,Kmm) ) * wvmask(ji,jj,2)
zWvs = ( wi(ji,jj ,2) + wi(ji,jj+1,2) ) / ze3va
zws(ji,jj,1 ) = zzws - zdt * MAX( zWvs, 0._wp )
@@ -316,6 +342,7 @@
SELECT CASE( nldf_dyn )
CASE( np_lap_i ) ! rotated lateral mixing: add its vertical mixing (akzu)
- DO_3D_00_00( 1, jpkm1 )
- ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,jk,Kmm) + r_vvl * e3v(ji,jj,jk,Kaa) ! after scale factor at V-point
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,jk,Kmm) &
+ & + r_vvl * e3v(ji,jj,jk,Kaa) ! after scale factor at V-point
zzwi = - zdt * ( avm(ji,jj+1,jk ) + avm(ji,jj,jk ) + akzv(ji,jj,jk ) ) &
& / ( ze3va * e3vw(ji,jj,jk ,Kmm) ) * wvmask(ji,jj,jk )
@@ -327,8 +354,11 @@
END_3D
CASE DEFAULT ! iso-level lateral mixing
- DO_3D_00_00( 1, jpkm1 )
- ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,jk,Kmm) + r_vvl * e3v(ji,jj,jk,Kaa) ! after scale factor at V-point
- zzwi = - zdt * ( avm(ji,jj+1,jk ) + avm(ji,jj,jk ) ) / ( ze3va * e3vw(ji,jj,jk ,Kmm) ) * wvmask(ji,jj,jk )
- zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) ) / ( ze3va * e3vw(ji,jj,jk+1,Kmm) ) * wvmask(ji,jj,jk+1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,jk,Kmm) &
+ & + r_vvl * e3v(ji,jj,jk,Kaa) ! after scale factor at V-point
+ zzwi = - zdt * ( avm(ji,jj+1,jk ) + avm(ji,jj,jk ) ) &
+ & / ( ze3va * e3vw(ji,jj,jk ,Kmm) ) * wvmask(ji,jj,jk )
+ zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) ) &
+ & / ( ze3va * e3vw(ji,jj,jk+1,Kmm) ) * wvmask(ji,jj,jk+1)
zwi(ji,jj,jk) = zzwi
zws(ji,jj,jk) = zzws
@@ -336,5 +366,5 @@
END_3D
END SELECT
- DO_2D_00_00
+ 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)
@@ -349,13 +379,15 @@
!
IF( ln_drgimp ) THEN
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
ikv = mbkv(ji,jj) ! (deepest ocean u- and v-points)
- ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,ikv,Kmm) + r_vvl * e3v(ji,jj,ikv,Kaa) ! after scale factor at T-point
+ ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,ikv,Kmm) &
+ & + r_vvl * e3v(ji,jj,ikv,Kaa) ! after scale factor at T-point
zwd(ji,jj,ikv) = zwd(ji,jj,ikv) - rDt * 0.5*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) / ze3va
END_2D
- IF ( ln_isfcav ) THEN
- DO_2D_00_00
+ 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)
- ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,ikv,Kmm) + r_vvl * e3v(ji,jj,ikv,Kaa) ! after scale factor at T-point
+ ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,ikv,Kmm) &
+ & + r_vvl * e3v(ji,jj,ikv,Kaa) ! after scale factor at T-point
zwd(ji,jj,ikv) = zwd(ji,jj,ikv) - rDt * 0.5*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) / ze3va
END_2D
@@ -378,21 +410,22 @@
!-----------------------------------------------------------------------
!
- DO_3D_00_00( 2, jpkm1 )
+ 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_00_00
- ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,1,Kmm) + r_vvl * e3v(ji,jj,1,Kaa)
+ DO_2D( 0, 0, 0, 0 ) !== second recurrence: SOLk = RHSk - Lk / Dk-1 Lk-1 ==!
+ ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,1,Kmm) &
+ & + r_vvl * e3v(ji,jj,1,Kaa)
pvv(ji,jj,1,Kaa) = pvv(ji,jj,1,Kaa) + rDt * 0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) ) &
& / ( ze3va * rho0 ) * vmask(ji,jj,1)
END_2D
- DO_3D_00_00( 2, jpkm1 )
+ 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_00_00
+ 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_00_00( jpk-2, 1, -1 )
+ 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
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/sshwzv.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/sshwzv.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/sshwzv.F90 (revision 13540)
@@ -28,4 +28,5 @@
USE bdydyn2d ! bdy_ssh routine
#if defined key_agrif
+ USE agrif_oce
USE agrif_oce_interp
#endif
@@ -50,4 +51,6 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
+
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -110,10 +113,11 @@
!
#if defined key_agrif
- Kbb_a = Kbb; Kmm_a = Kmm; Krhs_a = Kaa; CALL agrif_ssh( kt )
+ Kbb_a = Kbb ; Kmm_a = Kmm ; Krhs_a = Kaa
+ CALL agrif_ssh( kt )
#endif
!
IF ( .NOT.ln_dynspg_ts ) THEN
IF( ln_bdy ) THEN
- CALL lbc_lnk( 'sshwzv', pssh(:,:,Kaa), 'T', 1. ) ! Not sure that's necessary
+ CALL lbc_lnk( 'sshwzv', pssh(:,:,Kaa), 'T', 1.0_wp ) ! Not sure that's necessary
CALL bdy_ssh( pssh(:,:,Kaa) ) ! Duplicate sea level across open boundaries
ENDIF
@@ -130,5 +134,5 @@
- SUBROUTINE wzv( kt, Kbb, Kmm, pww, Kaa )
+ SUBROUTINE wzv( kt, Kbb, Kmm, Kaa, pww )
!!----------------------------------------------------------------------
!! *** ROUTINE wzv ***
@@ -147,5 +151,5 @@
INTEGER , INTENT(in) :: kt ! time step
INTEGER , INTENT(in) :: Kbb, Kmm, Kaa ! time level indices
- REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pww ! now vertical velocity
+ REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pww ! vertical velocity at Kmm
!
INTEGER :: ji, jj, jk ! dummy loop indices
@@ -166,5 +170,7 @@
! !------------------------------!
!
- IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! z_tilde and layer cases
+ ! !===============================!
+ IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN !== z_tilde and layer cases ==!
+ ! !===============================!
ALLOCATE( zhdiv(jpi,jpj,jpk) )
!
@@ -172,23 +178,33 @@
! 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_00_00
+ DO_2D( 0, 0, 0, 0 )
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
- CALL lbc_lnk('sshwzv', zhdiv, 'T', 1.) ! - ML - Perhaps not necessary: not used for horizontal "connexions"
+ 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 jk = jpkm1, 1, -1 ! integrate from the bottom the hor. divergence
! computation of w
- pww(:,:,jk) = pww(:,:,jk+1) - ( e3t(:,:,jk,Kmm) * hdiv(:,:,jk) + zhdiv(:,:,jk) &
- & + r1_Dt * ( e3t(:,:,jk,Kaa) - e3t(:,:,jk,Kbb) ) ) * tmask(:,:,jk)
+ pww(:,:,jk) = pww(:,:,jk+1) - ( e3t(:,:,jk,Kmm) * hdiv(:,:,jk) &
+ & + zhdiv(:,:,jk) &
+ & + r1_Dt * ( e3t(:,:,jk,Kaa) &
+ & - e3t(:,:,jk,Kbb) ) ) * tmask(:,:,jk)
END DO
! IF( ln_vvl_layer ) pww(:,:,:) = 0.e0
DEALLOCATE( zhdiv )
- ELSE ! z_star and linear free surface cases
- DO jk = jpkm1, 1, -1 ! integrate from the bottom the hor. divergence
- ! computation of w
+ ! !=================================!
+ ELSEIF( ln_linssh ) THEN !== linear free surface cases ==!
+ ! !=================================!
+ DO jk = jpkm1, 1, -1 ! integrate from the bottom the hor. divergence
+ pww(:,:,jk) = pww(:,:,jk+1) - ( e3t(:,:,jk,Kmm) * hdiv(:,:,jk) ) * tmask(:,:,jk)
+ END DO
+ ! !==========================================!
+ ELSE !== Quasi-Eulerian vertical coordinate ==! ('key_qco')
+ ! !==========================================!
+ DO jk = jpkm1, 1, -1 ! integrate from the bottom the hor. divergence
pww(:,:,jk) = pww(:,:,jk+1) - ( e3t(:,:,jk,Kmm) * hdiv(:,:,jk) &
- & + r1_Dt * ( e3t(:,:,jk,Kaa) - e3t(:,:,jk,Kbb) ) ) * tmask(:,:,jk)
+ & + r1_Dt * ( e3t(:,:,jk,Kaa) &
+ & - e3t(:,:,jk,Kbb) ) ) * tmask(:,:,jk)
END DO
ENDIF
@@ -200,12 +216,43 @@
ENDIF
!
-#if defined key_agrif
- IF( .NOT. AGRIF_Root() ) THEN
- IF ((nbondi == 1).OR.(nbondi == 2)) pww(nlci-1 , : ,:) = 0.e0 ! east
- IF ((nbondi == -1).OR.(nbondi == 2)) pww(2 , : ,:) = 0.e0 ! west
- IF ((nbondj == 1).OR.(nbondj == 2)) pww(: ,nlcj-1 ,:) = 0.e0 ! north
- IF ((nbondj == -1).OR.(nbondj == 2)) pww(: ,2 ,:) = 0.e0 ! south
+#if defined key_agrif
+ IF( .NOT. AGRIF_Root() ) THEN
+ !
+ ! Mask vertical velocity at first/last columns/row
+ ! inside computational domain (cosmetic)
+ DO jk = 1, jpkm1
+ IF( lk_west ) THEN ! --- West --- !
+ DO ji = mi0(2+nn_hls), mi1(2+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 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 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 ji = 1, jpi
+ pww(ji,jj,jk) = 0._wp
+ END DO
+ END DO
+ ENDIF
+ !
+ END DO
+ !
ENDIF
-#endif
+#endif
!
IF( ln_timing ) CALL timing_stop('wzv')
@@ -214,5 +261,5 @@
- SUBROUTINE ssh_atf( kt, Kbb, Kmm, Kaa, pssh )
+ SUBROUTINE ssh_atf( kt, Kbb, Kmm, Kaa, pssh, pssh_f )
!!----------------------------------------------------------------------
!! *** ROUTINE ssh_atf ***
@@ -231,7 +278,9 @@
INTEGER , INTENT(in ) :: kt ! ocean time-step index
INTEGER , INTENT(in ) :: Kbb, Kmm, Kaa ! ocean time level indices
- REAL(wp), DIMENSION(jpi,jpj,jpt), INTENT(inout) :: pssh ! SSH field
+ REAL(wp), DIMENSION(jpi,jpj,jpt) , TARGET, INTENT(inout) :: pssh ! SSH field
+ REAL(wp), DIMENSION(jpi,jpj ), OPTIONAL, TARGET, INTENT( out) :: pssh_f ! filtered SSH field
!
REAL(wp) :: zcoef ! local scalar
+ REAL(wp), POINTER, DIMENSION(:,:) :: zssh ! pointer for filtered SSH
!!----------------------------------------------------------------------
!
@@ -245,4 +294,7 @@
! !== Euler time-stepping: no filter, just swap ==!
IF ( .NOT.( l_1st_euler ) ) THEN ! Only do time filtering for leapfrog timesteps
+ IF( PRESENT( pssh_f ) ) THEN ; zssh => pssh_f
+ ELSE ; zssh => pssh(:,:,Kmm)
+ ENDIF
! ! filtered "now" field
pssh(:,:,Kmm) = pssh(:,:,Kmm) + rn_atfp * ( pssh(:,:,Kbb) - 2 * pssh(:,:,Kmm) + pssh(:,:,Kaa) )
@@ -266,4 +318,5 @@
END SUBROUTINE ssh_atf
+
SUBROUTINE wAimp( kt, Kmm )
!!----------------------------------------------------------------------
@@ -286,5 +339,5 @@
!
INTEGER :: ji, jj, jk ! dummy loop indices
- REAL(wp) :: zCu, zcff, z1_e3t ! local scalars
+ REAL(wp) :: zCu, zcff, z1_e3t, zdt ! local scalars
REAL(wp) , PARAMETER :: Cu_min = 0.15_wp ! local parameters
REAL(wp) , PARAMETER :: Cu_max = 0.30_wp ! local parameters
@@ -303,22 +356,27 @@
!
! 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_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
z1_e3t = 1._wp / e3t(ji,jj,jk,Kmm)
- ! 2*rn_Dt and not rDt (for restartability)
- Cu_adv(ji,jj,jk) = 2._wp * rn_Dt * ( ( 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 ) ) &
+ 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 ) ) &
+ & + ( 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_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
z1_e3t = 1._wp / e3t(ji,jj,jk,Kmm)
- ! 2*rn_Dt and not rDt (for restartability)
- Cu_adv(ji,jj,jk) = 2._wp * rn_Dt * ( ( MAX( ww(ji,jj,jk) , 0._wp ) - MIN( ww(ji,jj,jk+1) , 0._wp ) ) &
+ 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), 0._wp ) - &
& MIN( e2u(ji-1,jj)*e3u(ji-1,jj,jk,Kmm)*uu(ji-1,jj,jk,Kmm), 0._wp ) ) &
@@ -330,10 +388,10 @@
END_3D
ENDIF
- CALL lbc_lnk( 'sshwzv', Cu_adv, 'T', 1. )
+ CALL lbc_lnk( 'sshwzv', Cu_adv, 'T', 1.0_wp )
!
CALL iom_put("Courant",Cu_adv)
!
IF( MAXVAL( Cu_adv(:,:,:) ) > Cu_min ) THEN ! Quick check if any breaches anywhere
- DO_3DS_11_11( jpkm1, 2, -1 )
+ DO_3DS( 1, 1, 1, 1, jpkm1, 2, -1 ) ! or scan Courant criterion and partition ! w where necessary
!
zCu = MAX( Cu_adv(ji,jj,jk) , Cu_adv(ji,jj,jk-1) )
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/wet_dry.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/wet_dry.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/DYN/wet_dry.F90 (revision 13540)
@@ -33,4 +33,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! critical depths,filters, limiters,and masks for Wetting and Drying
@@ -173,5 +174,5 @@
!
wdmask(:,:) = 1._wp
- DO_2D_01_01
+ DO_2D( 0, 1, 0, 1 )
!
IF( tmask(ji,jj,1) < 0.5_wp ) CYCLE ! we don't care about land cells
@@ -197,5 +198,5 @@
wdramp(:,:) = min((ht_0(:,:) + psshb1(:,:) - rn_wdmin1)/(rn_wdmin0 - rn_wdmin1),1.0_wp)
!jth assume don't need a lbc_lnk here
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
wdrampu(ji,jj) = MIN( wdramp(ji,jj) , wdramp(ji+1,jj) )
wdrampv(ji,jj) = MIN( wdramp(ji,jj) , wdramp(ji,jj+1) )
@@ -210,5 +211,5 @@
jflag = 0 ! flag indicating if any further iterations are needed
!
- DO_2D_01_01
+ DO_2D( 0, 1, 0, 1 )
IF( tmask(ji, jj, 1) < 0.5_wp ) CYCLE
IF( ht_0(ji,jj) > zdepwd ) CYCLE
@@ -241,5 +242,5 @@
ENDIF
END_2D
- CALL lbc_lnk_multi( 'wet_dry', zwdlmtu, 'U', 1., zwdlmtv, 'V', 1. )
+ CALL lbc_lnk_multi( 'wet_dry', zwdlmtu, 'U', 1.0_wp, zwdlmtv, 'V', 1.0_wp )
!
CALL mpp_max('wet_dry', jflag) !max over the global domain
@@ -257,6 +258,6 @@
!
!!gm TO BE SUPPRESSED ? these lbc_lnk are useless since zwdlmtu and zwdlmtv are defined everywhere !
- CALL lbc_lnk_multi( 'wet_dry', puu(:,:,:,Kmm) , 'U', -1., pvv(:,:,:,Kmm) , 'V', -1. )
- CALL lbc_lnk_multi( 'wet_dry', uu_b(:,:,Kmm), 'U', -1., vv_b(:,:,Kmm), 'V', -1. )
+ CALL lbc_lnk_multi( 'wet_dry', puu(:,:,:,Kmm) , 'U', -1.0_wp, pvv(:,:,:,Kmm) , 'V', -1.0_wp )
+ CALL lbc_lnk_multi( 'wet_dry', uu_b(:,:,Kmm), 'U', -1.0_wp, vv_b(:,:,Kmm), 'V', -1.0_wp )
!!gm
!
@@ -306,5 +307,5 @@
zwdlmtv(:,:) = 1._wp
!
- DO_2D_01_01
+ DO_2D( 0, 1, 0, 1 ) ! Horizontal Flux in u and v direction
!
IF( tmask(ji, jj, 1 ) < 0.5_wp) CYCLE ! we don't care about land cells
@@ -332,5 +333,5 @@
jflag = 0 ! flag indicating if any further iterations are needed
!
- DO_2D_01_01
+ DO_2D( 0, 1, 0, 1 )
!
IF( tmask(ji, jj, 1 ) < 0.5_wp ) CYCLE
@@ -366,5 +367,5 @@
END_2D
!
- CALL lbc_lnk_multi( 'wet_dry', zwdlmtu, 'U', 1., zwdlmtv, 'V', 1. )
+ CALL lbc_lnk_multi( 'wet_dry', zwdlmtu, 'U', 1.0_wp, zwdlmtv, 'V', 1.0_wp )
!
CALL mpp_max('wet_dry', jflag) !max over the global domain
@@ -378,5 +379,5 @@
!
!!gm THIS lbc_lnk is useless since it is already done at the end of the jk1-loop
- CALL lbc_lnk_multi( 'wet_dry', zflxu, 'U', -1., zflxv, 'V', -1. )
+ CALL lbc_lnk_multi( 'wet_dry', zflxu, 'U', -1.0_wp, zflxv, 'V', -1.0_wp )
!!gm end
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/FLO/flo4rk.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/FLO/flo4rk.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/FLO/flo4rk.F90 (revision 13540)
@@ -26,4 +26,5 @@
REAL(wp), DIMENSION (3) :: scoef1 = (/ 0.5 , 0.5 , 1.0 /) !
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/FLO/floblk.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/FLO/floblk.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/FLO/floblk.F90 (revision 13540)
@@ -20,4 +20,6 @@
PUBLIC flo_blk ! routine called by floats.F90
+# include "domzgr_substitute.h90"
+
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -41,4 +43,8 @@
INTEGER, INTENT( in ) :: Kbb, Kmm ! ocean time level indices
!!
+#ifndef key_agrif
+
+!RB super quick fix to compile with agrif
+
INTEGER :: jfl ! dummy loop arguments
INTEGER :: ind, ifin, iloop
@@ -100,6 +106,6 @@
222 DO jfl = 1, jpnfl
# if defined key_mpp_mpi
- IF( iil(jfl) >= mig(nldi) .AND. iil(jfl) <= mig(nlei) .AND. &
- ijl(jfl) >= mjg(nldj) .AND. ijl(jfl) <= mjg(nlej) ) THEN
+ 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
@@ -111,8 +117,16 @@
! compute the transport across the mesh where the float is.
!!bug (gm) change e3t into e3. but never checked
- zsurfx(1) = e2u(iiloc(jfl)-1,ijloc(jfl) ) * e3u(iiloc(jfl)-1,ijloc(jfl) ,-ikl(jfl),Kmm)
- zsurfx(2) = e2u(iiloc(jfl) ,ijloc(jfl) ) * e3u(iiloc(jfl) ,ijloc(jfl) ,-ikl(jfl),Kmm)
- zsurfy(1) = e1v(iiloc(jfl) ,ijloc(jfl)-1) * e3v(iiloc(jfl) ,ijloc(jfl)-1,-ikl(jfl),Kmm)
- zsurfy(2) = e1v(iiloc(jfl) ,ijloc(jfl) ) * e3v(iiloc(jfl) ,ijloc(jfl) ,-ikl(jfl),Kmm)
+ zsurfx(1) = &
+ & e2u(iiloc(jfl)-1,ijloc(jfl) ) &
+ & * e3u(iiloc(jfl)-1,ijloc(jfl) ,-ikl(jfl),Kmm)
+ zsurfx(2) = &
+ & e2u(iiloc(jfl) ,ijloc(jfl) ) &
+ & * e3u(iiloc(jfl) ,ijloc(jfl) ,-ikl(jfl),Kmm)
+ zsurfy(1) = &
+ & e1v(iiloc(jfl) ,ijloc(jfl)-1) &
+ & * e3v(iiloc(jfl) ,ijloc(jfl)-1,-ikl(jfl),Kmm)
+ zsurfy(2) = &
+ & e1v(iiloc(jfl) ,ijloc(jfl) ) &
+ & * e3v(iiloc(jfl) ,ijloc(jfl) ,-ikl(jfl),Kmm)
! for a isobar float zsurfz is put to zero. The vertical velocity will be zero too.
@@ -175,5 +189,5 @@
zgidfl(jfl) = float(iioutfl(jfl) - iiinfl(jfl))
IF( zufl(jfl)*zuoutfl <= 0. ) THEN
- ztxfl(jfl) = 1.E99
+ ztxfl(jfl) = HUGE(1._wp)
ELSE
IF( ABS(zudfl(jfl)) >= 1.E-5 ) THEN
@@ -191,5 +205,5 @@
zgjdfl(jfl) = float(ijoutfl(jfl)-ijinfl(jfl))
IF( zvfl(jfl)*zvoutfl <= 0. ) THEN
- ztyfl(jfl) = 1.E99
+ ztyfl(jfl) = HUGE(1._wp)
ELSE
IF( ABS(zvdfl(jfl)) >= 1.E-5 ) THEN
@@ -208,5 +222,5 @@
zgkdfl(jfl) = float(ikoutfl(jfl) - ikinfl(jfl))
IF( zwfl(jfl)*zwoutfl <= 0. ) THEN
- ztzfl(jfl) = 1.E99
+ ztzfl(jfl) = HUGE(1._wp)
ELSE
IF( ABS(zwdfl(jfl)) >= 1.E-5 ) THEN
@@ -364,4 +378,5 @@
GO TO 222
ENDIF
+#endif
!
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/FLO/flodom.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/FLO/flodom.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/FLO/flodom.F90 (revision 13540)
@@ -155,6 +155,6 @@
ikmfl(jfl) = 0
# if defined key_mpp_mpi
- DO ji = MAX(nldi,2), nlei
- DO jj = MAX(nldj,2), nlej ! NO vector opt.
+ DO ji = MAX(Nis0,2), Nie0
+ DO jj = MAX(Njs0,2), Nje0 ! NO vector opt.
# else
DO ji = 2, jpi
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/FLO/florst.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/FLO/florst.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/FLO/florst.F90 (revision 13540)
@@ -98,8 +98,8 @@
IF( lk_mpp ) THEN
DO jfl = 1, jpnfl
- IF( (INT(tpifl(jfl)) >= mig(nldi)) .AND. &
- &(INT(tpifl(jfl)) <= mig(nlei)) .AND. &
- &(INT(tpjfl(jfl)) >= mjg(nldj)) .AND. &
- &(INT(tpjfl(jfl)) <= mjg(nlej)) ) THEN
+ 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
iperproc(narea) = iperproc(narea)+1
ENDIF
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/FLO/flowri.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/FLO/flowri.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/FLO/flowri.F90 (revision 13540)
@@ -105,6 +105,6 @@
ibfloc = mj1( ibfl )
- IF( nldi <= iafloc .AND. iafloc <= nlei .AND. &
- & nldj <= ibfloc .AND. ibfloc <= nlej ) THEN
+ IF( Nis0 <= iafloc .AND. iafloc <= Nie0 .AND. &
+ & Njs0 <= ibfloc .AND. ibfloc <= Nje0 ) THEN
!the float is inside of current proc's area
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/ICB/icb_oce.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/ICB/icb_oce.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/ICB/icb_oce.F90 (revision 13540)
@@ -57,9 +57,9 @@
TYPE, PUBLIC :: point !: properties of an individual iceberg (position, mass, size, etc...)
INTEGER :: year
- REAL(wp) :: xi , yj ! iceberg coordinates in the (i,j) referential (global)
- REAL(wp) :: e1 , e2 ! horizontal scale factors at the iceberg position
- REAL(wp) :: lon, lat, day ! geographic position
- REAL(wp) :: mass, thickness, width, length, uvel, vvel ! iceberg physical properties
- REAL(wp) :: uo, vo, ui, vi, ua, va, ssh_x, ssh_y, sst, cn, hi ! properties of iceberg environment
+ REAL(wp) :: xi , yj ! iceberg coordinates in the (i,j) referential (global)
+ REAL(wp) :: e1 , e2 ! horizontal scale factors at the iceberg position
+ REAL(wp) :: lon, lat, day ! geographic position
+ REAL(wp) :: mass, thickness, width, length, uvel, vvel ! iceberg physical properties
+ REAL(wp) :: uo, vo, ui, vi, ua, va, ssh_x, ssh_y, sst, cn, hi, sss ! properties of iceberg environment
REAL(wp) :: mass_of_bits, heat_density
END TYPE point
@@ -86,5 +86,5 @@
! particularly for MPP when iceberg can lie inside T grid but outside U, V, or f grid
REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: uo_e, vo_e
- REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: ff_e, tt_e, fr_e
+ REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: ff_e, tt_e, fr_e, ss_e
REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: ua_e, va_e
REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: ssh_e
@@ -147,7 +147,4 @@
INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nicbfldexpect !: nfold expected number of bergs
INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nicbfldreq !: nfold message handle (immediate send)
-
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: griddata !: work array for icbrst
-
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -183,4 +180,5 @@
& ff_e(0:jpi+1,0:jpj+1) , fr_e(0:jpi+1,0:jpj+1) , &
& tt_e(0:jpi+1,0:jpj+1) , ssh_e(0:jpi+1,0:jpj+1) , &
+ & ss_e(0:jpi+1,0:jpj+1) , &
& first_width(nclasses) , first_length(nclasses) , &
& src_calving (jpi,jpj) , &
@@ -194,7 +192,4 @@
ALLOCATE( nicbfldpts(jpi) , nicbflddest(jpi) , nicbfldproc(jpni) , &
& nicbfldnsend(jpni), nicbfldexpect(jpni) , nicbfldreq(jpni), STAT=ill)
- icb_alloc = icb_alloc + ill
-
- ALLOCATE( griddata(jpi,jpj,1), STAT=ill )
icb_alloc = icb_alloc + ill
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/ICB/icbclv.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/ICB/icbclv.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/ICB/icbclv.F90 (revision 13540)
@@ -71,5 +71,5 @@
! where (berg_grid%calving==0.) berg_grid%stored_ice(:,:,jn)=0.
!end do
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
IF( berg_grid%calving(ji,jj) /= 0._wp ) & ! Need units of J
berg_grid%stored_heat(ji,jj) = SUM( berg_grid%stored_ice(ji,jj,:) ) * & ! initial stored ice in kg
@@ -81,5 +81,5 @@
! assume that all calving flux must be distributed even if distribution array does not sum
! to one - this may not be what is intended, but it's what you've got
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
imx = berg_grid%maxclass(ji,jj)
zdist = SUM( rn_distribution(1:nclasses) ) / SUM( rn_distribution(1:imx) )
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/ICB/icbdyn.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/ICB/icbdyn.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/ICB/icbdyn.F90 (revision 13540)
@@ -258,5 +258,5 @@
!
INTEGER :: itloop
- REAL(wp) :: zuo, zui, zua, zuwave, zssh_x, zsst, zcn, zhi
+ REAL(wp) :: zuo, zui, zua, zuwave, zssh_x, zsst, zcn, zhi, zsss
REAL(wp) :: zvo, zvi, zva, zvwave, zssh_y
REAL(wp) :: zff, zT, zD, zW, zL, zM, zF
@@ -271,5 +271,5 @@
nknberg = berg%number(1)
CALL icb_utl_interp( pxi, pe1, zuo, zui, zua, zssh_x, &
- & pyj, pe2, zvo, zvi, zva, zssh_y, zsst, zcn, zhi, zff )
+ & pyj, pe2, zvo, zvi, zva, zssh_y, zsst, zcn, zhi, zff, zsss )
zM = berg%current_point%mass
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/ICB/icbini.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/ICB/icbini.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/ICB/icbini.F90 (revision 13540)
@@ -81,5 +81,5 @@
ua_e(:,:) = 0._wp ; va_e(:,:) = 0._wp ;
ff_e(:,:) = 0._wp ; tt_e(:,:) = 0._wp ;
- fr_e(:,:) = 0._wp ;
+ fr_e(:,:) = 0._wp ; ss_e(:,:) = 0._wp ;
#if defined key_si3
hi_e(:,:) = 0._wp ;
@@ -123,5 +123,5 @@
nicbfldproc(:) = -1
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
src_calving_hflx(ji,jj) = narea
src_calving (ji,jj) = nicbpack * mjg(jj) + mig(ji)
@@ -133,5 +133,5 @@
! first entry with narea for this processor is left hand interior index
! last entry is right hand interior index
- jj = nlcj/2
+ jj = jpj/2
nicbdi = -1
nicbei = -1
@@ -149,5 +149,5 @@
!
! repeat for j direction
- ji = nlci/2
+ ji = jpi/2
nicbdj = -1
nicbej = -1
@@ -166,9 +166,9 @@
! special for east-west boundary exchange we save the destination index
i1 = MAX( nicbdi-1, 1)
- i3 = INT( src_calving(i1,nlcj/2) )
+ i3 = INT( src_calving(i1,jpj/2) )
jj = INT( i3/nicbpack )
ricb_left = REAL( i3 - nicbpack*jj, wp )
i1 = MIN( nicbei+1, jpi )
- i3 = INT( src_calving(i1,nlcj/2) )
+ i3 = INT( src_calving(i1,jpj/2) )
jj = INT( i3/nicbpack )
ricb_right = REAL( i3 - nicbpack*jj, wp )
@@ -203,11 +203,11 @@
WRITE(numicb,*) 'processor ', narea
WRITE(numicb,*) 'jpi, jpj ', jpi, jpj
- WRITE(numicb,*) 'nldi, nlei ', nldi, nlei
- WRITE(numicb,*) 'nldj, nlej ', nldj, nlej
+ WRITE(numicb,*) 'Nis0, Nie0 ', Nis0, Nie0
+ WRITE(numicb,*) 'Njs0, Nje0 ', Njs0, Nje0
WRITE(numicb,*) 'berg i interior ', nicbdi, nicbei
WRITE(numicb,*) 'berg j interior ', nicbdj, nicbej
WRITE(numicb,*) 'berg left ', ricb_left
WRITE(numicb,*) 'berg right ', ricb_right
- jj = nlcj/2
+ jj = jpj/2
WRITE(numicb,*) "central j line:"
WRITE(numicb,*) "i processor"
@@ -215,5 +215,5 @@
WRITE(numicb,*) "i point"
WRITE(numicb,*) (INT(src_calving(ji,jj)), ji=1,jpi)
- ji = nlci/2
+ ji = jpi/2
WRITE(numicb,*) "central i line:"
WRITE(numicb,*) "j processor"
@@ -256,5 +256,5 @@
ivar = iom_varid( inum, 'maxclass', ldstop=.FALSE. )
IF( ivar > 0 ) THEN
- CALL iom_get ( inum, jpdom_data, 'maxclass', src_calving ) ! read the max distribution array
+ CALL iom_get ( inum, jpdom_global, 'maxclass', src_calving ) ! read the max distribution array
berg_grid%maxclass(:,:) = INT( src_calving )
src_calving(:,:) = 0._wp
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/ICB/icblbc.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/ICB/icblbc.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/ICB/icblbc.F90 (revision 13540)
@@ -81,5 +81,4 @@
TYPE(iceberg), POINTER :: this
TYPE(point) , POINTER :: pt
- INTEGER :: iine
!!----------------------------------------------------------------------
@@ -92,8 +91,7 @@
DO WHILE( ASSOCIATED(this) )
pt => this%current_point
- iine = INT( pt%xi + 0.5 )
- IF( iine > mig(nicbei) ) THEN
+ IF( pt%xi > REAL(mig(nicbei),wp) + 0.5_wp ) THEN
pt%xi = ricb_right + MOD(pt%xi, 1._wp ) - 1._wp
- ELSE IF( iine < mig(nicbdi) ) THEN
+ ELSE IF( pt%xi < REAL(mig(nicbdi),wp) - 0.5_wp ) THEN
pt%xi = ricb_left + MOD(pt%xi, 1._wp )
ENDIF
@@ -128,5 +126,5 @@
pt => this%current_point
ijne = INT( pt%yj + 0.5 )
- IF( ijne .GT. mjg(nicbej) ) THEN
+ IF( pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp ) THEN
!
iine = INT( pt%xi + 0.5 )
@@ -170,5 +168,4 @@
INTEGER :: ibergs_rcvd_from_n, ibergs_rcvd_from_s
INTEGER :: i, ibergs_start, ibergs_end
- INTEGER :: iine, ijne
INTEGER :: ipe_N, ipe_S, ipe_W, ipe_E
REAL(wp), DIMENSION(2) :: zewbergs, zwebergs, znsbergs, zsnbergs
@@ -234,6 +231,5 @@
DO WHILE (ASSOCIATED(this))
pt => this%current_point
- iine = INT( pt%xi + 0.5 )
- IF( ipe_E >= 0 .AND. iine > mig(nicbei) ) THEN
+ IF( ipe_E >= 0 .AND. pt%xi > REAL(mig(nicbei),wp) + 0.5_wp ) THEN
tmpberg => this
this => this%next
@@ -248,5 +244,5 @@
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. iine < mig(nicbdi) ) THEN
+ ELSE IF( ipe_W >= 0 .AND. pt%xi < REAL(mig(nicbdi),wp) - 0.5_wp ) THEN
tmpberg => this
this => this%next
@@ -372,6 +368,5 @@
DO WHILE (ASSOCIATED(this))
pt => this%current_point
- ijne = INT( pt%yj + 0.5 )
- IF( ipe_N >= 0 .AND. ijne .GT. mjg(nicbej) ) THEN
+ IF( ipe_N >= 0 .AND. pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp ) THEN
tmpberg => this
this => this%next
@@ -383,5 +378,5 @@
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. ijne .LT. mjg(nicbdj) ) THEN
+ ELSE IF( ipe_S >= 0 .AND. pt%yj < REAL(mjg(nicbdj),wp) - 0.5_wp ) THEN
tmpberg => this
this => this%next
@@ -539,12 +534,10 @@
DO WHILE (ASSOCIATED(this))
pt => this%current_point
- iine = INT( pt%xi + 0.5 )
- ijne = INT( pt%yj + 0.5 )
- IF( iine .LT. mig(nicbdi) .OR. &
- iine .GT. mig(nicbei) .OR. &
- ijne .LT. mjg(nicbdj) .OR. &
- ijne .GT. mjg(nicbej)) THEN
+ IF( pt%xi < REAL(mig(nicbdi),wp) - 0.5_wp .OR. &
+ pt%xi > REAL(mig(nicbei),wp) + 0.5_wp .OR. &
+ pt%yj < REAL(mjg(nicbdj),wp) - 0.5_wp .OR. &
+ pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp ) THEN
i = i + 1
- WRITE(numicb,*) 'berg lost in halo: ', this%number(:),iine,ijne
+ WRITE(numicb,*) 'berg lost in halo: ', this%number(:)
WRITE(numicb,*) ' ', nimpp, njmpp
WRITE(numicb,*) ' ', nicbdi, nicbei, nicbdj, nicbej
@@ -614,7 +607,6 @@
pt => this%current_point
iine = INT( pt%xi + 0.5 )
- ijne = INT( pt%yj + 0.5 )
iproc = nicbflddest(mi1(iine))
- IF( ijne .GT. mjg(nicbej) ) THEN
+ IF( pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp ) THEN
IF( iproc == ifldproc ) THEN
!
@@ -696,5 +688,5 @@
ipts = nicbfldpts (mi1(iine))
iproc = nicbflddest(mi1(iine))
- IF( ijne .GT. mjg(nicbej) ) THEN
+ IF( pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp ) THEN
IF( iproc == ifldproc ) THEN
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/ICB/icbrst.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/ICB/icbrst.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/ICB/icbrst.F90 (revision 13540)
@@ -91,8 +91,8 @@
ij = INT( localpt%yj + 0.5 )
! Only proceed if this iceberg is on the local processor (excluding halos).
- IF ( ii .GE. nldi+nimpp-1 .AND. ii .LE. nlei+nimpp-1 .AND. &
- & ij .GE. nldj+njmpp-1 .AND. ij .LE. nlej+njmpp-1 ) THEN
-
- CALL iom_get( ncid, jpdom_unknown, 'number' , zdata(:) , ktime=jn, kstart=(/1/), kcount=(/nkounts/) )
+ IF ( ii >= mig(Nis0) .AND. ii <= mig(Nie0) .AND. &
+ & ij >= mjg(Njs0) .AND. ij <= mjg(Nje0) ) THEN
+
+ CALL iom_get( ncid, jpdom_unknown, 'number', zdata(:) , ktime=jn, kstart=(/1/), kcount=(/nkounts/) )
localberg%number(:) = INT(zdata(:))
imax_icb = MAX( imax_icb, INT(zdata(1)) )
@@ -123,8 +123,9 @@
! Gridded variables
- CALL iom_get( ncid, jpdom_autoglo, 'calving' , src_calving )
- CALL iom_get( ncid, jpdom_autoglo, 'calving_hflx', src_calving_hflx )
- CALL iom_get( ncid, jpdom_autoglo, 'stored_heat' , berg_grid%stored_heat )
- CALL iom_get( ncid, jpdom_autoglo_xy, 'stored_ice' , berg_grid%stored_ice, kstart=(/1,1,1/), kcount=(/1,1,nclasses/) )
+ CALL iom_get( ncid, jpdom_auto, 'calving' , src_calving )
+ CALL iom_get( ncid, jpdom_auto, 'calving_hflx', src_calving_hflx )
+ CALL iom_get( ncid, jpdom_auto, 'stored_heat' , berg_grid%stored_heat )
+ ! with jpdom_auto_xy, ue use only the third element of kstart and kcount.
+ CALL iom_get( ncid, jpdom_auto_xy, 'stored_ice' , berg_grid%stored_ice, kstart=(/-99,-99,1/), kcount=(/-99,-99,nclasses/) )
CALL iom_get( ncid, jpdom_unknown, 'kount' , zdata(:) )
@@ -188,8 +189,10 @@
!
INTEGER :: jn ! dummy loop index
+ INTEGER :: idg ! number of digits
INTEGER :: ix_dim, iy_dim, ik_dim, in_dim
CHARACTER(len=256) :: cl_path
CHARACTER(len=256) :: cl_filename
- CHARACTER(len=256) :: cl_kt
+ CHARACTER(len=8 ) :: cl_kt
+ CHARACTER(LEN=12 ) :: clfmt ! writing format
TYPE(iceberg), POINTER :: this
TYPE(point) , POINTER :: pt
@@ -211,9 +214,11 @@
! file name
WRITE(cl_kt, '(i8.8)') kt
- cl_filename = TRIM(cexper)//"_"//TRIM(ADJUSTL(cl_kt))//"_"//TRIM(cn_icbrst_out)
+ cl_filename = TRIM(cexper)//"_"//cl_kt//"_"//TRIM(cn_icbrst_out)
IF( lk_mpp ) THEN
- WRITE(cl_filename,'(A,"_",I4.4,".nc")') TRIM(cl_filename), narea-1
+ idg = MAX( INT(LOG10(REAL(MAX(1,jpnij-1),wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9
+ WRITE(clfmt, "('(a,a,i', i1, '.', i1, ',a)')") idg, idg ! '(a,a,ix.x,a)'
+ WRITE(cl_filename, clfmt) TRIM(cl_filename), '_', narea-1, '.nc'
ELSE
- WRITE(cl_filename,'(A,".nc")') TRIM(cl_filename)
+ WRITE(cl_filename,'(a,a)') TRIM(cl_filename), '.nc'
ENDIF
@@ -225,8 +230,8 @@
! Dimensions
- nret = NF90_DEF_DIM(ncid, 'x', jpi, ix_dim)
+ nret = NF90_DEF_DIM(ncid, 'x', Ni_0, ix_dim)
IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_def_dim x failed')
- nret = NF90_DEF_DIM(ncid, 'y', jpj, iy_dim)
+ nret = NF90_DEF_DIM(ncid, 'y', Nj_0, iy_dim)
IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_def_dim y failed')
@@ -240,14 +245,14 @@
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' , (/jpiglo, jpjglo/) )
- nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_size_local' , (/jpi , jpj /) )
- nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_position_first' , (/nimpp , njmpp /) )
- nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_position_last' , (/nimpp + jpi - 1 , njmpp + jpj - 1 /) )
- nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_halo_size_start', (/nldi - 1 , nldj - 1 /) )
- nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_halo_size_end' , (/jpi - nlei , jpj - nlej /) )
- 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' , (/ 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' )
ENDIF
@@ -340,12 +345,11 @@
nstrt3(1) = 1
nstrt3(2) = 1
- nlngth3(1) = jpi
- nlngth3(2) = jpj
+ nlngth3(1) = Ni_0
+ nlngth3(2) = Nj_0
nlngth3(3) = 1
DO jn=1,nclasses
- griddata(:,:,1) = berg_grid%stored_ice(:,:,jn)
nstrt3(3) = jn
- nret = NF90_PUT_VAR( ncid, nsiceid, griddata, nstrt3, nlngth3 )
+ nret = NF90_PUT_VAR( ncid, nsiceid, berg_grid%stored_ice(Nis0:Nie0,Njs0:Nje0,jn), nstrt3, nlngth3 )
IF (nret .ne. NF90_NOERR) THEN
IF( lwp ) WRITE(numout,*) TRIM(NF90_STRERROR( nret ))
@@ -358,11 +362,11 @@
IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_put_var kount failed')
- nret = NF90_PUT_VAR( ncid, nsheatid, berg_grid%stored_heat(:,:) )
+ nret = NF90_PUT_VAR( ncid, nsheatid, berg_grid%stored_heat(Nis0:Nie0,Njs0:Nje0) )
IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_put_var stored_heat failed')
IF( lwp ) WRITE(numout,*) 'file: ',TRIM(cl_path)//TRIM(cl_filename),' var: stored_heat written'
- nret = NF90_PUT_VAR( ncid, ncalvid , src_calving(:,:) )
+ nret = NF90_PUT_VAR( ncid, ncalvid , src_calving(Nis0:Nie0,Njs0:Nje0) )
IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_put_var calving failed')
- nret = NF90_PUT_VAR( ncid, ncalvhid, src_calving_hflx(:,:) )
+ nret = NF90_PUT_VAR( ncid, ncalvhid, src_calving_hflx(Nis0:Nie0,Njs0:Nje0) )
IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_put_var calving_hflx failed')
IF( lwp ) WRITE(numout,*) 'file: ',TRIM(cl_path)//TRIM(cl_filename),' var: calving written'
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/ICB/icbthm.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/ICB/icbthm.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/ICB/icbthm.F90 (revision 13540)
@@ -20,4 +20,5 @@
USE phycst ! NEMO physical constants
USE sbc_oce
+ USE eosbn2 ! equation of state
USE lib_fortran, ONLY : DDPDD
@@ -50,4 +51,5 @@
INTEGER :: ii, ij
REAL(wp) :: zM, zT, zW, zL, zSST, zVol, zLn, zWn, zTn, znVol, zIC, zDn
+ REAL(wp) :: zSSS, zfzpt
REAL(wp) :: zMv, zMe, zMb, zmelt, zdvo, zdva, zdM, zSs, zdMe, zdMb, zdMv
REAL(wp) :: zMnew, zMnew1, zMnew2, zheat_hcflux, zheat_latent, z1_12
@@ -57,10 +59,10 @@
TYPE(point) , POINTER :: pt
!
- COMPLEX(wp), DIMENSION(jpi,jpj) :: cicb_melt, cicb_hflx
+ COMPLEX(dp), DIMENSION(jpi,jpj) :: cicb_melt, cicb_hflx
!!----------------------------------------------------------------------
!
!! initialiaze cicb_melt and cicb_heat
- cicb_melt = CMPLX( 0.e0, 0.e0, wp )
- cicb_hflx = CMPLX( 0.e0, 0.e0, wp )
+ cicb_melt = CMPLX( 0.e0, 0.e0, dp )
+ cicb_hflx = CMPLX( 0.e0, 0.e0, dp )
!
z1_rday = 1._wp / rday
@@ -85,7 +87,9 @@
CALL icb_utl_interp( pt%xi, pt%e1, pt%uo, pt%ui, pt%ua, pt%ssh_x, &
& pt%yj, pt%e2, pt%vo, pt%vi, pt%va, pt%ssh_y, &
- & pt%sst, pt%cn, pt%hi, zff )
+ & pt%sst, pt%cn, pt%hi, zff, pt%sss )
!
zSST = pt%sst
+ zSSS = pt%sss
+ CALL eos_fzp(zSSS,zfzpt) ! freezing point
zIC = MIN( 1._wp, pt%cn + rn_sicn_shift ) ! Shift sea-ice concentration !!gm ???
zM = pt%mass
@@ -109,7 +113,11 @@
! Melt rates in m/s (i.e. division by rday)
- zMv = MAX( 7.62d-3*zSST+1.29d-3*(zSST**2) , 0._wp ) * z1_rday ! Buoyant convection at sides (eqn M.A10)
- zMb = MAX( 0.58_wp*(zdvo**0.8_wp)*(zSST+4.0_wp)/(zL**0.2_wp) , 0._wp ) * z1_rday ! Basal turbulent melting (eqn M.A7 )
- zMe = MAX( z1_12*(zSST+2.)*zSs*(1._wp+COS(rpi*(zIC**3))) , 0._wp ) * z1_rday ! Wave erosion (eqn M.A8 )
+ zMv = MAX( 7.62d-3*zSST+1.29d-3*(zSST**2) , 0._wp ) * z1_rday ! Buoyant convection at sides (eqn M.A10)
+ IF ( zSST > zfzpt ) THEN ! Calculate basal melting only if SST above freezing point
+ zMb = MAX( 0.58_wp*(zdvo**0.8_wp)*(zSST+4.0_wp)/(zL**0.2_wp) , 0._wp ) * z1_rday ! Basal turbulent melting (eqn M.A7 )
+ ELSE
+ zMb = 0._wp ! No basal melting if SST below freezing point
+ ENDIF
+ zMe = MAX( z1_12*(zSST+2.)*zSs*(1._wp+COS(rpi*(zIC**3))) , 0._wp ) * z1_rday ! Wave erosion (eqn M.A8 )
IF( ln_operator_splitting ) THEN ! Operator split update of volume/mass
@@ -176,5 +184,5 @@
!! the use of DDPDD function for the cumulative sum is needed for reproducibility
zmelt = ( zdM - ( zdMbitsE - zdMbitsM ) ) * z1_dt ! kg/s
- CALL DDPDD( CMPLX( zmelt * z1_e1e2, 0.e0, wp ), cicb_melt(ii,ij) )
+ CALL DDPDD( CMPLX( zmelt * z1_e1e2, 0.e0, dp ), cicb_melt(ii,ij) )
!
! iceberg heat flux
@@ -185,5 +193,5 @@
zheat_hcflux = zmelt * pt%heat_density ! heat content flux : kg/s x J/kg = J/s
zheat_latent = - zmelt * rLfus ! latent heat flux: kg/s x J/kg = J/s
- CALL DDPDD( CMPLX( ( zheat_hcflux + zheat_latent ) * z1_e1e2, 0.e0, wp ), cicb_hflx(ii,ij) )
+ CALL DDPDD( CMPLX( ( zheat_hcflux + zheat_latent ) * z1_e1e2, 0.e0, dp ), cicb_hflx(ii,ij) )
!
! diagnostics
@@ -230,6 +238,6 @@
END DO
!
- berg_grid%floating_melt = REAL(cicb_melt,wp) ! kg/m2/s
- berg_grid%calving_hflx = REAL(cicb_hflx,wp)
+ berg_grid%floating_melt = REAL(cicb_melt,dp) ! kg/m2/s
+ berg_grid%calving_hflx = REAL(cicb_hflx,dp)
!
! now use melt and associated heat flux in ocean (or not)
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/ICB/icbtrj.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/ICB/icbtrj.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/ICB/icbtrj.F90 (revision 13540)
@@ -62,7 +62,9 @@
!
INTEGER :: iret, iyear, imonth, iday
+ INTEGER :: idg ! number of digits
REAL(wp) :: zfjulday, zsec
CHARACTER(len=80) :: cl_filename
- CHARACTER(LEN=20) :: cldate_ini, cldate_end
+ CHARACTER(LEN=12) :: clfmt ! writing format
+ CHARACTER(LEN=8 ) :: cldate_ini, cldate_end
TYPE(iceberg), POINTER :: this
TYPE(point) , POINTER :: pt
@@ -80,8 +82,11 @@
! define trajectory output name
- IF ( lk_mpp ) THEN ; WRITE(cl_filename,'("trajectory_icebergs_",A,"-",A,"_",I4.4,".nc")') &
- & TRIM(ADJUSTL(cldate_ini)), TRIM(ADJUSTL(cldate_end)), narea-1
- ELSE ; WRITE(cl_filename,'("trajectory_icebergs_",A,"-",A ,".nc")') &
- & TRIM(ADJUSTL(cldate_ini)), TRIM(ADJUSTL(cldate_end))
+ cl_filename = 'trajectory_icebergs_'//cldate_ini//'-'//cldate_end
+ IF ( lk_mpp ) THEN
+ idg = MAX( INT(LOG10(REAL(MAX(1,jpnij-1),wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9
+ WRITE(clfmt, "('(a,a,i', i1, '.', i1, ',a)')") idg, idg ! '(a,a,ix.x,a)'
+ WRITE(cl_filename, clfmt) TRIM(cl_filename), '_', narea-1, '.nc'
+ ELSE
+ WRITE(cl_filename,'(a,a)') TRIM(cl_filename), '.nc'
ENDIF
IF( lwp .AND. nn_verbose_level >= 0 ) WRITE(numout,'(2a)') 'icebergs, icb_trj_init: creating ',TRIM(cl_filename)
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/ICB/icbutl.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/ICB/icbutl.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/ICB/icbutl.F90 (revision 13540)
@@ -74,4 +74,5 @@
ff_e(1:jpi,1:jpj) = ff_f (:,:)
tt_e(1:jpi,1:jpj) = sst_m(:,:)
+ ss_e(1:jpi,1:jpj) = sss_m(:,:)
fr_e(1:jpi,1:jpj) = fr_i (:,:)
ua_e(1:jpi,1:jpj) = utau (:,:) * umask(:,:,1) ! maybe mask useless because mask applied in sbcblk
@@ -85,4 +86,5 @@
CALL lbc_lnk_icb( 'icbutl', fr_e, 'T', +1._wp, 1, 1 )
CALL lbc_lnk_icb( 'icbutl', tt_e, 'T', +1._wp, 1, 1 )
+ CALL lbc_lnk_icb( 'icbutl', ss_e, 'T', +1._wp, 1, 1 )
#if defined key_si3
hi_e(1:jpi, 1:jpj) = hm_i (:,:)
@@ -107,5 +109,5 @@
SUBROUTINE icb_utl_interp( pi, pe1, puo, pui, pua, pssh_i, &
& pj, pe2, pvo, pvi, pva, pssh_j, &
- & psst, pcn, phi, pff )
+ & psst, pcn, phi, pff, psss )
!!----------------------------------------------------------------------
!! *** ROUTINE icb_utl_interp ***
@@ -128,5 +130,5 @@
REAL(wp), INTENT( out) :: puo, pvo, pui, pvi, pua, pva ! ocean, ice and wind speeds
REAL(wp), INTENT( out) :: pssh_i, pssh_j ! ssh i- & j-gradients
- REAL(wp), INTENT( out) :: psst, pcn, phi, pff ! SST, ice concentration, ice thickness, Coriolis
+ REAL(wp), INTENT( out) :: psst, pcn, phi, pff, psss ! SST, ice concentration, ice thickness, Coriolis, SSS
!
REAL(wp) :: zcd, zmod ! local scalars
@@ -139,4 +141,5 @@
pvo = icb_utl_bilin_h( vo_e, pi, pj, 'V', .false. )
psst = icb_utl_bilin_h( tt_e, pi, pj, 'T', .true. ) ! SST
+ psss = icb_utl_bilin_h( ss_e, pi, pj, 'T', .true. ) ! SSS
pcn = icb_utl_bilin_h( fr_e, pi, pj, 'T', .true. ) ! ice concentration
pff = icb_utl_bilin_h( ff_e, pi, pj, 'F', .false. ) ! Coriolis parameter
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/IOM/in_out_manager.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/IOM/in_out_manager.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/IOM/in_out_manager.F90 (revision 13540)
@@ -100,14 +100,4 @@
!!----------------------------------------------------------------------
TYPE :: sn_ctl !: structure for control over output selection
- LOGICAL :: l_glochk = .FALSE. !: range sanity checks are local (F) or global (T)
- ! Use global setting for debugging only;
- ! local breaches will still be reported
- ! and stop the code in most cases.
- LOGICAL :: l_allon = .FALSE. !: overall control; activate all following output options
- LOGICAL :: l_config = .FALSE. !: activate/deactivate finer control
- ! Note if l_config is True then sn_cfctl%l_allon is ignored.
- ! Otherwise setting sn_cfctl%l_allon T/F is equivalent to
- ! setting all the following logicals in this structure T/F
- ! and disabling subsetting of processors
LOGICAL :: l_runstat = .FALSE. !: Produce/do not produce run.stat file (T/F)
LOGICAL :: l_trcstat = .FALSE. !: Produce/do not produce tracer.stat file (T/F)
@@ -128,5 +118,4 @@
LOGICAL :: ln_timing !: run control for timing
LOGICAL :: ln_diacfl !: flag whether to create CFL diagnostics
- INTEGER :: nn_print !: level of print (0 no print)
INTEGER :: nn_ictls !: Start i indice for the SUM control
INTEGER :: nn_ictle !: End i indice for the SUM control
@@ -135,8 +124,4 @@
INTEGER :: nn_isplt !: number of processors following i
INTEGER :: nn_jsplt !: number of processors following j
- !
- INTEGER :: nprint, nictls, nictle, njctls, njctle, isplt, jsplt !: OLD namelist names
-
- INTEGER :: ijsplt = 1 !: nb of local domain = nb of processors
!!----------------------------------------------------------------------
@@ -169,4 +154,7 @@
INTEGER :: no_print = 0 !: optional argument of fld_fill (if present, suppress some control print)
INTEGER :: nstop = 0 !: error flag (=number of reason for a premature stop run)
+!$AGRIF_DO_NOT_TREAT
+ INTEGER :: ngrdstop = -1 !: grid number having nstop > 1
+!$AGRIF_END_DO_NOT_TREAT
INTEGER :: nwarn = 0 !: warning flag (=number of warning found during the run)
CHARACTER(lc) :: ctmp1, ctmp2, ctmp3 !: temporary characters 1 to 3
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/IOM/iom.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/IOM/iom.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/IOM/iom.F90 (revision 13540)
@@ -21,4 +21,5 @@
!!----------------------------------------------------------------------
USE dom_oce ! ocean space and time domain
+ USE domutl !
USE c1d ! 1D vertical configuration
USE flo_oce ! floats module declarations
@@ -34,5 +35,4 @@
USE ice , ONLY : jpl
#endif
- USE domngb ! ocean space and time domain
USE phycst ! physical constants
USE dianam ! build name of file
@@ -59,7 +59,11 @@
PUBLIC iom_use, iom_context_finalize, iom_update_file_name, iom_miss_val
- PRIVATE iom_rp0d, iom_rp1d, iom_rp2d, iom_rp3d
- PRIVATE iom_g0d, iom_g1d, iom_g2d, iom_g3d, iom_get_123d
- PRIVATE iom_p1d, iom_p2d, iom_p3d, iom_p4d
+ PRIVATE iom_rp0d_sp, iom_rp1d_sp, iom_rp2d_sp, iom_rp3d_sp
+ PRIVATE iom_rp0d_dp, iom_rp1d_dp, iom_rp2d_dp, iom_rp3d_dp
+ PRIVATE iom_get_123d
+ PRIVATE iom_g0d_sp, iom_g1d_sp, iom_g2d_sp, iom_g3d_sp
+ PRIVATE iom_g0d_dp, iom_g1d_dp, iom_g2d_dp, iom_g3d_dp
+ PRIVATE iom_p1d_sp, iom_p2d_sp, iom_p3d_sp, iom_p4d_sp
+ PRIVATE iom_p1d_dp, iom_p2d_dp, iom_p3d_dp, iom_p4d_dp
#if defined key_iomput
PRIVATE iom_set_domain_attr, iom_set_axis_attr, iom_set_field_attr, iom_set_file_attr, iom_get_file_attr, iom_set_grid_attr
@@ -70,5 +74,6 @@
INTERFACE iom_get
- MODULE PROCEDURE iom_g0d, iom_g1d, iom_g2d, iom_g3d
+ MODULE PROCEDURE iom_g0d_sp, iom_g1d_sp, iom_g2d_sp, iom_g3d_sp
+ MODULE PROCEDURE iom_g0d_dp, iom_g1d_dp, iom_g2d_dp, iom_g3d_dp
END INTERFACE
INTERFACE iom_getatt
@@ -79,8 +84,10 @@
END INTERFACE
INTERFACE iom_rstput
- MODULE PROCEDURE iom_rp0d, iom_rp1d, iom_rp2d, iom_rp3d
+ MODULE PROCEDURE iom_rp0d_sp, iom_rp1d_sp, iom_rp2d_sp, iom_rp3d_sp
+ MODULE PROCEDURE iom_rp0d_dp, iom_rp1d_dp, iom_rp2d_dp, iom_rp3d_dp
END INTERFACE
INTERFACE iom_put
- MODULE PROCEDURE iom_p0d, iom_p1d, iom_p2d, iom_p3d, iom_p4d
+ MODULE PROCEDURE iom_p0d_sp, iom_p1d_sp, iom_p2d_sp, iom_p3d_sp, iom_p4d_sp
+ MODULE PROCEDURE iom_p0d_dp, iom_p1d_dp, iom_p2d_dp, iom_p3d_dp, iom_p4d_dp
END INTERFACE iom_put
@@ -94,5 +101,5 @@
CONTAINS
- SUBROUTINE iom_init( cdname, fname, ld_tmppatch, ld_closedef )
+ SUBROUTINE iom_init( cdname, fname, ld_closedef )
!!----------------------------------------------------------------------
!! *** ROUTINE ***
@@ -103,5 +110,4 @@
CHARACTER(len=*), INTENT(in) :: cdname
CHARACTER(len=*), OPTIONAL, INTENT(in) :: fname
- LOGICAL , OPTIONAL, INTENT(in) :: ld_tmppatch
LOGICAL , OPTIONAL, INTENT(in) :: ld_closedef
#if defined key_iomput
@@ -111,27 +117,12 @@
CHARACTER(len=lc) :: clname
INTEGER :: irefyear, irefmonth, irefday
- INTEGER :: ji, jkmin
+ INTEGER :: ji
LOGICAL :: llrst_context ! is context related to restart
!
REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zt_bnds, zw_bnds
REAL(wp), DIMENSION(2,jpkam1) :: za_bnds ! ABL vertical boundaries
- LOGICAL :: ll_tmppatch = .TRUE. !: seb: patch before we remove periodicity
- INTEGER :: nldi_save, nlei_save !: and close boundaries in output files
- INTEGER :: nldj_save, nlej_save !:
LOGICAL :: ll_closedef
!!----------------------------------------------------------------------
!
- ! seb: patch before we remove periodicity and close boundaries in output files
- IF( PRESENT(ld_tmppatch) ) THEN ; ll_tmppatch = ld_tmppatch
- ELSE ; ll_tmppatch = .TRUE.
- ENDIF
- IF ( ll_tmppatch ) THEN
- nldi_save = nldi ; nlei_save = nlei
- nldj_save = nldj ; nlej_save = nlej
- IF( nimpp == 1 ) nldi = 1
- IF( nimpp + jpi - 1 == jpiglo ) nlei = jpi
- IF( njmpp == 1 ) nldj = 1
- IF( njmpp + jpj - 1 == jpjglo ) nlej = jpj
- ENDIF
!
ll_closedef = .TRUE.
@@ -152,10 +143,10 @@
SELECT CASE ( nleapy ) ! Choose calendar for IOIPSL
- CASE ( 1) ; CALL xios_define_calendar( TYPE = "Gregorian", time_origin = xios_date(irefyear,irefmonth,irefday,00,00,00), &
- & start_date = xios_date(nyear,nmonth,nday,0,0,0) )
- CASE ( 0) ; CALL xios_define_calendar( TYPE = "NoLeap" , time_origin = xios_date(irefyear,irefmonth,irefday,00,00,00), &
- & start_date = xios_date(nyear,nmonth,nday,0,0,0) )
- CASE (30) ; CALL xios_define_calendar( TYPE = "D360" , time_origin = xios_date(irefyear,irefmonth,irefday,00,00,00), &
- & start_date = xios_date(nyear,nmonth,nday,0,0,0) )
+ CASE ( 1) ; CALL xios_define_calendar( TYPE = "Gregorian", time_origin = xios_date(irefyear,irefmonth,irefday,0,0,0), &
+ & start_date = xios_date( nyear, nmonth, nday,0,0,0) )
+ CASE ( 0) ; CALL xios_define_calendar( TYPE = "NoLeap" , time_origin = xios_date(irefyear,irefmonth,irefday,0,0,0), &
+ & start_date = xios_date( nyear, nmonth, nday,0,0,0) )
+ CASE (30) ; CALL xios_define_calendar( TYPE = "D360" , time_origin = xios_date(irefyear,irefmonth,irefday,0,0,0), &
+ & start_date = xios_date( nyear, nmonth, nday,0,0,0) )
END SELECT
@@ -171,8 +162,8 @@
!
IF( ln_cfmeta ) THEN ! Add additional grid metadata
- CALL iom_set_domain_attr("grid_T", area = e1e2t(nldi:nlei, nldj:nlej))
- CALL iom_set_domain_attr("grid_U", area = e1e2u(nldi:nlei, nldj:nlej))
- CALL iom_set_domain_attr("grid_V", area = e1e2v(nldi:nlei, nldj:nlej))
- CALL iom_set_domain_attr("grid_W", area = e1e2t(nldi:nlei, nldj:nlej))
+ CALL iom_set_domain_attr("grid_T", area = real( e1e2t(Nis0:Nie0, Njs0:Nje0), dp))
+ CALL iom_set_domain_attr("grid_U", area = real( e1e2u(Nis0:Nie0, Njs0:Nje0), dp))
+ CALL iom_set_domain_attr("grid_V", area = real( e1e2v(Nis0:Nie0, Njs0:Nje0), dp))
+ CALL iom_set_domain_attr("grid_W", area = real( e1e2t(Nis0:Nie0, Njs0:Nje0), dp))
CALL set_grid_bounds( "T", glamf, gphif, glamt, gphit )
CALL set_grid_bounds( "U", glamv, gphiv, glamu, gphiu )
@@ -194,8 +185,8 @@
!
IF( ln_cfmeta .AND. .NOT. llrst_context) THEN ! Add additional grid metadata
- CALL iom_set_domain_attr("grid_T", area = e1e2t_crs(nldi:nlei, nldj:nlej))
- CALL iom_set_domain_attr("grid_U", area = e1u_crs(nldi:nlei, nldj:nlej) * e2u_crs(nldi:nlei, nldj:nlej))
- CALL iom_set_domain_attr("grid_V", area = e1v_crs(nldi:nlei, nldj:nlej) * e2v_crs(nldi:nlei, nldj:nlej))
- CALL iom_set_domain_attr("grid_W", area = e1e2t_crs(nldi:nlei, nldj:nlej))
+ CALL iom_set_domain_attr("grid_T", area = real(e1e2t_crs(Nis0:Nie0, Njs0:Nje0), dp))
+ CALL iom_set_domain_attr("grid_U", area = real(e1u_crs(Nis0:Nie0, Njs0:Nje0) * e2u_crs(Nis0:Nie0, Njs0:Nje0), dp))
+ CALL iom_set_domain_attr("grid_V", area = real(e1v_crs(Nis0:Nie0, Njs0:Nje0) * e2v_crs(Nis0:Nie0, Njs0:Nje0), dp))
+ CALL iom_set_domain_attr("grid_W", area = real(e1e2t_crs(Nis0:Nie0, Njs0:Nje0), dp))
CALL set_grid_bounds( "T", glamf_crs, gphif_crs, glamt_crs, gphit_crs )
CALL set_grid_bounds( "U", glamv_crs, gphiv_crs, glamu_crs, gphiu_crs )
@@ -222,11 +213,10 @@
! Add vertical grid bounds
- jkmin = MIN(2,jpk) ! in case jpk=1 (i.e. sas2D)
- zt_bnds(2,: ) = gdept_1d(:)
- zt_bnds(1,jkmin:jpk) = gdept_1d(1:jpkm1)
- zt_bnds(1,1 ) = gdept_1d(1) - e3w_1d(1)
- zw_bnds(1,: ) = gdepw_1d(:)
- zw_bnds(2,1:jpkm1 ) = gdepw_1d(jkmin:jpk)
- zw_bnds(2,jpk: ) = gdepw_1d(jpk) + e3t_1d(jpk)
+ zt_bnds(2,: ) = gdept_1d(:)
+ zt_bnds(1,2:jpk ) = gdept_1d(1:jpkm1)
+ zt_bnds(1,1 ) = gdept_1d(1) - e3w_1d(1)
+ zw_bnds(1,: ) = gdepw_1d(:)
+ zw_bnds(2,1:jpkm1) = gdepw_1d(2:jpk)
+ zw_bnds(2,jpk: ) = gdepw_1d(jpk) + e3t_1d(jpk)
CALL iom_set_axis_attr( "deptht", bounds=zw_bnds )
CALL iom_set_axis_attr( "depthu", bounds=zw_bnds )
@@ -284,8 +274,4 @@
DEALLOCATE( zt_bnds, zw_bnds )
!
- IF ( ll_tmppatch ) THEN
- nldi = nldi_save ; nlei = nlei_save
- nldj = nldj_save ; nlej = nlej_save
- ENDIF
#endif
!
@@ -658,5 +644,5 @@
- SUBROUTINE iom_open( cdname, kiomid, ldwrt, kdom, ldstop, ldiof, kdlev )
+ SUBROUTINE iom_open( cdname, kiomid, ldwrt, ldstop, ldiof, kdlev, cdcomp )
!!---------------------------------------------------------------------
!! *** SUBROUTINE iom_open ***
@@ -667,8 +653,8 @@
INTEGER , INTENT( out) :: kiomid ! iom identifier of the opened file
LOGICAL , INTENT(in ), OPTIONAL :: ldwrt ! open in write modeb (default = .FALSE.)
- INTEGER , INTENT(in ), OPTIONAL :: kdom ! Type of domain to be written (default = jpdom_local_noovlap)
LOGICAL , INTENT(in ), OPTIONAL :: ldstop ! stop if open to read a non-existing file (default = .TRUE.)
LOGICAL , INTENT(in ), OPTIONAL :: ldiof ! Interp On the Fly, needed for AGRIF (default = .FALSE.)
INTEGER , INTENT(in ), OPTIONAL :: kdlev ! number of vertical levels
+ CHARACTER(len=3), INTENT(in ), OPTIONAL :: cdcomp ! name of component calling iom_nf90_open
!
CHARACTER(LEN=256) :: clname ! the name of the file based on cdname [[+clcpu]+clcpu]
@@ -679,12 +665,9 @@
LOGICAL :: llok ! check the existence
LOGICAL :: llwrt ! local definition of ldwrt
- LOGICAL :: llnoov ! local definition to read overlap
LOGICAL :: llstop ! local definition of ldstop
LOGICAL :: lliof ! local definition of ldiof
INTEGER :: icnt ! counter for digits in clcpu (max = jpmax_digits)
INTEGER :: iln, ils ! lengths of character
- INTEGER :: idom ! type of domain
INTEGER :: istop !
- INTEGER, DIMENSION(2,5) :: idompar ! domain parameters:
! local number of points for x,y dimensions
! position of first local point for x,y dimensions
@@ -718,7 +701,4 @@
ELSE ; lliof = .FALSE.
ENDIF
- ! do we read the overlap
- ! ugly patch SM+JMM+RB to overwrite global definition in some cases
- llnoov = (jpni * jpnj ) == jpnij .AND. .NOT. lk_agrif
! create the file name by added, if needed, TRIM(Agrif_CFixed()) and TRIM(clsuffix)
! =============
@@ -760,37 +740,4 @@
lxios_sini = .TRUE.
ENDIF
- IF( llwrt ) THEN
- ! check the domain definition
-! JMM + SM: ugly patch before getting the new version of lib_mpp)
-! idom = jpdom_local_noovlap ! default definition
- IF( llnoov ) THEN ; idom = jpdom_local_noovlap ! default definition
- ELSE ; idom = jpdom_local_full ! default definition
- ENDIF
- IF( PRESENT(kdom) ) idom = kdom
- ! create the domain informations
- ! =============
- SELECT CASE (idom)
- CASE (jpdom_local_full)
- idompar(:,1) = (/ jpi , jpj /)
- idompar(:,2) = (/ nimpp , njmpp /)
- idompar(:,3) = (/ nimpp + jpi - 1 , njmpp + jpj - 1 /)
- idompar(:,4) = (/ nldi - 1 , nldj - 1 /)
- idompar(:,5) = (/ jpi - nlei , jpj - nlej /)
- CASE (jpdom_local_noextra)
- idompar(:,1) = (/ nlci , nlcj /)
- idompar(:,2) = (/ nimpp , njmpp /)
- idompar(:,3) = (/ nimpp + nlci - 1, njmpp + nlcj - 1 /)
- idompar(:,4) = (/ nldi - 1 , nldj - 1 /)
- idompar(:,5) = (/ nlci - nlei , nlcj - nlej /)
- CASE (jpdom_local_noovlap)
- idompar(:,1) = (/ nlei - nldi + 1, nlej - nldj + 1 /)
- idompar(:,2) = (/ nimpp + nldi - 1, njmpp + nldj - 1 /)
- idompar(:,3) = (/ nimpp + nlei - 1, njmpp + nlej - 1 /)
- idompar(:,4) = (/ 0 , 0 /)
- idompar(:,5) = (/ 0 , 0 /)
- CASE DEFAULT
- CALL ctl_stop( TRIM(clinfo), 'wrong value of kdom, only jpdom_local* cases are accepted' )
- END SELECT
- ENDIF
! Open the NetCDF file
! =============
@@ -816,5 +763,5 @@
ENDIF
IF( istop == nstop ) THEN ! no error within this routine
- CALL iom_nf90_open( clname, kiomid, llwrt, llok, idompar, kdlev = kdlev )
+ CALL iom_nf90_open( clname, kiomid, llwrt, llok, kdlev = kdlev, cdcomp = cdcomp )
ENDIF
!
@@ -934,8 +881,60 @@
!! INTERFACE iom_get
!!----------------------------------------------------------------------
- SUBROUTINE iom_g0d( kiomid, cdvar, pvar, ktime, ldxios )
+ SUBROUTINE iom_g0d_sp( kiomid, cdvar, pvar, ktime, ldxios )
INTEGER , INTENT(in ) :: kiomid ! Identifier of the file
CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable
- REAL(wp) , INTENT( out) :: pvar ! read field
+ REAL(sp) , INTENT( out) :: pvar ! read field
+ REAL(dp) :: ztmp_pvar ! tmp var to read field
+ INTEGER , INTENT(in ), OPTIONAL :: ktime ! record number
+ LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! use xios to read restart
+ !
+ INTEGER :: idvar ! variable id
+ INTEGER :: idmspc ! number of spatial dimensions
+ INTEGER , DIMENSION(1) :: itime ! record number
+ CHARACTER(LEN=100) :: clinfo ! info character
+ CHARACTER(LEN=100) :: clname ! file name
+ CHARACTER(LEN=1) :: cldmspc !
+ LOGICAL :: llxios
+ !
+ llxios = .FALSE.
+ IF( PRESENT(ldxios) ) llxios = ldxios
+
+ IF(.NOT.llxios) THEN ! read data using default library
+ itime = 1
+ IF( PRESENT(ktime) ) itime = ktime
+ !
+ clname = iom_file(kiomid)%name
+ clinfo = ' iom_g0d, file: '//trim(clname)//', var: '//trim(cdvar)
+ !
+ IF( kiomid > 0 ) THEN
+ idvar = iom_varid( kiomid, cdvar )
+ IF( iom_file(kiomid)%nfid > 0 .AND. idvar > 0 ) THEN
+ idmspc = iom_file ( kiomid )%ndims( idvar )
+ IF( iom_file(kiomid)%luld(idvar) ) idmspc = idmspc - 1
+ WRITE(cldmspc , fmt='(i1)') idmspc
+ IF( idmspc > 0 ) CALL ctl_stop( TRIM(clinfo), 'When reading to a 0D array, we do not accept data', &
+ & 'with 1 or more spatial dimensions: '//cldmspc//' were found.' , &
+ & 'Use ncwa -a to suppress the unnecessary dimensions' )
+ CALL iom_nf90_get( kiomid, idvar, ztmp_pvar, itime )
+ pvar = ztmp_pvar
+ ENDIF
+ ENDIF
+ ELSE
+#if defined key_iomput
+ IF(lwp) WRITE(numout,*) 'XIOS RST READ (0D): ', trim(cdvar)
+ CALL iom_swap( TRIM(crxios_context) )
+ CALL xios_recv_field( trim(cdvar), pvar)
+ CALL iom_swap( TRIM(cxios_context) )
+#else
+ WRITE(ctmp1,*) 'Can not use XIOS in iom_g0d, file: '//trim(clname)//', var:'//trim(cdvar)
+ CALL ctl_stop( 'iom_g0d', ctmp1 )
+#endif
+ ENDIF
+ END SUBROUTINE iom_g0d_sp
+
+ SUBROUTINE iom_g0d_dp( kiomid, cdvar, pvar, ktime, ldxios )
+ INTEGER , INTENT(in ) :: kiomid ! Identifier of the file
+ CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable
+ REAL(dp) , INTENT( out) :: pvar ! read field
INTEGER , INTENT(in ), OPTIONAL :: ktime ! record number
LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! use xios to read restart
@@ -982,11 +981,12 @@
#endif
ENDIF
- END SUBROUTINE iom_g0d
-
- SUBROUTINE iom_g1d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, ldxios )
+ END SUBROUTINE iom_g0d_dp
+
+ SUBROUTINE iom_g1d_sp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, ldxios )
INTEGER , INTENT(in ) :: kiomid ! Identifier of the file
INTEGER , INTENT(in ) :: kdom ! Type of domain to be read
CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable
- REAL(wp) , INTENT( out), DIMENSION(:) :: pvar ! read field
+ REAL(sp) , INTENT( out), DIMENSION(:) :: pvar ! read field
+ REAL(dp) , ALLOCATABLE , DIMENSION(:) :: ztmp_pvar ! tmp var to read field
INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number
INTEGER , INTENT(in ), DIMENSION(1), OPTIONAL :: kstart ! start axis position of the reading
@@ -995,57 +995,131 @@
!
IF( kiomid > 0 ) THEN
+ IF( iom_file(kiomid)%nfid > 0 ) THEN
+ ALLOCATE(ztmp_pvar(size(pvar,1)))
+ CALL iom_get_123d( kiomid, kdom , cdvar , pv_r1d=ztmp_pvar, &
+ & ktime=ktime, kstart=kstart, kcount=kcount, &
+ & ldxios=ldxios )
+ pvar = ztmp_pvar
+ DEALLOCATE(ztmp_pvar)
+ END IF
+ ENDIF
+ END SUBROUTINE iom_g1d_sp
+
+
+ SUBROUTINE iom_g1d_dp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, ldxios )
+ INTEGER , INTENT(in ) :: kiomid ! Identifier of the file
+ INTEGER , INTENT(in ) :: kdom ! Type of domain to be read
+ CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable
+ REAL(dp) , INTENT( out), DIMENSION(:) :: pvar ! read field
+ INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number
+ INTEGER , INTENT(in ), DIMENSION(1), OPTIONAL :: kstart ! start axis position of the reading
+ INTEGER , INTENT(in ), DIMENSION(1), OPTIONAL :: kcount ! number of points in each axis
+ LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS
+ !
+ IF( kiomid > 0 ) THEN
IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom , cdvar , pv_r1d=pvar, &
& ktime=ktime, kstart=kstart, kcount=kcount, &
& ldxios=ldxios )
ENDIF
- END SUBROUTINE iom_g1d
-
- SUBROUTINE iom_g2d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr, ldxios)
- INTEGER , INTENT(in ) :: kiomid ! Identifier of the file
- INTEGER , INTENT(in ) :: kdom ! Type of domain to be read
- CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable
- REAL(wp) , INTENT( out), DIMENSION(:,:) :: pvar ! read field
- INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number
- INTEGER , INTENT(in ), DIMENSION(2) , OPTIONAL :: kstart ! start axis position of the reading
- INTEGER , INTENT(in ), DIMENSION(2) , OPTIONAL :: kcount ! number of points in each axis
- LOGICAL , INTENT(in ) , OPTIONAL :: lrowattr ! logical flag telling iom_get to
- ! look for and use a file attribute
- ! called open_ocean_jstart to set the start
- ! value for the 2nd dimension (netcdf only)
- LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS
+ END SUBROUTINE iom_g1d_dp
+
+ SUBROUTINE iom_g2d_sp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount, ldxios)
+ INTEGER , INTENT(in ) :: kiomid ! Identifier of the file
+ INTEGER , INTENT(in ) :: kdom ! Type of domain to be read
+ CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable
+ REAL(sp) , INTENT( out), DIMENSION(:,:) :: pvar ! read field
+ REAL(dp) , ALLOCATABLE , DIMENSION(:,:) :: ztmp_pvar ! tmp var to read field
+ INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number
+ CHARACTER(len=1), INTENT(in ) , OPTIONAL :: cd_type ! nature of grid-points (T, U, V, F, W)
+ REAL(dp) , INTENT(in ) , OPTIONAL :: psgn ! -1.(1.): (not) change sign across the north fold
+ INTEGER , INTENT(in ) , OPTIONAL :: kfill ! value of kfillmode in lbc_lbk
+ INTEGER , INTENT(in ), DIMENSION(2), OPTIONAL :: kstart ! start axis position of the reading
+ INTEGER , INTENT(in ), DIMENSION(2), OPTIONAL :: kcount ! number of points in each axis
+ LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS
!
IF( kiomid > 0 ) THEN
- IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom , cdvar , pv_r2d=pvar, &
- & ktime=ktime, kstart=kstart, kcount=kcount, &
- & lrowattr=lrowattr, ldxios=ldxios)
- ENDIF
- END SUBROUTINE iom_g2d
-
- SUBROUTINE iom_g3d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr, ldxios )
- INTEGER , INTENT(in ) :: kiomid ! Identifier of the file
- INTEGER , INTENT(in ) :: kdom ! Type of domain to be read
- CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable
- REAL(wp) , INTENT( out), DIMENSION(:,:,:) :: pvar ! read field
- INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number
- INTEGER , INTENT(in ), DIMENSION(3) , OPTIONAL :: kstart ! start axis position of the reading
- INTEGER , INTENT(in ), DIMENSION(3) , OPTIONAL :: kcount ! number of points in each axis
- LOGICAL , INTENT(in ) , OPTIONAL :: lrowattr ! logical flag telling iom_get to
- ! look for and use a file attribute
- ! called open_ocean_jstart to set the start
- ! value for the 2nd dimension (netcdf only)
- LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS
+ IF( iom_file(kiomid)%nfid > 0 ) THEN
+ ALLOCATE(ztmp_pvar(size(pvar,1), size(pvar,2)))
+ CALL iom_get_123d( kiomid, kdom, cdvar , pv_r2d = ztmp_pvar , ktime = ktime, &
+ & cd_type = cd_type, psgn = psgn , kfill = kfill, &
+ & kstart = kstart , kcount = kcount, ldxios=ldxios )
+ pvar = ztmp_pvar
+ DEALLOCATE(ztmp_pvar)
+ ENDIF
+ ENDIF
+ END SUBROUTINE iom_g2d_sp
+
+ SUBROUTINE iom_g2d_dp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount, ldxios)
+ INTEGER , INTENT(in ) :: kiomid ! Identifier of the file
+ INTEGER , INTENT(in ) :: kdom ! Type of domain to be read
+ CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable
+ REAL(dp) , INTENT( out), DIMENSION(:,:) :: pvar ! read field
+ INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number
+ CHARACTER(len=1), INTENT(in ) , OPTIONAL :: cd_type ! nature of grid-points (T, U, V, F, W)
+ REAL(dp) , INTENT(in ) , OPTIONAL :: psgn ! -1.(1.): (not) change sign across the north fold
+ INTEGER , INTENT(in ) , OPTIONAL :: kfill ! value of kfillmode in lbc_lbk
+ INTEGER , INTENT(in ), DIMENSION(2), OPTIONAL :: kstart ! start axis position of the reading
+ INTEGER , INTENT(in ), DIMENSION(2), OPTIONAL :: kcount ! number of points in each axis
+ LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS
!
IF( kiomid > 0 ) THEN
- IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom , cdvar , pv_r3d=pvar, &
- & ktime=ktime, kstart=kstart, kcount=kcount, &
- & lrowattr=lrowattr, ldxios=ldxios )
- ENDIF
- END SUBROUTINE iom_g3d
+ IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom, cdvar , pv_r2d = pvar , ktime = ktime, &
+ & cd_type = cd_type, psgn = psgn , kfill = kfill, &
+ & kstart = kstart , kcount = kcount, ldxios=ldxios )
+ ENDIF
+ END SUBROUTINE iom_g2d_dp
+
+ SUBROUTINE iom_g3d_sp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount, ldxios )
+ INTEGER , INTENT(in ) :: kiomid ! Identifier of the file
+ INTEGER , INTENT(in ) :: kdom ! Type of domain to be read
+ CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable
+ REAL(sp) , INTENT( out), DIMENSION(:,:,:) :: pvar ! read field
+ REAL(dp) , ALLOCATABLE , DIMENSION(:,:,:) :: ztmp_pvar ! tmp var to read field
+ INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number
+ CHARACTER(len=1), INTENT(in ) , OPTIONAL :: cd_type ! nature of grid-points (T, U, V, F, W)
+ REAL(dp) , INTENT(in ) , OPTIONAL :: psgn ! -1.(1.) : (not) change sign across the north fold
+ INTEGER , INTENT(in ) , OPTIONAL :: kfill ! value of kfillmode in lbc_lbk
+ INTEGER , INTENT(in ), DIMENSION(3), OPTIONAL :: kstart ! start axis position of the reading
+ INTEGER , INTENT(in ), DIMENSION(3), OPTIONAL :: kcount ! number of points in each axis
+ LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS
+ !
+ IF( kiomid > 0 ) THEN
+ IF( iom_file(kiomid)%nfid > 0 ) THEN
+ ALLOCATE(ztmp_pvar(size(pvar,1), size(pvar,2), size(pvar,3)))
+ CALL iom_get_123d( kiomid, kdom, cdvar , pv_r3d = ztmp_pvar , ktime = ktime, &
+ & cd_type = cd_type, psgn = psgn , kfill = kfill, &
+ & kstart = kstart , kcount = kcount, ldxios=ldxios )
+ pvar = ztmp_pvar
+ DEALLOCATE(ztmp_pvar)
+ END IF
+ ENDIF
+ END SUBROUTINE iom_g3d_sp
+
+ SUBROUTINE iom_g3d_dp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount, ldxios )
+ INTEGER , INTENT(in ) :: kiomid ! Identifier of the file
+ INTEGER , INTENT(in ) :: kdom ! Type of domain to be read
+ CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable
+ REAL(dp) , INTENT( out), DIMENSION(:,:,:) :: pvar ! read field
+ INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number
+ CHARACTER(len=1), INTENT(in ) , OPTIONAL :: cd_type ! nature of grid-points (T, U, V, F, W)
+ REAL(dp) , INTENT(in ) , OPTIONAL :: psgn ! -1.(1.) : (not) change sign across the north fold
+ INTEGER , INTENT(in ) , OPTIONAL :: kfill ! value of kfillmode in lbc_lbk
+ INTEGER , INTENT(in ), DIMENSION(3), OPTIONAL :: kstart ! start axis position of the reading
+ INTEGER , INTENT(in ), DIMENSION(3), OPTIONAL :: kcount ! number of points in each axis
+ LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS
+ !
+ IF( kiomid > 0 ) THEN
+ IF( iom_file(kiomid)%nfid > 0 ) THEN
+ CALL iom_get_123d( kiomid, kdom, cdvar , pv_r3d = pvar , ktime = ktime, &
+ & cd_type = cd_type, psgn = psgn , kfill = kfill, &
+ & kstart = kstart , kcount = kcount, ldxios=ldxios )
+ END IF
+ ENDIF
+ END SUBROUTINE iom_g3d_dp
+
!!----------------------------------------------------------------------
- SUBROUTINE iom_get_123d( kiomid, kdom , cdvar , &
- & pv_r1d, pv_r2d, pv_r3d, &
- & ktime , kstart, kcount, &
- & lrowattr, ldxios )
+ SUBROUTINE iom_get_123d( kiomid , kdom, cdvar, pv_r1d, pv_r2d, pv_r3d, ktime , &
+ & cd_type, psgn, kfill, kstart, kcount, ldxios )
!!-----------------------------------------------------------------------
!! *** ROUTINE iom_get_123d ***
@@ -1055,23 +1129,20 @@
!! ** Method : read ONE record at each CALL
!!-----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: kiomid ! Identifier of the file
- INTEGER , INTENT(in ) :: kdom ! Type of domain to be read
- CHARACTER(len=*) , INTENT(in ) :: cdvar ! Name of the variable
- REAL(wp), DIMENSION(:) , INTENT( out), OPTIONAL :: pv_r1d ! read field (1D case)
- REAL(wp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pv_r2d ! read field (2D case)
- REAL(wp), DIMENSION(:,:,:) , INTENT( out), OPTIONAL :: pv_r3d ! read field (3D case)
- INTEGER , INTENT(in ), OPTIONAL :: ktime ! record number
- INTEGER , DIMENSION(:) , INTENT(in ), OPTIONAL :: kstart ! start position of the reading in each axis
- INTEGER , DIMENSION(:) , INTENT(in ), OPTIONAL :: kcount ! number of points to be read in each axis
- LOGICAL , INTENT(in ), OPTIONAL :: lrowattr ! logical flag telling iom_get to
- ! look for and use a file attribute
- ! called open_ocean_jstart to set the start
- ! value for the 2nd dimension (netcdf only)
- LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! use XIOS to read restart
- !
- LOGICAL :: llxios ! local definition for XIOS read
- LOGICAL :: llnoov ! local definition to read overlap
- LOGICAL :: luse_jattr ! local definition to read open_ocean_jstart file attribute
- INTEGER :: jstartrow ! start point for 2nd dimension optionally set by file attribute
+ INTEGER , INTENT(in ) :: kiomid ! Identifier of the file
+ INTEGER , INTENT(in ) :: kdom ! Type of domain to be read
+ CHARACTER(len=*) , INTENT(in ) :: cdvar ! Name of the variable
+ REAL(dp), DIMENSION(:) , INTENT( out), OPTIONAL :: pv_r1d ! read field (1D case)
+ REAL(dp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pv_r2d ! read field (2D case)
+ REAL(dp), DIMENSION(:,:,:) , INTENT( out), OPTIONAL :: pv_r3d ! read field (3D case)
+ INTEGER , INTENT(in ), OPTIONAL :: ktime ! record number
+ CHARACTER(len=1) , INTENT(in ), OPTIONAL :: cd_type ! nature of grid-points (T, U, V, F, W)
+ REAL(dp) , INTENT(in ), OPTIONAL :: psgn ! -1.(1.) : (not) change sign across the north fold
+ INTEGER , INTENT(in ), OPTIONAL :: kfill ! value of kfillmode in lbc_lbk
+ INTEGER , DIMENSION(:) , INTENT(in ), OPTIONAL :: kstart ! start position of the reading in each axis
+ INTEGER , DIMENSION(:) , INTENT(in ), OPTIONAL :: kcount ! number of points to be read in each axis
+ LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! use XIOS to read restart
+ !
+ LOGICAL :: llok ! true if ok!
+ LOGICAL :: llxios ! local definition for XIOS read
INTEGER :: jl ! loop on number of dimension
INTEGER :: idom ! type of domain
@@ -1089,12 +1160,14 @@
INTEGER, DIMENSION(jpmax_dims) :: idimsz ! size of the dimensions of the variable
INTEGER, DIMENSION(jpmax_dims) :: ishape ! size of the dimensions of the variable
- REAL(wp) :: zscf, zofs ! sacle_factor and add_offset
+ REAL(dp) :: zscf, zofs ! sacle_factor and add_offset
+ REAL(wp) :: zsgn ! local value of psgn
INTEGER :: itmp ! temporary integer
CHARACTER(LEN=256) :: clinfo ! info character
CHARACTER(LEN=256) :: clname ! file name
CHARACTER(LEN=1) :: clrankpv, cldmspc !
- LOGICAL :: ll_depth_spec ! T => if kstart, kcount present then *only* use values for 3rd spatial dimension.
+ CHARACTER(LEN=1) :: cl_type ! local value of cd_type
+ 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(wp) :: gma, gmi
+ REAL(dp) :: gma, gmi
!---------------------------------------------------------------------
!
@@ -1103,33 +1176,26 @@
!
llxios = .FALSE.
- if(PRESENT(ldxios)) llxios = ldxios
- idvar = iom_varid( kiomid, cdvar )
+ IF( PRESENT(ldxios) ) llxios = ldxios
+ !
idom = kdom
+ istop = nstop
!
IF(.NOT.llxios) THEN
clname = iom_file(kiomid)%name ! esier to read
clinfo = ' iom_get_123d, file: '//trim(clname)//', var: '//trim(cdvar)
- ! local definition of the domain ?
- ! do we read the overlap
- ! ugly patch SM+JMM+RB to overwrite global definition in some cases
- llnoov = (jpni * jpnj ) == jpnij .AND. .NOT. lk_agrif
! check kcount and kstart optionals parameters...
- IF( PRESENT(kcount) .AND. (.NOT. PRESENT(kstart)) ) CALL ctl_stop(trim(clinfo), 'kcount present needs kstart present')
- IF( PRESENT(kstart) .AND. (.NOT. PRESENT(kcount)) ) CALL ctl_stop(trim(clinfo), 'kstart present needs kcount present')
- IF( PRESENT(kstart) .AND. idom /= jpdom_unknown .AND. idom /= jpdom_autoglo_xy ) &
- & CALL ctl_stop(trim(clinfo), 'kstart present needs kdom = jpdom_unknown or kdom = jpdom_autoglo_xy')
-
- luse_jattr = .false.
- IF( PRESENT(lrowattr) ) THEN
- IF( lrowattr .AND. idom /= jpdom_data ) CALL ctl_stop(trim(clinfo), 'lrowattr present and true needs kdom = jpdom_data')
- IF( lrowattr .AND. idom == jpdom_data ) luse_jattr = .true.
- ENDIF
-
+ IF( PRESENT(kcount) .AND. .NOT. PRESENT(kstart) ) CALL ctl_stop(trim(clinfo), 'kcount present needs kstart present')
+ IF( PRESENT(kstart) .AND. .NOT. PRESENT(kcount) ) CALL ctl_stop(trim(clinfo), 'kstart present needs kcount present')
+ IF( PRESENT(kstart) .AND. idom /= jpdom_unknown .AND. idom /= jpdom_auto_xy ) &
+ & CALL ctl_stop(TRIM(clinfo), 'kstart present needs idom = jpdom_unknown or idom = jpdom_auto_xy')
+ IF( idom == jpdom_auto_xy .AND. .NOT. PRESENT(kstart) ) &
+ & CALL ctl_stop(TRIM(clinfo), 'idom = jpdom_auto_xy requires kstart to be present')
+ !
! Search for the variable in the data base (eventually actualize data)
- istop = nstop
!
+ idvar = iom_varid( kiomid, cdvar )
IF( idvar > 0 ) THEN
- ! to write iom_file(kiomid)%dimsz in a shorter way !
- idimsz(:) = iom_file(kiomid)%dimsz(:, idvar)
+ !
+ idimsz(:) = iom_file(kiomid)%dimsz(:, idvar) ! to write iom_file(kiomid)%dimsz in a shorter way
inbdim = iom_file(kiomid)%ndims(idvar) ! number of dimensions in the file
idmspc = inbdim ! number of spatial dimensions in the file
@@ -1137,27 +1203,11 @@
IF( idmspc > 3 ) CALL ctl_stop(trim(clinfo), 'the file has more than 3 spatial dimensions this case is not coded...')
!
- ! update idom definition...
- ! Identify the domain in case of jpdom_auto(glo/dta) definition
- IF( idom == jpdom_autoglo_xy ) THEN
- ll_depth_spec = .TRUE.
- idom = jpdom_autoglo
- ELSE
- ll_depth_spec = .FALSE.
- ENDIF
- IF( idom == jpdom_autoglo .OR. idom == jpdom_autodta ) THEN
- IF( idom == jpdom_autoglo ) THEN ; idom = jpdom_global
- ELSE ; idom = jpdom_data
- ENDIF
+ ! Identify the domain in case of jpdom_auto definition
+ IF( idom == jpdom_auto .OR. idom == jpdom_auto_xy ) THEN
+ idom = jpdom_global ! default
+ ! else: if the file name finishes with _xxxx.nc with xxxx any number
ind1 = INDEX( clname, '_', back = .TRUE. ) + 1
ind2 = INDEX( clname, '.', back = .TRUE. ) - 1
IF( ind2 > ind1 ) THEN ; IF( VERIFY( clname(ind1:ind2), '0123456789' ) == 0 ) idom = jpdom_local ; ENDIF
- ENDIF
- ! Identify the domain in case of jpdom_local definition
- IF( idom == jpdom_local ) THEN
- IF( idimsz(1) == jpi .AND. idimsz(2) == jpj ) THEN ; idom = jpdom_local_full
- ELSEIF( idimsz(1) == nlci .AND. idimsz(2) == nlcj ) THEN ; idom = jpdom_local_noextra
- ELSEIF( idimsz(1) == (nlei - nldi + 1) .AND. idimsz(2) == (nlej - nldj + 1) ) THEN ; idom = jpdom_local_noovlap
- ELSE ; CALL ctl_stop( trim(clinfo), 'impossible to identify the local domain' )
- ENDIF
ENDIF
!
@@ -1172,22 +1222,30 @@
WRITE(cldmspc , fmt='(i1)') idmspc
!
- !!GS: we consider 2D data as 3D data with vertical dim size = 1
- !IF( idmspc < irankpv ) THEN
- ! CALL ctl_stop( TRIM(clinfo), 'The file has only '//cldmspc//' spatial dimension', &
- ! & 'it is impossible to read a '//clrankpv//'D array from this file...' )
- !ELSEIF( idmspc == irankpv ) THEN
- IF( idmspc == irankpv ) THEN
+ IF( idmspc < irankpv ) THEN ! it seems we want to read more than we can...
+ IF( irankpv == 3 .AND. idmspc == 2 ) THEN ! 3D input array from 2D spatial data in the file:
+ llok = inlev == 1 ! -> 3rd dimension must be equal to 1
+ ELSEIF( irankpv == 3 .AND. idmspc == 1 ) THEN ! 3D input array from 1D spatial data in the file:
+ llok = inlev == 1 .AND. SIZE(pv_r3d, 2) == 1 ! -> 2nd and 3rd dimensions must be equal to 1
+ ELSEIF( irankpv == 2 .AND. idmspc == 2 ) THEN ! 2D input array from 1D spatial data in the file:
+ llok = SIZE(pv_r2d, 2) == 1 ! -> 2nd dimension must be equal to 1
+ ELSE
+ llok = .FALSE.
+ ENDIF
+ IF( .NOT. llok ) CALL ctl_stop( TRIM(clinfo), 'The file has only '//cldmspc//' spatial dimension', &
+ & '=> cannot read a true '//clrankpv//'D array from this file...' )
+ ELSEIF( idmspc == irankpv ) THEN
IF( PRESENT(pv_r1d) .AND. idom /= jpdom_unknown ) &
& CALL ctl_stop( TRIM(clinfo), 'case not coded...You must use jpdom_unknown' )
- ELSEIF( idmspc > irankpv ) THEN
+ ELSEIF( idmspc > irankpv ) THEN ! it seems we want to read less than we should...
IF( PRESENT(pv_r2d) .AND. itime == 1 .AND. idimsz(3) == 1 .AND. idmspc == 3 ) THEN
- CALL ctl_warn( trim(clinfo), '2D array but 3 spatial dimensions for the data...' , &
+ CALL ctl_warn( trim(clinfo), '2D array input but 3 spatial dimensions in the file...' , &
& 'As the size of the z dimension is 1 and as we try to read the first record, ', &
& 'we accept this case, even if there is a possible mix-up between z and time dimension' )
idmspc = idmspc - 1
- ELSE
- CALL ctl_stop( TRIM(clinfo), 'To keep iom lisibility, when reading a '//clrankpv//'D array,' , &
- & 'we do not accept data with '//cldmspc//' spatial dimensions', &
- & 'Use ncwa -a to suppress the unnecessary dimensions' )
+ !!GS: possibility to read 3D ABL atmopsheric forcing and use 1st level to force BULK simulation
+ !ELSE
+ ! CALL ctl_stop( TRIM(clinfo), 'To keep iom lisibility, when reading a '//clrankpv//'D array,', &
+ ! & 'we do not accept data with '//cldmspc//' spatial dimensions' , &
+ ! & 'Use ncwa -a to suppress the unnecessary dimensions' )
ENDIF
ENDIF
@@ -1195,45 +1253,29 @@
! definition of istart and icnt
!
- icnt (:) = 1
- istart(:) = 1
- istart(idmspc+1) = itime
-
- IF( PRESENT(kstart) .AND. .NOT. ll_depth_spec ) THEN
- istart(1:idmspc) = kstart(1:idmspc)
- icnt (1:idmspc) = kcount(1:idmspc)
- ELSE
- IF(idom == jpdom_unknown ) THEN
- icnt(1:idmspc) = idimsz(1:idmspc)
- ELSE
- IF( .NOT. PRESENT(pv_r1d) ) THEN ! not a 1D array
- IF( idom == jpdom_data ) THEN
- jstartrow = 1
- IF( luse_jattr ) THEN
- CALL iom_getatt(kiomid, 'open_ocean_jstart', jstartrow ) ! -999 is returned if the attribute is not found
- jstartrow = MAX(1,jstartrow)
- ENDIF
- istart(1:2) = (/ mig(1), mjg(1) + jstartrow - 1 /) ! icnt(1:2) done below
- ELSEIF( idom == jpdom_global ) THEN ; istart(1:2) = (/ nimpp , njmpp /) ! icnt(1:2) done below
- ENDIF
- ! we do not read the overlap -> we start to read at nldi, nldj
-! JMM + SM: ugly patch before getting the new version of lib_mpp)
-! IF( idom /= jpdom_local_noovlap ) istart(1:2) = istart(1:2) + (/ nldi - 1, nldj - 1 /)
- IF( llnoov .AND. idom /= jpdom_local_noovlap ) istart(1:2) = istart(1:2) + (/ nldi - 1, nldj - 1 /)
- ! we do not read the overlap and the extra-halos -> from nldi to nlei and from nldj to nlej
-! JMM + SM: ugly patch before getting the new version of lib_mpp)
-! icnt(1:2) = (/ nlei - nldi + 1, nlej - nldj + 1 /)
- IF( llnoov ) THEN ; icnt(1:2) = (/ nlei - nldi + 1, nlej - nldj + 1 /)
- ELSE ; icnt(1:2) = (/ nlci , nlcj /)
- ENDIF
- IF( PRESENT(pv_r3d) ) THEN
- IF( idom == jpdom_data ) THEN ; icnt(3) = inlev
- ELSEIF( ll_depth_spec .AND. PRESENT(kstart) ) THEN ; istart(3) = kstart(3) ; icnt(3) = kcount(3)
- ELSE ; icnt(3) = inlev
- ENDIF
- ENDIF
+ icnt (:) = 1 ! default definition (simple way to deal with special cases listed above)
+ istart(:) = 1 ! default definition (simple way to deal with special cases listed above)
+ istart(idmspc+1) = itime ! temporal dimenstion
+ !
+ IF( idom == jpdom_unknown ) THEN
+ IF( PRESENT(kstart) .AND. idom /= jpdom_auto_xy ) THEN
+ istart(1:idmspc) = kstart(1:idmspc)
+ icnt (1:idmspc) = kcount(1:idmspc)
+ ELSE
+ icnt (1:idmspc) = idimsz(1:idmspc)
+ 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) /)
+ icnt(1:2) = (/ Ni_0, Nj_0 /)
+ IF( PRESENT(pv_r3d) ) THEN
+ IF( idom == jpdom_auto_xy ) THEN
+ istart(3) = kstart(3)
+ icnt (3) = kcount(3)
+ ELSE
+ icnt (3) = inlev
ENDIF
ENDIF
ENDIF
-
+ !
! check that istart and icnt can be used with this file
!-
@@ -1246,5 +1288,5 @@
ENDIF
END DO
-
+ !
! check that icnt matches the input array
!-
@@ -1256,19 +1298,10 @@
ELSE
IF( irankpv == 2 ) THEN
-! JMM + SM: ugly patch before getting the new version of lib_mpp)
-! ishape(1:2) = SHAPE(pv_r2d(nldi:nlei,nldj:nlej )) ; ctmp1 = 'd(nldi:nlei,nldj:nlej)'
- IF( llnoov ) THEN ; ishape(1:2)=SHAPE(pv_r2d(nldi:nlei,nldj:nlej )) ; ctmp1='d(nldi:nlei,nldj:nlej)'
- ELSE ; ishape(1:2)=SHAPE(pv_r2d(1 :nlci,1 :nlcj )) ; ctmp1='d(1:nlci,1:nlcj)'
- ENDIF
+ ishape(1:2) = SHAPE(pv_r2d(Nis0:Nie0,Njs0:Nje0 )) ; ctmp1 = 'd(Nis0:Nie0,Njs0:Nje0)'
ENDIF
IF( irankpv == 3 ) THEN
-! JMM + SM: ugly patch before getting the new version of lib_mpp)
-! ishape(1:3) = SHAPE(pv_r3d(nldi:nlei,nldj:nlej,:)) ; ctmp1 = 'd(nldi:nlei,nldj:nlej,:)'
- IF( llnoov ) THEN ; ishape(1:3)=SHAPE(pv_r3d(nldi:nlei,nldj:nlej,:)) ; ctmp1='d(nldi:nlei,nldj:nlej,:)'
- ELSE ; ishape(1:3)=SHAPE(pv_r3d(1 :nlci,1 :nlcj,:)) ; ctmp1='d(1:nlci,1:nlcj,:)'
- ENDIF
+ ishape(1:3) = SHAPE(pv_r3d(Nis0:Nie0,Njs0:Nje0,:)) ; ctmp1 = 'd(Nis0:Nie0,Njs0:Nje0,:)'
ENDIF
- ENDIF
-
+ ENDIF
DO jl = 1, irankpv
WRITE( ctmp2, FMT="(', ', i1,'): ', i5,' /= icnt(', i1,'):', i5)" ) jl, ishape(jl), jl, icnt(jl)
@@ -1282,17 +1315,7 @@
IF( idvar > 0 .AND. istop == nstop ) THEN ! no additional errors until this point...
!
- ! find the right index of the array to be read
-! JMM + SM: ugly patch before getting the new version of lib_mpp)
-! IF( idom /= jpdom_unknown ) THEN ; ix1 = nldi ; ix2 = nlei ; iy1 = nldj ; iy2 = nlej
-! ELSE ; ix1 = 1 ; ix2 = icnt(1) ; iy1 = 1 ; iy2 = icnt(2)
-! ENDIF
- IF( llnoov ) THEN
- IF( idom /= jpdom_unknown ) THEN ; ix1 = nldi ; ix2 = nlei ; iy1 = nldj ; iy2 = nlej
- ELSE ; ix1 = 1 ; ix2 = icnt(1) ; iy1 = 1 ; iy2 = icnt(2)
- ENDIF
- ELSE
- IF( idom /= jpdom_unknown ) THEN ; ix1 = 1 ; ix2 = nlci ; iy1 = 1 ; iy2 = nlcj
- ELSE ; ix1 = 1 ; ix2 = icnt(1) ; iy1 = 1 ; iy2 = icnt(2)
- ENDIF
+ ! 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
@@ -1301,16 +1324,14 @@
IF( istop == nstop ) THEN ! no additional errors until this point...
IF(lwp) WRITE(numout,"(10x,' read ',a,' (rec: ',i6,') in ',a,' ok')") TRIM(cdvar), itime, TRIM(iom_file(kiomid)%name)
-
+
+ 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 ) THEN
- CALL lbc_lnk( 'iom', pv_r2d,'Z', -999., kfillmode = jpfillnothing )
- ELSEIF( PRESENT(pv_r3d) .AND. idom /= jpdom_unknown ) THEN
- ! this if could be simplified with the new lbc_lnk that works with any size of the 3rd dimension
- IF( icnt(3) == inlev ) THEN
- CALL lbc_lnk( 'iom', pv_r3d,'Z', -999., kfillmode = jpfillnothing )
- ELSE ! put some arbitrary value (a call to lbc_lnk will be done later...)
- DO jj = nlcj+1, jpj ; pv_r3d(1:nlci, jj, :) = pv_r3d(1:nlci, nlej, :) ; END DO
- DO ji = nlci+1, jpi ; pv_r3d(ji , : , :) = pv_r3d(nlei , : , :) ; END DO
- ENDIF
+ 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 )
ENDIF
!
@@ -1329,20 +1350,13 @@
CALL iom_swap( TRIM(crxios_context) )
IF( PRESENT(pv_r3d) ) THEN
- pv_r3d(:, :, :) = 0.
- if(lwp) write(numout,*) 'XIOS RST READ (3D): ',trim(cdvar)
+ IF(lwp) WRITE(numout,*) 'XIOS RST READ (3D): ',TRIM(cdvar)
CALL xios_recv_field( trim(cdvar), pv_r3d)
- IF(idom /= jpdom_unknown ) then
- CALL lbc_lnk( 'iom', pv_r3d,'Z', -999., kfillmode = jpfillnothing)
- ENDIF
+ IF(idom /= jpdom_unknown ) CALL lbc_lnk( 'iom', pv_r3d,'Z', -999., kfillmode = jpfillnothing)
ELSEIF( PRESENT(pv_r2d) ) THEN
- pv_r2d(:, :) = 0.
- if(lwp) write(numout,*) 'XIOS RST READ (2D): ', trim(cdvar)
+ IF(lwp) WRITE(numout,*) 'XIOS RST READ (2D): ', TRIM(cdvar)
CALL xios_recv_field( trim(cdvar), pv_r2d)
- IF(idom /= jpdom_unknown ) THEN
- CALL lbc_lnk('iom', pv_r2d,'Z',-999., kfillmode = jpfillnothing)
- ENDIF
+ IF(idom /= jpdom_unknown ) CALL lbc_lnk('iom', pv_r2d,'Z',-999., kfillmode = jpfillnothing)
ELSEIF( PRESENT(pv_r1d) ) THEN
- pv_r1d(:) = 0.
- if(lwp) write(numout,*) 'XIOS RST READ (1D): ', trim(cdvar)
+ IF(lwp) WRITE(numout,*) 'XIOS RST READ (1D): ', TRIM(cdvar)
CALL xios_recv_field( trim(cdvar), pv_r1d)
ENDIF
@@ -1355,6 +1369,6 @@
!some final adjustments
! C1D case : always call lbc_lnk to replicate the central value over the whole 3X3 domain
- IF( lk_c1d .AND. PRESENT(pv_r2d) ) CALL lbc_lnk( 'iom', pv_r2d,'Z',1. )
- IF( lk_c1d .AND. PRESENT(pv_r3d) ) CALL lbc_lnk( 'iom', pv_r3d,'Z',1. )
+ IF( lk_c1d .AND. PRESENT(pv_r2d) ) CALL lbc_lnk( 'iom', pv_r2d,'Z',1.0_wp )
+ IF( lk_c1d .AND. PRESENT(pv_r3d) ) CALL lbc_lnk( 'iom', pv_r3d,'Z',1.0_wp )
!--- Apply scale_factor and offset
@@ -1543,10 +1557,10 @@
!! INTERFACE iom_rstput
!!----------------------------------------------------------------------
- SUBROUTINE iom_rp0d( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios )
+ SUBROUTINE iom_rp0d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios )
INTEGER , INTENT(in) :: kt ! ocean time-step
INTEGER , INTENT(in) :: kwrite ! writing time-step
INTEGER , INTENT(in) :: kiomid ! Identifier of the file
CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name
- REAL(wp) , INTENT(in) :: pvar ! written field
+ REAL(sp) , INTENT(in) :: pvar ! written field
INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type
LOGICAL, OPTIONAL :: ldxios ! xios write flag
@@ -1567,16 +1581,47 @@
IF( iom_file(kiomid)%nfid > 0 ) THEN
ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. )
- CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r0d = pvar )
+ CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r0d = real(pvar, dp) )
ENDIF
ENDIF
ENDIF
- END SUBROUTINE iom_rp0d
-
- SUBROUTINE iom_rp1d( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios )
+ END SUBROUTINE iom_rp0d_sp
+
+ SUBROUTINE iom_rp0d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios )
INTEGER , INTENT(in) :: kt ! ocean time-step
INTEGER , INTENT(in) :: kwrite ! writing time-step
INTEGER , INTENT(in) :: kiomid ! Identifier of the file
CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name
- REAL(wp) , INTENT(in), DIMENSION( :) :: pvar ! written field
+ REAL(dp) , INTENT(in) :: pvar ! written field
+ INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type
+ LOGICAL, OPTIONAL :: ldxios ! xios write flag
+ LOGICAL :: llx ! local xios write flag
+ INTEGER :: ivid ! variable id
+
+ llx = .FALSE.
+ IF(PRESENT(ldxios)) llx = ldxios
+ IF( llx ) THEN
+#ifdef key_iomput
+ IF( kt == kwrite ) THEN
+ IF(lwp) write(numout,*) 'RESTART: write (XIOS 0D) ',trim(cdvar)
+ CALL xios_send_field(trim(cdvar), pvar)
+ ENDIF
+#endif
+ ELSE
+ IF( kiomid > 0 ) THEN
+ IF( iom_file(kiomid)%nfid > 0 ) THEN
+ ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. )
+ CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r0d = pvar )
+ ENDIF
+ ENDIF
+ ENDIF
+ END SUBROUTINE iom_rp0d_dp
+
+
+ SUBROUTINE iom_rp1d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios )
+ INTEGER , INTENT(in) :: kt ! ocean time-step
+ INTEGER , INTENT(in) :: kwrite ! writing time-step
+ INTEGER , INTENT(in) :: kiomid ! Identifier of the file
+ CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name
+ REAL(sp) , INTENT(in), DIMENSION( :) :: pvar ! written field
INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type
LOGICAL, OPTIONAL :: ldxios ! xios write flag
@@ -1597,16 +1642,47 @@
IF( iom_file(kiomid)%nfid > 0 ) THEN
ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. )
- CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r1d = pvar )
+ CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r1d = real(pvar, dp) )
ENDIF
ENDIF
ENDIF
- END SUBROUTINE iom_rp1d
-
- SUBROUTINE iom_rp2d( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios )
+ END SUBROUTINE iom_rp1d_sp
+
+ SUBROUTINE iom_rp1d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios )
INTEGER , INTENT(in) :: kt ! ocean time-step
INTEGER , INTENT(in) :: kwrite ! writing time-step
INTEGER , INTENT(in) :: kiomid ! Identifier of the file
CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name
- REAL(wp) , INTENT(in), DIMENSION(:, : ) :: pvar ! written field
+ REAL(dp) , INTENT(in), DIMENSION( :) :: pvar ! written field
+ INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type
+ LOGICAL, OPTIONAL :: ldxios ! xios write flag
+ LOGICAL :: llx ! local xios write flag
+ INTEGER :: ivid ! variable id
+
+ llx = .FALSE.
+ IF(PRESENT(ldxios)) llx = ldxios
+ IF( llx ) THEN
+#ifdef key_iomput
+ IF( kt == kwrite ) THEN
+ IF(lwp) write(numout,*) 'RESTART: write (XIOS 1D) ',trim(cdvar)
+ CALL xios_send_field(trim(cdvar), pvar)
+ ENDIF
+#endif
+ ELSE
+ IF( kiomid > 0 ) THEN
+ IF( iom_file(kiomid)%nfid > 0 ) THEN
+ ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. )
+ CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r1d = pvar )
+ ENDIF
+ ENDIF
+ ENDIF
+ END SUBROUTINE iom_rp1d_dp
+
+
+ SUBROUTINE iom_rp2d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios )
+ INTEGER , INTENT(in) :: kt ! ocean time-step
+ INTEGER , INTENT(in) :: kwrite ! writing time-step
+ INTEGER , INTENT(in) :: kiomid ! Identifier of the file
+ CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name
+ REAL(sp) , INTENT(in), DIMENSION(:, : ) :: pvar ! written field
INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type
LOGICAL, OPTIONAL :: ldxios ! xios write flag
@@ -1627,16 +1703,47 @@
IF( iom_file(kiomid)%nfid > 0 ) THEN
ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. )
- CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r2d = pvar )
+ CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r2d = real(pvar, dp) )
ENDIF
ENDIF
ENDIF
- END SUBROUTINE iom_rp2d
-
- SUBROUTINE iom_rp3d( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios )
+ END SUBROUTINE iom_rp2d_sp
+
+ SUBROUTINE iom_rp2d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios )
INTEGER , INTENT(in) :: kt ! ocean time-step
INTEGER , INTENT(in) :: kwrite ! writing time-step
INTEGER , INTENT(in) :: kiomid ! Identifier of the file
CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name
- REAL(wp) , INTENT(in), DIMENSION(:,:,:) :: pvar ! written field
+ REAL(dp) , INTENT(in), DIMENSION(:, : ) :: pvar ! written field
+ INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type
+ LOGICAL, OPTIONAL :: ldxios ! xios write flag
+ LOGICAL :: llx
+ INTEGER :: ivid ! variable id
+
+ llx = .FALSE.
+ IF(PRESENT(ldxios)) llx = ldxios
+ IF( llx ) THEN
+#ifdef key_iomput
+ IF( kt == kwrite ) THEN
+ IF(lwp) write(numout,*) 'RESTART: write (XIOS 2D) ',trim(cdvar)
+ CALL xios_send_field(trim(cdvar), pvar)
+ ENDIF
+#endif
+ ELSE
+ IF( kiomid > 0 ) THEN
+ IF( iom_file(kiomid)%nfid > 0 ) THEN
+ ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. )
+ CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r2d = pvar )
+ ENDIF
+ ENDIF
+ ENDIF
+ END SUBROUTINE iom_rp2d_dp
+
+
+ SUBROUTINE iom_rp3d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios )
+ INTEGER , INTENT(in) :: kt ! ocean time-step
+ INTEGER , INTENT(in) :: kwrite ! writing time-step
+ INTEGER , INTENT(in) :: kiomid ! Identifier of the file
+ CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name
+ REAL(sp) , INTENT(in), DIMENSION(:,:,:) :: pvar ! written field
INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type
LOGICAL, OPTIONAL :: ldxios ! xios write flag
@@ -1657,9 +1764,40 @@
IF( iom_file(kiomid)%nfid > 0 ) THEN
ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. )
+ CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r3d = real(pvar, dp) )
+ ENDIF
+ ENDIF
+ ENDIF
+ END SUBROUTINE iom_rp3d_sp
+
+ SUBROUTINE iom_rp3d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios )
+ INTEGER , INTENT(in) :: kt ! ocean time-step
+ INTEGER , INTENT(in) :: kwrite ! writing time-step
+ INTEGER , INTENT(in) :: kiomid ! Identifier of the file
+ CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name
+ REAL(dp) , INTENT(in), DIMENSION(:,:,:) :: pvar ! written field
+ INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type
+ LOGICAL, OPTIONAL :: ldxios ! xios write flag
+ LOGICAL :: llx ! local xios write flag
+ INTEGER :: ivid ! variable id
+
+ llx = .FALSE.
+ IF(PRESENT(ldxios)) llx = ldxios
+ IF( llx ) THEN
+#ifdef key_iomput
+ IF( kt == kwrite ) THEN
+ IF(lwp) write(numout,*) 'RESTART: write (XIOS 3D) ',trim(cdvar)
+ CALL xios_send_field(trim(cdvar), pvar)
+ ENDIF
+#endif
+ ELSE
+ IF( kiomid > 0 ) THEN
+ IF( iom_file(kiomid)%nfid > 0 ) THEN
+ ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. )
CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r3d = pvar )
ENDIF
ENDIF
ENDIF
- END SUBROUTINE iom_rp3d
+ END SUBROUTINE iom_rp3d_dp
+
@@ -1713,7 +1851,7 @@
!! INTERFACE iom_put
!!----------------------------------------------------------------------
- SUBROUTINE iom_p0d( cdname, pfield0d )
+ SUBROUTINE iom_p0d_sp( cdname, pfield0d )
CHARACTER(LEN=*), INTENT(in) :: cdname
- REAL(wp) , INTENT(in) :: pfield0d
+ REAL(sp) , INTENT(in) :: pfield0d
!! REAL(wp) , DIMENSION(jpi,jpj) :: zz ! masson
#if defined key_iomput
@@ -1724,9 +1862,23 @@
IF( .FALSE. ) WRITE(numout,*) cdname, pfield0d ! useless test to avoid compilation warnings
#endif
- END SUBROUTINE iom_p0d
-
- SUBROUTINE iom_p1d( cdname, pfield1d )
+ END SUBROUTINE iom_p0d_sp
+
+ SUBROUTINE iom_p0d_dp( cdname, pfield0d )
+ CHARACTER(LEN=*), INTENT(in) :: cdname
+ REAL(dp) , INTENT(in) :: pfield0d
+!! REAL(wp) , DIMENSION(jpi,jpj) :: zz ! masson
+#if defined key_iomput
+!!clem zz(:,:)=pfield0d
+!!clem CALL xios_send_field(cdname, zz)
+ CALL xios_send_field(cdname, (/pfield0d/))
+#else
+ IF( .FALSE. ) WRITE(numout,*) cdname, pfield0d ! useless test to avoid compilation warnings
+#endif
+ END SUBROUTINE iom_p0d_dp
+
+
+ SUBROUTINE iom_p1d_sp( cdname, pfield1d )
CHARACTER(LEN=*) , INTENT(in) :: cdname
- REAL(wp), DIMENSION(:), INTENT(in) :: pfield1d
+ REAL(sp), DIMENSION(:), INTENT(in) :: pfield1d
#if defined key_iomput
CALL xios_send_field( cdname, RESHAPE( (/pfield1d/), (/1,1,SIZE(pfield1d)/) ) )
@@ -1734,36 +1886,111 @@
IF( .FALSE. ) WRITE(numout,*) cdname, pfield1d ! useless test to avoid compilation warnings
#endif
- END SUBROUTINE iom_p1d
-
- SUBROUTINE iom_p2d( cdname, pfield2d )
+ END SUBROUTINE iom_p1d_sp
+
+ SUBROUTINE iom_p1d_dp( cdname, pfield1d )
+ CHARACTER(LEN=*) , INTENT(in) :: cdname
+ REAL(dp), DIMENSION(:), INTENT(in) :: pfield1d
+#if defined key_iomput
+ CALL xios_send_field( cdname, RESHAPE( (/pfield1d/), (/1,1,SIZE(pfield1d)/) ) )
+#else
+ IF( .FALSE. ) WRITE(numout,*) cdname, pfield1d ! useless test to avoid compilation warnings
+#endif
+ END SUBROUTINE iom_p1d_dp
+
+ SUBROUTINE iom_p2d_sp( cdname, pfield2d )
CHARACTER(LEN=*) , INTENT(in) :: cdname
- REAL(wp), DIMENSION(:,:), INTENT(in) :: pfield2d
-#if defined key_iomput
- CALL xios_send_field(cdname, pfield2d)
+ REAL(sp), DIMENSION(:,:), INTENT(in) :: pfield2d
+ IF( iom_use(cdname) ) THEN
+#if defined key_iomput
+ IF( SIZE(pfield2d, dim=1) == jpi .AND. SIZE(pfield2d, dim=2) == jpj ) THEN
+ CALL xios_send_field( cdname, pfield2d(Nis0:Nie0, Njs0:Nje0) ) ! this extraction will create a copy of pfield2d
+ ELSE
+ CALL xios_send_field( cdname, pfield2d )
+ ENDIF
#else
- IF( .FALSE. ) WRITE(numout,*) cdname, pfield2d ! useless test to avoid compilation warnings
-#endif
- END SUBROUTINE iom_p2d
-
- SUBROUTINE iom_p3d( cdname, pfield3d )
+ WRITE(numout,*) pfield2d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings
+#endif
+ ENDIF
+ END SUBROUTINE iom_p2d_sp
+
+ SUBROUTINE iom_p2d_dp( cdname, pfield2d )
+ CHARACTER(LEN=*) , INTENT(in) :: cdname
+ REAL(dp), DIMENSION(:,:), INTENT(in) :: pfield2d
+ IF( iom_use(cdname) ) THEN
+#if defined key_iomput
+ IF( SIZE(pfield2d, dim=1) == jpi .AND. SIZE(pfield2d, dim=2) == jpj ) THEN
+ CALL xios_send_field( cdname, pfield2d(Nis0:Nie0, Njs0:Nje0) ) ! this extraction will create a copy of pfield2d
+ ELSE
+ CALL xios_send_field( cdname, pfield2d )
+ ENDIF
+#else
+ WRITE(numout,*) pfield2d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings
+#endif
+ ENDIF
+ END SUBROUTINE iom_p2d_dp
+
+ SUBROUTINE iom_p3d_sp( cdname, pfield3d )
CHARACTER(LEN=*) , INTENT(in) :: cdname
- REAL(wp), DIMENSION(:,:,:), INTENT(in) :: pfield3d
-#if defined key_iomput
- CALL xios_send_field( cdname, pfield3d )
+ REAL(sp), DIMENSION(:,:,:), INTENT(in) :: pfield3d
+ IF( iom_use(cdname) ) THEN
+#if defined key_iomput
+ IF( SIZE(pfield3d, dim=1) == jpi .AND. SIZE(pfield3d, dim=2) == jpj ) THEN
+ CALL xios_send_field( cdname, pfield3d(Nis0:Nie0, Njs0:Nje0,:) ) ! this extraction will create a copy of pfield3d
+ ELSE
+ CALL xios_send_field( cdname, pfield3d )
+ ENDIF
#else
- IF( .FALSE. ) WRITE(numout,*) cdname, pfield3d ! useless test to avoid compilation warnings
-#endif
- END SUBROUTINE iom_p3d
-
- SUBROUTINE iom_p4d( cdname, pfield4d )
+ WRITE(numout,*) pfield3d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings
+#endif
+ ENDIF
+ END SUBROUTINE iom_p3d_sp
+
+ SUBROUTINE iom_p3d_dp( cdname, pfield3d )
CHARACTER(LEN=*) , INTENT(in) :: cdname
- REAL(wp), DIMENSION(:,:,:,:), INTENT(in) :: pfield4d
-#if defined key_iomput
- CALL xios_send_field(cdname, pfield4d)
+ REAL(dp), DIMENSION(:,:,:), INTENT(in) :: pfield3d
+ IF( iom_use(cdname) ) THEN
+#if defined key_iomput
+ IF( SIZE(pfield3d, dim=1) == jpi .AND. SIZE(pfield3d, dim=2) == jpj ) THEN
+ CALL xios_send_field( cdname, pfield3d(Nis0:Nie0, Njs0:Nje0,:) ) ! this extraction will create a copy of pfield3d
+ ELSE
+ CALL xios_send_field( cdname, pfield3d )
+ ENDIF
#else
- IF( .FALSE. ) WRITE(numout,*) cdname, pfield4d ! useless test to avoid compilation warnings
-#endif
- END SUBROUTINE iom_p4d
-
+ WRITE(numout,*) pfield3d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings
+#endif
+ ENDIF
+ END SUBROUTINE iom_p3d_dp
+
+ SUBROUTINE iom_p4d_sp( cdname, pfield4d )
+ CHARACTER(LEN=*) , INTENT(in) :: cdname
+ REAL(sp), DIMENSION(:,:,:,:), INTENT(in) :: pfield4d
+ IF( iom_use(cdname) ) THEN
+#if defined key_iomput
+ IF( SIZE(pfield4d, dim=1) == jpi .AND. SIZE(pfield4d, dim=2) == jpj ) THEN
+ CALL xios_send_field( cdname, pfield4d(Nis0:Nie0, Njs0:Nje0,:,:) ) ! this extraction will create a copy of pfield4d
+ ELSE
+ CALL xios_send_field (cdname, pfield4d )
+ ENDIF
+#else
+ WRITE(numout,*) pfield4d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings
+#endif
+ ENDIF
+ END SUBROUTINE iom_p4d_sp
+
+ SUBROUTINE iom_p4d_dp( cdname, pfield4d )
+ CHARACTER(LEN=*) , INTENT(in) :: cdname
+ REAL(dp), DIMENSION(:,:,:,:), INTENT(in) :: pfield4d
+ IF( iom_use(cdname) ) THEN
+#if defined key_iomput
+ IF( SIZE(pfield4d, dim=1) == jpi .AND. SIZE(pfield4d, dim=2) == jpj ) THEN
+ CALL xios_send_field( cdname, pfield4d(Nis0:Nie0, Njs0:Nje0,:,:) ) ! this extraction will create a copy of pfield4d
+ ELSE
+ CALL xios_send_field (cdname, pfield4d )
+ ENDIF
+#else
+ WRITE(numout,*) pfield4d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings
+#endif
+ ENDIF
+ END SUBROUTINE iom_p4d_dp
#if defined key_iomput
@@ -1781,6 +2008,6 @@
INTEGER , OPTIONAL, INTENT(in) :: data_dim, data_ibegin, data_ni, data_jbegin, data_nj
INTEGER , OPTIONAL, INTENT(in) :: nvertex
- REAL(wp), DIMENSION(:) , OPTIONAL, INTENT(in) :: lonvalue, latvalue
- REAL(wp), DIMENSION(:,:), OPTIONAL, INTENT(in) :: bounds_lon, bounds_lat, area
+ REAL(dp), DIMENSION(:) , OPTIONAL, INTENT(in) :: lonvalue, latvalue
+ REAL(dp), DIMENSION(:,:), OPTIONAL, INTENT(in) :: bounds_lon, bounds_lat, area
LOGICAL , DIMENSION(:) , OPTIONAL, INTENT(in) :: mask
!!----------------------------------------------------------------------
@@ -1845,9 +2072,14 @@
!!----------------------------------------------------------------------
IF( PRESENT(paxis) ) THEN
- IF( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid, n_glo=SIZE(paxis), value=paxis )
- IF( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid, n_glo=SIZE(paxis), value=paxis )
- ENDIF
- IF( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid, bounds=bounds )
- IF( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid, bounds=bounds )
+ IF( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid, n_glo=SIZE(paxis), value=real(paxis, dp) )
+ IF( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid, n_glo=SIZE(paxis), value=real(paxis, dp) )
+ ENDIF
+ IF( PRESENT(bounds) ) THEN
+ IF( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid, bounds=real(bounds, dp) )
+ IF( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid, bounds=real(bounds, dp) )
+ ELSE
+ IF( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid)
+ IF( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid)
+ END IF
CALL xios_solve_inheritance()
END SUBROUTINE iom_set_axis_attr
@@ -1956,18 +2188,14 @@
REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: plat
!
- INTEGER :: ni, nj
REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask
LOGICAL, INTENT(IN) :: ldxios, ldrxios
!!----------------------------------------------------------------------
!
- ni = nlei-nldi+1
- nj = nlej-nldj+1
- !
- CALL iom_set_domain_attr("grid_"//cdgrd, ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-2, jbegin=njmpp+nldj-2, ni=ni, nj=nj)
- CALL iom_set_domain_attr("grid_"//cdgrd, data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj)
+ 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 = 0, data_ni = Ni_0, data_jbegin = 0, data_nj = Nj_0)
!don't define lon and lat for restart reading context.
IF ( .NOT.ldrxios ) &
- CALL iom_set_domain_attr("grid_"//cdgrd, lonvalue = RESHAPE(plon(nldi:nlei, nldj:nlej),(/ ni*nj /)), &
- & latvalue = RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /)))
+ CALL iom_set_domain_attr("grid_"//cdgrd, lonvalue = real(RESHAPE(plon(Nis0:Nie0, Njs0:Nje0),(/ Ni_0*Nj_0 /)),dp), &
+ & latvalue = real(RESHAPE(plat(Nis0:Nie0, Njs0:Nje0),(/ Ni_0*Nj_0 /)),dp ))
!
IF ( ln_mskland .AND. (.NOT.ldxios) ) THEN
@@ -1975,15 +2203,14 @@
SELECT CASE ( cdgrd )
CASE('T') ; zmask(:,:,:) = tmask(:,:,:)
- CASE('U') ; zmask(2:jpim1,:,:) = tmask(2:jpim1,:,:) + tmask(3:jpi,:,:) ; CALL lbc_lnk( 'iom', zmask, 'U', 1. )
- CASE('V') ; zmask(:,2:jpjm1,:) = tmask(:,2:jpjm1,:) + tmask(:,3:jpj,:) ; CALL lbc_lnk( 'iom', zmask, 'V', 1. )
+ CASE('U') ; zmask(2:jpim1,:,:) = tmask(2:jpim1,:,:) + tmask(3:jpi,:,:)
+ CASE('V') ; zmask(:,2:jpjm1,:) = tmask(:,2:jpjm1,:) + tmask(:,3:jpj,:)
CASE('W') ; zmask(:,:,2:jpk ) = tmask(:,:,1:jpkm1) + tmask(:,:,2:jpk) ; zmask(:,:,1) = tmask(:,:,1)
END SELECT
!
- CALL iom_set_domain_attr( "grid_"//cdgrd , mask = RESHAPE(zmask(nldi:nlei,nldj:nlej,1),(/ni*nj /)) /= 0. )
- CALL iom_set_grid_attr ( "grid_"//cdgrd//"_3D", mask = RESHAPE(zmask(nldi:nlei,nldj:nlej,:),(/ni,nj,jpk/)) /= 0. )
+ CALL iom_set_domain_attr( "grid_"//cdgrd , mask = RESHAPE(zmask(Nis0:Nie0,Njs0:Nje0,1),(/Ni_0*Nj_0 /)) /= 0. )
+ CALL iom_set_grid_attr ( "grid_"//cdgrd//"_3D", mask = RESHAPE(zmask(Nis0:Nie0,Njs0:Nje0,:),(/Ni_0,Nj_0,jpk/)) /= 0. )
ENDIF
!
END SUBROUTINE set_grid
-
SUBROUTINE set_grid_bounds( cdgrd, plon_cnr, plat_cnr, plon_pnt, plat_pnt )
@@ -1998,7 +2225,9 @@
REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: plon_pnt, plat_pnt ! Lat/lon coord. of the point of cell (i,j)
!
- INTEGER :: ji, jj, jn, ni, nj
+ INTEGER :: ji, jj, jn
INTEGER :: icnr, jcnr ! Offset such that the vertex coordinate (i+icnr,j+jcnr)
- ! ! represents the bottom-left corner of cell (i,j)
+ ! ! represents the
+ ! bottom-left corner of
+ ! cell (i,j)
REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: z_bnds ! Lat/lon coordinates of the vertices of cell (i,j)
REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_fld ! Working array to determine where to rotate cells
@@ -2015,81 +2244,34 @@
END SELECT
!
- ni = nlei-nldi+1 ! Dimensions of subdomain interior
- nj = nlej-nldj+1
- !
z_fld(:,:) = 1._wp
- CALL lbc_lnk( 'iom', z_fld, cdgrd, -1. ) ! Working array for location of northfold
+ CALL lbc_lnk( 'iom', z_fld, cdgrd, -1.0_wp ) ! Working array for location of northfold
!
! Cell vertices that can be defined
- DO jj = 2, jpjm1
- DO ji = 2, jpim1
- z_bnds(1,ji,jj,1) = plat_cnr(ji+icnr, jj+jcnr ) ! Bottom-left
- z_bnds(2,ji,jj,1) = plat_cnr(ji+icnr+1,jj+jcnr ) ! Bottom-right
- z_bnds(3,ji,jj,1) = plat_cnr(ji+icnr+1,jj+jcnr+1) ! Top-right
- z_bnds(4,ji,jj,1) = plat_cnr(ji+icnr, jj+jcnr+1) ! Top-left
- z_bnds(1,ji,jj,2) = plon_cnr(ji+icnr, jj+jcnr ) ! Bottom-left
- z_bnds(2,ji,jj,2) = plon_cnr(ji+icnr+1,jj+jcnr ) ! Bottom-right
- z_bnds(3,ji,jj,2) = plon_cnr(ji+icnr+1,jj+jcnr+1) ! Top-right
- z_bnds(4,ji,jj,2) = plon_cnr(ji+icnr, jj+jcnr+1) ! Top-left
- END DO
- END DO
- !
- ! Cell vertices on boundries
- DO jn = 1, 4
- CALL lbc_lnk( 'iom', z_bnds(jn,:,:,1), cdgrd, 1., pfillval=999._wp )
- CALL lbc_lnk( 'iom', z_bnds(jn,:,:,2), cdgrd, 1., pfillval=999._wp )
- END DO
- !
- ! Zero-size cells at closed boundaries if cell points provided,
- ! otherwise they are closed cells with unrealistic bounds
- IF( PRESENT(plon_pnt) .AND. PRESENT(plat_pnt) ) THEN
- IF( (nbondi == -1 .OR. nbondi == 2) .AND. .NOT. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6) ) THEN
- DO jn = 1, 4 ! (West or jpni = 1), closed E-W
- z_bnds(jn,1,:,1) = plat_pnt(1,:) ; z_bnds(jn,1,:,2) = plon_pnt(1,:)
- END DO
- ENDIF
- IF( (nbondi == 1 .OR. nbondi == 2) .AND. .NOT. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6) ) THEN
- DO jn = 1, 4 ! (East or jpni = 1), closed E-W
- z_bnds(jn,nlci,:,1) = plat_pnt(nlci,:) ; z_bnds(jn,nlci,:,2) = plon_pnt(nlci,:)
- END DO
- ENDIF
- IF( nbondj == -1 .OR. (nbondj == 2 .AND. jperio /= 2) ) THEN
- DO jn = 1, 4 ! South or (jpnj = 1, not symmetric)
- z_bnds(jn,:,1,1) = plat_pnt(:,1) ; z_bnds(jn,:,1,2) = plon_pnt(:,1)
- END DO
- ENDIF
- IF( (nbondj == 1 .OR. nbondj == 2) .AND. jperio < 3 ) THEN
- DO jn = 1, 4 ! (North or jpnj = 1), no north fold
- z_bnds(jn,:,nlcj,1) = plat_pnt(:,nlcj) ; z_bnds(jn,:,nlcj,2) = plon_pnt(:,nlcj)
- END DO
- ENDIF
- ENDIF
- !
- IF( (nbondj == 1 .OR. nbondj == 2) .AND. jperio >= 3 ) THEN ! Rotate cells at the north fold
- DO jj = 1, jpj
- DO ji = 1, jpi
- IF( z_fld(ji,jj) == -1. ) THEN
- z_rot(1,:) = z_bnds(3,ji,jj,:) ; z_rot(2,:) = z_bnds(4,ji,jj,:)
- z_rot(3,:) = z_bnds(1,ji,jj,:) ; z_rot(4,:) = z_bnds(2,ji,jj,:)
- z_bnds(:,ji,jj,:) = z_rot(:,:)
- ENDIF
- END DO
- END DO
- ELSE IF( nbondj == 2 .AND. jperio == 2 ) THEN ! Invert cells at the symmetric equator
- DO ji = 1, jpi
- z_rot(1:2,:) = z_bnds(3:4,ji,1,:)
- z_rot(3:4,:) = z_bnds(1:2,ji,1,:)
- z_bnds(:,ji,1,:) = z_rot(:,:)
- END DO
- ENDIF
- !
- CALL iom_set_domain_attr("grid_"//cdgrd, bounds_lat = RESHAPE(z_bnds(:,nldi:nlei,nldj:nlej,1),(/ 4,ni*nj /)), &
- & bounds_lon = RESHAPE(z_bnds(:,nldi:nlei,nldj:nlej,2),(/ 4,ni*nj /)), nvertex=4 )
- !
- DEALLOCATE( z_bnds, z_fld, z_rot )
+ DO_2D( 0, 0, 0, 0 )
+ z_bnds(1,ji,jj,1) = plat_cnr(ji+icnr, jj+jcnr ) ! Bottom-left
+ z_bnds(2,ji,jj,1) = plat_cnr(ji+icnr+1,jj+jcnr ) ! Bottom-right
+ z_bnds(3,ji,jj,1) = plat_cnr(ji+icnr+1,jj+jcnr+1) ! Top-right
+ z_bnds(4,ji,jj,1) = plat_cnr(ji+icnr, jj+jcnr+1) ! Top-left
+ z_bnds(1,ji,jj,2) = plon_cnr(ji+icnr, jj+jcnr ) ! Bottom-left
+ z_bnds(2,ji,jj,2) = plon_cnr(ji+icnr+1,jj+jcnr ) ! Bottom-right
+ z_bnds(3,ji,jj,2) = plon_cnr(ji+icnr+1,jj+jcnr+1) ! Top-right
+ z_bnds(4,ji,jj,2) = plon_cnr(ji+icnr, jj+jcnr+1) ! Top-left
+ END_2D
+ !
+ DO_2D( 0, 0, 0, 0 )
+ IF( z_fld(ji,jj) == -1. ) THEN
+ z_rot(1,:) = z_bnds(3,ji,jj,:) ; z_rot(2,:) = z_bnds(4,ji,jj,:)
+ z_rot(3,:) = z_bnds(1,ji,jj,:) ; z_rot(4,:) = z_bnds(2,ji,jj,:)
+ z_bnds(:,ji,jj,:) = z_rot(:,:)
+ ENDIF
+ END_2D
+ !
+ CALL iom_set_domain_attr("grid_"//cdgrd, bounds_lat = real(RESHAPE(z_bnds(:,Nis0:Nie0,Njs0:Nje0,1),(/ 4,Ni_0*Nj_0 /)), dp), &
+ & bounds_lon = real(RESHAPE(z_bnds(:,Nis0:Nie0,Njs0:Nje0,2),(/ 4,Ni_0*Nj_0 /)), dp), nvertex=4 )
+ !
+ DEALLOCATE( z_bnds, z_fld, z_rot )
!
END SUBROUTINE set_grid_bounds
-
SUBROUTINE set_grid_znl( plat )
!!----------------------------------------------------------------------
@@ -2101,19 +2283,17 @@
REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: plat
!
- INTEGER :: ni, nj, ix, iy
+ INTEGER :: ix, iy
REAL(wp), DIMENSION(:), ALLOCATABLE :: zlon
!!----------------------------------------------------------------------
!
- ni=nlei-nldi+1 ! define zonal mean domain (jpj*jpk)
- nj=nlej-nldj+1
- ALLOCATE( zlon(ni*nj) ) ; zlon(:) = 0._wp
- !
-! CALL dom_ngb( -168.53, 65.03, ix, iy, 'T' ) ! i-line that passes through Bering Strait: Reference latitude (used in plots)
- CALL dom_ngb( 180., 90., ix, iy, 'T' ) ! i-line that passes near the North Pole : Reference latitude (used in plots)
- CALL iom_set_domain_attr("gznl", ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-2, jbegin=njmpp+nldj-2, ni=ni, nj=nj)
- CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj)
- CALL iom_set_domain_attr("gznl", lonvalue = zlon, &
- & latvalue = RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /)))
- CALL iom_set_zoom_domain_attr("ptr", ibegin=ix-1, jbegin=0, ni=1, nj=jpjglo)
+ ALLOCATE( zlon(Ni_0*Nj_0) ) ; zlon(:) = 0._wp
+ !
+! 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 = 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=Nj_0)
!
CALL iom_update_file_name('ptr')
@@ -2129,5 +2309,5 @@
!!
!!----------------------------------------------------------------------
- REAL(wp), DIMENSION(1) :: zz = 1.
+ REAL(dp), DIMENSION(1) :: zz = 1.
!!----------------------------------------------------------------------
!
@@ -2191,6 +2371,6 @@
cl1 = clgrd(jg)
! Equatorial section (attributs: jbegin, ni, name_suffix)
- CALL dom_ngb( 0., 0., ix, iy, cl1 )
- CALL iom_set_zoom_domain_attr('Eq'//cl1, ibegin=0, jbegin=iy-1, ni=jpiglo, nj=1 )
+ CALL dom_ngb( 0.0_wp, 0.0_wp, ix, iy, cl1 )
+ CALL iom_set_zoom_domain_attr('Eq'//cl1, ibegin=0, jbegin=iy-1, ni=Ni0glo, nj=1 )
CALL iom_get_file_attr ('Eq'//cl1, name_suffix = clsuff )
CALL iom_set_file_attr ('Eq'//cl1, name_suffix = TRIM(clsuff)//'_Eq')
@@ -2417,5 +2597,5 @@
!
IF ( ll24 .AND. isec == 0 ) THEN ! 00:00 of the next day -> move to 24:00 of the current day
- CALL ju2ymds( pjday - 1., iyear, imonth, iday, zsec )
+ CALL ju2ymds( pjday - 1.0_wp, iyear, imonth, iday, zsec )
isec = 86400
ENDIF
@@ -2475,7 +2655,9 @@
CHARACTER(LEN=*), INTENT(in ) :: cdname
REAL(wp) , INTENT(out) :: pmiss_val
+ REAL(dp) :: ztmp_pmiss_val
#if defined key_iomput
! get missing value
- CALL xios_get_field_attr( cdname, default_value = pmiss_val )
+ CALL xios_get_field_attr( cdname, default_value = ztmp_pmiss_val )
+ pmiss_val = ztmp_pmiss_val
#else
IF( .FALSE. ) WRITE(numout,*) cdname, pmiss_val ! useless test to avoid compilation warnings
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/IOM/iom_def.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/IOM/iom_def.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/IOM/iom_def.F90 (revision 13540)
@@ -13,14 +13,9 @@
PRIVATE
- INTEGER, PARAMETER, PUBLIC :: jpdom_data = 1 !: ( 1 :jpiglo, 1 :jpjglo) !!gm to be suppressed
- INTEGER, PARAMETER, PUBLIC :: jpdom_global = 2 !: ( 1 :jpiglo, 1 :jpjglo)
- INTEGER, PARAMETER, PUBLIC :: jpdom_local = 3 !: One of the 3 following cases
- INTEGER, PARAMETER, PUBLIC :: jpdom_local_full = 4 !: ( 1 :jpi , 1 :jpi )
- INTEGER, PARAMETER, PUBLIC :: jpdom_local_noextra = 5 !: ( 1 :nlci , 1 :nlcj )
- INTEGER, PARAMETER, PUBLIC :: jpdom_local_noovlap = 6 !: (nldi:nlei ,nldj:nlej )
- INTEGER, PARAMETER, PUBLIC :: jpdom_unknown = 7 !: No dimension checking
- INTEGER, PARAMETER, PUBLIC :: jpdom_autoglo = 8 !:
- INTEGER, PARAMETER, PUBLIC :: jpdom_autoglo_xy = 9 !: Automatically set horizontal dimensions only
- INTEGER, PARAMETER, PUBLIC :: jpdom_autodta = 10 !:
+ INTEGER, PARAMETER, PUBLIC :: jpdom_global = 1 !: ( 1 :Ni0glo, 1 :Nj0glo)
+ INTEGER, PARAMETER, PUBLIC :: jpdom_local = 2 !: (Nis0: Nie0 ,Njs0: Nje0 )
+ INTEGER, PARAMETER, PUBLIC :: jpdom_unknown = 3 !: No dimension checking
+ INTEGER, PARAMETER, PUBLIC :: jpdom_auto = 4 !:
+ INTEGER, PARAMETER, PUBLIC :: jpdom_auto_xy = 5 !: Automatically set horizontal dimensions only
INTEGER, PARAMETER, PUBLIC :: jp_r8 = 200 !: write REAL(8)
@@ -33,6 +28,5 @@
INTEGER, PARAMETER, PUBLIC :: jpmax_vars = 1200 !: maximum number of variables in one file
INTEGER, PARAMETER, PUBLIC :: jpmax_dims = 4 !: maximum number of dimensions for one variable
- INTEGER, PARAMETER, PUBLIC :: jpmax_digits = 5 !: maximum number of digits for the cpu number in the file name
-
+ INTEGER, PARAMETER, PUBLIC :: jpmax_digits = 9 !: maximum number of digits for the cpu number in the file name
!$AGRIF_DO_NOT_TREAT
@@ -46,8 +40,7 @@
LOGICAL, PUBLIC :: lxios_set = .FALSE.
-
-
TYPE, PUBLIC :: file_descriptor
CHARACTER(LEN=240) :: name !: name of the file
+ CHARACTER(LEN=3 ) :: comp !: name of component opening the file ('OCE', 'ICE'...)
INTEGER :: nfid !: identifier of the file (0 if closed)
!: jpioipsl option has been removed)
@@ -64,5 +57,4 @@
REAL(kind=wp), DIMENSION(jpmax_vars) :: scf !: scale_factor of the variables
REAL(kind=wp), DIMENSION(jpmax_vars) :: ofs !: add_offset of the variables
- INTEGER :: nlev ! number of vertical levels
END TYPE file_descriptor
TYPE(file_descriptor), DIMENSION(jpmax_files), PUBLIC :: iom_file !: array containing the info for all opened files
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/IOM/iom_nf90.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/IOM/iom_nf90.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/IOM/iom_nf90.F90 (revision 13540)
@@ -19,5 +19,5 @@
!!----------------------------------------------------------------------
USE dom_oce ! ocean space and time domain
- USE sbc_oce, ONLY: jpka, ght_abl ! abl vertical level number and height
+ USE sbc_oce, ONLY: ght_abl ! abl vertical level number and height
USE lbclnk ! lateal boundary condition / mpp exchanges
USE iom_def ! iom variables definitions
@@ -33,8 +33,9 @@
INTERFACE iom_nf90_get
- MODULE PROCEDURE iom_nf90_g0d, iom_nf90_g123d
+ MODULE PROCEDURE iom_nf90_g0d_sp
+ MODULE PROCEDURE iom_nf90_g0d_dp, iom_nf90_g123d_dp
END INTERFACE
INTERFACE iom_nf90_rstput
- MODULE PROCEDURE iom_nf90_rp0123d
+ MODULE PROCEDURE iom_nf90_rp0123d_dp
END INTERFACE
@@ -46,5 +47,5 @@
CONTAINS
- SUBROUTINE iom_nf90_open( cdname, kiomid, ldwrt, ldok, kdompar, kdlev )
+ SUBROUTINE iom_nf90_open( cdname, kiomid, ldwrt, ldok, kdlev, cdcomp )
!!---------------------------------------------------------------------
!! *** SUBROUTINE iom_open ***
@@ -56,9 +57,12 @@
LOGICAL , INTENT(in ) :: ldwrt ! read or write the file?
LOGICAL , INTENT(in ) :: ldok ! check the existence
- INTEGER, DIMENSION(2,5), INTENT(in ), OPTIONAL :: kdompar ! domain parameters:
INTEGER , INTENT(in ), OPTIONAL :: kdlev ! size of the ice/abl third dimension
+ CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cdcomp ! name of component calling iom_nf90_open
CHARACTER(LEN=256) :: clinfo ! info character
CHARACTER(LEN=256) :: cltmp ! temporary character
+ CHARACTER(LEN=12 ) :: clfmt ! writing format
+ CHARACTER(LEN=3 ) :: clcomp ! name of component calling iom_nf90_open
+ INTEGER :: idg ! number of digits
INTEGER :: iln ! lengths of character
INTEGER :: istop ! temporary storage of nstop
@@ -70,5 +74,4 @@
INTEGER :: ihdf5 ! local variable for retrieval of value for NF90_HDF5
LOGICAL :: llclobber ! local definition of ln_clobber
- INTEGER :: ilevels ! vertical levels
!---------------------------------------------------------------------
!
@@ -77,6 +80,9 @@
!
! !number of vertical levels
- IF( PRESENT(kdlev) ) THEN ; ilevels = kdlev ! use input value (useful for sea-ice and abl)
- ELSE ; ilevels = jpk ! by default jpk
+ IF( PRESENT(cdcomp) ) THEN
+ IF( .NOT. PRESENT(kdlev) ) CALL ctl_stop( 'iom_nf90_open: cdcomp and kdlev must both be present' )
+ clcomp = cdcomp ! use input value
+ ELSE
+ clcomp = 'OCE' ! by default
ENDIF
!
@@ -105,5 +111,7 @@
IF( ldwrt ) THEN !* the file should be open in write mode so we create it...
IF( jpnij > 1 ) THEN
- WRITE(cltmp,'(a,a,i4.4,a)') cdname(1:iln-1), '_', narea-1, '.nc'
+ idg = MAX( INT(LOG10(REAL(MAX(1,jpnij-1),wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9
+ WRITE(clfmt, "('(a,a,i', i1, '.', i1, ',a)')") idg, idg ! '(a,a,ix.x,a)'
+ WRITE(cltmp,clfmt) cdname(1:iln-1), '_', narea-1, '.nc'
cdname = TRIM(cltmp)
ENDIF
@@ -125,30 +133,25 @@
CALL iom_nf90_check(NF90_SET_FILL( if90id, NF90_NOFILL, idmy ), clinfo)
! define dimensions
- CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'x', kdompar(1,1), idmy ), clinfo)
- CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'y', kdompar(2,1), idmy ), clinfo)
- IF( PRESENT(kdlev) ) THEN
- IF( kdlev == jpka ) THEN
- CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'nav_lev', kdlev, idmy ), clinfo)
- CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'time_counter', NF90_UNLIMITED, idmy ), clinfo)
- ELSE
- CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'nav_lev', jpk, idmy ), clinfo)
- CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'time_counter', NF90_UNLIMITED, idmy ), clinfo)
- CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'numcat', kdlev, idmy ), clinfo)
- ENDIF
- ELSE
- CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'nav_lev', jpk, idmy ), clinfo)
- CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'time_counter', NF90_UNLIMITED, idmy ), clinfo)
- ENDIF
+ CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'x', Ni_0, idmy ), clinfo)
+ CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'y', Nj_0, idmy ), clinfo)
+ SELECT CASE (clcomp)
+ CASE ('OCE') ; CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'nav_lev', jpk, idmy ), clinfo)
+ CASE ('ICE') ; CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'numcat', kdlev, idmy ), clinfo)
+ CASE ('ABL') ; CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'nav_lev', kdlev, idmy ), clinfo)
+ CASE ('SED') ; CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'numsed', kdlev, idmy ), clinfo)
+ CASE DEFAULT ; CALL ctl_stop( 'iom_nf90_open unknown component type' )
+ 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' , (/jpiglo, jpjglo/) ), clinfo)
- CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_size_local' , kdompar(:,1) ), clinfo)
- CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_position_first' , kdompar(:,2) ), clinfo)
- CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_position_last' , kdompar(:,3) ), clinfo)
- CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_halo_size_start', kdompar(:,4) ), clinfo)
- CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_halo_size_end' , kdompar(:,5) ), 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' , (/ 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)
ELSE !* the file should be open for read mode so it must exist...
CALL ctl_stop( TRIM(clinfo), ' should be impossible case...' )
@@ -165,8 +168,8 @@
ENDDO
iom_file(kiomid)%name = TRIM(cdname)
+ iom_file(kiomid)%comp = clcomp
iom_file(kiomid)%nfid = if90id
iom_file(kiomid)%nvars = 0
iom_file(kiomid)%irec = -1 ! useless for NetCDF files, used to know if the file is in define mode
- iom_file(kiomid)%nlev = ilevels
CALL iom_nf90_check(NF90_Inquire(if90id, unlimitedDimId = iom_file(kiomid)%iduld), clinfo)
IF( iom_file(kiomid)%iduld .GE. 0 ) THEN
@@ -273,5 +276,5 @@
!!----------------------------------------------------------------------
- SUBROUTINE iom_nf90_g0d( kiomid, kvid, pvar, kstart )
+ SUBROUTINE iom_nf90_g0d_sp( kiomid, kvid, pvar, kstart )
!!-----------------------------------------------------------------------
!! *** ROUTINE iom_nf90_g0d ***
@@ -281,5 +284,5 @@
INTEGER , INTENT(in ) :: kiomid ! Identifier of the file
INTEGER , INTENT(in ) :: kvid ! variable id
- REAL(wp), INTENT( out) :: pvar ! read field
+ REAL(sp), INTENT( out) :: pvar ! read field
INTEGER , DIMENSION(1), INTENT(in ), OPTIONAL :: kstart ! start position of the reading in each axis
!
@@ -288,8 +291,24 @@
clinfo = 'iom_nf90_g0d , file: '//TRIM(iom_file(kiomid)%name)//', var: '//TRIM(iom_file(kiomid)%cn_var(kvid))
CALL iom_nf90_check(NF90_GET_VAR(iom_file(kiomid)%nfid, iom_file(kiomid)%nvid(kvid), pvar, start = kstart), clinfo )
- END SUBROUTINE iom_nf90_g0d
-
-
- SUBROUTINE iom_nf90_g123d( kiomid, kvid, knbdim, kstart, kcount, kx1, kx2, ky1, ky2, &
+ END SUBROUTINE iom_nf90_g0d_sp
+
+ SUBROUTINE iom_nf90_g0d_dp( kiomid, kvid, pvar, kstart )
+ !!-----------------------------------------------------------------------
+ !! *** ROUTINE iom_nf90_g0d ***
+ !!
+ !! ** Purpose : read a scalar with NF90
+ !!-----------------------------------------------------------------------
+ INTEGER , INTENT(in ) :: kiomid ! Identifier of the file
+ INTEGER , INTENT(in ) :: kvid ! variable id
+ REAL(dp), INTENT( out) :: pvar ! read field
+ INTEGER , DIMENSION(1), INTENT(in ), OPTIONAL :: kstart ! start position of the reading in each axis
+ !
+ CHARACTER(LEN=100) :: clinfo ! info character
+ !---------------------------------------------------------------------
+ clinfo = 'iom_nf90_g0d , file: '//TRIM(iom_file(kiomid)%name)//', var: '//TRIM(iom_file(kiomid)%cn_var(kvid))
+ CALL iom_nf90_check(NF90_GET_VAR(iom_file(kiomid)%nfid, iom_file(kiomid)%nvid(kvid), pvar, start = kstart), clinfo )
+ END SUBROUTINE iom_nf90_g0d_dp
+
+ SUBROUTINE iom_nf90_g123d_dp( kiomid, kvid, knbdim, kstart, kcount, kx1, kx2, ky1, ky2, &
& pv_r1d, pv_r2d, pv_r3d )
!!-----------------------------------------------------------------------
@@ -306,7 +325,7 @@
INTEGER , DIMENSION(:) , INTENT(in ) :: kcount ! number of points to be read in each axis
INTEGER , INTENT(in ) :: kx1, kx2, ky1, ky2 ! subdomain indexes
- REAL(wp), DIMENSION(:) , INTENT( out), OPTIONAL :: pv_r1d ! read field (1D case)
- REAL(wp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pv_r2d ! read field (2D case)
- REAL(wp), DIMENSION(:,:,:) , INTENT( out), OPTIONAL :: pv_r3d ! read field (3D case)
+ REAL(dp), DIMENSION(:) , INTENT( out), OPTIONAL :: pv_r1d ! read field (1D case)
+ REAL(dp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pv_r2d ! read field (2D case)
+ REAL(dp), DIMENSION(:,:,:) , INTENT( out), OPTIONAL :: pv_r3d ! read field (3D case)
!
CHARACTER(LEN=100) :: clinfo ! info character
@@ -329,5 +348,6 @@
ENDIF
!
- END SUBROUTINE iom_nf90_g123d
+ END SUBROUTINE iom_nf90_g123d_dp
+
@@ -503,6 +523,5 @@
END SUBROUTINE iom_nf90_putatt
-
- SUBROUTINE iom_nf90_rp0123d( kt, kwrite, kiomid, cdvar , kvid , ktype, &
+ SUBROUTINE iom_nf90_rp0123d_dp( kt, kwrite, kiomid, cdvar , kvid , ktype, &
& pv_r0d, pv_r1d, pv_r2d, pv_r3d )
!!--------------------------------------------------------------------
@@ -517,8 +536,8 @@
INTEGER , INTENT(in) :: kvid ! variable id
INTEGER , INTENT(in), OPTIONAL :: ktype ! variable type (default R8)
- REAL(wp) , INTENT(in), OPTIONAL :: pv_r0d ! written Od field
- REAL(wp), DIMENSION( :), INTENT(in), OPTIONAL :: pv_r1d ! written 1d field
- REAL(wp), DIMENSION(:, : ), INTENT(in), OPTIONAL :: pv_r2d ! written 2d field
- REAL(wp), DIMENSION(:, :, :), INTENT(in), OPTIONAL :: pv_r3d ! written 3d field
+ REAL(dp) , INTENT(in), OPTIONAL :: pv_r0d ! written Od field
+ REAL(dp), DIMENSION( :), INTENT(in), OPTIONAL :: pv_r1d ! written 1d field
+ REAL(dp), DIMENSION(:, : ), INTENT(in), OPTIONAL :: pv_r2d ! written 2d field
+ REAL(dp), DIMENSION(:, :, :), INTENT(in), OPTIONAL :: pv_r3d ! written 3d field
!
INTEGER :: idims ! number of dimension
@@ -529,7 +548,5 @@
INTEGER, DIMENSION(4) :: idimid ! dimensions id
CHARACTER(LEN=256) :: clinfo ! info character
- CHARACTER(LEN= 12), DIMENSION(5) :: cltmp ! temporary character
INTEGER :: if90id ! nf90 file identifier
- INTEGER :: idmy ! dummy variable
INTEGER :: itype ! variable type
INTEGER, DIMENSION(4) :: ichunksz ! NetCDF4 chunk sizes. Will be computed using
@@ -540,5 +557,4 @@
! ! when appropriate (currently chunking is applied to 4d fields only)
INTEGER :: idlv ! local variable
- INTEGER :: idim3 ! id of the third dimension
!---------------------------------------------------------------------
!
@@ -554,24 +570,20 @@
ENDIF
! define the dimension variables if it is not already done
- ! Warning: we must use the same character length in an array constructor (at least for gcc compiler)
- cltmp = (/ 'nav_lon ', 'nav_lat ', 'nav_lev ', 'time_counter', 'numcat ' /)
- CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cltmp(1)), NF90_FLOAT , (/ 1, 2 /), iom_file(kiomid)%nvid(1) ), clinfo)
- CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cltmp(2)), NF90_FLOAT , (/ 1, 2 /), iom_file(kiomid)%nvid(2) ), clinfo)
- CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cltmp(3)), NF90_FLOAT , (/ 3 /), iom_file(kiomid)%nvid(3) ), clinfo)
- CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cltmp(4)), NF90_DOUBLE, (/ 4 /), iom_file(kiomid)%nvid(4) ), clinfo)
+ DO jd = 1, 2
+ CALL iom_nf90_check(NF90_INQUIRE_DIMENSION(if90id,jd,iom_file(kiomid)%cn_var(jd),iom_file(kiomid)%dimsz(jd,jd)),clinfo)
+ CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(iom_file(kiomid)%cn_var(jd)), NF90_FLOAT , (/ 1, 2 /), &
+ & iom_file(kiomid)%nvid(jd) ), clinfo)
+ END DO
+ iom_file(kiomid)%dimsz(2,1) = iom_file(kiomid)%dimsz(2,2) ! second dim of first variable
+ iom_file(kiomid)%dimsz(1,2) = iom_file(kiomid)%dimsz(1,1) ! first dim of second variable
+ DO jd = 3, 4
+ CALL iom_nf90_check(NF90_INQUIRE_DIMENSION(if90id,jd,iom_file(kiomid)%cn_var(jd),iom_file(kiomid)%dimsz(1,jd)), clinfo)
+ CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(iom_file(kiomid)%cn_var(jd)), NF90_FLOAT , (/ jd /), &
+ & iom_file(kiomid)%nvid(jd) ), clinfo)
+ END DO
! update informations structure related the dimension variable we just added...
iom_file(kiomid)%nvars = 4
iom_file(kiomid)%luld(1:4) = (/ .FALSE., .FALSE., .FALSE., .TRUE. /)
- iom_file(kiomid)%cn_var(1:4) = cltmp(1:4)
iom_file(kiomid)%ndims(1:4) = (/ 2, 2, 1, 1 /)
- IF( NF90_INQ_DIMID( if90id, 'numcat', idmy ) == nf90_noerr ) THEN ! add a 5th variable corresponding to the 5th dimension
- CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cltmp(5)), NF90_FLOAT , (/ 5 /), iom_file(kiomid)%nvid(5) ), clinfo)
- iom_file(kiomid)%nvars = 5
- iom_file(kiomid)%luld(5) = .FALSE.
- iom_file(kiomid)%cn_var(5) = cltmp(5)
- iom_file(kiomid)%ndims(5) = 1
- ENDIF
- ! trick: defined to 0 to say that dimension variables are defined but not yet written
- iom_file(kiomid)%dimsz(1, 1) = 0
IF(lwp) WRITE(numout,*) TRIM(clinfo)//' define dimension variables done'
ENDIF
@@ -594,14 +606,8 @@
IF( PRESENT(pv_r0d) ) THEN ; idims = 0
ELSEIF( PRESENT(pv_r1d) ) THEN
- IF(( SIZE(pv_r1d,1) == jpk ).OR.( SIZE(pv_r1d,1) == jpka )) THEN ; idim3 = 3
- ELSE ; idim3 = 5
- ENDIF
- idims = 2 ; idimid(1:idims) = (/idim3,4/)
- ELSEIF( PRESENT(pv_r2d) ) THEN ; idims = 3 ; idimid(1:idims) = (/1,2 ,4/)
+ idims = 2 ; idimid(1:idims) = (/3,4/)
+ ELSEIF( PRESENT(pv_r2d) ) THEN ; idims = 3 ; idimid(1:idims) = (/1,2,4/)
ELSEIF( PRESENT(pv_r3d) ) THEN
- IF(( SIZE(pv_r3d,3) == jpk ).OR.( SIZE(pv_r3d,3) == jpka )) THEN ; idim3 = 3
- ELSE ; idim3 = 5
- ENDIF
- idims = 4 ; idimid(1:idims) = (/1,2,idim3,4/)
+ idims = 4 ; idimid(1:idims) = (/1,2,3,4/)
ENDIF
IF( PRESENT(ktype) ) THEN ! variable external type
@@ -665,9 +671,9 @@
IF( PRESENT(pv_r2d) .OR. PRESENT(pv_r3d) ) THEN
idimsz(1:2) = iom_file(kiomid)%dimsz(1:2,idvar)
- IF( idimsz(1) == (nlei - nldi + 1) .AND. idimsz(2) == (nlej - nldj + 1) ) THEN
- ix1 = nldi ; ix2 = nlei ; iy1 = nldj ; iy2 = nlej
- ELSEIF( idimsz(1) == nlci .AND. idimsz(2) == nlcj ) THEN
- ix1 = 1 ; ix2 = nlci ; iy1 = 1 ; iy2 = nlcj
- ELSEIF( idimsz(1) == jpi .AND. idimsz(2) == jpj ) THEN
+ 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
@@ -678,25 +684,19 @@
! =============
! trick: is defined to 0 => dimension variable are defined but not yet written
- IF( iom_file(kiomid)%dimsz(1, 1) == 0 ) THEN
- CALL iom_nf90_check( NF90_INQ_VARID( if90id, 'nav_lon' , idmy ) , clinfo )
- CALL iom_nf90_check( NF90_PUT_VAR ( if90id, idmy, glamt(ix1:ix2, iy1:iy2) ), clinfo )
- CALL iom_nf90_check( NF90_INQ_VARID( if90id, 'nav_lat' , idmy ) , clinfo )
- CALL iom_nf90_check( NF90_PUT_VAR ( if90id, idmy, gphit(ix1:ix2, iy1:iy2) ), clinfo )
- CALL iom_nf90_check( NF90_INQ_VARID( if90id, 'nav_lev' , idmy ), clinfo )
- IF (iom_file(kiomid)%nlev == jpka) THEN ; CALL iom_nf90_check( NF90_PUT_VAR ( if90id, idmy, ght_abl), clinfo )
- ELSE ; CALL iom_nf90_check( NF90_PUT_VAR ( if90id, idmy, gdept_1d), clinfo )
- ENDIF
- IF( NF90_INQ_VARID( if90id, 'numcat', idmy ) == nf90_noerr ) THEN
- CALL iom_nf90_check( NF90_PUT_VAR ( if90id, idmy, (/ (idlv, idlv = 1,iom_file(kiomid)%nlev) /)), clinfo )
- ENDIF
- ! +++ WRONG VALUE: to be improved but not really useful...
- CALL iom_nf90_check( NF90_INQ_VARID( if90id, 'time_counter', idmy ), clinfo )
- CALL iom_nf90_check( NF90_PUT_VAR( if90id, idmy, kt ), clinfo )
- ! update the values of the variables dimensions size
- CALL iom_nf90_check( NF90_INQUIRE_DIMENSION( if90id, 1, len = iom_file(kiomid)%dimsz(1,1) ), clinfo )
- CALL iom_nf90_check( NF90_INQUIRE_DIMENSION( if90id, 2, len = iom_file(kiomid)%dimsz(2,1) ), clinfo )
- iom_file(kiomid)%dimsz(1:2, 2) = iom_file(kiomid)%dimsz(1:2, 1)
- CALL iom_nf90_check( NF90_INQUIRE_DIMENSION( if90id, 3, len = iom_file(kiomid)%dimsz(1,3) ), clinfo )
- iom_file(kiomid)%dimsz(1 , 4) = 1 ! unlimited dimension
+ 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 )
+ SELECT CASE (iom_file(kiomid)%comp)
+ CASE ('OCE')
+ CALL iom_nf90_check( NF90_PUT_VAR( if90id, 3, gdept_1d ), clinfo )
+ CASE ('ABL')
+ CALL iom_nf90_check( NF90_PUT_VAR( if90id, 3, ght_abl ), clinfo )
+ CASE DEFAULT
+ CALL iom_nf90_check( NF90_PUT_VAR( if90id, 3, (/ (idlv, idlv = 1,iom_file(kiomid)%dimsz(1,3)) /) ), clinfo )
+ END SELECT
+ ! "wrong" value: to be improved but not really useful...
+ CALL iom_nf90_check( NF90_PUT_VAR( if90id, 4, kt ), clinfo )
+ ! update the size of the variable corresponding to the unlimited dimension
+ 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
@@ -720,5 +720,5 @@
ENDIF
!
- END SUBROUTINE iom_nf90_rp0123d
+ END SUBROUTINE iom_nf90_rp0123d_dp
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/IOM/prtctl.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/IOM/prtctl.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/IOM/prtctl.F90 (revision 13540)
@@ -8,29 +8,21 @@
!!----------------------------------------------------------------------
USE dom_oce ! ocean space and time domain variables
-#if defined key_nemocice_decomp
- USE ice_domain_size, only: nx_global, ny_global
-#endif
USE in_out_manager ! I/O manager
+ USE mppini ! distributed memory computing
USE lib_mpp ! distributed memory computing
IMPLICIT NONE
PRIVATE
-
- INTEGER , DIMENSION(:), ALLOCATABLE, SAVE :: numid
- INTEGER , DIMENSION(:), ALLOCATABLE, SAVE :: nlditl , nldjtl ! first, last indoor index for each i-domain
- INTEGER , DIMENSION(:), ALLOCATABLE, SAVE :: nleitl , nlejtl ! first, last indoor index for each j-domain
- INTEGER , DIMENSION(:), ALLOCATABLE, SAVE :: nimpptl, njmpptl ! i-, j-indexes for each processor
- INTEGER , DIMENSION(:), ALLOCATABLE, SAVE :: nlcitl , nlcjtl ! dimensions of every subdomain
- INTEGER , DIMENSION(:), ALLOCATABLE, SAVE :: ibonitl, ibonjtl !
-
- REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: t_ctll , s_ctll ! previous tracer trend values
- REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: u_ctll , v_ctll ! previous velocity trend values
-
- INTEGER :: ktime ! time step
-
+
+ INTEGER , DIMENSION( :), ALLOCATABLE :: numprt_oce, numprt_top
+ INTEGER , DIMENSION( :), ALLOCATABLE :: nall_ictls, nall_ictle ! first, last indoor index for each i-domain
+ INTEGER , DIMENSION( :), ALLOCATABLE :: nall_jctls, nall_jctle ! first, last indoor index for each j-domain
+ REAL(wp), DIMENSION( :), ALLOCATABLE :: t_ctl , s_ctl ! previous tracer trend values
+ REAL(wp), DIMENSION( :), ALLOCATABLE :: u_ctl , v_ctl ! previous velocity trend values
+ REAL(wp), DIMENSION(:,:), ALLOCATABLE :: tra_ctl ! previous top trend values
+ !
PUBLIC prt_ctl ! called by all subroutines
PUBLIC prt_ctl_info ! called by all subroutines
- PUBLIC prt_ctl_init ! called by opa.F90
- PUBLIC sub_dom ! called by opa.F90
+ PUBLIC prt_ctl_init ! called by nemogcm.F90 and prt_ctl_trc_init
!!----------------------------------------------------------------------
@@ -41,6 +33,6 @@
CONTAINS
- SUBROUTINE prt_ctl (tab2d_1, tab3d_1, mask1, clinfo1, tab2d_2, tab3d_2, &
- & mask2, clinfo2, kdim, clinfo3 )
+ SUBROUTINE prt_ctl (tab2d_1, tab3d_1, tab4d_1, tab2d_2, tab3d_2, mask1, mask2, &
+ & clinfo, clinfo1, clinfo2, clinfo3, kdim )
!!----------------------------------------------------------------------
!! *** ROUTINE prt_ctl ***
@@ -68,4 +60,5 @@
!! tab2d_1 : first 2D array
!! tab3d_1 : first 3D array
+ !! tab4d_1 : first 4D array
!! mask1 : mask (3D) to apply to the tab[23]d_1 array
!! clinfo1 : information about the tab[23]d_1 array
@@ -77,508 +70,360 @@
!! clinfo3 : additional information
!!----------------------------------------------------------------------
- REAL(wp), DIMENSION(:,:) , INTENT(in), OPTIONAL :: tab2d_1
- REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: tab3d_1
- REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask1
- CHARACTER (len=*) , INTENT(in), OPTIONAL :: clinfo1
- REAL(wp), DIMENSION(:,:) , INTENT(in), OPTIONAL :: tab2d_2
- REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: tab3d_2
- REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask2
- CHARACTER (len=*) , INTENT(in), OPTIONAL :: clinfo2
- INTEGER , INTENT(in), OPTIONAL :: kdim
- CHARACTER (len=*) , INTENT(in), OPTIONAL :: clinfo3
- !
- CHARACTER (len=15) :: cl2
- INTEGER :: jn, sind, eind, kdir,j_id
+ REAL(wp), DIMENSION(:,:) , INTENT(in), OPTIONAL :: tab2d_1
+ REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: tab3d_1
+ REAL(wp), DIMENSION(:,:,:,:), INTENT(in), OPTIONAL :: tab4d_1
+ REAL(wp), DIMENSION(:,:) , INTENT(in), OPTIONAL :: tab2d_2
+ REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: tab3d_2
+ REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: mask1
+ REAL(wp), DIMENSION(:,:,:) , 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
+ INTEGER :: jn, jl, kdir
+ INTEGER :: iis, iie, jjs, jje
+ INTEGER :: itra, inum
REAL(wp) :: zsum1, zsum2, zvctl1, zvctl2
- REAL(wp), DIMENSION(jpi,jpj) :: ztab2d_1, ztab2d_2
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask1, zmask2, ztab3d_1, ztab3d_2
- !!----------------------------------------------------------------------
-
+ !!----------------------------------------------------------------------
+ !
! Arrays, scalars initialization
- kdir = jpkm1
- cl2 = ''
- zsum1 = 0.e0
- zsum2 = 0.e0
- zvctl1 = 0.e0
- zvctl2 = 0.e0
- ztab2d_1(:,:) = 0.e0
- ztab2d_2(:,:) = 0.e0
- ztab3d_1(:,:,:) = 0.e0
- ztab3d_2(:,:,:) = 0.e0
- zmask1 (:,:,:) = 1.e0
- zmask2 (:,:,:) = 1.e0
+ cl1 = ''
+ cl2 = ''
+ kdir = jpkm1
+ itra = 1
! Control of optional arguments
- IF( PRESENT(clinfo2) ) cl2 = clinfo2
- IF( PRESENT(kdim) ) kdir = kdim
- IF( PRESENT(tab2d_1) ) ztab2d_1(:,:) = tab2d_1(:,:)
- IF( PRESENT(tab2d_2) ) ztab2d_2(:,:) = tab2d_2(:,:)
- IF( PRESENT(tab3d_1) ) ztab3d_1(:,:,1:kdir) = tab3d_1(:,:,1:kdir)
- IF( PRESENT(tab3d_2) ) ztab3d_2(:,:,1:kdir) = tab3d_2(:,:,1:kdir)
- IF( PRESENT(mask1) ) zmask1 (:,:,:) = mask1 (:,:,:)
- IF( PRESENT(mask2) ) zmask2 (:,:,:) = mask2 (:,:,:)
-
- IF( lk_mpp .AND. jpnij > 1 ) THEN ! processor number
- sind = narea
- eind = narea
- ELSE ! processors total number
- sind = 1
- eind = ijsplt
- ENDIF
+ IF( PRESENT(clinfo1) ) cl1 = clinfo1
+ IF( PRESENT(clinfo2) ) cl2 = clinfo2
+ IF( PRESENT(kdim) ) kdir = kdim
+ IF( PRESENT(tab4d_1) ) itra = SIZE(tab4d_1,dim=4)
! Loop over each sub-domain, i.e. the total number of processors ijsplt
- DO jn = sind, eind
- ! Set logical unit
- j_id = numid(jn - narea + 1)
- ! Set indices for the SUM control
- IF( .NOT. lsp_area ) THEN
- IF (lk_mpp .AND. jpnij > 1) THEN
- nictls = MAX( 1, nlditl(jn) )
- nictle = MIN(jpi, nleitl(jn) )
- njctls = MAX( 1, nldjtl(jn) )
- njctle = MIN(jpj, nlejtl(jn) )
- ! Do not take into account the bound of the domain
- IF( ibonitl(jn) == -1 .OR. ibonitl(jn) == 2 ) nictls = MAX(2, nictls)
- IF( ibonjtl(jn) == -1 .OR. ibonjtl(jn) == 2 ) njctls = MAX(2, njctls)
- IF( ibonitl(jn) == 1 .OR. ibonitl(jn) == 2 ) nictle = MIN(nictle, nleitl(jn) - 1)
- IF( ibonjtl(jn) == 1 .OR. ibonjtl(jn) == 2 ) njctle = MIN(njctle, nlejtl(jn) - 1)
+ DO jl = 1, SIZE(nall_ictls)
+
+ ! define shoter names...
+ iis = nall_ictls(jl)
+ iie = nall_ictle(jl)
+ jjs = nall_jctls(jl)
+ jje = nall_jctle(jl)
+
+ IF( PRESENT(clinfo) ) THEN ; inum = numprt_top(jl)
+ ELSE ; inum = numprt_oce(jl)
+ ENDIF
+
+ DO jn = 1, itra
+
+ IF( PRESENT(clinfo3) ) THEN
+ IF ( clinfo3 == 'tra-ta' ) THEN
+ zvctl1 = t_ctl(jl)
+ ELSEIF( clinfo3 == 'tra' ) THEN
+ zvctl1 = t_ctl(jl)
+ zvctl2 = s_ctl(jl)
+ ELSEIF( clinfo3 == 'dyn' ) THEN
+ zvctl1 = u_ctl(jl)
+ zvctl2 = v_ctl(jl)
+ ELSE
+ zvctl1 = tra_ctl(jn,jl)
+ ENDIF
+ ENDIF
+
+ ! 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) )
+ 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) )
+ 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) )
+ 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) )
+ 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) )
+ ENDIF
+ ENDIF
+
+ ! Print the result
+ IF( PRESENT(clinfo ) ) cl1 = clinfo(jn)
+ IF( PRESENT(clinfo3) ) THEN
+ !
+ IF( PRESENT(tab2d_2) .OR. PRESENT(tab3d_2) ) THEN
+ WRITE(inum, "(3x,a,' : ',D23.16,3x,a,' : ',D23.16)") cl1, zsum1 - zvctl1, cl2, zsum2 - zvctl2
+ ELSE
+ WRITE(inum, "(3x,a,' : ',D23.16 )") cl1, zsum1 - zvctl1
+ ENDIF
+ !
+ SELECT CASE( clinfo3 )
+ CASE ( 'tra-ta' )
+ t_ctl(jl) = zsum1
+ CASE ( 'tra' )
+ t_ctl(jl) = zsum1
+ s_ctl(jl) = zsum2
+ CASE ( 'dyn' )
+ u_ctl(jl) = zsum1
+ v_ctl(jl) = zsum2
+ CASE default
+ tra_ctl(jn,jl) = zsum1
+ END SELECT
+ ELSEIF ( PRESENT(tab2d_2) .OR. PRESENT(tab3d_2) ) THEN
+ WRITE(inum, "(3x,a,' : ',D23.16,3x,a,' : ',D23.16)") cl1, zsum1, cl2, zsum2
ELSE
- nictls = MAX( 1, nimpptl(jn) - 1 + nlditl(jn) )
- nictle = MIN(jpi, nimpptl(jn) - 1 + nleitl(jn) )
- njctls = MAX( 1, njmpptl(jn) - 1 + nldjtl(jn) )
- njctle = MIN(jpj, njmpptl(jn) - 1 + nlejtl(jn) )
- ! Do not take into account the bound of the domain
- IF( ibonitl(jn) == -1 .OR. ibonitl(jn) == 2 ) nictls = MAX(2, nictls)
- IF( ibonjtl(jn) == -1 .OR. ibonjtl(jn) == 2 ) njctls = MAX(2, njctls)
- IF( ibonitl(jn) == 1 .OR. ibonitl(jn) == 2 ) nictle = MIN(nictle, nimpptl(jn) + nleitl(jn) - 2)
- IF( ibonjtl(jn) == 1 .OR. ibonjtl(jn) == 2 ) njctle = MIN(njctle, njmpptl(jn) + nlejtl(jn) - 2)
- ENDIF
- ENDIF
-
- IF( PRESENT(clinfo3)) THEN
- IF ( clinfo3 == 'tra' ) THEN
- zvctl1 = t_ctll(jn)
- zvctl2 = s_ctll(jn)
- ELSEIF ( clinfo3 == 'dyn' ) THEN
- zvctl1 = u_ctll(jn)
- zvctl2 = v_ctll(jn)
- ENDIF
- ENDIF
-
- ! Compute the sum control
- ! 2D arrays
- IF( PRESENT(tab2d_1) ) THEN
- zsum1 = SUM( ztab2d_1(nictls:nictle,njctls:njctle)*zmask1(nictls:nictle,njctls:njctle,1) )
- zsum2 = SUM( ztab2d_2(nictls:nictle,njctls:njctle)*zmask2(nictls:nictle,njctls:njctle,1) )
- ENDIF
-
- ! 3D arrays
- IF( PRESENT(tab3d_1) ) THEN
- zsum1 = SUM( ztab3d_1(nictls:nictle,njctls:njctle,1:kdir)*zmask1(nictls:nictle,njctls:njctle,1:kdir) )
- zsum2 = SUM( ztab3d_2(nictls:nictle,njctls:njctle,1:kdir)*zmask2(nictls:nictle,njctls:njctle,1:kdir) )
- ENDIF
-
- ! Print the result
- IF( PRESENT(clinfo3) ) THEN
- WRITE(j_id,FMT='(a,D23.16,3x,a,D23.16)')clinfo1, zsum1-zvctl1, cl2, zsum2-zvctl2
- SELECT CASE( clinfo3 )
- CASE ( 'tra-ta' )
- t_ctll(jn) = zsum1
- CASE ( 'tra' )
- t_ctll(jn) = zsum1
- s_ctll(jn) = zsum2
- CASE ( 'dyn' )
- u_ctll(jn) = zsum1
- v_ctll(jn) = zsum2
- END SELECT
- ELSEIF ( PRESENT(clinfo2) .OR. PRESENT(tab2d_2) .OR. PRESENT(tab3d_2) ) THEN
- WRITE(j_id,FMT='(a,D23.16,3x,a,D23.16)')clinfo1, zsum1, cl2, zsum2
- ELSE
- WRITE(j_id,FMT='(a,D23.16)')clinfo1, zsum1
- ENDIF
-
- ENDDO
- !
- END SUBROUTINE prt_ctl
-
-
- SUBROUTINE prt_ctl_info (clinfo1, ivar1, clinfo2, ivar2, itime)
- !!----------------------------------------------------------------------
- !! *** ROUTINE prt_ctl_info ***
- !!
- !! ** Purpose : - print information without any computation
- !!
- !! ** Action : - input arguments
- !! clinfo1 : information about the ivar1
- !! ivar1 : value to print
- !! clinfo2 : information about the ivar2
- !! ivar2 : value to print
- !!----------------------------------------------------------------------
- CHARACTER (len=*), INTENT(in) :: clinfo1
- INTEGER , INTENT(in), OPTIONAL :: ivar1
- CHARACTER (len=*), INTENT(in), OPTIONAL :: clinfo2
- INTEGER , INTENT(in), OPTIONAL :: ivar2
- INTEGER , INTENT(in), OPTIONAL :: itime
- !
- INTEGER :: jn, sind, eind, iltime, j_id
- !!----------------------------------------------------------------------
-
- IF( lk_mpp .AND. jpnij > 1 ) THEN ! processor number
- sind = narea
- eind = narea
- ELSE ! total number of processors
- sind = 1
- eind = ijsplt
- ENDIF
-
- ! Set to zero arrays at each new time step
- IF( PRESENT(itime) ) THEN
- iltime = itime
- IF( iltime > ktime ) THEN
- t_ctll(:) = 0.e0 ; s_ctll(:) = 0.e0
- u_ctll(:) = 0.e0 ; v_ctll(:) = 0.e0
- ktime = iltime
- ENDIF
- ENDIF
-
- ! Loop over each sub-domain, i.e. number of processors ijsplt
- DO jn = sind, eind
- !
- j_id = numid(jn - narea + 1) ! Set logical unit
- !
- IF( PRESENT(ivar1) .AND. PRESENT(clinfo2) .AND. PRESENT(ivar2) ) THEN
- WRITE(j_id,*)clinfo1, ivar1, clinfo2, ivar2
- ELSEIF ( PRESENT(ivar1) .AND. PRESENT(clinfo2) .AND. .NOT. PRESENT(ivar2) ) THEN
- WRITE(j_id,*)clinfo1, ivar1, clinfo2
- ELSEIF ( PRESENT(ivar1) .AND. .NOT. PRESENT(clinfo2) .AND. PRESENT(ivar2) ) THEN
- WRITE(j_id,*)clinfo1, ivar1, ivar2
- ELSEIF ( PRESENT(ivar1) .AND. .NOT. PRESENT(clinfo2) .AND. .NOT. PRESENT(ivar2) ) THEN
- WRITE(j_id,*)clinfo1, ivar1
- ELSE
- WRITE(j_id,*)clinfo1
- ENDIF
- !
- END DO
- !
- END SUBROUTINE prt_ctl_info
-
-
- SUBROUTINE prt_ctl_init
- !!----------------------------------------------------------------------
- !! *** ROUTINE prt_ctl_init ***
- !!
- !! ** Purpose : open ASCII files & compute indices
- !!----------------------------------------------------------------------
- INTEGER :: jn, sind, eind, j_id
- CHARACTER (len=28) :: clfile_out
- CHARACTER (len=23) :: clb_name
- CHARACTER (len=19) :: cl_run
- !!----------------------------------------------------------------------
-
- ! Allocate arrays
- ALLOCATE( nlditl(ijsplt) , nleitl(ijsplt) , nimpptl(ijsplt) , ibonitl(ijsplt) , &
- & nldjtl(ijsplt) , nlejtl(ijsplt) , njmpptl(ijsplt) , ibonjtl(ijsplt) , &
- & nlcitl(ijsplt) , t_ctll(ijsplt) , u_ctll (ijsplt) , &
- & nlcjtl(ijsplt) , s_ctll(ijsplt) , v_ctll (ijsplt) )
-
- ! Initialization
- t_ctll(:) = 0.e0
- s_ctll(:) = 0.e0
- u_ctll(:) = 0.e0
- v_ctll(:) = 0.e0
- ktime = 1
-
- IF( lk_mpp .AND. jpnij > 1 ) THEN
- sind = narea
- eind = narea
- clb_name = "('mpp.output_',I4.4)"
- cl_run = 'MULTI processor run'
- ! use indices for each area computed by mpp_init subroutine
- nlditl(1:jpnij) = nldit(:)
- nleitl(1:jpnij) = nleit(:)
- nldjtl(1:jpnij) = nldjt(:)
- nlejtl(1:jpnij) = nlejt(:)
- !
- nimpptl(1:jpnij) = nimppt(:)
- njmpptl(1:jpnij) = njmppt(:)
- !
- nlcitl(1:jpnij) = nlcit(:)
- nlcjtl(1:jpnij) = nlcjt(:)
- !
- ibonitl(1:jpnij) = ibonit(:)
- ibonjtl(1:jpnij) = ibonjt(:)
- ELSE
- sind = 1
- eind = ijsplt
- clb_name = "('mono.output_',I4.4)"
- cl_run = 'MONO processor run '
- ! compute indices for each area as done in mpp_init subroutine
- CALL sub_dom
- ENDIF
-
- ALLOCATE( numid(eind-sind+1) )
-
- DO jn = sind, eind
- WRITE(clfile_out,FMT=clb_name) jn-1
- CALL ctl_opn( numid(jn -narea + 1), clfile_out, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', 1, numout, .FALSE. )
- j_id = numid(jn -narea + 1)
- WRITE(j_id,*)
- WRITE(j_id,*) ' L O D Y C - I P S L'
- WRITE(j_id,*) ' O P A model'
- WRITE(j_id,*) ' Ocean General Circulation Model'
- WRITE(j_id,*) ' version OPA 9.0 (2005) '
- WRITE(j_id,*)
- WRITE(j_id,*) ' PROC number: ', jn
- WRITE(j_id,*)
- WRITE(j_id,FMT="(19x,a20)")cl_run
-
- ! Print the SUM control indices
- IF( .NOT. lsp_area ) THEN
- nictls = nimpptl(jn) + nlditl(jn) - 1
- nictle = nimpptl(jn) + nleitl(jn) - 1
- njctls = njmpptl(jn) + nldjtl(jn) - 1
- njctle = njmpptl(jn) + nlejtl(jn) - 1
- ENDIF
- WRITE(j_id,*)
- WRITE(j_id,*) 'prt_ctl : Sum control indices'
- WRITE(j_id,*) '~~~~~~~'
- WRITE(j_id,*)
- WRITE(j_id,9000)' nlej = ', nlejtl(jn), ' '
- WRITE(j_id,9000)' ------------- njctle = ', njctle, ' -------------'
- WRITE(j_id,9001)' | |'
- WRITE(j_id,9001)' | |'
- WRITE(j_id,9001)' | |'
- WRITE(j_id,9002)' nictls = ', nictls, ' nictle = ', nictle
- WRITE(j_id,9002)' nldi = ', nlditl(jn), ' nlei = ', nleitl(jn)
- WRITE(j_id,9001)' | |'
- WRITE(j_id,9001)' | |'
- WRITE(j_id,9001)' | |'
- WRITE(j_id,9004)' njmpp = ',njmpptl(jn),' ------------- njctls = ', njctls, ' -------------'
- WRITE(j_id,9003)' nimpp = ', nimpptl(jn), ' nldj = ', nldjtl(jn), ' '
- WRITE(j_id,*)
- WRITE(j_id,*)
-
-9000 FORMAT(a41,i4.4,a14)
-9001 FORMAT(a59)
-9002 FORMAT(a20,i4.4,a36,i3.3)
-9003 FORMAT(a20,i4.4,a17,i4.4)
-9004 FORMAT(a11,i4.4,a26,i4.4,a14)
- END DO
- !
- END SUBROUTINE prt_ctl_init
-
-
- SUBROUTINE sub_dom
- !!----------------------------------------------------------------------
- !! *** ROUTINE sub_dom ***
- !!
- !! ** Purpose : Lay out the global domain over processors.
- !! CAUTION:
- !! This part has been extracted from the mpp_init
- !! subroutine and names of variables/arrays have been
- !! slightly changed to avoid confusion but the computation
- !! is exactly the same. Any modification about indices of
- !! each sub-domain in the mppini.F90 module should be reported
- !! here.
- !!
- !! ** Method : Global domain is distributed in smaller local domains.
- !! Periodic condition is a function of the local domain position
- !! (global boundary or neighbouring domain) and of the global
- !! periodic
- !! Type : jperio global periodic condition
- !!
- !! ** Action : - set domain parameters
- !! nimpp : longitudinal index
- !! njmpp : latitudinal index
- !! narea : number for local area
- !! nlcil : first dimension
- !! nlcjl : second dimension
- !! nbondil : mark for "east-west local boundary"
- !! nbondjl : mark for "north-south local boundary"
- !!
- !! History :
- !! ! 94-11 (M. Guyon) Original code
- !! ! 95-04 (J. Escobar, M. Imbard)
- !! ! 98-02 (M. Guyon) FETI method
- !! ! 98-05 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI versions
- !! 8.5 ! 02-08 (G. Madec) F90 : free form
- !!----------------------------------------------------------------------
- INTEGER :: ji, jj, jn ! dummy loop indices
- INTEGER :: &
- ii, ij, & ! temporary integers
- irestil, irestjl, & ! " "
- ijpi , ijpj, nlcil, & ! temporary logical unit
- nlcjl , nbondil, nbondjl, &
- nrecil, nrecjl, nldil, nleil, nldjl, nlejl
-
- INTEGER, DIMENSION(jpi,jpj) :: iimpptl, ijmpptl, ilcitl, ilcjtl ! workspace
- REAL(wp) :: zidom, zjdom ! temporary scalars
- INTEGER :: inum ! local logical unit
- !!----------------------------------------------------------------------
-
- !
- !
- ! 1. Dimension arrays for subdomains
- ! -----------------------------------
- ! Computation of local domain sizes ilcitl() ilcjtl()
- ! These dimensions depend on global sizes isplt,jsplt and jpiglo,jpjglo
- ! The subdomains are squares leeser than or equal to the global
- ! dimensions divided by the number of processors minus the overlap
- ! array (cf. par_oce.F90).
-
-#if defined key_nemocice_decomp
- ijpi = ( nx_global+2-2*nn_hls + (isplt-1) ) / isplt + 2*nn_hls
- ijpj = ( ny_global+2-2*nn_hls + (jsplt-1) ) / jsplt + 2*nn_hls
-#else
- ijpi = ( jpiglo-2*nn_hls + (isplt-1) ) / isplt + 2*nn_hls
- ijpj = ( jpjglo-2*nn_hls + (jsplt-1) ) / jsplt + 2*nn_hls
-#endif
-
-
- nrecil = 2 * nn_hls
- nrecjl = 2 * nn_hls
- irestil = MOD( jpiglo - nrecil , isplt )
- irestjl = MOD( jpjglo - nrecjl , jsplt )
-
- IF( irestil == 0 ) irestil = isplt
-#if defined key_nemocice_decomp
-
- ! In order to match CICE the size of domains in NEMO has to be changed
- ! The last line of blocks (west) will have fewer points
- DO jj = 1, jsplt
- DO ji=1, isplt-1
- ilcitl(ji,jj) = ijpi
- END DO
- ilcitl(isplt,jj) = jpiglo - (isplt - 1) * (ijpi - nrecil)
- END DO
-
-#else
-
- DO jj = 1, jsplt
- DO ji = 1, irestil
- ilcitl(ji,jj) = ijpi
- END DO
- DO ji = irestil+1, isplt
- ilcitl(ji,jj) = ijpi -1
+ WRITE(inum, "(3x,a,' : ',D23.16 )") cl1, zsum1
+ ENDIF
+
END DO
END DO
-
-#endif
-
- IF( irestjl == 0 ) irestjl = jsplt
-#if defined key_nemocice_decomp
-
- ! Same change to domains in North-South direction as in East-West.
- DO ji = 1, isplt
- DO jj=1, jsplt-1
- ilcjtl(ji,jj) = ijpj
- END DO
- ilcjtl(ji,jsplt) = jpjglo - (jsplt - 1) * (ijpj - nrecjl)
- END DO
-
-#else
-
- DO ji = 1, isplt
- DO jj = 1, irestjl
- ilcjtl(ji,jj) = ijpj
- END DO
- DO jj = irestjl+1, jsplt
- ilcjtl(ji,jj) = ijpj -1
- END DO
+ !
+ END SUBROUTINE prt_ctl
+
+
+ SUBROUTINE prt_ctl_info (clinfo, ivar, cdcomp )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE prt_ctl_info ***
+ !!
+ !! ** Purpose : - print information without any computation
+ !!
+ !! ** Action : - input arguments
+ !! clinfo : information about the ivar
+ !! ivar : value to print
+ !!----------------------------------------------------------------------
+ CHARACTER(len=*), INTENT(in) :: clinfo
+ INTEGER , OPTIONAL, INTENT(in) :: ivar
+ CHARACTER(len=3), OPTIONAL, INTENT(in) :: cdcomp ! only 'top' is accepted
+ !
+ CHARACTER(len=3) :: clcomp
+ INTEGER :: jl, inum
+ !!----------------------------------------------------------------------
+ !
+ IF( PRESENT(cdcomp) ) THEN ; clcomp = cdcomp
+ ELSE ; clcomp = 'oce'
+ ENDIF
+ !
+ DO jl = 1, SIZE(nall_ictls)
+ !
+ IF( clcomp == 'oce' ) inum = numprt_oce(jl)
+ IF( clcomp == 'top' ) inum = numprt_top(jl)
+ !
+ IF ( PRESENT(ivar) ) THEN ; WRITE(inum,*) clinfo, ivar
+ ELSE ; WRITE(inum,*) clinfo
+ ENDIF
+ !
END DO
-
-#endif
- zidom = nrecil
- DO ji = 1, isplt
- zidom = zidom + ilcitl(ji,1) - nrecil
+ !
+ END SUBROUTINE prt_ctl_info
+
+
+ SUBROUTINE prt_ctl_init( cdcomp, kntra )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE prt_ctl_init ***
+ !!
+ !! ** Purpose : open ASCII files & compute indices
+ !!----------------------------------------------------------------------
+ CHARACTER(len=3), OPTIONAL, INTENT(in ) :: cdcomp ! only 'top' is accepted
+ INTEGER , OPTIONAL, INTENT(in ) :: kntra ! only for 'top': number of tracers
+ !
+ INTEGER :: ji, jj, jl
+ INTEGER :: inum, idg, idg2
+ INTEGER :: ijsplt, iimax, ijmax
+ INTEGER, DIMENSION(:,:), ALLOCATABLE :: iimppt, ijmppt, ijpi, ijpj, iproc
+ INTEGER, DIMENSION( :), ALLOCATABLE :: iipos, ijpos
+ LOGICAL, DIMENSION(:,:), ALLOCATABLE :: llisoce
+ CHARACTER(len=64) :: clfile_out
+ CHARACTER(LEN=64) :: clfmt, clfmt2, clfmt3, clfmt4
+ CHARACTER(len=32) :: clname, cl_run
+ CHARACTER(len= 3) :: clcomp
+ !!----------------------------------------------------------------------
+ !
+ clname = 'output'
+ IF( PRESENT(cdcomp) ) THEN
+ clname = TRIM(clname)//'.'//TRIM(cdcomp)
+ clcomp = cdcomp
+ ELSE
+ clcomp = 'oce'
+ ENDIF
+ !
+ IF( jpnij > 1 ) THEN ! MULTI processor run
+ cl_run = 'MULTI processor run'
+ idg = MAX( INT(LOG10(REAL(MAX(1,jpnij-1),wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9
+ WRITE(clfmt, "('(a,i', i1, '.', i1, ')')") idg, idg ! '(a,ix.x)'
+ WRITE(clfile_out,clfmt) 'mpp.'//trim(clname)//'_', narea - 1
+ ijsplt = 1
+ ELSE ! MONO processor run
+ cl_run = 'MONO processor run '
+ IF(lwp) THEN ! control print
+ WRITE(numout,*)
+ WRITE(numout,*) 'prt_ctl_init: sn_cfctl%l_prtctl parameters'
+ WRITE(numout,*) '~~~~~~~~~~~~~'
+ ENDIF
+ IF( nn_ictls+nn_ictle+nn_jctls+nn_jctle == 0 ) THEN ! print control done over the default area
+ nn_isplt = MAX(1, nn_isplt) ! number of processors following i-direction
+ nn_jsplt = MAX(1, nn_jsplt) ! number of processors following j-direction
+ ijsplt = nn_isplt * nn_jsplt ! total number of processors ijsplt
+ IF( ijsplt == 1 ) CALL ctl_warn( 'nn_isplt & nn_jsplt are equal to 1 -> control sum done over the whole domain' )
+ IF(lwp) WRITE(numout,*) ' number of proc. following i nn_isplt = ', nn_isplt
+ IF(lwp) WRITE(numout,*) ' number of proc. following j nn_jsplt = ', nn_jsplt
+ idg = MAX( INT(LOG10(REAL(MAX(1,ijsplt-1),wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9
+ WRITE(clfmt, "('(a,i', i1, '.', i1, ')')") idg, idg ! '(a,ix.x)'
+ IF( ijsplt == 1 ) WRITE(clfile_out,clfmt) 'mono.'//trim(clname)//'_', 0
+ ELSE ! print control done over a specific area
+ ijsplt = 1
+ IF( nn_ictls < 1 .OR. nn_ictls > Ni0glo ) THEN
+ CALL ctl_warn( ' - nictls must be 1<=nictls>=Ni0glo, it is forced to 1' )
+ nn_ictls = 1
+ ENDIF
+ IF( nn_ictle < 1 .OR. nn_ictle > Ni0glo ) THEN
+ CALL ctl_warn( ' - nictle must be 1<=nictle>=Ni0glo, it is forced to Ni0glo' )
+ nn_ictle = Ni0glo
+ ENDIF
+ IF( nn_jctls < 1 .OR. nn_jctls > Nj0glo ) THEN
+ CALL ctl_warn( ' - njctls must be 1<=njctls>=Nj0glo, it is forced to 1' )
+ nn_jctls = 1
+ ENDIF
+ IF( nn_jctle < 1 .OR. nn_jctle > Nj0glo ) THEN
+ CALL ctl_warn( ' - njctle must be 1<=njctle>=Nj0glo, it is forced to Nj0glo' )
+ nn_jctle = Nj0glo
+ ENDIF
+ WRITE(numout,*) ' Start i indice for SUM control nn_ictls = ', nn_ictls
+ WRITE(numout,*) ' End i indice for SUM control nn_ictle = ', nn_ictle
+ WRITE(numout,*) ' Start j indice for SUM control nn_jctls = ', nn_jctls
+ WRITE(numout,*) ' End j indice for SUM control nn_jctle = ', nn_jctle
+ idg = MAXVAL( (/ nn_ictls,nn_ictle,nn_jctls,nn_jctle /) ) ! temporary use of idg to store the largest index
+ idg = MAX( INT(LOG10(REAL(idg,wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9
+ WRITE(clfmt, "('(4(a,i', i1, '.', i1, '))')") idg, idg ! '(4(a,ix.x))'
+ WRITE(clfile_out,clfmt) 'mono.'//trim(clname)//'_', nn_ictls, '_', nn_ictle, '_', nn_jctls, '_', nn_jctle
+ ENDIF
+ ENDIF
+
+ ! Allocate arrays
+ IF( .NOT. ALLOCATED(nall_ictls) ) ALLOCATE( nall_ictls(ijsplt), nall_ictle(ijsplt), nall_jctls(ijsplt), nall_jctle(ijsplt) )
+
+ IF( jpnij > 1 ) THEN ! MULTI processor run
+ !
+ nall_ictls(1) = Nis0
+ nall_ictle(1) = Nie0
+ nall_jctls(1) = Njs0
+ nall_jctle(1) = Nje0
+ !
+ ELSE ! MONO processor run
+ !
+ IF( nn_ictls+nn_ictle+nn_jctls+nn_jctle == 0 ) THEN ! print control done over the default area
+ !
+ ALLOCATE( iimppt(nn_isplt,nn_jsplt), ijmppt(nn_isplt,nn_jsplt), ijpi(nn_isplt,nn_jsplt), ijpj(nn_isplt,nn_jsplt), &
+ & llisoce(nn_isplt,nn_jsplt), iproc(nn_isplt,nn_jsplt), iipos(nn_isplt*nn_jsplt), ijpos(nn_isplt*nn_jsplt) )
+ CALL mpp_basesplit( jpiglo, jpjglo, nn_hls, nn_isplt, nn_jsplt, iimax, ijmax, iimppt, ijmppt, ijpi, ijpj )
+ CALL mpp_is_ocean( llisoce )
+ CALL mpp_getnum( llisoce, iproc, iipos, ijpos )
+ !
+ DO jj = 1,nn_jsplt
+ DO ji = 1, nn_isplt
+ jl = iproc(ji,jj) + 1
+ nall_ictls(jl) = iimppt(ji,jj) - 1 + 1 + nn_hls
+ nall_ictle(jl) = iimppt(ji,jj) - 1 + ijpi(ji,jj) - nn_hls
+ nall_jctls(jl) = ijmppt(ji,jj) - 1 + 1 + nn_hls
+ nall_jctle(jl) = ijmppt(ji,jj) - 1 + ijpj(ji,jj) - nn_hls
+ END DO
+ END DO
+ !
+ DEALLOCATE( iimppt, ijmppt, ijpi, ijpj, llisoce, iproc, iipos, ijpos )
+ !
+ ELSE ! print control done over a specific area
+ !
+ nall_ictls(1) = nn_ictls + nn_hls
+ nall_ictle(1) = nn_ictle + nn_hls
+ nall_jctls(1) = nn_jctls + nn_hls
+ nall_jctle(1) = nn_jctle + nn_hls
+ !
+ ENDIF
+ ENDIF
+
+ ! Initialization
+ IF( clcomp == 'oce' ) THEN
+ ALLOCATE( t_ctl(ijsplt), s_ctl(ijsplt), u_ctl(ijsplt), v_ctl(ijsplt), numprt_oce(ijsplt) )
+ t_ctl(:) = 0.e0
+ s_ctl(:) = 0.e0
+ u_ctl(:) = 0.e0
+ v_ctl(:) = 0.e0
+ ENDIF
+ IF( clcomp == 'top' ) THEN
+ ALLOCATE( tra_ctl(kntra,ijsplt), numprt_top(ijsplt) )
+ tra_ctl(:,:) = 0.e0
+ ENDIF
+
+ DO jl = 1,ijsplt
+
+ IF( ijsplt > 1 ) WRITE(clfile_out,clfmt) 'mono.'//trim(clname)//'_', jl-1
+
+ CALL ctl_opn( inum, clfile_out, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', 1, numout, .FALSE. )
+ IF( clcomp == 'oce' ) numprt_oce(jl) = inum
+ IF( clcomp == 'top' ) numprt_top(jl) = inum
+ WRITE(inum,*)
+ WRITE(inum,*) ' CNRS - NERC - Met OFFICE - MERCATOR-ocean - CMCC'
+ WRITE(inum,*) ' NEMO team'
+ WRITE(inum,*) ' Ocean General Circulation Model'
+ IF( clcomp == 'oce' ) WRITE(inum,*) ' NEMO version 4.x (2020) '
+ IF( clcomp == 'top' ) WRITE(inum,*) ' TOP vversion x (2020) '
+ WRITE(inum,*)
+ IF( ijsplt > 1 ) &
+ & WRITE(inum,*) ' MPI-subdomain number: ', jl-1
+ IF( jpnij > 1 ) &
+ & WRITE(inum,*) ' MPI-subdomain number: ', narea-1
+ WRITE(inum,*)
+ WRITE(inum,'(19x,a20)') cl_run
+ WRITE(inum,*)
+ WRITE(inum,*) 'prt_ctl : Sum control indices'
+ WRITE(inum,*) '~~~~~~~'
+ WRITE(inum,*)
+ !
+ ! clfmt2: ' ----- jctle = XXX (YYY) -----' -> '(18x, 13a1, a9, iM, a2, iN, a2, 13a1)'
+ ! clfmt3: ' | |' -> '(18x, a1, Nx, a1)'
+ ! clfmt4: ' ictls = XXX (YYY) ictle = XXX (YYY)' -> '(Nx, a9, iM, a2, iP, a2, Qx, a9, iM, a2, iP, a2)'
+ ! ' | |'
+ ! ' ----- jctle = XXX (YYY) -----'
+ ! clfmt5: ' njmpp = XXX' -> '(Nx, a9, iM)'
+ ! clfmt6: ' nimpp = XXX' -> '(Nx, a9, iM)'
+ !
+ 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 = 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,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,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,*)
+ WRITE(inum,*)
+ !
END DO
- IF(lwp) WRITE(numout,*)
- IF(lwp) WRITE(numout,*)' sum ilcitl(i,1) = ', zidom, ' jpiglo = ', jpiglo
-
- zjdom = nrecjl
- DO jj = 1, jsplt
- zjdom = zjdom + ilcjtl(1,jj) - nrecjl
- END DO
- IF(lwp) WRITE(numout,*)' sum ilcitl(1,j) = ', zjdom, ' jpjglo = ', jpjglo
- IF(lwp) WRITE(numout,*)
-
-
- ! 2. Index arrays for subdomains
- ! -------------------------------
-
- iimpptl(:,:) = 1
- ijmpptl(:,:) = 1
-
- IF( isplt > 1 ) THEN
- DO jj = 1, jsplt
- DO ji = 2, isplt
- iimpptl(ji,jj) = iimpptl(ji-1,jj) + ilcitl(ji-1,jj) - nrecil
- END DO
- END DO
- ENDIF
-
- IF( jsplt > 1 ) THEN
- DO jj = 2, jsplt
- DO ji = 1, isplt
- ijmpptl(ji,jj) = ijmpptl(ji,jj-1)+ilcjtl(ji,jj-1)-nrecjl
- END DO
- END DO
- ENDIF
-
- ! 3. Subdomain description
- ! ------------------------
-
- DO jn = 1, ijsplt
- ii = 1 + MOD( jn-1, isplt )
- ij = 1 + (jn-1) / isplt
- nimpptl(jn) = iimpptl(ii,ij)
- njmpptl(jn) = ijmpptl(ii,ij)
- nlcitl (jn) = ilcitl (ii,ij)
- nlcil = nlcitl (jn)
- nlcjtl (jn) = ilcjtl (ii,ij)
- nlcjl = nlcjtl (jn)
- nbondjl = -1 ! general case
- IF( jn > isplt ) nbondjl = 0 ! first row of processor
- IF( jn > (jsplt-1)*isplt ) nbondjl = 1 ! last row of processor
- IF( jsplt == 1 ) nbondjl = 2 ! one processor only in j-direction
- ibonjtl(jn) = nbondjl
-
- nbondil = 0 !
- IF( MOD( jn, isplt ) == 1 ) nbondil = -1 !
- IF( MOD( jn, isplt ) == 0 ) nbondil = 1 !
- IF( isplt == 1 ) nbondil = 2 ! one processor only in i-direction
- ibonitl(jn) = nbondil
-
- nldil = 1 + nn_hls
- nleil = nlcil - nn_hls
- IF( nbondil == -1 .OR. nbondil == 2 ) nldil = 1
- IF( nbondil == 1 .OR. nbondil == 2 ) nleil = nlcil
- nldjl = 1 + nn_hls
- nlejl = nlcjl - nn_hls
- IF( nbondjl == -1 .OR. nbondjl == 2 ) nldjl = 1
- IF( nbondjl == 1 .OR. nbondjl == 2 ) nlejl = nlcjl
- nlditl(jn) = nldil
- nleitl(jn) = nleil
- nldjtl(jn) = nldjl
- nlejtl(jn) = nlejl
- END DO
- !
- ! Save processor layout in layout_prtctl.dat file
- IF(lwp) THEN
- CALL ctl_opn( inum, 'layout_prtctl.dat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea )
- WRITE(inum,'(a)') 'nproc nlcil nlcjl nldil nldjl nleil nlejl nimpptl njmpptl ibonitl ibonjtl'
- !
- DO jn = 1, ijsplt
- WRITE(inum,'(i5,6i6,4i8)') jn-1,nlcitl(jn), nlcjtl(jn), &
- & nlditl(jn), nldjtl(jn), &
- & nleitl(jn), nlejtl(jn), &
- & nimpptl(jn), njmpptl(jn), &
- & ibonitl(jn), ibonjtl(jn)
- END DO
- CLOSE(inum)
- END IF
- !
- !
- END SUBROUTINE sub_dom
+ !
+ END SUBROUTINE prt_ctl_init
+
!!======================================================================
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/IOM/restart.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/IOM/restart.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/IOM/restart.F90 (revision 13540)
@@ -214,10 +214,10 @@
IF( .NOT.lxios_set ) THEN
IF(lwp) WRITE(numout,*) 'Enable restart reading by XIOS'
- CALL iom_init( crxios_context, ld_tmppatch = .false. )
+ CALL iom_init( crxios_context )
lxios_set = .TRUE.
ENDIF
ENDIF
IF( TRIM(Agrif_CFixed()) /= '0' .AND. lrxios) THEN
- CALL iom_init( crxios_context, ld_tmppatch = .false. )
+ CALL iom_init( crxios_context )
IF(lwp) WRITE(numout,*) 'Enable restart reading by XIOS for AGRIF'
lxios_set = .TRUE.
@@ -259,10 +259,10 @@
! Diurnal DSST
- IF( ln_diurnal ) CALL iom_get( numror, jpdom_autoglo, 'Dsst' , x_dsst, ldxios = lrxios )
+ IF( ln_diurnal ) CALL iom_get( numror, jpdom_auto, 'Dsst' , x_dsst, ldxios = lrxios )
IF ( ln_diurnal_only ) THEN
IF(lwp) WRITE( numout, * ) &
& "rst_read:- ln_diurnal_only set, setting rhop=rho0"
rhop = rho0
- CALL iom_get( numror, jpdom_autoglo, 'tn' , w3d, ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'tn' , w3d, ldxios = lrxios )
ts(:,:,1,jp_tem,Kmm) = w3d(:,:,1)
RETURN
@@ -270,20 +270,22 @@
IF( iom_varid( numror, 'ub', ldstop = .FALSE. ) > 0 ) THEN
- CALL iom_get( numror, jpdom_autoglo, 'ub' , uu(:,:,: ,Kbb), ldxios = lrxios ) ! before fields
- CALL iom_get( numror, jpdom_autoglo, 'vb' , vv(:,:,: ,Kbb), ldxios = lrxios )
- CALL iom_get( numror, jpdom_autoglo, 'tb' , ts(:,:,:,jp_tem,Kbb), ldxios = lrxios )
- CALL iom_get( numror, jpdom_autoglo, 'sb' , ts(:,:,:,jp_sal,Kbb), ldxios = lrxios )
- CALL iom_get( numror, jpdom_autoglo, 'sshb' ,ssh(:,: ,Kbb), ldxios = lrxios )
+ ! before fields
+ CALL iom_get( numror, jpdom_auto, 'ub' , uu(:,:,: ,Kbb), ldxios = lrxios, cd_type = 'U', psgn = -1._wp )
+ CALL iom_get( numror, jpdom_auto, 'vb' , vv(:,:,: ,Kbb), ldxios = lrxios, cd_type = 'V', psgn = -1._wp )
+ CALL iom_get( numror, jpdom_auto, 'tb' , ts(:,:,:,jp_tem,Kbb), ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'sb' , ts(:,:,:,jp_sal,Kbb), ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'sshb' ,ssh(:,: ,Kbb), ldxios = lrxios )
ELSE
l_1st_euler = .TRUE. ! before field not found, forced euler 1st time-step
ENDIF
!
- CALL iom_get( numror, jpdom_autoglo, 'un' , uu(:,:,: ,Kmm), ldxios = lrxios ) ! now fields
- CALL iom_get( numror, jpdom_autoglo, 'vn' , vv(:,:,: ,Kmm), ldxios = lrxios )
- CALL iom_get( numror, jpdom_autoglo, 'tn' , ts(:,:,:,jp_tem,Kmm), ldxios = lrxios )
- CALL iom_get( numror, jpdom_autoglo, 'sn' , ts(:,:,:,jp_sal,Kmm), ldxios = lrxios )
- CALL iom_get( numror, jpdom_autoglo, 'sshn' ,ssh(:,: ,Kmm), ldxios = lrxios )
+ ! now fields
+ CALL iom_get( numror, jpdom_auto, 'un' , uu(:,:,: ,Kmm), ldxios = lrxios, cd_type = 'U', psgn = -1._wp )
+ CALL iom_get( numror, jpdom_auto, 'vn' , vv(:,:,: ,Kmm), ldxios = lrxios, cd_type = 'V', psgn = -1._wp )
+ CALL iom_get( numror, jpdom_auto, 'tn' , ts(:,:,:,jp_tem,Kmm), ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'sn' , ts(:,:,:,jp_sal,Kmm), ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'sshn' ,ssh(:,: ,Kmm), ldxios = lrxios )
IF( iom_varid( numror, 'rhop', ldstop = .FALSE. ) > 0 ) THEN
- CALL iom_get( numror, jpdom_autoglo, 'rhop' , rhop, ldxios = lrxios ) ! now potential density
+ CALL iom_get( numror, jpdom_auto, 'rhop' , rhop, ldxios = lrxios ) ! now potential density
ELSE
CALL eos( ts(:,:,:,:,Kmm), rhd, rhop, gdept(:,:,:,Kmm) )
@@ -295,11 +297,4 @@
vv (:,:,: ,Kbb) = vv (:,:,: ,Kmm)
ssh (:,: ,Kbb) = ssh (:,: ,Kmm)
- !
- IF( .NOT.ln_linssh ) THEN
- DO jk = 1, jpk
- e3t(:,:,jk,Kbb) = e3t(:,:,jk,Kmm)
- END DO
- ENDIF
- !
ENDIF
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/ISF/isfcav.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/ISF/isfcav.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/ISF/isfcav.F90 (revision 13540)
@@ -136,5 +136,5 @@
!
! lbclnk on melt
- CALL lbc_lnk_multi( 'isfmlt', zqh, 'T', 1., pqfwf, 'T', 1.)
+ CALL lbc_lnk_multi( 'isfmlt', zqh, 'T', 1.0_wp, pqfwf, 'T', 1.0_wp)
!
! output fluxes
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/ISF/isfcavgam.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/ISF/isfcavgam.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/ISF/isfcavgam.F90 (revision 13540)
@@ -30,4 +30,5 @@
PUBLIC isfcav_gammats
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/ISF/isfcavmlt.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/ISF/isfcavmlt.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/ISF/isfcavmlt.F90 (revision 13540)
@@ -136,5 +136,5 @@
!! ** 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 * Rau0 * Cp * ( Tw - Tfrz ) / Lf
+ !! qfwf = Gammat * rho0 * Cp * ( Tw - Tfrz ) / Lf
!! qhoce = qlat
!! qhc = qfwf * Cp * Tfrz
@@ -210,5 +210,5 @@
! 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_11_11
+ DO_2D( 1, 1, 1, 1 )
!
! compute coeficient to solve the 2nd order equation
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/ISF/isfcpl.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/ISF/isfcpl.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/ISF/isfcpl.F90 (revision 13540)
@@ -15,6 +15,10 @@
USE isfutils, ONLY : debug
USE lib_mpp , ONLY: mpp_sum, mpp_max ! mpp routine
+#if ! defined key_qco
USE domvvl , ONLY: dom_vvl_zgr ! vertical scale factor interpolation
- USE domngb , ONLY: dom_ngb ! find the closest grid point from a given lon/lat position
+#else
+ USE domqco , ONLY: dom_qco_zgr ! vertical scale factor interpolation
+#endif
+ USE domutl , ONLY: dom_ngb ! find the closest grid point from a given lon/lat position
!
USE oce ! ocean dynamics and tracers
@@ -43,4 +47,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -112,6 +117,7 @@
vv (:,:,:,Kbb) = vv (:,:,:,Kmm)
ssh (:,:,Kbb) = ssh (:,:,Kmm)
+#if ! defined key_qco
e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm)
-
+#endif
! prepare writing restart
IF( lwxios ) THEN
@@ -135,12 +141,23 @@
INTEGER, INTENT(in) :: Kmm ! ocean time level index
!!----------------------------------------------------------------------
+ INTEGER :: jk ! loop index
+ REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t, ze3u, ze3v, zgdepw ! e3t , e3u, e3v !!st patch to use substitution
+ !!----------------------------------------------------------------------
+ !
+ DO jk = 1, jpk
+ ze3t(:,:,jk) = e3t(:,:,jk,Kmm)
+ ze3u(:,:,jk) = e3u(:,:,jk,Kmm)
+ ze3v(:,:,jk) = e3v(:,:,jk,Kmm)
+ !
+ zgdepw(:,:,jk) = gdepw(:,:,jk,Kmm)
+ END DO
!
IF( lwxios ) CALL iom_swap( cwxios_context )
CALL iom_rstput( kt, nitrst, numrow, 'tmask' , tmask , ldxios = lwxios )
CALL iom_rstput( kt, nitrst, numrow, 'ssmask' , ssmask, ldxios = lwxios )
- CALL iom_rstput( kt, nitrst, numrow, 'e3t_n' , e3t(:,:,:,Kmm) , ldxios = lwxios )
- CALL iom_rstput( kt, nitrst, numrow, 'e3u_n' , e3u(:,:,:,Kmm) , ldxios = lwxios )
- CALL iom_rstput( kt, nitrst, numrow, 'e3v_n' , e3v(:,:,:,Kmm) , ldxios = lwxios )
- CALL iom_rstput( kt, nitrst, numrow, 'gdepw_n', gdepw(:,:,:,Kmm) , ldxios = lwxios )
+ CALL iom_rstput( kt, nitrst, numrow, 'e3t_n' , ze3t , ldxios = lwxios )
+ CALL iom_rstput( kt, nitrst, numrow, 'e3u_n' , ze3u , ldxios = lwxios )
+ CALL iom_rstput( kt, nitrst, numrow, 'e3v_n' , ze3v , ldxios = lwxios )
+ CALL iom_rstput( kt, nitrst, numrow, 'gdepw_n', zgdepw , ldxios = lwxios )
IF( lwxios ) CALL iom_swap( cxios_context )
!
@@ -166,5 +183,5 @@
!!----------------------------------------------------------------------
!
- CALL iom_get( numror, jpdom_autoglo, 'ssmask' , zssmask_b, ldxios = lrxios ) ! need to extrapolate T/S
+ CALL iom_get( numror, jpdom_auto, 'ssmask' , zssmask_b, ldxios = lrxios ) ! need to extrapolate T/S
! compute new ssh if we open a full water column
@@ -177,5 +194,5 @@
!
zdssmask(:,:) = ssmask(:,:) - zssmask0(:,:)
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
jip1=ji+1; jim1=ji-1;
jjp1=jj+1; jjm1=jj-1;
@@ -195,5 +212,5 @@
zssmask0(:,:) = zssmask_b(:,:)
!
- CALL lbc_lnk_multi( 'iscplrst', zssh, 'T', 1., zssmask0, 'T', 1. )
+ CALL lbc_lnk_multi( 'iscplrst', zssh, 'T', 1.0_wp, zssmask0, 'T', 1.0_wp )
!
END DO
@@ -209,11 +226,13 @@
IF(lwp) write(numout,*) 'isfcpl_ssh : recompute scale factor from ssh (new wet cell,Kmm)'
IF(lwp) write(numout,*) '~~~~~~~~~~~'
+#if ! defined key_qco
DO jk = 1, jpk
- e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * ( ht_0(:,:) + ssh(:,:,Kmm) ) &
- & / ( ht_0(:,:) + 1._wp - ssmask(:,:) ) * tmask(:,:,jk) &
- & + e3t_0(:,:,jk) * (1._wp -tmask(:,:,jk))
+ 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)
+#else
+ CALL dom_qco_zgr(Kbb, Kmm, Kaa)
+#endif
!
END SUBROUTINE isfcpl_ssh
@@ -245,7 +264,7 @@
!!----------------------------------------------------------------------
!
- CALL iom_get( numror, jpdom_autoglo, 'tmask' , ztmask_b, ldxios = lrxios ) ! need to extrapolate T/S
- !CALL iom_get( numror, jpdom_autoglo, 'wmask' , zwmask_b, ldxios = lrxios ) ! need to extrapolate T/S
- !CALL iom_get( numror, jpdom_autoglo, 'gdepw_n', zdepw_b(:,:,:), ldxios = lrxios ) ! need to interpol vertical profile (vvl)
+ CALL iom_get( numror, jpdom_auto, 'tmask' , ztmask_b, ldxios = lrxios ) ! need to extrapolate T/S
+ !CALL iom_get( numror, jpdom_auto, 'wmask' , zwmask_b, ldxios = lrxios ) ! need to extrapolate T/S
+ !CALL iom_get( numror, jpdom_auto, 'gdepw_n', zdepw_b(:,:,:), ldxios = lrxios ) ! need to interpol vertical profile (vvl)
!
!
@@ -298,5 +317,5 @@
zdmask(:,:) = tmask(:,:,jk) - ztmask0(:,:,jk);
!
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
jip1=ji+1; jim1=ji-1;
jjp1=jj+1; jjm1=jj-1;
@@ -348,5 +367,5 @@
ztmask0(:,:,:) = ztmask1(:,:,:)
!
- CALL lbc_lnk_multi( 'iscplrst', zts0(:,:,:,jp_tem), 'T', 1., zts0(:,:,:,jp_sal), 'T', 1., ztmask0, 'T', 1.)
+ CALL lbc_lnk_multi( 'iscplrst', zts0(:,:,:,jp_tem), 'T', 1.0_wp, zts0(:,:,:,jp_sal), 'T', 1.0_wp, ztmask0, 'T', 1.0_wp)
!
END DO ! nn_drown
@@ -359,5 +378,5 @@
! -----------------------------------------------------------------------------------------
! case we open a cell but no neigbour cells available to get an estimate of T and S
- DO_3D_11_11( 1,jpk-1 )
+ DO_3D( 1, 1, 1, 1, 1,jpk-1 )
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, &
@@ -391,7 +410,7 @@
!!----------------------------------------------------------------------
!
- CALL iom_get( numror, jpdom_autoglo, 'tmask' , ztmask_b, ldxios = lrxios )
- CALL iom_get( numror, jpdom_autoglo, 'e3u_n' , ze3u_b , ldxios = lrxios )
- CALL iom_get( numror, jpdom_autoglo, 'e3v_n' , ze3v_b , ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'tmask' , ztmask_b, ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'e3u_n' , ze3u_b , ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'e3v_n' , ze3v_b , ldxios = lrxios )
!
! 1.0: compute horizontal volume flux divergence difference before-after coupling
@@ -399,7 +418,10 @@
DO jk = 1, jpk ! Horizontal slab
! 1.1: get volume flux before coupling (>0 out)
- DO_2D_00_00
- zqvolb(ji,jj,jk) = ( e2u(ji,jj) * ze3u_b(ji,jj,jk) * uu(ji,jj,jk,Kmm) - e2u(ji-1,jj ) * ze3u_b(ji-1,jj ,jk) * uu(ji-1,jj ,jk,Kmm) &
- & + e1v(ji,jj) * ze3v_b(ji,jj,jk) * vv(ji,jj,jk,Kmm) - e1v(ji ,jj-1) * ze3v_b(ji ,jj-1,jk) * vv(ji ,jj-1,jk,Kmm) ) &
+ DO_2D( 0, 0, 0, 0 )
+ zqvolb(ji,jj,jk) = &
+ & ( e2u(ji ,jj ) * ze3u_b(ji ,jj ,jk) * uu(ji ,jj ,jk,Kmm) &
+ & - e2u(ji-1,jj ) * ze3u_b(ji-1,jj ,jk) * uu(ji-1,jj ,jk,Kmm) &
+ & + e1v(ji ,jj ) * ze3v_b(ji ,jj ,jk) * vv(ji ,jj ,jk,Kmm) &
+ & - e1v(ji ,jj-1) * ze3v_b(ji ,jj-1,jk) * vv(ji ,jj-1,jk,Kmm) ) &
& * ztmask_b(ji,jj,jk)
END_2D
@@ -411,7 +433,10 @@
vv(:,:,jk,Kmm) = vv(:,:,jk,Kmm) * vmask(:,:,jk)
! compute volume flux divergence after coupling
- DO_2D_00_00
- zqvoln(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) &
- & + 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) ) &
+ DO_2D( 0, 0, 0, 0 )
+ zqvoln(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) &
+ & + 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) ) &
& * tmask(ji,jj,jk)
END_2D
@@ -424,5 +449,5 @@
! 2.0: include the contribution of the vertical velocity in the volume flux correction
!
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
!
ikt = mikt(ji,jj)
@@ -433,5 +458,5 @@
END_2D
!
- CALL lbc_lnk( 'iscpl', risfcpl_vol, 'T', 1. )
+ CALL lbc_lnk( 'iscpl', risfcpl_vol, 'T', 1.0_wp )
!
! 3.0: set total correction (div, tr(:,:,:,:,Krhs), ssh)
@@ -495,8 +520,8 @@
! get restart variable
- CALL iom_get( numror, jpdom_autoglo, 'tmask' , ztmask_b(:,:,:), ldxios = lrxios ) ! need to extrapolate T/S
- CALL iom_get( numror, jpdom_autoglo, 'e3t_n' , ze3t_b(:,:,:) , ldxios = lrxios )
- CALL iom_get( numror, jpdom_autoglo, 'tn' , zt_b(:,:,:) , ldxios = lrxios )
- CALL iom_get( numror, jpdom_autoglo, 'sn' , zs_b(:,:,:) , ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'tmask' , ztmask_b(:,:,:), ldxios = lrxios ) ! need to extrapolate T/S
+ CALL iom_get( numror, jpdom_auto, 'e3t_n' , ze3t_b(:,:,:) , ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'tn' , zt_b(:,:,:) , ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'sn' , zs_b(:,:,:) , ldxios = lrxios )
! compute run length
@@ -519,9 +544,10 @@
DO jk = 1,jpk-1
- DO jj = nldj,nlej
- DO ji = nldi,nlei
+ 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)
+ zdvol = e3t (ji,jj,jk,Kmm) * tmask (ji,jj,jk) &
+ & - ze3t_b(ji,jj,jk ) * ztmask_b(ji,jj,jk)
! heat diff
@@ -552,8 +578,10 @@
nisfl(:)=0
DO jk = 1,jpk-1
- DO jj = nldj,nlej
- DO ji = nldi,nlei
+ 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 ) nisfl(narea) = nisfl(narea) + MAX(SUM(tmask(jim1:jip1,jjm1:jjp1,jk)),1._wp)
+ 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
@@ -572,6 +600,6 @@
jisf = 0
DO jk = 1,jpk-1
- DO jj = nldj,nlej
- DO ji = nldi,nlei
+ DO jj = Njs0,Nje0
+ DO ji = Nis0,Nie0
IF ( tmask(ji,jj,jk) == 0._wp .AND. ztmask_b(ji,jj,jk) == 1._wp ) THEN
@@ -602,8 +630,8 @@
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)
+ 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., 1)
+ CALL update_isfpts(zisfpts, jisf, ji , jj , jk , zdvol, zdsal, zdtem, 1.0_wp, 1)
END IF
END IF
@@ -665,6 +693,6 @@
!
! add lbclnk
- CALL lbc_lnk_multi( 'iscplrst', risfcpl_cons_tsc(:,:,:,jp_tem), 'T', 1., risfcpl_cons_tsc(:,:,:,jp_sal), 'T', 1., &
- & risfcpl_cons_vol(:,:,:) , 'T', 1.)
+ CALL lbc_lnk_multi( 'iscplrst', 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)
!
! ssh correction (for dynspg_ts)
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/ISF/isfdiags.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/ISF/isfdiags.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/ISF/isfdiags.F90 (revision 13540)
@@ -26,4 +26,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -88,5 +89,5 @@
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=256), INTENT(in) :: cdvar
+ CHARACTER(LEN=*), INTENT(in) :: cdvar
!!---------------------------------------------------------------------
INTEGER :: ji, jj, jk ! loop indices
@@ -100,5 +101,5 @@
zvar3d(:,:,:) = 0._wp
!
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
ikt = ktop(ji,jj)
ikb = kbot(ji,jj)
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/ISF/isfdynatf.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/ISF/isfdynatf.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/ISF/isfdynatf.F90 (revision 13540)
@@ -14,5 +14,6 @@
USE phycst , ONLY: r1_rho0 ! physical constant
- USE dom_oce, ONLY: tmask, ssmask, ht, e3t, r1_e1e2t ! time and space domain
+ USE dom_oce ! time and space domain
+ USE oce, ONLY : ssh ! sea-surface height !!st needed for substitution
USE in_out_manager
@@ -25,4 +26,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
CONTAINS
@@ -81,5 +83,6 @@
! add the increment
DO jk = 1, jpkm1
- pe3t_f(:,:,jk) = pe3t_f(:,:,jk) - tmask(:,:,jk) * zfwfinc(:,:) * e3t(:,:,jk,Kmm)
+ pe3t_f(:,:,jk) = pe3t_f(:,:,jk) - tmask(:,:,jk) * zfwfinc(:,:) &
+ & * e3t(:,:,jk,Kmm)
END DO
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/ISF/isfhdiv.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/ISF/isfhdiv.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/ISF/isfhdiv.F90 (revision 13540)
@@ -26,4 +26,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
CONTAINS
@@ -99,5 +100,5 @@
!
! update divergence at each level affected by ice shelf top boundary layer
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
ikt = ktop(ji,jj)
ikb = kbot(ji,jj)
@@ -134,5 +135,6 @@
!
DO jk=1,jpk
- phdiv(:,:,jk) = phdiv(:,:,jk) + pqvol(:,:,jk) * r1_e1e2t(:,:) / e3t(:,:,jk,Kmm)
+ phdiv(:,:,jk) = phdiv(:,:,jk) + pqvol(:,:,jk) * r1_e1e2t(:,:) &
+ & / e3t(:,:,jk,Kmm)
END DO
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/ISF/isfload.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/ISF/isfload.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/ISF/isfload.F90 (revision 13540)
@@ -13,5 +13,5 @@
USE isf_oce, ONLY: cn_isfload, rn_isfload_T, rn_isfload_S ! ice shelf variables
- USE dom_oce, ONLY: e3w, gdept, risfdep, mikt ! vertical scale factor
+ USE dom_oce ! vertical scale factor
USE eosbn2 , ONLY: eos ! eos routine
@@ -26,4 +26,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
CONTAINS
@@ -93,5 +94,5 @@
! !- Surface value + ice shelf gradient
pisfload(:,:) = 0._wp ! compute pressure due to ice shelf load
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
ikt = mikt(ji,jj)
!
@@ -99,9 +100,11 @@
!
! top layer of the ice shelf
- pisfload(ji,jj) = pisfload(ji,jj) + (znad + zrhd(ji,jj,1) ) * e3w(ji,jj,1,Kmm)
+ pisfload(ji,jj) = pisfload(ji,jj) + (znad + zrhd(ji,jj,1) ) &
+ & * e3w(ji,jj,1,Kmm)
!
! core layers of the ice shelf
DO jk = 2, ikt-1
- pisfload(ji,jj) = pisfload(ji,jj) + (2._wp * znad + zrhd(ji,jj,jk-1) + zrhd(ji,jj,jk)) * e3w(ji,jj,jk,Kmm)
+ pisfload(ji,jj) = pisfload(ji,jj) + (2._wp * znad + zrhd(ji,jj,jk-1) + zrhd(ji,jj,jk)) &
+ & * e3w(ji,jj,jk,Kmm)
END DO
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/ISF/isfpar.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/ISF/isfpar.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/ISF/isfpar.F90 (revision 13540)
@@ -82,5 +82,5 @@
!
! lbclnk on melt and heat fluxes
- CALL lbc_lnk_multi( 'isfmlt', zqh, 'T', 1., pqfwf, 'T', 1.)
+ CALL lbc_lnk_multi( 'isfmlt', zqh, 'T', 1.0_wp, pqfwf, 'T', 1.0_wp)
!
! output fluxes
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/ISF/isfrst.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/ISF/isfrst.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/ISF/isfrst.F90 (revision 13540)
@@ -53,7 +53,7 @@
IF( iom_varid( numror, cfwf_b, ldstop = .FALSE. ) > 0 ) THEN
IF(lwp) WRITE(numout,*) ' nit000-1 isf tracer content forcing fields read in the restart file'
- CALL iom_get( numror, jpdom_autoglo, cfwf_b, pfwf_b(:,:) , ldxios = lrxios ) ! before ice shelf melt
- CALL iom_get( numror, jpdom_autoglo, chc_b , ptsc_b (:,:,jp_tem), ldxios = lrxios ) ! before ice shelf heat flux
- CALL iom_get( numror, jpdom_autoglo, csc_b , ptsc_b (:,:,jp_sal), ldxios = lrxios ) ! before ice shelf heat flux
+ CALL iom_get( numror, jpdom_auto, cfwf_b, pfwf_b(:,:) , ldxios = lrxios ) ! before ice shelf melt
+ CALL iom_get( numror, jpdom_auto, chc_b , ptsc_b (:,:,jp_tem), ldxios = lrxios ) ! before ice shelf heat flux
+ CALL iom_get( numror, jpdom_auto, csc_b , ptsc_b (:,:,jp_sal), ldxios = lrxios ) ! before ice shelf heat flux
ELSE
pfwf_b(:,:) = pfwf(:,:)
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/ISF/isfstp.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/ISF/isfstp.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/ISF/isfstp.F90 (revision 13540)
@@ -13,5 +13,4 @@
!! isfstp : compute iceshelf melt and heat flux
!!----------------------------------------------------------------------
- !
USE isf_oce ! isf variables
USE isfload, ONLY: isf_load ! ice shelf load
@@ -21,5 +20,6 @@
USE isfcpl , ONLY: isfcpl_rst_write, isfcpl_init ! isf variables
- USE dom_oce, ONLY: ht, e3t, ln_isfcav, ln_linssh ! 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.
@@ -31,9 +31,10 @@
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)
@@ -41,4 +42,5 @@
!! Software governed by the CeCILL license (see ./LICENSE)
!!----------------------------------------------------------------------
+
CONTAINS
@@ -60,4 +62,7 @@
INTEGER, INTENT(in) :: kt ! ocean time step
INTEGER, INTENT(in) :: Kmm ! ocean time level index
+ !!----------------------------------------------------------------------
+ INTEGER :: jk ! loop index
+ REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t ! e3t
!!---------------------------------------------------------------------
!
@@ -78,5 +83,8 @@
! 1.2: compute misfkb, rhisf_tbl, rfrac (deepest level, thickness, fraction of deepest cell affected by tbl)
rhisf_tbl_cav(:,:) = rn_htbl * mskisf_cav(:,:)
- CALL isf_tbl_lvl(ht, e3t(:,:,:,Kmm), misfkt_cav, misfkb_cav, rhisf_tbl_cav, rfrac_tbl_cav)
+ 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)
!
! 1.3: compute ice shelf melt
@@ -100,5 +108,8 @@
! 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(:,:)
- CALL isf_tbl_lvl(ht, e3t(:,:,:,Kmm), misfkt_par, misfkb_par, rhisf_tbl_par, rfrac_tbl_par)
+ 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)
!
! 2.3: compute ice shelf melt
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/ISF/isftbl.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/ISF/isftbl.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/ISF/isftbl.F90 (revision 13540)
@@ -25,4 +25,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
CONTAINS
@@ -56,4 +57,6 @@
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
!!--------------------------------------------------------------------
!
@@ -64,13 +67,16 @@
zhtbl = phtbl
!
+ DO jk = 1, jpk
+ ze3u(:,:,jk) = e3u(:,:,jk,Kmm)
+ END DO
! compute tbl lvl and thickness
- CALL isf_tbl_lvl( hu(:,:,Kmm), e3u(:,:,:,Kmm), ktop, ikbot, zhtbl, zfrac )
+ CALL isf_tbl_lvl( hu(:,:,Kmm), ze3u, ktop, ikbot, zhtbl, zfrac )
!
! compute tbl property at U point
- CALL isf_tbl_avg( miku, ikbot, zhtbl, zfrac, e3u(:,:,:,Kmm), pvarin, zvarout )
+ CALL isf_tbl_avg( miku, ikbot, zhtbl, zfrac, ze3u, pvarin, zvarout )
!
! compute tbl property at T point
pvarout(1,:) = 0._wp
- DO_2D_11_01
+ DO_2D( 1, 1, 0, 1 )
pvarout(ji,jj) = 0.5_wp * (zvarout(ji,jj) + zvarout(ji-1,jj))
END_2D
@@ -82,13 +88,16 @@
zhtbl = phtbl
!
+ DO jk = 1, jpk
+ ze3v(:,:,jk) = e3v(:,:,jk,Kmm)
+ END DO
! compute tbl lvl and thickness
- CALL isf_tbl_lvl( hv(:,:,Kmm), e3v(:,:,:,Kmm), ktop, ikbot, zhtbl, zfrac )
+ CALL isf_tbl_lvl( hv(:,:,Kmm), ze3v, ktop, ikbot, zhtbl, zfrac )
!
! compute tbl property at V point
- CALL isf_tbl_avg( mikv, ikbot, zhtbl, zfrac, e3v(:,:,:,Kmm), pvarin, zvarout )
+ CALL isf_tbl_avg( mikv, ikbot, zhtbl, zfrac, ze3v, pvarin, zvarout )
!
! pvarout is an averaging of wet point
pvarout(:,1) = 0._wp
- DO_2D_01_11
+ DO_2D( 0, 1, 1, 1 )
pvarout(ji,jj) = 0.5_wp * (zvarout(ji,jj) + zvarout(ji,jj-1))
END_2D
@@ -98,5 +107,8 @@
!
! compute tbl property at T point
- CALL isf_tbl_avg( ktop, kbot, phtbl, pfrac, e3t(:,:,:,Kmm), pvarin, pvarout )
+ DO jk = 1, jpk
+ ze3t(:,:,jk) = e3t(:,:,jk,Kmm)
+ END DO
+ CALL isf_tbl_avg( ktop, kbot, phtbl, pfrac, ze3t, pvarin, pvarout )
!
END SELECT
@@ -126,5 +138,5 @@
!
! compute tbl top.bottom level and thickness
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
!
! tbl top/bottom indices initialisation
@@ -164,5 +176,5 @@
!
! get htbl
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
!
! tbl top/bottom indices initialisation
@@ -181,5 +193,5 @@
!
! get pfrac
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
!
! tbl top/bottom indices initialisation
@@ -212,8 +224,8 @@
! 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 e3t(ji,jj,1))
+ ! test: if htbl = 0 should return ktop (phtbl cap to pe3t(ji,jj,1))
!
! get ktbl
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
!
! determine the deepest level influenced by the boundary layer
@@ -249,5 +261,5 @@
! test: this routine run with pdep = 0 should return 1
!
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
! comput ktop
ikt = 2
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/ISF/isfutils.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/ISF/isfutils.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/ISF/isfutils.F90 (revision 13540)
@@ -12,8 +12,8 @@
!!----------------------------------------------------------------------
- USE iom , ONLY: iom_open, iom_get, iom_close, jpdom_data ! read input file
+ 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 ! domain size
- USE dom_oce , ONLY: nldi, nlei, nldj, nlej, narea, tmask_h, tmask_i ! local domain
+ USE par_oce , ONLY: jpi,jpj,jpk, jpnij, Nis0, Nie0, Njs0, Nje0 ! domain size
+ USE dom_oce , ONLY: narea, tmask_h, tmask_i ! local domain
USE in_out_manager, ONLY: i8, wp, lwp, numout ! miscelenious
USE lib_mpp
@@ -47,5 +47,5 @@
CALL iom_open( TRIM(cdfile), inum )
- CALL iom_get( inum, jpdom_data, TRIM(cdvar), pvar)
+ CALL iom_get( inum, jpdom_global, TRIM(cdvar), pvar)
CALL iom_close(inum)
@@ -84,6 +84,6 @@
!
! local MOD sum
- DO jj=nldj,nlej
- DO ji=nldi,nlei
+ DO jj=Njs0,Nje0
+ DO ji=Nis0,Nie0
idums = ABS(MOD(TRANSFER(pvar(ji,jj), ip),imodd))
itmps(narea) = MOD(itmps(narea) + idums, imods)
@@ -138,6 +138,6 @@
! local MOD sum
DO jk=1,jpk
- DO jj=nldj,nlej
- DO ji=nldi,nlei
+ DO jj=Njs0,Nje0
+ DO ji=Nis0,Nie0
idums = ABS(MOD(TRANSFER(pvar(ji,jj,jk), ip),imodd))
itmps(narea) = MOD(itmps(narea) + idums, imods)
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/halo_mng.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/halo_mng.F90 (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/halo_mng.F90 (revision 13540)
@@ -0,0 +1,194 @@
+MODULE halo_mng
+ !!======================================================================
+ !! *** MODULE halo_mng ***
+ !! Ocean numerics: massively parallel processing library
+ !!=====================================================================
+ !! History : OPA ! 1994 (M. Guyon, J. Escobar, M. Imbard)
+ !Original code
+ !! 4.0 ! 2019 (CMCC - ASC) initial version of halo management module
+ !in_out_manager
+ !!----------------------------------------------------------------------
+
+ USE dom_oce ! ocean space and time domain
+ USE lbclnk ! ocean lateral boundary condition (or mpp link)
+
+ IMPLICIT NONE
+ PRIVATE
+
+ INTERFACE halo_mng_resize
+ MODULE PROCEDURE halo_mng_resize_2D, halo_mng_resize_3D, halo_mng_resize_4D, halo_mng_resize_5D
+ END INTERFACE
+
+ PUBLIC halo_mng_resize
+ PUBLIC halo_mng_init
+ PUBLIC halo_mng_set
+
+ INTEGER :: jpi_1, jpj_1
+ INTEGER :: jpimax_1, jpjmax_1
+ INTEGER :: Nis0_1, Njs0_1
+ INTEGER :: Nie0_1, Nje0_1
+CONTAINS
+
+ SUBROUTINE halo_mng_init( )
+
+ jpi_1 = jpi
+ jpj_1 = jpj
+
+ Nis0_1 = Nis0
+ Njs0_1 = Njs0
+
+ Nie0_1 = Nie0
+ Nje0_1 = Nje0
+
+ jpimax_1 = jpimax
+ jpjmax_1 = jpjmax
+
+ END SUBROUTINE halo_mng_init
+
+ SUBROUTINE halo_mng_set( khls )
+
+ INTEGER, INTENT(in ) :: khls
+
+ nn_hls = khls
+
+ jpi = jpi_1 + 2*khls -2
+ jpj = jpj_1 + 2*khls -2
+
+ jpi = jpi_1 + 2*khls -2
+ jpj = jpj_1 + 2*khls -2
+
+ jpimax = jpimax_1 + 2*khls -2
+ jpjmax = jpjmax_1 + 2*khls -2
+
+ Nis0 = Nis0_1 + khls - 1
+ Njs0 = Njs0_1 + khls - 1
+
+ Nie0 = Nie0_1 + khls - 1
+ Nje0 = Nje0_1 + khls - 1
+
+ END SUBROUTINE halo_mng_set
+
+ SUBROUTINE halo_mng_resize_2D(pta, cdna, psgn, fillval)
+
+ REAL(wp), POINTER, DIMENSION(:,:) :: pta
+ CHARACTER(len=1), INTENT(in) :: cdna
+ REAL(wp), INTENT(in) :: psgn
+ REAL(wp), OPTIONAL, INTENT(in ) :: fillval
+ REAL(wp), POINTER, DIMENSION(:,:) :: zpta
+ INTEGER :: offset
+ INTEGER :: pta_size_i, pta_size_j
+
+ pta_size_i = SIZE(pta,1)
+ pta_size_j = SIZE(pta,2)
+
+ ! check if the current size of pta is equal to the current expected dimension
+ IF (pta_size_i .ne. jpi) THEN
+ ALLOCATE (zpta(jpi, jpj))
+ offset = abs((jpi - pta_size_i) / 2)
+
+ IF (pta_size_i .lt. jpi) THEN
+ zpta (offset+1 : offset+pta_size_i, offset+1 : offset+pta_size_j) = pta
+ ELSE
+ zpta = pta(offset+1 : offset+jpi, offset+1 : offset+jpj)
+ END IF
+ CALL lbc_lnk( 'halo_mng_resize_2D', zpta, cdna, psgn, pfillval=fillval)
+ DEALLOCATE(pta)
+ pta => zpta
+ END IF
+
+ END SUBROUTINE halo_mng_resize_2D
+
+ SUBROUTINE halo_mng_resize_3D(pta, cdna, psgn, fillval)
+
+ REAL(wp), POINTER, DIMENSION(:,:,:) :: pta
+ CHARACTER(len=1), INTENT(in) :: cdna
+ REAL(wp), INTENT(in) :: psgn
+ REAL(wp), OPTIONAL, INTENT(in ) :: fillval
+ REAL(wp), POINTER, DIMENSION(:,:,:) :: zpta
+ INTEGER :: offset
+ INTEGER :: pta_size_i, pta_size_j
+
+ pta_size_i = SIZE(pta,1)
+ pta_size_j = SIZE(pta,2)
+
+ ! check if the current size of pta is equal to the current expected dimension
+ IF (pta_size_i .ne. jpi) THEN
+ ALLOCATE (zpta(jpi, jpj, jpk))
+ offset = abs((jpi - pta_size_i) / 2)
+
+ IF (pta_size_i .lt. jpi) THEN
+ zpta (offset+1 : offset+pta_size_i, offset+1 : offset+pta_size_j, :) = pta
+ ELSE
+ zpta = pta(offset+1 : offset+jpi, offset+1 : offset+jpj, :)
+ END IF
+ CALL lbc_lnk( 'halo_mng_resize_3D', zpta, cdna, psgn, pfillval=fillval)
+ DEALLOCATE(pta)
+ pta => zpta
+ END IF
+
+ END SUBROUTINE halo_mng_resize_3D
+
+ SUBROUTINE halo_mng_resize_4D(pta, cdna, psgn, fillval, fjpt)
+
+ REAL(wp), POINTER, DIMENSION(:,:,:,:) :: pta
+ CHARACTER(len=1), INTENT(in) :: cdna
+ REAL(wp), INTENT(in) :: psgn
+ REAL(wp), OPTIONAL, INTENT(in) :: fillval
+ INTEGER , INTENT(in) :: fjpt
+ REAL(wp), POINTER, DIMENSION(:,:,:,:) :: zpta
+ INTEGER :: offset
+ INTEGER :: pta_size_i, pta_size_j
+
+ pta_size_i = SIZE(pta,1)
+ pta_size_j = SIZE(pta,2)
+
+ ! check if the current size of pta is equal to the current expected dimension
+ IF (pta_size_i .ne. jpi) THEN
+ ALLOCATE (zpta(jpi, jpj, jpk, jpt))
+ offset = abs((jpi - pta_size_i) / 2)
+
+ IF (pta_size_i .lt. jpi) THEN
+ zpta (offset+1 : offset+pta_size_i, offset+1 : offset+pta_size_j, :, :) = pta
+ ELSE
+ zpta = pta(offset+1 : offset+jpi, offset+1 : offset+jpj, :, :)
+ END IF
+ CALL lbc_lnk( 'halo_mng_resize_4D', zpta(:,:,:,fjpt), cdna, psgn, pfillval=fillval)
+ DEALLOCATE(pta)
+ pta => zpta
+ END IF
+
+ END SUBROUTINE halo_mng_resize_4D
+
+ SUBROUTINE halo_mng_resize_5D(pta, cdna, psgn, fillval, kjpt, fjpt)
+
+ REAL(wp), POINTER, DIMENSION(:,:,:,:,:) :: pta
+ CHARACTER(len=1), INTENT(in) :: cdna
+ REAL(wp), INTENT(in) :: psgn
+ REAL(wp), OPTIONAL, INTENT(in) :: fillval
+ INTEGER , OPTIONAL, INTENT(in) :: kjpt ! number of tracers
+ INTEGER , INTENT(in) :: fjpt
+ REAL(wp), POINTER, DIMENSION(:,:,:,:,:) :: zpta
+ INTEGER :: offset
+ INTEGER :: pta_size_i, pta_size_j
+
+ pta_size_i = SIZE(pta,1)
+ pta_size_j = SIZE(pta,2)
+
+ ! check if the current size of pta is equal to the current expected dimension
+ IF (pta_size_i .ne. jpi) THEN
+ ALLOCATE (zpta(jpi, jpj, jpk, kjpt, jpt))
+ offset = abs((jpi - pta_size_i) / 2)
+
+ IF (pta_size_i .lt. jpi) THEN
+ zpta (offset+1 : offset+pta_size_i, offset+1 : offset+pta_size_j, :, :, :) = pta
+ ELSE
+ zpta = pta(offset+1 : offset+jpi, offset+1 : offset+jpj, :, :, :)
+ END IF
+ CALL lbc_lnk( 'halo_mng_resize_5D', zpta(:,:,:,:,fjpt), cdna, psgn, pfillval=fillval)
+ DEALLOCATE(pta)
+ pta => zpta
+ END IF
+
+ END SUBROUTINE halo_mng_resize_5D
+
+END MODULE
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/lbc_lnk_multi_generic.h90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/lbc_lnk_multi_generic.h90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/lbc_lnk_multi_generic.h90 (revision 13540)
@@ -1,40 +1,63 @@
-#if defined DIM_2d
-# define ARRAY_TYPE(i,j,k,l) REAL(wp), DIMENSION(i,j)
-# define PTR_TYPE TYPE(PTR_2D)
-# define PTR_ptab pt2d
-#endif
-#if defined DIM_3d
-# define ARRAY_TYPE(i,j,k,l) REAL(wp), DIMENSION(i,j,k)
-# define PTR_TYPE TYPE(PTR_3D)
-# define PTR_ptab pt3d
-#endif
-#if defined DIM_4d
-# define ARRAY_TYPE(i,j,k,l) REAL(wp), DIMENSION(i,j,k,l)
-# define PTR_TYPE TYPE(PTR_4D)
-# define PTR_ptab pt4d
+#if defined SINGLE_PRECISION
+# if defined DIM_2d
+# define ARRAY_TYPE(i,j,k,l) REAL(sp), DIMENSION(i,j)
+# define PTR_TYPE TYPE(PTR_2D_sp)
+# define PTR_ptab pt2d
+# endif
+# if defined DIM_3d
+# define ARRAY_TYPE(i,j,k,l) REAL(sp), DIMENSION(i,j,k)
+# define PTR_TYPE TYPE(PTR_3D_sp)
+# define PTR_ptab pt3d
+# endif
+# if defined DIM_4d
+# define ARRAY_TYPE(i,j,k,l) REAL(sp), DIMENSION(i,j,k,l)
+# define PTR_TYPE TYPE(PTR_4D_sp)
+# define PTR_ptab pt4d
+# endif
+# define PRECISION sp
+#else
+# if defined DIM_2d
+# define ARRAY_TYPE(i,j,k,l) REAL(dp), DIMENSION(i,j)
+# define PTR_TYPE TYPE(PTR_2D_dp)
+# define PTR_ptab pt2d
+# endif
+# if defined DIM_3d
+# define ARRAY_TYPE(i,j,k,l) REAL(dp), DIMENSION(i,j,k)
+# define PTR_TYPE TYPE(PTR_3D_dp)
+# define PTR_ptab pt3d
+# endif
+# if defined DIM_4d
+# define ARRAY_TYPE(i,j,k,l) REAL(dp), DIMENSION(i,j,k,l)
+# define PTR_TYPE TYPE(PTR_4D_dp)
+# define PTR_ptab pt4d
+# endif
+# define PRECISION dp
#endif
- SUBROUTINE ROUTINE_MULTI( cdname &
- & , pt1, cdna1, psgn1, pt2 , cdna2 , psgn2 , pt3 , cdna3 , psgn3 , pt4, cdna4, psgn4 &
- & , pt5, cdna5, psgn5, pt6 , cdna6 , psgn6 , pt7 , cdna7 , psgn7 , pt8, cdna8, psgn8 &
- & , pt9, cdna9, psgn9, pt10, cdna10, psgn10, pt11, cdna11, psgn11 &
- & , kfillmode, pfillval, lsend, lrecv, ihlcom )
+ SUBROUTINE ROUTINE_MULTI( cdname &
+ & , pt1 , cdna1 , psgn1 , pt2 , cdna2 , psgn2 , pt3 , cdna3 , psgn3 , pt4 , cdna4 , psgn4 &
+ & , pt5 , cdna5 , psgn5 , pt6 , cdna6 , psgn6 , pt7 , cdna7 , psgn7 , pt8 , cdna8 , psgn8 &
+ & , pt9 , cdna9 , psgn9 , pt10, cdna10, psgn10, pt11, cdna11, psgn11, pt12, cdna12, psgn12 &
+ & , pt13, cdna13, psgn13, pt14, cdna14, psgn14, pt15, cdna15, psgn15, pt16, cdna16, psgn16 &
+ & , kfillmode, pfillval, lsend, lrecv )
!!---------------------------------------------------------------------
- CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine
- ARRAY_TYPE(:,:,:,:) , TARGET, INTENT(inout) :: pt1 ! arrays on which the lbc is applied
- ARRAY_TYPE(:,:,:,:), OPTIONAL, TARGET, INTENT(inout) :: pt2 , pt3 , pt4 , pt5 , pt6 , pt7 , pt8 , pt9 , pt10 , pt11
- 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
- REAL(wp) , INTENT(in ) :: psgn1 ! sign used across the north fold
- REAL(wp) , OPTIONAL , INTENT(in ) :: psgn2, psgn3, psgn4, psgn5, psgn6, psgn7, psgn8, psgn9, psgn10, psgn11
- INTEGER , OPTIONAL , INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant)
- REAL(wp) , OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries)
- LOGICAL, DIMENSION(4), OPTIONAL , INTENT(in ) :: lsend, lrecv ! indicate how communications are to be carried out
- INTEGER , OPTIONAL , INTENT(in ) :: ihlcom ! number of ranks and rows to be communicated
+ CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine
+ ARRAY_TYPE(:,:,:,:) , TARGET, INTENT(inout) :: pt1 ! arrays on which the lbc is applied
+ ARRAY_TYPE(:,:,:,:) , OPTIONAL, TARGET, INTENT(inout) :: pt2 , pt3 , pt4 , pt5 , pt6 , pt7 , pt8 , pt9 , &
+ & pt10 , pt11 , pt12 , pt13 , pt14 , pt15 , pt16
+ 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
+ REAL(wp) , INTENT(in ) :: psgn1 ! sign used across the north fold
+ REAL(wp) , OPTIONAL , INTENT(in ) :: psgn2 , psgn3 , psgn4 , psgn5 , psgn6 , psgn7 , psgn8 , psgn9, &
+ & psgn10, psgn11, psgn12, psgn13, psgn14, psgn15, psgn16
+ INTEGER , OPTIONAL , INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant)
+ REAL(wp) , OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries)
+ LOGICAL, DIMENSION(4), OPTIONAL , INTENT(in ) :: lsend, lrecv ! indicate how communications are to be carried out
!!
INTEGER :: kfld ! number of elements that will be attributed
- PTR_TYPE , DIMENSION(11) :: ptab_ptr ! pointer array
- CHARACTER(len=1) , DIMENSION(11) :: cdna_ptr ! nature of ptab_ptr grid-points
- REAL(wp) , DIMENSION(11) :: psgn_ptr ! sign used across the north fold boundary
+ PTR_TYPE , DIMENSION(16) :: ptab_ptr ! pointer array
+ CHARACTER(len=1) , DIMENSION(16) :: cdna_ptr ! nature of ptab_ptr grid-points
+ REAL(wp) , DIMENSION(16) :: psgn_ptr ! sign used across the north fold boundary
!!---------------------------------------------------------------------
!
@@ -55,6 +78,11 @@
IF( PRESENT(psgn10) ) CALL ROUTINE_LOAD( pt10, cdna10, psgn10, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
IF( PRESENT(psgn11) ) CALL ROUTINE_LOAD( pt11, cdna11, psgn11, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
+ IF( PRESENT(psgn12) ) CALL ROUTINE_LOAD( pt12, cdna12, psgn12, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
+ IF( PRESENT(psgn13) ) CALL ROUTINE_LOAD( pt13, cdna13, psgn13, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
+ IF( PRESENT(psgn14) ) CALL ROUTINE_LOAD( pt14, cdna14, psgn14, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
+ IF( PRESENT(psgn15) ) CALL ROUTINE_LOAD( pt15, cdna15, psgn15, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
+ IF( PRESENT(psgn16) ) CALL ROUTINE_LOAD( pt16, cdna16, psgn16, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
!
- CALL lbc_lnk_ptr ( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, lsend, lrecv, ihlcom )
+ CALL lbc_lnk_ptr( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, lsend, lrecv )
!
END SUBROUTINE ROUTINE_MULTI
@@ -79,4 +107,5 @@
END SUBROUTINE ROUTINE_LOAD
+#undef PRECISION
#undef ARRAY_TYPE
#undef PTR_TYPE
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/lbc_nfd_ext_generic.h90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/lbc_nfd_ext_generic.h90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/lbc_nfd_ext_generic.h90 (revision 13540)
@@ -8,5 +8,11 @@
# define L_SIZE(ptab) 1
#endif
-#define ARRAY_TYPE(i,j,k,l,f) REAL(wp),INTENT(inout)::ARRAY_IN(i,j,k,l,f)
+#if defined SINGLE_PRECISION
+# define ARRAY_TYPE(i,j,k,l,f) REAL(sp),INTENT(inout)::ARRAY_IN(i,j,k,l,f)
+# define PRECISION sp
+#else
+# define ARRAY_TYPE(i,j,k,l,f) REAL(dp),INTENT(inout)::ARRAY_IN(i,j,k,l,f)
+# define PRECISION dp
+#endif
SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kextj )
@@ -28,5 +34,5 @@
!
SELECT CASE ( jpni )
- CASE ( 1 ) ; ipj = nlcj ! 1 proc only along the i-direction
+ CASE ( 1 ) ; ipj = jpj ! 1 proc only along the i-direction
CASE DEFAULT ; ipj = 4 ! several proc along the i-direction
END SELECT
@@ -149,4 +155,5 @@
END SUBROUTINE ROUTINE_NFD
+#undef PRECISION
#undef ARRAY_TYPE
#undef ARRAY_IN
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/lbc_nfd_generic.h90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/lbc_nfd_generic.h90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/lbc_nfd_generic.h90 (revision 13540)
@@ -4,18 +4,33 @@
# define F_SIZE(ptab) kfld
# if defined DIM_2d
-# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D),INTENT(inout)::ptab(f)
+# if defined SINGLE_PRECISION
+# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_sp),INTENT(inout)::ptab(f)
+# else
+# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_dp),INTENT(inout)::ptab(f)
+# endif
# define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j)
+# define J_SIZE(ptab) SIZE(ptab(1)%pt2d,2)
# define K_SIZE(ptab) 1
# define L_SIZE(ptab) 1
# endif
# if defined DIM_3d
-# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D),INTENT(inout)::ptab(f)
+# if defined SINGLE_PRECISION
+# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_sp),INTENT(inout)::ptab(f)
+# else
+# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_dp),INTENT(inout)::ptab(f)
+# endif
# define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k)
+# define J_SIZE(ptab) SIZE(ptab(1)%pt3d,2)
# define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3)
# define L_SIZE(ptab) 1
# endif
# if defined DIM_4d
-# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D),INTENT(inout)::ptab(f)
+# if defined SINGLE_PRECISION
+# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_sp),INTENT(inout)::ptab(f)
+# else
+# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_dp),INTENT(inout)::ptab(f)
+# endif
# define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l)
+# define J_SIZE(ptab) SIZE(ptab(1)%pt4d,2)
# define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3)
# define L_SIZE(ptab) SIZE(ptab(1)%pt4d,4)
@@ -28,4 +43,5 @@
# if defined DIM_2d
# define ARRAY_IN(i,j,k,l,f) ptab(i,j)
+# define J_SIZE(ptab) SIZE(ptab,2)
# define K_SIZE(ptab) 1
# define L_SIZE(ptab) 1
@@ -33,4 +49,5 @@
# if defined DIM_3d
# define ARRAY_IN(i,j,k,l,f) ptab(i,j,k)
+# define J_SIZE(ptab) SIZE(ptab,2)
# define K_SIZE(ptab) SIZE(ptab,3)
# define L_SIZE(ptab) 1
@@ -38,9 +55,20 @@
# if defined DIM_4d
# define ARRAY_IN(i,j,k,l,f) ptab(i,j,k,l)
+# define J_SIZE(ptab) SIZE(ptab,2)
# define K_SIZE(ptab) SIZE(ptab,3)
# define L_SIZE(ptab) SIZE(ptab,4)
# endif
-# define ARRAY_TYPE(i,j,k,l,f) REAL(wp),INTENT(inout)::ARRAY_IN(i,j,k,l,f)
+# if defined SINGLE_PRECISION
+# define ARRAY_TYPE(i,j,k,l,f) REAL(sp),INTENT(inout)::ARRAY_IN(i,j,k,l,f)
+# else
+# define ARRAY_TYPE(i,j,k,l,f) REAL(dp),INTENT(inout)::ARRAY_IN(i,j,k,l,f)
+# endif
#endif
+
+# if defined SINGLE_PRECISION
+# define PRECISION sp
+# else
+# define PRECISION dp
+# endif
#if defined MULTI
@@ -54,20 +82,13 @@
REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary
!
- INTEGER :: ji, jj, jk, jl, jh, jf ! dummy loop indices
- INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array
- INTEGER :: ijt, iju, ipjm1
+ INTEGER :: ji, jj, jk, jl, jf ! dummy loop indices
+ INTEGER :: ipj, ipk, ipl, ipf ! dimension of the input array
+ INTEGER :: ii1, ii2, ij1, ij2
!!----------------------------------------------------------------------
!
- ipk = K_SIZE(ptab) ! 3rd dimension
+ ipj = J_SIZE(ptab) ! 2nd dimension
+ ipk = K_SIZE(ptab) ! 3rd -
ipl = L_SIZE(ptab) ! 4th -
ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers)
- !
- !
- SELECT CASE ( jpni )
- CASE ( 1 ) ; ipj = nlcj ! 1 proc only along the i-direction
- CASE DEFAULT ; ipj = 4 ! several proc along the i-direction
- END SELECT
- ipjm1 = ipj-1
-
!
DO jf = 1, ipf ! Loop on the number of arrays to be treated
@@ -79,40 +100,166 @@
SELECT CASE ( NAT_IN(jf) )
CASE ( 'T' , 'W' ) ! T-, W-point
- DO ji = 2, jpiglo
- ijt = jpiglo-ji+2
- ARRAY_IN(ji,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-2,:,:,jf)
- END DO
- ARRAY_IN(1,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(3,ipj-2,:,:,jf)
- DO ji = jpiglo/2+1, jpiglo
- ijt = jpiglo-ji+2
- ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipjm1,:,:,jf)
- END DO
+ DO jl = 1, ipl; DO jk = 1, ipk
+ !
+ ! last nn_hls lines (from ipj to ipj-nn_hls+1) : full
+ DO jj = 1, nn_hls
+ ij1 = ipj - jj + 1 ! ends at: ipj - nn_hls + 1
+ ij2 = ipj - 2*nn_hls + jj - 1 ! ends at: ipj - 2*nn_hls + nn_hls - 1 = ipj - nn_hls - 1
+ !
+ DO ji = 1, nn_hls ! first nn_hls points
+ ii1 = ji ! ends at: nn_hls
+ ii2 = 2*nn_hls + 2 - ji ! ends at: 2*nn_hls + 2 - nn_hls = nn_hls + 2
+ ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)
+ END DO
+ DO ji = 1, 1 ! point nn_hls+1
+ ii1 = nn_hls + ji
+ ii2 = ii1
+ ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)
+ END DO
+ DO ji = 1, Ni0glo - 1 ! points from nn_hls+2 to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls)
+ ii1 = 2 + nn_hls + ji - 1 ! ends at: 2 + nn_hls + jpiglo - 2*nn_hls - 1 - 1 = jpiglo - nn_hls
+ ii2 = jpiglo - nn_hls - ji + 1 ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls - 1 ) + 1 = nn_hls + 2
+ ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)
+ END DO
+ DO ji = 1, 1 ! point jpiglo - nn_hls + 1
+ ii1 = jpiglo - nn_hls + ji
+ ii2 = nn_hls + ji
+ ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)
+ END DO
+ DO ji = 1, nn_hls-1 ! last nn_hls-1 points
+ ii1 = jpiglo - nn_hls + 1 + ji ! ends at: jpiglo - nn_hls + 1 + nn_hls - 1 = jpiglo
+ ii2 = jpiglo - nn_hls + 1 - ji ! ends at: jpiglo - nn_hls + 1 - nn_hls + 1 = jpiglo - 2*nn_hls + 2
+ ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)
+ END DO
+ END DO
+ !
+ ! line number ipj-nn_hls : right half
+ DO jj = 1, 1
+ ij1 = ipj - nn_hls
+ ij2 = ij1 ! same line
+ !
+ DO ji = 1, Ni0glo/2-1 ! points from jpiglo/2+2 to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls)
+ ii1 = jpiglo/2 + ji + 1 ! ends at: jpiglo/2 + (jpiglo/2 - nn_hls - 1) + 1 = jpiglo - nn_hls
+ ii2 = jpiglo/2 - ji + 1 ! ends at: jpiglo/2 - (jpiglo/2 - nn_hls - 1) + 1 = nn_hls + 2
+ ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)
+ END DO
+ DO ji = 1, nn_hls ! first nn_hls points: redo them just in case (if e-w periodocity already done)
+ ! ! as we just changed points jpiglo-2nn_hls+1 to jpiglo-nn_hls
+ ii1 = ji ! ends at: nn_hls
+ ii2 = 2*nn_hls + 2 - ji ! ends at: 2*nn_hls + 2 - nn_hls = nn_hls + 2
+ ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)
+ END DO
+ ! ! last nn_hls-1 points: have been / will done by e-w periodicity
+ END DO
+ !
+ END DO; END DO
CASE ( 'U' ) ! U-point
- DO ji = 1, jpiglo-1
- iju = jpiglo-ji+1
- ARRAY_IN(ji,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-2,:,:,jf)
- END DO
- ARRAY_IN( 1 ,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN( 2 ,ipj-2,:,:,jf)
- ARRAY_IN(jpiglo,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpiglo-1,ipj-2,:,:,jf)
- DO ji = jpiglo/2, jpiglo-1
- iju = jpiglo-ji+1
- ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipjm1,:,:,jf)
- END DO
+ DO jl = 1, ipl; DO jk = 1, ipk
+ !
+ ! last nn_hls lines (from ipj to ipj-nn_hls+1) : full
+ DO jj = 1, nn_hls
+ ij1 = ipj - jj + 1 ! ends at: ipj - nn_hls + 1
+ ij2 = ipj - 2*nn_hls + jj - 1 ! ends at: ipj - 2*nn_hls + nn_hls - 1 = ipj - nn_hls - 1
+ !
+ DO ji = 1, nn_hls ! first nn_hls points
+ ii1 = ji ! ends at: nn_hls
+ ii2 = 2*nn_hls + 1 - ji ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1
+ ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)
+ END DO
+ DO ji = 1, Ni0glo ! points from nn_hls to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls)
+ ii1 = nn_hls + ji ! ends at: nn_hls + jpiglo - 2*nn_hls = jpiglo - nn_hls
+ ii2 = jpiglo - nn_hls - ji + 1 ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls ) + 1 = nn_hls + 1
+ ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)
+ END DO
+ DO ji = 1, nn_hls ! last nn_hls points
+ ii1 = jpiglo - nn_hls + ji ! ends at: jpiglo - nn_hls + nn_hls = jpiglo
+ ii2 = jpiglo - nn_hls + 1 - ji ! ends at: jpiglo - nn_hls + 1 - nn_hls = jpiglo - 2*nn_hls + 1
+ ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)
+ END DO
+ END DO
+ !
+ ! line number ipj-nn_hls : right half
+ DO jj = 1, 1
+ ij1 = ipj - nn_hls
+ ij2 = ij1 ! same line
+ !
+ DO ji = 1, Ni0glo/2 ! points from jpiglo/2+1 to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls)
+ ii1 = jpiglo/2 + ji ! ends at: jpiglo/2 + (jpiglo/2 - nn_hls) = jpiglo - nn_hls
+ ii2 = jpiglo/2 - ji + 1 ! ends at: jpiglo/2 - (jpiglo/2 - nn_hls) + 1 = nn_hls + 1
+ ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)
+ END DO
+ DO ji = 1, nn_hls ! first nn_hls points: redo them just in case (if e-w periodocity already done)
+ ! ! as we just changed points jpiglo-2nn_hls+1 to jpiglo-nn_hls
+ ii1 = ji ! ends at: nn_hls
+ ii2 = 2*nn_hls + 1 - ji ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1
+ ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)
+ END DO
+ ! ! last nn_hls-1 points: have been / will done by e-w periodicity
+ END DO
+ !
+ END DO; END DO
CASE ( 'V' ) ! V-point
- DO ji = 2, jpiglo
- ijt = jpiglo-ji+2
- ARRAY_IN(ji,ipj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-2,:,:,jf)
- ARRAY_IN(ji,ipj ,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-3,:,:,jf)
- END DO
- ARRAY_IN(1,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(3,ipj-3,:,:,jf)
+ DO jl = 1, ipl; DO jk = 1, ipk
+ !
+ ! last nn_hls+1 lines (from ipj to ipj-nn_hls) : full
+ DO jj = 1, nn_hls+1
+ ij1 = ipj - jj + 1 ! ends at: ipj - ( nn_hls + 1 ) + 1 = ipj - nn_hls
+ ij2 = ipj - 2*nn_hls + jj - 2 ! ends at: ipj - 2*nn_hls + nn_hls + 1 - 2 = ipj - nn_hls - 1
+ !
+ DO ji = 1, nn_hls ! first nn_hls points
+ ii1 = ji ! ends at: nn_hls
+ ii2 = 2*nn_hls + 2 - ji ! ends at: 2*nn_hls + 2 - nn_hls = nn_hls + 2
+ ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)
+ END DO
+ DO ji = 1, 1 ! point nn_hls+1
+ ii1 = nn_hls + ji
+ ii2 = ii1
+ ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)
+ END DO
+ DO ji = 1, Ni0glo - 1 ! points from nn_hls+2 to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls)
+ ii1 = 2 + nn_hls + ji - 1 ! ends at: 2 + nn_hls + jpiglo - 2*nn_hls - 1 - 1 = jpiglo - nn_hls
+ ii2 = jpiglo - nn_hls - ji + 1 ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls - 1 ) + 1 = nn_hls + 2
+ ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)
+ END DO
+ DO ji = 1, 1 ! point jpiglo - nn_hls + 1
+ ii1 = jpiglo - nn_hls + ji
+ ii2 = nn_hls + ji
+ ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)
+ END DO
+ DO ji = 1, nn_hls-1 ! last nn_hls-1 points
+ ii1 = jpiglo - nn_hls + 1 + ji ! ends at: jpiglo - nn_hls + 1 + nn_hls - 1 = jpiglo
+ ii2 = jpiglo - nn_hls + 1 - ji ! ends at: jpiglo - nn_hls + 1 - nn_hls + 1 = jpiglo - 2*nn_hls + 2
+ ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)
+ END DO
+ END DO
+ !
+ END DO; END DO
CASE ( 'F' ) ! F-point
- DO ji = 1, jpiglo-1
- iju = jpiglo-ji+1
- ARRAY_IN(ji,ipj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-2,:,:,jf)
- ARRAY_IN(ji,ipj ,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-3,:,:,jf)
- END DO
- ARRAY_IN( 1 ,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN( 2 ,ipj-3,:,:,jf)
- ARRAY_IN(jpiglo,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpiglo-1,ipj-3,:,:,jf)
- END SELECT
+ DO jl = 1, ipl; DO jk = 1, ipk
+ !
+ ! last nn_hls+1 lines (from ipj to ipj-nn_hls) : full
+ DO jj = 1, nn_hls+1
+ ij1 = ipj - jj + 1 ! ends at: ipj - ( nn_hls + 1 ) + 1 = ipj - nn_hls
+ ij2 = ipj - 2*nn_hls + jj - 2 ! ends at: ipj - 2*nn_hls + nn_hls + 1 - 2 = ipj - nn_hls - 1
+ !
+ DO ji = 1, nn_hls ! first nn_hls points
+ ii1 = ji ! ends at: nn_hls
+ ii2 = 2*nn_hls + 1 - ji ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1
+ ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)
+ END DO
+ DO ji = 1, Ni0glo ! points from nn_hls to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls)
+ ii1 = nn_hls + ji ! ends at: nn_hls + jpiglo - 2*nn_hls = jpiglo - nn_hls
+ ii2 = jpiglo - nn_hls - ji + 1 ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls ) + 1 = nn_hls + 1
+ ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)
+ END DO
+ DO ji = 1, nn_hls ! last nn_hls points
+ ii1 = jpiglo - nn_hls + ji ! ends at: jpiglo - nn_hls + nn_hls = jpiglo
+ ii2 = jpiglo - nn_hls + 1 - ji ! ends at: jpiglo - nn_hls + 1 - nn_hls = jpiglo - 2*nn_hls + 1
+ ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)
+ END DO
+ END DO
+ !
+ END DO; END DO
+ END SELECT ! NAT_IN(jf)
!
CASE ( 5 , 6 ) ! * North fold F-point pivot
@@ -120,55 +267,202 @@
SELECT CASE ( NAT_IN(jf) )
CASE ( 'T' , 'W' ) ! T-, W-point
- DO ji = 1, jpiglo
- ijt = jpiglo-ji+1
- ARRAY_IN(ji,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-1,:,:,jf)
- END DO
+ DO jl = 1, ipl; DO jk = 1, ipk
+ !
+ ! first: line number ipj-nn_hls : 3 points
+ DO jj = 1, 1
+ ij1 = ipj - nn_hls
+ ij2 = ij1 ! same line
+ !
+ DO ji = 1, 1 ! points from jpiglo/2+1
+ ii1 = jpiglo/2 + ji
+ ii2 = jpiglo/2 - ji + 1
+ ARRAY_IN(ii1,ij1,jk,jl,jf) = ARRAY_IN(ii2,ij2,jk,jl,jf) ! Warning: pb with sign...
+ END DO
+ DO ji = 1, 1 ! points jpiglo - nn_hls
+ ii1 = jpiglo - nn_hls + ji - 1
+ ii2 = nn_hls + ji
+ ARRAY_IN(ii1,ij1,jk,jl,jf) = ARRAY_IN(ii2,ij2,jk,jl,jf) ! Warning: pb with sign...
+ END DO
+ DO ji = 1, 1 ! point nn_hls: redo it just in case (if e-w periodocity already done)
+ ! ! as we just changed point jpiglo - nn_hls
+ ii1 = nn_hls + ji - 1
+ ii2 = nn_hls + ji
+ ARRAY_IN(ii1,ij1,jk,jl,jf) = ARRAY_IN(ii2,ij2,jk,jl,jf) ! Warning: pb with sign...
+ END DO
+ END DO
+ !
+ ! Second: last nn_hls lines (from ipj to ipj-nn_hls+1) : full
+ DO jj = 1, nn_hls
+ ij1 = ipj + 1 - jj ! ends at: ipj + 1 - nn_hls
+ ij2 = ipj - 2*nn_hls + jj ! ends at: ipj - 2*nn_hls + nn_hls = ipj - nn_hls
+ !
+ DO ji = 1, nn_hls ! first nn_hls points
+ ii1 = ji ! ends at: nn_hls
+ ii2 = 2*nn_hls + 1 - ji ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1
+ ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)
+ END DO
+ DO ji = 1, Ni0glo ! points from nn_hls to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls)
+ ii1 = nn_hls + ji ! ends at: nn_hls + jpiglo - 2*nn_hls = jpiglo - nn_hls
+ ii2 = jpiglo - nn_hls - ji + 1 ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls ) + 1 = nn_hls + 1
+ ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)
+ END DO
+ DO ji = 1, nn_hls ! last nn_hls points
+ ii1 = jpiglo - nn_hls + ji ! ends at: jpiglo - nn_hls + nn_hls = jpiglo
+ ii2 = jpiglo - nn_hls + 1 - ji ! ends at: jpiglo - nn_hls + 1 - nn_hls = jpiglo - 2*nn_hls + 1
+ ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)
+ END DO
+ END DO
+ !
+ END DO; END DO
CASE ( 'U' ) ! U-point
- DO ji = 1, jpiglo-1
- iju = jpiglo-ji
- ARRAY_IN(ji,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-1,:,:,jf)
- END DO
- ARRAY_IN(jpiglo,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpiglo-2,ipj-1,:,:,jf)
+ DO jl = 1, ipl; DO jk = 1, ipk
+ !
+ ! last nn_hls lines (from ipj to ipj-nn_hls+1) : full
+ DO jj = 1, nn_hls
+ ij1 = ipj + 1 - jj ! ends at: ipj + 1 - nn_hls
+ ij2 = ipj - 2*nn_hls + jj ! ends at: ipj - 2*nn_hls + nn_hls = ipj - nn_hls
+ !
+ DO ji = 1, nn_hls-1 ! first nn_hls-1 points
+ ii1 = ji ! ends at: nn_hls-1
+ ii2 = 2*nn_hls - ji ! ends at: 2*nn_hls - ( nn_hls - 1 ) = nn_hls + 1
+ ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)
+ END DO
+ DO ji = 1, 1 ! point nn_hls
+ ii1 = nn_hls + ji - 1
+ ii2 = jpiglo - ii1
+ ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)
+ END DO
+ DO ji = 1, Ni0glo - 1 ! points from nn_hls+1 to jpiglo - nn_hls - 1 (note: Ni0glo = jpiglo - 2*nn_hls)
+ ii1 = nn_hls + ji ! ends at: nn_hls + ( jpiglo - 2*nn_hls - 1 ) = jpiglo - nn_hls - 1
+ ii2 = jpiglo - nn_hls - ji ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls - 1 ) = nn_hls + 1
+ ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)
+ END DO
+ DO ji = 1, 1 ! point jpiglo - nn_hls
+ ii1 = jpiglo - nn_hls + ji - 1
+ ii2 = ii1
+ ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)
+ END DO
+ DO ji = 1, nn_hls ! last nn_hls points
+ ii1 = jpiglo - nn_hls + ji ! ends at: jpiglo - nn_hls + nn_hls = jpiglo
+ ii2 = jpiglo - nn_hls - ji ! ends at: jpiglo - nn_hls - nn_hls = jpiglo - 2*nn_hls
+ ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)
+ END DO
+ END DO
+ !
+ END DO; END DO
CASE ( 'V' ) ! V-point
- DO ji = 1, jpiglo
- ijt = jpiglo-ji+1
- ARRAY_IN(ji,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-2,:,:,jf)
- END DO
- DO ji = jpiglo/2+1, jpiglo
- ijt = jpiglo-ji+1
- ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipjm1,:,:,jf)
- END DO
+ DO jl = 1, ipl; DO jk = 1, ipk
+ !
+ ! last nn_hls lines (from ipj to ipj-nn_hls+1) : full
+ DO jj = 1, nn_hls
+ ij1 = ipj - jj + 1 ! ends at: ipj - nn_hls + 1
+ ij2 = ipj - 2*nn_hls + jj - 1 ! ends at: ipj - 2*nn_hls + nn_hls - 1 = ipj - nn_hls - 1
+ !
+ DO ji = 1, nn_hls ! first nn_hls points
+ ii1 = ji ! ends at: nn_hls
+ ii2 = 2*nn_hls + 1 - ji ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1
+ ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)
+ END DO
+ DO ji = 1, Ni0glo ! points from nn_hls to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls)
+ ii1 = nn_hls + ji ! ends at: nn_hls + jpiglo - 2*nn_hls = jpiglo - nn_hls
+ ii2 = jpiglo - nn_hls - ji + 1 ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls ) + 1 = nn_hls + 1
+ ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)
+ END DO
+ DO ji = 1, nn_hls ! last nn_hls points
+ ii1 = jpiglo - nn_hls + ji ! ends at: jpiglo - nn_hls + nn_hls = jpiglo
+ ii2 = jpiglo - nn_hls + 1 - ji ! ends at: jpiglo - nn_hls + 1 - nn_hls = jpiglo - 2*nn_hls + 1
+ ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)
+ END DO
+ END DO
+ !
+ ! line number ipj-nn_hls : right half
+ DO jj = 1, 1
+ ij1 = ipj - nn_hls
+ ij2 = ij1 ! same line
+ !
+ DO ji = 1, Ni0glo/2 ! points from jpiglo/2+1 to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls)
+ ii1 = jpiglo/2 + ji ! ends at: jpiglo/2 + (jpiglo/2 - nn_hls) = jpiglo - nn_hls
+ ii2 = jpiglo/2 - ji + 1 ! ends at: jpiglo/2 - (jpiglo/2 - nn_hls) + 1 = nn_hls + 1
+ ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)
+ END DO
+ DO ji = 1, nn_hls ! first nn_hls points: redo them just in case (if e-w periodocity already done)
+ ! ! as we just changed points jpiglo-2nn_hls+1 to jpiglo-nn_hls
+ ii1 = ji ! ends at: nn_hls
+ ii2 = 2*nn_hls + 1 - ji ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1
+ ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)
+ END DO
+ ! ! last nn_hls points: have been / will done by e-w periodicity
+ END DO
+ !
+ END DO; END DO
CASE ( 'F' ) ! F-point
- DO ji = 1, jpiglo-1
- iju = jpiglo-ji
- ARRAY_IN(ji,ipj ,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-2,:,:,jf)
- END DO
- ARRAY_IN(jpiglo,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpiglo-2,ipj-2,:,:,jf)
- DO ji = jpiglo/2+1, jpiglo-1
- iju = jpiglo-ji
- ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipjm1,:,:,jf)
- END DO
- END SELECT
+ DO jl = 1, ipl; DO jk = 1, ipk
+ !
+ ! last nn_hls lines (from ipj to ipj-nn_hls+1) : full
+ DO jj = 1, nn_hls
+ ij1 = ipj - jj + 1 ! ends at: ipj - nn_hls + 1
+ ij2 = ipj - 2*nn_hls + jj - 1 ! ends at: ipj - 2*nn_hls + nn_hls - 1 = ipj - nn_hls - 1
+ !
+ DO ji = 1, nn_hls-1 ! first nn_hls-1 points
+ ii1 = ji ! ends at: nn_hls-1
+ ii2 = 2*nn_hls - ji ! ends at: 2*nn_hls - ( nn_hls - 1 ) = nn_hls + 1
+ ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)
+ END DO
+ DO ji = 1, 1 ! point nn_hls
+ ii1 = nn_hls + ji - 1
+ ii2 = jpiglo - ii1
+ ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)
+ END DO
+ DO ji = 1, Ni0glo - 1 ! points from nn_hls+1 to jpiglo - nn_hls - 1 (note: Ni0glo = jpiglo - 2*nn_hls)
+ ii1 = nn_hls + ji ! ends at: nn_hls + ( jpiglo - 2*nn_hls - 1 ) = jpiglo - nn_hls - 1
+ ii2 = jpiglo - nn_hls - ji ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls - 1 ) = nn_hls + 1
+ ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)
+ END DO
+ DO ji = 1, 1 ! point jpiglo - nn_hls
+ ii1 = jpiglo - nn_hls + ji - 1
+ ii2 = ii1
+ ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)
+ END DO
+ DO ji = 1, nn_hls ! last nn_hls points
+ ii1 = jpiglo - nn_hls + ji ! ends at: jpiglo - nn_hls + nn_hls = jpiglo
+ ii2 = jpiglo - nn_hls - ji ! ends at: jpiglo - nn_hls - nn_hls = jpiglo - 2*nn_hls
+ ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)
+ END DO
+ END DO
+ !
+ ! line number ipj-nn_hls : right half
+ DO jj = 1, 1
+ ij1 = ipj - nn_hls
+ ij2 = ij1 ! same line
+ !
+ DO ji = 1, Ni0glo/2-1 ! points from jpiglo/2+1 to jpiglo - nn_hls-1 (note: Ni0glo = jpiglo - 2*nn_hls)
+ ii1 = jpiglo/2 + ji ! ends at: jpiglo/2 + (jpiglo/2 - nn_hls) = jpiglo - nn_hls
+ ii2 = jpiglo/2 - ji ! ends at: jpiglo/2 - (jpiglo/2 - nn_hls - 1 ) = nn_hls + 1
+ ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)
+ END DO
+ DO ji = 1, nn_hls-1 ! first nn_hls-1 points: redo them just in case (if e-w periodocity already done)
+ ! ! as we just changed points jpiglo-2nn_hls+1 to jpiglo-nn_hl-1
+ ii1 = ji ! ends at: nn_hls
+ ii2 = 2*nn_hls - ji ! ends at: 2*nn_hls - ( nn_hls - 1 ) = nn_hls + 1
+ ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf)
+ END DO
+ ! ! last nn_hls points: have been / will done by e-w periodicity
+ END DO
+ !
+ END DO; END DO
+ END SELECT ! NAT_IN(jf)
!
- CASE DEFAULT ! * closed : the code probably never go through
- !
- SELECT CASE ( NAT_IN(jf) )
- CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
- ARRAY_IN(:, 1 ,:,:,jf) = 0._wp
- ARRAY_IN(:,ipj,:,:,jf) = 0._wp
- CASE ( 'F' ) ! F-point
- ARRAY_IN(:,ipj,:,:,jf) = 0._wp
- END SELECT
- !
- END SELECT ! npolj
+ END SELECT ! npolj
!
- END DO
+ END DO ! ipf
!
END SUBROUTINE ROUTINE_NFD
+#undef PRECISION
#undef ARRAY_TYPE
#undef ARRAY_IN
#undef NAT_IN
#undef SGN_IN
+#undef J_SIZE
#undef K_SIZE
#undef L_SIZE
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/lbc_nfd_nogather_generic.h90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/lbc_nfd_nogather_generic.h90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/lbc_nfd_nogather_generic.h90 (revision 13540)
@@ -4,5 +4,9 @@
# define F_SIZE(ptab) kfld
# if defined DIM_2d
-# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D),INTENT(inout)::ptab(f)
+# if defined SINGLE_PRECISION
+# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_sp),INTENT(inout)::ptab(f)
+# else
+# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_dp),INTENT(inout)::ptab(f)
+# endif
# define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j)
# define K_SIZE(ptab) 1
@@ -10,5 +14,9 @@
# endif
# if defined DIM_3d
-# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D),INTENT(inout)::ptab(f)
+# if defined SINGLE_PRECISION
+# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_sp),INTENT(inout)::ptab(f)
+# else
+# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_dp),INTENT(inout)::ptab(f)
+# endif
# define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k)
# define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3)
@@ -16,10 +24,18 @@
# endif
# if defined DIM_4d
-# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D),INTENT(inout)::ptab(f)
+# if defined SINGLE_PRECISION
+# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_sp),INTENT(inout)::ptab(f)
+# else
+# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_dp),INTENT(inout)::ptab(f)
+# endif
# define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l)
# define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3)
# define L_SIZE(ptab) SIZE(ptab(1)%pt4d,4)
# endif
-# define ARRAY2_TYPE(i,j,k,l,f) TYPE(PTR_4D),INTENT(inout)::ptab2(f)
+# if defined SINGLE_PRECISION
+# define ARRAY2_TYPE(i,j,k,l,f) TYPE(PTR_4D_sp),INTENT(inout)::ptab2(f)
+# else
+# define ARRAY2_TYPE(i,j,k,l,f) TYPE(PTR_4D_dp),INTENT(inout)::ptab2(f)
+# endif
# define J_SIZE(ptab2) SIZE(ptab2(1)%pt4d,2)
# define ARRAY2_IN(i,j,k,l,f) ptab2(f)%pt4d(i,j,k,l)
@@ -44,10 +60,19 @@
# define L_SIZE(ptab) SIZE(ptab,4)
# endif
-# define ARRAY2_IN(i,j,k,l,f) ptab2(i,j,k,l)
# define J_SIZE(ptab2) SIZE(ptab2,2)
-# define ARRAY_TYPE(i,j,k,l,f) REAL(wp),INTENT(inout)::ARRAY_IN(i,j,k,l,f)
-# define ARRAY2_TYPE(i,j,k,l,f) REAL(wp),INTENT(inout)::ARRAY2_IN(i,j,k,l,f)
-#endif
-
+# define ARRAY2_IN(i,j,k,l,f) ptab2(i,j,k,l)
+# if defined SINGLE_PRECISION
+# define ARRAY_TYPE(i,j,k,l,f) REAL(sp),INTENT(inout)::ARRAY_IN(i,j,k,l,f)
+# define ARRAY2_TYPE(i,j,k,l,f) REAL(sp),INTENT(inout)::ARRAY2_IN(i,j,k,l,f)
+# else
+# define ARRAY_TYPE(i,j,k,l,f) REAL(dp),INTENT(inout)::ARRAY_IN(i,j,k,l,f)
+# define ARRAY2_TYPE(i,j,k,l,f) REAL(dp),INTENT(inout)::ARRAY2_IN(i,j,k,l,f)
+# endif
+# endif
+# ifdef SINGLE_PRECISION
+# define PRECISION sp
+# else
+# define PRECISION dp
+# endif
SUBROUTINE ROUTINE_NFD( ptab, ptab2, cd_nat, psgn, kfld )
!!----------------------------------------------------------------------
@@ -57,13 +82,13 @@
!!
!!----------------------------------------------------------------------
- ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied
- ARRAY2_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied
+ ARRAY_TYPE(:,:,:,:,:)
+ ARRAY2_TYPE(:,:,:,:,:)
CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points
REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary
INTEGER, OPTIONAL, INTENT(in ) :: kfld ! number of pt3d arrays
!
- INTEGER :: ji, jj, jk, jl, jh, jf ! dummy loop indices
- INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array
- INTEGER :: ijt, iju, ijpj, ijpjp1, ijta, ijua, jia, startloop, endloop
+ INTEGER :: ji, jj, jk, jn, ii, jl, jh, jf ! dummy loop indices
+ INTEGER :: ipi, ipj, ipk, ipl, ipf, iij, ijj ! dimension of the input array
+ INTEGER :: ijt, iju, ijta, ijua, jia, startloop, endloop
LOGICAL :: l_fast_exchanges
!!----------------------------------------------------------------------
@@ -75,8 +100,4 @@
! Security check for further developments
IF ( ipf > 1 ) CALL ctl_stop( 'STOP', 'lbc_nfd_nogather: multiple fields not allowed. Revise implementation...' )
- !
- ijpj = 1 ! index of first modified line
- ijpjp1 = 2 ! index + 1
-
! 2nd dimension determines exchange speed
IF (ipj == 1 ) THEN
@@ -95,38 +116,46 @@
!
CASE ( 'T' , 'W' ) ! T-, W-point
- IF ( nimpp /= 1 ) THEN ; startloop = 1
- ELSE ; startloop = 2
- ENDIF
- !
- DO jl = 1, ipl; DO jk = 1, ipk
- DO ji = startloop, nlci
- ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
- ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf)
+ IF ( nimpp /= 1 ) THEN ; startloop = 1
+ ELSE ; startloop = 1 + nn_hls
+ ENDIF
+ !
+ DO jl = 1, ipl; DO jk = 1, ipk
+ DO jj = 1, nn_hls
+ ijj = jpj -jj +1
+ DO ji = startloop, jpi
+ ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4
+ ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf)
+ END DO
END DO
END DO; END DO
IF( nimpp == 1 ) THEN
DO jl = 1, ipl; DO jk = 1, ipk
- ARRAY_IN(1,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(3,nlcj-2,jk,jl,jf)
- END DO; END DO
- ENDIF
- !
- IF ( .NOT. l_fast_exchanges ) THEN
- IF( nimpp >= jpiglo/2+1 ) THEN
+ DO jj = 1, nn_hls
+ ijj = jpj -jj +1
+ DO ii = 0, nn_hls-1
+ ARRAY_IN(ii+1,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(2*nn_hls-ii+1,jpj-2*nn_hls+jj-1,jk,jl,jf)
+ END DO
+ END DO
+ END DO; END DO
+ ENDIF
+ !
+ IF ( .NOT. l_fast_exchanges ) THEN
+ IF( nimpp >= Ni0glo/2+2 ) THEN
startloop = 1
- ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN
- startloop = jpiglo/2+1 - nimpp + 1
- ELSE
- startloop = nlci + 1
- ENDIF
- IF( startloop <= nlci ) THEN
+ ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN
+ startloop = Ni0glo/2+2 - nimpp + nn_hls
+ ELSE
+ startloop = jpi + 1
+ ENDIF
+ IF( startloop <= jpi ) THEN
DO jl = 1, ipl; DO jk = 1, ipk
- DO ji = startloop, nlci
- ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
+ DO ji = startloop, jpi
+ ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4
jia = ji + nimpp - 1
ijta = jpiglo - jia + 2
IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN
- ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ijta-nimpp+1,nlcj-1,jk,jl,jf)
+ ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ijta-nimpp+nn_hls,jpj-nn_hls,jk,jl,jf)
ELSE
- ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjp1,jk,jl,jf)
+ ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,nn_hls+1,jk,jl,jf)
ENDIF
END DO
@@ -134,34 +163,46 @@
ENDIF
ENDIF
-
CASE ( 'U' ) ! U-point
- IF( nimpp + nlci - 1 /= jpiglo ) THEN
- endloop = nlci
+ IF( nimpp + jpi - 1 /= jpiglo ) THEN
+ endloop = jpi
ELSE
- endloop = nlci - 1
- ENDIF
- DO jl = 1, ipl; DO jk = 1, ipk
- DO ji = 1, endloop
- iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
- ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf)
+ endloop = jpi - nn_hls
+ ENDIF
+ DO jl = 1, ipl; DO jk = 1, ipk
+ DO jj = 1, nn_hls
+ ijj = jpj -jj +1
+ DO ji = 1, endloop
+ iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3
+ ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf)
+ END DO
END DO
END DO; END DO
IF (nimpp .eq. 1) THEN
- ARRAY_IN(1,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2,nlcj-2,:,:,jf)
- ENDIF
- IF((nimpp + nlci - 1) .eq. jpiglo) THEN
- ARRAY_IN(nlci,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,nlcj-2,:,:,jf)
- ENDIF
- !
- IF ( .NOT. l_fast_exchanges ) THEN
- IF( nimpp + nlci - 1 /= jpiglo ) THEN
- endloop = nlci
- ELSE
- endloop = nlci - 1
- ENDIF
- IF( nimpp >= jpiglo/2 ) THEN
- startloop = 1
- ELSEIF( ( nimpp+nlci-1 >= jpiglo/2 ) .AND. ( nimpp < jpiglo/2 ) ) THEN
- startloop = jpiglo/2 - nimpp + 1
+ DO jj = 1, nn_hls
+ ijj = jpj -jj +1
+ DO ii = 0, nn_hls-1
+ ARRAY_IN(ii+1,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2*nn_hls-ii,jpj-2*nn_hls+jj-1,:,:,jf)
+ END DO
+ END DO
+ ENDIF
+ IF((nimpp + jpi - 1) .eq. jpiglo) THEN
+ DO jj = 1, nn_hls
+ ijj = jpj -jj +1
+ DO ii = 1, nn_hls
+ ARRAY_IN(jpi-ii+1,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpi-2*nn_hls+ii,jpj-2*nn_hls+jj-1,:,:,jf)
+ END DO
+ END DO
+ ENDIF
+ !
+ IF ( .NOT. l_fast_exchanges ) THEN
+ IF( nimpp + jpi - 1 /= jpiglo ) THEN
+ endloop = jpi
+ ELSE
+ endloop = jpi - nn_hls
+ ENDIF
+ IF( nimpp >= Ni0glo/2+1 ) THEN
+ startloop = nn_hls
+ ELSEIF( ( nimpp + jpi - 1 >= Ni0glo/2+1 ) .AND. ( nimpp < Ni0glo/2+1 ) ) THEN
+ startloop = Ni0glo/2+1 - nimpp + nn_hls
ELSE
startloop = endloop + 1
@@ -170,11 +211,11 @@
DO jl = 1, ipl; DO jk = 1, ipk
DO ji = startloop, endloop
- iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
- jia = ji + nimpp - 1
- ijua = jpiglo - jia + 1
+ iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3
+ jia = ji + nimpp - 1
+ ijua = jpiglo - jia + 1
IF( ijua >= startloop+nimpp-1 .AND. ijua < jia ) THEN
- ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ijua-nimpp+1,nlcj-1,jk,jl,jf)
+ ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ijua-nimpp+1,jpj-nn_hls,jk,jl,jf)
ELSE
- ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjp1,jk,jl,jf)
+ ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,nn_hls+1,jk,jl,jf)
ENDIF
END DO
@@ -185,57 +226,84 @@
CASE ( 'V' ) ! V-point
IF( nimpp /= 1 ) THEN
- startloop = 1
+ startloop = 1
ELSE
- startloop = 2
- ENDIF
- IF ( .NOT. l_fast_exchanges ) THEN
- DO jl = 1, ipl; DO jk = 1, ipk
- DO ji = startloop, nlci
- ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
- ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjp1,jk,jl,jf)
- END DO
- END DO; END DO
- ENDIF
- DO jl = 1, ipl; DO jk = 1, ipk
- DO ji = startloop, nlci
- ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
- ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf)
+ startloop = 1 + nn_hls
+ ENDIF
+ IF ( .NOT. l_fast_exchanges ) THEN
+ DO jl = 1, ipl; DO jk = 1, ipk
+ DO jj = 2, nn_hls+1
+ ijj = jpj -jj +1
+ DO ji = startloop, jpi
+ ijt=jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4
+ ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf)
+ END DO
+ END DO
+ END DO; END DO
+ ENDIF
+ DO jl = 1, ipl; DO jk = 1, ipk
+ DO ji = startloop, jpi
+ ijt=jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4
+ ARRAY_IN(ji,jpj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,1,jk,jl,jf)
END DO
END DO; END DO
IF (nimpp .eq. 1) THEN
- ARRAY_IN(1,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(3,nlcj-3,:,:,jf)
+ DO jj = 1, nn_hls
+ ijj = jpj-jj+1
+ DO ii = 0, nn_hls-1
+ ARRAY_IN(ii+1,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2*nn_hls-ii+1,jpj-2*nn_hls+jj-1,:,:,jf)
+ END DO
+ END DO
ENDIF
CASE ( 'F' ) ! F-point
- IF( nimpp + nlci - 1 /= jpiglo ) THEN
- endloop = nlci
+ IF( nimpp + jpi - 1 /= jpiglo ) THEN
+ endloop = jpi
ELSE
- endloop = nlci - 1
- ENDIF
- IF ( .NOT. l_fast_exchanges ) THEN
- DO jl = 1, ipl; DO jk = 1, ipk
- DO ji = 1, endloop
- iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
- ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjp1,jk,jl,jf)
- END DO
+ endloop = jpi - nn_hls
+ ENDIF
+ IF ( .NOT. l_fast_exchanges ) THEN
+ DO jl = 1, ipl; DO jk = 1, ipk
+ DO jj = 2, nn_hls+1
+ ijj = jpj -jj +1
+ DO ji = 1, endloop
+ iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3
+ ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf)
+ END DO
+ END DO
END DO; END DO
ENDIF
DO jl = 1, ipl; DO jk = 1, ipk
DO ji = 1, endloop
- iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
- ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf)
- END DO
- END DO; END DO
- IF (nimpp .eq. 1) THEN
- ARRAY_IN(1,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2,nlcj-3,:,:,jf)
- IF ( .NOT. l_fast_exchanges ) &
- ARRAY_IN(1,nlcj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2,nlcj-2,:,:,jf)
- ENDIF
- IF((nimpp + nlci - 1) .eq. jpiglo) THEN
- ARRAY_IN(nlci,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,nlcj-3,:,:,jf)
- IF ( .NOT. l_fast_exchanges ) &
- ARRAY_IN(nlci,nlcj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,nlcj-2,:,:,jf)
- ENDIF
- !
- END SELECT
+ iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3
+ ARRAY_IN(ji,jpj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,1,jk,jl,jf)
+ END DO
+ END DO; END DO
+ IF (nimpp .eq. 1) THEN
+ DO ii = 1, nn_hls
+ ARRAY_IN(ii,jpj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2*nn_hls-ii,jpj-2*nn_hls-1,:,:,jf)
+ END DO
+ IF ( .NOT. l_fast_exchanges ) THEN
+ DO jj = 1, nn_hls
+ ijj = jpj -jj
+ DO ii = 0, nn_hls-1
+ ARRAY_IN(ii+1,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2*nn_hls-ii,jpj-2*nn_hls+jj-1,:,:,jf)
+ END DO
+ END DO
+ ENDIF
+ ENDIF
+ IF((nimpp + jpi - 1 ) .eq. jpiglo) THEN
+ DO ii = 1, nn_hls
+ ARRAY_IN(jpi-ii+1,jpj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpi-2*nn_hls+ii,jpj-2*nn_hls-1,:,:,jf)
+ END DO
+ IF ( .NOT. l_fast_exchanges ) THEN
+ DO jj = 1, nn_hls
+ ijj = jpj -jj
+ DO ii = 1, nn_hls
+ ARRAY_IN(jpi-ii+1,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpi-2*nn_hls+ii,jpj-2*nn_hls+jj-1,:,:,jf)
+ END DO
+ END DO
+ ENDIF
+ ENDIF
+ !
+ END SELECT
!
CASE ( 5, 6 ) ! * North fold F-point pivot
@@ -244,25 +312,37 @@
CASE ( 'T' , 'W' ) ! T-, W-point
DO jl = 1, ipl; DO jk = 1, ipk
- DO ji = 1, nlci
- ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
- ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf)
- END DO
+ DO jj = 1, nn_hls
+ ijj = jpj-jj+1
+ DO ji = 1, jpi
+ ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3
+ ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf)
+ END DO
+ END DO
END DO; END DO
!
CASE ( 'U' ) ! U-point
- IF( nimpp + nlci - 1 /= jpiglo ) THEN
- endloop = nlci
+ IF( nimpp + jpi - 1 /= jpiglo ) THEN
+ endloop = jpi
ELSE
- endloop = nlci - 1
- ENDIF
- DO jl = 1, ipl; DO jk = 1, ipk
- DO ji = 1, endloop
- iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2
- ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf)
- END DO
- END DO; END DO
- IF((nimpp + nlci - 1) .eq. jpiglo) THEN
- DO jl = 1, ipl; DO jk = 1, ipk
- ARRAY_IN(nlci,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(nlci-2,nlcj-1,jk,jl,jf)
+ endloop = jpi - nn_hls
+ ENDIF
+ DO jl = 1, ipl; DO jk = 1, ipk
+ DO jj = 1, nn_hls
+ ijj = jpj-jj+1
+ DO ji = 1, endloop
+ iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2
+ ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf)
+ END DO
+ END DO
+ END DO; END DO
+ IF(nimpp + jpi - 1 .eq. jpiglo) THEN
+ DO jl = 1, ipl; DO jk = 1, ipk
+ DO jj = 1, nn_hls
+ ijj = jpj-jj+1
+ DO ii = 1, nn_hls
+ iij = jpi-ii+1
+ ARRAY_IN(iij,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(jpi-2*nn_hls+ii-1,jpj-2*nn_hls+jj,jk,jl,jf)
+ END DO
+ END DO
END DO; END DO
ENDIF
@@ -270,24 +350,27 @@
CASE ( 'V' ) ! V-point
DO jl = 1, ipl; DO jk = 1, ipk
- DO ji = 1, nlci
- ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
- ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf)
+ DO jj = 1, nn_hls
+ ijj = jpj -jj +1
+ DO ji = 1, jpi
+ ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3
+ ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf)
+ END DO
END DO
END DO; END DO
IF ( .NOT. l_fast_exchanges ) THEN
- IF( nimpp >= jpiglo/2+1 ) THEN
+ IF( nimpp >= Ni0glo/2+2 ) THEN
startloop = 1
- ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN
- startloop = jpiglo/2+1 - nimpp + 1
- ELSE
- startloop = nlci + 1
- ENDIF
- IF( startloop <= nlci ) THEN
- DO jl = 1, ipl; DO jk = 1, ipk
- DO ji = startloop, nlci
- ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
- ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjp1,jk,jl,jf)
- END DO
+ ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN
+ startloop = Ni0glo/2+2 - nimpp + nn_hls
+ ELSE
+ startloop = jpi + 1
+ ENDIF
+ IF( startloop <= jpi ) THEN
+ DO jl = 1, ipl; DO jk = 1, ipk
+ DO ji = startloop, jpi
+ ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3
+ ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,nn_hls+1,jk,jl,jf)
+ END DO
END DO; END DO
ENDIF
@@ -295,31 +378,40 @@
!
CASE ( 'F' ) ! F-point
- IF( nimpp + nlci - 1 /= jpiglo ) THEN
- endloop = nlci
+ IF( nimpp + jpi - 1 /= jpiglo ) THEN
+ endloop = jpi
ELSE
- endloop = nlci - 1
- ENDIF
- DO jl = 1, ipl; DO jk = 1, ipk
- DO ji = 1, endloop
- iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2
- ARRAY_IN(ji,nlcj ,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf)
- END DO
- END DO; END DO
- IF((nimpp + nlci - 1) .eq. jpiglo) THEN
- DO jl = 1, ipl; DO jk = 1, ipk
- ARRAY_IN(nlci,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(nlci-2,nlcj-2,jk,jl,jf)
- END DO; END DO
- ENDIF
- !
- IF ( .NOT. l_fast_exchanges ) THEN
- IF( nimpp + nlci - 1 /= jpiglo ) THEN
- endloop = nlci
- ELSE
- endloop = nlci - 1
- ENDIF
- IF( nimpp >= jpiglo/2+1 ) THEN
- startloop = 1
- ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN
- startloop = jpiglo/2+1 - nimpp + 1
+ endloop = jpi - nn_hls
+ ENDIF
+ DO jl = 1, ipl; DO jk = 1, ipk
+ DO jj = 1, nn_hls
+ ijj = jpj -jj +1
+ DO ji = 1, endloop
+ iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2
+ ARRAY_IN(ji,ijj ,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf)
+ END DO
+ END DO
+ END DO; END DO
+ IF((nimpp + jpi - 1) .eq. jpiglo) THEN
+ DO jl = 1, ipl; DO jk = 1, ipk
+ DO jj = 1, nn_hls
+ ijj = jpj -jj +1
+ DO ii = 1, nn_hls
+ iij = jpi -ii+1
+ ARRAY_IN(iij,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(jpi-2*nn_hls+ii-1,jpj-2*nn_hls+jj-1,jk,jl,jf)
+ END DO
+ END DO
+ END DO; END DO
+ ENDIF
+ !
+ IF ( .NOT. l_fast_exchanges ) THEN
+ IF( nimpp + jpi - 1 /= jpiglo ) THEN
+ endloop = jpi
+ ELSE
+ endloop = jpi - nn_hls
+ ENDIF
+ IF( nimpp >= Ni0glo/2+2 ) THEN
+ startloop = 1
+ ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN
+ startloop = Ni0glo/2+2 - nimpp + nn_hls
ELSE
startloop = endloop + 1
@@ -328,6 +420,6 @@
DO jl = 1, ipl; DO jk = 1, ipk
DO ji = startloop, endloop
- iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2
- ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjp1,jk,jl,jf)
+ iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2
+ ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,nn_hls+1,jk,jl,jf)
END DO
END DO; END DO
@@ -345,4 +437,5 @@
END DO ! End jf loop
END SUBROUTINE ROUTINE_NFD
+#undef PRECISION
#undef ARRAY_TYPE
#undef ARRAY_IN
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/lbclnk.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/lbclnk.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/lbclnk.F90 (revision 13540)
@@ -28,20 +28,26 @@
INTERFACE lbc_lnk
- MODULE PROCEDURE mpp_lnk_2d , mpp_lnk_3d , mpp_lnk_4d
+ MODULE PROCEDURE mpp_lnk_2d_sp , mpp_lnk_3d_sp , mpp_lnk_4d_sp
+ MODULE PROCEDURE mpp_lnk_2d_dp , mpp_lnk_3d_dp , mpp_lnk_4d_dp
END INTERFACE
INTERFACE lbc_lnk_ptr
- MODULE PROCEDURE mpp_lnk_2d_ptr , mpp_lnk_3d_ptr , mpp_lnk_4d_ptr
+ MODULE PROCEDURE mpp_lnk_2d_ptr_sp , mpp_lnk_3d_ptr_sp , mpp_lnk_4d_ptr_sp
+ MODULE PROCEDURE mpp_lnk_2d_ptr_dp , mpp_lnk_3d_ptr_dp , mpp_lnk_4d_ptr_dp
END INTERFACE
INTERFACE lbc_lnk_multi
- MODULE PROCEDURE lbc_lnk_2d_multi, lbc_lnk_3d_multi, lbc_lnk_4d_multi
+ MODULE PROCEDURE lbc_lnk_2d_multi_sp , lbc_lnk_3d_multi_sp, lbc_lnk_4d_multi_sp
+ MODULE PROCEDURE lbc_lnk_2d_multi_dp , lbc_lnk_3d_multi_dp, lbc_lnk_4d_multi_dp
END INTERFACE
!
INTERFACE lbc_lnk_icb
- MODULE PROCEDURE mpp_lnk_2d_icb
+ MODULE PROCEDURE mpp_lnk_2d_icb_dp, mpp_lnk_2d_icb_sp
END INTERFACE
INTERFACE mpp_nfd
- MODULE PROCEDURE mpp_nfd_2d , mpp_nfd_3d , mpp_nfd_4d
- MODULE PROCEDURE mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr
+ MODULE PROCEDURE mpp_nfd_2d_sp , mpp_nfd_3d_sp , mpp_nfd_4d_sp
+ MODULE PROCEDURE mpp_nfd_2d_dp , mpp_nfd_3d_dp , mpp_nfd_4d_dp
+ MODULE PROCEDURE mpp_nfd_2d_ptr_sp, mpp_nfd_3d_ptr_sp, mpp_nfd_4d_ptr_sp
+ MODULE PROCEDURE mpp_nfd_2d_ptr_dp, mpp_nfd_3d_ptr_dp, mpp_nfd_4d_ptr_dp
+
END INTERFACE
@@ -92,23 +98,55 @@
!!----------------------------------------------------------------------
-# define DIM_2d
-# define ROUTINE_LOAD load_ptr_2d
-# define ROUTINE_MULTI lbc_lnk_2d_multi
-# include "lbc_lnk_multi_generic.h90"
-# undef ROUTINE_MULTI
-# undef ROUTINE_LOAD
-# undef DIM_2d
-
-# define DIM_3d
-# define ROUTINE_LOAD load_ptr_3d
-# define ROUTINE_MULTI lbc_lnk_3d_multi
-# include "lbc_lnk_multi_generic.h90"
-# undef ROUTINE_MULTI
-# undef ROUTINE_LOAD
-# undef DIM_3d
-
-# define DIM_4d
-# define ROUTINE_LOAD load_ptr_4d
-# define ROUTINE_MULTI lbc_lnk_4d_multi
+ !!
+ !! ---- SINGLE PRECISION VERSIONS
+ !!
+# define SINGLE_PRECISION
+# define DIM_2d
+# define ROUTINE_LOAD load_ptr_2d_sp
+# define ROUTINE_MULTI lbc_lnk_2d_multi_sp
+# include "lbc_lnk_multi_generic.h90"
+# undef ROUTINE_MULTI
+# undef ROUTINE_LOAD
+# undef DIM_2d
+
+# define DIM_3d
+# define ROUTINE_LOAD load_ptr_3d_sp
+# define ROUTINE_MULTI lbc_lnk_3d_multi_sp
+# include "lbc_lnk_multi_generic.h90"
+# undef ROUTINE_MULTI
+# undef ROUTINE_LOAD
+# undef DIM_3d
+
+# define DIM_4d
+# define ROUTINE_LOAD load_ptr_4d_sp
+# define ROUTINE_MULTI lbc_lnk_4d_multi_sp
+# include "lbc_lnk_multi_generic.h90"
+# undef ROUTINE_MULTI
+# undef ROUTINE_LOAD
+# undef DIM_4d
+# undef SINGLE_PRECISION
+ !!
+ !! ---- DOUBLE PRECISION VERSIONS
+ !!
+
+# define DIM_2d
+# define ROUTINE_LOAD load_ptr_2d_dp
+# define ROUTINE_MULTI lbc_lnk_2d_multi_dp
+# include "lbc_lnk_multi_generic.h90"
+# undef ROUTINE_MULTI
+# undef ROUTINE_LOAD
+# undef DIM_2d
+
+# define DIM_3d
+# define ROUTINE_LOAD load_ptr_3d_dp
+# define ROUTINE_MULTI lbc_lnk_3d_multi_dp
+# include "lbc_lnk_multi_generic.h90"
+# undef ROUTINE_MULTI
+# undef ROUTINE_LOAD
+# undef DIM_3d
+
+# define DIM_4d
+# define ROUTINE_LOAD load_ptr_4d_dp
+# define ROUTINE_MULTI lbc_lnk_4d_multi_dp
# include "lbc_lnk_multi_generic.h90"
# undef ROUTINE_MULTI
@@ -130,10 +168,14 @@
! !== 2D array and array of 2D pointer ==!
!
-# define DIM_2d
-# define ROUTINE_LNK mpp_lnk_2d
-# include "mpp_lnk_generic.h90"
-# undef ROUTINE_LNK
-# define MULTI
-# define ROUTINE_LNK mpp_lnk_2d_ptr
+ !!
+ !! ---- SINGLE PRECISION VERSIONS
+ !!
+# define SINGLE_PRECISION
+# define DIM_2d
+# define ROUTINE_LNK mpp_lnk_2d_sp
+# include "mpp_lnk_generic.h90"
+# undef ROUTINE_LNK
+# define MULTI
+# define ROUTINE_LNK mpp_lnk_2d_ptr_sp
# include "mpp_lnk_generic.h90"
# undef ROUTINE_LNK
@@ -144,9 +186,9 @@
!
# define DIM_3d
-# define ROUTINE_LNK mpp_lnk_3d
-# include "mpp_lnk_generic.h90"
-# undef ROUTINE_LNK
-# define MULTI
-# define ROUTINE_LNK mpp_lnk_3d_ptr
+# define ROUTINE_LNK mpp_lnk_3d_sp
+# include "mpp_lnk_generic.h90"
+# undef ROUTINE_LNK
+# define MULTI
+# define ROUTINE_LNK mpp_lnk_3d_ptr_sp
# include "mpp_lnk_generic.h90"
# undef ROUTINE_LNK
@@ -157,13 +199,55 @@
!
# define DIM_4d
-# define ROUTINE_LNK mpp_lnk_4d
-# include "mpp_lnk_generic.h90"
-# undef ROUTINE_LNK
-# define MULTI
-# define ROUTINE_LNK mpp_lnk_4d_ptr
-# include "mpp_lnk_generic.h90"
-# undef ROUTINE_LNK
-# undef MULTI
-# undef DIM_4d
+# define ROUTINE_LNK mpp_lnk_4d_sp
+# include "mpp_lnk_generic.h90"
+# undef ROUTINE_LNK
+# define MULTI
+# define ROUTINE_LNK mpp_lnk_4d_ptr_sp
+# include "mpp_lnk_generic.h90"
+# undef ROUTINE_LNK
+# undef MULTI
+# undef DIM_4d
+# undef SINGLE_PRECISION
+
+ !!
+ !! ---- DOUBLE PRECISION VERSIONS
+ !!
+# define DIM_2d
+# define ROUTINE_LNK mpp_lnk_2d_dp
+# include "mpp_lnk_generic.h90"
+# undef ROUTINE_LNK
+# define MULTI
+# define ROUTINE_LNK mpp_lnk_2d_ptr_dp
+# include "mpp_lnk_generic.h90"
+# undef ROUTINE_LNK
+# undef MULTI
+# undef DIM_2d
+ !
+ ! !== 3D array and array of 3D pointer ==!
+ !
+# define DIM_3d
+# define ROUTINE_LNK mpp_lnk_3d_dp
+# include "mpp_lnk_generic.h90"
+# undef ROUTINE_LNK
+# define MULTI
+# define ROUTINE_LNK mpp_lnk_3d_ptr_dp
+# include "mpp_lnk_generic.h90"
+# undef ROUTINE_LNK
+# undef MULTI
+# undef DIM_3d
+ !
+ ! !== 4D array and array of 4D pointer ==!
+ !
+# define DIM_4d
+# define ROUTINE_LNK mpp_lnk_4d_dp
+# include "mpp_lnk_generic.h90"
+# undef ROUTINE_LNK
+# define MULTI
+# define ROUTINE_LNK mpp_lnk_4d_ptr_dp
+# include "mpp_lnk_generic.h90"
+# undef ROUTINE_LNK
+# undef MULTI
+# undef DIM_4d
+
!!----------------------------------------------------------------------
@@ -181,10 +265,14 @@
! !== 2D array and array of 2D pointer ==!
!
-# define DIM_2d
-# define ROUTINE_NFD mpp_nfd_2d
-# include "mpp_nfd_generic.h90"
-# undef ROUTINE_NFD
-# define MULTI
-# define ROUTINE_NFD mpp_nfd_2d_ptr
+ !!
+ !! ---- SINGLE PRECISION VERSIONS
+ !!
+# define SINGLE_PRECISION
+# define DIM_2d
+# define ROUTINE_NFD mpp_nfd_2d_sp
+# include "mpp_nfd_generic.h90"
+# undef ROUTINE_NFD
+# define MULTI
+# define ROUTINE_NFD mpp_nfd_2d_ptr_sp
# include "mpp_nfd_generic.h90"
# undef ROUTINE_NFD
@@ -195,9 +283,9 @@
!
# define DIM_3d
-# define ROUTINE_NFD mpp_nfd_3d
-# include "mpp_nfd_generic.h90"
-# undef ROUTINE_NFD
-# define MULTI
-# define ROUTINE_NFD mpp_nfd_3d_ptr
+# define ROUTINE_NFD mpp_nfd_3d_sp
+# include "mpp_nfd_generic.h90"
+# undef ROUTINE_NFD
+# define MULTI
+# define ROUTINE_NFD mpp_nfd_3d_ptr_sp
# include "mpp_nfd_generic.h90"
# undef ROUTINE_NFD
@@ -208,21 +296,60 @@
!
# define DIM_4d
-# define ROUTINE_NFD mpp_nfd_4d
-# include "mpp_nfd_generic.h90"
-# undef ROUTINE_NFD
-# define MULTI
-# define ROUTINE_NFD mpp_nfd_4d_ptr
-# include "mpp_nfd_generic.h90"
-# undef ROUTINE_NFD
-# undef MULTI
-# undef DIM_4d
-
+# define ROUTINE_NFD mpp_nfd_4d_sp
+# include "mpp_nfd_generic.h90"
+# undef ROUTINE_NFD
+# define MULTI
+# define ROUTINE_NFD mpp_nfd_4d_ptr_sp
+# include "mpp_nfd_generic.h90"
+# undef ROUTINE_NFD
+# undef MULTI
+# undef DIM_4d
+# undef SINGLE_PRECISION
+
+ !!
+ !! ---- DOUBLE PRECISION VERSIONS
+ !!
+# define DIM_2d
+# define ROUTINE_NFD mpp_nfd_2d_dp
+# include "mpp_nfd_generic.h90"
+# undef ROUTINE_NFD
+# define MULTI
+# define ROUTINE_NFD mpp_nfd_2d_ptr_dp
+# include "mpp_nfd_generic.h90"
+# undef ROUTINE_NFD
+# undef MULTI
+# undef DIM_2d
+ !
+ ! !== 3D array and array of 3D pointer ==!
+ !
+# define DIM_3d
+# define ROUTINE_NFD mpp_nfd_3d_dp
+# include "mpp_nfd_generic.h90"
+# undef ROUTINE_NFD
+# define MULTI
+# define ROUTINE_NFD mpp_nfd_3d_ptr_dp
+# include "mpp_nfd_generic.h90"
+# undef ROUTINE_NFD
+# undef MULTI
+# undef DIM_3d
+ !
+ ! !== 4D array and array of 4D pointer ==!
+ !
+# define DIM_4d
+# define ROUTINE_NFD mpp_nfd_4d_dp
+# include "mpp_nfd_generic.h90"
+# undef ROUTINE_NFD
+# define MULTI
+# define ROUTINE_NFD mpp_nfd_4d_ptr_dp
+# include "mpp_nfd_generic.h90"
+# undef ROUTINE_NFD
+# undef MULTI
+# undef DIM_4d
!!======================================================================
-
- SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, kextj)
- !!---------------------------------------------------------------------
+ !!======================================================================
+ !!---------------------------------------------------------------------
!! *** routine mpp_lbc_north_icb ***
!!
@@ -240,76 +367,14 @@
!!
!!----------------------------------------------------------------------
- REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array with extra halo
- CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points
- ! ! = T , U , V , F or W -points
- REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the
- !! ! north fold, = 1. otherwise
- INTEGER , INTENT(in ) :: kextj ! Extra halo width at north fold
- !
- INTEGER :: ji, jj, jr
- INTEGER :: ierr, itaille, ildi, ilei, iilb
- INTEGER :: ipj, ij, iproc
- !
- REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e
- REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e
- !!----------------------------------------------------------------------
-#if defined key_mpp_mpi
- !
- ipj=4
- ALLOCATE( ztab_e(jpiglo, 1-kextj:ipj+kextj) , &
- & znorthloc_e(jpimax, 1-kextj:ipj+kextj) , &
- & znorthgloio_e(jpimax, 1-kextj:ipj+kextj,jpni) )
- !
- ztab_e(:,:) = 0._wp
- znorthloc_e(:,:) = 0._wp
- !
- ij = 1 - kextj
- ! put the last ipj+2*kextj lines of pt2d into znorthloc_e
- DO jj = jpj - ipj + 1 - kextj , jpj + kextj
- znorthloc_e(1:jpi,ij)=pt2d(1:jpi,jj)
- ij = ij + 1
- END DO
- !
- itaille = jpimax * ( ipj + 2*kextj )
- !
- IF( ln_timing ) CALL tic_tac(.TRUE.)
- CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj) , itaille, MPI_DOUBLE_PRECISION, &
- & znorthgloio_e(1,1-kextj,1), itaille, MPI_DOUBLE_PRECISION, &
- & ncomm_north, ierr )
- !
- IF( ln_timing ) CALL tic_tac(.FALSE.)
- !
- DO jr = 1, ndim_rank_north ! recover the global north array
- iproc = nrank_north(jr) + 1
- ildi = nldit (iproc)
- ilei = nleit (iproc)
- iilb = nimppt(iproc)
- DO jj = 1-kextj, ipj+kextj
- DO ji = ildi, ilei
- ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr)
- END DO
- END DO
- END DO
-
- ! 2. North-Fold boundary conditions
- ! ----------------------------------
- CALL lbc_nfd( ztab_e(:,1-kextj:ipj+kextj), cd_type, psgn, kextj )
-
- ij = 1 - kextj
- !! Scatter back to pt2d
- DO jj = jpj - ipj + 1 - kextj , jpj + kextj
- DO ji= 1, jpi
- pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij)
- END DO
- ij = ij +1
- END DO
- !
- DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e )
- !
-#endif
- END SUBROUTINE mpp_lbc_north_icb
-
-
- SUBROUTINE mpp_lnk_2d_icb( cdname, pt2d, cd_type, psgn, kexti, kextj )
+# define SINGLE_PRECISION
+# define ROUTINE_LNK mpp_lbc_north_icb_sp
+# include "mpp_lbc_north_icb_generic.h90"
+# undef ROUTINE_LNK
+# undef SINGLE_PRECISION
+# define ROUTINE_LNK mpp_lbc_north_icb_dp
+# include "mpp_lbc_north_icb_generic.h90"
+# undef ROUTINE_LNK
+
+
!!----------------------------------------------------------------------
!! *** routine mpp_lnk_2d_icb ***
@@ -333,177 +398,14 @@
!! nono : number for local neighboring processors
!!----------------------------------------------------------------------
- CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine
- REAL(wp), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) :: pt2d ! 2D array with extra halo
- CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points
- REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold
- INTEGER , INTENT(in ) :: kexti ! extra i-halo width
- INTEGER , INTENT(in ) :: kextj ! extra j-halo width
- !
- INTEGER :: jl ! dummy loop indices
- INTEGER :: imigr, iihom, ijhom ! local integers
- INTEGER :: ipreci, iprecj ! - -
- INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
- INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
- !!
- REAL(wp), DIMENSION(1-kexti:jpi+kexti,nn_hls+kextj,2) :: r2dns, r2dsn
- REAL(wp), DIMENSION(1-kextj:jpj+kextj,nn_hls+kexti,2) :: r2dwe, r2dew
- !!----------------------------------------------------------------------
-
- ipreci = nn_hls + kexti ! take into account outer extra 2D overlap area
- iprecj = nn_hls + kextj
-
- IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, 1, 1, 1, ld_lbc = .TRUE. )
-
- ! 1. standard boundary treatment
- ! ------------------------------
- ! Order matters Here !!!!
- !
- ! ! East-West boundaries
- ! !* Cyclic east-west
- IF( l_Iperio ) THEN
- pt2d(1-kexti: 1 ,:) = pt2d(jpim1-kexti: jpim1 ,:) ! east
- pt2d( jpi :jpi+kexti,:) = pt2d( 2 :2+kexti,:) ! west
- !
- ELSE !* closed
- IF( .NOT. cd_type == 'F' ) pt2d( 1-kexti :nn_hls ,:) = 0._wp ! east except at F-point
- pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._wp ! west
- ENDIF
- ! ! North-South boundaries
- IF( l_Jperio ) THEN !* cyclic (only with no mpp j-split)
- pt2d(:,1-kextj: 1 ) = pt2d(:,jpjm1-kextj: jpjm1) ! north
- pt2d(:, jpj :jpj+kextj) = pt2d(:, 2 :2+kextj) ! south
- ELSE !* closed
- IF( .NOT. cd_type == 'F' ) pt2d(:, 1-kextj :nn_hls ) = 0._wp ! north except at F-point
- pt2d(:,jpj-nn_hls+1:jpj+kextj) = 0._wp ! south
- ENDIF
- !
-
- ! north fold treatment
- ! -----------------------
- IF( npolj /= 0 ) THEN
- !
- SELECT CASE ( jpni )
- CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj )
- CASE DEFAULT ; CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj )
- END SELECT
- !
- ENDIF
-
- ! 2. East and west directions exchange
- ! ------------------------------------
- ! we play with the neigbours AND the row number because of the periodicity
- !
- SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions
- CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
- iihom = jpi-nreci-kexti
- DO jl = 1, ipreci
- r2dew(:,jl,1) = pt2d(nn_hls+jl,:)
- r2dwe(:,jl,1) = pt2d(iihom +jl,:)
- END DO
- END SELECT
- !
- ! ! Migrations
- imigr = ipreci * ( jpj + 2*kextj )
- !
- IF( ln_timing ) CALL tic_tac(.TRUE.)
- !
- SELECT CASE ( nbondi )
- CASE ( -1 )
- CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req1 )
- CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea )
- CALL mpi_wait(ml_req1,ml_stat,ml_err)
- CASE ( 0 )
- CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 )
- CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req2 )
- CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea )
- CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe )
- CALL mpi_wait(ml_req1,ml_stat,ml_err)
- CALL mpi_wait(ml_req2,ml_stat,ml_err)
- CASE ( 1 )
- CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 )
- CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe )
- CALL mpi_wait(ml_req1,ml_stat,ml_err)
- END SELECT
- !
- IF( ln_timing ) CALL tic_tac(.FALSE.)
- !
- ! ! Write Dirichlet lateral conditions
- iihom = jpi - nn_hls
- !
- SELECT CASE ( nbondi )
- CASE ( -1 )
- DO jl = 1, ipreci
- pt2d(iihom+jl,:) = r2dew(:,jl,2)
- END DO
- CASE ( 0 )
- DO jl = 1, ipreci
- pt2d(jl-kexti,:) = r2dwe(:,jl,2)
- pt2d(iihom+jl,:) = r2dew(:,jl,2)
- END DO
- CASE ( 1 )
- DO jl = 1, ipreci
- pt2d(jl-kexti,:) = r2dwe(:,jl,2)
- END DO
- END SELECT
-
-
- ! 3. North and south directions
- ! -----------------------------
- ! always closed : we play only with the neigbours
- !
- IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions
- ijhom = jpj-nrecj-kextj
- DO jl = 1, iprecj
- r2dsn(:,jl,1) = pt2d(:,ijhom +jl)
- r2dns(:,jl,1) = pt2d(:,nn_hls+jl)
- END DO
- ENDIF
- !
- ! ! Migrations
- imigr = iprecj * ( jpi + 2*kexti )
- !
- IF( ln_timing ) CALL tic_tac(.TRUE.)
- !
- SELECT CASE ( nbondj )
- CASE ( -1 )
- CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req1 )
- CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono )
- CALL mpi_wait(ml_req1,ml_stat,ml_err)
- CASE ( 0 )
- CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 )
- CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req2 )
- CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono )
- CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso )
- CALL mpi_wait(ml_req1,ml_stat,ml_err)
- CALL mpi_wait(ml_req2,ml_stat,ml_err)
- CASE ( 1 )
- CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 )
- CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso )
- CALL mpi_wait(ml_req1,ml_stat,ml_err)
- END SELECT
- !
- IF( ln_timing ) CALL tic_tac(.FALSE.)
- !
- ! ! Write Dirichlet lateral conditions
- ijhom = jpj - nn_hls
- !
- SELECT CASE ( nbondj )
- CASE ( -1 )
- DO jl = 1, iprecj
- pt2d(:,ijhom+jl) = r2dns(:,jl,2)
- END DO
- CASE ( 0 )
- DO jl = 1, iprecj
- pt2d(:,jl-kextj) = r2dsn(:,jl,2)
- pt2d(:,ijhom+jl) = r2dns(:,jl,2)
- END DO
- CASE ( 1 )
- DO jl = 1, iprecj
- pt2d(:,jl-kextj) = r2dsn(:,jl,2)
- END DO
- END SELECT
- !
- END SUBROUTINE mpp_lnk_2d_icb
-
+
+# define SINGLE_PRECISION
+# define ROUTINE_LNK mpp_lnk_2d_icb_sp
+# include "mpp_lnk_icb_generic.h90"
+# undef ROUTINE_LNK
+# undef SINGLE_PRECISION
+# define ROUTINE_LNK mpp_lnk_2d_icb_dp
+# include "mpp_lnk_icb_generic.h90"
+# undef ROUTINE_LNK
+
END MODULE lbclnk
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/lbcnfd.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/lbcnfd.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/lbcnfd.F90 (revision 13540)
@@ -26,26 +26,43 @@
INTERFACE lbc_nfd
- MODULE PROCEDURE lbc_nfd_2d , lbc_nfd_3d , lbc_nfd_4d
- MODULE PROCEDURE lbc_nfd_2d_ptr, lbc_nfd_3d_ptr, lbc_nfd_4d_ptr
- MODULE PROCEDURE lbc_nfd_2d_ext
+ MODULE PROCEDURE lbc_nfd_2d_sp , lbc_nfd_3d_sp , lbc_nfd_4d_sp
+ MODULE PROCEDURE lbc_nfd_2d_ptr_sp, lbc_nfd_3d_ptr_sp, lbc_nfd_4d_ptr_sp
+ MODULE PROCEDURE lbc_nfd_2d_ext_sp
+ MODULE PROCEDURE lbc_nfd_2d_dp , lbc_nfd_3d_dp , lbc_nfd_4d_dp
+ MODULE PROCEDURE lbc_nfd_2d_ptr_dp, lbc_nfd_3d_ptr_dp, lbc_nfd_4d_ptr_dp
+ MODULE PROCEDURE lbc_nfd_2d_ext_dp
END INTERFACE
!
INTERFACE lbc_nfd_nogather
! ! Currently only 4d array version is needed
- MODULE PROCEDURE lbc_nfd_nogather_2d , lbc_nfd_nogather_3d
- MODULE PROCEDURE lbc_nfd_nogather_4d
- MODULE PROCEDURE lbc_nfd_nogather_2d_ptr, lbc_nfd_nogather_3d_ptr
+ MODULE PROCEDURE lbc_nfd_nogather_2d_sp , lbc_nfd_nogather_3d_sp
+ MODULE PROCEDURE lbc_nfd_nogather_4d_sp
+ MODULE PROCEDURE lbc_nfd_nogather_2d_ptr_sp, lbc_nfd_nogather_3d_ptr_sp
+ MODULE PROCEDURE lbc_nfd_nogather_2d_dp , lbc_nfd_nogather_3d_dp
+ MODULE PROCEDURE lbc_nfd_nogather_4d_dp
+ MODULE PROCEDURE lbc_nfd_nogather_2d_ptr_dp, lbc_nfd_nogather_3d_ptr_dp
! MODULE PROCEDURE lbc_nfd_nogather_4d_ptr
END INTERFACE
- TYPE, PUBLIC :: PTR_2D !: array of 2D pointers (also used in lib_mpp)
- REAL(wp), DIMENSION (:,:) , POINTER :: pt2d
- END TYPE PTR_2D
- TYPE, PUBLIC :: PTR_3D !: array of 3D pointers (also used in lib_mpp)
- REAL(wp), DIMENSION (:,:,:) , POINTER :: pt3d
- END TYPE PTR_3D
- TYPE, PUBLIC :: PTR_4D !: array of 4D pointers (also used in lib_mpp)
- REAL(wp), DIMENSION (:,:,:,:), POINTER :: pt4d
- END TYPE PTR_4D
+ TYPE, PUBLIC :: PTR_2D_dp !: array of 2D pointers (also used in lib_mpp)
+ REAL(dp), DIMENSION (:,:) , POINTER :: pt2d
+ END TYPE PTR_2D_dp
+ TYPE, PUBLIC :: PTR_3D_dp !: array of 3D pointers (also used in lib_mpp)
+ REAL(dp), DIMENSION (:,:,:) , POINTER :: pt3d
+ END TYPE PTR_3D_dp
+ TYPE, PUBLIC :: PTR_4D_dp !: array of 4D pointers (also used in lib_mpp)
+ REAL(dp), DIMENSION (:,:,:,:), POINTER :: pt4d
+ END TYPE PTR_4D_dp
+
+ TYPE, PUBLIC :: PTR_2D_sp !: array of 2D pointers (also used in lib_mpp)
+ REAL(sp), DIMENSION (:,:) , POINTER :: pt2d
+ END TYPE PTR_2D_sp
+ TYPE, PUBLIC :: PTR_3D_sp !: array of 3D pointers (also used in lib_mpp)
+ REAL(sp), DIMENSION (:,:,:) , POINTER :: pt3d
+ END TYPE PTR_3D_sp
+ TYPE, PUBLIC :: PTR_4D_sp !: array of 4D pointers (also used in lib_mpp)
+ REAL(sp), DIMENSION (:,:,:,:), POINTER :: pt4d
+ END TYPE PTR_4D_sp
+
PUBLIC lbc_nfd ! north fold conditions
@@ -53,6 +70,7 @@
INTEGER, PUBLIC, PARAMETER :: jpmaxngh = 3 !:
- INTEGER, PUBLIC :: nsndto, nfsloop, nfeloop !:
+ INTEGER, PUBLIC :: nsndto !:
INTEGER, PUBLIC, DIMENSION (jpmaxngh) :: isendto !: processes to which communicate
+ INTEGER, PUBLIC :: ijpj
!!----------------------------------------------------------------------
@@ -75,12 +93,16 @@
!!----------------------------------------------------------------------
!
- ! !== 2D array and array of 2D pointer ==!
- !
-# define DIM_2d
-# define ROUTINE_NFD lbc_nfd_2d
-# include "lbc_nfd_generic.h90"
-# undef ROUTINE_NFD
-# define MULTI
-# define ROUTINE_NFD lbc_nfd_2d_ptr
+ ! !== SINGLE PRECISION VERSIONS
+ !
+ !
+ ! !== 2D array and array of 2D pointer ==!
+ !
+# define SINGLE_PRECISION
+# define DIM_2d
+# define ROUTINE_NFD lbc_nfd_2d_sp
+# include "lbc_nfd_generic.h90"
+# undef ROUTINE_NFD
+# define MULTI
+# define ROUTINE_NFD lbc_nfd_2d_ptr_sp
# include "lbc_nfd_generic.h90"
# undef ROUTINE_NFD
@@ -91,5 +113,5 @@
!
# define DIM_2d
-# define ROUTINE_NFD lbc_nfd_2d_ext
+# define ROUTINE_NFD lbc_nfd_2d_ext_sp
# include "lbc_nfd_ext_generic.h90"
# undef ROUTINE_NFD
@@ -99,22 +121,22 @@
!
# define DIM_3d
-# define ROUTINE_NFD lbc_nfd_3d
-# include "lbc_nfd_generic.h90"
-# undef ROUTINE_NFD
-# define MULTI
-# define ROUTINE_NFD lbc_nfd_3d_ptr
-# include "lbc_nfd_generic.h90"
-# undef ROUTINE_NFD
-# undef MULTI
-# undef DIM_3d
- !
- ! !== 4D array and array of 4D pointer ==!
- !
-# define DIM_4d
-# define ROUTINE_NFD lbc_nfd_4d
-# include "lbc_nfd_generic.h90"
-# undef ROUTINE_NFD
-# define MULTI
-# define ROUTINE_NFD lbc_nfd_4d_ptr
+# define ROUTINE_NFD lbc_nfd_3d_sp
+# include "lbc_nfd_generic.h90"
+# undef ROUTINE_NFD
+# define MULTI
+# define ROUTINE_NFD lbc_nfd_3d_ptr_sp
+# include "lbc_nfd_generic.h90"
+# undef ROUTINE_NFD
+# undef MULTI
+# undef DIM_3d
+ !
+ ! !== 4D array and array of 4D pointer ==!
+ !
+# define DIM_4d
+# define ROUTINE_NFD lbc_nfd_4d_sp
+# include "lbc_nfd_generic.h90"
+# undef ROUTINE_NFD
+# define MULTI
+# define ROUTINE_NFD lbc_nfd_4d_ptr_sp
# include "lbc_nfd_generic.h90"
# undef ROUTINE_NFD
@@ -127,31 +149,31 @@
!
# define DIM_2d
-# define ROUTINE_NFD lbc_nfd_nogather_2d
-# include "lbc_nfd_nogather_generic.h90"
-# undef ROUTINE_NFD
-# define MULTI
-# define ROUTINE_NFD lbc_nfd_nogather_2d_ptr
-# include "lbc_nfd_nogather_generic.h90"
-# undef ROUTINE_NFD
-# undef MULTI
-# undef DIM_2d
- !
- ! !== 3D array and array of 3D pointer ==!
- !
-# define DIM_3d
-# define ROUTINE_NFD lbc_nfd_nogather_3d
-# include "lbc_nfd_nogather_generic.h90"
-# undef ROUTINE_NFD
-# define MULTI
-# define ROUTINE_NFD lbc_nfd_nogather_3d_ptr
-# include "lbc_nfd_nogather_generic.h90"
-# undef ROUTINE_NFD
-# undef MULTI
-# undef DIM_3d
- !
- ! !== 4D array and array of 4D pointer ==!
- !
-# define DIM_4d
-# define ROUTINE_NFD lbc_nfd_nogather_4d
+# define ROUTINE_NFD lbc_nfd_nogather_2d_sp
+# include "lbc_nfd_nogather_generic.h90"
+# undef ROUTINE_NFD
+# define MULTI
+# define ROUTINE_NFD lbc_nfd_nogather_2d_ptr_sp
+# include "lbc_nfd_nogather_generic.h90"
+# undef ROUTINE_NFD
+# undef MULTI
+# undef DIM_2d
+ !
+ ! !== 3D array and array of 3D pointer ==!
+ !
+# define DIM_3d
+# define ROUTINE_NFD lbc_nfd_nogather_3d_sp
+# include "lbc_nfd_nogather_generic.h90"
+# undef ROUTINE_NFD
+# define MULTI
+# define ROUTINE_NFD lbc_nfd_nogather_3d_ptr_sp
+# include "lbc_nfd_nogather_generic.h90"
+# undef ROUTINE_NFD
+# undef MULTI
+# undef DIM_3d
+ !
+ ! !== 4D array and array of 4D pointer ==!
+ !
+# define DIM_4d
+# define ROUTINE_NFD lbc_nfd_nogather_4d_sp
# include "lbc_nfd_nogather_generic.h90"
# undef ROUTINE_NFD
@@ -162,6 +184,101 @@
!# undef MULTI
# undef DIM_4d
-
- !!----------------------------------------------------------------------
+# undef SINGLE_PRECISION
+
+ !!----------------------------------------------------------------------
+ !
+ ! !== DOUBLE PRECISION VERSIONS
+ !
+ !
+ ! !== 2D array and array of 2D pointer ==!
+ !
+# define DIM_2d
+# define ROUTINE_NFD lbc_nfd_2d_dp
+# include "lbc_nfd_generic.h90"
+# undef ROUTINE_NFD
+# define MULTI
+# define ROUTINE_NFD lbc_nfd_2d_ptr_dp
+# include "lbc_nfd_generic.h90"
+# undef ROUTINE_NFD
+# undef MULTI
+# undef DIM_2d
+ !
+ ! !== 2D array with extra haloes ==!
+ !
+# define DIM_2d
+# define ROUTINE_NFD lbc_nfd_2d_ext_dp
+# include "lbc_nfd_ext_generic.h90"
+# undef ROUTINE_NFD
+# undef DIM_2d
+ !
+ ! !== 3D array and array of 3D pointer ==!
+ !
+# define DIM_3d
+# define ROUTINE_NFD lbc_nfd_3d_dp
+# include "lbc_nfd_generic.h90"
+# undef ROUTINE_NFD
+# define MULTI
+# define ROUTINE_NFD lbc_nfd_3d_ptr_dp
+# include "lbc_nfd_generic.h90"
+# undef ROUTINE_NFD
+# undef MULTI
+# undef DIM_3d
+ !
+ ! !== 4D array and array of 4D pointer ==!
+ !
+# define DIM_4d
+# define ROUTINE_NFD lbc_nfd_4d_dp
+# include "lbc_nfd_generic.h90"
+# undef ROUTINE_NFD
+# define MULTI
+# define ROUTINE_NFD lbc_nfd_4d_ptr_dp
+# include "lbc_nfd_generic.h90"
+# undef ROUTINE_NFD
+# undef MULTI
+# undef DIM_4d
+ !
+ ! lbc_nfd_nogather routines
+ !
+ ! !== 2D array and array of 2D pointer ==!
+ !
+# define DIM_2d
+# define ROUTINE_NFD lbc_nfd_nogather_2d_dp
+# include "lbc_nfd_nogather_generic.h90"
+# undef ROUTINE_NFD
+# define MULTI
+# define ROUTINE_NFD lbc_nfd_nogather_2d_ptr_dp
+# include "lbc_nfd_nogather_generic.h90"
+# undef ROUTINE_NFD
+# undef MULTI
+# undef DIM_2d
+ !
+ ! !== 3D array and array of 3D pointer ==!
+ !
+# define DIM_3d
+# define ROUTINE_NFD lbc_nfd_nogather_3d_dp
+# include "lbc_nfd_nogather_generic.h90"
+# undef ROUTINE_NFD
+# define MULTI
+# define ROUTINE_NFD lbc_nfd_nogather_3d_ptr_dp
+# include "lbc_nfd_nogather_generic.h90"
+# undef ROUTINE_NFD
+# undef MULTI
+# undef DIM_3d
+ !
+ ! !== 4D array and array of 4D pointer ==!
+ !
+# define DIM_4d
+# define ROUTINE_NFD lbc_nfd_nogather_4d_dp
+# include "lbc_nfd_nogather_generic.h90"
+# undef ROUTINE_NFD
+!# define MULTI
+!# define ROUTINE_NFD lbc_nfd_nogather_4d_ptr
+!# include "lbc_nfd_nogather_generic.h90"
+!# undef ROUTINE_NFD
+!# undef MULTI
+# undef DIM_4d
+
+ !!----------------------------------------------------------------------
+
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/lib_mpp.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/lib_mpp.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/lib_mpp.F90 (revision 13540)
@@ -67,8 +67,11 @@
PUBLIC mpp_ini_znl
PUBLIC mppsend, mpprecv ! needed by TAM and ICB routines
+ PUBLIC mppsend_sp, mpprecv_sp ! needed by TAM and ICB routines
+ PUBLIC mppsend_dp, mpprecv_dp ! needed by TAM and ICB routines
PUBLIC mpp_report
PUBLIC mpp_bcast_nml
PUBLIC tic_tac
#if ! defined key_mpp_mpi
+ PUBLIC MPI_wait
PUBLIC MPI_Wtime
#endif
@@ -79,18 +82,26 @@
!! for the compilation on AIX system as well as NEC and SGI. Ok on COMPACQ
INTERFACE mpp_min
- MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
+ MODULE PROCEDURE mppmin_a_int, mppmin_int
+ MODULE PROCEDURE mppmin_a_real_sp, mppmin_real_sp
+ MODULE PROCEDURE mppmin_a_real_dp, mppmin_real_dp
END INTERFACE
INTERFACE mpp_max
- MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
+ MODULE PROCEDURE mppmax_a_int, mppmax_int
+ MODULE PROCEDURE mppmax_a_real_sp, mppmax_real_sp
+ MODULE PROCEDURE mppmax_a_real_dp, mppmax_real_dp
END INTERFACE
INTERFACE mpp_sum
- MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real, &
- & mppsum_realdd, mppsum_a_realdd
+ MODULE PROCEDURE mppsum_a_int, mppsum_int
+ MODULE PROCEDURE mppsum_realdd, mppsum_a_realdd
+ MODULE PROCEDURE mppsum_a_real_sp, mppsum_real_sp
+ MODULE PROCEDURE mppsum_a_real_dp, mppsum_real_dp
END INTERFACE
INTERFACE mpp_minloc
- MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
+ MODULE PROCEDURE mpp_minloc2d_sp ,mpp_minloc3d_sp
+ MODULE PROCEDURE mpp_minloc2d_dp ,mpp_minloc3d_dp
END INTERFACE
INTERFACE mpp_maxloc
- MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
+ MODULE PROCEDURE mpp_maxloc2d_sp ,mpp_maxloc3d_sp
+ MODULE PROCEDURE mpp_maxloc2d_dp ,mpp_maxloc3d_dp
END INTERFACE
@@ -105,4 +116,5 @@
#else
INTEGER, PUBLIC, PARAMETER :: MPI_STATUS_SIZE = 1
+ INTEGER, PUBLIC, PARAMETER :: MPI_REAL = 4
INTEGER, PUBLIC, PARAMETER :: MPI_DOUBLE_PRECISION = 8
LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .FALSE. !: mpp flag
@@ -137,7 +149,7 @@
! Communications summary report
- CHARACTER(len=128), DIMENSION(:), ALLOCATABLE :: crname_lbc !: names of lbc_lnk calling routines
- CHARACTER(len=128), DIMENSION(:), ALLOCATABLE :: crname_glb !: names of global comm calling routines
- CHARACTER(len=128), DIMENSION(:), ALLOCATABLE :: crname_dlg !: names of delayed global comm calling routines
+ CHARACTER(len=lca), DIMENSION(:), ALLOCATABLE :: crname_lbc !: names of lbc_lnk calling routines
+ CHARACTER(len=lca), DIMENSION(:), ALLOCATABLE :: crname_glb !: names of global comm calling routines
+ CHARACTER(len=lca), DIMENSION(:), ALLOCATABLE :: crname_dlg !: names of delayed global comm calling routines
INTEGER, PUBLIC :: ncom_stp = 0 !: copy of time step # istp
INTEGER, PUBLIC :: ncom_fsbc = 1 !: copy of sbc time step # nn_fsbc
@@ -158,5 +170,5 @@
TYPE, PUBLIC :: DELAYARR
REAL( wp), POINTER, DIMENSION(:) :: z1d => NULL()
- COMPLEX(wp), POINTER, DIMENSION(:) :: y1d => NULL()
+ COMPLEX(dp), POINTER, DIMENSION(:) :: y1d => NULL()
END TYPE DELAYARR
TYPE( DELAYARR ), DIMENSION(nbdelay), PUBLIC, SAVE :: todelay !: must have SAVE for default initialization of DELAYARR
@@ -164,6 +176,6 @@
! timing summary report
- REAL(wp), DIMENSION(2), PUBLIC :: waiting_time = 0._wp
- REAL(wp) , PUBLIC :: compute_time = 0._wp, elapsed_time = 0._wp
+ REAL(dp), DIMENSION(2), PUBLIC :: waiting_time = 0._dp
+ REAL(dp) , PUBLIC :: compute_time = 0._dp, elapsed_time = 0._dp
REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: tampon ! buffer in case of bsend
@@ -251,4 +263,33 @@
!!
INTEGER :: iflag
+ INTEGER :: mpi_working_type
+ !!----------------------------------------------------------------------
+ !
+#if defined key_mpp_mpi
+ IF (wp == dp) THEN
+ mpi_working_type = mpi_double_precision
+ ELSE
+ mpi_working_type = mpi_real
+ END IF
+ CALL mpi_isend( pmess, kbytes, mpi_working_type, kdest , ktyp, mpi_comm_oce, md_req, iflag )
+#endif
+ !
+ END SUBROUTINE mppsend
+
+
+ SUBROUTINE mppsend_dp( ktyp, pmess, kbytes, kdest, md_req )
+ !!----------------------------------------------------------------------
+ !! *** routine mppsend ***
+ !!
+ !! ** Purpose : Send messag passing array
+ !!
+ !!----------------------------------------------------------------------
+ REAL(dp), INTENT(inout) :: pmess(*) ! array of real
+ INTEGER , INTENT(in ) :: kbytes ! size of the array pmess
+ INTEGER , INTENT(in ) :: kdest ! receive process number
+ INTEGER , INTENT(in ) :: ktyp ! tag of the message
+ INTEGER , INTENT(in ) :: md_req ! argument for isend
+ !!
+ INTEGER :: iflag
!!----------------------------------------------------------------------
!
@@ -257,5 +298,28 @@
#endif
!
- END SUBROUTINE mppsend
+ END SUBROUTINE mppsend_dp
+
+
+ SUBROUTINE mppsend_sp( ktyp, pmess, kbytes, kdest, md_req )
+ !!----------------------------------------------------------------------
+ !! *** routine mppsend ***
+ !!
+ !! ** Purpose : Send messag passing array
+ !!
+ !!----------------------------------------------------------------------
+ REAL(sp), INTENT(inout) :: pmess(*) ! array of real
+ INTEGER , INTENT(in ) :: kbytes ! size of the array pmess
+ INTEGER , INTENT(in ) :: kdest ! receive process number
+ INTEGER , INTENT(in ) :: ktyp ! tag of the message
+ INTEGER , INTENT(in ) :: md_req ! argument for isend
+ !!
+ INTEGER :: iflag
+ !!----------------------------------------------------------------------
+ !
+#if defined key_mpp_mpi
+ CALL mpi_isend( pmess, kbytes, mpi_real, kdest , ktyp, mpi_comm_oce, md_req, iflag )
+#endif
+ !
+ END SUBROUTINE mppsend_sp
@@ -275,4 +339,5 @@
INTEGER :: iflag
INTEGER :: use_source
+ INTEGER :: mpi_working_type
!!----------------------------------------------------------------------
!
@@ -283,8 +348,70 @@
IF( PRESENT(ksource) ) use_source = ksource
!
+ IF (wp == dp) THEN
+ mpi_working_type = mpi_double_precision
+ ELSE
+ mpi_working_type = mpi_real
+ END IF
+ CALL mpi_recv( pmess, kbytes, mpi_working_type, use_source, ktyp, mpi_comm_oce, istatus, iflag )
+#endif
+ !
+ END SUBROUTINE mpprecv
+
+ SUBROUTINE mpprecv_dp( ktyp, pmess, kbytes, ksource )
+ !!----------------------------------------------------------------------
+ !! *** routine mpprecv ***
+ !!
+ !! ** Purpose : Receive messag passing array
+ !!
+ !!----------------------------------------------------------------------
+ REAL(dp), INTENT(inout) :: pmess(*) ! array of real
+ INTEGER , INTENT(in ) :: kbytes ! suze of the array pmess
+ INTEGER , INTENT(in ) :: ktyp ! Tag of the recevied message
+ INTEGER, OPTIONAL, INTENT(in) :: ksource ! source process number
+ !!
+ INTEGER :: istatus(mpi_status_size)
+ INTEGER :: iflag
+ INTEGER :: use_source
+ !!----------------------------------------------------------------------
+ !
+#if defined key_mpp_mpi
+ ! If a specific process number has been passed to the receive call,
+ ! use that one. Default is to use mpi_any_source
+ use_source = mpi_any_source
+ IF( PRESENT(ksource) ) use_source = ksource
+ !
CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_oce, istatus, iflag )
#endif
!
- END SUBROUTINE mpprecv
+ END SUBROUTINE mpprecv_dp
+
+
+ SUBROUTINE mpprecv_sp( ktyp, pmess, kbytes, ksource )
+ !!----------------------------------------------------------------------
+ !! *** routine mpprecv ***
+ !!
+ !! ** Purpose : Receive messag passing array
+ !!
+ !!----------------------------------------------------------------------
+ REAL(sp), INTENT(inout) :: pmess(*) ! array of real
+ INTEGER , INTENT(in ) :: kbytes ! suze of the array pmess
+ INTEGER , INTENT(in ) :: ktyp ! Tag of the recevied message
+ INTEGER, OPTIONAL, INTENT(in) :: ksource ! source process number
+ !!
+ INTEGER :: istatus(mpi_status_size)
+ INTEGER :: iflag
+ INTEGER :: use_source
+ !!----------------------------------------------------------------------
+ !
+#if defined key_mpp_mpi
+ ! If a specific process number has been passed to the receive call,
+ ! use that one. Default is to use mpi_any_source
+ use_source = mpi_any_source
+ IF( PRESENT(ksource) ) use_source = ksource
+ !
+ CALL mpi_recv( pmess, kbytes, mpi_real, use_source, ktyp, mpi_comm_oce, istatus, iflag )
+#endif
+ !
+ END SUBROUTINE mpprecv_sp
@@ -351,5 +478,5 @@
CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine
CHARACTER(len=*), INTENT(in ) :: cdelay ! name (used as id) of the delayed operation
- COMPLEX(wp), INTENT(in ), DIMENSION(:) :: y_in
+ COMPLEX(dp), INTENT(in ), DIMENSION(:) :: y_in
REAL(wp), INTENT( out), DIMENSION(:) :: pout
LOGICAL, INTENT(in ) :: ldlast ! true if this is the last time we call this routine
@@ -359,5 +486,5 @@
INTEGER :: idvar
INTEGER :: ierr, ilocalcomm
- COMPLEX(wp), ALLOCATABLE, DIMENSION(:) :: ytmp
+ COMPLEX(dp), ALLOCATABLE, DIMENSION(:) :: ytmp
!!----------------------------------------------------------------------
#if defined key_mpp_mpi
@@ -402,5 +529,6 @@
# if defined key_mpi2
IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.)
- CALL mpi_allreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr )
+ CALL mpi_allreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ierr )
+ ndelayid(idvar) = 1
IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.)
# else
@@ -431,6 +559,17 @@
INTEGER :: idvar
INTEGER :: ierr, ilocalcomm
- !!----------------------------------------------------------------------
-#if defined key_mpp_mpi
+ INTEGER :: MPI_TYPE
+ !!----------------------------------------------------------------------
+
+#if defined key_mpp_mpi
+ if( wp == dp ) then
+ MPI_TYPE = MPI_DOUBLE_PRECISION
+ else if ( wp == sp ) then
+ MPI_TYPE = MPI_REAL
+ else
+ CALL ctl_stop( "Error defining type, wp is neither dp nor sp" )
+
+ end if
+
ilocalcomm = mpi_comm_oce
IF( PRESENT(kcom) ) ilocalcomm = kcom
@@ -469,8 +608,8 @@
# if defined key_mpi2
IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.)
- CALL mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr )
+ CALL mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_TYPE, mpi_max, ilocalcomm, ndelayid(idvar), ierr )
IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.)
# else
- CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr )
+ CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_TYPE, mpi_max, ilocalcomm, ndelayid(idvar), ierr )
# endif
#else
@@ -549,12 +688,32 @@
# undef INTEGER_TYPE
!
+ !!
+ !! ---- SINGLE PRECISION VERSIONS
+ !!
+# define SINGLE_PRECISION
# define REAL_TYPE
# define DIM_0d
-# define ROUTINE_ALLREDUCE mppmax_real
+# define ROUTINE_ALLREDUCE mppmax_real_sp
# include "mpp_allreduce_generic.h90"
# undef ROUTINE_ALLREDUCE
# undef DIM_0d
# define DIM_1d
-# define ROUTINE_ALLREDUCE mppmax_a_real
+# define ROUTINE_ALLREDUCE mppmax_a_real_sp
+# include "mpp_allreduce_generic.h90"
+# undef ROUTINE_ALLREDUCE
+# undef DIM_1d
+# undef SINGLE_PRECISION
+ !!
+ !!
+ !! ---- DOUBLE PRECISION VERSIONS
+ !!
+!
+# define DIM_0d
+# define ROUTINE_ALLREDUCE mppmax_real_dp
+# include "mpp_allreduce_generic.h90"
+# undef ROUTINE_ALLREDUCE
+# undef DIM_0d
+# define DIM_1d
+# define ROUTINE_ALLREDUCE mppmax_a_real_dp
# include "mpp_allreduce_generic.h90"
# undef ROUTINE_ALLREDUCE
@@ -581,12 +740,31 @@
# undef INTEGER_TYPE
!
+ !!
+ !! ---- SINGLE PRECISION VERSIONS
+ !!
+# define SINGLE_PRECISION
# define REAL_TYPE
# define DIM_0d
-# define ROUTINE_ALLREDUCE mppmin_real
+# define ROUTINE_ALLREDUCE mppmin_real_sp
# include "mpp_allreduce_generic.h90"
# undef ROUTINE_ALLREDUCE
# undef DIM_0d
# define DIM_1d
-# define ROUTINE_ALLREDUCE mppmin_a_real
+# define ROUTINE_ALLREDUCE mppmin_a_real_sp
+# include "mpp_allreduce_generic.h90"
+# undef ROUTINE_ALLREDUCE
+# undef DIM_1d
+# undef SINGLE_PRECISION
+ !!
+ !! ---- DOUBLE PRECISION VERSIONS
+ !!
+
+# define DIM_0d
+# define ROUTINE_ALLREDUCE mppmin_real_dp
+# include "mpp_allreduce_generic.h90"
+# undef ROUTINE_ALLREDUCE
+# undef DIM_0d
+# define DIM_1d
+# define ROUTINE_ALLREDUCE mppmin_a_real_dp
# include "mpp_allreduce_generic.h90"
# undef ROUTINE_ALLREDUCE
@@ -614,13 +792,38 @@
# undef DIM_1d
# undef INTEGER_TYPE
-!
+
+ !!
+ !! ---- SINGLE PRECISION VERSIONS
+ !!
+# define OPERATION_SUM
+# define SINGLE_PRECISION
# define REAL_TYPE
# define DIM_0d
-# define ROUTINE_ALLREDUCE mppsum_real
+# define ROUTINE_ALLREDUCE mppsum_real_sp
# include "mpp_allreduce_generic.h90"
# undef ROUTINE_ALLREDUCE
# undef DIM_0d
# define DIM_1d
-# define ROUTINE_ALLREDUCE mppsum_a_real
+# define ROUTINE_ALLREDUCE mppsum_a_real_sp
+# include "mpp_allreduce_generic.h90"
+# undef ROUTINE_ALLREDUCE
+# undef DIM_1d
+# undef REAL_TYPE
+# undef OPERATION_SUM
+
+# undef SINGLE_PRECISION
+
+ !!
+ !! ---- DOUBLE PRECISION VERSIONS
+ !!
+# define OPERATION_SUM
+# define REAL_TYPE
+# define DIM_0d
+# define ROUTINE_ALLREDUCE mppsum_real_dp
+# include "mpp_allreduce_generic.h90"
+# undef ROUTINE_ALLREDUCE
+# undef DIM_0d
+# define DIM_1d
+# define ROUTINE_ALLREDUCE mppsum_a_real_dp
# include "mpp_allreduce_generic.h90"
# undef ROUTINE_ALLREDUCE
@@ -649,12 +852,16 @@
!!----------------------------------------------------------------------
!!
+ !!
+ !! ---- SINGLE PRECISION VERSIONS
+ !!
+# define SINGLE_PRECISION
# define OPERATION_MINLOC
# define DIM_2d
-# define ROUTINE_LOC mpp_minloc2d
+# define ROUTINE_LOC mpp_minloc2d_sp
# include "mpp_loc_generic.h90"
# undef ROUTINE_LOC
# undef DIM_2d
# define DIM_3d
-# define ROUTINE_LOC mpp_minloc3d
+# define ROUTINE_LOC mpp_minloc3d_sp
# include "mpp_loc_generic.h90"
# undef ROUTINE_LOC
@@ -664,14 +871,44 @@
# define OPERATION_MAXLOC
# define DIM_2d
-# define ROUTINE_LOC mpp_maxloc2d
+# define ROUTINE_LOC mpp_maxloc2d_sp
# include "mpp_loc_generic.h90"
# undef ROUTINE_LOC
# undef DIM_2d
# define DIM_3d
-# define ROUTINE_LOC mpp_maxloc3d
+# define ROUTINE_LOC mpp_maxloc3d_sp
# include "mpp_loc_generic.h90"
# undef ROUTINE_LOC
# undef DIM_3d
# undef OPERATION_MAXLOC
+# undef SINGLE_PRECISION
+ !!
+ !! ---- DOUBLE PRECISION VERSIONS
+ !!
+# define OPERATION_MINLOC
+# define DIM_2d
+# define ROUTINE_LOC mpp_minloc2d_dp
+# include "mpp_loc_generic.h90"
+# undef ROUTINE_LOC
+# undef DIM_2d
+# define DIM_3d
+# define ROUTINE_LOC mpp_minloc3d_dp
+# include "mpp_loc_generic.h90"
+# undef ROUTINE_LOC
+# undef DIM_3d
+# undef OPERATION_MINLOC
+
+# define OPERATION_MAXLOC
+# define DIM_2d
+# define ROUTINE_LOC mpp_maxloc2d_dp
+# include "mpp_loc_generic.h90"
+# undef ROUTINE_LOC
+# undef DIM_2d
+# define DIM_3d
+# define ROUTINE_LOC mpp_maxloc3d_dp
+# include "mpp_loc_generic.h90"
+# undef ROUTINE_LOC
+# undef DIM_3d
+# undef OPERATION_MAXLOC
+
SUBROUTINE mppsync()
@@ -863,6 +1100,6 @@
! Look for how many procs on the northern boundary
ndim_rank_north = 0
- DO jjproc = 1, jpnij
- IF( njmppt(jjproc) == njmppmax ) ndim_rank_north = ndim_rank_north + 1
+ DO jjproc = 1, jpni
+ IF( nfproc(jjproc) /= -1 ) ndim_rank_north = ndim_rank_north + 1
END DO
!
@@ -874,8 +1111,8 @@
! Note : the rank start at 0 in MPI
ii = 0
- DO ji = 1, jpnij
- IF ( njmppt(ji) == njmppmax ) THEN
+ DO ji = 1, jpni
+ IF ( nfproc(ji) /= -1 ) THEN
ii=ii+1
- nrank_north(ii)=ji-1
+ nrank_north(ii)=nfproc(ji)
END IF
END DO
@@ -902,8 +1139,8 @@
!!---------------------------------------------------------------------
INTEGER , INTENT(in) :: ilen, itype
- COMPLEX(wp), DIMENSION(ilen), INTENT(in) :: ydda
- COMPLEX(wp), DIMENSION(ilen), INTENT(inout) :: yddb
- !
- REAL(wp) :: zerr, zt1, zt2 ! local work variables
+ COMPLEX(dp), DIMENSION(ilen), INTENT(in) :: ydda
+ COMPLEX(dp), DIMENSION(ilen), INTENT(inout) :: yddb
+ !
+ REAL(dp) :: zerr, zt1, zt2 ! local work variables
INTEGER :: ji, ztmp ! local scalar
!!---------------------------------------------------------------------
@@ -1058,6 +1295,6 @@
LOGICAL, INTENT(IN) :: ld_tic
LOGICAL, OPTIONAL, INTENT(IN) :: ld_global
- REAL(wp), DIMENSION(2), SAVE :: tic_wt
- REAL(wp), SAVE :: tic_ct = 0._wp
+ REAL(dp), DIMENSION(2), SAVE :: tic_wt
+ REAL(dp), SAVE :: tic_ct = 0._dp
INTEGER :: ii
#if defined key_mpp_mpi
@@ -1072,5 +1309,5 @@
IF ( ld_tic ) THEN
tic_wt(ii) = MPI_Wtime() ! start count tic->tac (waiting time)
- IF ( tic_ct > 0.0_wp ) compute_time = compute_time + MPI_Wtime() - tic_ct ! cumulate count tac->tic
+ IF ( tic_ct > 0.0_dp ) compute_time = compute_time + MPI_Wtime() - tic_ct ! cumulate count tac->tic
ELSE
waiting_time(ii) = waiting_time(ii) + MPI_Wtime() - tic_wt(ii) ! cumulate count tic->tac
@@ -1110,10 +1347,20 @@
CHARACTER(len=*), INTENT(in ), OPTIONAL :: cd2, cd3, cd4, cd5
CHARACTER(len=*), INTENT(in ), OPTIONAL :: cd6, cd7, cd8, cd9, cd10
+ !
+ CHARACTER(LEN=8) :: clfmt ! writing format
+ INTEGER :: inum
!!----------------------------------------------------------------------
!
nstop = nstop + 1
!
- ! force to open ocean.output file if not already opened
- IF( numout == 6 ) CALL ctl_opn( numout, 'ocean.output', 'APPEND', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. )
+ IF( cd1 == 'STOP' .AND. narea /= 1 ) THEN ! Immediate stop: add an arror message in 'ocean.output' file
+ CALL ctl_opn( inum, 'ocean.output', 'APPEND', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. )
+ WRITE(inum,*)
+ WRITE(inum,*) ' ==>>> Look for "E R R O R" messages in all existing *ocean.output* files'
+ CLOSE(inum)
+ ENDIF
+ IF( numout == 6 ) THEN ! force to open ocean.output file if not already opened
+ CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE., narea )
+ ENDIF
!
WRITE(numout,*)
@@ -1143,4 +1390,6 @@
WRITE(numout,*) 'huge E-R-R-O-R : immediate stop'
WRITE(numout,*)
+ CALL FLUSH(numout)
+ CALL SLEEP(60) ! make sure that all output and abort files are written by all cores. 60s should be enough...
CALL mppstop( ld_abort = .true. )
ENDIF
@@ -1205,5 +1454,7 @@
!
CHARACTER(len=80) :: clfile
+ CHARACTER(LEN=10) :: clfmt ! writing format
INTEGER :: iost
+ INTEGER :: idg ! number of digits
!!----------------------------------------------------------------------
!
@@ -1212,5 +1463,10 @@
clfile = TRIM(cdfile)
IF( PRESENT( karea ) ) THEN
- IF( karea > 1 ) WRITE(clfile, "(a,'_',i4.4)") TRIM(clfile), karea-1
+ IF( karea > 1 ) THEN
+ ! Warning: jpnij is maybe not already defined when calling ctl_opn -> use mppsize instead of jpnij
+ idg = MAX( INT(LOG10(REAL(MAX(1,mppsize-1),wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9
+ WRITE(clfmt, "('(a,a,i', i1, '.', i1, ')')") idg, idg ! '(a,a,ix.x)'
+ WRITE(clfile, clfmt) TRIM(clfile), '_', karea-1
+ ENDIF
ENDIF
#if defined key_agrif
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/mpp_allreduce_generic.h90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/mpp_allreduce_generic.h90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/mpp_allreduce_generic.h90 (revision 13540)
@@ -1,7 +1,13 @@
! !== IN: ptab is an array ==!
# if defined REAL_TYPE
-# define ARRAY_TYPE(i) REAL(wp) , INTENT(inout) :: ARRAY_IN(i)
-# define TMP_TYPE(i) REAL(wp) , ALLOCATABLE :: work(i)
-# define MPI_TYPE mpi_double_precision
+# if defined SINGLE_PRECISION
+# define ARRAY_TYPE(i) REAL(sp) , INTENT(inout) :: ARRAY_IN(i)
+# define TMP_TYPE(i) REAL(sp) , ALLOCATABLE :: work(i)
+# define MPI_TYPE mpi_real
+# else
+# define ARRAY_TYPE(i) REAL(dp) , INTENT(inout) :: ARRAY_IN(i)
+# define TMP_TYPE(i) REAL(dp) , ALLOCATABLE :: work(i)
+# define MPI_TYPE mpi_double_precision
+# endif
# endif
# if defined INTEGER_TYPE
@@ -11,6 +17,6 @@
# endif
# if defined COMPLEX_TYPE
-# define ARRAY_TYPE(i) COMPLEX , INTENT(inout) :: ARRAY_IN(i)
-# define TMP_TYPE(i) COMPLEX , ALLOCATABLE :: work(i)
+# define ARRAY_TYPE(i) COMPLEX(dp) , INTENT(inout) :: ARRAY_IN(i)
+# define TMP_TYPE(i) COMPLEX(dp) , ALLOCATABLE :: work(i)
# define MPI_TYPE mpi_double_complex
# endif
@@ -75,4 +81,5 @@
END SUBROUTINE ROUTINE_ALLREDUCE
+#undef PRECISION
#undef ARRAY_TYPE
#undef ARRAY_IN
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/mpp_lbc_north_icb_generic.h90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/mpp_lbc_north_icb_generic.h90 (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/mpp_lbc_north_icb_generic.h90 (revision 13540)
@@ -0,0 +1,114 @@
+# if defined SINGLE_PRECISION
+# define PRECISION sp
+# define SENDROUTINE mppsend_sp
+# define RECVROUTINE mpprecv_sp
+# define MPI_TYPE MPI_REAL
+# else
+# define PRECISION dp
+# define SENDROUTINE mppsend_dp
+# define RECVROUTINE mpprecv_dp
+# define MPI_TYPE MPI_DOUBLE_PRECISION
+# endif
+
+ SUBROUTINE ROUTINE_LNK( pt2d, cd_type, psgn, kextj)
+ !!---------------------------------------------------------------------
+ !! *** routine mpp_lbc_north_icb ***
+ !!
+ !! ** Purpose : Ensure proper north fold horizontal bondary condition
+ !! in mpp configuration in case of jpn1 > 1 and for 2d
+ !! array with outer extra halo
+ !!
+ !! ** Method : North fold condition and mpp with more than one proc
+ !! in i-direction require a specific treatment. We gather
+ !! the 4+kextj northern lines of the global domain on 1
+ !! processor and apply lbc north-fold on this sub array.
+ !! Then we scatter the north fold array back to the processors.
+ !! This routine accounts for an extra halo with icebergs
+ !! and assumes ghost rows and columns have been suppressed.
+ !!
+ !!----------------------------------------------------------------------
+ REAL(PRECISION), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array with extra halo
+ CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points
+ ! ! = T , U , V , F or W -points
+ REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the
+ !! ! north fold, = 1. otherwise
+ INTEGER , INTENT(in ) :: kextj ! Extra halo width at north fold
+ !
+ INTEGER :: ji, jj, jr
+ INTEGER :: ierr, itaille
+ INTEGER :: ipj, ij, iproc, ijnr, ii1, ipi, impp
+ !
+ REAL(PRECISION), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e
+ REAL(PRECISION), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e
+ !!----------------------------------------------------------------------
+#if defined key_mpp_mpi
+ !
+ ipj=4
+ ALLOCATE( ztab_e(jpiglo, 1-kextj:ipj+kextj) , &
+ & znorthloc_e(jpimax, 1-kextj:ipj+kextj) , &
+ & znorthgloio_e(jpimax, 1-kextj:ipj+kextj,ndim_rank_north) )
+ !
+# if defined SINGLE_PRECISION
+ ztab_e(:,:) = 0._sp
+ znorthloc_e(:,:) = 0._sp
+# else
+ ztab_e(:,:) = 0._dp
+ znorthloc_e(:,:) = 0._dp
+# endif
+ !
+ ij = 1 - kextj
+ ! put the last ipj+2*kextj lines of pt2d into znorthloc_e
+ DO jj = jpj - ipj + 1 - kextj , jpj + kextj
+ znorthloc_e(1:jpi,ij)=pt2d(1:jpi,jj)
+ ij = ij + 1
+ END DO
+ !
+ itaille = jpimax * ( ipj + 2*kextj )
+ !
+ IF( ln_timing ) CALL tic_tac(.TRUE.)
+#if defined key_mpp_mpi
+ CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj) , itaille, MPI_TYPE, &
+ & znorthgloio_e(1,1-kextj,1), itaille, MPI_TYPE, &
+ & ncomm_north, ierr )
+#endif
+ !
+ IF( ln_timing ) CALL tic_tac(.FALSE.)
+ !
+ ijnr = 0
+ DO jr = 1, ndim_rank_north ! recover the global north array
+ iproc = nfproc(jr)
+ IF( iproc /= -1 ) THEN
+ impp = nfimpp(jr)
+ ipi = nfjpi(jr)
+ ijnr = ijnr + 1
+ DO jj = 1-kextj, ipj+kextj
+ DO ji = 1, ipi
+ ii1 = impp + ji - 1 ! corresponds to mig(ji) but for subdomain iproc
+ ztab_e(ii1,jj) = znorthgloio_e(ji,jj,ijnr)
+ END DO
+ END DO
+ ENDIF
+ END DO
+
+ ! 2. North-Fold boundary conditions
+ ! ----------------------------------
+ CALL lbc_nfd( ztab_e(:,1-kextj:ipj+kextj), cd_type, psgn, kextj )
+
+ ij = 1 - kextj
+ !! Scatter back to pt2d
+ DO jj = jpj - ipj + 1 - kextj , jpj + kextj
+ DO ji= 1, jpi
+ pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij)
+ END DO
+ ij = ij +1
+ END DO
+ !
+ DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e )
+ !
+#endif
+ END SUBROUTINE ROUTINE_LNK
+
+# undef PRECISION
+# undef SENDROUTINE
+# undef RECVROUTINE
+# undef MPI_TYPE
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/mpp_lnk_generic.h90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/mpp_lnk_generic.h90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/mpp_lnk_generic.h90 (revision 13540)
@@ -5,5 +5,9 @@
# define OPT_K(k) ,ipf
# if defined DIM_2d
-# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D) , INTENT(inout) :: ptab(f)
+# if defined SINGLE_PRECISION
+# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_sp) , INTENT(inout) :: ptab(f)
+# else
+# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_dp) , INTENT(inout) :: ptab(f)
+# endif
# define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j)
# define K_SIZE(ptab) 1
@@ -11,5 +15,9 @@
# endif
# if defined DIM_3d
-# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D) , INTENT(inout) :: ptab(f)
+# if defined SINGLE_PRECISION
+# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_sp) , INTENT(inout) :: ptab(f)
+# else
+# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_dp) , INTENT(inout) :: ptab(f)
+# endif
# define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k)
# define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3)
@@ -17,5 +25,9 @@
# endif
# if defined DIM_4d
-# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D) , INTENT(inout) :: ptab(f)
+# if defined SINGLE_PRECISION
+# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_sp) , INTENT(inout) :: ptab(f)
+# else
+# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_dp) , INTENT(inout) :: ptab(f)
+# endif
# define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l)
# define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3)
@@ -23,5 +35,9 @@
# endif
#else
-# define ARRAY_TYPE(i,j,k,l,f) REAL(wp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f)
+# if defined SINGLE_PRECISION
+# define ARRAY_TYPE(i,j,k,l,f) REAL(sp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f)
+# else
+# define ARRAY_TYPE(i,j,k,l,f) REAL(dp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f)
+# endif
# define NAT_IN(k) cd_nat
# define SGN_IN(k) psgn
@@ -45,9 +61,19 @@
#endif
+# if defined SINGLE_PRECISION
+# define PRECISION sp
+# define SENDROUTINE mppsend_sp
+# define RECVROUTINE mpprecv_sp
+# else
+# define PRECISION dp
+# define SENDROUTINE mppsend_dp
+# define RECVROUTINE mpprecv_dp
+# endif
+
#if defined MULTI
- SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv, ihlcom )
+ SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv )
INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays
#else
- SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn , kfillmode, pfillval, lsend, lrecv, ihlcom )
+ SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn , kfillmode, pfillval, lsend, lrecv )
#endif
ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied
@@ -58,5 +84,4 @@
REAL(wp), OPTIONAL, INTENT(in ) :: pfillval ! background value (used at closed boundaries)
LOGICAL, DIMENSION(4),OPTIONAL, INTENT(in ) :: lsend, lrecv ! communication with other 4 proc
- INTEGER ,OPTIONAL, INTENT(in ) :: ihlcom ! number of ranks and rows to be communicated
!
INTEGER :: ji, jj, jk, jl, jf ! dummy loop indices
@@ -66,9 +91,8 @@
INTEGER :: ierr
INTEGER :: ifill_we, ifill_ea, ifill_so, ifill_no
- INTEGER :: ihl ! number of ranks and rows to be communicated
REAL(wp) :: zland
INTEGER , DIMENSION(MPI_STATUS_SIZE) :: istat ! for mpi_isend
- REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_we, zrcv_we, zsnd_ea, zrcv_ea ! east -west & west - east halos
- REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_so, zrcv_so, zsnd_no, zrcv_no ! north-south & south-north halos
+ REAL(PRECISION), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_we, zrcv_we, zsnd_ea, zrcv_ea ! east -west & west - east halos
+ REAL(PRECISION), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_so, zrcv_so, zsnd_no, zrcv_no ! north-south & south-north halos
LOGICAL :: llsend_we, llsend_ea, llsend_no, llsend_so ! communication send
LOGICAL :: llrecv_we, llrecv_ea, llrecv_no, llrecv_so ! communication receive
@@ -83,8 +107,4 @@
ipl = L_SIZE(ptab) ! 4th -
ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers)
- !
- IF( PRESENT(ihlcom) ) THEN ; ihl = ihlcom
- ELSE ; ihl = 1
- END IF
!
IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. )
@@ -149,23 +169,23 @@
!
! Must exchange the whole column (from 1 to jpj) to get the corners if we have no south/north neighbourg
- isize = ihl * jpj * ipk * ipl * ipf
+ isize = nn_hls * jpj * ipk * ipl * ipf
!
! Allocate local temporary arrays to be sent/received. Fill arrays to be sent
- IF( llsend_we ) ALLOCATE( zsnd_we(ihl,jpj,ipk,ipl,ipf) )
- IF( llsend_ea ) ALLOCATE( zsnd_ea(ihl,jpj,ipk,ipl,ipf) )
- IF( llrecv_we ) ALLOCATE( zrcv_we(ihl,jpj,ipk,ipl,ipf) )
- IF( llrecv_ea ) ALLOCATE( zrcv_ea(ihl,jpj,ipk,ipl,ipf) )
+ IF( llsend_we ) ALLOCATE( zsnd_we(nn_hls,jpj,ipk,ipl,ipf) )
+ IF( llsend_ea ) ALLOCATE( zsnd_ea(nn_hls,jpj,ipk,ipl,ipf) )
+ IF( llrecv_we ) ALLOCATE( zrcv_we(nn_hls,jpj,ipk,ipl,ipf) )
+ IF( llrecv_ea ) ALLOCATE( zrcv_ea(nn_hls,jpj,ipk,ipl,ipf) )
!
IF( llsend_we ) THEN ! copy western side of the inner mpi domain in local temporary array to be sent by MPI
- ishift = ihl
- DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl
- zsnd_we(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf) ! ihl + 1 -> 2*ihl
+ ishift = nn_hls
+ DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls
+ zsnd_we(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf) ! nn_hls + 1 -> 2*nn_hls
END DO ; END DO ; END DO ; END DO ; END DO
ENDIF
!
IF(llsend_ea ) THEN ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI
- ishift = jpi - 2 * ihl
- DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl
- zsnd_ea(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf) ! jpi - 2*ihl + 1 -> jpi - ihl
+ ishift = jpi - 2 * nn_hls
+ DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls
+ zsnd_ea(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf) ! jpi - 2*nn_hls + 1 -> jpi - nn_hls
END DO ; END DO ; END DO ; END DO ; END DO
ENDIF
@@ -174,9 +194,9 @@
!
! non-blocking send of the western/eastern side using local temporary arrays
- IF( llsend_we ) CALL mppsend( 1, zsnd_we(1,1,1,1,1), isize, nowe, ireq_we )
- IF( llsend_ea ) CALL mppsend( 2, zsnd_ea(1,1,1,1,1), isize, noea, ireq_ea )
+ IF( llsend_we ) CALL SENDROUTINE( 1, zsnd_we(1,1,1,1,1), isize, nowe, ireq_we )
+ IF( llsend_ea ) CALL SENDROUTINE( 2, zsnd_ea(1,1,1,1,1), isize, noea, ireq_ea )
! blocking receive of the western/eastern halo in local temporary arrays
- IF( llrecv_we ) CALL mpprecv( 2, zrcv_we(1,1,1,1,1), isize, nowe )
- IF( llrecv_ea ) CALL mpprecv( 1, zrcv_ea(1,1,1,1,1), isize, noea )
+ IF( llrecv_we ) CALL RECVROUTINE( 2, zrcv_we(1,1,1,1,1), isize, nowe )
+ IF( llrecv_ea ) CALL RECVROUTINE( 1, zrcv_ea(1,1,1,1,1), isize, noea )
!
IF( ln_timing ) CALL tic_tac(.FALSE.)
@@ -189,56 +209,48 @@
! 2.1 fill weastern halo
! ----------------------
- ! ishift = 0 ! fill halo from ji = 1 to ihl
+ ! ishift = 0 ! fill halo from ji = 1 to nn_hls
SELECT CASE ( ifill_we )
CASE ( jpfillnothing ) ! no filling
CASE ( jpfillmpi ) ! use data received by MPI
- DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl
- ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_we(ji,jj,jk,jl,jf) ! 1 -> ihl
- END DO; END DO ; END DO ; END DO ; END DO
+ DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls
+ ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_we(ji,jj,jk,jl,jf) ! 1 -> nn_hls
+ END DO ; END DO ; END DO ; END DO ; END DO
CASE ( jpfillperio ) ! use east-weast periodicity
- ishift2 = jpi - 2 * ihl
- DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl
+ ishift2 = jpi - 2 * nn_hls
+ DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls
ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf)
- END DO; END DO ; END DO ; END DO ; END DO
+ END DO ; END DO ; END DO ; END DO ; END DO
CASE ( jpfillcopy ) ! filling with inner domain values
- DO jf = 1, ipf ! number of arrays to be treated
- IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point
- DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl
- ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ihl+1,jj,jk,jl,jf)
- END DO ; END DO ; END DO ; END DO
- ENDIF
- END DO
+ DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls
+ ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(nn_hls+1,jj,jk,jl,jf)
+ END DO ; END DO ; END DO ; END DO ; END DO
CASE ( jpfillcst ) ! filling with constant value
- DO jf = 1, ipf ! number of arrays to be treated
- IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point
- DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl
- ARRAY_IN(ji,jj,jk,jl,jf) = zland
- END DO; END DO ; END DO ; END DO
- ENDIF
- END DO
+ DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls
+ ARRAY_IN(ji,jj,jk,jl,jf) = zland
+ END DO ; END DO ; END DO ; END DO ; END DO
END SELECT
!
! 2.2 fill eastern halo
! ---------------------
- ishift = jpi - ihl ! fill halo from ji = jpi-ihl+1 to jpi
+ ishift = jpi - nn_hls ! fill halo from ji = jpi-nn_hls+1 to jpi
SELECT CASE ( ifill_ea )
CASE ( jpfillnothing ) ! no filling
CASE ( jpfillmpi ) ! use data received by MPI
- DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl
- ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zrcv_ea(ji,jj,jk,jl,jf) ! jpi - ihl + 1 -> jpi
+ DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls
+ ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zrcv_ea(ji,jj,jk,jl,jf) ! jpi - nn_hls + 1 -> jpi
END DO ; END DO ; END DO ; END DO ; END DO
CASE ( jpfillperio ) ! use east-weast periodicity
- ishift2 = ihl
- DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl
+ ishift2 = nn_hls
+ DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls
ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf)
END DO ; END DO ; END DO ; END DO ; END DO
CASE ( jpfillcopy ) ! filling with inner domain values
- DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl
+ DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls
ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift,jj,jk,jl,jf)
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, jpj ; DO ji = 1, ihl
+ DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls
ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zland
- END DO; END DO ; END DO ; END DO ; END DO
+ END DO ; END DO ; END DO ; END DO ; END DO
END SELECT
!
@@ -252,6 +264,6 @@
!
SELECT CASE ( jpni )
- CASE ( 1 ) ; CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! only 1 northern proc, no mpp
- CASE DEFAULT ; CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! for all northern procs.
+ CASE ( 1 ) ; CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! only 1 northern proc, no mpp
+ CASE DEFAULT ; CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:), ifill_no, zland OPT_K(:) ) ! for all northern procs.
END SELECT
!
@@ -264,23 +276,23 @@
! ---------------------------------------------------- !
!
- IF( llsend_so ) ALLOCATE( zsnd_so(jpi,ihl,ipk,ipl,ipf) )
- IF( llsend_no ) ALLOCATE( zsnd_no(jpi,ihl,ipk,ipl,ipf) )
- IF( llrecv_so ) ALLOCATE( zrcv_so(jpi,ihl,ipk,ipl,ipf) )
- IF( llrecv_no ) ALLOCATE( zrcv_no(jpi,ihl,ipk,ipl,ipf) )
- !
- isize = jpi * ihl * ipk * ipl * ipf
+ IF( llsend_so ) ALLOCATE( zsnd_so(jpi,nn_hls,ipk,ipl,ipf) )
+ IF( llsend_no ) ALLOCATE( zsnd_no(jpi,nn_hls,ipk,ipl,ipf) )
+ IF( llrecv_so ) ALLOCATE( zrcv_so(jpi,nn_hls,ipk,ipl,ipf) )
+ IF( llrecv_no ) ALLOCATE( zrcv_no(jpi,nn_hls,ipk,ipl,ipf) )
+ !
+ isize = jpi * nn_hls * ipk * ipl * ipf
! allocate local temporary arrays to be sent/received. Fill arrays to be sent
IF( llsend_so ) THEN ! copy sourhern side of the inner mpi domain in local temporary array to be sent by MPI
- ishift = ihl
- DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi
- zsnd_so(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf) ! ihl+1 -> 2*ihl
+ ishift = nn_hls
+ DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi
+ zsnd_so(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf) ! nn_hls+1 -> 2*nn_hls
END DO ; END DO ; END DO ; END DO ; END DO
ENDIF
!
IF( llsend_no ) THEN ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI
- ishift = jpj - 2 * ihl
- DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi
- zsnd_no(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf) ! jpj-2*ihl+1 -> jpj-ihl
+ ishift = jpj - 2 * nn_hls
+ DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi
+ zsnd_no(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf) ! jpj-2*nn_hls+1 -> jpj-nn_hls
END DO ; END DO ; END DO ; END DO ; END DO
ENDIF
@@ -289,9 +301,9 @@
!
! non-blocking send of the southern/northern side
- IF( llsend_so ) CALL mppsend( 3, zsnd_so(1,1,1,1,1), isize, noso, ireq_so )
- IF( llsend_no ) CALL mppsend( 4, zsnd_no(1,1,1,1,1), isize, nono, ireq_no )
+ IF( llsend_so ) CALL SENDROUTINE( 3, zsnd_so(1,1,1,1,1), isize, noso, ireq_so )
+ IF( llsend_no ) CALL SENDROUTINE( 4, zsnd_no(1,1,1,1,1), isize, nono, ireq_no )
! blocking receive of the southern/northern halo
- IF( llrecv_so ) CALL mpprecv( 4, zrcv_so(1,1,1,1,1), isize, noso )
- IF( llrecv_no ) CALL mpprecv( 3, zrcv_no(1,1,1,1,1), isize, nono )
+ IF( llrecv_so ) CALL RECVROUTINE( 4, zrcv_so(1,1,1,1,1), isize, noso )
+ IF( llrecv_no ) CALL RECVROUTINE( 3, zrcv_no(1,1,1,1,1), isize, nono )
!
IF( ln_timing ) CALL tic_tac(.FALSE.)
@@ -303,56 +315,48 @@
! 5.1 fill southern halo
! ----------------------
- ! ishift = 0 ! fill halo from jj = 1 to ihl
+ ! ishift = 0 ! fill halo from jj = 1 to nn_hls
SELECT CASE ( ifill_so )
CASE ( jpfillnothing ) ! no filling
CASE ( jpfillmpi ) ! use data received by MPI
- DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi
- ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_so(ji,jj,jk,jl,jf) ! 1 -> ihl
- END DO; END DO ; END DO ; END DO ; END DO
+ DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi
+ ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_so(ji,jj,jk,jl,jf) ! 1 -> nn_hls
+ END DO ; END DO ; END DO ; END DO ; END DO
CASE ( jpfillperio ) ! use north-south periodicity
- ishift2 = jpj - 2 * ihl
- DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi
+ ishift2 = jpj - 2 * nn_hls
+ DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi
ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf)
- END DO; END DO ; END DO ; END DO ; END DO
+ END DO ; END DO ; END DO ; END DO ; END DO
CASE ( jpfillcopy ) ! filling with inner domain values
- DO jf = 1, ipf ! number of arrays to be treated
- IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point
- DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi
- ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ihl+1,jk,jl,jf)
- END DO ; END DO ; END DO ; END DO
- ENDIF
- END DO
+ DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi
+ ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,nn_hls+1,jk,jl,jf)
+ END DO ; END DO ; END DO ; END DO ; END DO
CASE ( jpfillcst ) ! filling with constant value
- DO jf = 1, ipf ! number of arrays to be treated
- IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point
- DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi
- ARRAY_IN(ji,jj,jk,jl,jf) = zland
- END DO; END DO ; END DO ; END DO
- ENDIF
- END DO
+ DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi
+ ARRAY_IN(ji,jj,jk,jl,jf) = zland
+ END DO ; END DO ; END DO ; END DO ; END DO
END SELECT
!
! 5.2 fill northern halo
! ----------------------
- ishift = jpj - ihl ! fill halo from jj = jpj-ihl+1 to jpj
+ ishift = jpj - nn_hls ! fill halo from jj = jpj-nn_hls+1 to jpj
SELECT CASE ( ifill_no )
CASE ( jpfillnothing ) ! no filling
CASE ( jpfillmpi ) ! use data received by MPI
- DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi
- ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zrcv_no(ji,jj,jk,jl,jf) ! jpj-ihl+1 -> jpj
+ DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi
+ ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zrcv_no(ji,jj,jk,jl,jf) ! jpj-nn_hls+1 -> jpj
END DO ; END DO ; END DO ; END DO ; END DO
CASE ( jpfillperio ) ! use north-south periodicity
- ishift2 = ihl
- DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi
+ ishift2 = nn_hls
+ DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi
ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf)
- END DO; END DO ; END DO ; END DO ; END DO
+ END DO ; END DO ; END DO ; END DO ; END DO
CASE ( jpfillcopy ) ! filling with inner domain values
- DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi
+ DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi
ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift,jk,jl,jf)
- END DO; END DO ; END DO ; END DO ; 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, ihl ; DO ji = 1, jpi
+ DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi
ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zland
- END DO; END DO ; END DO ; END DO ; END DO
+ END DO ; END DO ; END DO ; END DO ; END DO
END SELECT
!
@@ -384,5 +388,7 @@
!
END SUBROUTINE ROUTINE_LNK
-
+#undef PRECISION
+#undef SENDROUTINE
+#undef RECVROUTINE
#undef ARRAY_TYPE
#undef NAT_IN
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/mpp_lnk_icb_generic.h90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/mpp_lnk_icb_generic.h90 (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/mpp_lnk_icb_generic.h90 (revision 13540)
@@ -0,0 +1,223 @@
+# if defined SINGLE_PRECISION
+# define PRECISION sp
+# define SENDROUTINE mppsend_sp
+# define RECVROUTINE mpprecv_sp
+# define LBCNORTH mpp_lbc_north_icb_sp
+# else
+# define PRECISION dp
+# define SENDROUTINE mppsend_dp
+# define RECVROUTINE mpprecv_dp
+# define LBCNORTH mpp_lbc_north_icb_dp
+# endif
+
+ SUBROUTINE ROUTINE_LNK( cdname, pt2d, cd_type, psgn, kexti, kextj )
+ !!----------------------------------------------------------------------
+ !! *** routine mpp_lnk_2d_icb ***
+ !!
+ !! ** Purpose : Message passing management for 2d array (with extra halo for icebergs)
+ !! This routine receives a (1-kexti:jpi+kexti,1-kexti:jpj+kextj)
+ !! array (usually (0:jpi+1, 0:jpj+1)) from lbc_lnk_icb calls.
+ !!
+ !! ** Method : Use mppsend and mpprecv function for passing mask
+ !! between processors following neighboring subdomains.
+ !! domain parameters
+ !! jpi : first dimension of the local subdomain
+ !! jpj : second dimension of the local subdomain
+ !! kexti : number of columns for extra outer halo
+ !! kextj : number of rows for extra outer halo
+ !! nbondi : mark for "east-west local boundary"
+ !! nbondj : mark for "north-south local boundary"
+ !! noea : number for local neighboring processors
+ !! nowe : number for local neighboring processors
+ !! noso : number for local neighboring processors
+ !! nono : number for local neighboring processors
+ !!----------------------------------------------------------------------
+ CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine
+ REAL(PRECISION), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) :: pt2d ! 2D array with extra halo
+ CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points
+ REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold
+ INTEGER , INTENT(in ) :: kexti ! extra i-halo width
+ INTEGER , INTENT(in ) :: kextj ! extra j-halo width
+ !
+ INTEGER :: jl ! dummy loop indices
+ INTEGER :: imigr, iihom, ijhom ! local integers
+ INTEGER :: ipreci, iprecj ! - -
+ INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
+ INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
+ !!
+ REAL(PRECISION), DIMENSION(1-kexti:jpi+kexti,nn_hls+kextj,2) :: r2dns, r2dsn
+ REAL(PRECISION), DIMENSION(1-kextj:jpj+kextj,nn_hls+kexti,2) :: r2dwe, r2dew
+ !!----------------------------------------------------------------------
+ ipreci = nn_hls + kexti ! take into account outer extra 2D overlap area
+ iprecj = nn_hls + kextj
+
+ IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, 1, 1, 1, ld_lbc = .TRUE. )
+
+ ! 1. standard boundary treatment
+ ! ------------------------------
+ ! Order matters Here !!!!
+ !
+ ! ! East-West boundaries
+ ! !* Cyclic east-west
+ IF( l_Iperio ) THEN
+ pt2d(1-kexti: 1 ,:) = pt2d(jpim1-kexti: jpim1 ,:) ! east
+ pt2d( jpi :jpi+kexti,:) = pt2d( 2 :2+kexti,:) ! west
+ !
+ ELSE !* closed
+# if defined SINGLE_PRECISION
+ IF( .NOT. cd_type == 'F' ) pt2d( 1-kexti :nn_hls ,:) = 0._sp ! east except at F-point
+ pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._sp ! west
+# else
+ IF( .NOT. cd_type == 'F' ) pt2d( 1-kexti :nn_hls ,:) = 0._dp ! east except at F-point
+ pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._dp ! west
+# endif
+ ENDIF
+ ! ! North-South boundaries
+ IF( l_Jperio ) THEN !* cyclic (only with no mpp j-split)
+ pt2d(:,1-kextj: 1 ) = pt2d(:,jpjm1-kextj: jpjm1) ! north
+ pt2d(:, jpj :jpj+kextj) = pt2d(:, 2 :2+kextj) ! south
+ ELSE !* closed
+# if defined SINGLE_PRECISION
+ IF( .NOT. cd_type == 'F' ) pt2d(:, 1-kextj :nn_hls ) = 0._sp ! north except at F-point
+ pt2d(:,jpj-nn_hls+1:jpj+kextj) = 0._sp ! south
+# else
+ IF( .NOT. cd_type == 'F' ) pt2d(:, 1-kextj :nn_hls ) = 0._dp ! north except at F-point
+ pt2d(:,jpj-nn_hls+1:jpj+kextj) = 0._dp ! south
+# endif
+ ENDIF
+ !
+
+ ! north fold treatment
+ ! -----------------------
+ IF( npolj /= 0 ) THEN
+ !
+ SELECT CASE ( jpni )
+ CASE ( 1 ) ; CALL lbc_nfd ( 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
+ !
+ ENDIF
+
+ ! 2. East and west directions exchange
+ ! ------------------------------------
+ ! we play with the neigbours AND the row number because of the periodicity
+ !
+ SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions
+ CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
+ iihom = jpi - (2 * nn_hls) -kexti
+ DO jl = 1, ipreci
+ r2dew(:,jl,1) = pt2d(nn_hls+jl,:)
+ r2dwe(:,jl,1) = pt2d(iihom +jl,:)
+ END DO
+ END SELECT
+ !
+ ! ! Migrations
+ imigr = ipreci * ( jpj + 2*kextj )
+ !
+ ! ! Migrations
+ imigr = ipreci * ( jpj + 2*kextj )
+ !
+ IF( ln_timing ) CALL tic_tac(.TRUE.)
+ !
+ SELECT CASE ( nbondi )
+ CASE ( -1 )
+ CALL SENDROUTINE( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req1 )
+ CALL RECVROUTINE( 1, r2dew(1-kextj,1,2), imigr, noea )
+ CALL mpi_wait(ml_req1,ml_stat,ml_err)
+ CASE ( 0 )
+ CALL SENDROUTINE( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 )
+ CALL SENDROUTINE( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req2 )
+ CALL RECVROUTINE( 1, r2dew(1-kextj,1,2), imigr, noea )
+ CALL RECVROUTINE( 2, r2dwe(1-kextj,1,2), imigr, nowe )
+ CALL mpi_wait(ml_req1,ml_stat,ml_err)
+ CALL mpi_wait(ml_req2,ml_stat,ml_err)
+ CASE ( 1 )
+ CALL SENDROUTINE( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 )
+ CALL RECVROUTINE( 2, r2dwe(1-kextj,1,2), imigr, nowe )
+ CALL mpi_wait(ml_req1,ml_stat,ml_err)
+ END SELECT
+ !
+ IF( ln_timing ) CALL tic_tac(.FALSE.)
+ !
+ ! ! Write Dirichlet lateral conditions
+ iihom = jpi - nn_hls
+ !
+ SELECT CASE ( nbondi )
+ CASE ( -1 )
+ DO jl = 1, ipreci
+ pt2d(iihom+jl,:) = r2dew(:,jl,2)
+ END DO
+ CASE ( 0 )
+ DO jl = 1, ipreci
+ pt2d(jl-kexti,:) = r2dwe(:,jl,2)
+ pt2d(iihom+jl,:) = r2dew(:,jl,2)
+ END DO
+ CASE ( 1 )
+ DO jl = 1, ipreci
+ pt2d(jl-kexti,:) = r2dwe(:,jl,2)
+ END DO
+ END SELECT
+
+
+ ! 3. North and south directions
+ ! -----------------------------
+ ! always closed : we play only with the neigbours
+ !
+ IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions
+ ijhom = jpj - (2 * nn_hls) - kextj
+ DO jl = 1, iprecj
+ r2dsn(:,jl,1) = pt2d(:,ijhom +jl)
+ r2dns(:,jl,1) = pt2d(:,nn_hls+jl)
+ END DO
+ ENDIF
+ !
+ ! ! Migrations
+ imigr = iprecj * ( jpi + 2*kexti )
+ !
+ IF( ln_timing ) CALL tic_tac(.TRUE.)
+ !
+ SELECT CASE ( nbondj )
+ CASE ( -1 )
+ CALL SENDROUTINE( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req1 )
+ CALL RECVROUTINE( 3, r2dns(1-kexti,1,2), imigr, nono )
+ CALL mpi_wait(ml_req1,ml_stat,ml_err)
+ CASE ( 0 )
+ CALL SENDROUTINE( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 )
+ CALL SENDROUTINE( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req2 )
+ CALL RECVROUTINE( 3, r2dns(1-kexti,1,2), imigr, nono )
+ CALL RECVROUTINE( 4, r2dsn(1-kexti,1,2), imigr, noso )
+ CALL mpi_wait(ml_req1,ml_stat,ml_err)
+ CALL mpi_wait(ml_req2,ml_stat,ml_err)
+ CASE ( 1 )
+ CALL SENDROUTINE( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 )
+ CALL RECVROUTINE( 4, r2dsn(1-kexti,1,2), imigr, noso )
+ CALL mpi_wait(ml_req1,ml_stat,ml_err)
+ END SELECT
+ !
+ IF( ln_timing ) CALL tic_tac(.FALSE.)
+ !
+ ! ! Write Dirichlet lateral conditions
+ ijhom = jpj - nn_hls
+ !
+ SELECT CASE ( nbondj )
+ CASE ( -1 )
+ DO jl = 1, iprecj
+ pt2d(:,ijhom+jl) = r2dns(:,jl,2)
+ END DO
+ CASE ( 0 )
+ DO jl = 1, iprecj
+ pt2d(:,jl-kextj) = r2dsn(:,jl,2)
+ pt2d(:,ijhom+jl) = r2dns(:,jl,2)
+ END DO
+ CASE ( 1 )
+ DO jl = 1, iprecj
+ pt2d(:,jl-kextj) = r2dsn(:,jl,2)
+ END DO
+ END SELECT
+ !
+ END SUBROUTINE ROUTINE_LNK
+
+# undef LBCNORTH
+# undef PRECISION
+# undef SENDROUTINE
+# undef RECVROUTINE
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/mpp_loc_generic.h90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/mpp_loc_generic.h90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/mpp_loc_generic.h90 (revision 13540)
@@ -1,8 +1,20 @@
!== IN: ptab is an array ==!
-# define ARRAY_TYPE(i,j,k) REAL(wp) , INTENT(in ) :: ARRAY_IN(i,j,k)
-# define MASK_TYPE(i,j,k) REAL(wp) , INTENT(in ) :: MASK_IN(i,j,k)
+# if defined SINGLE_PRECISION
+# define ARRAY_TYPE(i,j,k) REAL(sp) , INTENT(in ) :: ARRAY_IN(i,j,k)
+#if defined key_mpp_mpi
+# define MPI_TYPE MPI_2REAL
+#endif
+# define PRECISION sp
+# else
+# define ARRAY_TYPE(i,j,k) REAL(dp) , INTENT(in ) :: ARRAY_IN(i,j,k)
+#if defined key_mpp_mpi
+# define MPI_TYPE MPI_2DOUBLE_PRECISION
+#endif
+# define PRECISION dp
+# endif
+
# if defined DIM_2d
# define ARRAY_IN(i,j,k) ptab(i,j)
-# define MASK_IN(i,j,k) pmask(i,j)
+# define MASK_IN(i,j,k) ldmsk(i,j)
# define INDEX_TYPE(k) INTEGER , INTENT( out) :: kindex(2)
# define K_SIZE(ptab) 1
@@ -10,98 +22,116 @@
# if defined DIM_3d
# define ARRAY_IN(i,j,k) ptab(i,j,k)
-# define MASK_IN(i,j,k) pmask(i,j,k)
+# define MASK_IN(i,j,k) ldmsk(i,j,k)
# define INDEX_TYPE(k) INTEGER , INTENT( out) :: kindex(3)
# define K_SIZE(ptab) SIZE(ptab,3)
# endif
# if defined OPERATION_MAXLOC
-# define MPI_OPERATION mpi_maxloc
+# define MPI_OPERATION MPI_MAXLOC
# define LOC_OPERATION MAXLOC
# define ERRVAL -HUGE
# endif
# if defined OPERATION_MINLOC
-# define MPI_OPERATION mpi_minloc
+# define MPI_OPERATION MPI_MINLOC
# define LOC_OPERATION MINLOC
# define ERRVAL HUGE
# endif
- SUBROUTINE ROUTINE_LOC( cdname, ptab, pmask, pmin, kindex )
+ SUBROUTINE ROUTINE_LOC( cdname, ptab, ldmsk, pmin, kindex, ldhalo )
!!----------------------------------------------------------------------
- CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine
+ CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine
ARRAY_TYPE(:,:,:) ! array on which loctrans operation is applied
- MASK_TYPE(:,:,:) ! local mask
- REAL(wp) , INTENT( out) :: pmin ! Global minimum of ptab
+ LOGICAL , INTENT(in ) :: MASK_IN(:,:,:) ! local mask
+ REAL(PRECISION) , INTENT( out) :: pmin ! Global minimum of ptab
INDEX_TYPE(:) ! index of minimum in global frame
-# if defined key_mpp_mpi
+ LOGICAL, OPTIONAL, INTENT(in ) :: ldhalo ! If .false. (default) excludes halos in kindex
!
INTEGER :: ierror, ii, idim
INTEGER :: index0
- REAL(wp) :: zmin ! local minimum
INTEGER , DIMENSION(:), ALLOCATABLE :: ilocs
- REAL(wp), DIMENSION(2,1) :: zain, zaout
+ REAL(PRECISION) :: zmin ! local minimum
+ REAL(PRECISION), DIMENSION(2,1) :: zain, zaout
+ LOGICAL :: llhalo
!!-----------------------------------------------------------------------
!
IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. )
!
+ IF( PRESENT(ldhalo) ) THEN ; llhalo = ldhalo
+ ELSE ; llhalo = .FALSE.
+ ENDIF
+ !
idim = SIZE(kindex)
!
- IF ( ALL(MASK_IN(:,:,:) /= 1._wp) ) THEN
- ! special case for land processors
- zmin = ERRVAL(zmin)
- index0 = 0
- ELSE
+ IF ( ANY( MASK_IN(:,:,:) ) ) THEN ! there is at least 1 valid point...
+ !
ALLOCATE ( ilocs(idim) )
!
- ilocs = LOC_OPERATION( ARRAY_IN(:,:,:) , mask= MASK_IN(:,:,:) == 1._wp )
+ ilocs = LOC_OPERATION( ARRAY_IN(:,:,:) , mask= MASK_IN(:,:,:) )
zmin = ARRAY_IN(ilocs(1),ilocs(2),ilocs(3))
!
kindex(1) = mig( ilocs(1) )
-# if defined DIM_2d || defined DIM_3d /* avoid warning when kindex has 1 element */
+#if defined DIM_2d || defined DIM_3d /* avoid warning when kindex has 1 element */
kindex(2) = mjg( ilocs(2) )
-# endif
-# if defined DIM_3d /* avoid warning when kindex has 2 elements */
+#endif
+#if defined DIM_3d /* avoid warning when kindex has 2 elements */
kindex(3) = ilocs(3)
-# endif
+#endif
!
DEALLOCATE (ilocs)
!
index0 = kindex(1)-1 ! 1d index starting at 0
-# if defined DIM_2d || defined DIM_3d /* avoid warning when kindex has 1 element */
+#if defined DIM_2d || defined DIM_3d /* avoid warning when kindex has 1 element */
index0 = index0 + jpiglo * (kindex(2)-1)
-# endif
-# if defined DIM_3d /* avoid warning when kindex has 2 elements */
+#endif
+#if defined DIM_3d /* avoid warning when kindex has 2 elements */
index0 = index0 + jpiglo * jpjglo * (kindex(3)-1)
-# endif
+#endif
+ ELSE
+ ! special case for land processors
+ zmin = ERRVAL(zmin)
+ index0 = 0
END IF
+ !
zain(1,:) = zmin
- zain(2,:) = REAL(index0, wp)
+ zain(2,:) = REAL(index0, PRECISION)
!
+#if defined key_mpp_mpi
IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.)
- CALL MPI_ALLREDUCE( zain, zaout, 1, MPI_2DOUBLE_PRECISION, MPI_OPERATION ,MPI_COMM_OCE, ierror)
+ CALL MPI_ALLREDUCE( zain, zaout, 1, MPI_TYPE, MPI_OPERATION ,MPI_COMM_OCE, ierror)
IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.)
+#else
+ zaout(:,:) = zain(:,:)
+#endif
!
pmin = zaout(1,1)
index0 = NINT( zaout(2,1) )
-# if defined DIM_3d /* avoid warning when kindex has 2 elements */
+#if defined DIM_3d /* avoid warning when kindex has 2 elements */
kindex(3) = index0 / (jpiglo*jpjglo)
index0 = index0 - kindex(3) * (jpiglo*jpjglo)
-# endif
-# if defined DIM_2d || defined DIM_3d /* avoid warning when kindex has 1 element */
+#endif
+#if defined DIM_2d || defined DIM_3d /* avoid warning when kindex has 1 element */
kindex(2) = index0 / jpiglo
index0 = index0 - kindex(2) * jpiglo
-# endif
+#endif
kindex(1) = index0
kindex(:) = kindex(:) + 1 ! start indices at 1
-#else
- kindex = 0 ; pmin = 0.
- WRITE(*,*) 'ROUTINE_LOC: You should not have seen this print! error?'
+
+ IF( .NOT. llhalo ) THEN
+ kindex(1) = kindex(1) - nn_hls
+#if defined DIM_2d || defined DIM_3d /* avoid warning when kindex has 1 element */
+ kindex(2) = kindex(2) - nn_hls
#endif
-
+ ENDIF
+
END SUBROUTINE ROUTINE_LOC
+
+#undef PRECISION
#undef ARRAY_TYPE
-#undef MAX_TYPE
#undef ARRAY_IN
#undef MASK_IN
#undef K_SIZE
+#if defined key_mpp_mpi
+# undef MPI_TYPE
+#endif
#undef MPI_OPERATION
#undef LOC_OPERATION
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/mpp_nfd_generic.h90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/mpp_nfd_generic.h90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/mpp_nfd_generic.h90 (revision 13540)
@@ -5,5 +5,9 @@
# define LBC_ARG (jf)
# if defined DIM_2d
-# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D) , INTENT(inout) :: ptab(f)
+# if defined SINGLE_PRECISION
+# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_sp) , INTENT(inout) :: ptab(f)
+# else
+# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_dp) , INTENT(inout) :: ptab(f)
+# endif
# define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j)
# define K_SIZE(ptab) 1
@@ -11,5 +15,9 @@
# endif
# if defined DIM_3d
-# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D) , INTENT(inout) :: ptab(f)
+# if defined SINGLE_PRECISION
+# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_sp) , INTENT(inout) :: ptab(f)
+# else
+# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_dp) , INTENT(inout) :: ptab(f)
+# endif
# define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k)
# define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3)
@@ -17,5 +25,9 @@
# endif
# if defined DIM_4d
-# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D) , INTENT(inout) :: ptab(f)
+# if defined SINGLE_PRECISION
+# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_sp) , INTENT(inout) :: ptab(f)
+# else
+# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_dp) , INTENT(inout) :: ptab(f)
+# endif
# define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l)
# define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3)
@@ -24,5 +36,9 @@
#else
! !== IN: ptab is an array ==!
-# define ARRAY_TYPE(i,j,k,l,f) REAL(wp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f)
+# if defined SINGLE_PRECISION
+# define ARRAY_TYPE(i,j,k,l,f) REAL(sp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f)
+# else
+# define ARRAY_TYPE(i,j,k,l,f) REAL(dp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f)
+# endif
# define NAT_IN(k) cd_nat
# define SGN_IN(k) psgn
@@ -46,28 +62,47 @@
#endif
- SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kfld )
+# if defined SINGLE_PRECISION
+# define PRECISION sp
+# define SENDROUTINE mppsend_sp
+# define RECVROUTINE mpprecv_sp
+# define MPI_TYPE MPI_REAL
+# define HUGEVAL(x) HUGE(x/**/_sp)
+# else
+# define PRECISION dp
+# define SENDROUTINE mppsend_dp
+# define RECVROUTINE mpprecv_dp
+# define MPI_TYPE MPI_DOUBLE_PRECISION
+# define HUGEVAL(x) HUGE(x/**/_dp)
+# endif
+
+ SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kfillmode, pfillval, kfld )
!!----------------------------------------------------------------------
ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied
CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points
REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary
+ INTEGER , INTENT(in ) :: kfillmode ! filling method for halo over land
+ REAL(wp) , INTENT(in ) :: pfillval ! background value (used at closed boundaries)
INTEGER, OPTIONAL, INTENT(in ) :: kfld ! number of pt3d arrays
!
+ LOGICAL :: ll_add_line
INTEGER :: ji, jj, jk, jl, jh, jf, jr ! dummy loop indices
- INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array
+ INTEGER :: ipi, ipj, ipj2, ipk, ipl, ipf ! dimension of the input array
INTEGER :: imigr, iihom, ijhom ! local integers
- INTEGER :: ierr, ibuffsize, ilci, ildi, ilei, iilb
- INTEGER :: ij, iproc
+ INTEGER :: ierr, ibuffsize, iis0, iie0, impp
+ INTEGER :: ii1, ii2, ij1, ij2
+ INTEGER :: ipimax, i0max
+ INTEGER :: ij, iproc, ipni, ijnr
INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf ! for mpi_isend when avoiding mpi_allgather
INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather
INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for mpi_isend when avoiding mpi_allgather
! ! Workspace for message transfers avoiding mpi_allgather
- INTEGER :: ipf_j ! sum of lines for all multi fields
- INTEGER :: js ! counter
- INTEGER, DIMENSION(:,:), ALLOCATABLE :: jj_s ! position of sent lines
- INTEGER, DIMENSION(:), ALLOCATABLE :: ipj_s ! number of sent lines
- REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztabl
- REAL(wp), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: ztab, ztabr
- REAL(wp), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: znorthloc, zfoldwk
- REAL(wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: znorthgloio
+ INTEGER :: ipj_b ! sum of lines for all multi fields
+ INTEGER :: i012 ! 0, 1 or 2
+ INTEGER , DIMENSION(:,:) , ALLOCATABLE :: jj_s ! position of sent lines
+ INTEGER , DIMENSION(:,:) , ALLOCATABLE :: jj_b ! position of buffer lines
+ INTEGER , DIMENSION(:) , ALLOCATABLE :: ipj_s ! number of sent lines
+ REAL(PRECISION), DIMENSION(:,:,:,:) , ALLOCATABLE :: ztabb, ztabr, ztabw ! buffer, receive and work arrays
+ REAL(PRECISION), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: ztabglo, znorthloc
+ REAL(PRECISION), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: znorthglo
!!----------------------------------------------------------------------
!
@@ -78,224 +113,294 @@
IF( l_north_nogather ) THEN !== no allgather exchanges ==!
- ALLOCATE(ipj_s(ipf))
-
- ipj = 2 ! Max 2nd dimension of message transfers (last two j-line only)
- ipj_s(:) = 1 ! Real 2nd dimension of message transfers (depending on perf requirement)
- ! by default, only one line is exchanged
-
- ALLOCATE( jj_s(ipf,2) )
-
- ! re-define number of exchanged lines :
- ! must be two during the first two time steps
- ! to correct possible incoherent values on North fold lines from restart
-
+ ! --- define number of exchanged lines ---
+ !
+ ! In theory we should exchange only nn_hls lines.
+ !
+ ! However, some other points are duplicated in the north pole folding:
+ ! - jperio=[34], grid=T : half of the last line (jpiglo/2+2:jpiglo-nn_hls)
+ ! - jperio=[34], grid=U : half of the last line (jpiglo/2+1:jpiglo-nn_hls)
+ ! - jperio=[34], grid=V : all the last line nn_hls+1 and (nn_hls+2:jpiglo-nn_hls)
+ ! - jperio=[34], grid=F : all the last line (nn_hls+1:jpiglo-nn_hls)
+ ! - jperio=[56], grid=T : 2 points of the last line (jpiglo/2+1 and jpglo-nn_hls)
+ ! - jperio=[56], grid=U : no points are duplicated
+ ! - jperio=[56], grid=V : half of the last line (jpiglo/2+1:jpiglo-nn_hls)
+ ! - jperio=[56], grid=F : half of the last line (jpiglo/2+1:jpiglo-nn_hls-1)
+ ! The order of the calculations may differ for these duplicated points (as, for example jj+1 becomes jj-1)
+ ! This explain why these duplicated points may have different values even if they are at the exact same location.
+ ! 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.
-
- ! Two lines update (slower but necessary to avoid different values ion identical grid points
- IF ( l_full_nf_update .OR. & ! if coupling fields
- ( ncom_stp == nit000 .AND. .NOT. ln_rstart ) ) & ! at first time step, if not restart
- ipj_s(:) = 2
+ ! 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 )
+
+ ALLOCATE(ipj_s(ipf)) ! how many lines do we exchange?
+ IF( ll_add_line ) THEN
+ DO jf = 1, ipf ! Loop over the number of arrays to be processed
+ ipj_s(jf) = nn_hls + COUNT( (/ npolj == 3 .OR. npolj == 4 .OR. NAT_IN(jf) == 'V' .OR. NAT_IN(jf) == 'F' /) )
+ END DO
+ ELSE
+ ipj_s(:) = nn_hls
+ ENDIF
+
+ ipj = MAXVAL(ipj_s(:)) ! Max 2nd dimension of message transfers
+ ipj_b = SUM( ipj_s(:)) ! Total number of lines to be exchanged
+ ALLOCATE( jj_s(ipj, ipf), jj_b(ipj, ipf) )
! Index of modifying lines in input
+ ij1 = 0
DO jf = 1, ipf ! Loop over the number of arrays to be processed
!
SELECT CASE ( npolj )
- !
CASE ( 3, 4 ) ! * North fold T-point pivot
- !
SELECT CASE ( NAT_IN(jf) )
- !
- CASE ( 'T' , 'W' ,'U' ) ! T-, U-, W-point
- jj_s(jf,1) = nlcj - 2 ; jj_s(jf,2) = nlcj - 1
- CASE ( 'V' , 'F' ) ! V-, F-point
- jj_s(jf,1) = nlcj - 3 ; jj_s(jf,2) = nlcj - 2
+ CASE ( 'T', 'W', 'U' ) ; i012 = 1 ! T-, U-, W-point
+ CASE ( 'V', 'F' ) ; i012 = 2 ! V-, F-point
END SELECT
- !
- CASE ( 5, 6 ) ! * North fold F-point pivot
+ CASE ( 5, 6 ) ! * North fold F-point pivot
SELECT CASE ( NAT_IN(jf) )
- !
- CASE ( 'T' , 'W' ,'U' ) ! T-, U-, W-point
- jj_s(jf,1) = nlcj - 1
- ipj_s(jf) = 1 ! need only one line anyway
- CASE ( 'V' , 'F' ) ! V-, F-point
- jj_s(jf,1) = nlcj - 2 ; jj_s(jf,2) = nlcj - 1
+ CASE ( 'T', 'W', 'U' ) ; i012 = 0 ! T-, U-, W-point
+ CASE ( 'V', 'F' ) ; i012 = 1 ! V-, F-point
END SELECT
- !
END SELECT
- !
- ENDDO
- !
- ipf_j = sum (ipj_s(:)) ! Total number of lines to be exchanged
- !
- ALLOCATE( znorthloc(jpimax,ipf_j,ipk,ipl,1) )
- !
- js = 0
- DO jf = 1, ipf ! Loop over the number of arrays to be processed
+ !
DO jj = 1, ipj_s(jf)
- js = js + 1
- DO jl = 1, ipl
- DO jk = 1, ipk
- znorthloc(1:jpi,js,jk,jl,1) = ARRAY_IN(1:jpi,jj_s(jf,jj),jk,jl,jf)
- END DO
- END DO
+ ij1 = ij1 + 1
+ jj_b(jj,jf) = ij1
+ jj_s(jj,jf) = jpj - 2*nn_hls + jj - i012
END DO
+ !
END DO
!
- ibuffsize = jpimax * ipf_j * ipk * ipl
- !
- ALLOCATE( zfoldwk(jpimax,ipf_j,ipk,ipl,1) )
- ALLOCATE( ztabr(jpimax*jpmaxngh,ipj,ipk,ipl,ipf) )
- ! when some processors of the north fold are suppressed,
- ! values of ztab* arrays corresponding to these suppressed domain won't be defined
- ! and we need a default definition to 0.
- ! a better test should be: a testing if "suppressed land-processors" belongs to the north-pole folding
- IF ( jpni*jpnj /= jpnij ) ztabr(:,:,:,:,:) = 0._wp
+ ALLOCATE( ztabb(jpimax,ipj_b,ipk,ipl) ) ! store all the data to be sent in a buffer array
+ ibuffsize = jpimax * ipj_b * ipk * ipl
+ !
+ DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk
+ DO jj = 1, ipj_s(jf)
+ ij1 = jj_b(jj,jf)
+ ij2 = jj_s(jj,jf)
+ DO ji = 1, jpi
+ ztabb(ji,ij1,jk,jl) = ARRAY_IN(ji,ij2,jk,jl,jf)
+ END DO
+ DO ji = jpi+1, jpimax
+ ztabb(ji,ij1,jk,jl) = HUGEVAL(0.) ! avoid sending uninitialized values (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.)
!
+ ! send the data as soon as possible
DO jr = 1, nsndto
- IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN
- CALL mppsend( 5, znorthloc, ibuffsize, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) )
+ iproc = nfproc(isendto(jr))
+ IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN
+ CALL SENDROUTINE( 5, ztabb, ibuffsize, iproc, ml_req_nf(jr) )
ENDIF
END DO
!
+ ipimax = jpimax * jpmaxngh
+ ALLOCATE( ztabw(jpimax,ipj_b,ipk,ipl), ztabr(ipimax,ipj_b,ipk,ipl) )
+ !
+ DO jr = 1, nsndto
+ !
+ ipni = isendto(jr)
+ iproc = nfproc(ipni)
+ ipi = nfjpi (ipni)
+ !
+ IF( ipni == 1 ) THEN ; iis0 = 1 ! domain left side: as e-w comm already done -> from 1st column
+ ELSE ; iis0 = 1 + nn_hls ! default: -> from inner domain
+ ENDIF
+ IF( ipni == jpni ) THEN ; iie0 = ipi ! domain right side: as e-w comm already done -> until last column
+ ELSE ; iie0 = ipi - nn_hls ! default: -> until inner domain
+ ENDIF
+ impp = nfimpp(ipni) - nfimpp(isendto(1))
+ !
+ IF( iproc == -1 ) THEN ! No neighbour (land proc that was suppressed)
+ !
+ 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, ipj_s(jf)
+ ij1 = jj_b(jj,jf)
+ ij2 = jj_s(jj,jf)
+ DO ji = iis0, iie0
+ ztabr(impp+ji,ij1,jk,jl) = ARRAY_IN(Nis0,ij2,jk,jl,jf) ! chose to take the 1st iner domain point
+ END DO
+ END DO
+ END DO ; END DO ; END DO
+ CASE ( jpfillcst ) ! filling with constant value
+ DO jl = 1, ipl ; DO jk = 1, ipk
+ DO jj = 1, ipj_b
+ DO ji = iis0, iie0
+ ztabr(impp+ji,jj,jk,jl) = pfillval
+ END DO
+ END DO
+ END DO ; END DO
+ END SELECT
+ !
+ ELSE IF( iproc == narea-1 ) THEN ! get data from myself!
+ !
+ DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk
+ DO jj = 1, ipj_s(jf)
+ ij1 = jj_b(jj,jf)
+ ij2 = jj_s(jj,jf)
+ DO ji = iis0, iie0
+ ztabr(impp+ji,ij1,jk,jl) = ARRAY_IN(ji,ij2,jk,jl,jf)
+ END DO
+ END DO
+ END DO ; END DO ; END DO
+ !
+ ELSE ! get data from a neighbour trough communication
+ !
+ CALL RECVROUTINE(5, ztabw, ibuffsize, iproc)
+ DO jl = 1, ipl ; DO jk = 1, ipk
+ DO jj = 1, ipj_b
+ DO ji = iis0, iie0
+ ztabr(impp+ji,jj,jk,jl) = ztabw(ji,jj,jk,jl)
+ END DO
+ END DO
+ END DO ; END DO
+
+ ENDIF
+ !
+ END DO ! nsndto
+ !
+ IF( ln_timing ) CALL tic_tac(.FALSE.)
+ !
+ ! North fold boundary condition
+ !
+ DO jf = 1, ipf
+ ij1 = jj_b( 1 ,jf)
+ ij2 = jj_b(ipj_s(jf),jf)
+ CALL lbc_nfd_nogather( ARRAY_IN(:,:,:,:,jf), ztabr(:,ij1:ij2,:,:), cd_nat LBC_ARG, psgn LBC_ARG )
+ END DO
+ !
+ DEALLOCATE( ztabr, ztabw, jj_s, jj_b, ipj_s )
+ !
DO jr = 1,nsndto
- iproc = nfipproc(isendto(jr),jpnj)
- IF(iproc /= -1) THEN
- iilb = nimppt(iproc+1)
- ilci = nlcit (iproc+1)
- ildi = nldit (iproc+1)
- ilei = nleit (iproc+1)
- IF( iilb == 1 ) ildi = 1 ! e-w boundary already done -> force to take 1st column
- IF( iilb + ilci - 1 == jpiglo ) ilei = ilci ! e-w boundary already done -> force to take last column
- iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj)
- ENDIF
+ iproc = nfproc(isendto(jr))
IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN
- CALL mpprecv(5, zfoldwk, ibuffsize, iproc)
- js = 0
- DO jf = 1, ipf ; DO jj = 1, ipj_s(jf)
- js = js + 1
- DO jl = 1, ipl
- DO jk = 1, ipk
- DO ji = ildi, ilei
- ztabr(iilb+ji,jj,jk,jl,jf) = zfoldwk(ji,js,jk,jl,1)
- END DO
- END DO
- END DO
- END DO; END DO
- ELSE IF( iproc == narea-1 ) THEN
- DO jf = 1, ipf ; DO jj = 1, ipj_s(jf)
- DO jl = 1, ipl
- DO jk = 1, ipk
- DO ji = ildi, ilei
- ztabr(iilb+ji,jj,jk,jl,jf) = ARRAY_IN(ji,jj_s(jf,jj),jk,jl,jf)
- END DO
- END DO
- END DO
- END DO; END DO
+ CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err ) ! put the wait at the very end just before the deallocate
ENDIF
END DO
- DO jr = 1,nsndto
- IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN
- CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err )
- ENDIF
- END DO
- !
- IF( ln_timing ) CALL tic_tac(.FALSE.)
- !
- ! North fold boundary condition
- !
- DO jf = 1, ipf
- CALL lbc_nfd_nogather( ARRAY_IN(:,:,:,:,jf), ztabr(:,1:ipj_s(jf),:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG )
- END DO
- !
- DEALLOCATE( zfoldwk, ztabr, jj_s, ipj_s )
+ DEALLOCATE( ztabb )
!
ELSE !== allgather exchanges ==!
!
- ipj = 4 ! 2nd dimension of message transfers (last j-lines)
- !
- ALLOCATE( znorthloc(jpimax,ipj,ipk,ipl,ipf) )
- !
- DO jf = 1, ipf ! put in znorthloc the last ipj j-lines of ptab
- DO jl = 1, ipl
- DO jk = 1, ipk
- DO jj = nlcj - ipj +1, nlcj
- ij = jj - nlcj + ipj
- znorthloc(1:jpi,ij,jk,jl,jf) = ARRAY_IN(1:jpi,jj,jk,jl,jf)
- END DO
+ ! how many lines do we exchange at max? -> ipj (no further optimizations in this case...)
+ ipj = nn_hls + 2
+ ! how many lines do we need at max? -> ipj2 (no further optimizations in this case...)
+ ipj2 = 2 * nn_hls + 2
+ !
+ i0max = jpimax - 2 * nn_hls
+ ibuffsize = i0max * ipj * ipk * ipl * ipf
+ ALLOCATE( znorthloc(i0max,ipj,ipk,ipl,ipf), znorthglo(i0max,ipj,ipk,ipl,ipf,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
+ DO ji = 1, Ni_0
+ ii2 = Nis0 - 1 + ji ! inner domain: Nis0 to Nie0
+ znorthloc(ji,jj,jk,jl,jf) = ARRAY_IN(ii2,ij2,jk,jl,jf)
+ END DO
+ DO ji = Ni_0+1, i0max
+ znorthloc(ji,jj,jk,jl,jf) = HUGEVAL(0.) ! avoid sending uninitialized values (make sure we don't use it)
END DO
END DO
- END DO
- !
- ibuffsize = jpimax * ipj * ipk * ipl * ipf
- !
- ALLOCATE( ztab (jpiglo,ipj,ipk,ipl,ipf ) )
- ALLOCATE( znorthgloio(jpimax,ipj,ipk,ipl,ipf,jpni) )
- !
- ! when some processors of the north fold are suppressed,
- ! values of ztab* arrays corresponding to these suppressed domain won't be defined
- ! and we need a default definition to 0.
- ! a better test should be: a testing if "suppressed land-processors" belongs to the north-pole folding
- IF ( jpni*jpnj /= jpnij ) ztab(:,:,:,:,:) = 0._wp
+ END DO ; END DO ; END DO
!
! start waiting time measurement
IF( ln_timing ) CALL tic_tac(.TRUE.)
- CALL MPI_ALLGATHER( znorthloc , ibuffsize, MPI_DOUBLE_PRECISION, &
- & znorthgloio, ibuffsize, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
- !
+#if defined key_mpp_mpi
+ CALL MPI_ALLGATHER( znorthloc, ibuffsize, MPI_TYPE, znorthglo, ibuffsize, MPI_TYPE, ncomm_north, ierr )
+#endif
! stop waiting time measurement
IF( ln_timing ) CALL tic_tac(.FALSE.)
- !
- DO jr = 1, ndim_rank_north ! recover the global north array
- iproc = nrank_north(jr) + 1
- iilb = nimppt(iproc)
- ilci = nlcit (iproc)
- ildi = nldit (iproc)
- ilei = nleit (iproc)
- IF( iilb == 1 ) ildi = 1 ! e-w boundary already done -> force to take 1st column
- IF( iilb + ilci - 1 == jpiglo ) ilei = ilci ! e-w boundary already done -> force to take last column
- DO jf = 1, ipf
- DO jl = 1, ipl
- DO jk = 1, ipk
+ DEALLOCATE( znorthloc )
+ ALLOCATE( ztabglo(jpiglo,ipj2,ipk,ipl,ipf) )
+ !
+ ! need to fill only the first ipj lines of ztabglo as lbc_nfd don't use the last nn_hls lines
+ ijnr = 0
+ DO jr = 1, jpni ! recover the global north array
+ iproc = nfproc(jr)
+ impp = nfimpp(jr)
+ ipi = nfjpi( jr) - 2 * nn_hls ! 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
+ CASE ( jpfillcopy ) ! filling with inner domain values
+ DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk
DO jj = 1, ipj
- DO ji = ildi, ilei
- ztab(ji+iilb-1,jj,jk,jl,jf) = znorthgloio(ji,jj,jk,jl,jf,jr)
+ ij2 = jpj - ipj2 + jj ! the first ipj lines of the last ipj2 lines
+ DO ji = 1, ipi
+ ii1 = impp + nn_hls + ji - 1 ! corresponds to mig(nn_hls + ji) but for subdomain iproc
+ ztabglo(ii1,jj,jk,jl,jf) = ARRAY_IN(Nis0,ij2,jk,jl,jf) ! chose to take the 1st iner domain point
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 + nn_hls + ji - 1 ! corresponds to mig(nn_hls + ji) but for subdomain iproc
+ ztabglo(ii1,jj,jk,jl,jf) = pfillval
+ END DO
+ END DO
+ END DO ; END DO ; END DO
+ END SELECT
+ !
+ 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 + nn_hls + ji - 1 ! corresponds to mig(nn_hls + ji) but for subdomain iproc
+ ztabglo(ii1,jj,jk,jl,jf) = znorthglo(ji,jj,jk,jl,jf,ijnr)
+ END DO
END DO
+ END DO ; END DO ; END DO
+ ENDIF
+ !
+ END DO ! jpni
+ DEALLOCATE( znorthglo )
+ !
+ DO jf = 1, ipf
+ CALL lbc_nfd( ztabglo(:,:,:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG ) ! North fold boundary condition
+ DO jl = 1, ipl ; DO jk = 1, ipk ! e-w periodicity
+ DO jj = 1, nn_hls + 1
+ ij1 = ipj2 - (nn_hls + 1) + jj ! need only the last nn_hls + 1 lines until ipj2
+ ztabglo( 1:nn_hls,ij1,jk,jl,jf) = ztabglo(jpiglo-2*nn_hls+1:jpiglo-nn_hls,ij1,jk,jl,jf)
+ ztabglo(jpiglo-nn_hls+1:jpiglo,ij1,jk,jl,jf) = ztabglo( nn_hls+1: 2*nn_hls,ij1,jk,jl,jf)
+ 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, nn_hls + 1
+ ij1 = jpj - (nn_hls + 1) + jj ! last nn_hls + 1 lines until jpj
+ ij2 = ipj2 - (nn_hls + 1) + jj ! last nn_hls + 1 lines until ipj2
+ DO ji= 1, jpi
+ ii2 = mig(ji)
+ ARRAY_IN(ji,ij1,jk,jl,jf) = ztabglo(ii2,ij2,jk,jl,jf)
END DO
END DO
- END DO
- DO jf = 1, ipf
- CALL lbc_nfd( ztab(:,:,:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG ) ! North fold boundary condition
- END DO
- !
- DO jf = 1, ipf
- DO jl = 1, ipl
- DO jk = 1, ipk
- DO jj = nlcj-ipj+1, nlcj ! Scatter back to ARRAY_IN
- ij = jj - nlcj + ipj
- DO ji= 1, nlci
- ARRAY_IN(ji,jj,jk,jl,jf) = ztab(ji+nimpp-1,ij,jk,jl,jf)
- END DO
- END DO
- END DO
- END DO
- END DO
- !
- !
- DEALLOCATE( ztab )
- DEALLOCATE( znorthgloio )
- ENDIF
- !
- DEALLOCATE( znorthloc )
+ END DO ; END DO ; END DO
+ !
+ DEALLOCATE( ztabglo )
+ !
+ ENDIF ! l_north_nogather
!
END SUBROUTINE ROUTINE_NFD
+#undef PRECISION
+#undef MPI_TYPE
+#undef SENDROUTINE
+#undef RECVROUTINE
#undef ARRAY_TYPE
#undef NAT_IN
@@ -306,2 +411,3 @@
#undef F_SIZE
#undef LBC_ARG
+#undef HUGEVAL
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/mppini.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/mppini.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/LBC/mppini.F90 (revision 13540)
@@ -8,6 +8,6 @@
!! 8.0 ! 1998-05 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI versions
!! NEMO 1.0 ! 2004-01 (G. Madec, J.M Molines) F90 : free form , north fold jpni > 1
- !! 3.4 ! 2011-10 (A. C. Coward, NOCS & J. Donners, PRACE) add mpp_init_nfdcom
- !! 3. ! 2013-06 (I. Epicoco, S. Mocavero, CMCC) mpp_init_nfdcom: setup avoiding MPI communication
+ !! 3.4 ! 2011-10 (A. C. Coward, NOCS & J. Donners, PRACE) add init_nfdcom
+ !! 3. ! 2013-06 (I. Epicoco, S. Mocavero, CMCC) init_nfdcom: setup avoiding MPI communication
!! 4.0 ! 2016-06 (G. Madec) use domain configuration file instead of bathymetry file
!! 4.0 ! 2017-06 (J.M. Molines, T. Lovato) merge of mppini and mppini_2
@@ -15,15 +15,13 @@
!!----------------------------------------------------------------------
- !! mpp_init : Lay out the global domain over processors with/without land processor elimination
- !! mpp_init_mask : Read global bathymetric information to facilitate land suppression
- !! mpp_init_ioipsl : IOIPSL initialization in mpp
- !! mpp_init_partition: Calculate MPP domain decomposition
- !! factorise : Calculate the factors of the no. of MPI processes
- !! mpp_init_nfdcom : Setup for north fold exchanges with explicit point-to-point messaging
+ !! mpp_init : Lay out the global domain over processors with/without land processor elimination
+ !! init_ioipsl: IOIPSL initialization in mpp
+ !! init_nfdcom: Setup for north fold exchanges with explicit point-to-point messaging
+ !! init_doloop: set the starting/ending indices of DO-loop used in do_loop_substitute
!!----------------------------------------------------------------------
USE dom_oce ! ocean space and time domain
USE bdy_oce ! open BounDarY
!
- USE lbcnfd , ONLY : isendto, nsndto, nfsloop, nfeloop ! Setup of north fold exchanges
+ USE lbcnfd , ONLY : isendto, nsndto ! Setup of north fold exchanges
USE lib_mpp ! distribued memory computing library
USE iom ! nemo I/O library
@@ -34,8 +32,11 @@
PRIVATE
- PUBLIC mpp_init ! called by opa.F90
-
- INTEGER :: numbot = -1 ! 'bottom_level' local logical unit
- INTEGER :: numbdy = -1 ! 'bdy_msk' local logical unit
+ PUBLIC mpp_init ! called by nemogcm.F90
+ PUBLIC mpp_getnum ! called by prtctl
+ PUBLIC mpp_basesplit ! called by prtctl
+ PUBLIC mpp_is_ocean ! called by prtctl
+
+ INTEGER :: numbot = -1 ! 'bottom_level' local logical unit
+ INTEGER :: numbdy = -1 ! 'bdy_msk' local logical unit
!!----------------------------------------------------------------------
@@ -61,4 +62,7 @@
!!----------------------------------------------------------------------
!
+ nn_hls = 1
+ jpiglo = Ni0glo + 2 * nn_hls
+ jpjglo = Nj0glo + 2 * nn_hls
jpimax = jpiglo
jpjmax = jpjglo
@@ -66,19 +70,13 @@
jpj = jpjglo
jpk = jpkglo
- jpim1 = jpi-1 ! inner domain indices
- jpjm1 = jpj-1 ! " "
- jpkm1 = MAX( 1, jpk-1 ) ! " "
+ jpim1 = jpi-1 ! inner domain indices
+ jpjm1 = jpj-1 ! " "
+ jpkm1 = MAX( 1, jpk-1 ) ! " "
jpij = jpi*jpj
jpni = 1
jpnj = 1
jpnij = jpni*jpnj
- nimpp = 1 !
+ nimpp = 1
njmpp = 1
- nlci = jpi
- nlcj = jpj
- nldi = 1
- nldj = 1
- nlei = jpi
- nlej = jpj
nbondi = 2
nbondj = 2
@@ -90,4 +88,6 @@
l_Jperio = jpnj == 1 .AND. (jperio == 2 .OR. jperio == 7)
!
+ CALL init_doloop ! set start/end indices or do-loop depending on the halo width value (nn_hls)
+ !
IF(lwp) THEN
WRITE(numout,*)
@@ -98,8 +98,9 @@
ENDIF
!
- IF( jpni /= 1 .OR. jpnj /= 1 .OR. jpnij /= 1 ) &
- CALL ctl_stop( 'mpp_init: equality jpni = jpnj = jpnij = 1 is not satisfied', &
- & 'the domain is lay out for distributed memory computing!' )
- !
+#if defined key_agrif
+ IF (.NOT.agrif_root()) THEN
+ call agrif_nemo_init()
+ ENDIF
+#endif
END SUBROUTINE mpp_init
@@ -130,6 +131,4 @@
!! njmpp : latitudinal index
!! narea : number for local area
- !! nlci : first dimension
- !! nlcj : second dimension
!! nbondi : mark for "east-west local boundary"
!! nbondj : mark for "north-south local boundary"
@@ -142,7 +141,6 @@
INTEGER :: ji, jj, jn, jproc, jarea ! dummy loop indices
INTEGER :: inijmin
- INTEGER :: i2add
INTEGER :: inum ! local logical unit
- INTEGER :: idir, ifreq, icont ! local integers
+ INTEGER :: idir, ifreq ! local integers
INTEGER :: ii, il1, ili, imil ! - -
INTEGER :: ij, il2, ilj, ijm1 ! - -
@@ -157,8 +155,8 @@
INTEGER, ALLOCATABLE, DIMENSION(:) :: iin, ii_nono, ii_noea ! 1D workspace
INTEGER, ALLOCATABLE, DIMENSION(:) :: ijn, ii_noso, ii_nowe ! - -
- INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iimppt, ilci, ibondi, ipproc ! 2D workspace
- INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ijmppt, ilcj, ibondj, ipolj ! - -
- INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ilei, ildi, iono, ioea ! - -
- INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ilej, ildj, ioso, iowe ! - -
+ INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iimppt, ijpi, ibondi, ipproc ! 2D workspace
+ INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ijmppt, ijpj, ibondj, ipolj ! - -
+ INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iie0, iis0, iono, ioea ! - -
+ INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ije0, ijs0, ioso, iowe ! - -
LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: llisoce ! - -
NAMELIST/nambdy/ ln_bdy, nb_bdy, ln_coords_file, cn_coords_file, &
@@ -168,5 +166,5 @@
& cn_ice, nn_ice_dta, &
& ln_vol, nn_volctl, nn_rimwidth
- NAMELIST/nammpp/ jpni, jpnj, ln_nnogather, ln_listonly
+ NAMELIST/nammpp/ jpni, jpnj, nn_hls, ln_nnogather, ln_listonly
!!----------------------------------------------------------------------
!
@@ -181,4 +179,5 @@
902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nammpp in configuration namelist' )
!
+ nn_hls = MAX(1, nn_hls) ! nn_hls must be > 0
IF(lwp) THEN
WRITE(numout,*) ' Namelist nammpp'
@@ -190,8 +189,15 @@
ENDIF
WRITE(numout,*) ' avoid use of mpi_allgather at the north fold ln_nnogather = ', ln_nnogather
+ WRITE(numout,*) ' halo width (applies to both rows and columns) nn_hls = ', nn_hls
ENDIF
!
IF(lwm) WRITE( numond, nammpp )
-
+ !
+!!!------------------------------------
+!!! nn_hls shloud be read in nammpp
+!!!------------------------------------
+ jpiglo = Ni0glo + 2 * nn_hls
+ jpjglo = Nj0glo + 2 * nn_hls
+ !
! do we need to take into account bdy_msk?
READ ( numnam_ref, nambdy, IOSTAT = ios, ERR = 903)
@@ -203,10 +209,10 @@
IF( ln_bdy .AND. ln_mask_file ) CALL iom_open( cn_mask_file, numbdy )
!
- IF( ln_listonly ) CALL mpp_init_bestpartition( MAX(mppsize,jpni*jpnj), ldlist = .TRUE. ) ! must be done by all core
+ IF( ln_listonly ) CALL bestpartition( MAX(mppsize,jpni*jpnj), ldlist = .TRUE. ) ! must be done by all core
!
! 1. Dimension arrays for subdomains
! -----------------------------------
!
- ! If dimensions of processor grid weren't specified in the namelist file
+ ! If dimensions of processors grid weren't specified in the namelist file
! then we calculate them here now that we have our communicator size
IF(lwp) THEN
@@ -216,14 +222,14 @@
ENDIF
IF( jpni < 1 .OR. jpnj < 1 ) THEN
- CALL mpp_init_bestpartition( mppsize, jpni, jpnj ) ! best mpi decomposition for mppsize mpi processes
+ CALL bestpartition( mppsize, jpni, jpnj ) ! best mpi decomposition for mppsize mpi processes
llauto = .TRUE.
llbest = .TRUE.
ELSE
llauto = .FALSE.
- CALL mpp_init_bestpartition( mppsize, inbi, inbj, icnt2 ) ! best mpi decomposition for mppsize mpi processes
+ CALL bestpartition( mppsize, inbi, inbj, icnt2 ) ! best mpi decomposition for mppsize mpi processes
! largest subdomain size for mpi decoposition jpni*jpnj given in the namelist
- CALL mpp_basic_decomposition( jpni, jpnj, jpimax, jpjmax )
- ! largest subdomain size for mpi decoposition inbi*inbj given by mpp_init_bestpartition
- CALL mpp_basic_decomposition( inbi, inbj, iimax, ijmax )
+ CALL mpp_basesplit( jpiglo, jpjglo, nn_hls, jpni, jpnj, jpimax, jpjmax )
+ ! largest subdomain size for mpi decoposition inbi*inbj given by bestpartition
+ CALL mpp_basesplit( jpiglo, jpjglo, nn_hls, inbi, inbj, iimax, ijmax )
icnt1 = jpni*jpnj - mppsize ! number of land subdomains that should be removed to use mppsize mpi processes
IF(lwp) THEN
@@ -256,5 +262,5 @@
! look for land mpi subdomains...
ALLOCATE( llisoce(jpni,jpnj) )
- CALL mpp_init_isoce( jpni, jpnj, llisoce )
+ CALL mpp_is_ocean( llisoce )
inijmin = COUNT( llisoce ) ! number of oce subdomains
@@ -265,5 +271,5 @@
WRITE(ctmp4,*) ' ==>>> There is the list of best domain decompositions you should use: '
CALL ctl_stop( ctmp1, ctmp2, ctmp3, ' ', ctmp4, ' ' )
- CALL mpp_init_bestpartition( mppsize, ldlist = .TRUE. ) ! must be done by all core
+ CALL bestpartition( mppsize, ldlist = .TRUE. ) ! must be done by all core
ENDIF
@@ -289,5 +295,5 @@
WRITE(numout,*)
ENDIF
- CALL mpp_init_bestpartition( mppsize, ldlist = .TRUE. ) ! must be done by all core
+ CALL bestpartition( mppsize, ldlist = .TRUE. ) ! must be done by all core
ENDIF
@@ -314,17 +320,14 @@
9003 FORMAT (a, i5)
- IF( numbot /= -1 ) CALL iom_close( numbot )
- IF( numbdy /= -1 ) CALL iom_close( numbdy )
-
- ALLOCATE( nfiimpp(jpni,jpnj), nfipproc(jpni,jpnj), nfilcit(jpni,jpnj) , &
- & nimppt(jpnij) , ibonit(jpnij) , nlcit(jpnij) , nlcjt(jpnij) , &
- & njmppt(jpnij) , ibonjt(jpnij) , nldit(jpnij) , nldjt(jpnij) , &
- & nleit(jpnij) , nlejt(jpnij) , &
+ ALLOCATE( nfimpp(jpni ) , nfproc(jpni ) , nfjpi(jpni ) , &
+ & nimppt(jpnij) , ibonit(jpnij) , jpiall(jpnij) , jpjall(jpnij) , &
+ & njmppt(jpnij) , ibonjt(jpnij) , nis0all(jpnij) , njs0all(jpnij) , &
+ & nie0all(jpnij) , nje0all(jpnij) , &
& iin(jpnij), ii_nono(jpnij), ii_noea(jpnij), &
& ijn(jpnij), ii_noso(jpnij), ii_nowe(jpnij), &
- & iimppt(jpni,jpnj), ilci(jpni,jpnj), ibondi(jpni,jpnj), ipproc(jpni,jpnj), &
- & ijmppt(jpni,jpnj), ilcj(jpni,jpnj), ibondj(jpni,jpnj), ipolj(jpni,jpnj), &
- & ilei(jpni,jpnj), ildi(jpni,jpnj), iono(jpni,jpnj), ioea(jpni,jpnj), &
- & ilej(jpni,jpnj), ildj(jpni,jpnj), ioso(jpni,jpnj), iowe(jpni,jpnj), &
+ & iimppt(jpni,jpnj), ijpi(jpni,jpnj), ibondi(jpni,jpnj), ipproc(jpni,jpnj), &
+ & ijmppt(jpni,jpnj), ijpj(jpni,jpnj), ibondj(jpni,jpnj), ipolj(jpni,jpnj), &
+ & iie0(jpni,jpnj), iis0(jpni,jpnj), iono(jpni,jpnj), ioea(jpni,jpnj), &
+ & ije0(jpni,jpnj), ijs0(jpni,jpnj), ioso(jpni,jpnj), iowe(jpni,jpnj), &
& STAT=ierr )
CALL mpp_sum( 'mppini', ierr )
@@ -333,9 +336,5 @@
#if defined key_agrif
IF( .NOT. Agrif_Root() ) THEN ! AGRIF children: specific setting (cf. agrif_user.F90)
- IF( jpiglo /= nbcellsx + 2 + 2*nbghostcells ) &
- CALL ctl_stop( 'STOP', 'mpp_init: Agrif children requires jpiglo == nbcellsx + 2 + 2*nbghostcells' )
- IF( jpjglo /= nbcellsy + 2 + 2*nbghostcells ) &
- CALL ctl_stop( 'STOP', 'mpp_init: Agrif children requires jpjglo == nbcellsy + 2 + 2*nbghostcells' )
- IF( ln_use_jattr ) CALL ctl_stop( 'STOP', 'mpp_init:Agrif children requires ln_use_jattr = .false. ' )
+ CALL agrif_nemo_init()
ENDIF
#endif
@@ -344,9 +343,18 @@
! -----------------------------------
!
- nreci = 2 * nn_hls
- nrecj = 2 * nn_hls
- CALL mpp_basic_decomposition( jpni, jpnj, jpimax, jpjmax, iimppt, ijmppt, ilci, ilcj )
- nfiimpp(:,:) = iimppt(:,:)
- nfilcit(:,:) = ilci(:,:)
+ CALL mpp_basesplit( jpiglo, jpjglo, nn_hls, jpni, jpnj, jpimax, jpjmax, iimppt, ijmppt, ijpi, ijpj )
+ CALL mpp_getnum( llisoce, ipproc, iin, ijn )
+ !
+ !DO jn = 1, jpni
+ ! jproc = ipproc(jn,jpnj)
+ ! ii = iin(jproc+1)
+ ! ij = ijn(jproc+1)
+ ! nfproc(jn) = jproc
+ ! nfimpp(jn) = iimppt(ii,ij)
+ ! nfjpi (jn) = ijpi(ii,ij)
+ !END DO
+ nfproc(:) = ipproc(:,jpnj)
+ nfimpp(:) = iimppt(:,jpnj)
+ nfjpi (:) = ijpi(:,jpnj)
!
IF(lwp) THEN
@@ -357,7 +365,8 @@
WRITE(numout,*) ' jpni = ', jpni
WRITE(numout,*) ' jpnj = ', jpnj
+ WRITE(numout,*) ' jpnij = ', jpnij
WRITE(numout,*)
- WRITE(numout,*) ' sum ilci(i,1) = ', sum(ilci(:,1)), ' jpiglo = ', jpiglo
- WRITE(numout,*) ' sum ilcj(1,j) = ', sum(ilcj(1,:)), ' jpjglo = ', jpjglo
+ WRITE(numout,*) ' sum ijpi(i,1) = ', sum(ijpi(:,1)), ' jpiglo = ', jpiglo
+ WRITE(numout,*) ' sum ijpj(1,j) = ', sum(ijpj(1,:)), ' jpjglo = ', jpjglo
ENDIF
@@ -374,6 +383,6 @@
ii = 1 + MOD(iarea0,jpni)
ij = 1 + iarea0/jpni
- ili = ilci(ii,ij)
- ilj = ilcj(ii,ij)
+ ili = ijpi(ii,ij)
+ ilj = ijpj(ii,ij)
ibondi(ii,ij) = 0 ! default: has e-w neighbours
IF( ii == 1 ) ibondi(ii,ij) = -1 ! first column, has only e neighbour
@@ -390,8 +399,8 @@
ioea(ii,ij) = iarea0 + 1
iono(ii,ij) = iarea0 + jpni
- ildi(ii,ij) = 1 + nn_hls
- ilei(ii,ij) = ili - nn_hls
- ildj(ii,ij) = 1 + nn_hls
- ilej(ii,ij) = ilj - nn_hls
+ iis0(ii,ij) = 1 + nn_hls
+ iie0(ii,ij) = ili - nn_hls
+ ijs0(ii,ij) = 1 + nn_hls
+ ije0(ii,ij) = ilj - nn_hls
! East-West periodicity: change ibondi, ioea, iowe
@@ -431,34 +440,4 @@
! ----------------------------
!
- ! specify which subdomains are oce subdomains; other are land subdomains
- ipproc(:,:) = -1
- icont = -1
- DO jarea = 1, jpni*jpnj
- iarea0 = jarea - 1
- ii = 1 + MOD(iarea0,jpni)
- ij = 1 + iarea0/jpni
- IF( llisoce(ii,ij) ) THEN
- icont = icont + 1
- ipproc(ii,ij) = icont
- iin(icont+1) = ii
- ijn(icont+1) = ij
- ENDIF
- END DO
- ! if needed add some land subdomains to reach jpnij active subdomains
- i2add = jpnij - inijmin
- DO jarea = 1, jpni*jpnj
- iarea0 = jarea - 1
- ii = 1 + MOD(iarea0,jpni)
- ij = 1 + iarea0/jpni
- IF( .NOT. llisoce(ii,ij) .AND. i2add > 0 ) THEN
- icont = icont + 1
- ipproc(ii,ij) = icont
- iin(icont+1) = ii
- ijn(icont+1) = ij
- i2add = i2add - 1
- ENDIF
- END DO
- nfipproc(:,:) = ipproc(:,:)
-
! neighbour treatment: change ibondi, ibondj if next to a land zone
DO jarea = 1, jpni*jpnj
@@ -499,15 +478,4 @@
ENDIF
END DO
-
- ! Update il[de][ij] according to modified ibond[ij]
- ! ----------------------
- DO jproc = 1, jpnij
- ii = iin(jproc)
- ij = ijn(jproc)
- IF( ibondi(ii,ij) == -1 .OR. ibondi(ii,ij) == 2 ) ildi(ii,ij) = 1
- IF( ibondi(ii,ij) == 1 .OR. ibondi(ii,ij) == 2 ) ilei(ii,ij) = ilci(ii,ij)
- IF( ibondj(ii,ij) == -1 .OR. ibondj(ii,ij) == 2 ) ildj(ii,ij) = 1
- IF( ibondj(ii,ij) == 1 .OR. ibondj(ii,ij) == 2 ) ilej(ii,ij) = ilcj(ii,ij)
- END DO
! 5. Subdomain print
@@ -522,5 +490,5 @@
DO jj = jpnj, 1, -1
WRITE(numout,9403) (' ',ji=il1,il2-1)
- WRITE(numout,9402) jj, (ilci(ji,jj),ilcj(ji,jj),ji=il1,il2)
+ WRITE(numout,9402) jj, (ijpi(ji,jj),ijpj(ji,jj),ji=il1,il2)
WRITE(numout,9404) (ipproc(ji,jj),ji=il1,il2)
WRITE(numout,9403) (' ',ji=il1,il2-1)
@@ -579,36 +547,31 @@
noea = ii_noea(narea)
nono = ii_nono(narea)
- nlci = ilci(ii,ij)
- nldi = ildi(ii,ij)
- nlei = ilei(ii,ij)
- nlcj = ilcj(ii,ij)
- nldj = ildj(ii,ij)
- nlej = ilej(ii,ij)
+ jpi = ijpi(ii,ij)
+!!$ Nis0 = iis0(ii,ij)
+!!$ Nie0 = iie0(ii,ij)
+ jpj = ijpj(ii,ij)
+!!$ Njs0 = ijs0(ii,ij)
+!!$ Nje0 = ije0(ii,ij)
nbondi = ibondi(ii,ij)
nbondj = ibondj(ii,ij)
nimpp = iimppt(ii,ij)
njmpp = ijmppt(ii,ij)
- jpi = nlci
- jpj = nlcj
- jpk = jpkglo ! third dim
-#if defined key_agrif
- ! simple trick to use same vertical grid as parent but different number of levels:
- ! Save maximum number of levels in jpkglo, then define all vertical grids with this number.
- ! Suppress once vertical online interpolation is ok
-!!$ IF(.NOT.Agrif_Root()) jpkglo = Agrif_Parent( jpkglo )
-#endif
- jpim1 = jpi-1 ! inner domain indices
- jpjm1 = jpj-1 ! " "
- jpkm1 = MAX( 1, jpk-1 ) ! " "
- jpij = jpi*jpj ! jpi x j
+ jpk = jpkglo ! third dim
+ !
+ CALL init_doloop ! set start/end indices of do-loop, depending on the halo width value (nn_hls)
+ !
+ jpim1 = jpi-1 ! inner domain indices
+ jpjm1 = jpj-1 ! " "
+ jpkm1 = MAX( 1, jpk-1 ) ! " "
+ jpij = jpi*jpj ! jpi x j
DO jproc = 1, jpnij
ii = iin(jproc)
ij = ijn(jproc)
- nlcit(jproc) = ilci(ii,ij)
- nldit(jproc) = ildi(ii,ij)
- nleit(jproc) = ilei(ii,ij)
- nlcjt(jproc) = ilcj(ii,ij)
- nldjt(jproc) = ildj(ii,ij)
- nlejt(jproc) = ilej(ii,ij)
+ jpiall (jproc) = ijpi(ii,ij)
+ nis0all(jproc) = iis0(ii,ij)
+ nie0all(jproc) = iie0(ii,ij)
+ jpjall (jproc) = ijpj(ii,ij)
+ njs0all(jproc) = ijs0(ii,ij)
+ nje0all(jproc) = ije0(ii,ij)
ibonit(jproc) = ibondi(ii,ij)
ibonjt(jproc) = ibondj(ii,ij)
@@ -624,10 +587,10 @@
WRITE(inum,'(6i8,a,3i8,a)') jpnij,jpimax,jpjmax,jpk,jpiglo,jpjglo,&
& ' ( local: ',narea,jpi,jpj,' )'
- WRITE(inum,'(a)') 'nproc nlci nlcj nldi nldj nlei nlej nimp njmp nono noso nowe noea nbondi nbondj '
+ WRITE(inum,'(a)') 'nproc jpi jpj Nis0 Njs0 Nie0 Nje0 nimp njmp nono noso nowe noea nbondi nbondj '
DO jproc = 1, jpnij
- WRITE(inum,'(13i5,2i7)') jproc-1, nlcit (jproc), nlcjt (jproc), &
- & nldit (jproc), nldjt (jproc), &
- & nleit (jproc), nlejt (jproc), &
+ WRITE(inum,'(13i5,2i7)') jproc-1, jpiall(jproc), jpjall(jproc), &
+ & nis0all(jproc), njs0all(jproc), &
+ & nie0all(jproc), nje0all(jproc), &
& nimppt (jproc), njmppt (jproc), &
& ii_nono(jproc), ii_noso(jproc), &
@@ -663,11 +626,6 @@
WRITE(numout,*) ' l_Iperio = ', l_Iperio
WRITE(numout,*) ' l_Jperio = ', l_Jperio
- WRITE(numout,*) ' nlci = ', nlci
- WRITE(numout,*) ' nlcj = ', nlcj
WRITE(numout,*) ' nimpp = ', nimpp
WRITE(numout,*) ' njmpp = ', njmpp
- WRITE(numout,*) ' nreci = ', nreci
- WRITE(numout,*) ' nrecj = ', nrecj
- WRITE(numout,*) ' nn_hls = ', nn_hls
ENDIF
@@ -691,14 +649,12 @@
ENDIF
!
- CALL mpp_init_ioipsl ! Prepare NetCDF output file (if necessary)
+ CALL init_ioipsl ! Prepare NetCDF output file (if necessary)
!
IF (( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ).AND.( ln_nnogather )) THEN
- CALL mpp_init_nfdcom ! northfold neighbour lists
+ CALL init_nfdcom ! northfold neighbour lists
IF (llwrtlay) THEN
WRITE(inum,*)
WRITE(inum,*)
WRITE(inum,*) 'north fold exchanges with explicit point-to-point messaging :'
- WRITE(inum,*) 'nfsloop : ', nfsloop
- WRITE(inum,*) 'nfeloop : ', nfeloop
WRITE(inum,*) 'nsndto : ', nsndto
WRITE(inum,*) 'isendto : ', isendto
@@ -710,13 +666,14 @@
DEALLOCATE(iin, ijn, ii_nono, ii_noea, ii_noso, ii_nowe, &
& iimppt, ijmppt, ibondi, ibondj, ipproc, ipolj, &
- & ilci, ilcj, ilei, ilej, ildi, ildj, &
+ & ijpi, ijpj, iie0, ije0, iis0, ijs0, &
& iono, ioea, ioso, iowe, llisoce)
!
END SUBROUTINE mpp_init
-
- SUBROUTINE mpp_basic_decomposition( knbi, knbj, kimax, kjmax, kimppt, kjmppt, klci, klcj)
- !!----------------------------------------------------------------------
- !! *** ROUTINE mpp_basic_decomposition ***
+#endif
+
+ SUBROUTINE mpp_basesplit( kiglo, kjglo, khls, knbi, knbj, kimax, kjmax, kimppt, kjmppt, klci, klcj)
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE mpp_basesplit ***
!!
!! ** Purpose : Lay out the global domain over processors.
@@ -730,4 +687,6 @@
!! klcj : second dimension
!!----------------------------------------------------------------------
+ INTEGER, INTENT(in ) :: kiglo, kjglo
+ INTEGER, INTENT(in ) :: khls
INTEGER, INTENT(in ) :: knbi, knbj
INTEGER, INTENT( out) :: kimax, kjmax
@@ -736,14 +695,15 @@
!
INTEGER :: ji, jj
+ INTEGER :: i2hls
INTEGER :: iresti, irestj, irm, ijpjmin
- INTEGER :: ireci, irecj
- !!----------------------------------------------------------------------
+ !!----------------------------------------------------------------------
+ i2hls = 2*khls
!
#if defined key_nemocice_decomp
- kimax = ( nx_global+2-2*nn_hls + (knbi-1) ) / knbi + 2*nn_hls ! first dim.
- kjmax = ( ny_global+2-2*nn_hls + (knbj-1) ) / knbj + 2*nn_hls ! second dim.
+ kimax = ( nx_global+2-i2hls + (knbi-1) ) / knbi + i2hls ! first dim.
+ kjmax = ( ny_global+2-i2hls + (knbj-1) ) / knbj + i2hls ! second dim.
#else
- kimax = ( jpiglo - 2*nn_hls + (knbi-1) ) / knbi + 2*nn_hls ! first dim.
- kjmax = ( jpjglo - 2*nn_hls + (knbj-1) ) / knbj + 2*nn_hls ! second dim.
+ kimax = ( kiglo - i2hls + (knbi-1) ) / knbi + i2hls ! first dim.
+ kjmax = ( kjglo - i2hls + (knbj-1) ) / knbj + i2hls ! second dim.
#endif
IF( .NOT. PRESENT(kimppt) ) RETURN
@@ -752,25 +712,23 @@
! -----------------------------------
! Computation of local domain sizes klci() klcj()
- ! These dimensions depend on global sizes knbi,knbj and jpiglo,jpjglo
+ ! These dimensions depend on global sizes knbi,knbj and kiglo,kjglo
! The subdomains are squares lesser than or equal to the global
! dimensions divided by the number of processors minus the overlap array.
!
- ireci = 2 * nn_hls
- irecj = 2 * nn_hls
- iresti = 1 + MOD( jpiglo - ireci -1 , knbi )
- irestj = 1 + MOD( jpjglo - irecj -1 , knbj )
+ iresti = 1 + MOD( kiglo - i2hls - 1 , knbi )
+ irestj = 1 + MOD( kjglo - i2hls - 1 , knbj )
!
! Need to use kimax and kjmax here since jpi and jpj not yet defined
#if defined key_nemocice_decomp
! Change padding to be consistent with CICE
- klci(1:knbi-1 ,:) = kimax
- klci(knbi ,:) = jpiglo - (knbi - 1) * (kimax - nreci)
- klcj(:, 1:knbj-1) = kjmax
- klcj(:, knbj) = jpjglo - (knbj - 1) * (kjmax - nrecj)
+ klci(1:knbi-1,: ) = kimax
+ klci( knbi ,: ) = kiglo - (knbi - 1) * (kimax - i2hls)
+ klcj(: ,1:knbj-1) = kjmax
+ klcj(: , knbj ) = kjglo - (knbj - 1) * (kjmax - i2hls)
#else
klci(1:iresti ,:) = kimax
klci(iresti+1:knbi ,:) = kimax-1
- IF( MINVAL(klci) < 3 ) THEN
- WRITE(ctmp1,*) ' mpp_basic_decomposition: minimum value of jpi must be >= 3'
+ IF( MINVAL(klci) < 2*i2hls ) THEN
+ WRITE(ctmp1,*) ' mpp_basesplit: minimum value of jpi must be >= ', 2*i2hls
WRITE(ctmp2,*) ' We have ', MINVAL(klci)
CALL ctl_stop( 'STOP', ctmp1, ctmp2 )
@@ -778,19 +736,17 @@
IF( jperio == 3 .OR. jperio == 4 .OR. jperio == 5 .OR. jperio == 6 ) THEN
! minimize the size of the last row to compensate for the north pole folding coast
- IF( jperio == 3 .OR. jperio == 4 ) ijpjmin = 5 ! V and F folding involves line jpj-3 that must not be south boundary
- IF( jperio == 5 .OR. jperio == 6 ) ijpjmin = 4 ! V and F folding involves line jpj-2 that must not be south boundary
- irm = knbj - irestj ! total number of lines to be removed
- klcj(:, knbj) = MAX( ijpjmin, kjmax-irm ) ! we must have jpj >= ijpjmin in the last row
- irm = irm - ( kjmax - klcj(1,knbj) ) ! remaining number of lines to remove
- irestj = knbj - 1 - irm
- klcj(:, 1:irestj) = kjmax
+ IF( jperio == 3 .OR. jperio == 4 ) ijpjmin = 2+3*khls ! V and F folding must be outside of southern halos
+ IF( jperio == 5 .OR. jperio == 6 ) ijpjmin = 1+3*khls ! V and F folding must be outside of southern halos
+ irm = knbj - irestj ! total number of lines to be removed
+ klcj(:,knbj) = MAX( ijpjmin, kjmax-irm ) ! we must have jpj >= ijpjmin in the last row
+ irm = irm - ( kjmax - klcj(1,knbj) ) ! remaining number of lines to remove
+ irestj = knbj - 1 - irm
klcj(:, irestj+1:knbj-1) = kjmax-1
ELSE
- ijpjmin = 3
- klcj(:, 1:irestj) = kjmax
- klcj(:, irestj+1:knbj) = kjmax-1
- ENDIF
- IF( MINVAL(klcj) < ijpjmin ) THEN
- WRITE(ctmp1,*) ' mpp_basic_decomposition: minimum value of jpj must be >= ', ijpjmin
+ klcj(:, irestj+1:knbj ) = kjmax-1
+ ENDIF
+ klcj(:,1:irestj) = kjmax
+ IF( MINVAL(klcj) < 2*i2hls ) THEN
+ WRITE(ctmp1,*) ' mpp_basesplit: minimum value of jpj must be >= ', 2*i2hls
WRITE(ctmp2,*) ' We have ', MINVAL(klcj)
CALL ctl_stop( 'STOP', ctmp1, ctmp2 )
@@ -806,5 +762,5 @@
DO jj = 1, knbj
DO ji = 2, knbi
- kimppt(ji,jj) = kimppt(ji-1,jj) + klci(ji-1,jj) - ireci
+ kimppt(ji,jj) = kimppt(ji-1,jj) + klci(ji-1,jj) - i2hls
END DO
END DO
@@ -814,15 +770,15 @@
DO jj = 2, knbj
DO ji = 1, knbi
- kjmppt(ji,jj) = kjmppt(ji,jj-1) + klcj(ji,jj-1) - irecj
+ kjmppt(ji,jj) = kjmppt(ji,jj-1) + klcj(ji,jj-1) - i2hls
END DO
END DO
ENDIF
- END SUBROUTINE mpp_basic_decomposition
-
-
- SUBROUTINE mpp_init_bestpartition( knbij, knbi, knbj, knbcnt, ldlist )
- !!----------------------------------------------------------------------
- !! *** ROUTINE mpp_init_bestpartition ***
+ END SUBROUTINE mpp_basesplit
+
+
+ SUBROUTINE bestpartition( knbij, knbi, knbj, knbcnt, ldlist )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE bestpartition ***
!!
!! ** Purpose :
@@ -830,5 +786,5 @@
!! ** Method :
!!----------------------------------------------------------------------
- INTEGER, INTENT(in ) :: knbij ! total number if subdomains (knbi*knbj)
+ INTEGER, INTENT(in ) :: knbij ! total number of subdomains (knbi*knbj)
INTEGER, OPTIONAL, INTENT( out) :: knbi, knbj ! number if subdomains along i and j (knbi and knbj)
INTEGER, OPTIONAL, INTENT( out) :: knbcnt ! number of land subdomains
@@ -838,4 +794,5 @@
INTEGER :: iszitst, iszjtst
INTEGER :: isziref, iszjref
+ INTEGER :: iszimin, iszjmin
INTEGER :: inbij, iszij
INTEGER :: inbimax, inbjmax, inbijmax, inbijold
@@ -866,6 +823,11 @@
inbimax = 0
inbjmax = 0
- isziref = jpiglo*jpjglo+1
+ isziref = jpiglo*jpjglo+1 ! define a value that is larger than the largest possible
iszjref = jpiglo*jpjglo+1
+ !
+ iszimin = 4*nn_hls ! minimum size of the MPI subdomain so halos are always adressing neighbor inner domain
+ iszjmin = 4*nn_hls
+ IF( jperio == 3 .OR. jperio == 4 ) iszjmin = MAX(iszjmin, 2+3*nn_hls) ! V and F folding must be outside of southern halos
+ IF( jperio == 5 .OR. jperio == 6 ) iszjmin = MAX(iszjmin, 1+3*nn_hls) ! V and F folding must be outside of southern halos
!
! get the list of knbi that gives a smaller jpimax than knbi-1
@@ -875,7 +837,7 @@
iszitst = ( nx_global+2-2*nn_hls + (ji-1) ) / ji + 2*nn_hls ! first dim.
#else
- iszitst = ( jpiglo - 2*nn_hls + (ji-1) ) / ji + 2*nn_hls
+ iszitst = ( Ni0glo + (ji-1) ) / ji + 2*nn_hls ! max subdomain i-size
#endif
- IF( iszitst < isziref ) THEN
+ IF( iszitst < isziref .AND. iszitst >= iszimin ) THEN
isziref = iszitst
inbimax = inbimax + 1
@@ -886,7 +848,7 @@
iszjtst = ( ny_global+2-2*nn_hls + (ji-1) ) / ji + 2*nn_hls ! first dim.
#else
- iszjtst = ( jpjglo - 2*nn_hls + (ji-1) ) / ji + 2*nn_hls
+ iszjtst = ( Nj0glo + (ji-1) ) / ji + 2*nn_hls ! max subdomain j-size
#endif
- IF( iszjtst < iszjref ) THEN
+ IF( iszjtst < iszjref .AND. iszjtst >= iszjmin ) THEN
iszjref = iszjtst
inbjmax = inbjmax + 1
@@ -926,5 +888,5 @@
iszij1(:) = iszi1(:) * iszj1(:)
- ! if therr is no land and no print
+ ! if there is no land and no print
IF( .NOT. llist .AND. numbot == -1 .AND. numbdy == -1 ) THEN
! get the smaller partition which gives the smallest subdomain size
@@ -945,4 +907,5 @@
ii = MINLOC(iszij1, mask = inbij1 == inbij, dim = 1) ! warning: send back the first occurence if multiple results
IF ( iszij1(ii) < iszij ) THEN
+ ii = MINLOC( iszi1+iszj1, mask = iszij1 == iszij1(ii) .AND. inbij1 == inbij, dim = 1) ! select the smaller perimeter if multiple min
isz0 = isz0 + 1
indexok(isz0) = ii
@@ -974,10 +937,10 @@
ji = isz0 ! initialization with the largest value
ALLOCATE( llisoce(inbi0(ji), inbj0(ji)) )
- CALL mpp_init_isoce( inbi0(ji), inbj0(ji), llisoce ) ! Warning: must be call by all cores (call mpp_sum)
+ CALL mpp_is_ocean( llisoce ) ! Warning: must be call by all cores (call mpp_sum)
inbijold = COUNT(llisoce)
DEALLOCATE( llisoce )
DO ji =isz0-1,1,-1
ALLOCATE( llisoce(inbi0(ji), inbj0(ji)) )
- CALL mpp_init_isoce( inbi0(ji), inbj0(ji), llisoce ) ! Warning: must be call by all cores (call mpp_sum)
+ CALL mpp_is_ocean( llisoce ) ! Warning: must be call by all cores (call mpp_sum)
inbij = COUNT(llisoce)
DEALLOCATE( llisoce )
@@ -1005,5 +968,5 @@
ii = ii -1
ALLOCATE( llisoce(inbi0(ii), inbj0(ii)) )
- CALL mpp_init_isoce( inbi0(ii), inbj0(ii), llisoce ) ! must be done by all core
+ CALL mpp_is_ocean( llisoce ) ! must be done by all core
inbij = COUNT(llisoce)
DEALLOCATE( llisoce )
@@ -1014,5 +977,5 @@
DEALLOCATE( inbi0, inbj0 )
!
- END SUBROUTINE mpp_init_bestpartition
+ END SUBROUTINE bestpartition
@@ -1023,5 +986,5 @@
!! ** Purpose : the the proportion of land points in the surface land-sea mask
!!
- !! ** Method : read iproc strips (of length jpiglo) of the land-sea mask
+ !! ** Method : read iproc strips (of length Ni0glo) of the land-sea mask
!!----------------------------------------------------------------------
REAL(wp), INTENT( out) :: propland ! proportion of land points in the global domain (between 0 and 1)
@@ -1040,5 +1003,5 @@
! number of processes reading the bathymetry file
- iproc = MINVAL( (/mppsize, jpjglo/2, 100/) ) ! read a least 2 lines, no more that 100 processes reading at the same time
+ iproc = MINVAL( (/mppsize, Nj0glo/2, 100/) ) ! read a least 2 lines, no more that 100 processes reading at the same time
! we want to read iproc strips of the land-sea mask. -> pick up iproc processes every idiv processes starting at 1
@@ -1050,10 +1013,10 @@
IF( MOD( narea-1, idiv ) == 0 .AND. iarea < iproc ) THEN ! beware idiv can be = to 1
!
- ijsz = jpjglo / iproc ! width of the stripe to read
- IF( iarea < MOD(jpjglo,iproc) ) ijsz = ijsz + 1
- ijstr = iarea*(jpjglo/iproc) + MIN(iarea, MOD(jpjglo,iproc)) + 1 ! starting j position of the reading
+ ijsz = Nj0glo / iproc ! width of the stripe to read
+ IF( iarea < MOD(Nj0glo,iproc) ) ijsz = ijsz + 1
+ ijstr = iarea*(Nj0glo/iproc) + MIN(iarea, MOD(Nj0glo,iproc)) + 1 ! starting j position of the reading
!
- ALLOCATE( lloce(jpiglo, ijsz) ) ! allocate the strip
- CALL mpp_init_readbot_strip( ijstr, ijsz, lloce )
+ ALLOCATE( lloce(Ni0glo, ijsz) ) ! allocate the strip
+ CALL readbot_strip( ijstr, ijsz, lloce )
inboce = COUNT(lloce) ! number of ocean point in the stripe
DEALLOCATE(lloce)
@@ -1064,28 +1027,34 @@
CALL mpp_sum( 'mppini', inboce ) ! total number of ocean points over the global domain
!
- propland = REAL( jpiglo*jpjglo - inboce, wp ) / REAL( jpiglo*jpjglo, wp )
+ propland = REAL( Ni0glo*Nj0glo - inboce, wp ) / REAL( Ni0glo*Nj0glo, wp )
!
END SUBROUTINE mpp_init_landprop
- SUBROUTINE mpp_init_isoce( knbi, knbj, ldisoce )
- !!----------------------------------------------------------------------
- !! *** ROUTINE mpp_init_nboce ***
- !!
- !! ** Purpose : check for a mpi domain decomposition knbi x knbj which
- !! subdomains contain at least 1 ocean point
- !!
- !! ** Method : read knbj strips (of length jpiglo) of the land-sea mask
- !!----------------------------------------------------------------------
- INTEGER, INTENT(in ) :: knbi, knbj ! domain decomposition
- LOGICAL, DIMENSION(knbi,knbj), INTENT( out) :: ldisoce ! .true. if a sub domain constains 1 ocean point
- !
- INTEGER, DIMENSION(knbi,knbj) :: inboce ! number oce oce pint in each mpi subdomain
- INTEGER, DIMENSION(knbi*knbj) :: inboce_1d
+ SUBROUTINE mpp_is_ocean( ldisoce )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE mpp_is_ocean ***
+ !!
+ !! ** Purpose : Check for a mpi domain decomposition inbi x inbj which
+ !! subdomains, including 1 halo (even if nn_hls>1), contain
+ !! at least 1 ocean point.
+ !! We must indeed ensure that each subdomain that is a neighbour
+ !! of a land subdomain as only land points on its boundary
+ !! (inside the inner subdomain) with the land subdomain.
+ !! This is needed to get the proper bondary conditions on
+ !! a subdomain with a closed boundary.
+ !!
+ !! ** Method : read inbj strips (of length Ni0glo) of the land-sea mask
+ !!----------------------------------------------------------------------
+ LOGICAL, DIMENSION(:,:), INTENT( out) :: ldisoce ! .true. if a sub domain constains 1 ocean point
+ !
INTEGER :: idiv, iimax, ijmax, iarea
+ INTEGER :: inbi, inbj, inx, iny, inry, isty
INTEGER :: ji, jn
- LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: lloce ! lloce(i,j) = .true. if the point (i,j) is ocean
- INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iimppt, ilci
- INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ijmppt, ilcj
+ INTEGER, ALLOCATABLE, DIMENSION(:,:) :: inboce ! number oce oce pint in each mpi subdomain
+ INTEGER, ALLOCATABLE, DIMENSION(: ) :: inboce_1d
+ INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iimppt, ijpi
+ INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ijmppt, ijpj
+ LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: lloce ! lloce(i,j) = .true. if the point (i,j) is ocean
!!----------------------------------------------------------------------
! do nothing if there is no land-sea mask
@@ -1094,43 +1063,88 @@
RETURN
ENDIF
-
- ! we want to read knbj strips of the land-sea mask. -> pick up knbj processes every idiv processes starting at 1
- IF ( knbj == 1 ) THEN ; idiv = mppsize
- ELSE IF ( mppsize < knbj ) THEN ; idiv = 1
- ELSE ; idiv = ( mppsize - 1 ) / ( knbj - 1 )
- ENDIF
+ !
+ inbi = SIZE( ldisoce, dim = 1 )
+ inbj = SIZE( ldisoce, dim = 2 )
+ !
+ ! we want to read inbj strips of the land-sea mask. -> pick up inbj processes every idiv processes starting at 1
+ IF ( inbj == 1 ) THEN ; idiv = mppsize
+ ELSE IF ( mppsize < inbj ) THEN ; idiv = 1
+ ELSE ; idiv = ( mppsize - 1 ) / ( inbj - 1 )
+ ENDIF
+ !
+ ALLOCATE( inboce(inbi,inbj), inboce_1d(inbi*inbj) )
inboce(:,:) = 0 ! default no ocean point found
-
- DO jn = 0, (knbj-1)/mppsize ! if mppsize < knbj : more strips than mpi processes (because of potential land domains)
+ !
+ DO jn = 0, (inbj-1)/mppsize ! if mppsize < inbj : more strips than mpi processes (because of potential land domains)
!
- iarea = (narea-1)/idiv + jn * mppsize ! involed process number (starting counting at 0)
- IF( MOD( narea-1, idiv ) == 0 .AND. iarea < knbj ) THEN ! beware idiv can be = to 1
+ iarea = (narea-1)/idiv + jn * mppsize + 1 ! involed process number (starting counting at 1)
+ IF( MOD( narea-1, idiv ) == 0 .AND. iarea <= inbj ) THEN ! beware idiv can be = to 1
!
- ALLOCATE( iimppt(knbi,knbj), ijmppt(knbi,knbj), ilci(knbi,knbj), ilcj(knbi,knbj) )
- CALL mpp_basic_decomposition( knbi, knbj, iimax, ijmax, iimppt, ijmppt, ilci, ilcj )
+ ALLOCATE( iimppt(inbi,inbj), ijmppt(inbi,inbj), ijpi(inbi,inbj), ijpj(inbi,inbj) )
+ CALL mpp_basesplit( Ni0glo, Nj0glo, 0, inbi, inbj, iimax, ijmax, iimppt, ijmppt, ijpi, ijpj )
!
- ALLOCATE( lloce(jpiglo, ilcj(1,iarea+1)) ) ! allocate the strip
- CALL mpp_init_readbot_strip( ijmppt(1,iarea+1), ilcj(1,iarea+1), lloce ) ! read the strip
- DO ji = 1, knbi
- inboce(ji,iarea+1) = COUNT( lloce(iimppt(ji,1):iimppt(ji,1)+ilci(ji,1)-1,:) ) ! number of ocean point in subdomain
+ inx = Ni0glo + 2 ; iny = ijpj(1,iarea) + 2 ! strip size + 1 halo on each direction (even if nn_hls>1)
+ ALLOCATE( lloce(inx, iny) ) ! allocate the strip
+ inry = iny - COUNT( (/ iarea == 1, iarea == inbj /) ) ! number of point to read in y-direction
+ isty = 1 + COUNT( (/ iarea == 1 /) ) ! read from the first or the second line?
+ CALL readbot_strip( ijmppt(1,iarea) - 2 + isty, inry, lloce(2:inx-1, isty:inry+isty-1) ) ! read the strip
+ !
+ IF( iarea == 1 ) THEN ! the first line was not read
+ IF( jperio == 2 .OR. jperio == 7 ) THEN ! north-south periodocity
+ CALL readbot_strip( Nj0glo, 1, lloce(2:inx-1, 1) ) ! read the last line -> first line of lloce
+ ELSE
+ lloce(2:inx-1, 1) = .FALSE. ! closed boundary
+ ENDIF
+ ENDIF
+ IF( iarea == inbj ) THEN ! the last line was not read
+ IF( jperio == 2 .OR. jperio == 7 ) THEN ! north-south periodocity
+ CALL readbot_strip( 1, 1, lloce(2:inx-1,iny) ) ! read the first line -> last line of lloce
+ ELSEIF( jperio == 3 .OR. jperio == 4 ) THEN ! north-pole folding T-pivot, T-point
+ lloce(2,iny) = lloce(2,iny-2) ! here we have 1 halo (even if nn_hls>1)
+ DO ji = 3,inx-1
+ lloce(ji,iny ) = lloce(inx-ji+2,iny-2) ! ok, we have at least 3 lines
+ END DO
+ DO ji = inx/2+2,inx-1
+ lloce(ji,iny-1) = lloce(inx-ji+2,iny-1)
+ END DO
+ ELSEIF( jperio == 5 .OR. jperio == 6 ) THEN ! north-pole folding F-pivot, T-point, 1 halo
+ lloce(inx/2+1,iny-1) = lloce(inx/2,iny-1) ! here we have 1 halo (even if nn_hls>1)
+ lloce(inx -1,iny-1) = lloce(2 ,iny-1)
+ DO ji = 2,inx-1
+ lloce(ji,iny) = lloce(inx-ji+1,iny-1)
+ END DO
+ ELSE ! closed boundary
+ lloce(2:inx-1,iny) = .FALSE.
+ ENDIF
+ ENDIF
+ ! ! first and last column were not read
+ IF( jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7 ) THEN
+ lloce(1,:) = lloce(inx-1,:) ; lloce(inx,:) = lloce(2,:) ! east-west periodocity
+ ELSE
+ lloce(1,:) = .FALSE. ; lloce(inx,:) = .FALSE. ! closed boundary
+ ENDIF
+ !
+ DO ji = 1, inbi
+ inboce(ji,iarea) = COUNT( lloce(iimppt(ji,1):iimppt(ji,1)+ijpi(ji,1)+1,:) ) ! lloce as 2 points more than Ni0glo
END DO
!
DEALLOCATE(lloce)
- DEALLOCATE(iimppt, ijmppt, ilci, ilcj)
+ DEALLOCATE(iimppt, ijmppt, ijpi, ijpj)
!
ENDIF
END DO
- inboce_1d = RESHAPE(inboce, (/ knbi*knbj /))
+ inboce_1d = RESHAPE(inboce, (/ inbi*inbj /))
CALL mpp_sum( 'mppini', inboce_1d )
- inboce = RESHAPE(inboce_1d, (/knbi, knbj/))
+ inboce = RESHAPE(inboce_1d, (/inbi, inbj/))
ldisoce(:,:) = inboce(:,:) /= 0
- !
- END SUBROUTINE mpp_init_isoce
+ DEALLOCATE(inboce, inboce_1d)
+ !
+ END SUBROUTINE mpp_is_ocean
- SUBROUTINE mpp_init_readbot_strip( kjstr, kjcnt, ldoce )
- !!----------------------------------------------------------------------
- !! *** ROUTINE mpp_init_readbot_strip ***
+ SUBROUTINE readbot_strip( kjstr, kjcnt, ldoce )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE readbot_strip ***
!!
!! ** Purpose : Read relevant bathymetric information in order to
@@ -1138,36 +1152,89 @@
!! of land domains, in an mpp computation.
!!
- !! ** Method : read stipe of size (jpiglo,...)
- !!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: kjstr ! starting j position of the reading
- INTEGER , INTENT(in ) :: kjcnt ! number of lines to read
- LOGICAL, DIMENSION(jpiglo,kjcnt), INTENT( out) :: ldoce ! ldoce(i,j) = .true. if the point (i,j) is ocean
+ !! ** Method : read stipe of size (Ni0glo,...)
+ !!----------------------------------------------------------------------
+ INTEGER , INTENT(in ) :: kjstr ! starting j position of the reading
+ INTEGER , INTENT(in ) :: kjcnt ! number of lines to read
+ LOGICAL, DIMENSION(Ni0glo,kjcnt), INTENT( out) :: ldoce ! ldoce(i,j) = .true. if the point (i,j) is ocean
!
INTEGER :: inumsave ! local logical unit
- REAL(wp), DIMENSION(jpiglo,kjcnt) :: zbot, zbdy
+ REAL(wp), DIMENSION(Ni0glo,kjcnt) :: zbot, zbdy
!!----------------------------------------------------------------------
!
inumsave = numout ; numout = numnul ! redirect all print to /dev/null
!
- IF( numbot /= -1 ) THEN
- CALL iom_get( numbot, jpdom_unknown, 'bottom_level', zbot, kstart = (/1,kjstr/), kcount = (/jpiglo, kjcnt/) )
+ IF( numbot /= -1 ) THEN
+ CALL iom_get( numbot, jpdom_unknown, 'bottom_level', zbot, kstart = (/1,kjstr/), kcount = (/Ni0glo, kjcnt/) )
ELSE
- zbot(:,:) = 1. ! put a non-null value
- ENDIF
-
- IF( numbdy /= -1 ) THEN ! Adjust with bdy_msk if it exists
- CALL iom_get ( numbdy, jpdom_unknown, 'bdy_msk', zbdy, kstart = (/1,kjstr/), kcount = (/jpiglo, kjcnt/) )
+ zbot(:,:) = 1._wp ! put a non-null value
+ ENDIF
+ !
+ IF( numbdy /= -1 ) THEN ! Adjust with bdy_msk if it exists
+ CALL iom_get ( numbdy, jpdom_unknown, 'bdy_msk', zbdy, kstart = (/1,kjstr/), kcount = (/Ni0glo, kjcnt/) )
zbot(:,:) = zbot(:,:) * zbdy(:,:)
ENDIF
!
- ldoce(:,:) = zbot(:,:) > 0.
+ ldoce(:,:) = zbot(:,:) > 0._wp
numout = inumsave
!
- END SUBROUTINE mpp_init_readbot_strip
-
-
- SUBROUTINE mpp_init_ioipsl
- !!----------------------------------------------------------------------
- !! *** ROUTINE mpp_init_ioipsl ***
+ END SUBROUTINE readbot_strip
+
+
+ SUBROUTINE mpp_getnum( ldisoce, kproc, kipos, kjpos )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE mpp_getnum ***
+ !!
+ !! ** Purpose : give a number to each MPI subdomains (starting at 0)
+ !!
+ !! ** Method : start from bottom left. First skip land subdomain, and finally use them if needed
+ !!----------------------------------------------------------------------
+ LOGICAL, DIMENSION(:,:), INTENT(in ) :: ldisoce ! F if land process
+ INTEGER, DIMENSION(:,:), INTENT( out) :: kproc ! subdomain number (-1 if supressed, starting at 0)
+ INTEGER, DIMENSION( :), INTENT( out) :: kipos ! i-position of the subdomain (from 1 to jpni)
+ INTEGER, DIMENSION( :), INTENT( out) :: kjpos ! j-position of the subdomain (from 1 to jpnj)
+ !
+ INTEGER :: ii, ij, jarea, iarea0
+ INTEGER :: icont, i2add , ini, inj, inij
+ !!----------------------------------------------------------------------
+ !
+ ini = SIZE(ldisoce, dim = 1)
+ inj = SIZE(ldisoce, dim = 2)
+ inij = SIZE(kipos)
+ !
+ ! specify which subdomains are oce subdomains; other are land subdomains
+ kproc(:,:) = -1
+ icont = -1
+ DO jarea = 1, ini*inj
+ iarea0 = jarea - 1
+ ii = 1 + MOD(iarea0,ini)
+ ij = 1 + iarea0/ini
+ IF( ldisoce(ii,ij) ) THEN
+ icont = icont + 1
+ kproc(ii,ij) = icont
+ kipos(icont+1) = ii
+ kjpos(icont+1) = ij
+ ENDIF
+ END DO
+ ! if needed add some land subdomains to reach inij active subdomains
+ i2add = inij - COUNT( ldisoce )
+ DO jarea = 1, ini*inj
+ iarea0 = jarea - 1
+ ii = 1 + MOD(iarea0,ini)
+ ij = 1 + iarea0/ini
+ IF( .NOT. ldisoce(ii,ij) .AND. i2add > 0 ) THEN
+ icont = icont + 1
+ kproc(ii,ij) = icont
+ kipos(icont+1) = ii
+ kjpos(icont+1) = ij
+ i2add = i2add - 1
+ ENDIF
+ END DO
+ !
+ END SUBROUTINE mpp_getnum
+
+
+ SUBROUTINE init_ioipsl
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE init_ioipsl ***
!!
!! ** Purpose :
@@ -1186,34 +1253,28 @@
! Set idompar values equivalent to the jpdom_local_noextra definition
! used in IOM. This works even if jpnij .ne. jpni*jpnj.
- iglo(1) = jpiglo
- iglo(2) = jpjglo
- iloc(1) = nlci
- iloc(2) = nlcj
- iabsf(1) = nimppt(narea)
- iabsf(2) = njmppt(narea)
+ 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!
iabsl(:) = iabsf(:) + iloc(:) - 1
- ihals(1) = nldi - 1
- ihals(2) = nldj - 1
- ihale(1) = nlci - nlei
- ihale(2) = nlcj - nlej
- idid(1) = 1
- idid(2) = 2
+ ihals(:) = (/ 0 , 0 /)
+ ihale(:) = (/ 0 , 0 /)
+ idid( :) = (/ 1 , 2 /)
IF(lwp) THEN
WRITE(numout,*)
- WRITE(numout,*) 'mpp_init_ioipsl : iloc = ', iloc (1), iloc (2)
- WRITE(numout,*) '~~~~~~~~~~~~~~~ iabsf = ', iabsf(1), iabsf(2)
- WRITE(numout,*) ' ihals = ', ihals(1), ihals(2)
- WRITE(numout,*) ' ihale = ', ihale(1), ihale(2)
+ WRITE(numout,*) 'mpp init_ioipsl : iloc = ', iloc
+ WRITE(numout,*) '~~~~~~~~~~~~~~~ iabsf = ', iabsf
+ WRITE(numout,*) ' ihals = ', ihals
+ WRITE(numout,*) ' ihale = ', ihale
ENDIF
!
CALL flio_dom_set ( jpnij, nproc, idid, iglo, iloc, iabsf, iabsl, ihals, ihale, 'BOX', nidom)
!
- END SUBROUTINE mpp_init_ioipsl
-
-
- SUBROUTINE mpp_init_nfdcom
- !!----------------------------------------------------------------------
- !! *** ROUTINE mpp_init_nfdcom ***
+ END SUBROUTINE init_ioipsl
+
+
+ SUBROUTINE init_nfdcom
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE init_nfdcom ***
!! ** Purpose : Setup for north fold exchanges with explicit
!! point-to-point messaging
@@ -1225,8 +1286,5 @@
!!----------------------------------------------------------------------
INTEGER :: sxM, dxM, sxT, dxT, jn
- INTEGER :: njmppmax
- !!----------------------------------------------------------------------
- !
- njmppmax = MAXVAL( njmppt )
+ !!----------------------------------------------------------------------
!
!initializes the north-fold communication variables
@@ -1234,8 +1292,8 @@
nsndto = 0
!
- IF ( njmpp == njmppmax ) THEN ! if I am a process in the north
+ IF ( njmpp == MAXVAL( njmppt ) ) THEN ! if I am a process in the north
!
!sxM is the first point (in the global domain) needed to compute the north-fold for the current process
- sxM = jpiglo - nimppt(narea) - nlcit(narea) + 1
+ sxM = jpiglo - nimppt(narea) - jpiall(narea) + 1
!dxM is the last point (in the global domain) needed to compute the north-fold for the current process
dxM = jpiglo - nimppt(narea) + 2
@@ -1246,6 +1304,6 @@
DO jn = 1, jpni
!
- sxT = nfiimpp(jn, jpnj) ! sxT = 1st point (in the global domain) of the jn process
- dxT = nfiimpp(jn, jpnj) + nfilcit(jn, jpnj) - 1 ! dxT = last point (in the global domain) of the jn process
+ sxT = nfimpp(jn) ! sxT = 1st point (in the global domain) of the jn process
+ dxT = nfimpp(jn) + nfjpi(jn) - 1 ! dxT = last point (in the global domain) of the jn process
!
IF ( sxT < sxM .AND. sxM < dxT ) THEN
@@ -1261,21 +1319,46 @@
!
END DO
- nfsloop = 1
- nfeloop = nlci
- DO jn = 2,jpni-1
- IF( nfipproc(jn,jpnj) == (narea - 1) ) THEN
- IF( nfipproc(jn-1,jpnj) == -1 ) nfsloop = nldi
- IF( nfipproc(jn+1,jpnj) == -1 ) nfeloop = nlei
- ENDIF
- END DO
!
ENDIF
l_north_nogather = .TRUE.
!
- END SUBROUTINE mpp_init_nfdcom
-
-
-#endif
-
+ END SUBROUTINE init_nfdcom
+
+
+ SUBROUTINE init_doloop
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE init_doloop ***
+ !!
+ !! ** Purpose : set the starting/ending indices of DO-loop
+ !! These indices are used in do_loop_substitute.h90
+ !!----------------------------------------------------------------------
+ !
+ Nis0 = 1+nn_hls ; Nis1 = Nis0-1 ; Nis2 = MAX( 1, Nis0-2)
+ Njs0 = 1+nn_hls ; Njs1 = Njs0-1 ; Njs2 = MAX( 1, Njs0-2)
+ !
+ Nie0 = jpi-nn_hls ; Nie1 = Nie0+1 ; Nie2 = MIN(jpi, Nie0+2)
+ Nje0 = jpj-nn_hls ; Nje1 = Nje0+1 ; Nje2 = MIN(jpj, Nje0+2)
+ !
+ IF( nn_hls == 1 ) THEN !* halo size of 1
+ !
+ Nis1nxt2 = Nis0 ; Njs1nxt2 = Njs0
+ Nie1nxt2 = Nie0 ; Nje1nxt2 = Nje0
+ !
+ ELSE !* larger halo size...
+ !
+ Nis1nxt2 = Nis1 ; Njs1nxt2 = Njs1
+ Nie1nxt2 = Nie1 ; Nje1nxt2 = Nje1
+ !
+ ENDIF
+ !
+ Ni_0 = Nie0 - Nis0 + 1
+ Nj_0 = Nje0 - Njs0 + 1
+ Ni_1 = Nie1 - Nis1 + 1
+ Nj_1 = Nje1 - Njs1 + 1
+ Ni_2 = Nie2 - Nis2 + 1
+ Nj_2 = Nje2 - Njs2 + 1
+ !
+ END SUBROUTINE init_doloop
+
!!======================================================================
END MODULE mppini
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/LDF/ldfc1d_c2d.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/LDF/ldfc1d_c2d.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/LDF/ldfc1d_c2d.F90 (revision 13540)
@@ -80,13 +80,13 @@
pah1(:,:,jk) = pahs1(:,:) * ( zratio + zc * ( 1._wp + TANH( - ( gdept_0(:,:,jk) - zh ) * zw) ) )
END DO
- DO_3DS_10_10( jpkm1, 1, -1 )
+ DO_3DS( 1, 0, 1, 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
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. ) ! Lateral boundary conditions
+ CALL lbc_lnk( 'ldfc1d_c2d', pah2, 'F', 1.0_wp ) ! Lateral boundary conditions
!
CASE( 'TRA' ) ! U- and V-points (zdep1 & 2 are an approximation in zps-coord.)
- DO_3DS_10_10( jpkm1, 1, -1 )
+ DO_3DS( 1, 0, 1, 0, jpkm1, 1, -1 )
zdep1 = ( gdept_0(ji,jj,jk) + gdept_0(ji+1,jj,jk) ) * 0.5_wp
zdep2 = ( gdept_0(ji,jj,jk) + gdept_0(ji,jj+1,jk) ) * 0.5_wp
@@ -95,5 +95,5 @@
END_3D
! Lateral boundary conditions
- CALL lbc_lnk_multi( 'ldfc1d_c2d', pah1, 'U', 1. , pah2, 'V', 1. )
+ CALL lbc_lnk_multi( 'ldfc1d_c2d', pah1, 'U', 1.0_wp , pah2, 'V', 1.0_wp )
!
CASE DEFAULT ! error
@@ -135,10 +135,10 @@
!
CASE( 'DYN' ) ! T- and F-points
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
pah1(ji,jj,1) = pUfac * MAX( e1t(ji,jj) , e2t(ji,jj) )**knn
pah2(ji,jj,1) = pUfac * MAX( e1f(ji,jj) , e2f(ji,jj) )**knn
END_2D
CASE( 'TRA' ) ! U- and V-points
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
pah1(ji,jj,1) = pUfac * MAX( e1u(ji,jj), e2u(ji,jj) )**knn
pah2(ji,jj,1) = pUfac * MAX( e1v(ji,jj), e2v(ji,jj) )**knn
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/LDF/ldfdyn.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/LDF/ldfdyn.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/LDF/ldfdyn.F90 (revision 13540)
@@ -267,6 +267,6 @@
IF(lwp) WRITE(numout,*) ' ==>>> eddy viscosity = F(i,j) read in eddy_viscosity.nc file'
CALL iom_open( 'eddy_viscosity_2D.nc', inum )
- CALL iom_get ( inum, jpdom_data, 'ahmt_2d', ahmt(:,:,1) )
- CALL iom_get ( inum, jpdom_data, 'ahmf_2d', ahmf(:,:,1) )
+ CALL iom_get ( inum, jpdom_global, 'ahmt_2d', ahmt(:,:,1), cd_type = 'T', psgn = 1._wp )
+ CALL iom_get ( inum, jpdom_global, 'ahmf_2d', ahmf(:,:,1), cd_type = 'F', psgn = 1._wp )
CALL iom_close( inum )
DO jk = 2, jpkm1
@@ -284,6 +284,6 @@
IF(lwp) WRITE(numout,*) ' ==>>> eddy viscosity = F(i,j,k) read in eddy_viscosity_3D.nc file'
CALL iom_open( 'eddy_viscosity_3D.nc', inum )
- CALL iom_get ( inum, jpdom_data, 'ahmt_3d', ahmt )
- CALL iom_get ( inum, jpdom_data, 'ahmf_3d', ahmf )
+ CALL iom_get ( inum, jpdom_global, 'ahmt_3d', ahmt, cd_type = 'T', psgn = 1._wp )
+ CALL iom_get ( inum, jpdom_global, 'ahmf_3d', ahmf, cd_type = 'F', psgn = 1._wp )
CALL iom_close( inum )
!
@@ -311,5 +311,5 @@
IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'ldf_dyn_init: failed to allocate Smagorinsky arrays')
!
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 ) ! 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
@@ -368,5 +368,5 @@
IF( ln_dynldf_lap ) THEN ! laplacian operator : |u| e /12 = |u/144| e
DO jk = 1, jpkm1
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
zu2pv2_ij = uu(ji ,jj ,jk,Kbb) * uu(ji ,jj ,jk,Kbb) + vv(ji ,jj ,jk,Kbb) * vv(ji ,jj ,jk,Kbb)
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)
@@ -374,5 +374,5 @@
ahmt(ji,jj,jk) = SQRT( (zu2pv2_ij + zu2pv2_ij_m1) * r1_288 ) * zemax * tmask(ji,jj,jk) ! 288= 12*12 * 2
END_2D
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
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)
@@ -383,5 +383,5 @@
ELSEIF( ln_dynldf_blp ) THEN ! bilaplacian operator : sqrt( |u| e^3 /12 ) = sqrt( |u/144| e ) * e
DO jk = 1, jpkm1
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
zu2pv2_ij = uu(ji ,jj ,jk,Kbb) * uu(ji ,jj ,jk,Kbb) + vv(ji ,jj ,jk,Kbb) * vv(ji ,jj ,jk,Kbb)
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)
@@ -389,5 +389,5 @@
ahmt(ji,jj,jk) = SQRT( SQRT( (zu2pv2_ij + zu2pv2_ij_m1) * r1_288 ) * zemax ) * zemax * tmask(ji,jj,jk)
END_2D
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
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)
@@ -398,5 +398,5 @@
ENDIF
!
- CALL lbc_lnk_multi( 'ldfdyn', ahmt, 'T', 1., ahmf, 'F', 1. )
+ CALL lbc_lnk_multi( 'ldfdyn', ahmt, 'T', 1.0_wp, ahmf, 'F', 1.0_wp )
!
!
@@ -412,5 +412,5 @@
DO jk = 1, jpkm1
!
- DO_2D_00_00
+ 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) &
@@ -420,5 +420,5 @@
END_2D
!
- DO_2D_10_10
+ 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) &
@@ -430,9 +430,9 @@
END DO
!
- CALL lbc_lnk_multi( 'ldfdyn', dtensq, 'T', 1. ) ! lbc_lnk on dshesq not needed
+ CALL lbc_lnk_multi( 'ldfdyn', dtensq, 'T', 1.0_wp ) ! lbc_lnk on dshesq not needed
!
DO jk = 1, jpkm1
!
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 ) ! T-point value
!
zu2pv2_ij = uu(ji ,jj ,jk,Kbb) * uu(ji ,jj ,jk,Kbb) + vv(ji ,jj ,jk,Kbb) * vv(ji ,jj ,jk,Kbb)
@@ -448,5 +448,5 @@
END_2D
!
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 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)
@@ -471,8 +471,8 @@
! ! effective default limits are 1/12 |U|L^3 < B_hm < 1//(32*2dt) L^4
DO jk = 1, jpkm1
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
ahmt(ji,jj,jk) = SQRT( r1_8 * esqt(ji,jj) * ahmt(ji,jj,jk) )
END_2D
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
ahmf(ji,jj,jk) = SQRT( r1_8 * esqf(ji,jj) * ahmf(ji,jj,jk) )
END_2D
@@ -481,5 +481,5 @@
ENDIF
!
- CALL lbc_lnk_multi( 'ldfdyn', ahmt, 'T', 1. , ahmf, 'F', 1. )
+ CALL lbc_lnk_multi( 'ldfdyn', ahmt, 'T', 1.0_wp , ahmf, 'F', 1.0_wp )
!
END SELECT
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/LDF/ldfslp.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/LDF/ldfslp.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/LDF/ldfslp.F90 (revision 13540)
@@ -75,4 +75,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -127,5 +128,5 @@
IF( ln_timing ) CALL timing_start('ldf_slp')
!
- zeps = 1.e-20_wp !== Local constant initialization ==!
+ zeps = 1.e-20_wp !== Local constant initialization ==!
z1_16 = 1.0_wp / 16._wp
zm1_g = -1.0_wp / grav
@@ -136,10 +137,10 @@
zwz(:,:,:) = 0._wp
!
- DO_3D_10_10( 1, jpk )
+ 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_10_10
+ DO_2D( 1, 0, 1, 0 )
zgru(ji,jj,mbku(ji,jj)) = gru(ji,jj)
zgrv(ji,jj,mbkv(ji,jj)) = grv(ji,jj)
@@ -147,5 +148,5 @@
ENDIF
IF( ln_zps .AND. ln_isfcav ) THEN ! partial steps correction at the bottom ocean level
- DO_2D_10_10
+ 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)
@@ -153,5 +154,5 @@
ENDIF
!
- zdzr(:,:,1) = 0._wp !== Local vertical density gradient at T-point == ! (evaluated from N^2)
+ 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
@@ -164,5 +165,5 @@
END DO
!
- ! !== Slopes just below the mixed layer ==!
+ ! !== Slopes just below the mixed layer ==!
CALL ldf_slp_mxl( prd, pn2, zgru, zgrv, zdzr, Kmm ) ! output: uslpml, vslpml, wslpiml, wslpjml
@@ -172,5 +173,5 @@
!
IF ( ln_isfcav ) THEN
- DO_2D_00_00
+ 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 ) ) )
@@ -179,5 +180,5 @@
END_2D
ELSE
- DO_2D_00_00
+ 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)
@@ -185,5 +186,5 @@
END IF
- DO_3D_00_00( 2, jpkm1 )
+ 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)
@@ -198,7 +199,9 @@
! ! 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 ) )
+ 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 ) )
+ 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) )
@@ -206,7 +209,9 @@
! 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) )
+ & - 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) )
+ & - 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 ) &
@@ -224,9 +229,9 @@
!!gm end modif
END_3D
- CALL lbc_lnk_multi( 'ldfslp', zwz, 'U', -1., zww, 'V', -1. ) ! lateral boundary conditions
- !
- ! !* horizontal Shapiro filter
+ CALL lbc_lnk_multi( 'ldfslp', zwz, 'U', -1.0_wp, zww, 'V', -1.0_wp ) ! lateral boundary conditions
+ !
+ ! !* horizontal Shapiro filter
DO jk = 2, jpkm1
- DO_2D_00_00
+ 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) &
@@ -240,5 +245,5 @@
& + 4.* zww(ji,jj ,jk) )
END_2D
- DO jj = 3, jpj-2 ! other rows
+ DO jj = 3, jpj-2 ! other rows
DO ji = 2, jpim1 ! vector opt.
uslp(ji,jj,jk) = z1_16 * ( zwz(ji-1,jj-1,jk) + zwz(ji+1,jj-1,jk) &
@@ -254,6 +259,6 @@
END DO
END DO
- ! !* decrease along coastal boundaries
- DO_2D_00_00
+ ! !* 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
@@ -267,5 +272,5 @@
! =========================== | wslpj = mij( d/dj( prd ) / d/dz( prd )
!
- DO_3D_00_00( 2, jpkm1 )
+ 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. )
@@ -293,14 +298,14 @@
! ! ! 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) / MAX( hmlp(ji,jj), 10. )
+! 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_multi( 'ldfslp', zwz, 'T', -1., zww, 'T', -1. ) ! lateral boundary conditions
+ CALL lbc_lnk_multi( 'ldfslp', zwz, 'T', -1.0_wp, zww, 'T', -1.0_wp ) ! lateral boundary conditions
!
! !* horizontal Shapiro filter
DO jk = 2, jpkm1
- DO_2D_00_00
+ 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) &
@@ -333,5 +338,5 @@
END DO
! !* decrease in vicinity of topography
- DO_2D_00_00
+ 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
@@ -343,5 +348,5 @@
! IV. Lateral boundary conditions
! ===============================
- CALL lbc_lnk_multi( 'ldfslp', uslp , 'U', -1. , vslp , 'V', -1. , wslpi, 'W', -1., wslpj, 'W', -1. )
+ CALL lbc_lnk_multi( '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
@@ -396,5 +401,5 @@
!
ip = jl ; jp = jl ! guaranteed nonzero gradients ( absolute value larger than repsln)
- DO_3D_10_10( 1, jpkm1 )
+ DO_3D( 1, 0, 1, 0, 1, jpkm1 ) ! done each pair of triad ! NB: not masked ==> a minimum value is set
zdit = ( ts(ji+1,jj,jk,jp_tem,Kbb) - ts(ji,jj,jk,jp_tem,Kbb) ) ! i-gradient of T & S at u-point
zdis = ( ts(ji+1,jj,jk,jp_sal,Kbb) - ts(ji,jj,jk,jp_sal,Kbb) )
@@ -408,5 +413,5 @@
!
IF( ln_zps .AND. l_grad_zps ) THEN ! partial steps: correction of i- & j-grad on bottom
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
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
@@ -422,6 +427,6 @@
DO kp = 0, 1 !== unmasked before density i- j-, k-gradients ==!
- DO_3D_11_11( 1, jpkm1 )
- IF( jk+kp > 1 ) THEN ! k-gradient of T & S a jk+kp
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 ) ! done each pair of triad ! NB: not masked ==> a minimum value is set
+ IF( jk+kp > 1 ) THEN ! k-gradient of T & S a jk+kp
zdkt = ( ts(ji,jj,jk+kp-1,jp_tem,Kbb) - ts(ji,jj,jk+kp,jp_tem,Kbb) )
zdks = ( ts(ji,jj,jk+kp-1,jp_sal,Kbb) - ts(ji,jj,jk+kp,jp_sal,Kbb) )
@@ -437,5 +442,5 @@
END DO
!
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 ) !== 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
z1_mlbw(ji,jj) = 1._wp / gdepw(ji,jj,jk,Kmm)
@@ -457,5 +462,5 @@
DO jl = 0, 1 ! calculate slope of the 4 triads immediately ONE level below mixed-layer base
DO kp = 0, 1 ! with only the slope-max limit and MASKED
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
ip = jl ; jp = jl
!
@@ -494,5 +499,5 @@
! Must mask contribution to slope from dz/dx at constant s for triads jk=1,kp=0 that poke up though ocean surface
znot_thru_surface = REAL( 1-1/(jk+kp), wp ) !jk+kp=1,=0.; otherwise=1.0
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
!
! Calculate slope relative to geopotentials used for GM skew fluxes
@@ -575,5 +580,5 @@
wslp2(:,:,1) = 0._wp ! force the surface wslp to zero
- CALL lbc_lnk( 'ldfslp', wslp2, 'W', 1. ) ! lateral boundary confition on wslp2 only ==>>> gm : necessary ? to be checked
+ CALL lbc_lnk( 'ldfslp', wslp2, 'W', 1.0_wp ) ! lateral boundary confition on wslp2 only ==>>> gm : necessary ? to be checked
!
IF( ln_timing ) CALL timing_stop('ldf_slp_triad')
@@ -623,5 +628,5 @@
!
! !== surface mixed layer mask !
- DO_3D_11_11( 1, jpk )
+ 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
@@ -641,5 +646,5 @@
!-----------------------------------------------------------------------
!
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
! !== Slope at u- & v-points just below the Mixed Layer ==!
!
@@ -684,5 +689,5 @@
END_2D
!!gm this lbc_lnk should be useless....
- CALL lbc_lnk_multi( 'ldfslp', uslpml , 'U', -1. , vslpml , 'V', -1. , wslpiml, 'W', -1. , wslpjml, 'W', -1. )
+ CALL lbc_lnk_multi( '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
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/LDF/ldftra.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/LDF/ldftra.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/LDF/ldftra.F90 (revision 13540)
@@ -95,4 +95,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -316,6 +317,6 @@
IF(lwp) WRITE(numout,*) ' ==>>> eddy diffusivity = F(i,j) read in eddy_diffusivity.nc file'
CALL iom_open( 'eddy_diffusivity_2D.nc', inum )
- CALL iom_get ( inum, jpdom_data, 'ahtu_2D', ahtu(:,:,1) )
- CALL iom_get ( inum, jpdom_data, 'ahtv_2D', ahtv(:,:,1) )
+ CALL iom_get ( inum, jpdom_global, 'ahtu_2D', ahtu(:,:,1), cd_type = 'U', psgn = 1._wp )
+ CALL iom_get ( inum, jpdom_global, 'ahtv_2D', ahtv(:,:,1), cd_type = 'V', psgn = 1._wp )
CALL iom_close( inum )
DO jk = 2, jpkm1
@@ -344,6 +345,6 @@
IF(lwp) WRITE(numout,*) ' ==>>> eddy diffusivity = F(i,j,k) read in eddy_diffusivity.nc file'
CALL iom_open( 'eddy_diffusivity_3D.nc', inum )
- CALL iom_get ( inum, jpdom_data, 'ahtu_3D', ahtu )
- CALL iom_get ( inum, jpdom_data, 'ahtv_3D', ahtv )
+ CALL iom_get ( inum, jpdom_global, 'ahtu_3D', ahtu, cd_type = 'U', psgn = 1._wp )
+ CALL iom_get ( inum, jpdom_global, 'ahtv_3D', ahtv, cd_type = 'V', psgn = 1._wp )
CALL iom_close( inum )
!
@@ -429,5 +430,5 @@
zaht_min = 0.2_wp * aht0 ! minimum value for aht
zDaht = aht0 - zaht_min
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
!!gm CAUTION : here we assume lat/lon grid in 20deg N/S band (like all ORCA cfg)
!! ==>>> The Coriolis value is identical for t- & u_points, and for v- and f-points
@@ -571,6 +572,6 @@
IF(lwp) WRITE(numout,*) ' ==>>> eddy induced velocity coef. = F(i,j) read in eddy_diffusivity_2D.nc file'
CALL iom_open ( 'eddy_induced_velocity_2D.nc', inum )
- CALL iom_get ( inum, jpdom_data, 'aeiu', aeiu(:,:,1) )
- CALL iom_get ( inum, jpdom_data, 'aeiv', aeiv(:,:,1) )
+ CALL iom_get ( inum, jpdom_global, 'aeiu', aeiu(:,:,1), cd_type = 'U', psgn = 1._wp )
+ CALL iom_get ( inum, jpdom_global, 'aeiv', aeiv(:,:,1), cd_type = 'V', psgn = 1._wp )
CALL iom_close( inum )
DO jk = 2, jpkm1
@@ -595,6 +596,6 @@
IF(lwp) WRITE(numout,*) ' ==>>> eddy induced velocity coef. = F(i,j,k) read in eddy_diffusivity_3D.nc file'
CALL iom_open ( 'eddy_induced_velocity_3D.nc', inum )
- CALL iom_get ( inum, jpdom_data, 'aeiu', aeiu )
- CALL iom_get ( inum, jpdom_data, 'aeiv', aeiv )
+ CALL iom_get ( inum, jpdom_global, 'aeiu', aeiu, cd_type = 'U', psgn = 1._wp )
+ CALL iom_get ( inum, jpdom_global, 'aeiv', aeiv, cd_type = 'V', psgn = 1._wp )
CALL iom_close( inum )
!
@@ -647,5 +648,5 @@
! ! Compute lateral diffusive coefficient at T-point
IF( ln_traldf_triad ) THEN
- DO_3D_00_00( 1, jpk )
+ DO_3D( 0, 0, 0, 0, 1, jpk )
! Take the max of N^2 and zero then take the vertical sum
! of the square root of the resulting N^2 ( required to compute
@@ -661,5 +662,5 @@
END_3D
ELSE
- DO_3D_00_00( 1, jpk )
+ DO_3D( 0, 0, 0, 0, 1, jpk )
! Take the max of N^2 and zero then take the vertical sum
! of the square root of the resulting N^2 ( required to compute
@@ -677,5 +678,5 @@
ENDIF
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
zfw = MAX( ABS( 2. * omega * SIN( rad * gphit(ji,jj) ) ) , 1.e-10 )
! Rossby radius at w-point taken betwenn 2 km and 40km
@@ -687,15 +688,15 @@
! !== Bound on eiv coeff. ==!
z1_f20 = 1._wp / ( 2._wp * omega * sin( rad * 20._wp ) )
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
zzaei = MIN( 1._wp, ABS( ff_t(ji,jj) * z1_f20 ) ) * zaeiw(ji,jj) ! tropical decrease
zaeiw(ji,jj) = MIN( zzaei , paei0 ) ! Max value = paei0
END_2D
- CALL lbc_lnk( 'ldftra', zaeiw(:,:), 'W', 1. ) ! lateral boundary condition
+ CALL lbc_lnk( 'ldftra', zaeiw(:,:), 'W', 1.0_wp ) ! lateral boundary condition
!
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 ) !== aei at u- and v-points ==!
paeiu(ji,jj,1) = 0.5_wp * ( zaeiw(ji,jj) + zaeiw(ji+1,jj ) ) * umask(ji,jj,1)
paeiv(ji,jj,1) = 0.5_wp * ( zaeiw(ji,jj) + zaeiw(ji ,jj+1) ) * vmask(ji,jj,1)
END_2D
- CALL lbc_lnk_multi( 'ldftra', paeiu(:,:,1), 'U', 1. , paeiv(:,:,1), 'V', 1. ) ! lateral boundary condition
+ CALL lbc_lnk_multi( 'ldftra', paeiu(:,:,1), 'U', 1.0_wp , paeiv(:,:,1), 'V', 1.0_wp ) ! lateral boundary condition
DO jk = 2, jpkm1 !== deeper values equal the surface one ==!
@@ -749,5 +750,5 @@
zpsi_uw(:,:,jpk) = 0._wp ; zpsi_vw(:,:,jpk) = 0._wp
!
- DO_3D_10_10( 2, jpkm1 )
+ DO_3D( 1, 0, 1, 0, 2, jpkm1 )
zpsi_uw(ji,jj,jk) = - r1_4 * e2u(ji,jj) * ( wslpi(ji,jj,jk ) + wslpi(ji+1,jj,jk) ) &
& * ( aeiu (ji,jj,jk-1) + aeiu (ji ,jj,jk) ) * wumask(ji,jj,jk)
@@ -756,9 +757,9 @@
END_3D
!
- DO_3D_10_10( 1, jpkm1 )
+ DO_3D( 1, 0, 1, 0, 1, jpkm1 )
pu(ji,jj,jk) = pu(ji,jj,jk) - ( zpsi_uw(ji,jj,jk) - zpsi_uw(ji,jj,jk+1) )
pv(ji,jj,jk) = pv(ji,jj,jk) - ( zpsi_vw(ji,jj,jk) - zpsi_vw(ji,jj,jk+1) )
END_3D
- DO_3D_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 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) )
@@ -793,5 +794,5 @@
!!gm to be redesigned....
! !== eiv stream function: output ==!
- CALL lbc_lnk_multi( 'ldftra', psi_uw, 'U', -1. , psi_vw, 'V', -1. )
+ CALL lbc_lnk_multi( 'ldftra', psi_uw, 'U', -1.0_wp , psi_vw, 'V', -1.0_wp )
!
!!gm CALL iom_put( "psi_eiv_uw", psi_uw ) ! output
@@ -812,9 +813,9 @@
CALL iom_put( "voce_eiv", zw3d )
!
- DO_3D_00_00( 1, jpkm1 )
+ 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 lbc_lnk( 'ldftra', zw3d, 'T', 1. ) ! lateral boundary condition
+ CALL lbc_lnk( 'ldftra', zw3d, 'T', 1.0_wp ) ! lateral boundary condition
CALL iom_put( "woce_eiv", zw3d )
!
@@ -839,11 +840,11 @@
zw2d(:,:) = 0._wp
zw3d(:,:,:) = 0._wp
- DO_3D_00_00( 1, jpkm1 )
+ 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_tem,Kmm) + ts (ji+1,jj,jk,jp_tem,Kmm) )
zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk)
END_3D
- CALL lbc_lnk( 'ldftra', zw2d, 'U', -1. )
- CALL lbc_lnk( 'ldftra', zw3d, 'U', -1. )
+ CALL lbc_lnk( 'ldftra', zw2d, 'U', -1.0_wp )
+ CALL lbc_lnk( 'ldftra', zw3d, 'U', -1.0_wp )
CALL iom_put( "ueiv_heattr" , zztmp * zw2d ) ! heat transport in i-direction
CALL iom_put( "ueiv_heattr3d", zztmp * zw3d ) ! heat transport in i-direction
@@ -860,10 +861,10 @@
zw2d(:,:) = 0._wp
zw3d(:,:,:) = 0._wp
- DO_3D_00_00( 1, jpkm1 )
+ 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 lbc_lnk( 'ldftra', zw2d, 'V', -1. )
+ CALL lbc_lnk( 'ldftra', zw2d, 'V', -1.0_wp )
CALL iom_put( "veiv_heattr", zztmp * zw2d ) ! heat transport in j-direction
CALL iom_put( "veiv_heattr", zztmp * zw3d ) ! heat transport in j-direction
@@ -875,11 +876,11 @@
zw2d(:,:) = 0._wp
zw3d(:,:,:) = 0._wp
- DO_3D_00_00( 1, jpkm1 )
+ 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 lbc_lnk( 'ldftra', zw2d, 'U', -1. )
- CALL lbc_lnk( 'ldftra', zw3d, 'U', -1. )
+ CALL lbc_lnk( 'ldftra', zw2d, 'U', -1.0_wp )
+ CALL lbc_lnk( 'ldftra', zw3d, 'U', -1.0_wp )
CALL iom_put( "ueiv_salttr", zztmp * zw2d ) ! salt transport in i-direction
CALL iom_put( "ueiv_salttr3d", zztmp * zw3d ) ! salt transport in i-direction
@@ -887,10 +888,10 @@
zw2d(:,:) = 0._wp
zw3d(:,:,:) = 0._wp
- DO_3D_00_00( 1, jpkm1 )
+ 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 lbc_lnk( 'ldftra', zw2d, 'V', -1. )
+ CALL lbc_lnk( 'ldftra', zw2d, 'V', -1.0_wp )
CALL iom_put( "veiv_salttr", zztmp * zw2d ) ! salt transport in j-direction
CALL iom_put( "veiv_salttr", zztmp * zw3d ) ! salt transport in j-direction
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/OBS/ddatetoymdhms.h90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/OBS/ddatetoymdhms.h90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/OBS/ddatetoymdhms.h90 (revision 13540)
@@ -21,5 +21,5 @@
!! * Arguments
- real(wp), INTENT(IN) :: ddate
+ real(dp), INTENT(IN) :: ddate
INTEGER, INTENT(OUT) :: kyea
INTEGER, INTENT(OUT) :: kmon
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/OBS/diaobs.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/OBS/diaobs.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/OBS/diaobs.F90 (revision 13540)
@@ -94,5 +94,5 @@
TYPE(obs_prof), PUBLIC, POINTER, DIMENSION(:) :: profdataqc !: Profile data after quality control
- CHARACTER(len=6), PUBLIC, DIMENSION(:), ALLOCATABLE :: cobstypesprof, cobstypessurf !: Profile & surface obs types
+ CHARACTER(len=lca), PUBLIC, DIMENSION(:), ALLOCATABLE :: cobstypesprof, cobstypessurf !: Profile & surface obs types
!!----------------------------------------------------------------------
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/OBS/find_obs_proc.h90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/OBS/find_obs_proc.h90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/OBS/find_obs_proc.h90 (revision 13540)
@@ -41,5 +41,5 @@
! first and last indoor i- and j-indexes kldi, klei, kldj, klej
! exclude any obs in the bottom-left overlap region
- ! also any obs outside to whole region (defined by nlci and nlcj)
+ ! also any obs outside to whole region (defined by jpi and jpj)
! I am assuming that kobsp does not need to be the correct processor
! number
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/OBS/grt_cir_dis.h90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/OBS/grt_cir_dis.h90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/OBS/grt_cir_dis.h90 (revision 13540)
@@ -28,6 +28,12 @@
REAL(KIND=wp) :: pc2 ! cos(lat2) * sin(lon2)
+ REAL(KIND=wp) :: cosdist ! cosine of great circle distance
+
+ ! Compute cosine of great circle distance, constraining it to be between
+ ! -1 and 1 (rounding errors can take it slightly outside this range
+ cosdist = MAX( MIN( pa1 * pa2 + pb1 * pb2 + pc1 * pc2, 1.0_wp), -1.0_wp )
+
grt_cir_dis = &
- & ASIN( SQRT( 1.0 - ( pa1 * pa2 + pb1 * pb2 + pc1 * pc2 )**2 ) )
+ & ASIN( SQRT( 1.0_wp - cosdist**2.0_wp ) )
END FUNCTION grt_cir_dis
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/OBS/mpp_map.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/OBS/mpp_map.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/OBS/mpp_map.F90 (revision 13540)
@@ -11,8 +11,8 @@
!!----------------------------------------------------------------------
USE par_kind, ONLY : wp ! Precision variables
- USE par_oce , ONLY : jpi, jpj ! Ocean parameters
- USE dom_oce , ONLY : mig, mjg, nldi, nlei, nldj, nlej, nlci, nlcj, narea ! Ocean space and time domain 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
#if defined key_mpp_mpi
- USE lib_mpp, ONLY : mpi_comm_oce ! MPP library
+ USE lib_mpp , ONLY : mpi_comm_oce ! MPP library
#endif
USE in_out_manager ! I/O manager
@@ -65,5 +65,5 @@
! ! Setup local grid points
- imppmap(mig(1):mig(nlci),mjg(1):mjg(nlcj)) = narea
+ imppmap(mig(1):mig(jpi),mjg(1):mjg(jpj)) = narea
! Get global data
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/OBS/obs_grid.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/OBS/obs_grid.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/OBS/obs_grid.F90 (revision 13540)
@@ -129,5 +129,5 @@
IF ( cdgrid == 'T' ) THEN
CALL obs_grd_bruteforce( jpi, jpj, jpiglo, jpjglo, &
- & 1, nlci, 1, nlcj, &
+ & 1, jpi, 1, jpj, &
& nproc, jpnij, &
& glamt, gphit, tmask, &
@@ -136,5 +136,5 @@
ELSEIF ( cdgrid == 'U' ) THEN
CALL obs_grd_bruteforce( jpi, jpj, jpiglo, jpjglo, &
- & 1, nlci, 1, nlcj, &
+ & 1, jpi, 1, jpj, &
& nproc, jpnij, &
& glamu, gphiu, umask, &
@@ -143,5 +143,5 @@
ELSEIF ( cdgrid == 'V' ) THEN
CALL obs_grd_bruteforce( jpi, jpj, jpiglo, jpjglo, &
- & 1, nlci, 1, nlcj, &
+ & 1, jpi, 1, jpj, &
& nproc, jpnij, &
& glamv, gphiv, vmask, &
@@ -150,5 +150,5 @@
ELSEIF ( cdgrid == 'F' ) THEN
CALL obs_grd_bruteforce( jpi, jpj, jpiglo, jpjglo, &
- & 1, nlci, 1, nlcj, &
+ & 1, jpi, 1, jpj, &
& nproc, jpnij, &
& glamf, gphif, fmask, &
@@ -279,6 +279,6 @@
zmskg(:,:) = -1.e+10
! Add various grids here.
- DO jj = 1, nlcj
- DO ji = 1, nlci
+ DO jj = 1, jpj
+ DO ji = 1, jpi
zlamg(mig(ji),mjg(jj)) = glamt(ji,jj)
zphig(mig(ji),mjg(jj)) = gphit(ji,jj)
@@ -684,5 +684,7 @@
& fhistx1, fhistx2, fhisty1, fhisty2
REAL(wp) :: histtol
-
+ CHARACTER(LEN=26) :: clfmt ! writing format
+ INTEGER :: idg ! number of digits
+
IF (ln_grid_search_lookup) THEN
@@ -709,9 +711,10 @@
IF ( ln_grid_global ) THEN
- WRITE(cfname, FMT="(A,'_',A)") &
- & TRIM(cn_gridsearchfile), 'global.nc'
+ WRITE(cfname, FMT="(A,'_',A)") TRIM(cn_gridsearchfile), 'global.nc'
ELSE
- WRITE(cfname, FMT="(A,'_',I4.4,'of',I4.4,'by',I4.4,'.nc')") &
- & TRIM(cn_gridsearchfile), nproc, jpni, jpnj
+ idg = MAX( INT(LOG10(REAL(jpnij,wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9
+ ! define the following format: "(a,a,ix.x,a,ix.x,a,ix.x,a)"
+ WRITE(clfmt, "('(a,a,i', i1, '.', i1',a,i', i1, '.', i1',a,i', i1, '.', i1',a)')") idg, idg, idg, idg, idg, idg
+ WRITE(cfname, clfmt ) TRIM(cn_gridsearchfile),'_', nproc,'of', jpni,'by', jpnj,'.nc'
ENDIF
@@ -816,5 +819,5 @@
CALL obs_grd_bruteforce( jpi, jpj, jpiglo, jpjglo, &
- & 1, nlci, 1, nlcj, &
+ & 1, jpi, 1, jpj, &
& nproc, jpnij, &
& glamt, gphit, tmask, &
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/OBS/obs_oper.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/OBS/obs_oper.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/OBS/obs_oper.F90 (revision 13540)
@@ -189,5 +189,5 @@
! Initialize daily mean for first timestep of the day
IF ( idayend == 1 .OR. kt == 0 ) THEN
- DO_3D_11_11( 1, jpk )
+ DO_3D( 1, 1, 1, 1, 1, jpk )
prodatqc%vdmean(ji,jj,jk,1) = 0.0
prodatqc%vdmean(ji,jj,jk,2) = 0.0
@@ -195,5 +195,5 @@
ENDIF
- DO_3D_11_11( 1, jpk )
+ DO_3D( 1, 1, 1, 1, 1, jpk )
! Increment field 1 for computing daily mean
prodatqc%vdmean(ji,jj,jk,1) = prodatqc%vdmean(ji,jj,jk,1) &
@@ -209,5 +209,5 @@
IF (lwp) WRITE(numout,*) 'Calculating prodatqc%vdmean on time-step: ',kt
CALL FLUSH(numout)
- DO_3D_11_11( 1, jpk )
+ DO_3D( 1, 1, 1, 1, 1, jpk )
prodatqc%vdmean(ji,jj,jk,1) = prodatqc%vdmean(ji,jj,jk,1) &
& * zdaystp
@@ -750,5 +750,5 @@
! Initialize night-time mean for first timestep of the day
IF ( idayend == 1 .OR. kt == 0 ) THEN
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
surfdataqc%vdmean(ji,jj) = 0.0
zmeanday(ji,jj) = 0.0
@@ -761,5 +761,5 @@
imask_night(:,:) = INT( zouttmp(:,:) )
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
! Increment the temperature field for computing night mean and counter
surfdataqc%vdmean(ji,jj) = surfdataqc%vdmean(ji,jj) &
@@ -773,5 +773,5 @@
IF ( idayend == 0 ) THEN
IF (lwp) WRITE(numout,*) 'Calculating surfdataqc%vdmean on time-step: ',kt
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
! Test if "no night" point
IF ( icount_night(ji,jj) > 0 ) THEN
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/OBS/obs_read_altbias.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/OBS/obs_read_altbias.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/OBS/obs_read_altbias.F90 (revision 13540)
@@ -125,5 +125,5 @@
! Get the Alt bias data
- CALL iom_get( numaltbias, jpdom_data, 'altbias', z_altbias(:,:), 1 )
+ CALL iom_get( numaltbias, jpdom_global, 'altbias', z_altbias(:,:) )
! Close the file
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/OBS/obs_read_prof.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/OBS/obs_read_prof.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/OBS/obs_read_prof.F90 (revision 13540)
@@ -140,7 +140,7 @@
& zphi, &
& zlam
- REAL(wp), DIMENSION(:), ALLOCATABLE :: &
+ REAL(dp), DIMENSION(:), ALLOCATABLE :: &
& zdat
- REAL(wp), DIMENSION(knumfiles) :: &
+ REAL(dp), DIMENSION(knumfiles) :: &
& djulini, &
& djulend
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/OBS/obs_read_surf.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/OBS/obs_read_surf.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/OBS/obs_read_surf.F90 (revision 13540)
@@ -112,7 +112,7 @@
& zphi, &
& zlam
- REAL(wp), DIMENSION(:), ALLOCATABLE :: &
+ REAL(dp), DIMENSION(:), ALLOCATABLE :: &
& zdat
- REAL(wp), DIMENSION(knumfiles) :: &
+ REAL(dp), DIMENSION(knumfiles) :: &
& djulini, &
& djulend
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/OBS/obs_readmdt.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/OBS/obs_readmdt.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/OBS/obs_readmdt.F90 (revision 13540)
@@ -90,5 +90,5 @@
CALL iom_open( mdtname, nummdt ) ! Open the file
! ! Get the MDT data
- CALL iom_get ( nummdt, jpdom_data, 'sossheig', z_mdt(:,:), 1 )
+ CALL iom_get ( nummdt, jpdom_global, 'sossheig', z_mdt(:,:) )
CALL iom_close(nummdt) ! Close the file
@@ -215,5 +215,5 @@
zeta2 = 0.0
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
zdxdy = e1e2t(ji,jj) * zpromsk(ji,jj)
zarea = zarea + zdxdy
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/OBS/obs_sstbias.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/OBS/obs_sstbias.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/OBS/obs_sstbias.F90 (revision 13540)
@@ -139,5 +139,5 @@
cl_bias_files(jtype) )
! Get the SST bias data
- CALL iom_get( numsstbias, jpdom_data, 'tn', z_sstbias_2d(:,:), 1 )
+ CALL iom_get( numsstbias, jpdom_global, 'tn', z_sstbias_2d(:,:), 1 )
z_sstbias(:,:,jtype) = z_sstbias_2d(:,:)
! Close the file
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/OBS/obs_write.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/OBS/obs_write.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/OBS/obs_write.F90 (revision 13540)
@@ -86,4 +86,6 @@
CHARACTER(LEN=40) :: clfname
CHARACTER(LEN=10) :: clfiletype
+ CHARACTER(LEN=12) :: clfmt ! writing format
+ INTEGER :: idg ! number of digits
INTEGER :: ilevel
INTEGER :: jvar
@@ -181,5 +183,7 @@
fbdata%caddname(1) = 'Hx'
- WRITE(clfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(clfiletype), nproc
+ idg = MAX( INT(LOG10(REAL(jpnij,wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9
+ WRITE(clfmt, "('(a,a,i', i1, '.', i1, ',a)')") idg, idg ! '(a,a,ix.x,a)'
+ WRITE(clfname,clfmt) TRIM(clfiletype), '_fdbk_', nproc, '.nc'
IF(lwp) THEN
@@ -326,4 +330,6 @@
CHARACTER(LEN=10) :: clfiletype
CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_wri_surf'
+ CHARACTER(LEN=12) :: clfmt ! writing format
+ INTEGER :: idg ! number of digits
INTEGER :: jo
INTEGER :: ja
@@ -453,5 +459,7 @@
fbdata%caddname(1) = 'Hx'
- WRITE(clfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(clfiletype), nproc
+ idg = MAX( INT(LOG10(REAL(jpnij,wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9
+ WRITE(clfmt, "('(a,a,i', i1, '.', i1, ',a)')") idg, idg ! '(a,a,ix.x,a)'
+ WRITE(clfname,clfmt) TRIM(clfiletype), '_fdbk_', nproc, '.nc'
IF(lwp) THEN
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/OBS/obsinter_z1d.h90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/OBS/obsinter_z1d.h90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/OBS/obsinter_z1d.h90 (revision 13540)
@@ -62,29 +62,33 @@
z1dm = ( pdep(kkco(jdep)) - pobsdep(jdep) )
z1dp = ( pobsdep(jdep) - pdep(kkco(jdep)-1) )
- IF ( pobsmask(kkco(jdep)) == 0.0_wp ) z1dp = 0.0_wp
+
+ ! If kkco(jdep) is masked then set pobs(jdep) to the lowest value located above bathymetry
+ IF ( pobsmask(kkco(jdep)) == 0.0_wp ) THEN
+ pobs(jdep) = pobsk(kkco(jdep)-1)
+ ELSE
+ zsum = z1dm + z1dp
- zsum = z1dm + z1dp
-
- IF ( k1dint == 0 ) THEN
+ IF ( k1dint == 0 ) THEN
- !-----------------------------------------------------------------
- ! Linear interpolation
- !-----------------------------------------------------------------
- pobs(jdep) = ( z1dm * pobsk(kkco(jdep)-1) &
- & + z1dp * pobsk(kkco(jdep) ) ) / zsum
+ !-----------------------------------------------------------------
+ ! Linear interpolation
+ !-----------------------------------------------------------------
+ pobs(jdep) = ( z1dm * pobsk(kkco(jdep)-1) &
+ & + z1dp * pobsk(kkco(jdep) ) ) / zsum
- ELSEIF ( k1dint == 1 ) THEN
+ ELSEIF ( k1dint == 1 ) THEN
- !-----------------------------------------------------------------
- ! Cubic spline interpolation
- !-----------------------------------------------------------------
- zsum2 = zsum * zsum
- pobs(jdep) = ( z1dm * pobsk (kkco(jdep)-1) &
- & + z1dp * pobsk (kkco(jdep) ) &
- & + ( z1dm * ( z1dm * z1dm - zsum2 ) * pobs2k(kkco(jdep)-1) &
- & + z1dp * ( z1dp * z1dp - zsum2 ) * pobs2k(kkco(jdep) ) &
- & ) / 6.0_wp &
- & ) / zsum
+ !-----------------------------------------------------------------
+ ! Cubic spline interpolation
+ !-----------------------------------------------------------------
+ zsum2 = zsum * zsum
+ pobs(jdep) = ( z1dm * pobsk (kkco(jdep)-1) &
+ & + z1dp * pobsk (kkco(jdep) ) &
+ & + ( z1dm * ( z1dm * z1dm - zsum2 ) * pobs2k(kkco(jdep)-1) &
+ & + z1dp * ( z1dp * z1dp - zsum2 ) * pobs2k(kkco(jdep) ) &
+ & ) / 6.0_wp &
+ & ) / zsum
+ ENDIF
ENDIF
END DO
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/cpl_oasis3.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/cpl_oasis3.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/cpl_oasis3.F90 (revision 13540)
@@ -69,7 +69,4 @@
INTEGER, PUBLIC, PARAMETER :: nmaxcat=5 ! Maximum number of coupling fields
INTEGER, PUBLIC, PARAMETER :: nmaxcpl=5 ! Maximum number of coupling fields
- LOGICAL, PARAMETER :: ltmp_wapatch = .TRUE. ! patch to restore wraparound rows in cpl_send, cpl_rcv, cpl_define
- INTEGER :: nldi_save, nlei_save
- INTEGER :: nldj_save, nlej_save
TYPE, PUBLIC :: FLD_CPL !: Type for coupling field information
@@ -148,13 +145,4 @@
!!--------------------------------------------------------------------
- ! patch to restore wraparound rows in cpl_send, cpl_rcv, cpl_define
- IF( ltmp_wapatch ) THEN
- nldi_save = nldi ; nlei_save = nlei
- nldj_save = nldj ; nlej_save = nlej
- IF( nimpp == 1 ) nldi = 1
- IF( nimpp + jpi - 1 == jpiglo ) nlei = jpi
- IF( njmpp == 1 ) nldj = 1
- IF( njmpp + jpj - 1 == jpjglo ) nlej = jpj
- ENDIF
IF(lwp) WRITE(numout,*)
IF(lwp) WRITE(numout,*) 'cpl_define : initialization in coupled ocean/atmosphere case'
@@ -177,16 +165,14 @@
ENDIF
!
- ! ... Define the shape for the area that excludes the halo
- ! For serial configuration (key_mpp_mpi not being active)
- ! nl* is set to the global values 1 and jp*glo.
+ ! ... Define the shape for the area that excludes the halo as we don't want them to be "seen" by oasis
!
ishape(1) = 1
- ishape(2) = nlei-nldi+1
+ ishape(2) = Ni_0
ishape(3) = 1
- ishape(4) = nlej-nldj+1
+ ishape(4) = Nj_0
!
! ... Allocate memory for data exchange
!
- ALLOCATE(exfld(nlei-nldi+1, nlej-nldj+1), stat = nerror)
+ ALLOCATE(exfld(Ni_0, Nj_0), stat = nerror) ! allocate only inner domain (without halos)
IF( nerror > 0 ) THEN
CALL oasis_abort ( ncomp_id, 'cpl_define', 'Failure in allocating exfld') ; RETURN
@@ -194,21 +180,21 @@
!
! -----------------------------------------------------------------
- ! ... Define the partition
+ ! ... Define the partition, excluding halos as we don't want them to be "seen" by oasis
! -----------------------------------------------------------------
- paral(1) = 2 ! box partitioning
- paral(2) = jpiglo * (nldj-1+njmpp-1) + (nldi-1+nimpp-1) ! NEMO lower left corner global offset
- paral(3) = nlei-nldi+1 ! local extent in i
- paral(4) = nlej-nldj+1 ! local extent in j
- paral(5) = jpiglo ! global extent in x
+ 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
IF( sn_cfctl%l_oasout ) THEN
WRITE(numout,*) ' multiexchg: paral (1:5)', paral
- WRITE(numout,*) ' multiexchg: jpi, jpj =', jpi, jpj
- WRITE(numout,*) ' multiexchg: nldi, nlei, nimpp =', nldi, nlei, nimpp
- WRITE(numout,*) ' multiexchg: nldj, nlej, njmpp =', nldj, nlej, njmpp
+ WRITE(numout,*) ' multiexchg: Ni_0, Nj_0 =', Ni_0, Nj_0
+ WRITE(numout,*) ' multiexchg: Nis0, Nie0, nimpp =', Nis0, Nie0, nimpp
+ WRITE(numout,*) ' multiexchg: Njs0, Nje0, njmpp =', Njs0, Nje0, njmpp
ENDIF
- CALL oasis_def_partition ( id_part, paral, nerror, jpiglo*jpjglo )
+ CALL oasis_def_partition ( id_part, paral, nerror, Ni0glo*Nj0glo ) ! global number of points, excluding halos
!
! ... Announce send variables.
@@ -316,8 +302,4 @@
#endif
!
- IF( ltmp_wapatch ) THEN
- nldi = nldi_save ; nlei = nlei_save
- nldj = nldj_save ; nlej = nlej_save
- ENDIF
END SUBROUTINE cpl_define
@@ -337,13 +319,4 @@
INTEGER :: jc,jm ! local loop index
!!--------------------------------------------------------------------
- ! patch to restore wraparound rows in cpl_send, cpl_rcv, cpl_define
- IF( ltmp_wapatch ) THEN
- nldi_save = nldi ; nlei_save = nlei
- nldj_save = nldj ; nlej_save = nlej
- IF( nimpp == 1 ) nldi = 1
- IF( nimpp + jpi - 1 == jpiglo ) nlei = jpi
- IF( njmpp == 1 ) nldj = 1
- IF( njmpp + jpj - 1 == jpjglo ) nlej = jpj
- ENDIF
!
! snd data to OASIS3
@@ -352,6 +325,6 @@
DO jm = 1, ssnd(kid)%ncplmodel
- IF( ssnd(kid)%nid(jc,jm) /= -1 ) THEN
- CALL oasis_put ( ssnd(kid)%nid(jc,jm), kstep, pdata(nldi:nlei, nldj:nlej,jc), kinfo )
+ IF( ssnd(kid)%nid(jc,jm) /= -1 ) THEN ! exclude halos from data sent to oasis
+ CALL oasis_put ( ssnd(kid)%nid(jc,jm), kstep, pdata(Nis0:Nie0, Njs0:Nje0,jc), kinfo )
IF ( sn_cfctl%l_oasout ) THEN
@@ -363,7 +336,7 @@
WRITE(numout,*) 'oasis_put: kstep ', kstep
WRITE(numout,*) 'oasis_put: info ', kinfo
- WRITE(numout,*) ' - Minimum value is ', MINVAL(pdata(nldi:nlei,nldj:nlej,jc))
- WRITE(numout,*) ' - Maximum value is ', MAXVAL(pdata(nldi:nlei,nldj:nlej,jc))
- WRITE(numout,*) ' - Sum value is ', SUM(pdata(nldi:nlei,nldj:nlej,jc))
+ WRITE(numout,*) ' - Minimum value is ', MINVAL(pdata(Nis0:Nie0,Njs0:Nje0,jc))
+ WRITE(numout,*) ' - Maximum value is ', MAXVAL(pdata(Nis0:Nie0,Njs0:Nje0,jc))
+ WRITE(numout,*) ' - Sum value is ', SUM(pdata(Nis0:Nie0,Njs0:Nje0,jc))
WRITE(numout,*) '****************'
ENDIF
@@ -374,8 +347,4 @@
ENDDO
ENDDO
- IF( ltmp_wapatch ) THEN
- nldi = nldi_save ; nlei = nlei_save
- nldj = nldj_save ; nlej = nlej_save
- ENDIF
!
END SUBROUTINE cpl_snd
@@ -396,11 +365,6 @@
!!
INTEGER :: jc,jm ! local loop index
- LOGICAL :: llaction, llfisrt
+ LOGICAL :: llaction, ll_1st
!!--------------------------------------------------------------------
- ! patch to restore wraparound rows in cpl_send, cpl_rcv, cpl_define
- IF( ltmp_wapatch ) THEN
- nldi_save = nldi ; nlei_save = nlei
- nldj_save = nldj ; nlej_save = nlej
- ENDIF
!
! receive local data from OASIS3 on every process
@@ -409,11 +373,5 @@
!
DO jc = 1, srcv(kid)%nct
- IF( ltmp_wapatch ) THEN
- IF( nimpp == 1 ) nldi = 1
- IF( nimpp + jpi - 1 == jpiglo ) nlei = jpi
- IF( njmpp == 1 ) nldj = 1
- IF( njmpp + jpj - 1 == jpjglo ) nlej = jpj
- ENDIF
- llfisrt = .TRUE.
+ ll_1st = .TRUE.
DO jm = 1, srcv(kid)%ncplmodel
@@ -426,14 +384,16 @@
& kinfo == OASIS_RecvOut .OR. kinfo == OASIS_FromRestOut
- IF ( sn_cfctl%l_oasout ) WRITE(numout,*) "llaction, kinfo, kstep, ivarid: " , llaction, kinfo, kstep, srcv(kid)%nid(jc,jm)
+ IF ( sn_cfctl%l_oasout ) &
+ & WRITE(numout,*) "llaction, kinfo, kstep, ivarid: " , llaction, kinfo, kstep, srcv(kid)%nid(jc,jm)
- IF( llaction ) THEN
+ IF( llaction ) THEN ! data received from oasis do not include halos
kinfo = OASIS_Rcv
- IF( llfisrt ) THEN
- pdata(nldi:nlei,nldj:nlej,jc) = exfld(:,:) * pmask(nldi:nlei,nldj:nlej,jm)
- llfisrt = .FALSE.
+ IF( ll_1st ) THEN
+ pdata(Nis0:Nie0,Njs0:Nje0,jc) = exfld(:,:) * pmask(Nis0:Nie0,Njs0:Nje0,jm)
+ ll_1st = .FALSE.
ELSE
- pdata(nldi:nlei,nldj:nlej,jc) = pdata(nldi:nlei,nldj:nlej,jc) + exfld(:,:) * pmask(nldi:nlei,nldj:nlej,jm)
+ pdata(Nis0:Nie0,Njs0:Nje0,jc) = pdata(Nis0:Nie0,Njs0:Nje0,jc) &
+ & + exfld(:,:) * pmask(Nis0:Nie0,Njs0:Nje0,jm)
ENDIF
@@ -444,7 +404,7 @@
WRITE(numout,*) 'oasis_get: kstep', kstep
WRITE(numout,*) 'oasis_get: info ', kinfo
- WRITE(numout,*) ' - Minimum value is ', MINVAL(pdata(:,:,jc))
- WRITE(numout,*) ' - Maximum value is ', MAXVAL(pdata(:,:,jc))
- WRITE(numout,*) ' - Sum value is ', SUM(pdata(:,:,jc))
+ WRITE(numout,*) ' - Minimum value is ', MINVAL(pdata(Nis0:Nie0,Njs0:Nje0,jc))
+ WRITE(numout,*) ' - Maximum value is ', MAXVAL(pdata(Nis0:Nie0,Njs0:Nje0,jc))
+ WRITE(numout,*) ' - Sum value is ', SUM(pdata(Nis0:Nie0,Njs0:Nje0,jc))
WRITE(numout,*) '****************'
ENDIF
@@ -456,11 +416,6 @@
ENDDO
- IF( ltmp_wapatch ) THEN
- nldi = nldi_save ; nlei = nlei_save
- nldj = nldj_save ; nlej = nlej_save
- ENDIF
- !--- Fill the overlap areas and extra hallows (mpp)
- !--- check periodicity conditions (all cases)
- IF( .not. llfisrt ) THEN
+ !--- 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 )
ENDIF
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/cyclone.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/cyclone.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/cyclone.F90 (revision 13540)
@@ -147,5 +147,5 @@
zb = 2.
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
! calc distance between TC center and any point following great circle
@@ -208,5 +208,5 @@
ENDIF
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
zzrglam = rad * glamt(ji,jj) - zrlon
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/fldread.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/fldread.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/fldread.F90 (revision 13540)
@@ -53,5 +53,5 @@
LOGICAL :: ln_tint ! time interpolation or not (T/F)
LOGICAL :: ln_clim ! climatology or not (T/F)
- CHARACTER(len = 8) :: cltype ! type of data file 'daily', 'monthly' or yearly'
+ CHARACTER(len = 8) :: clftyp ! type of data file 'daily', 'monthly' or yearly'
CHARACTER(len = 256) :: wname ! generic name of a NetCDF weights file to be used, blank if not
CHARACTER(len = 34) :: vcomp ! symbolic component name if a vector that needs rotation
@@ -69,11 +69,14 @@
LOGICAL :: ln_tint ! time interpolation or not (T/F)
LOGICAL :: ln_clim ! climatology or not (T/F)
- CHARACTER(len = 8) :: cltype ! type of data file 'daily', 'monthly' or yearly'
+ CHARACTER(len = 8) :: clftyp ! type of data file 'daily', 'monthly' or yearly'
+ CHARACTER(len = 1) :: cltype ! nature of grid-points: T, U, V...
+ REAL(wp) :: zsgn ! -1. the sign change across the north fold, = 1. otherwise
INTEGER :: num ! iom id of the jpfld files to be read
- INTEGER , DIMENSION(2) :: nrec_b ! before record (1: index, 2: second since Jan. 1st 00h of nit000 year)
- INTEGER , DIMENSION(2) :: nrec_a ! after record (1: index, 2: second since Jan. 1st 00h of nit000 year)
- INTEGER , ALLOCATABLE, DIMENSION(: ) :: nrecsec !
- REAL(wp), ALLOCATABLE, DIMENSION(:,:,: ) :: fnow ! input fields interpolated to now time step
- REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: fdta ! 2 consecutive record of input fields
+ INTEGER , DIMENSION(2,2) :: nrec ! before/after record (1: index, 2: second since Jan. 1st 00h of yr nit000)
+ INTEGER :: nbb ! index of before values
+ INTEGER :: naa ! index of after values
+ INTEGER , ALLOCATABLE, DIMENSION(:) :: nrecsec !
+ REAL(wp), POINTER, DIMENSION(:,:,: ) :: fnow ! input fields interpolated to now time step
+ REAL(wp), POINTER, DIMENSION(:,:,:,:) :: fdta ! 2 consecutive record of input fields
CHARACTER(len = 256) :: wgtname ! current name of the NetCDF weight file acting as a key
! ! into the WGTLIST structure
@@ -127,4 +130,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -156,4 +160,5 @@
INTEGER :: jf ! dummy indices
INTEGER :: isecsbc ! number of seconds between Jan. 1st 00h of nit000 year and the middle of sbc time step
+ INTEGER :: ibb, iaa ! shorter name for sd(jf)%nbb and sd(jf)%naa
LOGICAL :: ll_firstcall ! true if this is the first call to fld_read for this set of fields
REAL(wp) :: zt_offset ! local time offset variable
@@ -203,4 +208,6 @@
IF( TRIM(sd(jf)%clrootname) == 'NOT USED' ) CYCLE
!
+ ibb = sd(jf)%nbb ; iaa = sd(jf)%naa
+ !
IF( sd(jf)%ln_tint ) THEN ! temporal interpolation
IF(lwp .AND. kt - nit000 <= 100 ) THEN
@@ -208,11 +215,11 @@
& "', records b/a: ', i6.4, '/', i6.4, ' (days ', f9.4,'/', f9.4, ')')"
WRITE(numout, clfmt) TRIM( sd(jf)%clvar ), kt, REAL(isecsbc,wp)/rday, nyear, nmonth, nday, &
- & sd(jf)%nrec_b(1), sd(jf)%nrec_a(1), REAL(sd(jf)%nrec_b(2),wp)/rday, REAL(sd(jf)%nrec_a(2),wp)/rday
+ & sd(jf)%nrec(1,ibb), sd(jf)%nrec(1,iaa), REAL(sd(jf)%nrec(2,ibb),wp)/rday, REAL(sd(jf)%nrec(2,iaa),wp)/rday
WRITE(numout, *) ' zt_offset is : ',zt_offset
ENDIF
! temporal interpolation weights
- ztinta = REAL( isecsbc - sd(jf)%nrec_b(2), wp ) / REAL( sd(jf)%nrec_a(2) - sd(jf)%nrec_b(2), wp )
+ ztinta = REAL( isecsbc - sd(jf)%nrec(2,ibb), wp ) / REAL( sd(jf)%nrec(2,iaa) - sd(jf)%nrec(2,ibb), wp )
ztintb = 1. - ztinta
- sd(jf)%fnow(:,:,:) = ztintb * sd(jf)%fdta(:,:,:,1) + ztinta * sd(jf)%fdta(:,:,:,2)
+ sd(jf)%fnow(:,:,:) = ztintb * sd(jf)%fdta(:,:,:,ibb) + ztinta * sd(jf)%fdta(:,:,:,iaa)
ELSE ! nothing to do...
IF(lwp .AND. kt - nit000 <= 100 ) THEN
@@ -220,5 +227,5 @@
& "', record: ', i6.4, ' (days ', f9.4, ' <-> ', f9.4, ')')"
WRITE(numout, clfmt) TRIM(sd(jf)%clvar), kt, REAL(isecsbc,wp)/rday, nyear, nmonth, nday, &
- & sd(jf)%nrec_a(1), REAL(sd(jf)%nrec_b(2),wp)/rday, REAL(sd(jf)%nrec_a(2),wp)/rday
+ & sd(jf)%nrec(1,iaa), REAL(sd(jf)%nrec(2,ibb),wp)/rday, REAL(sd(jf)%nrec(2,iaa),wp)/rday
ENDIF
ENDIF
@@ -250,5 +257,5 @@
!
CALL fld_clopn( sdjf )
- sdjf%nrec_a(:) = (/ 1, nflag /) ! default definition to force flp_update to read the file.
+ sdjf%nrec(:,sdjf%naa) = (/ 1, nflag /) ! default definition to force flp_update to read the file.
!
END SUBROUTINE fld_init
@@ -261,8 +268,8 @@
!! ** Purpose : Compute
!! if sdjf%ln_tint = .TRUE.
- !! nrec_a: record number and its time (nrec_b is obtained from nrec_a when swapping)
+ !! nrec(:,iaa): record number and its time (nrec(:,ibb) is obtained from nrec(:,iaa) when swapping)
!! if sdjf%ln_tint = .FALSE.
- !! nrec_a(1): record number
- !! nrec_b(2) and nrec_a(2): time of the beginning and end of the record
+ !! nrec(1,iaa): record number
+ !! nrec(2,ibb) and nrec(2,iaa): time of the beginning and end of the record
!!----------------------------------------------------------------------
INTEGER , INTENT(in ) :: ksecsbc !
@@ -270,11 +277,13 @@
INTEGER , OPTIONAL, INTENT(in ) :: Kmm ! ocean time level index
!
- INTEGER :: ja ! end of this record (in seconds)
- !!----------------------------------------------------------------------
- !
- IF( ksecsbc > sdjf%nrec_a(2) ) THEN ! --> we need to update after data
+ INTEGER :: ja ! end of this record (in seconds)
+ INTEGER :: ibb, iaa ! shorter name for sdjf%nbb and sdjf%naa
+ !!----------------------------------------------------------------------
+ ibb = sdjf%nbb ; iaa = sdjf%naa
+ !
+ IF( ksecsbc > sdjf%nrec(2,iaa) ) THEN ! --> we need to update after data
- ! find where is the new after record... (it is not necessary sdjf%nrec_a(1)+1 )
- ja = sdjf%nrec_a(1)
+ ! find where is the new after record... (it is not necessary sdjf%nrec(1,iaa)+1 )
+ ja = sdjf%nrec(1,iaa)
DO WHILE ( ksecsbc >= sdjf%nrecsec(ja) .AND. ja < sdjf%nreclast ) ! Warning: make sure ja <= sdjf%nreclast in this test
ja = ja + 1
@@ -283,8 +292,8 @@
! 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_b(2) will still be the closest value located just before ksecsbc
- IF( sdjf%ln_tint .AND. ( ja > sdjf%nrec_a(1) + 1 .OR. sdjf%nrec_a(2) == nflag ) ) THEN
- sdjf%nrec_a(:) = (/ ja-1, sdjf%nrecsec(ja-1) /) ! update nrec_a with before information
- CALL fld_get( sdjf, Kmm ) ! read after data that will be used as before data
+ ! so, after the swap, sdjf%nrec(2,ibb) will still be the closest value located just before ksecsbc
+ IF( sdjf%ln_tint .AND. ( ja > sdjf%nrec(1,iaa) + 1 .OR. sdjf%nrec(2,iaa) == nflag ) ) THEN
+ sdjf%nrec(:,iaa) = (/ ja-1, sdjf%nrecsec(ja-1) /) ! update nrec(:,iaa) with before information
+ CALL fld_get( sdjf, Kmm ) ! read after data that will be used as before data
ENDIF
@@ -309,7 +318,7 @@
! if ln_tint and if after is not the first record, we must (potentially again) update after data before the swap
IF( sdjf%ln_tint .AND. ja > 1 ) THEN
- IF( sdjf%nrecsec(0) /= nflag ) THEN ! no trick used: after file is not the current file
- sdjf%nrec_a(:) = (/ ja-1, sdjf%nrecsec(ja-1) /) ! update nrec_a with before information
- CALL fld_get( sdjf, Kmm ) ! read after data that will be used as before data
+ IF( sdjf%nrecsec(0) /= nflag ) THEN ! no trick used: after file is not the current file
+ sdjf%nrec(:,iaa) = (/ ja-1, sdjf%nrecsec(ja-1) /) ! update nrec(:,iaa) with before information
+ CALL fld_get( sdjf, Kmm ) ! read after data that will be used as before data
ENDIF
ENDIF
@@ -317,16 +326,14 @@
ENDIF
- IF( sdjf%ln_tint ) THEN
- ! Swap data
- sdjf%nrec_b(:) = sdjf%nrec_a(:) ! swap before record informations
- sdjf%rotn(1) = sdjf%rotn(2) ! swap before rotate informations
- sdjf%fdta(:,:,:,1) = sdjf%fdta(:,:,:,2) ! swap before record field
- ELSE
- sdjf%nrec_b(:) = (/ ja-1, sdjf%nrecsec(ja-1) /) ! only for print
+ IF( sdjf%ln_tint ) THEN ! Swap data
+ sdjf%nbb = sdjf%naa ! swap indices
+ sdjf%naa = 3 - sdjf%naa ! = 2(1) if naa == 1(2)
+ ELSE ! No swap
+ sdjf%nrec(:,ibb) = (/ ja-1, sdjf%nrecsec(ja-1) /) ! only for print
ENDIF
! read new after data
- sdjf%nrec_a(:) = (/ ja, sdjf%nrecsec(ja) /) ! update nrec_a as it is used by fld_get
- CALL fld_get( sdjf, Kmm ) ! read after data (with nrec_a informations)
+ sdjf%nrec(:,sdjf%naa) = (/ ja, sdjf%nrecsec(ja) /) ! update nrec(:,naa) as it is used by fld_get
+ CALL fld_get( sdjf, Kmm ) ! read after data (with nrec(:,naa) informations)
ENDIF
@@ -345,70 +352,43 @@
!
INTEGER :: ipk ! number of vertical levels of sdjf%fdta ( 2D: ipk=1 ; 3D: ipk=jpk )
+ INTEGER :: iaa ! shorter name for sdjf%naa
INTEGER :: iw ! index into wgts array
- INTEGER :: ipdom ! index of the domain
INTEGER :: idvar ! variable ID
INTEGER :: idmspc ! number of spatial dimensions
LOGICAL :: lmoor ! C1D case: point data
- !!---------------------------------------------------------------------
- !
- ipk = SIZE( sdjf%fnow, 3 )
- !
- IF( ASSOCIATED(sdjf%imap) ) THEN
- IF( sdjf%ln_tint ) THEN ; CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fdta(:,:,:,2), sdjf%nrec_a(1), &
- & sdjf%imap, sdjf%igrd, sdjf%ibdy, sdjf%ltotvel, sdjf%lzint, Kmm )
- ELSE ; CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fnow(:,:,: ), sdjf%nrec_a(1), &
- & sdjf%imap, sdjf%igrd, sdjf%ibdy, sdjf%ltotvel, sdjf%lzint, Kmm )
- ENDIF
- ELSE IF( LEN(TRIM(sdjf%wgtname)) > 0 ) THEN
+ REAL(wp), DIMENSION(:,:,:), POINTER :: dta_alias ! short cut
+ !!---------------------------------------------------------------------
+ iaa = sdjf%naa
+ !
+ IF( sdjf%ln_tint ) THEN ; dta_alias => sdjf%fdta(:,:,:,iaa)
+ ELSE ; dta_alias => sdjf%fnow(:,:,: )
+ ENDIF
+ ipk = SIZE( dta_alias, 3 )
+ !
+ IF( ASSOCIATED(sdjf%imap) ) THEN ! BDY case
+ CALL fld_map( sdjf%num, sdjf%clvar, dta_alias(:,:,:), sdjf%nrec(1,iaa), &
+ & sdjf%imap, sdjf%igrd, sdjf%ibdy, sdjf%ltotvel, sdjf%lzint, Kmm )
+ ELSE IF( LEN(TRIM(sdjf%wgtname)) > 0 ) THEN ! On-the-fly interpolation
CALL wgt_list( sdjf, iw )
- IF( sdjf%ln_tint ) THEN ; CALL fld_interp( sdjf%num, sdjf%clvar, iw, ipk, sdjf%fdta(:,:,:,2), &
- & sdjf%nrec_a(1), sdjf%lsmname )
- ELSE ; CALL fld_interp( sdjf%num, sdjf%clvar, iw, ipk, sdjf%fnow(:,:,: ), &
- & sdjf%nrec_a(1), sdjf%lsmname )
- ENDIF
- ELSE
- IF( SIZE(sdjf%fnow, 1) == jpi ) THEN ; ipdom = jpdom_data
- ELSE ; ipdom = jpdom_unknown
- ENDIF
+ CALL fld_interp( sdjf%num, sdjf%clvar, iw, ipk, dta_alias(:,:,:), sdjf%nrec(1,iaa), sdjf%lsmname )
+ CALL lbc_lnk( 'fldread', dta_alias(:,:,:), sdjf%cltype, sdjf%zsgn, kfillmode = jpfillcopy )
+ ELSE ! default case
! C1D case: If product of spatial dimensions == ipk, then x,y are of
! size 1 (point/mooring data): this must be read onto the central grid point
idvar = iom_varid( sdjf%num, sdjf%clvar )
idmspc = iom_file ( sdjf%num )%ndims( idvar )
- IF( iom_file( sdjf%num )%luld( idvar ) ) idmspc = idmspc - 1
- lmoor = ( idmspc == 0 .OR. PRODUCT( iom_file( sdjf%num )%dimsz( 1:MAX(idmspc,1) ,idvar ) ) == ipk )
- !
- SELECT CASE( ipk )
- CASE(1)
- IF( lk_c1d .AND. lmoor ) THEN
- IF( sdjf%ln_tint ) THEN
- CALL iom_get( sdjf%num, sdjf%clvar, sdjf%fdta(2,2,1,2), sdjf%nrec_a(1) )
- CALL lbc_lnk( 'fldread', sdjf%fdta(:,:,1,2),'Z',1. )
- ELSE
- CALL iom_get( sdjf%num, sdjf%clvar, sdjf%fnow(2,2,1 ), sdjf%nrec_a(1) )
- CALL lbc_lnk( 'fldread', sdjf%fnow(:,:,1 ),'Z',1. )
- ENDIF
- ELSE
- IF( sdjf%ln_tint ) THEN ; CALL iom_get( sdjf%num, ipdom, sdjf%clvar, sdjf%fdta(:,:,1,2), sdjf%nrec_a(1) )
- ELSE ; CALL iom_get( sdjf%num, ipdom, sdjf%clvar, sdjf%fnow(:,:,1 ), sdjf%nrec_a(1) )
- ENDIF
- ENDIF
- CASE DEFAULT
- IF(lk_c1d .AND. lmoor ) THEN
- IF( sdjf%ln_tint ) THEN
- CALL iom_get( sdjf%num, jpdom_unknown, sdjf%clvar, sdjf%fdta(2,2,:,2), sdjf%nrec_a(1) )
- CALL lbc_lnk( 'fldread', sdjf%fdta(:,:,:,2),'Z',1. )
- ELSE
- CALL iom_get( sdjf%num, jpdom_unknown, sdjf%clvar, sdjf%fnow(2,2,: ), sdjf%nrec_a(1) )
- CALL lbc_lnk( 'fldread', sdjf%fnow(:,:,: ),'Z',1. )
- ENDIF
- ELSE
- IF( sdjf%ln_tint ) THEN ; CALL iom_get( sdjf%num, ipdom, sdjf%clvar, sdjf%fdta(:,:,:,2), sdjf%nrec_a(1) )
- ELSE ; CALL iom_get( sdjf%num, ipdom, sdjf%clvar, sdjf%fnow(:,:,: ), sdjf%nrec_a(1) )
- ENDIF
- ENDIF
- END SELECT
- ENDIF
- !
- sdjf%rotn(2) = .false. ! vector not yet rotated
+ IF( iom_file( sdjf%num )%luld( idvar ) ) idmspc = idmspc - 1 ! id of the last spatial dimension
+ lmoor = ( idmspc == 0 .OR. PRODUCT( iom_file( sdjf%num )%dimsz( 1:MAX(idmspc,1) ,idvar ) ) == ipk )
+ !
+ IF( lk_c1d .AND. lmoor ) THEN
+ CALL iom_get( sdjf%num, jpdom_unknown, sdjf%clvar, dta_alias(2,2,:), sdjf%nrec(1,iaa) ) ! jpdom_unknown -> no lbc_lnk
+ CALL lbc_lnk( 'fldread', dta_alias(:,:,:), 'T', 1., kfillmode = jpfillcopy )
+ ELSE
+ CALL iom_get( sdjf%num, jpdom_global, sdjf%clvar, dta_alias(:,:,:), sdjf%nrec(1,iaa), &
+ & sdjf%cltype, sdjf%zsgn, kfill = jpfillcopy )
+ ENDIF
+ ENDIF
+ !
+ sdjf%rotn(iaa) = .false. ! vector not yet rotated
!
END SUBROUTINE fld_get
@@ -446,10 +426,10 @@
REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zdta_read_z ! work space local data requiring vertical interpolation
REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zdta_read_dz ! work space local data requiring vertical interpolation
- CHARACTER(LEN=1),DIMENSION(3) :: clgrid
+ CHARACTER(LEN=1),DIMENSION(3) :: cltype
LOGICAL :: lluld ! is the variable using the unlimited dimension
LOGICAL :: llzint ! local value of ldzint
!!---------------------------------------------------------------------
!
- clgrid = (/'t','u','v'/)
+ cltype = (/'t','u','v'/)
!
ipi = SIZE( pdta, 1 )
@@ -486,12 +466,12 @@
IF( ipkb /= ipk .OR. llzint ) THEN ! boundary data not on model vertical grid : vertical interpolation
!
- IF( ipk == jpk .AND. iom_varid(knum,'gdep'//clgrid(kgrd)) /= -1 .AND. iom_varid(knum,'e3'//clgrid(kgrd)) /= -1 ) THEN
+ IF( ipk == jpk .AND. iom_varid(knum,'gdep'//cltype(kgrd)) /= -1 .AND. iom_varid(knum,'e3'//cltype(kgrd)) /= -1 ) THEN
ALLOCATE( zdta_read(ipi,ipj,ipkb), zdta_read_z(ipi,ipj,ipkb), zdta_read_dz(ipi,ipj,ipkb) )
CALL fld_map_core( zz_read, kmap, zdta_read )
- CALL iom_get ( knum, jpdom_unknown, 'gdep'//clgrid(kgrd), zz_read ) ! read only once? Potential temporal evolution?
+ CALL iom_get ( knum, jpdom_unknown, 'gdep'//cltype(kgrd), zz_read ) ! read only once? Potential temporal evolution?
CALL fld_map_core( zz_read, kmap, zdta_read_z )
- CALL iom_get ( knum, jpdom_unknown, 'e3'//clgrid(kgrd), zz_read ) ! read only once? Potential temporal evolution?
+ CALL iom_get ( knum, jpdom_unknown, 'e3'//cltype(kgrd), zz_read ) ! read only once? Potential temporal evolution?
CALL fld_map_core( zz_read, kmap, zdta_read_dz )
@@ -503,6 +483,6 @@
IF( ipk /= jpk ) CALL ctl_stop( 'fld_map : this should be an impossible case...' )
WRITE(ctmp1,*) 'fld_map : vertical interpolation for bdy variable '//TRIM(cdvar)//' requires '
- IF( iom_varid(knum, 'gdep'//clgrid(kgrd)) == -1 ) CALL ctl_stop( ctmp1//'gdep'//clgrid(kgrd)//' variable' )
- IF( iom_varid(knum, 'e3'//clgrid(kgrd)) == -1 ) CALL ctl_stop( ctmp1// 'e3'//clgrid(kgrd)//' variable' )
+ IF( iom_varid(knum, 'gdep'//cltype(kgrd)) == -1 ) CALL ctl_stop( ctmp1//'gdep'//cltype(kgrd)//' variable' )
+ IF( iom_varid(knum, 'e3'//cltype(kgrd)) == -1 ) CALL ctl_stop( ctmp1// 'e3'//cltype(kgrd)//' variable' )
ENDIF
@@ -632,5 +612,5 @@
zdhalf(jk) = zdhalf(jk-1) + e3v(ji,jj,jk-1,Kmm)
zdepth(jk) = zcoef * ( zdhalf(jk ) + 0.5_wp * e3vw(ji,jj,jk,Kmm)) &
- & + (1._wp-zcoef) * ( zdepth(jk-1) + e3vw(ji,jj,jk,Kmm))
+ + (1._wp-zcoef) * ( zdepth(jk-1) + e3vw(ji,jj,jk,Kmm))
END DO
END SELECT
@@ -727,4 +707,5 @@
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
!!---------------------------------------------------------------------
!
@@ -746,14 +727,11 @@
END DO
IF( iv > 0 ) THEN ! fields ju and iv are two components which need to be rotated together
+ 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
DO jk = 1, SIZE( sd(ju)%fnow, 3 )
- IF( sd(ju)%ln_tint )THEN
- CALL rot_rep( sd(ju)%fdta(:,:,jk,jn), sd(iv)%fdta(:,:,jk,jn), 'T', 'en->i', utmp(:,:) )
- CALL rot_rep( sd(ju)%fdta(:,:,jk,jn), sd(iv)%fdta(:,:,jk,jn), 'T', 'en->j', vtmp(:,:) )
- sd(ju)%fdta(:,:,jk,jn) = utmp(:,:) ; sd(iv)%fdta(:,:,jk,jn) = vtmp(:,:)
- ELSE
- CALL rot_rep( sd(ju)%fnow(:,:,jk ), sd(iv)%fnow(:,:,jk ), 'T', 'en->i', utmp(:,:) )
- CALL rot_rep( sd(ju)%fnow(:,:,jk ), sd(iv)%fnow(:,:,jk ), 'T', 'en->j', vtmp(:,:) )
- sd(ju)%fnow(:,:,jk ) = utmp(:,:) ; sd(iv)%fnow(:,:,jk ) = vtmp(:,:)
- ENDIF
+ 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
sd(ju)%rotn(jn) = .TRUE. ! vector was rotated
@@ -801,12 +779,12 @@
! current file parameters
- IF( sdjf%cltype(1:4) == 'week' ) THEN ! find the day of the beginning of the current week
- isecwk = ksec_week( sdjf%cltype(6:8) ) ! seconds between the beginning of the week and half of current time step
- llprevmt = isecwk > nsec_month ! longer time since beginning of the current week than the current month
+ IF( sdjf%clftyp(1:4) == 'week' ) THEN ! find the day of the beginning of the current week
+ isecwk = ksec_week( sdjf%clftyp(6:8) ) ! seconds between the beginning of the week and half of current time step
+ llprevmt = isecwk > nsec_month ! longer time since beginning of the current week than the current month
llprevyr = llprevmt .AND. nmonth == 1
iyr = nyear - COUNT((/llprevyr/))
imt = nmonth - COUNT((/llprevmt/)) + 12 * COUNT((/llprevyr/))
idy = nday + nmonth_len(nmonth-1) * COUNT((/llprevmt/)) - isecwk / idaysec
- isecwk = nsec_year - isecwk ! seconds between 00h jan 1st of current year and current week beginning
+ isecwk = nsec_year - isecwk ! seconds between 00h jan 1st of current year and current week beginning
ELSE
iyr = nyear
@@ -818,16 +796,16 @@
! previous file parameters
IF( llprev ) THEN
- IF( sdjf%cltype(1:4) == 'week' ) THEN ! find the day of the beginning of previous week
- isecwk = isecwk + 7 * idaysec ! seconds between the beginning of previous week and half of the time step
- llprevmt = isecwk > nsec_month ! longer time since beginning of the previous week than the current month
+ IF( sdjf%clftyp(1:4) == 'week' ) THEN ! find the day of the beginning of previous week
+ isecwk = isecwk + 7 * idaysec ! seconds between the beginning of previous week and half of the time step
+ llprevmt = isecwk > nsec_month ! longer time since beginning of the previous week than the current month
llprevyr = llprevmt .AND. nmonth == 1
iyr = nyear - COUNT((/llprevyr/))
imt = nmonth - COUNT((/llprevmt/)) + 12 * COUNT((/llprevyr/))
idy = nday + nmonth_len(nmonth-1) * COUNT((/llprevmt/)) - isecwk / idaysec
- isecwk = nsec_year - isecwk ! seconds between 00h jan 1st of current year and previous week beginning
+ isecwk = nsec_year - isecwk ! seconds between 00h jan 1st of current year and previous week beginning
ELSE
- idy = nday - COUNT((/ sdjf%cltype == 'daily' /))
- imt = nmonth - COUNT((/ sdjf%cltype == 'monthly' .OR. idy == 0 /))
- iyr = nyear - COUNT((/ sdjf%cltype == 'yearly' .OR. imt == 0 /))
+ idy = nday - COUNT((/ sdjf%clftyp == 'daily' /))
+ imt = nmonth - COUNT((/ sdjf%clftyp == 'monthly' .OR. idy == 0 /))
+ iyr = nyear - COUNT((/ sdjf%clftyp == 'yearly' .OR. imt == 0 /))
IF( idy == 0 ) idy = nmonth_len(imt)
IF( imt == 0 ) imt = 12
@@ -838,6 +816,6 @@
! next file parameters
IF( llnext ) THEN
- IF( sdjf%cltype(1:4) == 'week' ) THEN ! find the day of the beginning of next week
- isecwk = 7 * idaysec - isecwk ! seconds between half of the time step and the beginning of next week
+ IF( sdjf%clftyp(1:4) == 'week' ) THEN ! find the day of the beginning of next week
+ isecwk = 7 * idaysec - isecwk ! seconds between half of the time step and the beginning of next week
llnextmt = isecwk > ( nmonth_len(nmonth)*idaysec - nsec_month ) ! larger than the seconds to the end of the month
llnextyr = llnextmt .AND. nmonth == 12
@@ -845,9 +823,9 @@
imt = nmonth + COUNT((/llnextmt/)) - 12 * COUNT((/llnextyr/))
idy = nday - nmonth_len(nmonth) * COUNT((/llnextmt/)) + isecwk / idaysec + 1
- isecwk = nsec_year + isecwk ! seconds between 00h jan 1st of current year and next week beginning
+ isecwk = nsec_year + isecwk ! seconds between 00h jan 1st of current year and next week beginning
ELSE
- idy = nday + COUNT((/ sdjf%cltype == 'daily' /))
- imt = nmonth + COUNT((/ sdjf%cltype == 'monthly' .OR. idy > nmonth_len(nmonth) /))
- iyr = nyear + COUNT((/ sdjf%cltype == 'yearly' .OR. imt == 13 /))
+ idy = nday + COUNT((/ sdjf%clftyp == 'daily' /))
+ imt = nmonth + COUNT((/ sdjf%clftyp == 'monthly' .OR. idy > nmonth_len(nmonth) /))
+ iyr = nyear + COUNT((/ sdjf%clftyp == 'yearly' .OR. imt == 13 /))
IF( idy > nmonth_len(nmonth) ) idy = 1
IF( imt == 13 ) imt = 1
@@ -866,11 +844,11 @@
IF ( NINT(sdjf%freqh) == -12 ) THEN ; ireclast = 1 ! yearly mean: consider only 1 record
ELSEIF( NINT(sdjf%freqh) == -1 ) THEN ! monthly mean:
- IF( sdjf%cltype == 'monthly' ) THEN ; ireclast = 1 ! consider that the file has 1 record
+ IF( sdjf%clftyp == 'monthly' ) THEN ; ireclast = 1 ! consider that the file has 1 record
ELSE ; ireclast = 12 ! consider that the file has 12 record
ENDIF
ELSE ! higher frequency mean (in hours)
- IF( sdjf%cltype == 'monthly' ) THEN ; ireclast = NINT( 24. * REAL(nmonth_len(indexmt), wp) / sdjf%freqh )
- ELSEIF( sdjf%cltype(1:4) == 'week' ) THEN ; ireclast = NINT( 24. * 7. / sdjf%freqh )
- ELSEIF( sdjf%cltype == 'daily' ) THEN ; ireclast = NINT( 24. / sdjf%freqh )
+ IF( sdjf%clftyp == 'monthly' ) THEN ; ireclast = NINT( 24. * REAL(nmonth_len(indexmt), wp) / sdjf%freqh )
+ ELSEIF( sdjf%clftyp(1:4) == 'week' ) THEN ; ireclast = NINT( 24. * 7. / sdjf%freqh )
+ ELSEIF( sdjf%clftyp == 'daily' ) THEN ; ireclast = NINT( 24. / sdjf%freqh )
ELSE ; ireclast = NINT( 24. * REAL( nyear_len(indexyr), wp) / sdjf%freqh )
ENDIF
@@ -890,5 +868,5 @@
sdjf%nrecsec(1) = sdjf%nrecsec(0) + nyear_len( indexyr ) * idaysec
ELSEIF( NINT(sdjf%freqh) == -1 ) THEN ! monthly mean:
- IF( sdjf%cltype == 'monthly' ) THEN ! monthly file
+ IF( sdjf%clftyp == 'monthly' ) THEN ! monthly file
sdjf%nrecsec(0 ) = nsec1jan000 + nmonth_beg(indexmt )
sdjf%nrecsec(1 ) = nsec1jan000 + nmonth_beg(indexmt+1)
@@ -898,7 +876,7 @@
ENDIF
ELSE ! higher frequency mean (in hours)
- IF( sdjf%cltype == 'monthly' ) THEN ; istart = nsec1jan000 + nmonth_beg(indexmt)
- ELSEIF( sdjf%cltype(1:4) == 'week' ) THEN ; istart = nsec1jan000 + isecwk
- ELSEIF( sdjf%cltype == 'daily' ) THEN ; istart = nsec1jan000 + nmonth_beg(indexmt) + ( idy - 1 ) * idaysec
+ IF( sdjf%clftyp == 'monthly' ) THEN ; istart = nsec1jan000 + nmonth_beg(indexmt)
+ ELSEIF( sdjf%clftyp(1:4) == 'week' ) THEN ; istart = nsec1jan000 + isecwk
+ ELSEIF( sdjf%clftyp == 'daily' ) THEN ; istart = nsec1jan000 + nmonth_beg(indexmt) + ( idy - 1 ) * idaysec
ELSEIF( indexyr == 0 ) THEN ; istart = nsec1jan000 - nyear_len( 0 ) * idaysec
ELSEIF( indexyr == 2 ) THEN ; istart = nsec1jan000 + nyear_len( 1 ) * idaysec
@@ -941,5 +919,5 @@
IF( sdjf%num <= 0 .OR. .NOT. sdjf%ln_clim ) THEN
IF( sdjf%num > 0 ) CALL iom_close( sdjf%num ) ! close file if already open
- CALL iom_open( sdjf%clname, sdjf%num, ldstop = llstop, ldiof = LEN(TRIM(sdjf%wgtname)) > 0 )
+ CALL iom_open( sdjf%clname, sdjf%num, ldstop = llstop, ldiof = LEN_TRIM(sdjf%wgtname) > 0 )
ENDIF
!
@@ -963,5 +941,5 @@
ENDIF
!
- CALL iom_open( sdjf%clname, sdjf%num, ldiof = LEN(TRIM(sdjf%wgtname)) > 0 )
+ CALL iom_open( sdjf%clname, sdjf%num, ldiof = LEN_TRIM(sdjf%wgtname) > 0 )
!
ENDIF
@@ -996,6 +974,10 @@
sdf(jf)%ln_tint = sdf_n(jf)%ln_tint
sdf(jf)%ln_clim = sdf_n(jf)%ln_clim
- sdf(jf)%cltype = sdf_n(jf)%cltype
+ sdf(jf)%clftyp = sdf_n(jf)%clftyp
+ sdf(jf)%cltype = 'T' ! by default don't do any call to lbc_lnk in iom_get
+ sdf(jf)%zsgn = 1. ! by default don't do change signe across the north fold
sdf(jf)%num = -1
+ sdf(jf)%nbb = 1 ! start with before data in 1
+ sdf(jf)%naa = 2 ! start with after data in 2
sdf(jf)%wgtname = " "
IF( LEN( TRIM(sdf_n(jf)%wname) ) > 0 ) sdf(jf)%wgtname = TRIM( cdir )//sdf_n(jf)%wname
@@ -1004,7 +986,7 @@
sdf(jf)%vcomp = sdf_n(jf)%vcomp
sdf(jf)%rotn(:) = .TRUE. ! pretend to be rotated -> won't try to rotate data before the first call to fld_get
- IF( sdf(jf)%cltype(1:4) == 'week' .AND. nn_leapy == 0 ) &
+ IF( sdf(jf)%clftyp(1:4) == 'week' .AND. nn_leapy == 0 ) &
& CALL ctl_stop('fld_clopn: weekly file ('//TRIM(sdf(jf)%clrootname)//') needs nn_leapy = 1')
- IF( sdf(jf)%cltype(1:4) == 'week' .AND. sdf(jf)%ln_clim ) &
+ IF( sdf(jf)%clftyp(1:4) == 'week' .AND. sdf(jf)%ln_clim ) &
& CALL ctl_stop('fld_clopn: weekly file ('//TRIM(sdf(jf)%clrootname)//') needs ln_clim = .FALSE.')
sdf(jf)%nreclast = -1 ! Set to non zero default value to avoid errors, is updated to meaningful value during fld_clopn
@@ -1032,5 +1014,5 @@
WRITE(numout,*) ' weights: ' , TRIM( sdf(jf)%wgtname ), &
& ' pairing: ' , TRIM( sdf(jf)%vcomp ), &
- & ' data type: ' , sdf(jf)%cltype , &
+ & ' data type: ' , sdf(jf)%clftyp , &
& ' land/sea mask:' , TRIM( sdf(jf)%lsmname )
call flush(numout)
@@ -1050,13 +1032,11 @@
!!----------------------------------------------------------------------
TYPE( FLD ), INTENT(in ) :: sd ! field with name of weights file
- INTEGER , INTENT(inout) :: kwgt ! index of weights
+ INTEGER , INTENT( out) :: kwgt ! index of weights
!
INTEGER :: kw, nestid ! local integer
- LOGICAL :: found ! local logical
!!----------------------------------------------------------------------
!
!! search down linked list
!! weights filename is either present or we hit the end of the list
- found = .FALSE.
!
!! because agrif nest part of filenames are now added in iom_open
@@ -1068,15 +1048,12 @@
#endif
DO kw = 1, nxt_wgt-1
- IF( TRIM(ref_wgts(kw)%wgtname) == TRIM(sd%wgtname) .AND. &
- ref_wgts(kw)%nestid == nestid) THEN
+ IF( ref_wgts(kw)%wgtname == sd%wgtname .AND. &
+ ref_wgts(kw)%nestid == nestid) THEN
kwgt = kw
- found = .TRUE.
- EXIT
+ RETURN
ENDIF
END DO
- IF( .NOT.found ) THEN
- kwgt = nxt_wgt
- CALL fld_weight( sd )
- ENDIF
+ kwgt = nxt_wgt
+ CALL fld_weight( sd )
!
END SUBROUTINE wgt_list
@@ -1121,5 +1098,5 @@
TYPE( FLD ), INTENT(in) :: sd ! field with name of weights file
!!
- INTEGER :: jn ! dummy loop indices
+ INTEGER :: ji,jj,jn ! dummy loop indices
INTEGER :: inum ! local logical unit
INTEGER :: id ! local variable id
@@ -1127,7 +1104,7 @@
INTEGER :: zwrap ! local integer
LOGICAL :: cyclical !
- CHARACTER (len=5) :: aname !
- INTEGER , DIMENSION(:), ALLOCATABLE :: ddims
- INTEGER, DIMENSION(jpi,jpj) :: data_src
+ CHARACTER (len=5) :: clname !
+ INTEGER , DIMENSION(4) :: ddims
+ INTEGER :: isrc
REAL(wp), DIMENSION(jpi,jpj) :: data_tmp
!!----------------------------------------------------------------------
@@ -1142,20 +1119,8 @@
!! current weights file
- !! open input data file (non-model grid)
- CALL iom_open( sd%clname, inum, ldiof = LEN(TRIM(sd%wgtname)) > 0 )
-
- !! get dimensions: we consider 2D data as 3D data with vertical dim size = 1
- IF( SIZE(sd%fnow, 3) > 0 ) THEN
- ALLOCATE( ddims(4) )
- ELSE
- ALLOCATE( ddims(3) )
- ENDIF
- id = iom_varid( inum, sd%clvar, ddims )
-
- !! close it
- CALL iom_close( inum )
+ !! get data grid dimensions
+ id = iom_varid( sd%num, sd%clvar, ddims )
!! now open the weights file
-
CALL iom_open ( sd%wgtname, inum ) ! interpolation weights
IF( inum > 0 ) THEN
@@ -1193,35 +1158,34 @@
!! two possible cases: bilinear (4 weights) or bicubic (16 weights)
id = iom_varid(inum, 'src05', ldstop=.FALSE.)
- IF( id <= 0) THEN
- ref_wgts(nxt_wgt)%numwgt = 4
- ELSE
- ref_wgts(nxt_wgt)%numwgt = 16
- ENDIF
-
- ALLOCATE( ref_wgts(nxt_wgt)%data_jpi(jpi,jpj,4) )
- ALLOCATE( ref_wgts(nxt_wgt)%data_jpj(jpi,jpj,4) )
- ALLOCATE( ref_wgts(nxt_wgt)%data_wgt(jpi,jpj,ref_wgts(nxt_wgt)%numwgt) )
+ IF( id <= 0 ) THEN ; ref_wgts(nxt_wgt)%numwgt = 4
+ 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) )
DO jn = 1,4
- aname = ' '
- WRITE(aname,'(a3,i2.2)') 'src',jn
- data_tmp(:,:) = 0
- CALL iom_get ( inum, jpdom_data, aname, data_tmp(:,:) )
- data_src(:,:) = INT(data_tmp(:,:))
- ref_wgts(nxt_wgt)%data_jpj(:,:,jn) = 1 + (data_src(:,:)-1) / ref_wgts(nxt_wgt)%ddims(1)
- ref_wgts(nxt_wgt)%data_jpi(:,:,jn) = data_src(:,:) - ref_wgts(nxt_wgt)%ddims(1)*(ref_wgts(nxt_wgt)%data_jpj(:,:,jn)-1)
+ WRITE(clname,'(a3,i2.2)') 'src',jn
+ CALL iom_get ( inum, jpdom_global, clname, data_tmp(:,:), cd_type = 'Z' ) ! no call to lbc_lnk
+ DO_2D( 0, 0, 0, 0 )
+ isrc = NINT(data_tmp(ji,jj)) - 1
+ ref_wgts(nxt_wgt)%data_jpi(ji,jj,jn) = 1 + MOD(isrc, ref_wgts(nxt_wgt)%ddims(1))
+ ref_wgts(nxt_wgt)%data_jpj(ji,jj,jn) = 1 + isrc / ref_wgts(nxt_wgt)%ddims(1)
+ END_2D
END DO
DO jn = 1, ref_wgts(nxt_wgt)%numwgt
- aname = ' '
- WRITE(aname,'(a3,i2.2)') 'wgt',jn
- ref_wgts(nxt_wgt)%data_wgt(:,:,jn) = 0.0
- CALL iom_get ( inum, jpdom_data, aname, ref_wgts(nxt_wgt)%data_wgt(:,:,jn) )
+ WRITE(clname,'(a3,i2.2)') 'wgt',jn
+ CALL iom_get ( inum, jpdom_global, clname, data_tmp(:,:), cd_type = 'Z' ) ! no call to lbc_lnk
+ DO_2D( 0, 0, 0, 0 )
+ ref_wgts(nxt_wgt)%data_wgt(ji,jj,jn) = data_tmp(ji,jj)
+ END_2D
END DO
CALL iom_close (inum)
! find min and max indices in grid
- ref_wgts(nxt_wgt)%botleft(1) = MINVAL(ref_wgts(nxt_wgt)%data_jpi(:,:,:))
- ref_wgts(nxt_wgt)%botleft(2) = MINVAL(ref_wgts(nxt_wgt)%data_jpj(:,:,:))
+ ref_wgts(nxt_wgt)%botleft( 1) = MINVAL(ref_wgts(nxt_wgt)%data_jpi(:,:,:))
+ ref_wgts(nxt_wgt)%botleft( 2) = MINVAL(ref_wgts(nxt_wgt)%data_jpj(:,:,:))
ref_wgts(nxt_wgt)%topright(1) = MAXVAL(ref_wgts(nxt_wgt)%data_jpi(:,:,:))
ref_wgts(nxt_wgt)%topright(2) = MAXVAL(ref_wgts(nxt_wgt)%data_jpj(:,:,:))
@@ -1247,6 +1211,4 @@
CALL ctl_stop( ' fld_weight : unable to read the file ' )
ENDIF
-
- DEALLOCATE (ddims )
!
END SUBROUTINE fld_weight
@@ -1281,7 +1243,9 @@
SELECT CASE( SIZE(zfieldo(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:),3) )
CASE(1)
- CALL iom_get( inum, jpdom_unknown, 'LSM', zslmec1(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,1), 1, rec1_lsm, recn_lsm)
+ CALL iom_get( inum, jpdom_unknown, 'LSM', zslmec1(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,1), &
+ & 1, kstart = rec1_lsm, kcount = recn_lsm)
CASE DEFAULT
- CALL iom_get( inum, jpdom_unknown, 'LSM', zslmec1(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:), 1, rec1_lsm, recn_lsm)
+ CALL iom_get( inum, jpdom_unknown, 'LSM', zslmec1(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:), &
+ & 1, kstart = rec1_lsm, kcount = recn_lsm)
END SELECT
CALL iom_close( inum )
@@ -1326,14 +1290,14 @@
!! D. Delrosso INGV
!!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: ileni,ilenj ! lengths
- REAL, DIMENSION (ileni,ilenj), INTENT(in ) :: zfieldn ! array of forcing field with undeff for land points
- REAL, DIMENSION (ileni,ilenj), INTENT( out) :: zfield ! array of forcing field
- !
- REAL , DIMENSION (ileni,ilenj) :: zmat1, zmat2, zmat3, zmat4 ! local arrays
- REAL , DIMENSION (ileni,ilenj) :: zmat5, zmat6, zmat7, zmat8 ! - -
- REAL , DIMENSION (ileni,ilenj) :: zlsm2d ! - -
- REAL , DIMENSION (ileni,ilenj,8) :: zlsm3d ! - -
- LOGICAL, DIMENSION (ileni,ilenj,8) :: ll_msknan3d ! logical mask for undeff detection
- LOGICAL, DIMENSION (ileni,ilenj) :: ll_msknan2d ! logical mask for undeff detection
+ INTEGER , INTENT(in ) :: ileni,ilenj ! lengths
+ REAL(wp), DIMENSION (ileni,ilenj), INTENT(in ) :: zfieldn ! array of forcing field with undeff for land points
+ REAL(wp), DIMENSION (ileni,ilenj), INTENT( out) :: zfield ! array of forcing field
+ !
+ REAL(wp) , DIMENSION (ileni,ilenj) :: zmat1, zmat2, zmat3, zmat4 ! local arrays
+ REAL(wp) , DIMENSION (ileni,ilenj) :: zmat5, zmat6, zmat7, zmat8 ! - -
+ REAL(wp) , DIMENSION (ileni,ilenj) :: zlsm2d ! - -
+ REAL(wp) , DIMENSION (ileni,ilenj,8) :: zlsm3d ! - -
+ LOGICAL , DIMENSION (ileni,ilenj,8) :: ll_msknan3d ! logical mask for undeff detection
+ LOGICAL , DIMENSION (ileni,ilenj) :: ll_msknan2d ! logical mask for undeff detection
!!----------------------------------------------------------------------
zmat8 = eoshift( zfieldn , SHIFT=-1 , BOUNDARY = (/zfieldn(:,1)/) , DIM=2 )
@@ -1356,6 +1320,5 @@
- SUBROUTINE fld_interp( num, clvar, kw, kk, dta, &
- & nrec, lsmfile)
+ SUBROUTINE fld_interp( num, clvar, kw, kk, dta, nrec, lsmfile)
!!---------------------------------------------------------------------
!! *** ROUTINE fld_interp ***
@@ -1375,5 +1338,6 @@
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 :: jk, jn, jm, jir, jjr ! loop counters
+ INTEGER :: ji, jj, jk, jn, jir, jjr ! loop counters
+ INTEGER :: ipk
INTEGER :: ni, nj ! lengths
INTEGER :: jpimin,jpiwid ! temporary indices
@@ -1386,4 +1350,5 @@
REAL(wp),DIMENSION(:,:,:), ALLOCATABLE :: ztmp_fly_dta ! local array of values on input grid
!!----------------------------------------------------------------------
+ ipk = SIZE(dta, 3)
!
!! for weighted interpolation we have weights at four corners of a box surrounding
@@ -1415,5 +1380,5 @@
- IF( LEN( TRIM(lsmfile) ) > 0 ) THEN
+ IF( LEN_TRIM(lsmfile) > 0 ) THEN
!! indeces for ztmp_fly_dta
! --------------------------
@@ -1445,8 +1410,8 @@
CASE(1)
CALL iom_get( num, jpdom_unknown, clvar, ztmp_fly_dta(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,1), &
- & nrec, rec1_lsm, recn_lsm)
+ & nrec, kstart = rec1_lsm, kcount = recn_lsm)
CASE DEFAULT
CALL iom_get( num, jpdom_unknown, clvar, ztmp_fly_dta(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:), &
- & nrec, rec1_lsm, recn_lsm)
+ & nrec, kstart = rec1_lsm, kcount = recn_lsm)
END SELECT
CALL apply_seaoverland(lsmfile,ztmp_fly_dta(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:), &
@@ -1468,5 +1433,5 @@
ref_wgts(kw)%fly_dta(:,:,:) = 0.0
- CALL iom_get( num, jpdom_unknown, clvar, ref_wgts(kw)%fly_dta(jpi1:jpi2,jpj1:jpj2,:), nrec, rec1, recn)
+ CALL iom_get( num, jpdom_unknown, clvar, ref_wgts(kw)%fly_dta(jpi1:jpi2,jpj1:jpj2,:), nrec, kstart = rec1, kcount = recn)
ENDIF
@@ -1474,87 +1439,95 @@
!! first four weights common to both bilinear and bicubic
!! data_jpi, data_jpj have already been shifted to (1,1) corresponding to botleft
- !! note that we have to offset by 1 into fly_dta array because of halo
- dta(:,:,:) = 0.0
- DO jk = 1,4
- DO jn = 1, jpj
- DO jm = 1,jpi
- ni = ref_wgts(kw)%data_jpi(jm,jn,jk)
- nj = ref_wgts(kw)%data_jpj(jm,jn,jk)
- dta(jm,jn,:) = dta(jm,jn,:) + ref_wgts(kw)%data_wgt(jm,jn,jk) * ref_wgts(kw)%fly_dta(ni+1,nj+1,:)
- END DO
- END DO
+ !! note that we have to offset by 1 into fly_dta array because of halo added to fly_dta (rec1 definition)
+ dta(:,:,:) = 0._wp
+ DO jn = 1,4
+ 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)
+ END_3D
END DO
IF(ref_wgts(kw)%numwgt .EQ. 16) THEN
- !! fix up halo points that we couldnt read from file
- IF( jpi1 == 2 ) THEN
- ref_wgts(kw)%fly_dta(jpi1-1,:,:) = ref_wgts(kw)%fly_dta(jpi1,:,:)
- ENDIF
- IF( jpi2 + jpimin - 1 == ref_wgts(kw)%ddims(1)+1 ) THEN
- ref_wgts(kw)%fly_dta(jpi2+1,:,:) = ref_wgts(kw)%fly_dta(jpi2,:,:)
- ENDIF
- IF( jpj1 == 2 ) THEN
- ref_wgts(kw)%fly_dta(:,jpj1-1,:) = ref_wgts(kw)%fly_dta(:,jpj1,:)
- ENDIF
- IF( jpj2 + jpjmin - 1 == ref_wgts(kw)%ddims(2)+1 .AND. jpj2 .lt. jpjwid+2 ) THEN
- ref_wgts(kw)%fly_dta(:,jpj2+1,:) = 2.0*ref_wgts(kw)%fly_dta(:,jpj2,:) - ref_wgts(kw)%fly_dta(:,jpj2-1,:)
- ENDIF
-
- !! if data grid is cyclic we can do better on east-west edges
- !! but have to allow for whether first and last columns are coincident
- IF( ref_wgts(kw)%cyclic ) THEN
- rec1(2) = MAX( jpjmin-1, 1 )
- recn(1) = 1
- recn(2) = MIN( jpjwid+2, ref_wgts(kw)%ddims(2)-rec1(2)+1 )
- jpj1 = 2 + rec1(2) - jpjmin
- jpj2 = jpj1 + recn(2) - 1
- IF( jpi1 == 2 ) THEN
- rec1(1) = ref_wgts(kw)%ddims(1) - ref_wgts(kw)%overlap
- CALL iom_get( num, jpdom_unknown, clvar, ref_wgts(kw)%col(:,jpj1:jpj2,:), nrec, rec1, recn)
- ref_wgts(kw)%fly_dta(jpi1-1,jpj1:jpj2,:) = ref_wgts(kw)%col(1,jpj1:jpj2,:)
- ENDIF
- IF( jpi2 + jpimin - 1 == ref_wgts(kw)%ddims(1)+1 ) THEN
- rec1(1) = 1 + ref_wgts(kw)%overlap
- CALL iom_get( num, jpdom_unknown, clvar, ref_wgts(kw)%col(:,jpj1:jpj2,:), nrec, rec1, recn)
- ref_wgts(kw)%fly_dta(jpi2+1,jpj1:jpj2,:) = ref_wgts(kw)%col(1,jpj1:jpj2,:)
- ENDIF
- ENDIF
-
- ! gradient in the i direction
- DO jk = 1,4
- DO jn = 1, jpj
- DO jm = 1,jpi
- ni = ref_wgts(kw)%data_jpi(jm,jn,jk)
- nj = ref_wgts(kw)%data_jpj(jm,jn,jk)
- dta(jm,jn,:) = dta(jm,jn,:) + ref_wgts(kw)%data_wgt(jm,jn,jk+4) * 0.5 * &
- (ref_wgts(kw)%fly_dta(ni+2,nj+1,:) - ref_wgts(kw)%fly_dta(ni,nj+1,:))
- END DO
- END DO
- END DO
-
- ! gradient in the j direction
- DO jk = 1,4
- DO jn = 1, jpj
- DO jm = 1,jpi
- ni = ref_wgts(kw)%data_jpi(jm,jn,jk)
- nj = ref_wgts(kw)%data_jpj(jm,jn,jk)
- dta(jm,jn,:) = dta(jm,jn,:) + ref_wgts(kw)%data_wgt(jm,jn,jk+8) * 0.5 * &
- (ref_wgts(kw)%fly_dta(ni+1,nj+2,:) - ref_wgts(kw)%fly_dta(ni+1,nj,:))
- END DO
- END DO
- END DO
-
- ! gradient in the ij direction
- DO jk = 1,4
- DO jn = 1, jpj
- DO jm = 1,jpi
- ni = ref_wgts(kw)%data_jpi(jm,jn,jk)
- nj = ref_wgts(kw)%data_jpj(jm,jn,jk)
- dta(jm,jn,:) = dta(jm,jn,:) + ref_wgts(kw)%data_wgt(jm,jn,jk+12) * 0.25 * ( &
- (ref_wgts(kw)%fly_dta(ni+2,nj+2,:) - ref_wgts(kw)%fly_dta(ni ,nj+2,:)) - &
- (ref_wgts(kw)%fly_dta(ni+2,nj ,:) - ref_wgts(kw)%fly_dta(ni ,nj ,:)))
- END DO
- END DO
+ !! fix up halo points that we couldnt read from file
+ IF( jpi1 == 2 ) THEN
+ ref_wgts(kw)%fly_dta(jpi1-1,:,:) = ref_wgts(kw)%fly_dta(jpi1,:,:)
+ ENDIF
+ IF( jpi2 + jpimin - 1 == ref_wgts(kw)%ddims(1)+1 ) THEN
+ ref_wgts(kw)%fly_dta(jpi2+1,:,:) = ref_wgts(kw)%fly_dta(jpi2,:,:)
+ ENDIF
+ IF( jpj1 == 2 ) THEN
+ ref_wgts(kw)%fly_dta(:,jpj1-1,:) = ref_wgts(kw)%fly_dta(:,jpj1,:)
+ ENDIF
+ IF( jpj2 + jpjmin - 1 == ref_wgts(kw)%ddims(2)+1 .AND. jpj2 .LT. jpjwid+2 ) THEN
+ ref_wgts(kw)%fly_dta(:,jpj2+1,:) = 2.0*ref_wgts(kw)%fly_dta(:,jpj2,:) - ref_wgts(kw)%fly_dta(:,jpj2-1,:)
+ ENDIF
+
+ !! if data grid is cyclic we can do better on east-west edges
+ !! but have to allow for whether first and last columns are coincident
+ IF( ref_wgts(kw)%cyclic ) THEN
+ rec1(2) = MAX( jpjmin-1, 1 )
+ recn(1) = 1
+ recn(2) = MIN( jpjwid+2, ref_wgts(kw)%ddims(2)-rec1(2)+1 )
+ jpj1 = 2 + rec1(2) - jpjmin
+ jpj2 = jpj1 + recn(2) - 1
+ IF( jpi1 == 2 ) THEN
+ rec1(1) = ref_wgts(kw)%ddims(1) - ref_wgts(kw)%overlap
+ CALL iom_get( num, jpdom_unknown, clvar, ref_wgts(kw)%col(:,jpj1:jpj2,:), nrec, kstart = rec1, kcount = recn)
+ ref_wgts(kw)%fly_dta(jpi1-1,jpj1:jpj2,:) = ref_wgts(kw)%col(1,jpj1:jpj2,:)
+ ENDIF
+ IF( jpi2 + jpimin - 1 == ref_wgts(kw)%ddims(1)+1 ) THEN
+ rec1(1) = 1 + ref_wgts(kw)%overlap
+ CALL iom_get( num, jpdom_unknown, clvar, ref_wgts(kw)%col(:,jpj1:jpj2,:), nrec, kstart = rec1, kcount = recn)
+ ref_wgts(kw)%fly_dta(jpi2+1,jpj1:jpj2,:) = ref_wgts(kw)%col(1,jpj1:jpj2,:)
+ ENDIF
+ ENDIF
+ !
+!!$ DO jn = 1,4
+!!$ 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) &
+!!$ ! 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)) &
+!!$ ! gradient in the j direction
+!!$ & + ref_wgts(kw)%data_wgt(ji,jj,jn+8) * 0.5_wp * &
+!!$ & (ref_wgts(kw)%fly_dta(ni ,nj+1,jk) - ref_wgts(kw)%fly_dta(ni ,nj-1,jk)) &
+!!$ ! gradient in the ij direction
+!!$ & + ref_wgts(kw)%data_wgt(ji,jj,jn+12) * 0.25_wp * &
+!!$ & ((ref_wgts(kw)%fly_dta(ni+1,nj+1,jk) - ref_wgts(kw)%fly_dta(ni-1,nj+1,jk)) - &
+!!$ & (ref_wgts(kw)%fly_dta(ni+1,nj-1,jk) - ref_wgts(kw)%fly_dta(ni-1,nj-1,jk)))
+!!$ END_3D
+!!$ END DO
+ !
+ DO jn = 1,4
+ 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)
+ ! 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 * &
+ & (ref_wgts(kw)%fly_dta(ni+2,nj+1,jk) - ref_wgts(kw)%fly_dta(ni ,nj+1,jk))
+ END_3D
+ END DO
+ DO jn = 1,4
+ 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)
+ ! 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 * &
+ & (ref_wgts(kw)%fly_dta(ni+1,nj+2,jk) - ref_wgts(kw)%fly_dta(ni+1,nj ,jk))
+ END_3D
+ END DO
+ DO jn = 1,4
+ 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)
+ ! 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 * ( &
+ & (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
END DO
!
@@ -1583,10 +1556,10 @@
IF( .NOT. sdjf%ln_clim ) THEN
WRITE(clname, '(a,"_y",i4.4)' ) TRIM( sdjf%clrootname ), kyear ! add year
- IF( sdjf%cltype /= 'yearly' ) WRITE(clname, '(a, "m",i2.2)' ) TRIM( clname ), kmonth ! add month
+ IF( sdjf%clftyp /= 'yearly' ) WRITE(clname, '(a, "m",i2.2)' ) TRIM( clname ), kmonth ! add month
ELSE
! build the new filename if climatological data
- IF( sdjf%cltype /= 'yearly' ) WRITE(clname, '(a,"_m",i2.2)' ) TRIM( sdjf%clrootname ), kmonth ! add month
- ENDIF
- IF( sdjf%cltype == 'daily' .OR. sdjf%cltype(1:4) == 'week' ) &
+ IF( sdjf%clftyp /= 'yearly' ) WRITE(clname, '(a,"_m",i2.2)' ) TRIM( sdjf%clrootname ), kmonth ! add month
+ ENDIF
+ IF( sdjf%clftyp == 'daily' .OR. sdjf%clftyp(1:4) == 'week' ) &
& WRITE(clname, '(a,"d" ,i2.2)' ) TRIM( clname ), kday ! add day
@@ -1612,5 +1585,5 @@
IF( cl_week(ijul) == TRIM(cdday) ) EXIT
END DO
- IF( ijul .GT. 7 ) CALL ctl_stop( 'ksec_week: wrong day for sdjf%cltype(6:8): '//TRIM(cdday) )
+ IF( ijul .GT. 7 ) CALL ctl_stop( 'ksec_week: wrong day for sdjf%clftyp(6:8): '//TRIM(cdday) )
!
ishift = ijul * NINT(rday)
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/geo2ocean.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/geo2ocean.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/geo2ocean.F90 (revision 13540)
@@ -160,5 +160,5 @@
! (computation done on the north stereographic polar plane)
!
- DO_2D_00_01
+ DO_2D( 0, 0, 0, 1 )
!
zlam = plamt(ji,jj) ! north pole direction & modulous (at t-point)
@@ -249,5 +249,5 @@
! =============== !
- DO_2D_00_01
+ DO_2D( 0, 0, 0, 1 )
IF( MOD( ABS( plamv(ji,jj) - plamv(ji,jj-1) ), 360. ) < 1.e-8 ) THEN
gsint(ji,jj) = 0.
@@ -272,6 +272,6 @@
! =========================== !
! ! lateral boundary cond.: T-, U-, V-, F-pts, sgn
- CALL lbc_lnk_multi( 'geo2ocean', gcost, 'T', -1., gsint, 'T', -1., gcosu, 'U', -1., gsinu, 'U', -1., &
- & gcosv, 'V', -1., gsinv, 'V', -1., gcosf, 'F', -1., gsinf, 'F', -1. )
+ CALL lbc_lnk_multi( 'geo2ocean', gcost, 'T', -1.0_wp, gsint, 'T', -1.0_wp, gcosu, 'U', -1.0_wp, gsinu, 'U', -1.0_wp, &
+ & gcosv, 'V', -1.0_wp, gsinv, 'V', -1.0_wp, gcosf, 'F', -1.0_wp, gsinf, 'F', -1.0_wp )
!
END SUBROUTINE angle
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbc_ice.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbc_ice.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbc_ice.F90 (revision 13540)
@@ -69,5 +69,6 @@
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp_oce !: evap - precip over ocean [kg/m2/s]
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wndm_ice !: wind speed module at T-point [m/s]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sstfrz !: wind speed module at T-point [m/s]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sstfrz !: sea surface freezing temperature [degC]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rCdU_ice !: ice-ocean drag at T-point (<0) [m/s]
#endif
@@ -89,5 +90,5 @@
! variables used in the coupled interface
INTEGER , PUBLIC, PARAMETER :: jpl = ncat
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_ice, v_ice ! jpi, jpj
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_ice, v_ice
! already defined in ice.F90 for SI3
@@ -98,5 +99,5 @@
#endif
- REAL(wp), PUBLIC, SAVE :: cldf_ice = 0.81 !: cloud fraction over sea ice, summer CLIO value [-]
+ REAL(wp), PUBLIC, SAVE :: pp_cldf = 0.81 !: cloud fraction over sea ice, summer CLIO value [-]
!! arrays relating to embedding ice in the ocean
@@ -131,5 +132,5 @@
& 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) , STAT= ierr(2) )
+ & emp_ice (jpi,jpj) , sstfrz (jpi,jpj) , rCdU_ice (jpi,jpj) , STAT= ierr(2) )
#endif
@@ -167,5 +168,5 @@
LOGICAL , PUBLIC, PARAMETER :: lk_si3 = .FALSE. !: no SI3 ice model
LOGICAL , PUBLIC, PARAMETER :: lk_cice = .FALSE. !: no CICE ice model
- REAL(wp) , PUBLIC, PARAMETER :: cldf_ice = 0.81 !: cloud fraction over sea ice, summer CLIO value [-]
+ REAL(wp) , PUBLIC, PARAMETER :: pp_cldf = 0.81 !: cloud fraction over sea ice, summer CLIO value [-]
INTEGER , PUBLIC, PARAMETER :: jpl = 1
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_ice, v_ice ! jpi, jpj
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbc_oce.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbc_oce.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbc_oce.F90 (revision 13540)
@@ -136,4 +136,5 @@
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) [-]
!!---------------------------------------------------------------------
@@ -188,5 +189,5 @@
!
ALLOCATE( tprecip(jpi,jpj) , sprecip(jpi,jpj) , fr_i(jpi,jpj) , &
- & atm_co2(jpi,jpj) , tsk_m(jpi,jpj) , &
+ & atm_co2(jpi,jpj) , tsk_m(jpi,jpj) , cloud_fra(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) )
@@ -217,5 +218,5 @@
!!---------------------------------------------------------------------
zcoef = 0.5 / ( zrhoa * zcdrag )
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
ztx = utau(ji-1,jj ) + utau(ji,jj)
zty = vtau(ji ,jj-1) + vtau(ji,jj)
@@ -223,5 +224,5 @@
wndm(ji,jj) = SQRT ( ztau * zcoef ) * tmask(ji,jj,1)
END_2D
- CALL lbc_lnk( 'sbc_oce', wndm(:,:) , 'T', 1. )
+ CALL lbc_lnk( 'sbc_oce', wndm(:,:) , 'T', 1.0_wp )
!
END SUBROUTINE sbc_tau2wnd
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcapr.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcapr.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcapr.F90 (revision 13540)
@@ -154,5 +154,5 @@
IF( ln_rstart .AND. iom_varid( numror, 'ssh_ibb', ldstop = .FALSE. ) > 0 ) THEN
IF(lwp) WRITE(numout,*) 'sbc_apr: ssh_ibb read in the restart file'
- CALL iom_get( numror, jpdom_autoglo, 'ssh_ibb', ssh_ibb, ldxios = lrxios ) ! before inv. barometer ssh
+ CALL iom_get( numror, jpdom_auto, 'ssh_ibb', ssh_ibb, ldxios = lrxios ) ! before inv. barometer ssh
!
ELSE !* no restart: set from nit000 values
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcblk.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcblk.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcblk.F90 (revision 13540)
@@ -44,6 +44,6 @@
USE lib_fortran ! to use key_nosignedzero
#if defined key_si3
- USE ice , ONLY : jpl, a_i_b, at_i_b, rn_cnd_s, hfx_err_dif
- USE icethd_dh ! for CALL ice_thd_snwblow
+ USE ice , ONLY : u_ice, v_ice, jpl, a_i_b, at_i_b, t_su, rn_cnd_s, hfx_err_dif, nn_qtrice
+ USE icevar ! for CALL ice_var_snwblow
#endif
USE sbcblk_algo_ncar ! => turb_ncar : NCAR - CORE (Large & Yeager, 2009)
@@ -74,17 +74,23 @@
#endif
- INTEGER , PUBLIC :: jpfld ! maximum number of files to read
- INTEGER , PUBLIC, PARAMETER :: jp_wndi = 1 ! index of 10m wind velocity (i-component) (m/s) at T-point
- INTEGER , PUBLIC, PARAMETER :: jp_wndj = 2 ! index of 10m wind velocity (j-component) (m/s) at T-point
- INTEGER , PUBLIC, PARAMETER :: jp_tair = 3 ! index of 10m air temperature (Kelvin)
- INTEGER , PUBLIC, PARAMETER :: jp_humi = 4 ! index of specific humidity ( % )
- INTEGER , PUBLIC, PARAMETER :: jp_qsr = 5 ! index of solar heat (W/m2)
- INTEGER , PUBLIC, PARAMETER :: jp_qlw = 6 ! index of Long wave (W/m2)
- INTEGER , PUBLIC, PARAMETER :: jp_prec = 7 ! index of total precipitation (rain+snow) (Kg/m2/s)
- INTEGER , PUBLIC, PARAMETER :: jp_snow = 8 ! index of snow (solid prcipitation) (kg/m2/s)
- INTEGER , PUBLIC, PARAMETER :: jp_slp = 9 ! index of sea level pressure (Pa)
- INTEGER , PUBLIC, PARAMETER :: jp_hpgi =10 ! index of ABL geostrophic wind or hpg (i-component) (m/s) at T-point
- INTEGER , PUBLIC, PARAMETER :: jp_hpgj =11 ! index of ABL geostrophic wind or hpg (j-component) (m/s) at T-point
-
+ INTEGER , PUBLIC, PARAMETER :: jp_wndi = 1 ! index of 10m wind velocity (i-component) (m/s) at T-point
+ INTEGER , PUBLIC, PARAMETER :: jp_wndj = 2 ! index of 10m wind velocity (j-component) (m/s) at T-point
+ INTEGER , PUBLIC, PARAMETER :: jp_tair = 3 ! index of 10m air temperature (Kelvin)
+ INTEGER , PUBLIC, PARAMETER :: jp_humi = 4 ! index of specific humidity ( % )
+ INTEGER , PUBLIC, PARAMETER :: jp_qsr = 5 ! index of solar heat (W/m2)
+ INTEGER , PUBLIC, PARAMETER :: jp_qlw = 6 ! index of Long wave (W/m2)
+ INTEGER , PUBLIC, PARAMETER :: jp_prec = 7 ! index of total precipitation (rain+snow) (Kg/m2/s)
+ INTEGER , PUBLIC, PARAMETER :: jp_snow = 8 ! index of snow (solid prcipitation) (kg/m2/s)
+ INTEGER , PUBLIC, PARAMETER :: jp_slp = 9 ! index of sea level pressure (Pa)
+ INTEGER , PUBLIC, PARAMETER :: jp_uoatm = 10 ! index of surface current (i-component)
+ ! ! seen by the atmospheric forcing (m/s) at T-point
+ INTEGER , PUBLIC, PARAMETER :: jp_voatm = 11 ! index of surface current (j-component)
+ ! ! seen by the atmospheric forcing (m/s) at T-point
+ INTEGER , PUBLIC, PARAMETER :: jp_cc = 12 ! index of cloud cover (-) range:0-1
+ INTEGER , PUBLIC, PARAMETER :: jp_hpgi = 13 ! index of ABL geostrophic wind or hpg (i-component) (m/s) at T-point
+ INTEGER , PUBLIC, PARAMETER :: jp_hpgj = 14 ! index of ABL geostrophic wind or hpg (j-component) (m/s) at T-point
+ INTEGER , PUBLIC, PARAMETER :: jpfld = 14 ! maximum number of files to read
+
+ ! Warning: keep this structure allocatable for Agrif...
TYPE(FLD), PUBLIC, ALLOCATABLE, DIMENSION(:) :: sf ! structure of input atmospheric fields (file informations, fields read)
@@ -98,13 +104,16 @@
LOGICAL :: ln_Cd_L15 ! ice-atm drag = F( ice concentration, atmospheric stability ) (Lupkes et al. JGR2015)
!
+ LOGICAL :: ln_crt_fbk ! Add surface current feedback to the wind stress computation (Renault et al. 2020)
+ REAL(wp) :: rn_stau_a ! Alpha and Beta coefficients of Renault et al. 2020, eq. 10: Stau = Alpha * Wnd + Beta
+ REAL(wp) :: rn_stau_b !
+ !
REAL(wp) :: rn_pfac ! multiplication factor for precipitation
REAL(wp), PUBLIC :: rn_efac ! multiplication factor for evaporation
- REAL(wp), PUBLIC :: rn_vfac ! multiplication factor for ice/ocean velocity in the calculation of wind stress
REAL(wp) :: rn_zqt ! z(q,t) : height of humidity and temperature measurements
REAL(wp) :: rn_zu ! z(u) : height of wind measurements
!
- REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: Cd_ice , Ch_ice , Ce_ice ! transfert coefficients over ice
- REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: Cdn_oce, Chn_oce, Cen_oce ! neutral coeffs over ocean (L15 bulk scheme)
- REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: t_zu, q_zu ! air temp. and spec. hum. at wind speed height (L15 bulk scheme)
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: Cdn_oce, Chn_oce, Cen_oce ! neutral coeffs over ocean (L15 bulk scheme and ABL)
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: Cd_ice , Ch_ice , Ce_ice ! transfert coefficients over ice
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: t_zu, q_zu ! air temp. and spec. hum. at wind speed height (L15 bulk scheme)
LOGICAL :: ln_skin_cs ! use the cool-skin (only available in ECMWF and COARE algorithms) !LB
@@ -113,4 +122,5 @@
LOGICAL :: ln_humi_dpt ! humidity read in files ("sn_humi") is dew-point temperature [K] if .true. !LB
LOGICAL :: ln_humi_rlh ! humidity read in files ("sn_humi") is relative humidity [%] if .true. !LB
+ LOGICAL :: ln_tpot !!GS: flag to compute or not potential temperature
!
INTEGER :: nhumi ! choice of the bulk algorithm
@@ -162,13 +172,17 @@
!!
CHARACTER(len=100) :: cn_dir ! Root directory for location of atmospheric forcing files
- TYPE(FLD_N), ALLOCATABLE, DIMENSION(:) :: slf_i ! array of namelist informations on the fields to read
- TYPE(FLD_N) :: sn_wndi, sn_wndj, sn_humi, sn_qsr ! informations about the fields to be read
- TYPE(FLD_N) :: sn_qlw , sn_tair, sn_prec, sn_snow ! " "
- TYPE(FLD_N) :: sn_slp , sn_hpgi, sn_hpgj ! " "
+ TYPE(FLD_N), DIMENSION(jpfld) :: slf_i ! array of namelist informations on the fields to read
+ TYPE(FLD_N) :: sn_wndi, sn_wndj , sn_humi, sn_qsr ! informations about the fields to be read
+ TYPE(FLD_N) :: sn_qlw , sn_tair , sn_prec, sn_snow ! " "
+ TYPE(FLD_N) :: sn_slp , sn_uoatm, sn_voatm ! " "
+ TYPE(FLD_N) :: sn_cc, sn_hpgi, sn_hpgj ! " "
+ INTEGER :: ipka ! number of levels in the atmospheric variable
NAMELIST/namsbc_blk/ sn_wndi, sn_wndj, sn_humi, sn_qsr, sn_qlw , & ! input fields
- & sn_tair, sn_prec, sn_snow, sn_slp, sn_hpgi, sn_hpgj, &
+ & sn_tair, sn_prec, sn_snow, sn_slp, sn_uoatm, sn_voatm, &
+ & sn_cc, sn_hpgi, sn_hpgj, &
& ln_NCAR, ln_COARE_3p0, ln_COARE_3p6, ln_ECMWF, & ! bulk algorithm
& cn_dir , rn_zqt, rn_zu, &
- & rn_pfac, rn_efac, rn_vfac, ln_Cd_L12, ln_Cd_L15, &
+ & rn_pfac, rn_efac, ln_Cd_L12, ln_Cd_L15, ln_tpot, &
+ & ln_crt_fbk, rn_stau_a, rn_stau_b, & ! current feedback
& ln_skin_cs, ln_skin_wl, ln_humi_sph, ln_humi_dpt, ln_humi_rlh ! cool-skin / warm-layer !LB
!!---------------------------------------------------------------------
@@ -242,16 +256,17 @@
! !* set the bulk structure
! !- store namelist information in an array
- IF( ln_blk ) jpfld = 9
- IF( ln_abl ) jpfld = 11
- ALLOCATE( slf_i(jpfld) )
- !
- slf_i(jp_wndi) = sn_wndi ; slf_i(jp_wndj) = sn_wndj
- slf_i(jp_qsr ) = sn_qsr ; slf_i(jp_qlw ) = sn_qlw
- slf_i(jp_tair) = sn_tair ; slf_i(jp_humi) = sn_humi
- slf_i(jp_prec) = sn_prec ; slf_i(jp_snow) = sn_snow
- slf_i(jp_slp ) = sn_slp
- IF( ln_abl ) THEN
- slf_i(jp_hpgi) = sn_hpgi ; slf_i(jp_hpgj) = sn_hpgj
- END IF
+ !
+ slf_i(jp_wndi ) = sn_wndi ; slf_i(jp_wndj ) = sn_wndj
+ slf_i(jp_qsr ) = sn_qsr ; slf_i(jp_qlw ) = sn_qlw
+ slf_i(jp_tair ) = sn_tair ; slf_i(jp_humi ) = sn_humi
+ slf_i(jp_prec ) = sn_prec ; slf_i(jp_snow ) = sn_snow
+ slf_i(jp_slp ) = sn_slp ; slf_i(jp_cc ) = sn_cc
+ slf_i(jp_uoatm) = sn_uoatm ; slf_i(jp_voatm) = sn_voatm
+ slf_i(jp_hpgi ) = sn_hpgi ; slf_i(jp_hpgj ) = sn_hpgj
+ !
+ IF( .NOT. ln_abl ) THEN ! force to not use jp_hpgi and jp_hpgj, should already be done in namelist_* but we never know...
+ slf_i(jp_hpgi)%clname = 'NOT USED'
+ slf_i(jp_hpgj)%clname = 'NOT USED'
+ ENDIF
!
! !- allocate the bulk structure
@@ -264,21 +279,37 @@
DO jfpr= 1, jpfld
!
- IF( TRIM(sf(jfpr)%clrootname) == 'NOT USED' ) THEN !-- not used field --! (only now allocated and set to zero)
- ALLOCATE( sf(jfpr)%fnow(jpi,jpj,1) )
- sf(jfpr)%fnow(:,:,1) = 0._wp
+ IF( ln_abl .AND. &
+ & ( jfpr == jp_wndi .OR. jfpr == jp_wndj .OR. jfpr == jp_humi .OR. &
+ & jfpr == jp_hpgi .OR. jfpr == jp_hpgj .OR. jfpr == jp_tair ) ) THEN
+ ipka = jpka ! ABL: some fields are 3D input
+ ELSE
+ ipka = 1
+ ENDIF
+ !
+ ALLOCATE( sf(jfpr)%fnow(jpi,jpj,ipka) )
+ !
+ IF( TRIM(sf(jfpr)%clrootname) == 'NOT USED' ) THEN !-- not used field --! (only now allocated and set to default)
+ IF( jfpr == jp_slp ) THEN
+ sf(jfpr)%fnow(:,:,1:ipka) = 101325._wp ! use standard pressure in Pa
+ ELSEIF( jfpr == jp_prec .OR. jfpr == jp_snow .OR. jfpr == jp_uoatm .OR. jfpr == jp_voatm ) THEN
+ sf(jfpr)%fnow(:,:,1:ipka) = 0._wp ! no precip or no snow or no surface currents
+ ELSEIF( jfpr == jp_hpgi .OR. jfpr == jp_hpgj ) THEN
+ IF( .NOT. ln_abl ) THEN
+ DEALLOCATE( sf(jfpr)%fnow ) ! deallocate as not used in this case
+ ELSE
+ sf(jfpr)%fnow(:,:,1:ipka) = 0._wp
+ ENDIF
+ ELSEIF( jfpr == jp_cc ) THEN
+ sf(jp_cc)%fnow(:,:,1:ipka) = pp_cldf
+ ELSE
+ WRITE(ctmp1,*) 'sbc_blk_init: no default value defined for field number', jfpr
+ CALL ctl_stop( ctmp1 )
+ ENDIF
ELSE !-- used field --!
- IF( ln_abl .AND. &
- & ( jfpr == jp_wndi .OR. jfpr == jp_wndj .OR. jfpr == jp_humi .OR. &
- & jfpr == jp_hpgi .OR. jfpr == jp_hpgj .OR. jfpr == jp_tair ) ) THEN ! ABL: some fields are 3D input
- ALLOCATE( sf(jfpr)%fnow(jpi,jpj,jpka) )
- IF( sf(jfpr)%ln_tint ) ALLOCATE( sf(jfpr)%fdta(jpi,jpj,jpka,2) )
- ELSE ! others or Bulk fields are 2D fiels
- ALLOCATE( sf(jfpr)%fnow(jpi,jpj,1) )
- IF( sf(jfpr)%ln_tint ) ALLOCATE( sf(jfpr)%fdta(jpi,jpj,1,2) )
- ENDIF
+ IF( sf(jfpr)%ln_tint ) ALLOCATE( sf(jfpr)%fdta(jpi,jpj,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.', &
- & ' This is not ideal. You should consider changing either rn_Dt or nn_fsbc value...' )
+ & CALL ctl_warn( 'sbc_blk_init: sbcmod timestep rn_Dt*nn_fsbc is NOT a submultiple of atmospheric forcing frequency.', &
+ & ' This is not ideal. You should consider changing either rn_Dt or nn_fsbc value...' )
ENDIF
END DO
@@ -327,8 +358,13 @@
WRITE(numout,*) ' factor applied on precipitation (total & snow) rn_pfac = ', rn_pfac
WRITE(numout,*) ' factor applied on evaporation rn_efac = ', rn_efac
- WRITE(numout,*) ' factor applied on ocean/ice velocity rn_vfac = ', rn_vfac
WRITE(numout,*) ' (form absolute (=0) to relative winds(=1))'
WRITE(numout,*) ' use ice-atm drag from Lupkes2012 ln_Cd_L12 = ', ln_Cd_L12
WRITE(numout,*) ' use ice-atm drag from Lupkes2015 ln_Cd_L15 = ', ln_Cd_L15
+ WRITE(numout,*) ' use surface current feedback on wind stress ln_crt_fbk = ', ln_crt_fbk
+ IF(ln_crt_fbk) THEN
+ WRITE(numout,*) ' Renault et al. 2020, eq. 10: Stau = Alpha * Wnd + Beta'
+ WRITE(numout,*) ' Alpha rn_stau_a = ', rn_stau_a
+ WRITE(numout,*) ' Beta rn_stau_b = ', rn_stau_b
+ ENDIF
!
WRITE(numout,*)
@@ -429,14 +465,15 @@
! ! compute the surface ocean fluxes using bulk formulea
IF( MOD( kt - 1, nn_fsbc ) == 0 ) THEN
- CALL blk_oce_1( kt, sf(jp_wndi)%fnow(:,:,1), sf(jp_wndj)%fnow(:,:,1), & ! <<= in
- & sf(jp_tair)%fnow(:,:,1), sf(jp_humi)%fnow(:,:,1), & ! <<= in
- & sf(jp_slp )%fnow(:,:,1), sst_m, ssu_m, ssv_m, & ! <<= in
- & sf(jp_qsr )%fnow(:,:,1), sf(jp_qlw )%fnow(:,:,1), & ! <<= in (wl/cs)
- & tsk_m, zssq, zcd_du, zsen, zevp ) ! =>> out
-
- CALL blk_oce_2( sf(jp_tair)%fnow(:,:,1), sf(jp_qsr )%fnow(:,:,1), & ! <<= in
- & sf(jp_qlw )%fnow(:,:,1), sf(jp_prec)%fnow(:,:,1), & ! <<= in
- & sf(jp_snow)%fnow(:,:,1), tsk_m, & ! <<= in
- & zsen, zevp ) ! <=> in out
+ CALL blk_oce_1( kt, sf(jp_wndi )%fnow(:,:,1), sf(jp_wndj )%fnow(:,:,1), & ! <<= in
+ & sf(jp_tair )%fnow(:,:,1), sf(jp_humi )%fnow(:,:,1), & ! <<= in
+ & sf(jp_slp )%fnow(:,:,1), sst_m, ssu_m, ssv_m, & ! <<= 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, zevp ) ! =>> out
+
+ CALL blk_oce_2( sf(jp_tair )%fnow(:,:,1), sf(jp_qsr )%fnow(:,:,1), & ! <<= in
+ & sf(jp_qlw )%fnow(:,:,1), sf(jp_prec )%fnow(:,:,1), & ! <<= in
+ & sf(jp_snow )%fnow(:,:,1), tsk_m, & ! <<= in
+ & zsen, zevp ) ! <=> in out
ENDIF
!
@@ -470,8 +507,8 @@
- SUBROUTINE blk_oce_1( kt, pwndi, pwndj , ptair, phumi, & ! inp
- & pslp , pst , pu , pv, & ! inp
- & pqsr , pqlw , & ! inp
- & ptsk, pssq , pcd_du, psen , pevp ) ! out
+ SUBROUTINE blk_oce_1( kt, pwndi, pwndj, ptair, phumi, & ! inp
+ & pslp , pst , pu , pv, & ! inp
+ & puatm, pvatm, pqsr , pqlw , & ! inp
+ & ptsk , pssq , pcd_du, psen, pevp ) ! out
!!---------------------------------------------------------------------
!! *** ROUTINE blk_oce_1 ***
@@ -498,4 +535,6 @@
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(:,:) :: pqsr !
REAL(wp), INTENT(in ), DIMENSION(:,:) :: pqlw !
@@ -508,5 +547,9 @@
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
+#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) :: ztpot ! potential temperature of air at z=rn_zqt [K]
@@ -523,4 +566,7 @@
ptsk(:,:) = pst(:,:) + rt0 ! by default: skin temperature = "bulk SST" (will remain this way if NCAR algorithm used!)
+ ! --- cloud cover --- !
+ cloud_fra(:,:) = sf(jp_cc)%fnow(:,:,1)
+
! ----------------------------------------------------------------------------- !
! 0 Wind components and module at T-point relative to the moving ocean !
@@ -532,18 +578,16 @@
zwnd_j(:,:) = 0._wp
CALL wnd_cyc( kt, zwnd_i, zwnd_j ) ! add analytical tropical cyclone (Vincent et al. JGR 2012)
- DO_2D_00_00
- pwndi(ji,jj) = pwndi(ji,jj) + zwnd_i(ji,jj)
- pwndj(ji,jj) = pwndj(ji,jj) + zwnd_j(ji,jj)
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ 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)
+ wndm(ji,jj) = SQRT( zwnd_i(ji,jj) * zwnd_i(ji,jj) + zwnd_j(ji,jj) * zwnd_j(ji,jj) )
+ 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) )
END_2D
#endif
- DO_2D_00_00
- zwnd_i(ji,jj) = ( pwndi(ji,jj) - rn_vfac * 0.5 * ( pu(ji-1,jj ) + pu(ji,jj) ) )
- zwnd_j(ji,jj) = ( pwndj(ji,jj) - rn_vfac * 0.5 * ( pv(ji ,jj-1) + pv(ji,jj) ) )
- END_2D
- CALL lbc_lnk_multi( 'sbcblk', zwnd_i, 'T', -1., zwnd_j, 'T', -1. )
- ! ... scalar wind ( = | U10m - U_oce | ) at T-point (masked)
- wndm(:,:) = SQRT( zwnd_i(:,:) * zwnd_i(:,:) &
- & + zwnd_j(:,:) * zwnd_j(:,:) ) * tmask(:,:,1)
-
! ----------------------------------------------------------------------------- !
! I Solar FLUX !
@@ -593,10 +637,12 @@
!#LB: because AGRIF hates functions that return something else than a scalar, need to
! use scalar version of gamma_moist() ...
- DO_2D_11_11
- ztpot(ji,jj) = ptair(ji,jj) + gamma_moist( ptair(ji,jj), zqair(ji,jj) ) * rn_zqt
- END_2D
- ENDIF
-
-
+ IF( ln_tpot ) THEN
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ ztpot(ji,jj) = ptair(ji,jj) + gamma_moist( ptair(ji,jj), zqair(ji,jj) ) * rn_zqt
+ END_2D
+ ELSE
+ ztpot = ptair(:,:)
+ ENDIF
+ ENDIF
!! Time to call the user-selected bulk parameterization for
@@ -627,5 +673,16 @@
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))
+ !! LB: mainly here for debugging purpose:
+ IF( iom_use('theta_zt') ) CALL iom_put("theta_zt", (ztpot-rt0) * tmask(:,:,1)) ! potential temperature at z=zt
+ IF( iom_use('q_zt') ) CALL iom_put("q_zt", zqair * tmask(:,:,1)) ! specific humidity "
+ IF( iom_use('theta_zu') ) CALL iom_put("theta_zu", (t_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( ln_skin_cs .OR. ln_skin_wl ) THEN
!! ptsk and pssq have been updated!!!
@@ -639,32 +696,22 @@
END IF
- !! CALL iom_put( "Cd_oce", zcd_oce) ! output value of pure ocean-atm. transfer coef.
- !! CALL iom_put( "Ch_oce", zch_oce) ! output value of pure ocean-atm. transfer coef.
-
- IF( ABS(rn_zu - rn_zqt) < 0.1_wp ) THEN
- !! If zu == zt, then ensuring once for all that:
- t_zu(:,:) = ztpot(:,:)
- q_zu(:,:) = zqair(:,:)
- ENDIF
-
-
! Turbulent fluxes over ocean => BULK_FORMULA @ sbcblk_phy.F90
! -------------------------------------------------------------
IF( ln_abl ) THEN !== ABL formulation ==! multiplication by rho_air and turbulent fluxes computation done in ablstp
- !! FL do we need this multiplication by tmask ... ???
- DO_2D_11_11
- zztmp = zU_zu(ji,jj) !* tmask(ji,jj,1)
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ 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)
psen(ji,jj) = zztmp * zch_oce(ji,jj)
pevp(ji,jj) = zztmp * zce_oce(ji,jj)
+ rhoa(ji,jj) = rho_air( ptair(ji,jj), phumi(ji,jj), pslp(ji,jj) )
END_2D
ELSE !== BLK formulation ==! turbulent fluxes computation
CALL BULK_FORMULA( rn_zu, ptsk(:,:), pssq(:,:), t_zu(:,:), q_zu(:,:), &
- & zcd_oce(:,:), zch_oce(:,:), zce_oce(:,:), &
- & wndm(:,:), zU_zu(:,:), pslp(:,:), &
- & taum(:,:), psen(:,:), zqla(:,:), &
- & pEvap=pevp(:,:), prhoa=rhoa(:,:) )
+ & zcd_oce(:,:), zch_oce(:,:), zce_oce(:,:), &
+ & wndm(:,:), zU_zu(:,:), pslp(:,:), &
+ & taum(:,:), psen(:,:), zqla(:,:), &
+ & pEvap=pevp(:,:), prhoa=rhoa(:,:), pfact_evap=rn_efac )
zqla(:,:) = zqla(:,:) * tmask(:,:,1)
@@ -673,22 +720,47 @@
pevp(:,:) = pevp(:,:) * tmask(:,:,1)
- ! Tau i and j component on T-grid points, using array "zcd_oce" as a temporary array...
- zcd_oce = 0._wp
- WHERE ( wndm > 0._wp ) zcd_oce = taum / wndm
- zwnd_i = zcd_oce * zwnd_i
- zwnd_j = zcd_oce * zwnd_j
-
- CALL iom_put( "taum_oce", taum ) ! output wind stress module
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ IF( wndm(ji,jj) > 0._wp ) THEN
+ 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)
+#else
+ ztau_i(ji,jj) = zztmp * pwndi(ji,jj)
+ ztau_j(ji,jj) = zztmp * pwndj(ji,jj)
+#endif
+ ELSE
+ ztau_i(ji,jj) = 0._wp
+ ztau_j(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) )
+ END_2D
+ 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 the use of MAX(tmask(i,j),tmask(i+1,j) is to mask tau over ice shelves
- DO_2D_10_10
- utau(ji,jj) = 0.5 * ( 2. - umask(ji,jj,1) ) * ( zwnd_i(ji,jj) + zwnd_i(ji+1,jj ) ) &
- & * MAX(tmask(ji,jj,1),tmask(ji+1,jj,1))
- vtau(ji,jj) = 0.5 * ( 2. - vmask(ji,jj,1) ) * ( zwnd_j(ji,jj) + zwnd_j(ji ,jj+1) ) &
- & * MAX(tmask(ji,jj,1),tmask(ji,jj+1,1))
+ ! 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
- CALL lbc_lnk_multi( 'sbcblk', utau, 'U', -1., vtau, 'V', -1. )
+
+ IF( ln_crt_fbk ) THEN
+ CALL lbc_lnk_multi( 'sbcblk', utau, 'U', -1., vtau, 'V', -1., taum, 'T', -1. )
+ ELSE
+ CALL lbc_lnk_multi( 'sbcblk', utau, 'U', -1., vtau, 'V', -1. )
+ ENDIF
+
+ CALL iom_put( "taum_oce", taum ) ! output wind stress module
IF(sn_cfctl%l_prtctl) THEN
@@ -766,5 +838,5 @@
! use scalar version of L_vap() for AGRIF compatibility
- DO_2D_11_11
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
zqla(ji,jj) = - L_vap( ztskk(ji,jj) ) * pevp(ji,jj) ! Latent Heat flux !!GS: possibility to add a global qla to avoid recomputation after abl update
END_2D
@@ -861,5 +933,4 @@
!
INTEGER :: ji, jj ! dummy loop indices
- REAL(wp) :: zwndi_t , zwndj_t ! relative wind components at T-point
REAL(wp) :: zootm_su ! sea-ice surface mean temperature
REAL(wp) :: zztmp1, zztmp2 ! temporary arrays
@@ -872,10 +943,7 @@
! ------------------------------------------------------------ !
! C-grid ice dynamics : U & V-points (same as ocean)
- DO_2D_00_00
- zwndi_t = ( pwndi(ji,jj) - rn_vfac * 0.5_wp * ( puice(ji-1,jj ) + puice(ji,jj) ) )
- zwndj_t = ( pwndj(ji,jj) - rn_vfac * 0.5_wp * ( pvice(ji ,jj-1) + pvice(ji,jj) ) )
- wndm_ice(ji,jj) = SQRT( zwndi_t * zwndi_t + zwndj_t * zwndj_t ) * tmask(ji,jj,1)
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ wndm_ice(ji,jj) = SQRT( pwndi(ji,jj) * pwndi(ji,jj) + pwndj(ji,jj) * pwndj(ji,jj) )
END_2D
- CALL lbc_lnk( 'sbcblk', wndm_ice, 'T', 1. )
!
! Make ice-atm. drag dependent on ice concentration
@@ -888,33 +956,37 @@
Ce_ice(:,:) = Ch_ice(:,:) ! sensible and latent heat transfer coef. are considered identical
ENDIF
-
- !! IF ( iom_use("Cd_ice") ) CALL iom_put("Cd_ice", Cd_ice) ! output value of pure ice-atm. transfer coef.
- !! IF ( iom_use("Ch_ice") ) CALL iom_put("Ch_ice", Ch_ice) ! output value of pure ice-atm. transfer coef.
-
+
+ IF( iom_use('Cd_ice') ) CALL iom_put("Cd_ice", Cd_ice)
+ IF( iom_use('Ce_ice') ) CALL iom_put("Ce_ice", Ce_ice)
+ IF( iom_use('Ch_ice') ) CALL iom_put("Ch_ice", Ch_ice)
+
! local scalars ( place there for vector optimisation purposes)
- !IF (ln_abl) rhoa (:,:) = rho_air( ptair(:,:), phumi(:,:), pslp(:,:) ) !!GS: rhoa must be (re)computed here with ABL to avoid division by zero after (TBI)
zcd_dui(:,:) = wndm_ice(:,:) * Cd_ice(:,:)
IF( ln_blk ) THEN
- ! ------------------------------------------------------------ !
- ! Wind stress relative to the moving ice ( U10m - U_ice ) !
- ! ------------------------------------------------------------ !
- ! C-grid ice dynamics : U & V-points (same as ocean)
- DO_2D_00_00
- putaui(ji,jj) = 0.5_wp * ( rhoa(ji+1,jj) * zcd_dui(ji+1,jj) &
- & + rhoa(ji ,jj) * zcd_dui(ji ,jj) ) &
- & * ( 0.5_wp * ( pwndi(ji+1,jj) + pwndi(ji,jj) ) - rn_vfac * puice(ji,jj) )
- pvtaui(ji,jj) = 0.5_wp * ( rhoa(ji,jj+1) * zcd_dui(ji,jj+1) &
- & + rhoa(ji,jj ) * zcd_dui(ji,jj ) ) &
- & * ( 0.5_wp * ( pwndj(ji,jj+1) + pwndj(ji,jj) ) - rn_vfac * pvice(ji,jj) )
+ ! ---------------------------------------------------- !
+ ! 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
+ putaui(ji,jj) = rhoa(ji,jj) * zcd_dui(ji,jj) * pwndi(ji,jj)
+ pvtaui(ji,jj) = rhoa(ji,jj) * zcd_dui(ji,jj) * pwndj(ji,jj)
END_2D
- CALL lbc_lnk_multi( 'sbcblk', putaui, 'U', -1., pvtaui, 'V', -1. )
+ !
+ DO_2D( 0, 0, 0, 0 ) ! U & V-points (same as ocean).
+ ! 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_multi( 'sbcblk', putaui, 'U', -1._wp, pvtaui, 'V', -1._wp )
!
IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=putaui , clinfo1=' blk_ice: putaui : ' &
& , tab2d_2=pvtaui , clinfo2=' pvtaui : ' )
- ELSE
+ ELSE ! ln_abl
zztmp1 = 11637800.0_wp
zztmp2 = -5897.8_wp
- DO_2D_11_11
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
pcd_dui(ji,jj) = zcd_dui (ji,jj)
pseni (ji,jj) = wndm_ice(ji,jj) * Ch_ice(ji,jj)
@@ -957,5 +1029,4 @@
REAL(wp) :: zcoef_dqlw, zcoef_dqla ! - -
REAL(wp) :: zztmp, zztmp2, z1_rLsub ! - -
- REAL(wp) :: zfr1, zfr2 ! local variables
REAL(wp), DIMENSION(jpi,jpj,jpl) :: z1_st ! inverse of surface temperature
REAL(wp), DIMENSION(jpi,jpj,jpl) :: z_qlw ! long wave heat flux over ice
@@ -966,4 +1037,5 @@
REAL(wp), DIMENSION(jpi,jpj) :: zqair ! specific humidity of air at z=rn_zqt [kg/kg] !LB
REAL(wp), DIMENSION(jpi,jpj) :: ztmp, ztmp2
+ REAL(wp), DIMENSION(jpi,jpj) :: ztri
!!---------------------------------------------------------------------
!
@@ -1046,9 +1118,9 @@
evap_ice (:,:,:) = rn_efac * qla_ice (:,:,:) * z1_rLsub ! sublimation
devap_ice(:,:,:) = rn_efac * dqla_ice(:,:,:) * z1_rLsub ! d(sublimation)/dT
- zevap (:,:) = rn_efac * ( emp(:,:) + tprecip(:,:) ) ! evaporation over ocean
+ zevap (:,:) = emp(:,:) + tprecip(:,:) ! evaporation over ocean !LB: removed rn_efac here, correct???
! --- evaporation minus precipitation --- !
zsnw(:,:) = 0._wp
- CALL ice_thd_snwblow( (1.-at_i_b(:,:)), zsnw ) ! snow distribution over ice after wind blowing
+ 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
@@ -1077,17 +1149,27 @@
END DO
- ! --- shortwave radiation transmitted below the surface (W/m2, see Grenfell Maykut 77) --- !
- zfr1 = ( 0.18 * ( 1.0 - cldf_ice ) + 0.35 * cldf_ice ) ! transmission when hi>10cm
- zfr2 = ( 0.82 * ( 1.0 - cldf_ice ) + 0.65 * cldf_ice ) ! 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
- qtr_ice_top(:,:,:) = qsr_ice(:,:,:) * zfr1
- ELSEWHERE ! zero when hs>0
- qtr_ice_top(:,:,:) = 0._wp
- END WHERE
- !
-
+ ! --- shortwave radiation transmitted thru the surface scattering layer (W/m2) --- !
+ IF( nn_qtrice == 0 ) THEN
+ ! formulation derived from Grenfell and Maykut (1977), where transmission rate
+ ! 1) depends on cloudiness
+ ! 2) is 0 when there is any snow
+ ! 3) tends to 1 for thin ice
+ 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
+ qtr_ice_top(:,:,jl) = qsr_ice(:,:,jl) * ztri(:,:)
+ ELSEWHERE ! zero when hs>0
+ qtr_ice_top(:,:,jl) = 0._wp
+ END WHERE
+ ENDDO
+ ELSEIF( nn_qtrice == 1 ) THEN
+ ! formulation is derived from the thesis of M. Lebrun (2019).
+ ! It represents the best fit using several sets of observations
+ ! It comes with snow conductivities adapted to freezing/melting conditions (see icethd_zdf_bl99.F90)
+ qtr_ice_top(:,:,:) = 0.3_wp * qsr_ice(:,:,:)
+ ENDIF
+ !
IF( iom_use('evap_ao_cea') .OR. iom_use('hflx_evap_cea') ) THEN
ztmp(:,:) = zevap(:,:) * ( 1._wp - at_i_b(:,:) )
@@ -1171,5 +1253,5 @@
!
DO jl = 1, jpl
- DO_2D_11_11
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
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
@@ -1186,5 +1268,5 @@
!
DO jl = 1, jpl
- DO_2D_11_11
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
!
zkeff_h = zfac * zgfac(ji,jj,jl) / & ! Effective conductivity of the snow-ice system divided by thickness
@@ -1334,5 +1416,5 @@
zqi_sat(:,:) = q_sat( ptm_su(:,:), pslp(:,:) ) ! saturation humidity over ice [kg/kg]
!
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
! Virtual potential temperature [K]
zthetav_os = zst(ji,jj) * ( 1._wp + rctv0 * zqo_sat(ji,jj) ) ! over ocean
@@ -1377,5 +1459,5 @@
!
END_2D
- CALL lbc_lnk_multi( 'sbcblk', pcd, 'T', 1., pch, 'T', 1. )
+ CALL lbc_lnk_multi( 'sbcblk', pcd, 'T', 1.0_wp, pch, 'T', 1.0_wp )
!
END SUBROUTINE Cdn10_Lupkes2015
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcblk_algo_coare3p0.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcblk_algo_coare3p0.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcblk_algo_coare3p0.F90 (revision 13540)
@@ -194,6 +194,5 @@
IF( kt == nit000 ) CALL SBCBLK_ALGO_COARE3P0_INIT(l_use_cs, l_use_wl)
- l_zt_equal_zu = .FALSE.
- IF( ABS(zu - zt) < 0.01_wp ) l_zt_equal_zu = .TRUE. ! testing "zu == zt" is risky with double precision
+ 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) )
@@ -395,16 +394,16 @@
!!-------------------------------------------------------------------
!
- DO_2D_11_11
- !
- zw = pwnd(ji,jj) ! wind speed
- !
- ! Charnock's constant, increases with the wind :
- zgt10 = 0.5 + SIGN(0.5_wp,(zw - 10)) ! If zw<10. --> 0, else --> 1
- zgt18 = 0.5 + SIGN(0.5_wp,(zw - 18.)) ! If zw<18. --> 0, else --> 1
- !
- alfa_charn_3p0(ji,jj) = (1. - zgt10)*0.011 & ! wind is lower than 10 m/s
- & + zgt10*((1. - zgt18)*(0.011 + (0.018 - 0.011) &
- & *(zw - 10.)/(18. - 10.)) + zgt18*( 0.018 ) ) ! Hare et al. (1999)
- !
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ !
+ zw = pwnd(ji,jj) ! wind speed
+ !
+ ! Charnock's constant, increases with the wind :
+ zgt10 = 0.5 + SIGN(0.5_wp,(zw - 10)) ! If zw<10. --> 0, else --> 1
+ zgt18 = 0.5 + SIGN(0.5_wp,(zw - 18.)) ! If zw<18. --> 0, else --> 1
+ !
+ alfa_charn_3p0(ji,jj) = (1. - zgt10)*0.011 & ! wind is lower than 10 m/s
+ & + zgt10*((1. - zgt18)*(0.011 + (0.018 - 0.011) &
+ & *(zw - 10.)/(18. - 10.)) + zgt18*( 0.018 ) ) ! Hare et al. (1999)
+ !
END_2D
!
@@ -431,27 +430,27 @@
!!----------------------------------------------------------------------------------
!
- DO_2D_11_11
- !
- zta = pzeta(ji,jj)
- !
- zphi_m = ABS(1. - 15.*zta)**.25 !!Kansas unstable
- !
- zpsi_k = 2.*LOG((1. + zphi_m)/2.) + LOG((1. + zphi_m*zphi_m)/2.) &
- & - 2.*ATAN(zphi_m) + 0.5*rpi
- !
- zphi_c = ABS(1. - 10.15*zta)**.3333 !!Convective
- !
- zpsi_c = 1.5*LOG((1. + zphi_c + zphi_c*zphi_c)/3.) &
- & - 1.7320508*ATAN((1. + 2.*zphi_c)/1.7320508) + 1.813799447
- !
- zf = zta*zta
- zf = zf/(1. + zf)
- zc = MIN(50._wp, 0.35_wp*zta)
- zstab = 0.5 + SIGN(0.5_wp, zta)
- !
- psi_m_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) & ! (zta < 0)
- & - zstab * ( 1. + 1.*zta & ! (zta > 0)
- & + 0.6667*(zta - 14.28)/EXP(zc) + 8.525 ) ! "
- !
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ !
+ zta = pzeta(ji,jj)
+ !
+ zphi_m = ABS(1. - 15.*zta)**.25 !!Kansas unstable
+ !
+ zpsi_k = 2.*LOG((1. + zphi_m)/2.) + LOG((1. + zphi_m*zphi_m)/2.) &
+ & - 2.*ATAN(zphi_m) + 0.5*rpi
+ !
+ zphi_c = ABS(1. - 10.15*zta)**.3333 !!Convective
+ !
+ zpsi_c = 1.5*LOG((1. + zphi_c + zphi_c*zphi_c)/3.) &
+ & - 1.7320508*ATAN((1. + 2.*zphi_c)/1.7320508) + 1.813799447
+ !
+ zf = zta*zta
+ zf = zf/(1. + zf)
+ zc = MIN(50._wp, 0.35_wp*zta)
+ zstab = 0.5 + SIGN(0.5_wp, zta)
+ !
+ psi_m_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) & ! (zta < 0)
+ & - zstab * ( 1. + 1.*zta & ! (zta > 0)
+ & + 0.6667*(zta - 14.28)/EXP(zc) + 8.525 ) ! "
+ !
END_2D
!
@@ -482,26 +481,26 @@
REAL(wp) :: zta, zphi_h, zphi_c, zpsi_k, zpsi_c, zf, zc, zstab
!
- DO_2D_11_11
- !
- zta = pzeta(ji,jj)
- !
- zphi_h = (ABS(1. - 15.*zta))**.5 !! Kansas unstable (zphi_h = zphi_m**2 when unstable, zphi_m when stable)
- !
- zpsi_k = 2.*LOG((1. + zphi_h)/2.)
- !
- zphi_c = (ABS(1. - 34.15*zta))**.3333 !! Convective
- !
- zpsi_c = 1.5*LOG((1. + zphi_c + zphi_c*zphi_c)/3.) &
- & -1.7320508*ATAN((1. + 2.*zphi_c)/1.7320508) + 1.813799447
- !
- zf = zta*zta
- zf = zf/(1. + zf)
- zc = MIN(50._wp,0.35_wp*zta)
- zstab = 0.5 + SIGN(0.5_wp, zta)
- !
- psi_h_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) &
- & - zstab * ( (ABS(1. + 2.*zta/3.))**1.5 &
- & + .6667*(zta - 14.28)/EXP(zc) + 8.525 )
- !
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ !
+ zta = pzeta(ji,jj)
+ !
+ zphi_h = (ABS(1. - 15.*zta))**.5 !! Kansas unstable (zphi_h = zphi_m**2 when unstable, zphi_m when stable)
+ !
+ zpsi_k = 2.*LOG((1. + zphi_h)/2.)
+ !
+ zphi_c = (ABS(1. - 34.15*zta))**.3333 !! Convective
+ !
+ zpsi_c = 1.5*LOG((1. + zphi_c + zphi_c*zphi_c)/3.) &
+ & -1.7320508*ATAN((1. + 2.*zphi_c)/1.7320508) + 1.813799447
+ !
+ zf = zta*zta
+ zf = zf/(1. + zf)
+ zc = MIN(50._wp,0.35_wp*zta)
+ zstab = 0.5 + SIGN(0.5_wp, zta)
+ !
+ psi_h_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) &
+ & - zstab * ( (ABS(1. + 2.*zta/3.))**1.5 &
+ & + .6667*(zta - 14.28)/EXP(zc) + 8.525 )
+ !
END_2D
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcblk_algo_coare3p6.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcblk_algo_coare3p6.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcblk_algo_coare3p6.F90 (revision 13540)
@@ -194,6 +194,5 @@
IF( kt == nit000 ) CALL SBCBLK_ALGO_COARE3P6_INIT(l_use_cs, l_use_wl)
- l_zt_equal_zu = .FALSE.
- IF( ABS(zu - zt) < 0.01_wp ) l_zt_equal_zu = .TRUE. ! testing "zu == zt" is risky with double precision
+ 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) )
@@ -431,27 +430,27 @@
!!----------------------------------------------------------------------------------
!
- DO_2D_11_11
- !
- zta = pzeta(ji,jj)
- !
- zphi_m = ABS(1. - 15.*zta)**.25 !!Kansas unstable
- !
- zpsi_k = 2.*LOG((1. + zphi_m)/2.) + LOG((1. + zphi_m*zphi_m)/2.) &
- & - 2.*ATAN(zphi_m) + 0.5*rpi
- !
- zphi_c = ABS(1. - 10.15*zta)**.3333 !!Convective
- !
- zpsi_c = 1.5*LOG((1. + zphi_c + zphi_c*zphi_c)/3.) &
- & - 1.7320508*ATAN((1. + 2.*zphi_c)/1.7320508) + 1.813799447
- !
- zf = zta*zta
- zf = zf/(1. + zf)
- zc = MIN(50._wp, 0.35_wp*zta)
- zstab = 0.5 + SIGN(0.5_wp, zta)
- !
- psi_m_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) & ! (zta < 0)
- & - zstab * ( 1. + 1.*zta & ! (zta > 0)
- & + 0.6667*(zta - 14.28)/EXP(zc) + 8.525 ) ! "
- !
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ !
+ zta = pzeta(ji,jj)
+ !
+ zphi_m = ABS(1. - 15.*zta)**.25 !!Kansas unstable
+ !
+ zpsi_k = 2.*LOG((1. + zphi_m)/2.) + LOG((1. + zphi_m*zphi_m)/2.) &
+ & - 2.*ATAN(zphi_m) + 0.5*rpi
+ !
+ zphi_c = ABS(1. - 10.15*zta)**.3333 !!Convective
+ !
+ zpsi_c = 1.5*LOG((1. + zphi_c + zphi_c*zphi_c)/3.) &
+ & - 1.7320508*ATAN((1. + 2.*zphi_c)/1.7320508) + 1.813799447
+ !
+ zf = zta*zta
+ zf = zf/(1. + zf)
+ zc = MIN(50._wp, 0.35_wp*zta)
+ zstab = 0.5 + SIGN(0.5_wp, zta)
+ !
+ psi_m_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) & ! (zta < 0)
+ & - zstab * ( 1. + 1.*zta & ! (zta > 0)
+ & + 0.6667*(zta - 14.28)/EXP(zc) + 8.525 ) ! "
+ !
END_2D
!
@@ -482,26 +481,26 @@
REAL(wp) :: zta, zphi_h, zphi_c, zpsi_k, zpsi_c, zf, zc, zstab
!
- DO_2D_11_11
- !
- zta = pzeta(ji,jj)
- !
- zphi_h = (ABS(1. - 15.*zta))**.5 !! Kansas unstable (zphi_h = zphi_m**2 when unstable, zphi_m when stable)
- !
- zpsi_k = 2.*LOG((1. + zphi_h)/2.)
- !
- zphi_c = (ABS(1. - 34.15*zta))**.3333 !! Convective
- !
- zpsi_c = 1.5*LOG((1. + zphi_c + zphi_c*zphi_c)/3.) &
- & -1.7320508*ATAN((1. + 2.*zphi_c)/1.7320508) + 1.813799447
- !
- zf = zta*zta
- zf = zf/(1. + zf)
- zc = MIN(50._wp,0.35_wp*zta)
- zstab = 0.5 + SIGN(0.5_wp, zta)
- !
- psi_h_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) &
- & - zstab * ( (ABS(1. + 2.*zta/3.))**1.5 &
- & + .6667*(zta - 14.28)/EXP(zc) + 8.525 )
- !
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ !
+ zta = pzeta(ji,jj)
+ !
+ zphi_h = (ABS(1. - 15.*zta))**.5 !! Kansas unstable (zphi_h = zphi_m**2 when unstable, zphi_m when stable)
+ !
+ zpsi_k = 2.*LOG((1. + zphi_h)/2.)
+ !
+ zphi_c = (ABS(1. - 34.15*zta))**.3333 !! Convective
+ !
+ zpsi_c = 1.5*LOG((1. + zphi_c + zphi_c*zphi_c)/3.) &
+ & -1.7320508*ATAN((1. + 2.*zphi_c)/1.7320508) + 1.813799447
+ !
+ zf = zta*zta
+ zf = zf/(1. + zf)
+ zc = MIN(50._wp,0.35_wp*zta)
+ zstab = 0.5 + SIGN(0.5_wp, zta)
+ !
+ psi_h_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) &
+ & - zstab * ( (ABS(1. + 2.*zta/3.))**1.5 &
+ & + .6667*(zta - 14.28)/EXP(zc) + 8.525 )
+ !
END_2D
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcblk_algo_ecmwf.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcblk_algo_ecmwf.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcblk_algo_ecmwf.F90 (revision 13540)
@@ -98,5 +98,5 @@
& Qsw, rad_lw, slp, pdT_cs, & ! optionals for cool-skin (and warm-layer)
& pdT_wl, pHz_wl ) ! optionals for warm-layer only
- !!----------------------------------------------------------------------
+ !!----------------------------------------------------------------------------------
!! *** ROUTINE turb_ecmwf ***
!!
@@ -184,7 +184,7 @@
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) :: 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
@@ -196,9 +196,7 @@
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)
- l_zt_equal_zu = .FALSE.
- IF( ABS(zu - zt) < 0.01_wp ) l_zt_equal_zu = .TRUE. ! testing "zu == zt" is risky with double precision
+ l_zt_equal_zu = ( ABS(zu - zt) < 0.01_wp ) ! testing "zu == zt" is risky with double precision
!! Initializations for cool skin and warm layer:
@@ -412,27 +410,27 @@
REAL(wp) :: zzeta, zx, ztmp, psi_unst, psi_stab, stab
!!----------------------------------------------------------------------------------
- DO_2D_11_11
- !
- zzeta = MIN( pzeta(ji,jj) , 5._wp ) !! Very stable conditions (L positif and big!):
- !
- ! Unstable (Paulson 1970):
- ! eq.3.20, Chap.3, p.33, IFS doc - Cy31r1
- zx = SQRT(ABS(1._wp - 16._wp*zzeta))
- ztmp = 1._wp + SQRT(zx)
- ztmp = ztmp*ztmp
- psi_unst = LOG( 0.125_wp*ztmp*(1._wp + zx) ) &
- & -2._wp*ATAN( SQRT(zx) ) + 0.5_wp*rpi
- !
- ! Unstable:
- ! eq.3.22, Chap.3, p.33, IFS doc - Cy31r1
- psi_stab = -2._wp/3._wp*(zzeta - 5._wp/0.35_wp)*EXP(-0.35_wp*zzeta) &
- & - zzeta - 2._wp/3._wp*5._wp/0.35_wp
- !
- ! Combining:
- stab = 0.5_wp + SIGN(0.5_wp, zzeta) ! zzeta > 0 => stab = 1
- !
- psi_m_ecmwf(ji,jj) = (1._wp - stab) * psi_unst & ! (zzeta < 0) Unstable
- & + stab * psi_stab ! (zzeta > 0) Stable
- !
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ !
+ zzeta = MIN( pzeta(ji,jj) , 5._wp ) !! Very stable conditions (L positif and big!):
+ !
+ ! Unstable (Paulson 1970):
+ ! eq.3.20, Chap.3, p.33, IFS doc - Cy31r1
+ zx = SQRT(ABS(1._wp - 16._wp*zzeta))
+ ztmp = 1._wp + SQRT(zx)
+ ztmp = ztmp*ztmp
+ psi_unst = LOG( 0.125_wp*ztmp*(1._wp + zx) ) &
+ & -2._wp*ATAN( SQRT(zx) ) + 0.5_wp*rpi
+ !
+ ! Unstable:
+ ! eq.3.22, Chap.3, p.33, IFS doc - Cy31r1
+ psi_stab = -2._wp/3._wp*(zzeta - 5._wp/0.35_wp)*EXP(-0.35_wp*zzeta) &
+ & - zzeta - 2._wp/3._wp*5._wp/0.35_wp
+ !
+ ! Combining:
+ stab = 0.5_wp + SIGN(0.5_wp, zzeta) ! zzeta > 0 => stab = 1
+ !
+ psi_m_ecmwf(ji,jj) = (1._wp - stab) * psi_unst & ! (zzeta < 0) Unstable
+ & + stab * psi_stab ! (zzeta > 0) Stable
+ !
END_2D
END FUNCTION psi_m_ecmwf
@@ -457,24 +455,24 @@
!!----------------------------------------------------------------------------------
!
- DO_2D_11_11
- !
- zzeta = MIN(pzeta(ji,jj) , 5._wp) ! Very stable conditions (L positif and big!):
- !
- zx = ABS(1._wp - 16._wp*zzeta)**.25 ! this is actually (1/phi_m)**2 !!!
- ! ! eq.3.19, Chap.3, p.33, IFS doc - Cy31r1
- ! Unstable (Paulson 1970) :
- psi_unst = 2._wp*LOG(0.5_wp*(1._wp + zx*zx)) ! eq.3.20, Chap.3, p.33, IFS doc - Cy31r1
- !
- ! Stable:
- psi_stab = -2._wp/3._wp*(zzeta - 5._wp/0.35_wp)*EXP(-0.35_wp*zzeta) & ! eq.3.22, Chap.3, p.33, IFS doc - Cy31r1
- & - ABS(1._wp + 2._wp/3._wp*zzeta)**1.5_wp - 2._wp/3._wp*5._wp/0.35_wp + 1._wp
- ! LB: added ABS() to avoid NaN values when unstable, which contaminates the unstable solution...
- !
- stab = 0.5_wp + SIGN(0.5_wp, zzeta) ! zzeta > 0 => stab = 1
- !
- !
- psi_h_ecmwf(ji,jj) = (1._wp - stab) * psi_unst & ! (zzeta < 0) Unstable
- & + stab * psi_stab ! (zzeta > 0) Stable
- !
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ !
+ zzeta = MIN(pzeta(ji,jj) , 5._wp) ! Very stable conditions (L positif and big!):
+ !
+ zx = ABS(1._wp - 16._wp*zzeta)**.25 ! this is actually (1/phi_m)**2 !!!
+ ! ! eq.3.19, Chap.3, p.33, IFS doc - Cy31r1
+ ! Unstable (Paulson 1970) :
+ psi_unst = 2._wp*LOG(0.5_wp*(1._wp + zx*zx)) ! eq.3.20, Chap.3, p.33, IFS doc - Cy31r1
+ !
+ ! Stable:
+ psi_stab = -2._wp/3._wp*(zzeta - 5._wp/0.35_wp)*EXP(-0.35_wp*zzeta) & ! eq.3.22, Chap.3, p.33, IFS doc - Cy31r1
+ & - ABS(1._wp + 2._wp/3._wp*zzeta)**1.5_wp - 2._wp/3._wp*5._wp/0.35_wp + 1._wp
+ ! LB: added ABS() to avoid NaN values when unstable, which contaminates the unstable solution...
+ !
+ stab = 0.5_wp + SIGN(0.5_wp, zzeta) ! zzeta > 0 => stab = 1
+ !
+ !
+ psi_h_ecmwf(ji,jj) = (1._wp - stab) * psi_unst & ! (zzeta < 0) Unstable
+ & + stab * psi_stab ! (zzeta > 0) Stable
+ !
END_2D
END FUNCTION psi_h_ecmwf
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcblk_algo_ncar.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcblk_algo_ncar.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcblk_algo_ncar.F90 (revision 13540)
@@ -112,7 +112,5 @@
REAL(wp), DIMENSION(jpi,jpj) :: stab ! stability test integer
!!----------------------------------------------------------------------------------
- !
- l_zt_equal_zu = .FALSE.
- IF( ABS(zu - zt) < 0.01_wp ) l_zt_equal_zu = .TRUE. ! testing "zu == zt" is risky with double precision
+ l_zt_equal_zu = ( ABS(zu - zt) < 0.01_wp ) ! testing "zu == zt" is risky with double precision
U_blk = MAX( 0.5_wp , U_zu ) ! relative wind speed at zu (normally 10m), we don't want to fall under 0.5 m/s
@@ -143,6 +141,7 @@
ENDIF
- !! Initializing values at z_u with z_t values:
- t_zu = t_zt ; q_zu = q_zt
+ !! First guess of temperature and humidity at height zu:
+ t_zu = MAX( t_zt , 180._wp ) ! who knows what's given on masked-continental regions...
+ q_zu = MAX( q_zt , 1.e-6_wp ) ! "
!! ITERATION BLOCK
@@ -242,5 +241,5 @@
!!----------------------------------------------------------------------------------
!
- DO_2D_11_11
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
!
zw = pw10(ji,jj)
@@ -278,5 +277,5 @@
REAL(wp) :: zx2, zx, zstab ! local scalars
!!----------------------------------------------------------------------------------
- DO_2D_11_11
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
zx2 = SQRT( ABS( 1._wp - 16._wp*pzeta(ji,jj) ) )
zx2 = MAX( zx2 , 1._wp )
@@ -309,5 +308,5 @@
!!----------------------------------------------------------------------------------
!
- DO_2D_11_11
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
zx2 = SQRT( ABS( 1._wp - 16._wp*pzeta(ji,jj) ) )
zx2 = MAX( zx2 , 1._wp )
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcblk_phy.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcblk_phy.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcblk_phy.F90 (revision 13540)
@@ -31,5 +31,5 @@
REAL(wp), PARAMETER, PUBLIC :: R_vap = 461.495_wp !: Specific gas constant for water vapor [J/K/kg]
REAL(wp), PARAMETER, PUBLIC :: reps0 = R_dry/R_vap !: ratio of gas constant for dry air and water vapor => ~ 0.622
- REAL(wp), PARAMETER, PUBLIC :: rctv0 = R_vap/R_dry !: for virtual temperature (== (1-eps)/eps) => ~ 0.608
+ REAL(wp), PARAMETER, PUBLIC :: rctv0 = R_vap/R_dry - 1._wp !: for virtual temperature (== (1-eps)/eps) => ~ 0.608
REAL(wp), PARAMETER, PUBLIC :: rCp_air = 1000.5_wp !: specific heat of air (only used for ice fluxes now...)
REAL(wp), PARAMETER, PUBLIC :: rCd_ice = 1.4e-3_wp !: transfer coefficient over ice
@@ -181,5 +181,5 @@
!!----------------------------------------------------------------------------------
!
- DO_2D_11_11
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
ztc = ptak(ji,jj) - rt0 ! air temp, in deg. C
ztc2 = ztc*ztc
@@ -270,5 +270,5 @@
INTEGER :: ji, jj ! dummy loop indices
!!----------------------------------------------------------------------------------
- DO_2D_11_11
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
gamma_moist_vctr(ji,jj) = gamma_moist_sclr( ptak(ji,jj), pqa(ji,jj) )
END_2D
@@ -315,5 +315,5 @@
!!-------------------------------------------------------------------
!
- DO_2D_11_11
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
!
zqa = (1._wp + rctv0*pqa(ji,jj))
@@ -351,5 +351,5 @@
!!-------------------------------------------------------------------
!
- DO_2D_11_11
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
!
zqa = 0.5_wp*(pqa(ji,jj)+pssq(ji,jj)) ! ~ mean q within the layer...
@@ -448,5 +448,5 @@
!!----------------------------------------------------------------------------------
!
- DO_2D_11_11
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
!
ze_sat = e_sat_sclr( ptak(ji,jj) )
@@ -473,5 +473,5 @@
!!----------------------------------------------------------------------------------
!
- DO_2D_11_11
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
ze = prha(ji,jj)*e_sat_sclr(ptak(ji,jj))
q_air_rh(ji,jj) = ze*reps0/(pslp(ji,jj) - (1. - reps0)*ze)
@@ -511,5 +511,5 @@
INTEGER :: ji, jj ! dummy loop indices
!!----------------------------------------------------------------------------------
- DO_2D_11_11
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
zdt = pTa(ji,jj) - pTs(ji,jj) ; zdt = SIGN( MAX(ABS(zdt),1.E-6_wp), zdt )
@@ -520,9 +520,9 @@
zCe = zz0*pqst(ji,jj)/zdq
- CALL BULK_FORMULA( pzu, pTs(ji,jj), pqs(ji,jj), pTa(ji,jj), pqa(ji,jj), &
- & zCd, zCh, zCe, &
- & pwnd(ji,jj), pUb(ji,jj), pslp(ji,jj), &
- & pTau(ji,jj), zQsen, zQlat )
-
+ CALL BULK_FORMULA_SCLR( pzu, pTs(ji,jj), pqs(ji,jj), pTa(ji,jj), pqa(ji,jj), &
+ & zCd, zCh, zCe, &
+ & pwnd(ji,jj), pUb(ji,jj), pslp(ji,jj), &
+ & pTau(ji,jj), zQsen, zQlat )
+
zTs2 = pTs(ji,jj)*pTs(ji,jj)
zQlw = emiss_w*(prlw(ji,jj) - stefan*zTs2*zTs2) ! Net longwave flux
@@ -535,8 +535,63 @@
- SUBROUTINE BULK_FORMULA_VCTR( pzu, pTs, pqs, pTa, pqa, &
- & pCd, pCh, pCe, &
- & pwnd, pUb, pslp, &
- & pTau, pQsen, pQlat, pEvap, prhoa )
+ SUBROUTINE BULK_FORMULA_SCLR( pzu, pTs, pqs, pTa, pqa, &
+ & pCd, pCh, pCe, &
+ & pwnd, pUb, pslp, &
+ & pTau, pQsen, pQlat, &
+ & pEvap, prhoa, pfact_evap )
+ !!----------------------------------------------------------------------------------
+ REAL(wp), INTENT(in) :: pzu ! height above the sea-level where all this takes place (normally 10m)
+ REAL(wp), INTENT(in) :: pTs ! water temperature at the air-sea interface [K]
+ REAL(wp), INTENT(in) :: pqs ! satur. spec. hum. at T=pTs [kg/kg]
+ REAL(wp), INTENT(in) :: pTa ! potential air temperature at z=pzu [K]
+ REAL(wp), INTENT(in) :: pqa ! specific humidity at z=pzu [kg/kg]
+ REAL(wp), INTENT(in) :: pCd
+ REAL(wp), INTENT(in) :: pCh
+ REAL(wp), INTENT(in) :: pCe
+ REAL(wp), INTENT(in) :: pwnd ! wind speed module at z=pzu [m/s]
+ REAL(wp), INTENT(in) :: pUb ! bulk wind speed at z=pzu (inc. pot. effect of gustiness etc) [m/s]
+ REAL(wp), INTENT(in) :: pslp ! sea-level atmospheric pressure [Pa]
+ !!
+ REAL(wp), INTENT(out) :: pTau ! module of the wind stress [N/m^2]
+ REAL(wp), INTENT(out) :: pQsen ! [W/m^2]
+ REAL(wp), INTENT(out) :: pQlat ! [W/m^2]
+ !!
+ REAL(wp), INTENT(out), OPTIONAL :: pEvap ! Evaporation [kg/m^2/s]
+ REAL(wp), INTENT(out), OPTIONAL :: prhoa ! Air density at z=pzu [kg/m^3]
+ 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 :: jq
+ !!----------------------------------------------------------------------------------
+ zfact_evap = 1._wp
+ IF( PRESENT(pfact_evap) ) zfact_evap = pfact_evap
+
+ !! Need ztaa, absolute temperature at pzu (formula to estimate rho_air needs absolute temperature, not the potential temperature "pTa")
+ ztaa = pTa ! first guess...
+ DO jq = 1, 4
+ zgamma = gamma_moist( 0.5*(ztaa+pTs) , pqa ) !LOLO: why not "0.5*(pqs+pqa)" rather then "pqa" ???
+ ztaa = pTa - zgamma*pzu ! Absolute temp. is slightly colder...
+ END DO
+ zrho = rho_air(ztaa, pqa, pslp)
+ zrho = rho_air(ztaa, pqa, pslp-zrho*grav*pzu) ! taking into account that we are pzu m above the sea level where SLP is given!
+
+ zUrho = pUb*MAX(zrho, 1._wp) ! rho*U10
+
+ pTau = zUrho * pCd * pwnd ! Wind stress module
+
+ zevap = zUrho * pCe * (pqa - pqs)
+ pQsen = zUrho * pCh * (pTa - pTs) * cp_air(pqa)
+ pQlat = L_vap(pTs) * zevap
+
+ IF( PRESENT(pEvap) ) pEvap = - zfact_evap * zevap
+ IF( PRESENT(prhoa) ) prhoa = zrho
+
+ END SUBROUTINE BULK_FORMULA_SCLR
+
+ SUBROUTINE BULK_FORMULA_VCTR( pzu, pTs, pqs, pTa, pqa, &
+ & pCd, pCh, pCe, &
+ & pwnd, pUb, pslp, &
+ & pTau, pQsen, pQlat, &
+ & pEvap, prhoa, pfact_evap )
!!----------------------------------------------------------------------------------
REAL(wp), INTENT(in) :: pzu ! height above the sea-level where all this takes place (normally 10m)
@@ -558,85 +613,25 @@
REAL(wp), DIMENSION(jpi,jpj), INTENT(out), OPTIONAL :: pEvap ! Evaporation [kg/m^2/s]
REAL(wp), DIMENSION(jpi,jpj), INTENT(out), OPTIONAL :: prhoa ! Air density at z=pzu [kg/m^3]
- !!
- REAL(wp) :: ztaa, zgamma, zrho, zUrho, zevap
- INTEGER :: ji, jj, jq ! dummy loop indices
- !!----------------------------------------------------------------------------------
- DO_2D_11_11
-
- !! Need ztaa, absolute temperature at pzu (formula to estimate rho_air needs absolute temperature, not the potential temperature "pTa")
- ztaa = pTa(ji,jj) ! first guess...
- DO jq = 1, 4
- zgamma = gamma_moist( 0.5*(ztaa+pTs(ji,jj)) , pqa(ji,jj) )
- ztaa = pTa(ji,jj) - zgamma*pzu ! Absolute temp. is slightly colder...
- END DO
- zrho = rho_air(ztaa, pqa(ji,jj), pslp(ji,jj))
- zrho = rho_air(ztaa, pqa(ji,jj), pslp(ji,jj)-zrho*grav*pzu) ! taking into account that we are pzu m above the sea level where SLP is given!
-
- zUrho = pUb(ji,jj)*MAX(zrho, 1._wp) ! rho*U10
-
- pTau(ji,jj) = zUrho * pCd(ji,jj) * pwnd(ji,jj) ! Wind stress module
-
- zevap = zUrho * pCe(ji,jj) * (pqa(ji,jj) - pqs(ji,jj))
- pQsen(ji,jj) = zUrho * pCh(ji,jj) * (pTa(ji,jj) - pTs(ji,jj)) * cp_air(pqa(ji,jj))
- pQlat(ji,jj) = L_vap(pTs(ji,jj)) * zevap
-
- IF( PRESENT(pEvap) ) pEvap(ji,jj) = - zevap
+ 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
+ !!----------------------------------------------------------------------------------
+ zfact_evap = 1._wp
+ IF( PRESENT(pfact_evap) ) zfact_evap = pfact_evap
+
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+
+ 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), &
+ & pwnd(ji,jj), pUb(ji,jj), pslp(ji,jj), &
+ & pTau(ji,jj), pQsen(ji,jj), pQlat(ji,jj), &
+ & pEvap=zevap, prhoa=zrho, pfact_evap=zfact_evap )
+
+ IF( PRESENT(pEvap) ) pEvap(ji,jj) = zevap
IF( PRESENT(prhoa) ) prhoa(ji,jj) = zrho
-
+
END_2D
END SUBROUTINE BULK_FORMULA_VCTR
-
-
- SUBROUTINE BULK_FORMULA_SCLR( pzu, pTs, pqs, pTa, pqa, &
- & pCd, pCh, pCe, &
- & pwnd, pUb, pslp, &
- & pTau, pQsen, pQlat, pEvap, prhoa )
- !!----------------------------------------------------------------------------------
- REAL(wp), INTENT(in) :: pzu ! height above the sea-level where all this takes place (normally 10m)
- REAL(wp), INTENT(in) :: pTs ! water temperature at the air-sea interface [K]
- REAL(wp), INTENT(in) :: pqs ! satur. spec. hum. at T=pTs [kg/kg]
- REAL(wp), INTENT(in) :: pTa ! potential air temperature at z=pzu [K]
- REAL(wp), INTENT(in) :: pqa ! specific humidity at z=pzu [kg/kg]
- REAL(wp), INTENT(in) :: pCd
- REAL(wp), INTENT(in) :: pCh
- REAL(wp), INTENT(in) :: pCe
- REAL(wp), INTENT(in) :: pwnd ! wind speed module at z=pzu [m/s]
- REAL(wp), INTENT(in) :: pUb ! bulk wind speed at z=pzu (inc. pot. effect of gustiness etc) [m/s]
- REAL(wp), INTENT(in) :: pslp ! sea-level atmospheric pressure [Pa]
- !!
- REAL(wp), INTENT(out) :: pTau ! module of the wind stress [N/m^2]
- REAL(wp), INTENT(out) :: pQsen ! [W/m^2]
- REAL(wp), INTENT(out) :: pQlat ! [W/m^2]
- !!
- REAL(wp), INTENT(out), OPTIONAL :: pEvap ! Evaporation [kg/m^2/s]
- REAL(wp), INTENT(out), OPTIONAL :: prhoa ! Air density at z=pzu [kg/m^3]
- !!
- REAL(wp) :: ztaa, zgamma, zrho, zUrho, zevap
- INTEGER :: jq
- !!----------------------------------------------------------------------------------
-
- !! Need ztaa, absolute temperature at pzu (formula to estimate rho_air needs absolute temperature, not the potential temperature "pTa")
- ztaa = pTa ! first guess...
- DO jq = 1, 4
- zgamma = gamma_moist( 0.5*(ztaa+pTs) , pqa )
- ztaa = pTa - zgamma*pzu ! Absolute temp. is slightly colder...
- END DO
- zrho = rho_air(ztaa, pqa, pslp)
- zrho = rho_air(ztaa, pqa, pslp-zrho*grav*pzu) ! taking into account that we are pzu m above the sea level where SLP is given!
-
- zUrho = pUb*MAX(zrho, 1._wp) ! rho*U10
-
- pTau = zUrho * pCd * pwnd ! Wind stress module
-
- zevap = zUrho * pCe * (pqa - pqs)
- pQsen = zUrho * pCh * (pTa - pTs) * cp_air(pqa)
- pQlat = L_vap(pTs) * zevap
-
- IF( PRESENT(pEvap) ) pEvap = - zevap
- IF( PRESENT(prhoa) ) prhoa = zrho
-
- END SUBROUTINE BULK_FORMULA_SCLR
-
-
@@ -645,5 +640,5 @@
!! *** FUNCTION alpha_sw_vctr ***
!!
- !! ** Purpose : ROUGH estimate of the thermal expansion coefficient of sea-water at the surface (P =~ 1010 hpa)
+ !! ** Purpose : ROUGH estimate of the thermal expansion coefficient of sea-water at the surface (i.e. P =~ 101000 Pa)
!!
!! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/)
@@ -659,5 +654,5 @@
!! *** FUNCTION alpha_sw_sclr ***
!!
- !! ** Purpose : ROUGH estimate of the thermal expansion coefficient of sea-water at the surface (P =~ 1010 hpa)
+ !! ** Purpose : ROUGH estimate of the thermal expansion coefficient of sea-water at the surface (i.e. P =~ 101000 Pa)
!!
!! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/)
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcblk_skin_coare.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcblk_skin_coare.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcblk_skin_coare.F90 (revision 13540)
@@ -89,5 +89,5 @@
REAL(wp) :: zQabs, zdlt, zfr, zalfa, zqlat, zus
!!---------------------------------------------------------------------
- DO_2D_11_11
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
zQabs = pQnsol(ji,jj) ! first guess of heat flux absorbed within the viscous sublayer of thicknes delta,
@@ -156,5 +156,5 @@
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_11_11
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
l_exit = .FALSE.
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcblk_skin_ecmwf.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcblk_skin_ecmwf.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcblk_skin_ecmwf.F90 (revision 13540)
@@ -95,5 +95,5 @@
REAL(wp) :: zQabs, zdlt, zfr, zalfa, zus
!!---------------------------------------------------------------------
- DO_2D_11_11
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
zQabs = pQnsol(ji,jj) ! first guess of heat flux absorbed within the viscous sublayer of thicknes delta,
@@ -173,5 +173,5 @@
IF( PRESENT(pustk) ) l_pustk_known = .TRUE.
- DO_2D_11_11
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
zHwl = Hz_wl(ji,jj) ! first guess for warm-layer depth (and unique..., less advanced than COARE3p6 !)
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbccpl.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbccpl.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbccpl.F90 (revision 13540)
@@ -41,5 +41,5 @@
#endif
#if defined key_si3
- USE icethd_dh ! for CALL ice_thd_snwblow
+ USE icevar ! for CALL ice_var_snwblow
#endif
!
@@ -48,4 +48,8 @@
USE lib_mpp ! distribued memory computing library
USE lbclnk ! ocean lateral boundary conditions (or mpp link)
+
+#if defined key_oasis3
+ USE mod_oasis, ONLY : OASIS_Sent, OASIS_ToRest, OASIS_SentOut, OASIS_ToRestOut
+#endif
IMPLICIT NONE
@@ -152,5 +156,5 @@
INTEGER, PARAMETER :: jps_wlev = 32 ! water level
INTEGER, PARAMETER :: jps_fice1 = 33 ! first-order ice concentration (for semi-implicit coupling of atmos-ice fluxes)
- INTEGER, PARAMETER :: jps_a_p = 34 ! meltpond area
+ INTEGER, PARAMETER :: jps_a_p = 34 ! meltpond area fraction
INTEGER, PARAMETER :: jps_ht_p = 35 ! meltpond thickness
INTEGER, PARAMETER :: jps_kice = 36 ! sea ice effective conductivity
@@ -159,4 +163,12 @@
INTEGER, PARAMETER :: jpsnd = 38 ! total number of fields sent
+
+#if ! defined key_oasis3
+ ! Dummy variables to enable compilation when oasis3 is not being used
+ INTEGER :: OASIS_Sent = -1
+ INTEGER :: OASIS_SentOut = -1
+ INTEGER :: OASIS_ToRest = -1
+ INTEGER :: OASIS_ToRestOut = -1
+#endif
! !!** namelist namsbc_cpl **
@@ -184,4 +196,6 @@
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)
+ LOGICAL :: ln_scale_ice_flux ! use ice fluxes that are already "ice weighted" ( i.e. multiplied ice concentration)
+
TYPE :: DYNARR
REAL(wp), POINTER, DIMENSION(:,:,:) :: z3
@@ -191,4 +205,7 @@
REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: alb_oce_mix ! ocean albedo sent to atmosphere (mix clear/overcast sky)
+#if defined key_si3 || defined key_cice
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_i_last_couple !: Ice fractional area at last coupling time
+#endif
REAL(wp) :: rpref = 101000._wp ! reference atmospheric pressure[N/m2]
@@ -199,4 +216,5 @@
!! Substitution
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -210,5 +228,5 @@
!! *** FUNCTION sbc_cpl_alloc ***
!!----------------------------------------------------------------------
- INTEGER :: ierr(4)
+ INTEGER :: ierr(5)
!!----------------------------------------------------------------------
ierr(:) = 0
@@ -220,6 +238,9 @@
#endif
ALLOCATE( xcplmask(jpi,jpj,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) )
+#if defined key_si3 || defined key_cice
+ ALLOCATE( a_i_last_couple(jpi,jpj,jpl) , STAT=ierr(4) )
+#endif
+ !
+ IF( .NOT. ln_apr_dyn ) ALLOCATE( ssh_ib(jpi,jpj), ssh_ibb(jpi,jpj), apr(jpi, jpj), STAT=ierr(5) )
sbc_cpl_alloc = MAXVAL( ierr )
@@ -248,14 +269,14 @@
REAL(wp), DIMENSION(jpi,jpj) :: zacs, zaos
!!
- NAMELIST/namsbc_cpl/ sn_snd_temp , sn_snd_alb , sn_snd_thick, sn_snd_crt , sn_snd_co2 , &
+ 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 , &
& sn_snd_ttilyr, sn_snd_cond , sn_snd_mpnd , sn_snd_sstfrz, sn_snd_thick1, &
- & sn_snd_ifrac , sn_snd_crtw , sn_snd_wlev , sn_rcv_hsig , sn_rcv_phioc, &
- & sn_rcv_w10m , sn_rcv_taumod, sn_rcv_tau , sn_rcv_dqnsdt, sn_rcv_qsr , &
+ & sn_snd_ifrac , sn_snd_crtw , sn_snd_wlev , sn_rcv_hsig , sn_rcv_phioc , &
+ & sn_rcv_w10m , sn_rcv_taumod, sn_rcv_tau , sn_rcv_dqnsdt, sn_rcv_qsr , &
& sn_rcv_sdrfx , sn_rcv_sdrfy , sn_rcv_wper , sn_rcv_wnum , sn_rcv_tauwoc, &
- & sn_rcv_wdrag , sn_rcv_qns , sn_rcv_emp , sn_rcv_rnf , sn_rcv_cal , &
- & sn_rcv_iceflx, sn_rcv_co2 , nn_cplmodel , ln_usecplmask, sn_rcv_mslp , &
- & sn_rcv_icb , sn_rcv_isf , sn_rcv_wfreq , sn_rcv_tauw, nn_cats_cpl , &
+ & sn_rcv_wdrag , sn_rcv_qns , sn_rcv_emp , sn_rcv_rnf , sn_rcv_cal , &
+ & sn_rcv_iceflx, sn_rcv_co2 , sn_rcv_mslp , &
+ & sn_rcv_icb , sn_rcv_isf , sn_rcv_wfreq, sn_rcv_tauw , &
& sn_rcv_ts_ice
-
!!---------------------------------------------------------------------
!
@@ -277,4 +298,8 @@
ENDIF
IF( lwp .AND. ln_cpl ) THEN ! control print
+ WRITE(numout,*)' nn_cplmodel = ', nn_cplmodel
+ WRITE(numout,*)' ln_usecplmask = ', ln_usecplmask
+ WRITE(numout,*)' ln_scale_ice_flux = ', ln_scale_ice_flux
+ WRITE(numout,*)' nn_cats_cpl = ', nn_cats_cpl
WRITE(numout,*)' received fields (mutiple ice categogies)'
WRITE(numout,*)' 10m wind module = ', TRIM(sn_rcv_w10m%cldes ), ' (', TRIM(sn_rcv_w10m%clcat ), ')'
@@ -325,7 +350,4 @@
WRITE(numout,*)' - orientation = ', sn_snd_crtw%clvor
WRITE(numout,*)' - mesh = ', sn_snd_crtw%clvgrd
- WRITE(numout,*)' nn_cplmodel = ', nn_cplmodel
- WRITE(numout,*)' ln_usecplmask = ', ln_usecplmask
- WRITE(numout,*)' nn_cats_cpl = ', nn_cats_cpl
ENDIF
@@ -364,5 +386,7 @@
!
! 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') THEN ! avoid working with the atmospheric fields if they are not coupled
+ 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.
@@ -695,5 +719,5 @@
! Change first letter to couple with atmosphere if already coupled OPA
! this is nedeed as each variable name used in the namcouple must be unique:
- ! for example O_Runoff received by OPA from SAS and therefore O_Runoff received by SAS from the Atmosphere
+ ! for example O_Runoff received by OPA from SAS and therefore S_Runoff received by SAS from the Atmosphere
DO jn = 1, jprcv
IF( srcv(jn)%clname(1:1) == "O" ) srcv(jn)%clname = "S"//srcv(jn)%clname(2:LEN(srcv(jn)%clname))
@@ -819,4 +843,8 @@
END SELECT
+ ! Initialise ice fractions from last coupling time to zero (needed by Met-Office)
+#if defined key_si3 || defined key_cice
+ a_i_last_couple(:,:,:) = 0._wp
+#endif
! ! ------------------------- !
! ! Ice Meltponds !
@@ -1036,6 +1064,6 @@
xcplmask(:,:,:) = 0.
CALL iom_open( 'cplmask', inum )
- CALL iom_get( inum, jpdom_unknown, 'cplmask', xcplmask(1:nlci,1:nlcj,1:nn_cplmodel), &
- & kstart = (/ mig(1),mjg(1),1 /), kcount = (/ nlci,nlcj,nn_cplmodel /) )
+ 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_close( inum )
ELSE
@@ -1107,5 +1135,5 @@
REAL(wp) :: zcdrag = 1.5e-3 ! drag coefficient
REAL(wp) :: zzx, zzy ! temporary variables
- REAL(wp), DIMENSION(jpi,jpj) :: ztx, zty, zmsk, zemp, zqns, zqsr
+ REAL(wp), DIMENSION(jpi,jpj) :: ztx, zty, zmsk, zemp, zqns, zqsr, zcloud_fra
!!----------------------------------------------------------------------
!
@@ -1115,5 +1143,7 @@
IF( ln_dm2dc .AND. ncpl_qsr_freq /= 86400 ) &
& CALL ctl_stop( 'sbc_cpl_rcv: diurnal cycle reconstruction (ln_dm2dc) needs daily couping for solar radiation' )
- ncpl_qsr_freq = 86400 / ncpl_qsr_freq ! used by top
+
+ IF( ncpl_qsr_freq /= 0) ncpl_qsr_freq = 86400 / ncpl_qsr_freq ! used by top
+
ENDIF
!
@@ -1165,9 +1195,9 @@
!
IF( srcv(jpr_otx1)%clgrid == 'T' ) THEN
- DO_2D_00_00
+ 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_multi( 'sbccpl', frcv(jpr_otx1)%z3(:,:,1), 'U', -1., frcv(jpr_oty1)%z3(:,:,1), 'V', -1. )
+ CALL lbc_lnk_multi( 'sbccpl', frcv(jpr_otx1)%z3(:,:,1), 'U', -1.0_wp, frcv(jpr_oty1)%z3(:,:,1), 'V', -1.0_wp )
ENDIF
llnewtx = .TRUE.
@@ -1189,10 +1219,10 @@
! => need to be done only when otx1 was changed
IF( llnewtx ) THEN
- DO_2D_00_00
+ 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)
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. )
+ CALL lbc_lnk( 'sbccpl', frcv(jpr_taum)%z3(:,:,1), 'T', 1.0_wp )
llnewtau = .TRUE.
ELSE
@@ -1214,10 +1244,22 @@
IF( llnewtau ) THEN
zcoef = 1. / ( zrhoa * zcdrag )
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
frcv(jpr_w10m)%z3(ji,jj,1) = SQRT( frcv(jpr_taum)%z3(ji,jj,1) * zcoef )
END_2D
ENDIF
ENDIF
-
+!!$ ! ! ========================= !
+!!$ SELECT CASE( TRIM( sn_rcv_clouds%cldes ) ) ! cloud fraction !
+!!$ ! ! ========================= !
+!!$ cloud_fra(:,:) = frcv(jpr_clfra)*z3(:,:,1)
+!!$ END SELECT
+!!$
+ zcloud_fra(:,:) = pp_cldf ! should be real cloud fraction instead (as in the bulk) but needs to be read from atm.
+ IF( ln_mixcpl ) THEN
+ cloud_fra(:,:) = cloud_fra(:,:) * xcplmask(:,:,0) + zcloud_fra(:,:)* zmsk(:,:)
+ ELSE
+ cloud_fra(:,:) = zcloud_fra(:,:)
+ ENDIF
+ ! ! ========================= !
! u(v)tau and taum will be modified by ice model
! -> need to be reset before each call of the ice/fsbc
@@ -1479,4 +1521,5 @@
INTEGER :: ji, jj ! dummy loop indices
INTEGER :: itx ! index of taux over ice
+ REAL(wp) :: zztmp1, zztmp2
REAL(wp), DIMENSION(jpi,jpj) :: ztx, zty
!!----------------------------------------------------------------------
@@ -1542,23 +1585,14 @@
p_taui(:,:) = frcv(jpr_itx1)%z3(:,:,1) ! (U,V) ==> (U,V)
p_tauj(:,:) = frcv(jpr_ity1)%z3(:,:,1)
- CASE( 'F' )
- DO_2D_00_00
- p_taui(ji,jj) = 0.5 * ( frcv(jpr_itx1)%z3(ji,jj,1) + frcv(jpr_itx1)%z3(ji ,jj-1,1) )
- p_tauj(ji,jj) = 0.5 * ( frcv(jpr_ity1)%z3(ji,jj,1) + frcv(jpr_ity1)%z3(ji-1,jj ,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
- CASE( 'T' )
- DO_2D_00_00
- p_taui(ji,jj) = 0.5 * ( frcv(jpr_itx1)%z3(ji+1,jj ,1) + frcv(jpr_itx1)%z3(ji,jj,1) )
- p_tauj(ji,jj) = 0.5 * ( frcv(jpr_ity1)%z3(ji ,jj+1,1) + frcv(jpr_ity1)%z3(ji,jj,1) )
- END_2D
- CASE( 'I' )
- DO_2D_00_00
- p_taui(ji,jj) = 0.5 * ( frcv(jpr_itx1)%z3(ji+1,jj+1,1) + frcv(jpr_itx1)%z3(ji+1,jj ,1) )
- p_tauj(ji,jj) = 0.5 * ( frcv(jpr_ity1)%z3(ji+1,jj+1,1) + frcv(jpr_ity1)%z3(ji ,jj+1,1) )
- END_2D
+ CALL lbc_lnk_multi( 'sbccpl', p_taui, 'U', -1., p_tauj, 'V', -1. )
END SELECT
- IF( srcv(jpr_itx1)%clgrid /= 'U' ) THEN
- CALL lbc_lnk_multi( 'sbccpl', p_taui, 'U', -1., p_tauj, 'V', -1. )
- ENDIF
ENDIF
@@ -1626,9 +1660,10 @@
!
INTEGER :: ji, jj, jl ! dummy loop index
- REAL(wp) :: ztri ! local scalar
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
!!----------------------------------------------------------------------
!
@@ -1650,5 +1685,4 @@
ztprecip(:,:) = frcv(jpr_rain)%z3(:,:,1) + zsprecip(:,:) ! May need to ensure positive here
zemp_tot(:,:) = frcv(jpr_tevp)%z3(:,:,1) - ztprecip(:,:)
- zemp_ice(:,:) = ( frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_snow)%z3(:,:,1) ) * picefr(:,:)
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)
@@ -1662,6 +1696,45 @@
#if defined key_si3
+
+ ! --- 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
+ END WHERE
+ WHERE( picefr(:,:) > 1.e-10 ) ; zevap_ice_total(:,:) = SUM( zevap_ice(:,:,:) * a_i(:,:,:), 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
+ END WHERE
+ zevap_ice_total(:,:) = zevap_ice(:,:,1)
+ DO jl = 2, jpl
+ zevap_ice(:,:,jl) = zevap_ice(:,:,1)
+ ENDDO
+ ENDIF
+ ELSE
+ 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(:,:)
+ ELSEWHERE ; zevap_ice_total(:,:) = 0._wp
+ END WHERE
+ ELSE
+ zevap_ice(:,:,1) = frcv(jpr_ievp)%z3(:,:,1)
+ zevap_ice_total(:,:) = zevap_ice(:,:,1)
+ DO jl = 2, jpl
+ zevap_ice(:,:,jl) = zevap_ice(:,:,1)
+ ENDDO
+ ENDIF
+ ENDIF
+
+ 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
+
! zsnw = snow fraction over ice after wind blowing (=picefr if no blowing)
- zsnw(:,:) = 0._wp ; CALL ice_thd_snwblow( ziceld, zsnw )
+ zsnw(:,:) = 0._wp ; CALL ice_var_snwblow( ziceld, zsnw )
! --- evaporation minus precipitation corrected (because of wind blowing on snow) --- !
@@ -1670,11 +1743,5 @@
! --- evaporation over ocean (used later for qemp) --- !
- zevap_oce(:,:) = frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * picefr(:,:)
-
- ! --- evaporation over ice (kg/m2/s) --- !
- DO jl=1,jpl
- IF(sn_rcv_emp%clcat == 'yes') THEN ; zevap_ice(:,:,jl) = frcv(jpr_ievp)%z3(:,:,jl)
- ELSE ; zevap_ice(:,:,jl) = frcv(jpr_ievp)%z3(:,:,1 ) ; ENDIF
- ENDDO
+ zevap_oce(:,:) = frcv(jpr_tevp)%z3(:,:,1) - zevap_ice_total(:,:) * picefr(:,:)
! since the sensitivity of evap to temperature (devap/dT) is not prescribed by the atmosphere, we set it to 0
@@ -1754,15 +1821,15 @@
!! 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_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( 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(:,:) ) * picefr(:,:) ) ! liquid precipitation over ocean (cell average)
- IF( iom_use('subl_ai_cea') ) CALL iom_put( 'subl_ai_cea' , frcv(jpr_ievp)%z3(:,:,1) * picefr(:,:) * tmask(:,:,1) ) ! Sublimation over sea-ice (cell average)
- IF( iom_use('evap_ao_cea') ) CALL iom_put( 'evap_ao_cea' , ( frcv(jpr_tevp)%z3(:,:,1) &
- & - frcv(jpr_ievp)%z3(:,:,1) * picefr(:,:) ) * tmask(:,:,1) ) ! ice-free oce evap (cell average)
+ 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( 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(:,:) ) * picefr(:,:) ) ! liquid precipitation over ocean (cell average)
+ IF( iom_use('subl_ai_cea') ) CALL iom_put( 'subl_ai_cea' , frcv(jpr_ievp)%z3(:,:,1) * picefr(:,:) * tmask(:,:,1) ) ! Sublimation over sea-ice (cell average)
+ IF( iom_use('evap_ao_cea') ) CALL iom_put( 'evap_ao_cea' , ( frcv(jpr_tevp)%z3(:,:,1) &
+ & - frcv(jpr_ievp)%z3(:,:,1) * picefr(:,:) ) * tmask(:,:,1) ) ! ice-free oce evap (cell average)
! note: runoff output is done in sbcrnf (which includes icebergs too) and iceshelf output is done in sbcisf
!
@@ -1772,4 +1839,7 @@
CASE( 'oce only' ) ! the required field is directly provided
zqns_tot(:,:) = frcv(jpr_qnsoce)%z3(:,:,1)
+ ! For Met Office sea ice non-solar fluxes are already delt with by JULES so setting to zero
+ ! here so the only flux is the ocean only one.
+ zqns_ice(:,:,:) = 0._wp
CASE( 'conservative' ) ! the required fields are directly provided
zqns_tot(:,:) = frcv(jpr_qnsmix)%z3(:,:,1)
@@ -1789,7 +1859,6 @@
ENDDO
ELSE
- qns_tot(:,:) = qns_tot(:,:) + picefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1)
+ zqns_tot(:,:) = zqns_tot(:,:) + picefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1)
DO jl = 1, jpl
- zqns_tot(:,: ) = zqns_tot(:,:) + picefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1)
zqns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1)
END DO
@@ -1802,5 +1871,5 @@
zqns_ice(:,:,jl) = frcv(jpr_qnsmix)%z3(:,:,jl) &
& + frcv(jpr_dqnsdt)%z3(:,:,jl) * ( pist(:,:,jl) - ( ( rt0 + psst(:,:) ) * ziceld(:,:) &
- & + pist(:,:,jl) * picefr(:,:) ) )
+ & + pist(:,:,jl) * picefr(:,:) ) )
END DO
ELSE
@@ -1808,5 +1877,5 @@
zqns_ice(:,:,jl) = frcv(jpr_qnsmix)%z3(:,:, 1) &
& + frcv(jpr_dqnsdt)%z3(:,:, 1) * ( pist(:,:,jl) - ( ( rt0 + psst(:,:) ) * ziceld(:,:) &
- & + pist(:,:,jl) * picefr(:,:) ) )
+ & + pist(:,:,jl) * picefr(:,:) ) )
END DO
ENDIF
@@ -1914,4 +1983,7 @@
CASE( 'oce only' )
zqsr_tot(:,: ) = MAX( 0._wp , frcv(jpr_qsroce)%z3(:,:,1) )
+ ! For Met Office sea ice solar fluxes are already delt with by JULES so setting to zero
+ ! here so the only flux is the ocean only one.
+ zqsr_ice(:,:,:) = 0._wp
CASE( 'conservative' )
zqsr_tot(:,: ) = frcv(jpr_qsrmix)%z3(:,:,1)
@@ -1932,7 +2004,6 @@
END DO
ELSE
- qsr_tot(:,: ) = qsr_tot(:,:) + picefr(:,:) * frcv(jpr_qsrice)%z3(:,:,1)
+ zqsr_tot(:,:) = zqsr_tot(:,:) + picefr(:,:) * frcv(jpr_qsrice)%z3(:,:,1)
DO jl = 1, jpl
- zqsr_tot(:,: ) = zqsr_tot(:,:) + picefr(:,:) * frcv(jpr_qsrice)%z3(:,:,1)
zqsr_ice(:,:,jl) = frcv(jpr_qsrice)%z3(:,:,1)
END DO
@@ -2000,4 +2071,6 @@
ENDDO
ENDIF
+ CASE( 'none' )
+ zdqns_ice(:,:,:) = 0._wp
END SELECT
@@ -2015,9 +2088,12 @@
! ! ========================= !
CASE ('coupled')
- IF( ln_mixcpl ) THEN
- DO jl=1,jpl
- qml_ice(:,:,jl) = qml_ice(:,:,jl) * xcplmask(:,:,0) + frcv(jpr_topm)%z3(:,:,jl) * zmsk(:,:)
- qcn_ice(:,:,jl) = qcn_ice(:,:,jl) * xcplmask(:,:,0) + frcv(jpr_botm)%z3(:,:,jl) * zmsk(:,:)
- ENDDO
+ 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(:,:,:)
+ ELSEWHERE
+ qml_ice(:,:,:) = 0.0_wp
+ qcn_ice(:,:,:) = 0.0_wp
+ END WHERE
ELSE
qml_ice(:,:,:) = frcv(jpr_topm)%z3(:,:,:)
@@ -2030,19 +2106,32 @@
IF( .NOT.ln_cndflx ) THEN !== No conduction flux as surface forcing ==!
!
- ! ! ===> used prescribed cloud fraction representative for polar oceans in summer (0.81)
- ztri = 0.18 * ( 1.0 - cldf_ice ) + 0.35 * cldf_ice ! surface transmission when hi>10cm (Grenfell Maykut 77)
- !
- WHERE ( phs(:,:,:) <= 0._wp .AND. phi(:,:,:) < 0.1_wp ) ! linear decrease from hi=0 to 10cm
- zqtr_ice_top(:,:,:) = qsr_ice(:,:,:) * ( ztri + ( 1._wp - ztri ) * ( 1._wp - phi(:,:,:) * 10._wp ) )
- ELSEWHERE( phs(:,:,:) <= 0._wp .AND. phi(:,:,:) >= 0.1_wp ) ! constant (ztri) when hi>10cm
- zqtr_ice_top(:,:,:) = qsr_ice(:,:,:) * ztri
- ELSEWHERE ! zero when hs>0
- zqtr_ice_top(:,:,:) = 0._wp
- END WHERE
+ IF( nn_qtrice == 0 ) THEN
+ ! formulation derived from Grenfell and Maykut (1977), where transmission rate
+ ! 1) depends on cloudiness
+ ! ! ===> used prescribed cloud fraction representative for polar oceans in summer (0.81)
+ ! ! should be real cloud fraction instead (as in the bulk) but needs to be read from atm.
+ ! 2) is 0 when there is any snow
+ ! 3) tends to 1 for thin ice
+ 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
+ zqtr_ice_top(:,:,jl) = zqsr_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
+ zqtr_ice_top(:,:,jl) = zqsr_ice(:,:,jl) * ztri(:,:)
+ ELSEWHERE ! zero when hs>0
+ zqtr_ice_top(:,:,jl) = 0._wp
+ END WHERE
+ ENDDO
+ ELSEIF( nn_qtrice == 1 ) THEN
+ ! formulation is derived from the thesis of M. Lebrun (2019).
+ ! It represents the best fit using several sets of observations
+ ! It comes with snow conductivities adapted to freezing/melting conditions (see icethd_zdf_bl99.F90)
+ zqtr_ice_top(:,:,:) = 0.3_wp * zqsr_ice(:,:,:)
+ ENDIF
!
ELSEIF( ln_cndflx .AND. .NOT.ln_cndemulate ) THEN !== conduction flux as surface forcing ==!
!
- ! ! ===> here we must receive the qtr_ice_top array from the coupler
- ! for now just assume zero (fully opaque ice)
+ ! ! ===> here we must receive the qtr_ice_top array from the coupler
+ ! for now just assume zero (fully opaque ice)
zqtr_ice_top(:,:,:) = 0._wp
!
@@ -2101,4 +2190,5 @@
!
isec = ( kt - nit000 ) * NINT( rn_Dt ) ! date of exchanges
+ info = OASIS_idle
zfr_l(:,:) = 1.- fr_i(:,:)
@@ -2239,4 +2329,16 @@
ENDIF
+#if defined key_si3 || defined key_cice
+ ! If this coupling was successful then save ice fraction for use between coupling points.
+ ! This is needed for some calculations where the ice fraction at the last coupling point
+ ! is needed.
+ IF( info == OASIS_Sent .OR. info == OASIS_ToRest .OR. &
+ & info == OASIS_SentOut .OR. info == OASIS_ToRestOut ) THEN
+ IF ( sn_snd_thick%clcat == 'yes' ) THEN
+ a_i_last_couple(:,:,1:jpl) = a_i(:,:,1:jpl)
+ ENDIF
+ ENDIF
+#endif
+
IF( ssnd(jps_fice1)%laction ) THEN
SELECT CASE( sn_snd_thick1%clcat )
@@ -2302,5 +2404,5 @@
SELECT CASE( sn_snd_mpnd%clcat )
CASE( 'yes' )
- ztmp3(:,:,1:jpl) = a_ip_frac(:,:,1:jpl)
+ ztmp3(:,:,1:jpl) = a_ip_eff(:,:,1:jpl)
ztmp4(:,:,1:jpl) = h_ip(:,:,1:jpl)
CASE( 'no' )
@@ -2308,6 +2410,6 @@
ztmp4(:,:,:) = 0.0
DO jl=1,jpl
- ztmp3(:,:,1) = ztmp3(:,:,1) + a_ip_frac(:,:,jpl)
- ztmp4(:,:,1) = ztmp4(:,:,1) + h_ip(:,:,jpl)
+ ztmp3(:,:,1) = ztmp3(:,:,1) + a_ip_frac(:,:,jpl)
+ ztmp4(:,:,1) = ztmp4(:,:,1) + h_ip(:,:,jpl)
ENDDO
CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_mpnd%clcat' )
@@ -2370,10 +2472,10 @@
SELECT CASE( TRIM( sn_snd_crt%cldes ) )
CASE( 'oce only' ) ! C-grid ==> T
- DO_2D_00_00
+ 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_00_00
+ 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)
@@ -2381,7 +2483,7 @@
zity1(ji,jj) = 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj)
END_2D
- CALL lbc_lnk_multi( 'sbccpl', zitx1, 'T', -1., zity1, 'T', -1. )
+ CALL lbc_lnk_multi( 'sbccpl', zitx1, 'T', -1.0_wp, zity1, 'T', -1.0_wp )
CASE( 'mixed oce-ice' ) ! Ocean and Ice on C-grid ==> T
- DO_2D_00_00
+ 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)
@@ -2390,5 +2492,5 @@
END_2D
END SELECT
- CALL lbc_lnk_multi( 'sbccpl', zotx1, ssnd(jps_ocx1)%clgrid, -1., zoty1, ssnd(jps_ocy1)%clgrid, -1. )
+ CALL lbc_lnk_multi( 'sbccpl', zotx1, ssnd(jps_ocx1)%clgrid, -1.0_wp, zoty1, ssnd(jps_ocy1)%clgrid, -1.0_wp )
!
ENDIF
@@ -2447,10 +2549,10 @@
SELECT CASE( TRIM( sn_snd_crtw%cldes ) )
CASE( 'oce only' ) ! C-grid ==> T
- DO_2D_00_00
+ 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_00_00
+ 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)
@@ -2458,7 +2560,7 @@
zity1(ji,jj) = 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj)
END_2D
- CALL lbc_lnk_multi( 'sbccpl', zitx1, 'T', -1., zity1, 'T', -1. )
+ CALL lbc_lnk_multi( 'sbccpl', zitx1, 'T', -1.0_wp, zity1, 'T', -1.0_wp )
CASE( 'mixed oce-ice' ) ! Ocean and Ice on C-grid ==> T
- DO_2D_00_00
+ 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)
@@ -2467,5 +2569,5 @@
END_2D
END SELECT
- CALL lbc_lnk_multi( 'sbccpl', zotx1, ssnd(jps_ocxw)%clgrid, -1., zoty1, ssnd(jps_ocyw)%clgrid, -1. )
+ CALL lbc_lnk_multi( 'sbccpl', zotx1, ssnd(jps_ocxw)%clgrid, -1.0_wp, zoty1, ssnd(jps_ocyw)%clgrid, -1.0_wp )
!
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcdcy.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcdcy.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcdcy.F90 (revision 13540)
@@ -110,5 +110,5 @@
imask_night(:,:) = 0
- DO_2D_11_11
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
ztmpm = 0._wp
IF( ABS(rab(ji,jj)) < 1. ) THEN ! day duration is less than 24h
@@ -193,5 +193,5 @@
zsin = SIN( zdecrad ) ; zcos = COS( zdecrad )
- DO_2D_11_11
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
ztmp = rad * gphit(ji,jj)
raa(ji,jj) = SIN( ztmp ) * zsin
@@ -202,5 +202,5 @@
! rab to test if the day time is equal to 0, less than 24h of full day
rab(:,:) = -raa(:,:) / rbb(:,:)
- DO_2D_11_11
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
IF( ABS(rab(ji,jj)) < 1._wp ) THEN ! day duration is less than 24h
! When is it night?
@@ -226,5 +226,5 @@
! 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_11_11
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
IF( ABS(rab(ji,jj)) < 1._wp ) THEN ! day duration is less than 24h
rscal(ji,jj) = 0.0_wp
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcflx.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcflx.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcflx.F90 (revision 13540)
@@ -29,5 +29,4 @@
PUBLIC sbc_flx ! routine called by step.F90
- INTEGER , PARAMETER :: jpfld = 5 ! maximum number of files to read
INTEGER , PARAMETER :: jp_utau = 1 ! index of wind stress (i-component) file
INTEGER , PARAMETER :: jp_vtau = 2 ! index of wind stress (j-component) file
@@ -35,4 +34,6 @@
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
TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf ! structure of input fields (file informations, fields read)
@@ -59,4 +60,5 @@
!! net downward radiative flux qsr (watt/m2)
!! net upward freshwater (evapo - precip) emp (kg/m2/s)
+ !! salt flux sfx (pss*dh*rho/dt => g/m2/s)
!!
!! CAUTION : - never mask the surface stress fields
@@ -71,5 +73,5 @@
!! - emp upward mass flux (evap. - precip.)
!! - sfx salt flux; set to zero at nit000 but possibly non-zero
- !! if ice is present
+ !! if ice
!!----------------------------------------------------------------------
INTEGER, INTENT(in) :: kt ! ocean time step
@@ -85,6 +87,6 @@
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 ! informations about the fields to be read
- NAMELIST/namsbc_flx/ cn_dir, sn_utau, sn_vtau, sn_qtot, sn_qsr, sn_emp
+ 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
!!---------------------------------------------------------------------
!
@@ -105,5 +107,5 @@
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_emp ) = sn_emp !! ; slf_i(jp_sfx ) = sn_sfx
!
ALLOCATE( sf(jpfld), STAT=ierror ) ! set sf structure
@@ -118,6 +120,4 @@
CALL fld_fill( sf, slf_i, cn_dir, 'sbc_flx', 'flux formulation for ocean surface boundary condition', 'namsbc_flx' )
!
- sfx(:,:) = 0.0_wp ! salt flux due to freezing/melting (non-zero only if ice is present)
- !
ENDIF
@@ -126,31 +126,26 @@
IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN ! update ocean fluxes at each SBC frequency
- IF( ln_dm2dc ) THEN ; qsr(:,:) = sbc_dcy( sf(jp_qsr)%fnow(:,:,1) ) ! modify now Qsr to include the diurnal cycle
- ELSE ; qsr(:,:) = sf(jp_qsr)%fnow(:,:,1)
+ IF( ln_dm2dc ) THEN ! modify now Qsr to include the diurnal cycle
+ qsr(:,:) = sbc_dcy( sf(jp_qsr)%fnow(:,:,1) ) * tmask(ji,jj,1)
+ ELSE
+ DO_2D( 0, 0, 0, 0 )
+ qsr(ji,jj) = sf(jp_qsr)%fnow(ji,jj,1) * tmask(ji,jj,1)
+ END_2D
ENDIF
- DO_2D_11_11
- utau(ji,jj) = sf(jp_utau)%fnow(ji,jj,1)
- vtau(ji,jj) = sf(jp_vtau)%fnow(ji,jj,1)
- qns (ji,jj) = sf(jp_qtot)%fnow(ji,jj,1) - sf(jp_qsr)%fnow(ji,jj,1)
- emp (ji,jj) = sf(jp_emp )%fnow(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) * 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)
END_2D
! ! add to qns the heat due to e-p
- qns(:,:) = qns(:,:) - emp(:,:) * sst_m(:,:) * rcp ! mass flux is at SST
+ !!clem: I do not think it is needed
+ !!qns(:,:) = qns(:,:) - emp(:,:) * sst_m(:,:) * rcp ! mass flux is at SST
!
- qns(:,:) = qns(:,:) * tmask(:,:,1)
- emp(:,:) = emp(:,:) * tmask(:,:,1)
+ ! clem: without these lbc calls, it seems that the northfold is not ok (true in 3.6, not sure in 4.x)
+ CALL lbc_lnk_multi( 'sbcflx', utau, 'U', -1._wp, vtau, 'V', -1._wp, &
+ & qns, 'T', 1._wp, emp , 'T', 1._wp, qsr, 'T', 1._wp ) !! sfx, 'T', 1._wp )
!
- ! ! module of wind stress and wind speed at T-point
- zcoef = 1. / ( zrhoa * zcdrag )
- DO_2D_00_00
- 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
- wndm(ji,jj) = SQRT( zmod * zcoef )
- END_2D
- taum(:,:) = taum(:,:) * tmask(:,:,1) ; wndm(:,:) = wndm(:,:) * tmask(:,:,1)
- CALL lbc_lnk( 'sbcflx', taum(:,:), 'T', 1. ) ; CALL lbc_lnk( 'sbcflx', wndm(:,:), 'T', 1. )
-
IF( nitend-nit000 <= 100 .AND. lwp ) THEN ! control print (if less than 100 time-step asked)
WRITE(numout,*)
@@ -166,4 +161,16 @@
!
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
+ 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 = 0.5_wp * SQRT( ztx * ztx + zty * zty ) * tmask(ji,jj,1)
+ taum(ji,jj) = zmod
+ wndm(ji,jj) = SQRT( zmod * zcoef ) !!clem: not used?
+ END_2D
+ !
+ CALL lbc_lnk_multi( 'sbcflx', taum, 'T', 1._wp, wndm, 'T', 1._wp )
!
END SUBROUTINE sbc_flx
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcfwb.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcfwb.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcfwb.F90 (revision 13540)
@@ -71,5 +71,5 @@
REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: ztmsk_tospread, zerp_cor ! - -
REAL(wp) ,DIMENSION(1) :: z_fwfprv
- COMPLEX(wp),DIMENSION(1) :: y_fwfnow
+ COMPLEX(dp),DIMENSION(1) :: y_fwfnow
!!----------------------------------------------------------------------
!
@@ -180,5 +180,5 @@
!
!!gm ===>>>> lbc_lnk should be useless as all the computation is done over the whole domain !
- CALL lbc_lnk( 'sbcfwb', zerp_cor, 'T', 1. )
+ CALL lbc_lnk( 'sbcfwb', zerp_cor, 'T', 1.0_wp )
!
emp(:,:) = emp(:,:) + zerp_cor(:,:)
@@ -186,5 +186,5 @@
erp(:,:) = erp(:,:) + zerp_cor(:,:)
!
- IF( nprint == 1 .AND. lwp ) THEN ! control print
+ IF( lwp ) THEN ! control print
IF( z_fwf < 0._wp ) THEN
WRITE(numout,*)' z_fwf < 0'
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcice_cice.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcice_cice.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcice_cice.F90 (revision 13540)
@@ -12,5 +12,9 @@
USE oce ! ocean dynamics and tracers
USE dom_oce ! ocean space and time domain
+# if ! defined key_qco
USE domvvl
+# else
+ USE domqco
+# endif
USE phycst, only : rcp, rho0, r1_rho0, rhos, rhoi
USE in_out_manager ! I/O manager
@@ -213,10 +217,10 @@
! T point to U point
! T point to V point
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
fr_iu(ji,jj)=0.5*(fr_i(ji,jj)+fr_i(ji+1,jj))*umask(ji,jj,1)
fr_iv(ji,jj)=0.5*(fr_i(ji,jj)+fr_i(ji,jj+1))*vmask(ji,jj,1)
END_2D
- CALL lbc_lnk_multi( 'sbcice_cice', fr_iu , 'U', 1., fr_iv , 'V', 1. )
+ CALL lbc_lnk_multi( 'sbcice_cice', fr_iu , 'U', 1.0_wp, fr_iv , 'V', 1.0_wp )
! set the snow+ice mass
@@ -233,9 +237,12 @@
!!gm This should be put elsewhere.... (same remark for limsbc)
!!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, Kaa ) ! 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)*tmask(:,:,1)/(ht_0(:,:) + 1.0 - tmask(:,:,1)) )
- e3t(:,:,jk,Kbb) = e3t_0(:,:,jk)*( 1._wp + ssh(:,:,Kbb)*tmask(:,:,1)/(ht_0(:,:) + 1.0 - tmask(:,:,1)) )
+ 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)
@@ -267,4 +274,5 @@
END DO
ENDIF
+#endif
ENDIF
ENDIF
@@ -304,5 +312,5 @@
! x comp of wind stress (CI_1)
! U point to F point
- DO_2D_10_11
+ DO_2D( 1, 0, 1, 1 )
ztmp(ji,jj) = 0.5 * ( fr_iu(ji,jj) * utau(ji,jj) &
+ fr_iu(ji,jj+1) * utau(ji,jj+1) ) * fmask(ji,jj,1)
@@ -312,5 +320,5 @@
! y comp of wind stress (CI_2)
! V point to F point
- DO_2D_11_10
+ DO_2D( 1, 1, 1, 0 )
ztmp(ji,jj) = 0.5 * ( fr_iv(ji,jj) * vtau(ji,jj) &
+ fr_iv(ji+1,jj) * vtau(ji+1,jj) ) * fmask(ji,jj,1)
@@ -327,5 +335,5 @@
qla_ice(:,:,1)= - ( emp_ice(:,:)+sprecip(:,:) ) * rLsub
! End of temporary code
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
IF(fr_i(ji,jj).eq.0.0) THEN
DO jl=1,ncat
@@ -429,5 +437,5 @@
! x comp and y comp of surface ocean current
! U point to F point
- DO_2D_10_11
+ DO_2D( 1, 0, 1, 1 )
ztmp(ji,jj)=0.5*(ssu_m(ji,jj)+ssu_m(ji,jj+1))*fmask(ji,jj,1)
END_2D
@@ -435,5 +443,5 @@
! V point to F point
- DO_2D_11_10
+ DO_2D( 1, 1, 1, 0 )
ztmp(ji,jj)=0.5*(ssv_m(ji,jj)+ssv_m(ji+1,jj))*fmask(ji,jj,1)
END_2D
@@ -459,5 +467,5 @@
! x comp and y comp of sea surface slope (on F points)
! T point to F point
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
ztmp(ji,jj)=0.5 * ( (zpice(ji+1,jj )-zpice(ji,jj )) * r1_e1u(ji,jj ) &
& + (zpice(ji+1,jj+1)-zpice(ji,jj+1)) * r1_e1u(ji,jj+1) ) * fmask(ji,jj,1)
@@ -466,5 +474,5 @@
! T point to F point
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
ztmp(ji,jj)=0.5 * ( (zpice(ji ,jj+1)-zpice(ji ,jj)) * r1_e2v(ji ,jj) &
& + (zpice(ji+1,jj+1)-zpice(ji+1,jj)) * r1_e2v(ji+1,jj) ) * fmask(ji,jj,1)
@@ -495,8 +503,8 @@
ss_iou(:,:)=0.0
! F point to U point
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
ss_iou(ji,jj) = 0.5 * ( ztmp1(ji,jj-1) + ztmp1(ji,jj) ) * umask(ji,jj,1)
END_2D
- CALL lbc_lnk( 'sbcice_cice', ss_iou , 'U', -1. )
+ CALL lbc_lnk( 'sbcice_cice', ss_iou , 'U', -1.0_wp )
! y comp of ocean-ice stress
@@ -505,8 +513,8 @@
! F point to V point
- DO_2D_10_00
+ DO_2D( 1, 0, 0, 0 )
ss_iov(ji,jj) = 0.5 * ( ztmp1(ji-1,jj) + ztmp1(ji,jj) ) * vmask(ji,jj,1)
END_2D
- CALL lbc_lnk( 'sbcice_cice', ss_iov , 'V', -1. )
+ CALL lbc_lnk( 'sbcice_cice', ss_iov , 'V', -1.0_wp )
! x and y comps of surface stress
@@ -561,5 +569,5 @@
fmmflx(:,:) = ztmp1(:,:) !!Joakim edit
- CALL lbc_lnk_multi( 'sbcice_cice', emp , 'T', 1., sfx , 'T', 1. )
+ CALL lbc_lnk_multi( 'sbcice_cice', emp , 'T', 1.0_wp, sfx , 'T', 1.0_wp )
! Solar penetrative radiation and non solar surface heat flux
@@ -587,7 +595,7 @@
#endif
qsr(:,:)=qsr(:,:)+ztmp1(:,:)
- CALL lbc_lnk( 'sbcice_cice', qsr , 'T', 1. )
-
- DO_2D_11_11
+ CALL lbc_lnk( 'sbcice_cice', qsr , 'T', 1.0_wp )
+
+ DO_2D( 1, 1, 1, 1 )
nfrzmlt(ji,jj)=MAX(nfrzmlt(ji,jj),0.0)
END_2D
@@ -600,5 +608,5 @@
qns(:,:)=qns(:,:)+nfrzmlt(:,:)+ztmp1(:,:)
- CALL lbc_lnk( 'sbcice_cice', qns , 'T', 1. )
+ CALL lbc_lnk( 'sbcice_cice', qns , 'T', 1.0_wp )
! Prepare for the following CICE time-step
@@ -613,10 +621,10 @@
! T point to U point
! T point to V point
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
fr_iu(ji,jj)=0.5*(fr_i(ji,jj)+fr_i(ji+1,jj))*umask(ji,jj,1)
fr_iv(ji,jj)=0.5*(fr_i(ji,jj)+fr_i(ji,jj+1))*vmask(ji,jj,1)
END_2D
- CALL lbc_lnk_multi( 'sbcice_cice', fr_iu , 'U', 1., fr_iv , 'V', 1. )
+ CALL lbc_lnk_multi( 'sbcice_cice', fr_iu , 'U', 1.0_wp, fr_iv , 'V', 1.0_wp )
! set the snow+ice mass
@@ -872,6 +880,6 @@
! pcg(:,:)=0.0
DO jn=1,jpnij
- DO jj=nldjt(jn),nlejt(jn)
- DO ji=nldit(jn),nleit(jn)
+ DO jj=njs0all(jn),nje0all(jn)
+ DO ji=nis0all(jn),nie0all(jn)
png2(ji+nimppt(jn)-1,jj+njmppt(jn)-1)=png(ji,jj,jn)
ENDDO
@@ -973,5 +981,5 @@
pn(:,:)=0.0
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
pn(ji,jj)=pc(ji+1-ji_off,jj+1-jj_off,1)
END_2D
@@ -993,6 +1001,6 @@
png(:,:,:)=0.0
DO jn=1,jpnij
- DO jj=nldjt(jn),nlejt(jn)
- DO ji=nldit(jn),nleit(jn)
+ DO jj=njs0all(jn),nje0all(jn)
+ DO ji=nis0all(jn),nie0all(jn)
png(ji,jj,jn)=pcg(ji+nimppt(jn)-1-ji_off,jj+njmppt(jn)-1-jj_off)
ENDDO
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcice_if.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcice_if.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcice_if.F90 (revision 13540)
@@ -109,5 +109,5 @@
! Flux and ice fraction computation
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
!
zt_fzp = fr_i(ji,jj) ! freezing point temperature
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcmod.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcmod.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcmod.F90 (revision 13540)
@@ -99,6 +99,6 @@
& nn_ice , ln_ice_embd, &
& ln_traqsr, ln_dm2dc , &
- & ln_rnf , nn_fwb , ln_ssr , ln_apr_dyn, &
- & ln_wave , ln_cdgw , ln_sdw , ln_tauwoc , ln_stcor , &
+ & ln_rnf , nn_fwb , ln_ssr , ln_apr_dyn, &
+ & ln_wave , ln_cdgw , ln_sdw , ln_tauwoc , ln_stcor , &
& ln_tauw , nn_lsm, nn_sdrift
!!----------------------------------------------------------------------
@@ -120,15 +120,8 @@
ncom_fsbc = nn_fsbc ! make nn_fsbc available for lib_mpp
#endif
- ! !* overwrite namelist parameter using CPP key information
-#if defined key_agrif
- IF( Agrif_Root() ) THEN ! AGRIF zoom (cf r1242: possibility to run without ice in fine grid)
- IF( lk_si3 ) nn_ice = 2
- IF( lk_cice ) nn_ice = 3
- ENDIF
-!!GS: TBD
-!#else
-! IF( lk_si3 ) nn_ice = 2
-! IF( lk_cice ) nn_ice = 3
+#if ! defined key_si3
+ IF( nn_ice == 2 ) nn_ice = 0 ! without key key_si3 you cannot use si3...
#endif
+ !
!
IF(lwp) THEN !* Control print
@@ -253,5 +246,4 @@
ENDIF
!
-
IF( nn_ice == 0 ) THEN !* No sea-ice in the domain : ice fraction is always zero
IF( nn_components /= jp_iam_opa ) fr_i(:,:) = 0._wp ! except for OPA in SAS-OPA coupled case
@@ -471,5 +463,5 @@
! A lbc_lnk is therefore needed to ensure reproducibility and restartability.
! see ticket #2113 for discussion about this lbc_lnk.
- IF( .NOT. ln_passive_mode ) CALL lbc_lnk( 'sbcmod', emp, 'T', 1. ) ! ensure restartability with icebergs
+ IF( .NOT. ln_passive_mode ) CALL lbc_lnk( 'sbcmod', emp, 'T', 1.0_wp ) ! ensure restartability with icebergs
ENDIF
@@ -486,5 +478,5 @@
!!$!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. )
+!!$ 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
@@ -517,13 +509,13 @@
& iom_varid( numror, 'utau_b', ldstop = .FALSE. ) > 0 ) THEN
IF(lwp) WRITE(numout,*) ' nit000-1 surface forcing fields red in the restart file'
- CALL iom_get( numror, jpdom_autoglo, 'utau_b', utau_b, ldxios = lrxios ) ! before i-stress (U-point)
- CALL iom_get( numror, jpdom_autoglo, 'vtau_b', vtau_b, ldxios = lrxios ) ! before j-stress (V-point)
- CALL iom_get( numror, jpdom_autoglo, 'qns_b', qns_b, ldxios = lrxios ) ! before non solar heat flux (T-point)
+ CALL iom_get( numror, jpdom_auto, 'utau_b', utau_b, ldxios = lrxios, cd_type = 'U', psgn = -1._wp ) ! before i-stress (U-point)
+ CALL iom_get( numror, jpdom_auto, 'vtau_b', vtau_b, ldxios = lrxios, cd_type = 'V', psgn = -1._wp ) ! before j-stress (V-point)
+ CALL iom_get( numror, jpdom_auto, 'qns_b', qns_b, ldxios = lrxios ) ! before non solar heat flux (T-point)
! The 3D heat content due to qsr forcing is treated in traqsr
- ! CALL iom_get( numror, jpdom_autoglo, 'qsr_b' , qsr_b, ldxios = lrxios ) ! before solar heat flux (T-point)
- CALL iom_get( numror, jpdom_autoglo, 'emp_b', emp_b, ldxios = lrxios ) ! before freshwater flux (T-point)
+ ! CALL iom_get( numror, jpdom_auto, 'qsr_b' , qsr_b, ldxios = lrxios ) ! before solar heat flux (T-point)
+ CALL iom_get( numror, jpdom_auto, 'emp_b', emp_b, ldxios = lrxios ) ! before freshwater flux (T-point)
! 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_autoglo, 'sfx_b', sfx_b, ldxios = lrxios ) ! before salt flux (T-point)
+ CALL iom_get( numror, jpdom_auto, 'sfx_b', sfx_b, ldxios = lrxios ) ! before salt flux (T-point)
ELSE
sfx_b (:,:) = sfx(:,:)
@@ -573,7 +565,4 @@
ENDIF
!
- CALL iom_put( "utau", utau ) ! i-wind stress (stress can be updated at each time step in sea-ice)
- CALL iom_put( "vtau", vtau ) ! j-wind stress
- !
IF(sn_cfctl%l_prtctl) THEN ! print mean trends (used for debugging)
CALL prt_ctl(tab2d_1=fr_i , clinfo1=' fr_i - : ', mask1=tmask )
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcrnf.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcrnf.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcrnf.F90 (revision 13540)
@@ -72,4 +72,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -159,7 +160,7 @@
& iom_varid( numror, 'rnf_b', ldstop = .FALSE. ) > 0 ) THEN
IF(lwp) WRITE(numout,*) ' nit000-1 runoff forcing fields red in the restart file', lrxios
- CALL iom_get( numror, jpdom_autoglo, 'rnf_b', rnf_b, ldxios = lrxios ) ! before runoff
- CALL iom_get( numror, jpdom_autoglo, 'rnf_hc_b', rnf_tsc_b(:,:,jp_tem), ldxios = lrxios ) ! before heat content of runoff
- CALL iom_get( numror, jpdom_autoglo, 'rnf_sc_b', rnf_tsc_b(:,:,jp_sal), ldxios = lrxios ) ! before salinity content of runoff
+ CALL iom_get( numror, jpdom_auto, 'rnf_b', rnf_b, ldxios = lrxios ) ! before runoff
+ CALL iom_get( numror, jpdom_auto, 'rnf_hc_b', rnf_tsc_b(:,:,jp_tem), ldxios = lrxios ) ! before heat content of runoff
+ CALL iom_get( numror, jpdom_auto, 'rnf_sc_b', rnf_tsc_b(:,:,jp_sal), ldxios = lrxios ) ! before salinity content of runoff
ELSE !* no restart: set from nit000 values
IF(lwp) WRITE(numout,*) ' nit000-1 runoff forcing fields set to nit000'
@@ -208,5 +209,5 @@
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_11_11
+ DO_2D( 1, 1, 1, 1 )
DO jk = 1, nk_rnf(ji,jj)
phdivn(ji,jj,jk) = phdivn(ji,jj,jk) - ( rnf(ji,jj) + rnf_b(ji,jj) ) * zfact * r1_rho0 / h_rnf(ji,jj)
@@ -214,7 +215,7 @@
END_2D
ELSE !* variable volume case
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 ) ! 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
+ 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
@@ -353,12 +354,12 @@
rn_dep_file = TRIM( cn_dir )//TRIM( sn_dep_rnf%clname )
IF( .NOT. sn_dep_rnf%ln_clim ) THEN ; WRITE(rn_dep_file, '(a,"_y",i4)' ) TRIM( rn_dep_file ), nyear ! add year
- IF( sn_dep_rnf%cltype == 'monthly' ) WRITE(rn_dep_file, '(a,"m",i2)' ) TRIM( rn_dep_file ), nmonth ! add month
- ENDIF
- CALL iom_open ( rn_dep_file, inum ) ! open file
- CALL iom_get ( inum, jpdom_data, sn_dep_rnf%clvar, h_rnf ) ! read the river mouth array
- CALL iom_close( inum ) ! close file
+ IF( sn_dep_rnf%clftyp == 'monthly' ) WRITE(rn_dep_file, '(a,"m",i2)' ) TRIM( rn_dep_file ), nmonth ! add month
+ ENDIF
+ CALL iom_open ( rn_dep_file, inum ) ! open file
+ CALL iom_get ( inum, jpdom_global, sn_dep_rnf%clvar, h_rnf ) ! read the river mouth array
+ CALL iom_close( inum ) ! close file
!
nk_rnf(:,:) = 0 ! set the number of level over which river runoffs are applied
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
IF( h_rnf(ji,jj) > 0._wp ) THEN
jk = 2
@@ -373,5 +374,5 @@
ENDIF
END_2D
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 ) ! set the associated depth
h_rnf(ji,jj) = 0._wp
DO jk = 1, nk_rnf(ji,jj)
@@ -390,8 +391,8 @@
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
+ zrnfcl(:,:,1) = 0._wp ! init the max to 0. in 1
DO jm = 1, nbrec
- CALL iom_get( inum, jpdom_data, TRIM( sn_rnf%clvar ), zrnfcl(:,:,2), jm ) ! read the value in 2
- zrnfcl(:,:,1) = MAXVAL( zrnfcl(:,:,:), DIM=3 ) ! store the maximum value in time in 1
+ CALL iom_get( inum, jpdom_global, TRIM( sn_rnf%clvar ), zrnfcl(:,:,2), jm ) ! read the value in 2
+ zrnfcl(:,:,1) = MAXVAL( zrnfcl(:,:,:), DIM=3 ) ! store the maximum value in time in 1
END DO
CALL iom_close( inum )
@@ -403,5 +404,5 @@
WHERE( zrnfcl(:,:,1) > 0._wp ) h_rnf(:,:) = zacoef * zrnfcl(:,:,1) ! compute depth for all runoffs
!
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 ) ! take in account min depth of ocean rn_hmin
IF( zrnfcl(ji,jj,1) > 0._wp ) THEN
jk = mbkt(ji,jj)
@@ -411,5 +412,5 @@
!
nk_rnf(:,:) = 0 ! number of levels on which runoffs are distributed
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
IF( zrnfcl(ji,jj,1) > 0._wp ) THEN
jk = 2
@@ -422,5 +423,5 @@
END_2D
!
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 ) ! set the associated depth
h_rnf(ji,jj) = 0._wp
DO jk = 1, nk_rnf(ji,jj)
@@ -518,11 +519,11 @@
cl_rnfile = TRIM( cn_dir )//TRIM( sn_cnf%clname )
IF( .NOT. sn_cnf%ln_clim ) THEN ; WRITE(cl_rnfile, '(a,"_y",i4)' ) TRIM( cl_rnfile ), nyear ! add year
- IF( sn_cnf%cltype == 'monthly' ) WRITE(cl_rnfile, '(a,"m",i2)' ) TRIM( cl_rnfile ), nmonth ! add month
+ IF( sn_cnf%clftyp == 'monthly' ) WRITE(cl_rnfile, '(a,"m",i2)' ) TRIM( cl_rnfile ), nmonth ! add month
ENDIF
!
! horizontal mask (read in NetCDF file)
- CALL iom_open ( cl_rnfile, inum ) ! open file
- CALL iom_get ( inum, jpdom_data, 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 ) ! 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
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcssm.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcssm.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcssm.F90 (revision 13540)
@@ -32,4 +32,5 @@
LOGICAL, SAVE :: l_ssm_mean = .FALSE. ! keep track of whether means have been read from restart file
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -207,14 +208,14 @@
IF( ln_rstart .AND. iom_varid( numror, 'nn_fsbc', ldstop = .FALSE. ) > 0 ) THEN
l_ssm_mean = .TRUE.
- CALL iom_get( numror , 'nn_fsbc', zf_sbc, ldxios = lrxios ) ! sbc frequency of previous run
- CALL iom_get( numror, jpdom_autoglo, 'ssu_m' , ssu_m, ldxios = lrxios ) ! sea surface mean velocity (U-point)
- CALL iom_get( numror, jpdom_autoglo, 'ssv_m' , ssv_m, ldxios = lrxios ) ! " " velocity (V-point)
- CALL iom_get( numror, jpdom_autoglo, 'sst_m' , sst_m, ldxios = lrxios ) ! " " temperature (T-point)
- CALL iom_get( numror, jpdom_autoglo, 'sss_m' , sss_m, ldxios = lrxios ) ! " " salinity (T-point)
- CALL iom_get( numror, jpdom_autoglo, 'ssh_m' , ssh_m, ldxios = lrxios ) ! " " height (T-point)
- CALL iom_get( numror, jpdom_autoglo, 'e3t_m' , e3t_m, ldxios = lrxios ) ! 1st level thickness (T-point)
+ CALL iom_get( numror , 'nn_fsbc', zf_sbc,ldxios = lrxios ) ! sbc frequency of previous run
+ CALL iom_get( numror, jpdom_auto, 'ssu_m' , ssu_m, ldxios = lrxios, cd_type = 'U', psgn = -1._wp ) ! sea surface mean velocity (U-point)
+ CALL iom_get( numror, jpdom_auto, 'ssv_m' , ssv_m, ldxios = lrxios, cd_type = 'V', psgn = -1._wp ) ! " " velocity (V-point)
+ CALL iom_get( numror, jpdom_auto, 'sst_m' , sst_m, ldxios = lrxios ) ! " " temperature (T-point)
+ CALL iom_get( numror, jpdom_auto, 'sss_m' , sss_m, ldxios = lrxios ) ! " " salinity (T-point)
+ CALL iom_get( numror, jpdom_auto, 'ssh_m' , ssh_m, ldxios = lrxios ) ! " " height (T-point)
+ CALL iom_get( numror, jpdom_auto, 'e3t_m' , e3t_m, ldxios = lrxios ) ! 1st level thickness (T-point)
! fraction of solar net radiation absorbed in 1st T level
IF( iom_varid( numror, 'frq_m', ldstop = .FALSE. ) > 0 ) THEN
- CALL iom_get( numror, jpdom_autoglo, 'frq_m' , frq_m, ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'frq_m' , frq_m, ldxios = lrxios )
ELSE
frq_m(:,:) = 1._wp ! default definition
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcssr.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcssr.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcssr.F90 (revision 13540)
@@ -95,5 +95,5 @@
!
IF( nn_sstr == 1 ) THEN !* Temperature restoring term
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
zqrp = rn_dqdt * ( sst_m(ji,jj) - sf_sst(1)%fnow(ji,jj,1) ) * tmask(ji,jj,1)
qns(ji,jj) = qns(ji,jj) + zqrp
@@ -105,5 +105,5 @@
! 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_11_11
+ DO_2D( 1, 1, 1, 1 )
SELECT CASE ( nn_sssr_ice )
CASE ( 0 ) ; coefice(ji,jj) = 1._wp - fr_i(ji,jj) ! no/reduced damping under ice
@@ -115,5 +115,5 @@
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_11_11
+ DO_2D( 1, 1, 1, 1 )
zerp = zsrp * ( 1. - 2.*rnfmsk(ji,jj) ) & ! No damping in vicinity of river mouths
& * coefice(ji,jj) & ! Optional control of damping under sea-ice
@@ -126,10 +126,10 @@
zsrp = rn_deds / rday ! from [mm/day] to [kg/m2/s]
zerp_bnd = rn_sssr_bnd / rday ! - -
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
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)
- IF( ln_sssr_bnd ) zerp = SIGN( 1., zerp ) * MIN( zerp_bnd, ABS(zerp) )
+ 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)
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcwave.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcwave.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/SBC/sbcwave.F90 (revision 13540)
@@ -73,4 +73,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -112,5 +113,5 @@
IF( ll_st_bv_li ) THEN ! (Eq. (19) in Breivik et al. (2014) )
zfac = 2.0_wp * rpi / 16.0_wp
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
! Stokes drift velocity estimated from Hs and Tmean
ztransp = zfac * hsw(ji,jj)*hsw(ji,jj) / MAX( wmp(ji,jj), 0.0000001_wp )
@@ -120,5 +121,5 @@
zk_t(ji,jj) = ABS( tsd2d(ji,jj) ) / MAX( ABS( 5.97_wp*ztransp ), 0.0000001_wp )
END_2D
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 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) )
@@ -128,8 +129,8 @@
END_2D
ELSE IF( ll_st_peakfr ) THEN ! peak wave number calculated from the peak frequency received by the wave model
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
zk_t(ji,jj) = ( 2.0_wp * rpi * wfreq(ji,jj) ) * ( 2.0_wp * rpi * wfreq(ji,jj) ) / grav
END_2D
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
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) )
@@ -142,5 +143,5 @@
! !== horizontal Stokes Drift 3D velocity ==!
IF( ll_st_bv2014 ) THEN
- DO_3D_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
zdep_u = 0.5_wp * ( gdept(ji,jj,jk,Kmm) + gdept(ji+1,jj,jk,Kmm) )
zdep_v = 0.5_wp * ( gdept(ji,jj,jk,Kmm) + gdept(ji,jj+1,jk,Kmm) )
@@ -157,5 +158,5 @@
ELSE IF( ll_st_li2017 .OR. ll_st_peakfr ) THEN
ALLOCATE( zstokes_psi_u_top(jpi,jpj), zstokes_psi_v_top(jpi,jpj) )
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
zstokes_psi_u_top(ji,jj) = 0._wp
zstokes_psi_v_top(ji,jj) = 0._wp
@@ -163,5 +164,5 @@
zsqrtpi = SQRT(rpi)
z_two_thirds = 2.0_wp / 3.0_wp
- DO_3D_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! exp. wave number & Stokes drift velocity at u- & v-points
zbot_u = ( gdepw(ji,jj,jk+1,Kmm) + gdepw(ji+1,jj,jk+1,Kmm) ) ! 2 * bottom depth
zbot_v = ( gdepw(ji,jj,jk+1,Kmm) + gdepw(ji,jj+1,jk+1,Kmm) ) ! 2 * bottom depth
@@ -198,26 +199,18 @@
ENDIF
- CALL lbc_lnk_multi( 'sbcwave', usd, 'U', -1., vsd, 'V', -1. )
+ CALL lbc_lnk_multi( 'sbcwave', usd, 'U', -1.0_wp, vsd, 'V', -1.0_wp )
!
! !== vertical Stokes Drift 3D velocity ==!
!
- DO_3D_01_01( 1, jpkm1 )
+ 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)
+ & - e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) * vsd(ji,jj-1,jk) ) &
+ & * r1_e1e2t(ji,jj)
END_3D
!
-#if defined key_agrif
- IF( .NOT. Agrif_Root() ) THEN
- IF( nbondi == -1 .OR. nbondi == 2 ) ze3divh( 2:nbghostcells+1,: ,:) = 0._wp ! west
- IF( nbondi == 1 .OR. nbondi == 2 ) ze3divh( nlci-nbghostcells:nlci-1,:,:) = 0._wp ! east
- IF( nbondj == -1 .OR. nbondj == 2 ) ze3divh( :,2:nbghostcells+1 ,:) = 0._wp ! south
- IF( nbondj == 1 .OR. nbondj == 2 ) ze3divh( :,nlcj-nbghostcells:nlcj-1,:) = 0._wp ! north
- ENDIF
-#endif
- !
- CALL lbc_lnk( 'sbcwave', ze3divh, 'T', 1. )
+ CALL lbc_lnk( 'sbcwave', ze3divh, 'T', 1.0_wp )
!
IF( ln_linssh ) THEN ; ik = 1 ! none zero velocity through the sea surface
@@ -270,5 +263,5 @@
!
IF( ln_tauw ) THEN
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
! Stress components at u- & v-points
utau(ji,jj) = 0.5_wp * ( tauw_x(ji,jj) + tauw_x(ji+1,jj) )
@@ -278,5 +271,5 @@
taum(ji,jj) = SQRT( tauw_x(ji,jj)*tauw_x(ji,jj) + tauw_y(ji,jj)*tauw_y(ji,jj) )
END_2D
- CALL lbc_lnk_multi( 'sbcwave', utau(:,:), 'U', -1. , vtau(:,:), 'V', -1. , taum(:,:) , 'T', -1. )
+ CALL lbc_lnk_multi( 'sbcwave', utau(:,:), 'U', -1.0_wp , vtau(:,:), 'V', -1.0_wp , taum(:,:) , 'T', -1.0_wp )
ENDIF
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/STO/stopar.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/STO/stopar.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/STO/stopar.F90 (revision 13540)
@@ -56,6 +56,6 @@
INTEGER, DIMENSION(:), ALLOCATABLE :: sto3d_ord ! order of autoregressive process
- CHARACTER(len=1), DIMENSION(:), ALLOCATABLE :: sto2d_typ ! nature of grid point (T, U, V, W, F, I)
- CHARACTER(len=1), DIMENSION(:), ALLOCATABLE :: sto3d_typ ! nature of grid point (T, U, V, W, F, I)
+ CHARACTER(len=lca), DIMENSION(:), ALLOCATABLE :: sto2d_typ ! nature of grid point (T, U, V, W, F, I)
+ CHARACTER(len=lca), DIMENSION(:), ALLOCATABLE :: sto3d_typ ! nature of grid point (T, U, V, W, F, I)
REAL(wp), DIMENSION(:), ALLOCATABLE :: sto2d_sgn ! control of the sign accross the north fold
REAL(wp), DIMENSION(:), ALLOCATABLE :: sto3d_sgn ! control of the sign accross the north fold
@@ -684,10 +684,12 @@
!! ** Purpose : read stochastic parameters from restart file
!!----------------------------------------------------------------------
- INTEGER :: jsto, jseed
+ INTEGER :: jsto, jseed
+ INTEGER :: idg ! number of digits
INTEGER(KIND=8) :: ziseed(4) ! RNG seeds in integer type
- REAL(KIND=8) :: zrseed(4) ! RNG seeds in real type (with same bits to save in restart)
+ REAL(KIND=dp) :: zrseed(4) ! RNG seeds in double-precision (with same bits to save in restart)
CHARACTER(LEN=9) :: clsto2d='sto2d_000' ! stochastic parameter variable name
CHARACTER(LEN=9) :: clsto3d='sto3d_000' ! stochastic parameter variable name
- CHARACTER(LEN=10) :: clseed='seed0_0000' ! seed variable name
+ CHARACTER(LEN=15) :: clseed='seed0_0000' ! seed variable name
+ CHARACTER(LEN=6) :: clfmt ! writing format
!!----------------------------------------------------------------------
@@ -707,18 +709,20 @@
DO jsto = 1 , jpsto2d
WRITE(clsto2d(7:9),'(i3.3)') jsto
- CALL iom_get( numstor, jpdom_autoglo, clsto2d , sto2d(:,:,jsto) )
+ CALL iom_get( numstor, jpdom_auto, clsto2d, sto2d(:,:, jsto) )
END DO
! 3D stochastic parameters
DO jsto = 1 , jpsto3d
WRITE(clsto3d(7:9),'(i3.3)') jsto
- CALL iom_get( numstor, jpdom_autoglo, clsto3d , sto3d(:,:,:,jsto) )
+ CALL iom_get( numstor, jpdom_auto, clsto3d, sto3d(:,:,:,jsto) )
END DO
IF (ln_rstseed) THEN
! Get saved state of the random number generator
+ idg = MAX( INT(LOG10(REAL(jpnij,wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9
+ WRITE(clfmt, "('(i', i1, '.', i1, ')')") idg, idg ! "(ix.x)"
DO jseed = 1 , 4
- WRITE(clseed(5:5) ,'(i1.1)') jseed
- WRITE(clseed(7:10),'(i4.4)') narea
- CALL iom_get( numstor, clseed , zrseed(jseed) )
+ WRITE(clseed(5:5) ,'(i1.1)') jseed
+ WRITE(clseed(7:7+idg-1), clfmt ) narea
+ CALL iom_get( numstor, clseed(1:7+idg-1) , zrseed(jseed) )
END DO
ziseed = TRANSFER( zrseed , ziseed)
@@ -742,12 +746,14 @@
INTEGER, INTENT(in) :: kt ! ocean time-step
!!
- INTEGER :: jsto, jseed
+ INTEGER :: jsto, jseed
+ INTEGER :: idg ! number of digits
INTEGER(KIND=8) :: ziseed(4) ! RNG seeds in integer type
- REAL(KIND=8) :: zrseed(4) ! RNG seeds in real type (with same bits to save in restart)
+ REAL(KIND=dp) :: zrseed(4) ! RNG seeds in double-precision (with same bits to save in restart)
CHARACTER(LEN=20) :: clkt ! ocean time-step defined as a character
CHARACTER(LEN=50) :: clname ! restart file name
CHARACTER(LEN=9) :: clsto2d='sto2d_000' ! stochastic parameter variable name
CHARACTER(LEN=9) :: clsto3d='sto3d_000' ! stochastic parameter variable name
- CHARACTER(LEN=10) :: clseed='seed0_0000' ! seed variable name
+ CHARACTER(LEN=15) :: clseed='seed0_0000' ! seed variable name
+ CHARACTER(LEN=6) :: clfmt ! writing format
!!----------------------------------------------------------------------
@@ -771,8 +777,10 @@
CALL kiss_state( ziseed(1) , ziseed(2) , ziseed(3) , ziseed(4) )
zrseed = TRANSFER( ziseed , zrseed)
+ idg = MAX( INT(LOG10(REAL(jpnij,wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9
+ WRITE(clfmt, "('(i', i1, '.', i1, ')')") idg, idg ! "(ix.x)"
DO jseed = 1 , 4
- WRITE(clseed(5:5) ,'(i1.1)') jseed
- WRITE(clseed(7:10),'(i4.4)') narea
- CALL iom_rstput( kt, nitrst, numstow, clseed , zrseed(jseed) )
+ WRITE(clseed(5:5) ,'(i1.1)') jseed
+ WRITE(clseed(7:7+idg-1), clfmt ) narea
+ CALL iom_rstput( kt, nitrst, numstow, clseed(1:7+idg-1), zrseed(jseed) )
END DO
! 2D stochastic parameters
@@ -827,7 +835,7 @@
!!
INTEGER :: ji, jj
- REAL(KIND=8) :: gran ! Gaussian random number (forced KIND=8 as in kiss_gaussian)
-
- DO_2D_11_11
+ REAL(wp) :: gran ! Gaussian random number (forced KIND=8 as in kiss_gaussian)
+
+ DO_2D( 1, 1, 1, 1 )
CALL kiss_gaussian( gran )
psto(ji,jj) = gran
@@ -847,5 +855,5 @@
INTEGER :: ji, jj
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
psto(ji,jj) = 0.5_wp * psto(ji,jj) + 0.125_wp * &
& ( psto(ji-1,jj) + psto(ji+1,jj) + &
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/STO/stopts.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/STO/stopts.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/STO/stopts.F90 (revision 13540)
@@ -95,5 +95,5 @@
! Eliminate any possible negative salinity
DO jdof = 1, nn_sto_eos
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
pts_ran(ji,jj,jk,jp_sal,jdof) = MIN( ABS(pts_ran(ji,jj,jk,jp_sal,jdof)) , &
& MAX(pts(ji,jj,jk,jp_sal),0._wp) ) &
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/STO/storng.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/STO/storng.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/STO/storng.F90 (revision 13540)
@@ -50,5 +50,4 @@
! Parameters to generate real random variates
- REAL(KIND=wp), PARAMETER :: huge64=9223372036854775808.0 ! +1
REAL(KIND=wp), PARAMETER :: zero=0.0, half=0.5, one=1.0, two=2.0
@@ -275,5 +274,5 @@
REAL(KIND=wp) :: uran
- uran = half * ( one + REAL(kiss(),wp) / huge64 )
+ uran = half * ( one + REAL(kiss(),wp) / HUGE(1._wp) )
END SUBROUTINE kiss_uniform
@@ -298,6 +297,6 @@
rsq = two
DO WHILE ( (rsq.GE.one).OR. (rsq.EQ.zero) )
- u1 = REAL(kiss(),wp) / huge64
- u2 = REAL(kiss(),wp) / huge64
+ u1 = REAL(kiss(),wp) / HUGE(1._wp)
+ u2 = REAL(kiss(),wp) / HUGE(1._wp)
rsq = u1*u1 + u2*u2
ENDDO
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/TDE/tide_mod.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/TDE/tide_mod.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/TDE/tide_mod.F90 (revision 13540)
@@ -400,6 +400,6 @@
!
DO itide = 1, nb_harmo
- CALL iom_get ( inum, jpdom_data,TRIM(tide_components(itide)%cname_tide)//'_z1', ztr(:,:) )
- CALL iom_get ( inum, jpdom_data,TRIM(tide_components(itide)%cname_tide)//'_z2', zti(:,:) )
+ CALL iom_get ( inum, jpdom_global,TRIM(tide_components(itide)%cname_tide)//'_z1', ztr(:,:) )
+ CALL iom_get ( inum, jpdom_global,TRIM(tide_components(itide)%cname_tide)//'_z2', zti(:,:) )
!
DO ji=1,jpi
@@ -723,5 +723,5 @@
!! ** Action : pot_astro actronomical potential
!!----------------------------------------------------------------------
- REAL, INTENT(in) :: pdelta ! Temporal offset in seconds
+ REAL(wp), INTENT(in) :: pdelta ! Temporal offset in seconds
INTEGER, INTENT(IN) :: Kmm ! Time level index
INTEGER :: jk ! Dummy loop index
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/eosbn2.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/eosbn2.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/eosbn2.F90 (revision 13540)
@@ -180,4 +180,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -237,5 +238,5 @@
CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==!
!
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
!
zh = pdep(ji,jj,jk) * r1_Z0 ! depth
@@ -273,5 +274,5 @@
CASE( np_seos ) !== simplified EOS ==!
!
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
zt = pts (ji,jj,jk,jp_tem) - 10._wp
zs = pts (ji,jj,jk,jp_sal) - 35._wp
@@ -337,5 +338,5 @@
END DO
!
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
!
! compute density (2*nn_sto_eos) times:
@@ -387,5 +388,5 @@
! Non-stochastic equation of state
ELSE
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
!
zh = pdep(ji,jj,jk) * r1_Z0 ! depth
@@ -425,5 +426,5 @@
CASE( np_seos ) !== simplified EOS ==!
!
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
zt = pts (ji,jj,jk,jp_tem) - 10._wp
zs = pts (ji,jj,jk,jp_sal) - 35._wp
@@ -479,5 +480,5 @@
CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==!
!
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
!
zh = pdep(ji,jj) * r1_Z0 ! depth
@@ -514,5 +515,5 @@
CASE( np_seos ) !== simplified EOS ==!
!
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
!
zt = pts (ji,jj,jp_tem) - 10._wp
@@ -562,5 +563,5 @@
CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==!
!
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
!
zh = gdept(ji,jj,jk,Kmm) * r1_Z0 ! depth
@@ -615,5 +616,5 @@
CASE( np_seos ) !== simplified EOS ==!
!
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 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)
@@ -669,5 +670,5 @@
CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==!
!
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
!
zh = pdep(ji,jj) * r1_Z0 ! depth
@@ -722,5 +723,5 @@
CASE( np_seos ) !== simplified EOS ==!
!
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
!
zt = pts (ji,jj,jp_tem) - 10._wp ! pot. temperature anomaly (t-T0)
@@ -872,5 +873,5 @@
IF( ln_timing ) CALL timing_start('bn2')
!
- DO_3D_11_11( 2, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 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) )
@@ -920,5 +921,5 @@
z1_T0 = 1._wp/40._wp
!
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
!
zt = ctmp (ji,jj) * z1_T0
@@ -973,5 +974,5 @@
!
z1_S0 = 1._wp / 35.16504_wp
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
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 &
@@ -1080,5 +1081,5 @@
CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==!
!
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
!
zh = gdept(ji,jj,jk,Kmm) * r1_Z0 ! depth
@@ -1139,5 +1140,5 @@
CASE( np_seos ) !== Vallis (2006) simplified EOS ==!
!
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 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)
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/traadv.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/traadv.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/traadv.F90 (revision 13540)
@@ -66,4 +66,5 @@
INTEGER, PARAMETER :: np_QCK = 5 ! QUICK scheme
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -98,7 +99,10 @@
IF( ln_wave .AND. ln_sdw ) THEN
DO jk = 1, jpkm1 ! eulerian transport + Stokes Drift
- zuu(:,:,jk) = e2u (:,:) * e3u(:,:,jk,Kmm) * ( uu(:,:,jk,Kmm) + usd(:,:,jk) )
- zvv(:,:,jk) = e1v (:,:) * e3v(:,:,jk,Kmm) * ( vv(:,:,jk,Kmm) + vsd(:,:,jk) )
- zww(:,:,jk) = e1e2t(:,:) * ( ww(:,:,jk) + wsd(:,:,jk) )
+ zuu(:,:,jk) = &
+ & e2u (:,:) * e3u(:,:,jk,Kmm) * ( uu(:,:,jk,Kmm) + usd(:,:,jk) )
+ zvv(:,:,jk) = &
+ & e1v (:,:) * e3v(:,:,jk,Kmm) * ( vv(:,:,jk,Kmm) + vsd(:,:,jk) )
+ zww(:,:,jk) = &
+ & e1e2t(:,:) * ( ww(:,:,jk) + wsd(:,:,jk) )
END DO
ELSE
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/traadv_cen.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/traadv_cen.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/traadv_cen.F90 (revision 13540)
@@ -37,4 +37,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -103,5 +104,5 @@
!
CASE( 2 ) !* 2nd order centered
- DO_3D_10_10( 1, jpkm1 )
+ 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) )
@@ -111,11 +112,11 @@
ztu(:,:,jpk) = 0._wp ! Bottom value : flux set to zero
ztv(:,:,jpk) = 0._wp
- DO_3D_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 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
- CALL lbc_lnk_multi( 'traadv_cen', ztu, 'U', -1. , ztv, 'V', -1. ) ! Lateral boundary cond.
+ CALL lbc_lnk_multi( 'traadv_cen', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp ) ! Lateral boundary cond.
!
- DO_3D_00_10( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 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)
@@ -127,7 +128,8 @@
zwy(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * zC4t_v
END_3D
+ CALL lbc_lnk_multi( 'traadv_cen', zwx, 'U', -1. , zwy, 'V', -1. )
!
CASE DEFAULT
- CALL ctl_stop( 'traadv_fct: wrong value for nn_fct' )
+ CALL ctl_stop( 'traadv_cen: wrong value for nn_cen' )
END SELECT
!
@@ -135,5 +137,5 @@
!
CASE( 2 ) !* 2nd order centered
- DO_3D_00_00( 2, jpk )
+ 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
@@ -141,5 +143,5 @@
CASE( 4 ) !* 4th order compact
CALL interp_4th_cpt( pt(:,:,:,jn,Kmm) , ztw ) ! ztw = interpolated value of T at w-point
- DO_3D_00_00( 2, jpkm1 )
+ 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
@@ -149,5 +151,5 @@
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_11_11
+ 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
@@ -157,11 +159,12 @@
ENDIF
!
- DO_3D_00_00( 1, jpkm1 )
+ 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)
+ & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) &
+ & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm)
END_3D
- ! ! trend diagnostics
+ ! ! trend diagnostics
IF( l_trd ) THEN
CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, zwx, pU, pt(:,:,:,jn,Kmm) )
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/traadv_fct.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/traadv_fct.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/traadv_fct.F90 (revision 13540)
@@ -46,4 +46,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -96,4 +97,14 @@
IF(lwp) WRITE(numout,*) '~~~~~~~~~~~'
ENDIF
+ !! -- init to 0
+ zwi(:,:,:) = 0._wp
+ zwx(:,:,:) = 0._wp
+ zwy(:,:,:) = 0._wp
+ zwz(:,:,:) = 0._wp
+ ztu(:,:,:) = 0._wp
+ ztv(:,:,:) = 0._wp
+ zltu(:,:,:) = 0._wp
+ zltv(:,:,:) = 0._wp
+ ztw(:,:,:) = 0._wp
!
l_trd = .FALSE. ! set local switches
@@ -128,6 +139,7 @@
IF( ll_zAimp ) THEN
ALLOCATE(zwdia(jpi,jpj,jpk), zwinf(jpi,jpj,jpk),zwsup(jpi,jpj,jpk))
- DO_3D_00_00( 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,Krhs)
+ DO_3D( 0, 0, 0, 0, 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,Krhs)
zwinf(ji,jj,jk) = p2dt * MIN( wi(ji,jj,jk ) , 0._wp ) / e3t(ji,jj,jk,Krhs)
zwsup(ji,jj,jk) = -p2dt * MAX( wi(ji,jj,jk+1) , 0._wp ) / e3t(ji,jj,jk,Krhs)
@@ -139,5 +151,5 @@
! !== upstream advection with initial mass fluxes & intermediate update ==!
! !* upstream tracer flux in the i and j direction
- DO_3D_10_10( 1, jpkm1 )
+ DO_3D( 1, 0, 1, 0, 1, jpkm1 )
! upstream scheme
zfp_ui = pU(ji,jj,jk) + ABS( pU(ji,jj,jk) )
@@ -148,28 +160,32 @@
zwy(ji,jj,jk) = 0.5 * ( zfp_vj * pt(ji,jj,jk,jn,Kbb) + zfm_vj * pt(ji ,jj+1,jk,jn,Kbb) )
END_3D
- ! !* upstream tracer flux in the k direction *!
- DO_3D_11_11( 2, jpkm1 )
+ ! !* 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_11_11
+ 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
- zwz(:,:,1) = pW(:,:,1) * pt(:,:,1,jn,Kbb)
+ 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
!
- DO_3D_00_00( 1, jpkm1 )
- ! ! total intermediate advective trends
+ DO_3D( 0, 0, 0, 0, 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)
- ! ! 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,Krhs) * tmask(ji,jj,jk)
+ ! ! 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,Krhs) * tmask(ji,jj,jk)
END_3D
@@ -178,5 +194,5 @@
!
ztw(:,:,1) = 0._wp ; ztw(:,:,jpk) = 0._wp ;
- DO_3D_00_00( 2, jpkm1 )
+ 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) )
@@ -184,5 +200,5 @@
zwz(ji,jj,jk) = zwz(ji,jj,jk) + ztw(ji,jj,jk) ! update vertical fluxes
END_3D
- DO_3D_00_00( 1, jpkm1 )
+ 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)
@@ -202,5 +218,5 @@
!
CASE( 2 ) !- 2nd order centered
- DO_3D_10_10( 1, jpkm1 )
+ 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) ) - zwx(ji,jj,jk)
zwy(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji,jj+1,jk,jn,Kmm) ) - zwy(ji,jj,jk)
@@ -211,19 +227,19 @@
zltv(:,:,jpk) = 0._wp
DO jk = 1, jpkm1 ! Laplacian
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 ) ! 1st derivative (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_2D
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 ) ! 2nd derivative * 1/ 6
zltu(ji,jj,jk) = ( ztu(ji,jj,jk) + ztu(ji-1,jj,jk) ) * r1_6
zltv(ji,jj,jk) = ( ztv(ji,jj,jk) + ztv(ji,jj-1,jk) ) * r1_6
END_2D
END DO
- CALL lbc_lnk_multi( 'traadv_fct', zltu, 'T', 1. , zltv, 'T', 1. ) ! Lateral boundary cond. (unchanged sgn)
- !
- DO_3D_10_10( 1, jpkm1 )
+ CALL lbc_lnk_multi( 'traadv_fct', zltu, 'T', 1.0_wp , zltv, 'T', 1.0_wp ) ! Lateral boundary cond. (unchanged sgn)
+ !
+ DO_3D( 1, 0, 1, 0, 1, jpkm1 ) ! Horizontal advective fluxes
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
+ ! ! C4 minus upstream advective fluxes
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)
@@ -233,11 +249,11 @@
ztu(:,:,jpk) = 0._wp ! Bottom value : flux set to zero
ztv(:,:,jpk) = 0._wp
- DO_3D_10_10( 1, jpkm1 )
+ DO_3D( 1, 0, 1, 0, 1, jpkm1 ) ! 1st derivative (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
- CALL lbc_lnk_multi( 'traadv_fct', ztu, 'U', -1. , ztv, 'V', -1. ) ! Lateral boundary cond. (unchanged sgn)
- !
- DO_3D_00_00( 1, jpkm1 )
+ CALL lbc_lnk_multi( 'traadv_fct', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp ) ! Lateral boundary cond. (unchanged sgn)
+ !
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! Horizontal advective fluxes
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)
@@ -255,5 +271,5 @@
!
CASE( 2 ) !- 2nd order centered
- DO_3D_00_00( 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 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)
@@ -262,5 +278,5 @@
CASE( 4 ) !- 4th order COMPACT
CALL interp_4th_cpt( pt(:,:,:,jn,Kmm) , ztw ) ! zwt = COMPACT interpolation of T at w-point
- DO_3D_00_00( 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
zwz(ji,jj,jk) = ( pW(ji,jj,jk) * ztw(ji,jj,jk) - zwz(ji,jj,jk) ) * wmask(ji,jj,jk)
END_3D
@@ -272,6 +288,6 @@
!
IF ( ll_zAimp ) THEN
- DO_3D_00_00( 1, jpkm1 )
- ! ! total intermediate advective trends
+ DO_3D( 0, 0, 0, 0, 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 ) &
@@ -282,5 +298,5 @@
CALL tridia_solver( zwdia, zwsup, zwinf, ztw, ztw , 0 )
!
- DO_3D_00_00( 2, jpkm1 )
+ 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) )
@@ -289,5 +305,5 @@
END IF
!
- CALL lbc_lnk_multi( 'traadv_fct', zwi, 'T', 1., zwx, 'U', -1. , zwy, 'V', -1., zwz, 'W', 1. )
+ CALL lbc_lnk_multi( 'traadv_fct', zwi, 'T', 1.0_wp, zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp, zwz, 'W', 1.0_wp )
!
! !== monotonicity algorithm ==!
@@ -297,5 +313,5 @@
! !== final trend with corrected fluxes ==!
!
- DO_3D_00_00( 1, jpkm1 )
+ 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 ) &
@@ -308,5 +324,5 @@
!
ztw(:,:,1) = 0._wp ; ztw(:,:,jpk) = 0._wp
- DO_3D_00_00( 2, jpkm1 )
+ 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) )
@@ -314,5 +330,5 @@
zwz(ji,jj,jk) = zwz(ji,jj,jk) + ztw(ji,jj,jk) ! Update vertical fluxes for trend diagnostic
END_3D
- DO_3D_00_00( 1, jpkm1 )
+ 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)
@@ -374,12 +390,12 @@
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) :: zau, zbu, zcu, zav, zbv, zcv, zup, zdo ! - -
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zbetup, zbetdo, zbup, zbdo
- !!----------------------------------------------------------------------
- !
- zbig = 1.e+40_wp
- zrtrn = 1.e-15_wp
- zbetup(:,:,:) = 0._wp ; zbetdo(:,:,:) = 0._wp
+ 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(jpi,jpj,jpk) :: zbetup, zbetdo, zbup, zbdo
+ !!----------------------------------------------------------------------
+ !
+ zbig = 1.e+40_dp
+ zrtrn = 1.e-15_dp
+ zbetup(:,:,:) = 0._dp ; zbetdo(:,:,:) = 0._dp
! Search local extrema
@@ -393,5 +409,5 @@
DO jk = 1, jpkm1
ikm1 = MAX(jk-1,1)
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
! search maximum in neighbourhood
@@ -423,27 +439,27 @@
END_2D
END DO
- CALL lbc_lnk_multi( 'traadv_fct', zbetup, 'T', 1. , zbetdo, 'T', 1. ) ! lateral boundary cond. (unchanged sign)
+ CALL lbc_lnk_multi( 'traadv_fct', zbetup, 'T', 1.0_wp , zbetdo, 'T', 1.0_wp ) ! lateral boundary cond. (unchanged sign)
! 3. monotonic flux in the i & j direction (paa & pbb)
! ----------------------------------------
- DO_3D_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
zau = MIN( 1._wp, zbetdo(ji,jj,jk), zbetup(ji+1,jj,jk) )
zbu = MIN( 1._wp, zbetup(ji,jj,jk), zbetdo(ji+1,jj,jk) )
- zcu = ( 0.5 + SIGN( 0.5 , paa(ji,jj,jk) ) )
+ zcu = ( 0.5 + SIGN( 0.5_wp , paa(ji,jj,jk) ) )
paa(ji,jj,jk) = paa(ji,jj,jk) * ( zcu * zau + ( 1._wp - zcu) * zbu )
zav = MIN( 1._wp, zbetdo(ji,jj,jk), zbetup(ji,jj+1,jk) )
zbv = MIN( 1._wp, zbetup(ji,jj,jk), zbetdo(ji,jj+1,jk) )
- zcv = ( 0.5 + SIGN( 0.5 , pbb(ji,jj,jk) ) )
+ zcv = ( 0.5 + SIGN( 0.5_wp , pbb(ji,jj,jk) ) )
pbb(ji,jj,jk) = pbb(ji,jj,jk) * ( zcv * zav + ( 1._wp - zcv) * zbv )
-! monotonic flux in the k direction, i.e. pcc
-! -------------------------------------------
+ ! monotonic flux in the k direction, i.e. pcc
+ ! -------------------------------------------
za = MIN( 1., zbetdo(ji,jj,jk+1), zbetup(ji,jj,jk) )
zb = MIN( 1., zbetup(ji,jj,jk+1), zbetdo(ji,jj,jk) )
- zc = ( 0.5 + SIGN( 0.5 , pcc(ji,jj,jk+1) ) )
+ zc = ( 0.5 + SIGN( 0.5_wp , pcc(ji,jj,jk+1) ) )
pcc(ji,jj,jk+1) = pcc(ji,jj,jk+1) * ( zc * za + ( 1._wp - zc) * zb )
END_3D
- CALL lbc_lnk_multi( 'traadv_fct', paa, 'U', -1. , pbb, 'V', -1. ) ! lateral boundary condition (changed sign)
+ CALL lbc_lnk_multi( 'traadv_fct', paa, 'U', -1.0_wp , pbb, 'V', -1.0_wp ) ! lateral boundary condition (changed sign)
!
END SUBROUTINE nonosc
@@ -465,5 +481,5 @@
!!----------------------------------------------------------------------
- DO_3D_11_11( 3, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 3, jpkm1 ) !== build the three diagonal matrix ==!
zwd (ji,jj,jk) = 4._wp
zwi (ji,jj,jk) = 1._wp
@@ -479,6 +495,6 @@
END_3D
!
- jk = 2 ! Switch to second order centered at top
- DO_2D_11_11
+ jk = 2 ! Switch to second order centered at top
+ DO_2D( 1, 1, 1, 1 )
zwd (ji,jj,jk) = 1._wp
zwi (ji,jj,jk) = 0._wp
@@ -488,22 +504,22 @@
!
! !== tridiagonal solve ==!
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 ) ! first recurrence
zwt(ji,jj,2) = zwd(ji,jj,2)
END_2D
- DO_3D_11_11( 3, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 3, 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
!
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 ) ! second recurrence: Zk = Yk - Ik / Tk-1 Zk-1
pt_out(ji,jj,2) = zwrm(ji,jj,2)
END_2D
- DO_3D_11_11( 3, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 3, jpkm1 )
pt_out(ji,jj,jk) = zwrm(ji,jj,jk) - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1)
END_3D
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 ) ! third recurrence: Xk = (Zk - Sk Xk+1 ) / Tk
pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1)
END_2D
- DO_3DS_11_11( jpk-2, 2, -1 )
+ DO_3DS( 1, 1, 1, 1, jpk-2, 2, -1 )
pt_out(ji,jj,jk) = ( pt_out(ji,jj,jk) - zws(ji,jj,jk) * pt_out(ji,jj,jk+1) ) / zwt(ji,jj,jk)
END_3D
@@ -530,5 +546,5 @@
! !== build the three diagonal matrix & the RHS ==!
!
- DO_3D_00_00( 3, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 3, jpkm1 ) ! interior (from jk=3 to jpk-1)
zwd (ji,jj,jk) = 3._wp * wmask(ji,jj,jk) + 1._wp ! diagonal
zwi (ji,jj,jk) = wmask(ji,jj,jk) ! lower diagonal
@@ -549,5 +565,5 @@
END IF
!
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 ) ! 2nd order centered at top & bottom
ikt = mikt(ji,jj) + 1 ! w-point below the 1st wet point
ikb = MAX(mbkt(ji,jj), 2) ! - above the last wet point
@@ -566,22 +582,22 @@
! !== tridiagonal solver ==!
!
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 ) !* 1st recurrence: Tk = Dk - Ik Sk-1 / Tk-1
zwt(ji,jj,2) = zwd(ji,jj,2)
END_2D
- DO_3D_00_00( 3, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 3, 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
!
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 ) !* 2nd recurrence: Zk = Yk - Ik / Tk-1 Zk-1
pt_out(ji,jj,2) = zwrm(ji,jj,2)
END_2D
- DO_3D_00_00( 3, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 3, jpkm1 )
pt_out(ji,jj,jk) = zwrm(ji,jj,jk) - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1)
END_3D
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 ) !* 3d recurrence: Xk = (Zk - Sk Xk+1 ) / Tk
pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1)
END_2D
- DO_3DS_00_00( jpk-2, 2, -1 )
+ DO_3DS( 0, 0, 0, 0, jpk-2, 2, -1 )
pt_out(ji,jj,jk) = ( pt_out(ji,jj,jk) - zws(ji,jj,jk) * pt_out(ji,jj,jk+1) ) / zwt(ji,jj,jk)
END_3D
@@ -622,22 +638,22 @@
kstart = 1 + klev
!
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 ) !* 1st recurrence: Tk = Dk - Ik Sk-1 / Tk-1
zwt(ji,jj,kstart) = pD(ji,jj,kstart)
END_2D
- DO_3D_00_00( kstart+1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, kstart+1, jpkm1 )
zwt(ji,jj,jk) = pD(ji,jj,jk) - pL(ji,jj,jk) * pU(ji,jj,jk-1) /zwt(ji,jj,jk-1)
END_3D
!
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 ) !* 2nd recurrence: Zk = Yk - Ik / Tk-1 Zk-1
pt_out(ji,jj,kstart) = pRHS(ji,jj,kstart)
END_2D
- DO_3D_00_00( kstart+1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, kstart+1, jpkm1 )
pt_out(ji,jj,jk) = pRHS(ji,jj,jk) - pL(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1)
END_3D
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 ) !* 3d recurrence: Xk = (Zk - Sk Xk+1 ) / Tk
pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1)
END_2D
- DO_3DS_00_00( jpk-2, kstart, -1 )
+ DO_3DS( 0, 0, 0, 0, jpk-2, kstart, -1 )
pt_out(ji,jj,jk) = ( pt_out(ji,jj,jk) - pU(ji,jj,jk) * pt_out(ji,jj,jk+1) ) / zwt(ji,jj,jk)
END_3D
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/traadv_mus.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/traadv_mus.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/traadv_mus.F90 (revision 13540)
@@ -47,4 +47,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -131,32 +132,32 @@
zwx(:,:,jpk) = 0._wp ! bottom values
zwy(:,:,jpk) = 0._wp
- DO_3D_10_10( 1, jpkm1 )
+ DO_3D( 1, 0, 1, 0, 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
! lateral boundary conditions (changed sign)
- CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1. , zwy, 'V', -1. )
+ CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp )
! !-- Slopes of tracer
zslpx(:,:,jpk) = 0._wp ! bottom values
zslpy(:,:,jpk) = 0._wp
- DO_3D_01_01( 1, jpkm1 )
- zslpx(ji,jj,jk) = ( zwx(ji,jj,jk) + zwx(ji-1,jj ,jk) ) &
- & * ( 0.25 + SIGN( 0.25, 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, zwy(ji,jj,jk) * zwy(ji ,jj-1,jk) ) )
- END_3D
- !
- DO_3D_01_01( 1, jpkm1 )
- zslpx(ji,jj,jk) = SIGN( 1., 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., 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
- !
- DO_3D_00_00( 1, jpkm1 )
+ DO_3D( 0, 1, 0, 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( 0, 1, 0, 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
+ !
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !-- MUSCL horizontal advective fluxes
! MUSCL fluxes
- z0u = SIGN( 0.5, pU(ji,jj,jk) )
+ 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)
@@ -165,5 +166,5 @@
zwx(ji,jj,jk) = pU(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy )
!
- z0v = SIGN( 0.5, pV(ji,jj,jk) )
+ 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)
@@ -172,7 +173,7 @@
zwy(ji,jj,jk) = pV(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy )
END_3D
- CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1. , zwy, 'V', -1. ) ! lateral boundary conditions (changed sign)
- !
- DO_3D_00_00( 1, jpkm1 )
+ CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp ) ! lateral boundary conditions (changed sign)
+ !
+ 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 ) ) &
@@ -199,15 +200,15 @@
! !-- Slopes of tracer
zslpx(:,:,1) = 0._wp ! surface values
- DO_3D_11_11( 2, jpkm1 )
- zslpx(ji,jj,jk) = ( zwx(ji,jj,jk) + zwx(ji,jj,jk+1) ) &
- & * ( 0.25 + SIGN( 0.25, zwx(ji,jj,jk) * zwx(ji,jj,jk+1) ) )
- END_3D
- DO_3D_11_11( 2, jpkm1 )
- zslpx(ji,jj,jk) = SIGN( 1., 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_00_00( 1, jpk-2 )
- z0w = SIGN( 0.5, pW(ji,jj,jk+1) )
+ DO_3D( 1, 1, 1, 1, 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( 1, 1, 1, 1, 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)
@@ -218,5 +219,5 @@
IF( ln_linssh ) THEN ! top values, linear free surface only
IF( ln_isfcav ) THEN ! ice-shelf cavities (top of the ocean)
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
zwx(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kbb)
END_2D
@@ -226,6 +227,7 @@
ENDIF
!
- DO_3D_00_00( 1, jpkm1 )
- 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)
+ 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
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/traadv_qck.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/traadv_qck.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/traadv_qck.F90 (revision 13540)
@@ -41,4 +41,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -141,20 +142,20 @@
!
!!gm why not using a SHIFT instruction...
- DO_3D_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !--- Computation of the ustream and downstream value of the tracer and the mask
zfc(ji,jj,jk) = pt(ji-1,jj,jk,jn,Kbb) ! Upstream in the x-direction for the tracer
zfd(ji,jj,jk) = pt(ji+1,jj,jk,jn,Kbb) ! Downstream in the x-direction for the tracer
END_3D
- CALL lbc_lnk_multi( 'traadv_qck', zfc(:,:,:), 'T', 1. , zfd(:,:,:), 'T', 1. ) ! Lateral boundary conditions
+ CALL lbc_lnk_multi( 'traadv_qck', zfc(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp ) ! Lateral boundary conditions
!
! Horizontal advective fluxes
! ---------------------------
- DO_3D_00_00( 1, jpkm1 )
- zdir = 0.5 + SIGN( 0.5, pU(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ zdir = 0.5 + SIGN( 0.5_wp, pU(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0
zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji+1,jj,jk) ! FU in the x-direction for T
END_3D
!
- DO_3D_00_00( 1, jpkm1 )
- zdir = 0.5 + SIGN( 0.5, pU(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ zdir = 0.5 + SIGN( 0.5_wp, pU(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0
zdx = ( zdir * e1t(ji,jj) + ( 1. - zdir ) * e1t(ji+1,jj) ) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm)
zwx(ji,jj,jk) = ABS( pU(ji,jj,jk) ) * p2dt / zdx ! (0 0 : zdir = 1 otherwise zdir = 0
+ DO_2D( 0, 0, 0, 0 )
+ zdir = 0.5 + SIGN( 0.5_wp, pU(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0
!--- If the second ustream point is a land point
!--- the flux is computed by the 1st order UPWIND scheme
@@ -188,8 +189,8 @@
END DO
!
- CALL lbc_lnk( 'traadv_qck', zwx(:,:,:), 'T', 1. ) ! Lateral boundary conditions
+ CALL lbc_lnk( 'traadv_qck', zwx(:,:,:), 'T', 1.0_wp ) ! Lateral boundary conditions
!
! Computation of the trend
- DO_3D_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
zbtr = r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm)
! horizontal advective trends
@@ -232,5 +233,5 @@
!
!--- Computation of the ustream and downstream value of the tracer and the mask
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
! Upstream in the x-direction for the tracer
zfc(ji,jj,jk) = pt(ji,jj-1,jk,jn,Kbb)
@@ -239,5 +240,5 @@
END_2D
END DO
- CALL lbc_lnk_multi( 'traadv_qck', zfc(:,:,:), 'T', 1. , zfd(:,:,:), 'T', 1. ) ! Lateral boundary conditions
+ CALL lbc_lnk_multi( 'traadv_qck', zfc(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp ) ! Lateral boundary conditions
@@ -246,11 +247,11 @@
! ---------------------------
!
- DO_3D_00_00( 1, jpkm1 )
- zdir = 0.5 + SIGN( 0.5, pV(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ zdir = 0.5 + SIGN( 0.5_wp, pV(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0
zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji,jj+1,jk) ! FU in the x-direction for T
END_3D
!
- DO_3D_00_00( 1, jpkm1 )
- zdir = 0.5 + SIGN( 0.5, pV(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ zdir = 0.5 + SIGN( 0.5_wp, pV(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0
zdx = ( zdir * e2t(ji,jj) + ( 1. - zdir ) * e2t(ji,jj+1) ) * e1v(ji,jj) * e3v(ji,jj,jk,Kmm)
zwy(ji,jj,jk) = ABS( pV(ji,jj,jk) ) * p2dt / zdx ! (0 0 : zdir = 1 otherwise zdir = 0
+ DO_2D( 0, 0, 0, 0 )
+ zdir = 0.5 + SIGN( 0.5_wp, pV(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0
!--- If the second ustream point is a land point
!--- the flux is computed by the 1st order UPWIND scheme
@@ -284,8 +285,8 @@
END DO
!
- CALL lbc_lnk( 'traadv_qck', zwy(:,:,:), 'T', 1. ) ! Lateral boundary conditions
+ CALL lbc_lnk( 'traadv_qck', zwy(:,:,:), 'T', 1.0_wp ) ! Lateral boundary conditions
!
! Computation of the trend
- DO_3D_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
zbtr = r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm)
! horizontal advective trends
@@ -326,10 +327,10 @@
! ! ===========
!
- DO_3D_00_00( 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 ) !* Interior point (w-masked 2nd order centered flux)
zwz(ji,jj,jk) = 0.5 * pW(ji,jj,jk) * ( pt(ji,jj,jk-1,jn,Kmm) + pt(ji,jj,jk,jn,Kmm) ) * wmask(ji,jj,jk)
END_3D
IF( ln_linssh ) THEN !* top value (only in linear free surf. as zwz is multiplied by wmask)
IF( ln_isfcav ) THEN ! ice-shelf cavities (top of the ocean)
- DO_2D_11_11
+ 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) ! linear free surface
END_2D
@@ -339,5 +340,5 @@
ENDIF
!
- DO_3D_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !== Tracer flux divergence added to the general trend ==!
pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( zwz(ji,jj,jk) - zwz(ji,jj,jk+1) ) &
& * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm)
@@ -368,5 +369,5 @@
!----------------------------------------------------------------------
!
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
zc = puc(ji,jj,jk) ! Courant number
zcurv = pfd(ji,jj,jk) + pfu(ji,jj,jk) - 2. * pfc(ji,jj,jk)
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/traadv_ubs.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/traadv_ubs.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/traadv_ubs.F90 (revision 13540)
@@ -39,4 +39,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -82,5 +83,5 @@
!!
!! Reference : Shchepetkin, A. F., J. C. McWilliams, 2005, Ocean Modelling, 9, 347-404.
- !! Farrow, D.E., Stevens, D.P., 1995, J. Phys. Ocean. 25, 1731Ð1741.
+ !! Farrow, D.E., Stevens, D.P., 1995, J. Phys. Ocean. 25, 1731�1741.
!!----------------------------------------------------------------------
INTEGER , INTENT(in ) :: kt ! ocean time-step index
@@ -123,6 +124,6 @@
! ! ===========
!
- DO jk = 1, jpkm1 !== horizontal laplacian of before tracer ==!
- DO_2D_10_10
+ DO jk = 1, jpkm1 !== horizontal laplacian of before tracer ==!
+ DO_2D( 1, 0, 1, 0 ) ! First derivative (masked gradient)
zeeu = e2_e1u(ji,jj) * e3u(ji,jj,jk,Kmm) * umask(ji,jj,jk)
zeev = e1_e2v(ji,jj) * e3v(ji,jj,jk,Kmm) * vmask(ji,jj,jk)
@@ -130,5 +131,5 @@
ztv(ji,jj,jk) = zeev * ( pt(ji ,jj+1,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) )
END_2D
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 ) ! Second derivative (divergence)
zcoef = 1._wp / ( 6._wp * e3t(ji,jj,jk,Kmm) )
zltu(ji,jj,jk) = ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) ) * zcoef
@@ -137,8 +138,8 @@
!
END DO
- CALL lbc_lnk( 'traadv_ubs', zltu, 'T', 1. ) ; CALL lbc_lnk( 'traadv_ubs', zltv, 'T', 1. ) ! Lateral boundary cond. (unchanged sgn)
+ CALL lbc_lnk( 'traadv_ubs', zltu, 'T', 1.0_wp ) ; CALL lbc_lnk( 'traadv_ubs', zltv, 'T', 1.0_wp ) ! Lateral boundary cond. (unchanged sgn)
!
- DO_3D_10_10( 1, jpkm1 )
- zfp_ui = pU(ji,jj,jk) + ABS( pU(ji,jj,jk) ) ! upstream transport (x2)
+ DO_3D( 1, 0, 1, 0, 1, jpkm1 ) !== Horizontal advective fluxes ==! (UBS)
+ zfp_ui = pU(ji,jj,jk) + ABS( pU(ji,jj,jk) ) ! upstream transport (x2)
zfm_ui = pU(ji,jj,jk) - ABS( pU(ji,jj,jk) )
zfp_vj = pV(ji,jj,jk) + ABS( pV(ji,jj,jk) )
@@ -155,8 +156,9 @@
!
DO jk = 1, jpkm1 !== add the horizontal advective trend ==!
- DO_2D_00_00
+ 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) ) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm)
+ & + ztv(ji,jj,jk) - ztv(ji ,jj-1,jk) ) &
+ & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm)
END_2D
!
@@ -164,5 +166,5 @@
!
zltu(:,:,:) = pt(:,:,:,jn,Krhs) - zltu(:,:,:) ! Horizontal advective trend used in vertical 2nd order FCT case
- ! ! and/or in trend diagnostic (l_trd=T)
+ ! ! and/or in trend diagnostic (l_trd=T)
!
IF( l_trd ) THEN ! trend diagnostics
@@ -185,29 +187,30 @@
IF( l_trd ) zltv(:,:,:) = pt(:,:,:,jn,Krhs) ! store pt(:,:,:,:,Krhs) if trend diag.
!
- ! !* upstream advection with initial mass fluxes & intermediate update ==!
- DO_3D_11_11( 2, jpkm1 )
+ ! !* upstream advection with initial mass fluxes & intermediate update ==!
+ DO_3D( 1, 1, 1, 1, 2, jpkm1 )
zfp_wk = pW(ji,jj,jk) + ABS( pW(ji,jj,jk) )
zfm_wk = pW(ji,jj,jk) - ABS( pW(ji,jj,jk) )
ztw(ji,jj,jk) = 0.5_wp * ( 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 ztw has been w-masked)
- IF( ln_isfcav ) THEN ! top of the ice-shelf cavities and at the ocean surface
- DO_2D_11_11
+ IF( ln_linssh ) THEN ! top ocean value (only in linear free surface as ztw 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 )
ztw(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
+ ELSE ! no cavities: only at the ocean surface
ztw(:,:,1) = pW(:,:,1) * pt(:,:,1,jn,Kbb)
ENDIF
ENDIF
!
- DO_3D_00_00( 1, jpkm1 )
- ztak = - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !* trend and after field with monotonic scheme
+ ztak = - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) &
+ & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm)
pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + ztak
zti(ji,jj,jk) = ( pt(ji,jj,jk,jn,Kbb) + p2dt * ( ztak + zltu(ji,jj,jk) ) ) * tmask(ji,jj,jk)
END_3D
- CALL lbc_lnk( 'traadv_ubs', zti, 'T', 1. ) ! Lateral boundary conditions on zti, zsi (unchanged sign)
+ CALL lbc_lnk( 'traadv_ubs', zti, 'T', 1.0_wp ) ! Lateral boundary conditions on zti, zsi (unchanged sign)
!
! !* anti-diffusive flux : high order minus low order
- DO_3D_11_11( 2, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 2, jpkm1 )
ztw(ji,jj,jk) = ( 0.5_wp * pW(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji,jj,jk-1,jn,Kmm) ) &
& - ztw(ji,jj,jk) ) * wmask(ji,jj,jk)
@@ -220,5 +223,5 @@
CASE( 4 ) ! 4th order COMPACT
CALL interp_4th_cpt( pt(:,:,:,jn,Kmm) , ztw ) ! 4th order compact interpolation of T at w-point
- DO_3D_00_00( 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
ztw(ji,jj,jk) = pW(ji,jj,jk) * ztw(ji,jj,jk) * wmask(ji,jj,jk)
END_3D
@@ -227,10 +230,11 @@
END SELECT
!
- DO_3D_00_00( 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)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! final trend with corrected fluxes
+ 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
!
- IF( l_trd ) THEN ! vertical advective trend diagnostics
- DO_3D_00_00( 1, jpkm1 )
+ IF( l_trd ) THEN ! vertical advective trend diagnostics
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! (compute -w.dk[ptn]= -dk[w.ptn] + ptn.dk[w])
zltv(ji,jj,jk) = pt(ji,jj,jk,jn,Krhs) - zltv(ji,jj,jk) &
& + pt(ji,jj,jk,jn,Kmm) * ( pW(ji,jj,jk) - pW(ji,jj,jk+1) ) &
@@ -270,5 +274,5 @@
!!----------------------------------------------------------------------
!
- zbig = 1.e+40_wp
+ zbig = 1.e+38_wp
zrtrn = 1.e-15_wp
zbetup(:,:,:) = 0._wp ; zbetdo(:,:,:) = 0._wp
@@ -282,5 +286,5 @@
DO jk = 1, jpkm1 ! search maximum in neighbourhood
ikm1 = MAX(jk-1,1)
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
zbetup(ji,jj,jk) = MAX( pbef(ji ,jj ,jk ), paft(ji ,jj ,jk ), &
& pbef(ji ,jj ,ikm1), pbef(ji ,jj ,jk+1), &
@@ -294,5 +298,5 @@
DO jk = 1, jpkm1 ! search minimum in neighbourhood
ikm1 = MAX(jk-1,1)
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
zbetdo(ji,jj,jk) = MIN( pbef(ji ,jj ,jk ), paft(ji ,jj ,jk ), &
& pbef(ji ,jj ,ikm1), pbef(ji ,jj ,jk+1), &
@@ -306,5 +310,5 @@
! Positive and negative part of fluxes and beta terms
! ---------------------------------------------------
- DO_3D_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
! positive & negative part of the flux
zpos = MAX( 0., pcc(ji ,jj ,jk+1) ) - MIN( 0., pcc(ji ,jj ,jk ) )
@@ -318,8 +322,8 @@
! monotonic flux in the k direction, i.e. pcc
! -------------------------------------------
- DO_3D_00_00( 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
za = MIN( 1., zbetdo(ji,jj,jk), zbetup(ji,jj,jk-1) )
zb = MIN( 1., zbetup(ji,jj,jk), zbetdo(ji,jj,jk-1) )
- zc = 0.5 * ( 1.e0 + SIGN( 1.e0, pcc(ji,jj,jk) ) )
+ zc = 0.5 * ( 1.e0 + SIGN( 1.0_wp, pcc(ji,jj,jk) ) )
pcc(ji,jj,jk) = pcc(ji,jj,jk) * ( zc * za + ( 1.e0 - zc) * zb )
END_3D
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/traatf.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/traatf.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/traatf.F90 (revision 13540)
@@ -58,4 +58,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -109,5 +110,5 @@
#endif
! ! local domain boundaries (T-point, unchanged sign)
- CALL lbc_lnk_multi( 'traatf', pts(:,:,:,jp_tem,Kaa), 'T', 1., pts(:,:,:,jp_sal,Kaa), 'T', 1. )
+ CALL lbc_lnk_multi( '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
@@ -155,15 +156,14 @@
ENDIF
!
- CALL lbc_lnk_multi( 'traatf', pts(:,:,:,jp_tem,Kbb) , 'T', 1., pts(:,:,:,jp_sal,Kbb) , 'T', 1., &
- & pts(:,:,:,jp_tem,Kmm) , 'T', 1., pts(:,:,:,jp_sal,Kmm) , 'T', 1., &
- & pts(:,:,:,jp_tem,Kaa), 'T', 1., pts(:,:,:,jp_sal,Kaa), 'T', 1. )
+ CALL lbc_lnk_multi( 'traatf', pts(:,:,:,jp_tem,Kbb) , 'T', 1.0_wp, pts(:,:,:,jp_sal,Kbb) , 'T', 1.0_wp, &
+ & pts(:,:,:,jp_tem,Kmm) , 'T', 1.0_wp, pts(:,:,:,jp_sal,Kmm) , 'T', 1.0_wp, &
+ & pts(:,:,:,jp_tem,Kaa), 'T', 1.0_wp, pts(:,:,:,jp_sal,Kaa), 'T', 1.0_wp )
!
ENDIF
!
IF( l_trdtra .AND. ln_linssh ) THEN ! trend of the Asselin filter (tb filtered - tb)/dt
- zfact = 1._wp / rDt
DO jk = 1, jpkm1
- ztrdt(:,:,jk) = ( pts(:,:,jk,jp_tem,Kmm) - ztrdt(:,:,jk) ) * zfact
- ztrds(:,:,jk) = ( pts(:,:,jk,jp_sal,Kmm) - ztrds(:,:,jk) ) * zfact
+ 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 )
@@ -210,5 +210,5 @@
DO jn = 1, kjpt
!
- DO_3D_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 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
@@ -229,6 +229,6 @@
!!
!! ** 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_a*pt(Kaa) ] )
- !! /( e3t(Kmm) + rn_atfp*[ e3t(Kbb) - 2 e3t(Kmm) + e3t(Kaa) ] )
+ !! 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
@@ -275,5 +275,5 @@
zfact2 = zfact1 * r1_rho0
DO jn = 1, kjpt
- DO_3D_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
ze3t_b = e3t(ji,jj,jk,Kbb)
ze3t_n = e3t(ji,jj,jk,Kmm)
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/traatf_qco.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/traatf_qco.F90 (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/traatf_qco.F90 (revision 13540)
@@ -0,0 +1,374 @@
+MODULE traatfqco
+ !!======================================================================
+ !! *** MODULE traatfqco ***
+ !! 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 -> traatfLF.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_qco ! routine called by step.F90
+ PUBLIC tra_atf_fix_lf ! to be used in trcnxt !!st WARNING discrepancy here interpol is used by PISCES
+ PUBLIC tra_atf_qco_lf ! to be used in trcnxt !!st WARNING discrepancy here interpol is used by PISCES
+
+ !! * Substitutions
+# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
+ !!----------------------------------------------------------------------
+ !! NEMO/OCE 4.0 , NEMO Consortium (2018)
+ !! $Id$
+ !! Software governed by the CeCILL license (see ./LICENSE)
+ !!----------------------------------------------------------------------
+CONTAINS
+
+ SUBROUTINE tra_atf_qco( kt, Kbb, Kmm, Kaa, pts )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE traatfLF ***
+ !!
+ !! ** 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_qco')
+ !
+ IF( kt == nit000 ) THEN
+ IF(lwp) WRITE(numout,*)
+ IF(lwp) WRITE(numout,*) 'tra_atf_qco : apply Asselin time filter to "now" fields'
+ IF(lwp) WRITE(numout,*) '~~~~~~~'
+ ENDIF
+!!st Update after tracer on domain lateral boundaries as been removed outside
+
+ ! trends computation initialisation
+ IF( l_trdtra ) THEN
+ ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) )
+ ztrdt(:,:,jpk) = 0._wp
+ ztrds(:,:,jpk) = 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) * (1._wp + r3t(:,:,Kaa) * tmask(:,:,jk))/(1._wp + r3t(:,:,Kmm) * tmask(:,:,jk)) &
+ & - pts(:,:,jk,jp_tem,Kmm) ) * zfact
+ ztrds(:,:,jk) = ( pts(:,:,jk,jp_sal,Kaa) * (1._wp + r3t(:,:,Kaa) * tmask(:,:,jk))/(1._wp + r3t(:,:,Kmm) * tmask(:,:,jk)) &
+ & - 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_lf( kt, Kbb, Kmm, Kaa, nit000, 'TRA', pts, jpts ) ! linear free surface
+ 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_multi( 'traatfqco', pts(:,:,:,jp_tem,Kbb) , 'T', 1., pts(:,:,:,jp_sal,Kbb) , 'T', 1., &
+ & pts(:,:,:,jp_tem,Kmm) , 'T', 1., pts(:,:,:,jp_sal,Kmm) , 'T', 1., &
+ & pts(:,:,:,jp_tem,Kaa), 'T', 1., pts(:,:,:,jp_sal,Kaa), 'T', 1. )
+ !
+ 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_qco')
+ !
+ END SUBROUTINE tra_atf_qco
+
+
+ SUBROUTINE tra_atf_fix_lf( 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_lf : time filtering', cdtype
+ IF(lwp) WRITE(numout,*) '~~~~~~~~~~~'
+ ENDIF
+ !
+ DO jn = 1, kjpt
+ !
+ DO_3D( 0, 0, 0, 0, 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_lf
+
+
+ SUBROUTINE tra_atf_qco_lf( 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_m*pt(Kmm) + rn_atfp*[ e3t_b*pt(Kbb) - 2 e3t_m*pt(Kmm) + e3t_a*pt(Kaa) ] )
+ !! /( e3t_m + rn_atfp*[ e3t_b - 2 e3t_m + e3t_a ] )
+ !!
+ !! ** 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 ! - -
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: ztrd_atf
+ !!----------------------------------------------------------------------
+ !
+ IF( kt == kit000 ) THEN
+ IF(lwp) WRITE(numout,*)
+ IF(lwp) WRITE(numout,*) 'tra_atf_qco : 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
+ zfact = 1._wp / p2dt
+ zfact1 = rn_atfp * p2dt
+ zfact2 = zfact1 * r1_rho0
+ DO jn = 1, kjpt
+ DO_3D( 0, 0, 0, 0, 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
+ !
+ ztc_d = ztc_a - 2. * ztc_n + ztc_b
+ !
+ ztc_f = ztc_n + rn_atfp * ztc_d
+ !
+ ! Asselin correction on scale factors is done via ssh in r3t_f
+ ze3t_f = e3t_0(ji,jj,jk) * ( 1._wp + r3t_f(ji,jj) * tmask(ji,jj,jk) )
+
+ !
+ 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 ?
+ 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_qco_lf
+
+ !!======================================================================
+END MODULE traatfqco
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/trabbc.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/trabbc.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/trabbc.F90 (revision 13540)
@@ -46,4 +46,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -90,9 +91,10 @@
ENDIF
! ! Add the geothermal trend on temperature
- DO_2D_00_00
- pts(ji,jj,mbkt(ji,jj),jp_tem,Krhs) = pts(ji,jj,mbkt(ji,jj),jp_tem,Krhs) + qgh_trd0(ji,jj) / e3t(ji,jj,mbkt(ji,jj),Kmm)
+ DO_2D( 0, 0, 0, 0 )
+ pts(ji,jj,mbkt(ji,jj),jp_tem,Krhs) = pts(ji,jj,mbkt(ji,jj),jp_tem,Krhs) &
+ & + qgh_trd0(ji,jj) / e3t(ji,jj,mbkt(ji,jj),Kmm)
END_2D
!
- CALL lbc_lnk( 'trabbc', pts(:,:,:,jp_tem,Krhs) , 'T', 1. )
+ CALL lbc_lnk( 'trabbc', pts(:,:,:,jp_tem,Krhs) , 'T', 1.0_wp )
!
IF( l_trdtra ) THEN ! Send the trend for diagnostics
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/trabbl.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/trabbl.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/trabbl.F90 (revision 13540)
@@ -68,4 +68,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -125,5 +126,5 @@
& tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' )
! lateral boundary conditions ; just need for outputs
- CALL lbc_lnk_multi( 'trabbl', ahu_bbl, 'U', 1. , ahv_bbl, 'V', 1. )
+ CALL lbc_lnk_multi( 'trabbl', ahu_bbl, 'U', 1.0_wp , ahv_bbl, 'V', 1.0_wp )
CALL iom_put( "ahu_bbl", ahu_bbl ) ! bbl diffusive flux i-coef
CALL iom_put( "ahv_bbl", ahv_bbl ) ! bbl diffusive flux j-coef
@@ -138,5 +139,5 @@
& tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' )
! lateral boundary conditions ; just need for outputs
- CALL lbc_lnk_multi( 'trabbl', utr_bbl, 'U', 1. , vtr_bbl, 'V', 1. )
+ CALL lbc_lnk_multi( 'trabbl', utr_bbl, 'U', 1.0_wp , vtr_bbl, 'V', 1.0_wp )
CALL iom_put( "uoce_bbl", utr_bbl ) ! bbl i-transport
CALL iom_put( "voce_bbl", vtr_bbl ) ! bbl j-transport
@@ -191,10 +192,10 @@
DO jn = 1, kjpt ! tracer loop
! ! ===========
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
ik = mbkt(ji,jj) ! bottom T-level index
zptb(ji,jj) = pt(ji,jj,ik,jn) ! bottom before T and S
END_2D
!
- DO_2D_00_00
+ 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) &
@@ -342,5 +343,5 @@
ENDIF
! !* bottom variables (T, S, alpha, beta, depth, velocity)
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
ik = mbkt(ji,jj) ! bottom T-level index
zts (ji,jj,jp_tem) = ts(ji,jj,ik,jp_tem,Kbb) ! bottom before T and S
@@ -357,5 +358,5 @@
IF( nn_bbl_ldf == 1 ) THEN ! diffusive bbl !
! !-------------------!
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 ) ! (criteria for non zero flux: grad(rho).grad(h) < 0 )
! ! i-direction
za = zab(ji+1,jj,jp_tem) + zab(ji,jj,jp_tem) ! 2*(alpha,beta) at u-point
@@ -365,5 +366,5 @@
& - zb * ( zts(ji+1,jj,jp_sal) - zts(ji,jj,jp_sal) ) ) * umask(ji,jj,1)
!
- zsign = SIGN( 0.5, -zgdrho * REAL( mgrhu(ji,jj) ) ) ! sign of ( i-gradient * i-slope )
+ zsign = SIGN( 0.5_wp, -zgdrho * REAL( mgrhu(ji,jj) ) ) ! sign of ( i-gradient * i-slope )
ahu_bbl(ji,jj) = ( 0.5 - zsign ) * ahu_bbl_0(ji,jj) ! masked diffusive flux coeff.
!
@@ -375,5 +376,5 @@
& - zb * ( zts(ji,jj+1,jp_sal) - zts(ji,jj,jp_sal) ) ) * vmask(ji,jj,1)
!
- zsign = SIGN( 0.5, -zgdrho * REAL( mgrhv(ji,jj) ) ) ! sign of ( j-gradient * j-slope )
+ zsign = SIGN( 0.5_wp, -zgdrho * REAL( mgrhv(ji,jj) ) ) ! sign of ( j-gradient * j-slope )
ahv_bbl(ji,jj) = ( 0.5 - zsign ) * ahv_bbl_0(ji,jj)
END_2D
@@ -387,5 +388,5 @@
!
CASE( 1 ) != use of upper velocity
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 ) ! criteria: grad(rho).grad(h)<0 and grad(rho).grad(h)<0
! ! i-direction
za = zab(ji+1,jj,jp_tem) + zab(ji,jj,jp_tem) ! 2*(alpha,beta) at u-point
@@ -395,6 +396,6 @@
- zb * ( zts(ji+1,jj,jp_sal) - zts(ji,jj,jp_sal) ) ) * umask(ji,jj,1)
!
- zsign = SIGN( 0.5, - zgdrho * REAL( mgrhu(ji,jj) ) ) ! sign of i-gradient * i-slope
- zsigna= SIGN( 0.5, zub(ji,jj) * REAL( mgrhu(ji,jj) ) ) ! sign of u * i-slope
+ zsign = SIGN( 0.5_wp, - zgdrho * REAL( mgrhu(ji,jj) ) ) ! sign of i-gradient * i-slope
+ zsigna= SIGN( 0.5_wp, zub(ji,jj) * REAL( mgrhu(ji,jj) ) ) ! sign of u * i-slope
!
! ! bbl velocity
@@ -407,6 +408,6 @@
zgdrho = ( za * ( zts(ji,jj+1,jp_tem) - zts(ji,jj,jp_tem) ) &
& - zb * ( zts(ji,jj+1,jp_sal) - zts(ji,jj,jp_sal) ) ) * vmask(ji,jj,1)
- zsign = SIGN( 0.5, - zgdrho * REAL( mgrhv(ji,jj) ) ) ! sign of j-gradient * j-slope
- zsigna= SIGN( 0.5, zvb(ji,jj) * REAL( mgrhv(ji,jj) ) ) ! sign of u * i-slope
+ zsign = SIGN( 0.5_wp, - zgdrho * REAL( mgrhv(ji,jj) ) ) ! sign of j-gradient * j-slope
+ zsigna= SIGN( 0.5_wp, zvb(ji,jj) * REAL( mgrhv(ji,jj) ) ) ! sign of u * i-slope
!
! ! bbl transport
@@ -416,5 +417,5 @@
CASE( 2 ) != bbl velocity = F( delta rho )
zgbbl = grav * rn_gambbl
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 ) ! criteria: rho_up > rho_down
! ! i-direction
! down-slope T-point i/k-index (deep) & up-slope T-point i/k-index (shelf)
@@ -504,9 +505,11 @@
IF( tra_bbl_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'tra_bbl_init : unable to allocate arrays' )
!
- IF( nn_bbl_adv == 1 ) WRITE(numout,*) ' * Advective BBL using upper velocity'
- IF( nn_bbl_adv == 2 ) WRITE(numout,*) ' * Advective BBL using velocity = F( delta rho)'
+ IF(lwp) THEN
+ IF( nn_bbl_adv == 1 ) WRITE(numout,*) ' * Advective BBL using upper velocity'
+ IF( nn_bbl_adv == 2 ) WRITE(numout,*) ' * Advective BBL using velocity = F( delta rho)'
+ ENDIF
!
! !* vertical index of "deep" bottom u- and v-points
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 ) ! (the "shelf" bottom k-indices are mbku and mbkv)
mbku_d(ji,jj) = MAX( mbkt(ji+1,jj ) , mbkt(ji,jj) ) ! >= 1 as mbkt=1 over land
mbkv_d(ji,jj) = MAX( mbkt(ji ,jj+1) , mbkt(ji,jj) )
@@ -514,24 +517,24 @@
! converte into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk
zmbku(:,:) = REAL( mbku_d(:,:), wp ) ; zmbkv(:,:) = REAL( mbkv_d(:,:), wp )
- CALL lbc_lnk_multi( 'trabbl', zmbku,'U',1., zmbkv,'V',1.)
+ CALL lbc_lnk_multi( 'trabbl', zmbku,'U',1.0_wp, zmbkv,'V',1.0_wp)
mbku_d(:,:) = MAX( INT( zmbku(:,:) ), 1 ) ; mbkv_d(:,:) = MAX( NINT( zmbkv(:,:) ), 1 )
!
! !* sign of grad(H) at u- and v-points; zero if grad(H) = 0
mgrhu(:,:) = 0 ; mgrhv(:,:) = 0
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
IF( gdept_0(ji+1,jj,mbkt(ji+1,jj)) - gdept_0(ji,jj,mbkt(ji,jj)) /= 0._wp ) THEN
- mgrhu(ji,jj) = INT( SIGN( 1.e0, gdept_0(ji+1,jj,mbkt(ji+1,jj)) - gdept_0(ji,jj,mbkt(ji,jj)) ) )
+ mgrhu(ji,jj) = INT( SIGN( 1.0_wp, gdept_0(ji+1,jj,mbkt(ji+1,jj)) - gdept_0(ji,jj,mbkt(ji,jj)) ) )
ENDIF
!
IF( gdept_0(ji,jj+1,mbkt(ji,jj+1)) - gdept_0(ji,jj,mbkt(ji,jj)) /= 0._wp ) THEN
- mgrhv(ji,jj) = INT( SIGN( 1.e0, gdept_0(ji,jj+1,mbkt(ji,jj+1)) - gdept_0(ji,jj,mbkt(ji,jj)) ) )
+ mgrhv(ji,jj) = INT( SIGN( 1.0_wp, gdept_0(ji,jj+1,mbkt(ji,jj+1)) - gdept_0(ji,jj,mbkt(ji,jj)) ) )
ENDIF
END_2D
!
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 ) !* bbl thickness at u- (v-) point; minimum of top & bottom e3u_0 (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
- CALL lbc_lnk_multi( 'trabbl', e3u_bbl_0, 'U', 1. , e3v_bbl_0, 'V', 1. ) ! lateral boundary conditions
+ CALL lbc_lnk_multi( 'trabbl', e3u_bbl_0, 'U', 1.0_wp , e3v_bbl_0, 'V', 1.0_wp ) ! lateral boundary conditions
!
! !* masked diffusive flux coefficients
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/tradmp.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/tradmp.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/tradmp.F90 (revision 13540)
@@ -112,5 +112,5 @@
CASE( 0 ) !* newtonian damping throughout the water column *!
DO jn = 1, jpts
- DO_3D_00_00( 1, jpkm1 )
+ 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) )
@@ -119,5 +119,5 @@
!
CASE ( 1 ) !* no damping in the turbocline (avt > 5 cm2/s) *!
- DO_3D_00_00( 1, jpkm1 )
+ 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) &
@@ -129,5 +129,5 @@
!
CASE ( 2 ) !* no damping in the mixed layer *!
- DO_3D_00_00( 1, jpkm1 )
+ 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) &
@@ -208,5 +208,5 @@
! ! Read in mask from file
CALL iom_open ( cn_resto, imask)
- CALL iom_get ( imask, jpdom_autoglo, 'resto', resto )
+ CALL iom_get ( imask, jpdom_auto, 'resto', resto )
CALL iom_close( imask )
ENDIF
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/traisf.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/traisf.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/traisf.F90 (revision 13540)
@@ -11,5 +11,5 @@
!!----------------------------------------------------------------------
USE isf_oce ! Ice shelf variables
- USE dom_oce , ONLY : e3t, r1_e1e2t ! ocean space domain variables
+ USE dom_oce ! ocean space domain variables
USE isfutils, ONLY : debug ! debug option
USE timing , ONLY : timing_start, timing_stop ! Timing
@@ -23,4 +23,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -107,5 +108,5 @@
!
! update pts(:,:,:,:,Krhs)
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
!
ikt = ktop(ji,jj)
@@ -140,6 +141,8 @@
!
DO jk = 1,jpk
- ptsa(:,:,jk,jp_tem) = ptsa(:,:,jk,jp_tem) + ptsc(:,:,jk,jp_tem) * r1_e1e2t(:,:) / e3t(:,:,jk,Kmm)
- ptsa(:,:,jk,jp_sal) = ptsa(:,:,jk,jp_sal) + ptsc(:,:,jk,jp_sal) * r1_e1e2t(:,:) / e3t(:,:,jk,Kmm)
+ ptsa(:,:,jk,jp_tem) = &
+ & ptsa(:,:,jk,jp_tem) + ptsc(:,:,jk,jp_tem) * r1_e1e2t(:,:) / e3t(:,:,jk,Kmm)
+ ptsa(:,:,jk,jp_sal) = &
+ & ptsa(:,:,jk,jp_sal) + ptsc(:,:,jk,jp_sal) * r1_e1e2t(:,:) / e3t(:,:,jk,Kmm)
END DO
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/traldf_iso.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/traldf_iso.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/traldf_iso.F90 (revision 13540)
@@ -41,4 +41,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -140,5 +141,5 @@
IF( kpass == 1 ) THEN !== first pass only ==!
!
- DO_3D_00_00( 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
!
zmsku = wmask(ji,jj,jk) / MAX( umask(ji ,jj,jk-1) + umask(ji-1,jj,jk) &
@@ -157,5 +158,5 @@
!
IF( ln_traldf_msc ) THEN ! stabilizing vertical diffusivity coefficient
- DO_3D_00_00( 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
akz(ji,jj,jk) = 0.25_wp * ( &
& ( pahu(ji ,jj,jk) + pahu(ji ,jj,jk-1) ) / ( e1u(ji ,jj) * e1u(ji ,jj) ) &
@@ -166,10 +167,13 @@
!
IF( ln_traldf_blp ) THEN ! bilaplacian operator
- DO_3D_10_10( 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) ) )
+ DO_3D( 1, 0, 1, 0, 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_10_10( 2, jpkm1 )
+ DO_3D( 1, 0, 1, 0, 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 )
@@ -196,15 +200,15 @@
! Horizontal tracer gradient
- DO_3D_10_10( 1, jpkm1 )
+ DO_3D( 1, 0, 1, 0, 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_10_10
+ DO_2D( 1, 0, 1, 0 ) ! 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_10_10
+ DO_2D( 1, 0, 1, 0 )
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)
@@ -225,5 +229,5 @@
ELSE ; zdkt(:,:) = ( pt(:,:,jk-1,jn) - pt(:,:,jk,jn) ) * wmask(:,:,jk)
ENDIF
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 ) !== 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)
@@ -246,7 +250,7 @@
END_2D
!
- DO_2D_00_00
- pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + zsign * ( zftu(ji,jj,jk) - zftu(ji-1,jj,jk) &
- & + zftv(ji,jj,jk) - zftv(ji,jj-1,jk) ) &
+ DO_2D( 0, 0, 0, 0 ) !== horizontal divergence and add to pta
+ pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) &
+ & + zsign * ( zftu(ji,jj,jk) - zftu(ji-1,jj,jk) + zftv(ji,jj,jk) - zftv(ji,jj-1,jk) ) &
& * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm)
END_2D
@@ -262,5 +266,5 @@
ztfw(:,:, 1 ) = 0._wp ; ztfw(:,:,jpk) = 0._wp
- DO_3D_00_00( 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! interior (2= 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)
@@ -124,5 +125,5 @@
ENDIF
!
- DO_3D_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !== Second derivative (divergence) added to the general tracer trends ==!
pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) &
& + ztv(ji,jj,jk) - ztv(ji,jj-1,jk) ) &
@@ -199,5 +200,5 @@
END SELECT
!
- CALL lbc_lnk( 'traldf_lap_blp', zlap(:,:,:,:) , 'T', 1. ) ! Lateral boundary conditions (unchanged sign)
+ 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, Kmm, kjpt, zlap, zglu, zglv, zgui, zgvi ) ! both top & bottom
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/traldf_triad.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/traldf_triad.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/traldf_triad.F90 (revision 13540)
@@ -41,4 +41,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -136,5 +137,5 @@
DO ip = 0, 1 ! i-k triads
DO kp = 0, 1
- DO_3D_10_10( 1, jpkm1 )
+ DO_3D( 1, 0, 1, 0, 1, jpkm1 )
ze3wr = 1._wp / e3w(ji+ip,jj,jk+kp,Kmm)
zbu = e1e2u(ji,jj) * e3u(ji,jj,jk,Kmm)
@@ -156,5 +157,5 @@
DO jp = 0, 1 ! j-k triads
DO kp = 0, 1
- DO_3D_10_10( 1, jpkm1 )
+ DO_3D( 1, 0, 1, 0, 1, jpkm1 )
ze3wr = 1.0_wp / e3w(ji,jj+jp,jk+kp,Kmm)
zbv = e1e2v(ji,jj) * e3v(ji,jj,jk,Kmm)
@@ -178,10 +179,13 @@
!
IF( ln_traldf_blp ) THEN ! bilaplacian operator
- DO_3D_10_10( 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) ) )
+ DO_3D( 1, 0, 1, 0, 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_10_10( 2, jpkm1 )
+ DO_3D( 1, 0, 1, 0, 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 )
@@ -207,15 +211,15 @@
zftv(:,:,:) = 0._wp
!
- DO_3D_10_10( 1, jpkm1 )
+ DO_3D( 1, 0, 1, 0, 1, jpkm1 ) !== before lateral T & S gradients at T-level jk ==!
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_10_10
+ DO_2D( 1, 0, 1, 0 ) ! 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_10_10
+ DO_2D( 1, 0, 1, 0 )
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)
@@ -242,5 +246,5 @@
DO ip = 0, 1 !== Horizontal & vertical fluxes
DO kp = 0, 1
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
ze1ur = r1_e1u(ji,jj)
zdxt = zdit(ji,jj,jk) * ze1ur
@@ -263,5 +267,5 @@
DO jp = 0, 1
DO kp = 0, 1
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
ze2vr = r1_e2v(ji,jj)
zdyt = zdjt(ji,jj,jk) * ze2vr
@@ -285,5 +289,5 @@
DO ip = 0, 1 !== Horizontal & vertical fluxes
DO kp = 0, 1
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
ze1ur = r1_e1u(ji,jj)
zdxt = zdit(ji,jj,jk) * ze1ur
@@ -306,5 +310,5 @@
DO jp = 0, 1
DO kp = 0, 1
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
ze2vr = r1_e2v(ji,jj)
zdyt = zdjt(ji,jj,jk) * ze2vr
@@ -325,6 +329,7 @@
ENDIF
! !== horizontal divergence and add to the general trend ==!
- DO_2D_00_00
- pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + zsign * ( zftu(ji-1,jj,jk) - zftu(ji,jj,jk) &
+ DO_2D( 0, 0, 0, 0 )
+ pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) &
+ & + zsign * ( zftu(ji-1,jj ,jk) - zftu(ji,jj,jk) &
& + zftv(ji,jj-1,jk) - zftv(ji,jj,jk) ) &
& / ( e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) )
@@ -335,5 +340,5 @@
! !== add the vertical 33 flux ==!
IF( ln_traldf_lap ) THEN ! laplacian case: eddy coef = ah_wslp2 - akz
- DO_3D_10_00( 2, jpkm1 )
+ DO_3D( 1, 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) &
& * ( ah_wslp2(ji,jj,jk) - akz(ji,jj,jk) ) &
@@ -343,10 +348,10 @@
SELECT CASE( kpass )
CASE( 1 ) ! 1st pass : eddy coef = ah_wslp2
- DO_3D_10_00( 2, jpkm1 )
+ DO_3D( 1, 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) &
& * 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.
- DO_3D_10_00( 2, jpkm1 )
+ DO_3D( 1, 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) &
& * ( ah_wslp2(ji,jj,jk) * ( pt (ji,jj,jk-1,jn) - pt (ji,jj,jk,jn) ) &
@@ -356,6 +361,7 @@
ENDIF
!
- DO_3D_00_00( 1, jpkm1 )
- pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + zsign * ( ztfw(ji,jj,jk+1) - ztfw(ji,jj,jk) ) &
+ DO_3D( 0, 0, 0, 0, 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+1) - ztfw(ji,jj,jk) ) &
& / ( e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) )
END_3D
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/tramle.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/tramle.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/tramle.F90 (revision 13540)
@@ -49,4 +49,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -99,5 +100,5 @@
inml_mle(:,:) = mbkt(:,:) + 1 ! init. to number of ocean w-level (T-level + 1)
IF ( nla10 > 0 ) THEN ! avoid case where first level is thicker than 10m
- DO_3DS_11_11( jpkm1, nlb10, -1 )
+ DO_3DS( 1, 1, 1, 1, jpkm1, nlb10, -1 ) ! from the bottom to nlb10 (10m)
IF( rhop(ji,jj,jk) > rhop(ji,jj,nla10) + rn_rho_c_mle ) inml_mle(ji,jj) = jk ! Mixed layer
END_3D
@@ -109,5 +110,5 @@
zbm (:,:) = 0._wp
zn2 (:,:) = 0._wp
- DO_3D_11_11( 1, ikmax )
+ DO_3D( 1, 1, 1, 1, 1, ikmax ) ! MLD and mean buoyancy and N2 over the mixed layer
zc = e3t(ji,jj,jk,Kmm) * REAL( MIN( MAX( 0, inml_mle(ji,jj)-jk ) , 1 ) ) ! zc being 0 outside the ML t-points
zmld(ji,jj) = zmld(ji,jj) + zc
@@ -118,15 +119,15 @@
SELECT CASE( nn_mld_uv ) ! MLD at u- & v-pts
CASE ( 0 ) != min of the 2 neighbour MLDs
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
zhu(ji,jj) = MIN( zmld(ji+1,jj), zmld(ji,jj) )
zhv(ji,jj) = MIN( zmld(ji,jj+1), zmld(ji,jj) )
END_2D
CASE ( 1 ) != average of the 2 neighbour MLDs
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
zhu(ji,jj) = ( zmld(ji+1,jj) + zmld(ji,jj) ) * 0.5_wp
zhv(ji,jj) = ( zmld(ji,jj+1) + zmld(ji,jj) ) * 0.5_wp
END_2D
CASE ( 2 ) != max of the 2 neighbour MLDs
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
zhu(ji,jj) = MAX( zmld(ji+1,jj), zmld(ji,jj) )
zhv(ji,jj) = MAX( zmld(ji,jj+1), zmld(ji,jj) )
@@ -145,5 +146,5 @@
!
IF( nn_mle == 0 ) THEN ! Fox-Kemper et al. 2010 formulation
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
zpsim_u(ji,jj) = rn_ce * zhu(ji,jj) * zhu(ji,jj) * e2_e1u(ji,jj) &
& * ( zbm(ji+1,jj) - zbm(ji,jj) ) * MIN( 111.e3_wp , e1u(ji,jj) ) &
@@ -156,5 +157,5 @@
!
ELSEIF( nn_mle == 1 ) THEN ! New formulation (Lf = 5km fo/ff with fo=Coriolis parameter at latitude rn_lat)
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
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) )
@@ -166,5 +167,5 @@
!
IF( nn_conv == 1 ) THEN ! No MLE in case of convection
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
IF( MIN( zn2(ji,jj) , zn2(ji+1,jj) ) < 0._wp ) zpsim_u(ji,jj) = 0._wp
IF( MIN( zn2(ji,jj) , zn2(ji,jj+1) ) < 0._wp ) zpsim_v(ji,jj) = 0._wp
@@ -173,5 +174,5 @@
!
! !== structure function value at uw- and vw-points ==!
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
zhu(ji,jj) = 1._wp / zhu(ji,jj) ! hu --> 1/hu
zhv(ji,jj) = 1._wp / zhv(ji,jj)
@@ -181,5 +182,5 @@
zpsi_vw(:,:,:) = 0._wp
!
- DO_3D_10_10( 2, ikmax )
+ DO_3D( 1, 0, 1, 0, 2, ikmax ) ! start from 2 : surface value = 0
zcuw = 1._wp - ( gdepw(ji+1,jj,jk,Kmm) + gdepw(ji,jj,jk,Kmm) ) * zhu(ji,jj)
zcvw = 1._wp - ( gdepw(ji,jj+1,jk,Kmm) + gdepw(ji,jj,jk,Kmm) ) * zhv(ji,jj)
@@ -195,9 +196,9 @@
! !== transport increased by the MLE induced transport ==!
DO jk = 1, ikmax
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 ) ! CAUTION pu,pv must be defined at row/column i=1 / j=1
pu(ji,jj,jk) = pu(ji,jj,jk) + ( zpsi_uw(ji,jj,jk) - zpsi_uw(ji,jj,jk+1) )
pv(ji,jj,jk) = pv(ji,jj,jk) + ( zpsi_vw(ji,jj,jk) - zpsi_vw(ji,jj,jk+1) )
END_2D
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
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) )
@@ -282,5 +283,5 @@
IF( ierr /= 0 ) CALL ctl_stop( 'tra_adv_mle_init: failed to allocate arrays' )
z1_t2 = 1._wp / ( rn_time * rn_time )
- DO_2D_01_01
+ DO_2D( 0, 1, 0, 1 ) ! "coriolis+ time^-1" at u- & v-points
zfu = ( ff_f(ji,jj) + ff_f(ji,jj-1) ) * 0.5_wp
zfv = ( ff_f(ji,jj) + ff_f(ji-1,jj) ) * 0.5_wp
@@ -288,5 +289,5 @@
rfv(ji,jj) = SQRT( zfv * zfv + z1_t2 )
END_2D
- CALL lbc_lnk_multi( 'tramle', rfu, 'U', 1. , rfv, 'V', 1. )
+ CALL lbc_lnk_multi( 'tramle', rfu, 'U', 1.0_wp , rfv, 'V', 1.0_wp )
!
ELSEIF( nn_mle == 1 ) THEN ! MLE array allocation & initialisation
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/tranpc.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/tranpc.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/tranpc.F90 (revision 13540)
@@ -35,4 +35,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -102,5 +103,5 @@
inpcc = 0
!
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 ) ! interior column only
!
IF( tmask(ji,jj,2) == 1 ) THEN ! At least 2 ocean points
@@ -309,5 +310,5 @@
ENDIF
!
- CALL lbc_lnk_multi( 'tranpc', pts(:,:,:,jp_tem,Kaa), 'T', 1., pts(:,:,:,jp_sal,Kaa), 'T', 1. )
+ CALL lbc_lnk_multi( 'tranpc', pts(:,:,:,jp_tem,Kaa), 'T', 1.0_wp, pts(:,:,:,jp_sal,Kaa), 'T', 1.0_wp )
!
IF( lwp .AND. l_LB_debug ) THEN
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/traqsr.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/traqsr.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/traqsr.F90 (revision 13540)
@@ -63,9 +63,10 @@
REAL(wp) :: xsi1r ! inverse of rn_si1
!
- REAL(wp) , DIMENSION(3,61) :: rkrgb ! tabulated attenuation coefficients for RGB absorption
+ REAL(wp) , PUBLIC, DIMENSION(3,61) :: rkrgb ! tabulated attenuation coefficients for RGB absorption
TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_chl ! structure of input Chl (file informations, fields read)
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -110,10 +111,9 @@
REAL(wp) :: zc0 , zc1 , zc2 , zc3 ! - -
REAL(wp) :: zzc0, zzc1, zzc2, zzc3 ! - -
- REAL(wp) :: zz0 , zz1 ! - -
- REAL(wp) :: zCb, zCmax, zze, zpsi, zpsimax, zdelpsi, zCtot, zCze
- REAL(wp) :: zlogc, zlogc2, zlogc3
- REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zekb, zekg, zekr
- REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ze0, ze1, ze2, ze3, zea, ztrdt
- REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zetot, zchl3d
+ REAL(wp) :: zz0 , zz1 , ze3t, zlui ! - -
+ REAL(wp) :: zCb, zCmax, zpsi, zpsimax, zrdpsi, zCze
+ REAL(wp) :: zlogc, zlogze, zlogCtot, zlogCze
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: ze0, ze1, ze2, ze3
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, zetot, ztmp3d
!!----------------------------------------------------------------------
!
@@ -138,5 +138,5 @@
IF(lwp) WRITE(numout,*) ' nit000-1 qsr tracer content forcing field read in the restart file'
z1_2 = 0.5_wp
- CALL iom_get( numror, jpdom_autoglo, 'qsr_hc_b', qsr_hc_b, ldxios = lrxios ) ! before heat content trend due to Qsr flux
+ CALL iom_get( numror, jpdom_auto, 'qsr_hc_b', qsr_hc_b, ldxios = lrxios ) ! before heat content trend due to Qsr flux
ELSE ! No restart or restart not found: Euler forward time stepping
z1_2 = 1._wp
@@ -160,75 +160,95 @@
CASE( np_RGB , np_RGBc ) !== R-G-B fluxes ==!
!
- ALLOCATE( zekb(jpi,jpj) , zekg(jpi,jpj) , zekr (jpi,jpj) , &
- & ze0 (jpi,jpj,jpk) , ze1 (jpi,jpj,jpk) , ze2 (jpi,jpj,jpk) , &
- & ze3 (jpi,jpj,jpk) , zea (jpi,jpj,jpk) , zchl3d(jpi,jpj,jpk) )
+ ALLOCATE( ze0 (jpi,jpj) , ze1 (jpi,jpj) , &
+ & ze2 (jpi,jpj) , ze3 (jpi,jpj) , &
+ & ztmp3d(jpi,jpj,nksr + 1) )
!
IF( nqsr == np_RGBc ) THEN !* Variable Chlorophyll
CALL fld_read( kt, 1, sf_chl ) ! Read Chl data and provides it at the current time step
+ !
+ ! Separation in R-G-B depending on the surface Chl
+ ! perform and store as many of the 2D calculations as possible
+ ! before the 3D loop (use the temporary 2D arrays to replace the
+ ! most expensive calculations)
+ !
+ DO_2D( 0, 0, 0, 0 )
+ ! zlogc = log(zchl)
+ zlogc = LOG ( MIN( 10. , MAX( 0.03, sf_chl(1)%fnow(ji,jj,1) ) ) )
+ ! zc1 : log(zCze) = log (1.12 * zchl**0.803)
+ zc1 = 0.113328685307 + 0.803 * zlogc
+ ! zc2 : log(zCtot) = log(40.6 * zchl**0.459)
+ zc2 = 3.703768066608 + 0.459 * zlogc
+ ! zc3 : log(zze) = log(568.2 * zCtot**(-0.746))
+ zc3 = 6.34247346942 - 0.746 * zc2
+ ! IF( log(zze) > log(102.) ) log(zze) = log(200.0 * zCtot**(-0.293))
+ IF( zc3 > 4.62497281328 ) zc3 = 5.298317366548 - 0.293 * zc2
+ !
+ ze0(ji,jj) = zlogc ! ze0 = log(zchl)
+ ze1(ji,jj) = EXP( zc1 ) ! ze1 = zCze
+ ze2(ji,jj) = 1._wp / ( 0.710 + zlogc * ( 0.159 + zlogc * 0.021 ) ) ! ze2 = 1/zdelpsi
+ ze3(ji,jj) = EXP( - zc3 ) ! ze3 = 1/zze
+ END_2D
+
+!
+ DO_3D( 0, 0, 0, 0, 1, nksr + 1 )
+ ! zchl = ALOG( ze0(ji,jj) )
+ zlogc = ze0(ji,jj)
+ !
+ 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 = ze1(ji,jj)
+ zrdpsi = ze2(ji,jj) ! 1/zdelpsi
+ zpsi = ze3(ji,jj) * gdepw(ji,jj,jk,Kmm) ! gdepw/zze
+ !
+ ! NB. make sure zchl value is such that: zchl = MIN( 10. , MAX( 0.03, zchl ) )
+ zchl = MIN( 10. , MAX( 0.03, zCze * ( zCb + zCmax * EXP( -( (zpsi - zpsimax) * zrdpsi )**2 ) ) ) )
+ ! Convert chlorophyll value to attenuation coefficient look-up table index
+ ztmp3d(ji,jj,jk) = 41 + 20.*LOG10(zchl) + 1.e-15
+ END_3D
+ ELSE !* constant chlorophyll
+ zchl = 0.05
+ ! NB. make sure constant value is such that:
+ zchl = MIN( 10. , MAX( 0.03, zchl ) )
+ ! Convert chlorophyll value to attenuation coefficient look-up table index
+ zlui = 41 + 20.*LOG10(zchl) + 1.e-15
DO jk = 1, nksr + 1
- DO jj = 2, jpjm1 ! Separation in R-G-B depending of the surface Chl
- DO ji = 2, jpim1
- zchl = MIN( 10. , MAX( 0.03, sf_chl(1)%fnow(ji,jj,1) ) )
- zCtot = 40.6 * zchl**0.459
- zze = 568.2 * zCtot**(-0.746)
- IF( zze > 102. ) zze = 200.0 * zCtot**(-0.293)
- zpsi = gdepw(ji,jj,jk,Kmm) / zze
- !
- zlogc = LOG( zchl )
- zlogc2 = zlogc * zlogc
- zlogc3 = zlogc * zlogc * zlogc
- zCb = 0.768 + 0.087 * zlogc - 0.179 * zlogc2 - 0.025 * zlogc3
- zCmax = 0.299 - 0.289 * zlogc + 0.579 * zlogc2
- zpsimax = 0.6 - 0.640 * zlogc + 0.021 * zlogc2 + 0.115 * zlogc3
- zdelpsi = 0.710 + 0.159 * zlogc + 0.021 * zlogc2
- zCze = 1.12 * (zchl)**0.803
- !
- zchl3d(ji,jj,jk) = zCze * ( zCb + zCmax * EXP( -( (zpsi - zpsimax) / zdelpsi )**2 ) )
- END DO
- !
- END DO
+ ztmp3d(:,:,jk) = zlui
END DO
- ELSE !* constant chrlorophyll
- DO jk = 1, nksr + 1
- zchl3d(:,:,jk) = 0.05
- ENDDO
ENDIF
!
zcoef = ( 1. - rn_abs ) / 3._wp !* surface equi-partition in R-G-B
- DO_2D_00_00
- ze0(ji,jj,1) = rn_abs * qsr(ji,jj)
- ze1(ji,jj,1) = zcoef * qsr(ji,jj)
- ze2(ji,jj,1) = zcoef * qsr(ji,jj)
- ze3(ji,jj,1) = zcoef * qsr(ji,jj)
- zea(ji,jj,1) = qsr(ji,jj)
+ DO_2D( 0, 0, 0, 0 )
+ ze0(ji,jj) = rn_abs * qsr(ji,jj)
+ ze1(ji,jj) = zcoef * qsr(ji,jj)
+ ze2(ji,jj) = zcoef * qsr(ji,jj)
+ ze3(ji,jj) = zcoef * qsr(ji,jj)
+ ! store the surface SW radiation; re-use the surface ztmp3d array
+ ! since the surface attenuation coefficient is not used
+ ztmp3d(ji,jj,1) = qsr(ji,jj)
END_2D
!
- DO jk = 2, nksr+1 !* interior equi-partition in R-G-B depending of vertical profile of Chl
- DO_2D_00_00
- zchl = MIN( 10. , MAX( 0.03, zchl3d(ji,jj,jk) ) )
- irgb = NINT( 41 + 20.*LOG10(zchl) + 1.e-15 )
- zekb(ji,jj) = rkrgb(1,irgb)
- zekg(ji,jj) = rkrgb(2,irgb)
- zekr(ji,jj) = rkrgb(3,irgb)
- END_2D
-
- DO_2D_00_00
- zc0 = ze0(ji,jj,jk-1) * EXP( - e3t(ji,jj,jk-1,Kmm) * xsi0r )
- zc1 = ze1(ji,jj,jk-1) * EXP( - e3t(ji,jj,jk-1,Kmm) * zekb(ji,jj) )
- zc2 = ze2(ji,jj,jk-1) * EXP( - e3t(ji,jj,jk-1,Kmm) * zekg(ji,jj) )
- zc3 = ze3(ji,jj,jk-1) * EXP( - e3t(ji,jj,jk-1,Kmm) * zekr(ji,jj) )
- ze0(ji,jj,jk) = zc0
- ze1(ji,jj,jk) = zc1
- ze2(ji,jj,jk) = zc2
- ze3(ji,jj,jk) = zc3
- zea(ji,jj,jk) = ( zc0 + zc1 + zc2 + zc3 ) * wmask(ji,jj,jk)
- END_2D
- END DO
- !
- DO_3D_00_00( 1, nksr )
- qsr_hc(ji,jj,jk) = r1_rho0_rcp * ( zea(ji,jj,jk) - zea(ji,jj,jk+1) )
+ ! !* interior equi-partition in R-G-B depending on vertical profile of Chl
+ DO_3D( 0, 0, 0, 0, 2, nksr + 1 )
+ ze3t = e3t(ji,jj,jk-1,Kmm)
+ irgb = NINT( ztmp3d(ji,jj,jk) )
+ zc0 = ze0(ji,jj) * EXP( - ze3t * xsi0r )
+ zc1 = ze1(ji,jj) * EXP( - ze3t * rkrgb(1,irgb) )
+ zc2 = ze2(ji,jj) * EXP( - ze3t * rkrgb(2,irgb) )
+ zc3 = ze3(ji,jj) * EXP( - ze3t * rkrgb(3,irgb) )
+ ze0(ji,jj) = zc0
+ ze1(ji,jj) = zc1
+ ze2(ji,jj) = zc2
+ ze3(ji,jj) = zc3
+ ztmp3d(ji,jj,jk) = ( zc0 + zc1 + zc2 + zc3 ) * wmask(ji,jj,jk)
END_3D
!
- DEALLOCATE( zekb , zekg , zekr , ze0 , ze1 , ze2 , ze3 , zea , zchl3d )
+ DO_3D( 0, 0, 0, 0, 1, nksr ) !* now qsr induced heat content
+ qsr_hc(ji,jj,jk) = r1_rho0_rcp * ( ztmp3d(ji,jj,jk) - ztmp3d(ji,jj,jk+1) )
+ END_3D
+ !
+ DEALLOCATE( ze0 , ze1 , ze2 , ze3 , ztmp3d )
!
CASE( np_2BD ) !== 2-bands fluxes ==!
@@ -236,5 +256,5 @@
zz0 = rn_abs * r1_rho0_rcp ! surface equi-partition in 2-bands
zz1 = ( 1. - rn_abs ) * r1_rho0_rcp
- DO_3D_00_00( 1, nksr )
+ DO_3D( 0, 0, 0, 0, 1, nksr ) ! solar heat absorbed at T-point in the top 400m
zc0 = zz0 * EXP( -gdepw(ji,jj,jk ,Kmm)*xsi0r ) + zz1 * EXP( -gdepw(ji,jj,jk ,Kmm)*xsi1r )
zc1 = zz0 * EXP( -gdepw(ji,jj,jk+1,Kmm)*xsi0r ) + zz1 * EXP( -gdepw(ji,jj,jk+1,Kmm)*xsi1r )
@@ -245,11 +265,14 @@
!
! !-----------------------------!
- DO_3D_00_00( 1, nksr )
+ ! ! update to the temp. trend !
+ ! !-----------------------------!
+ DO_3D( 0, 0, 0, 0, 1, nksr )
pts(ji,jj,jk,jp_tem,Krhs) = pts(ji,jj,jk,jp_tem,Krhs) &
- & + z1_2 * ( qsr_hc_b(ji,jj,jk) + qsr_hc(ji,jj,jk) ) / e3t(ji,jj,jk,Kmm)
+ & + z1_2 * ( qsr_hc_b(ji,jj,jk) + qsr_hc(ji,jj,jk) ) &
+ & / e3t(ji,jj,jk,Kmm)
END_3D
!
! sea-ice: store the 1st ocean level attenuation coefficient
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
IF( qsr(ji,jj) /= 0._wp ) THEN ; fraqsr_1lev(ji,jj) = qsr_hc(ji,jj,1) / ( r1_rho0_rcp * qsr(ji,jj) )
ELSE ; fraqsr_1lev(ji,jj) = 1._wp
@@ -396,4 +419,10 @@
IF( .NOT.lk_top ) CALL ctl_stop( 'No bio model : ln_qsr_bio = true impossible ' )
!
+ CALL trc_oce_rgb( rkrgb ) ! tabulated attenuation coef.
+ !
+ nksr = trc_oce_ext_lev( r_si2, 33._wp ) ! level of light extinction
+ !
+ IF(lwp) WRITE(numout,*) ' level of light extinction = ', nksr, ' ref depth = ', gdepw_1d(nksr+1), ' m'
+ !
END SELECT
!
@@ -402,5 +431,5 @@
! 1st ocean level attenuation coefficient (used in sbcssm)
IF( iom_varid( numror, 'fraqsr_1lev', ldstop = .FALSE. ) > 0 ) THEN
- CALL iom_get( numror, jpdom_autoglo, 'fraqsr_1lev' , fraqsr_1lev, ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'fraqsr_1lev' , fraqsr_1lev, ldxios = lrxios )
ELSE
fraqsr_1lev(:,:) = 1._wp ! default : no penetration
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/trasbc.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/trasbc.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/trasbc.F90 (revision 13540)
@@ -43,4 +43,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -111,6 +112,6 @@
zfact = 0.5_wp
sbc_tsc(:,:,:) = 0._wp
- CALL iom_get( numror, jpdom_autoglo, 'sbc_hc_b', sbc_tsc_b(:,:,jp_tem), ldxios = lrxios ) ! before heat content sbc trend
- CALL iom_get( numror, jpdom_autoglo, 'sbc_sc_b', sbc_tsc_b(:,:,jp_sal), ldxios = lrxios ) ! before salt content sbc trend
+ CALL iom_get( numror, jpdom_auto, 'sbc_hc_b', sbc_tsc_b(:,:,jp_tem), ldxios = lrxios ) ! before heat content sbc trend
+ CALL iom_get( numror, jpdom_auto, 'sbc_sc_b', sbc_tsc_b(:,:,jp_sal), ldxios = lrxios ) ! before salt content sbc trend
ELSE ! No restart or restart not found: Euler forward time stepping
zfact = 1._wp
@@ -123,13 +124,13 @@
ENDIF
! !== Now sbc tracer content fields ==!
- DO_2D_01_00
+ DO_2D( 0, 1, 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_01_00
+ DO_2D( 0, 1, 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
+ END_2D !==>> output c./d. term
IF( iom_use('emp_x_sst') ) CALL iom_put( "emp_x_sst", emp (:,:) * pts(:,:,1,jp_tem,Kmm) )
IF( iom_use('emp_x_sss') ) CALL iom_put( "emp_x_sss", emp (:,:) * pts(:,:,1,jp_sal,Kmm) )
@@ -137,6 +138,7 @@
!
DO jn = 1, jpts !== update tracer trend ==!
- DO_2D_01_00
- pts(ji,jj,1,jn,Krhs) = pts(ji,jj,1,jn,Krhs) + zfact * ( sbc_tsc_b(ji,jj,jn) + sbc_tsc(ji,jj,jn) ) / e3t(ji,jj,1,Kmm)
+ DO_2D( 0, 1, 0, 0 )
+ pts(ji,jj,1,jn,Krhs) = pts(ji,jj,1,jn,Krhs) + zfact * ( sbc_tsc_b(ji,jj,jn) + sbc_tsc(ji,jj,jn) ) &
+ & / e3t(ji,jj,1,Kmm)
END_2D
END DO
@@ -155,5 +157,5 @@
IF( ln_rnf ) THEN ! input of heat and salt due to river runoff
zfact = 0.5_wp
- DO_2D_01_00
+ DO_2D( 0, 1, 0, 0 )
IF( rnf(ji,jj) /= 0._wp ) THEN
zdep = zfact / h_rnf(ji,jj)
@@ -180,5 +182,5 @@
!
IF( ln_linssh ) THEN
- DO_2D_01_00
+ DO_2D( 0, 1, 0, 0 )
ztim = ssh_iau(ji,jj) / e3t(ji,jj,1,Kmm)
pts(ji,jj,1,jp_tem,Krhs) = pts(ji,jj,1,jp_tem,Krhs) + pts(ji,jj,1,jp_tem,Kmm) * ztim
@@ -186,5 +188,5 @@
END_2D
ELSE
- DO_2D_01_00
+ DO_2D( 0, 1, 0, 0 )
ztim = ssh_iau(ji,jj) / ( ht(ji,jj) + 1. - ssmask(ji, jj) )
pts(ji,jj,:,jp_tem,Krhs) = pts(ji,jj,:,jp_tem,Krhs) + pts(ji,jj,:,jp_tem,Kmm) * ztim
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/trazdf.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/trazdf.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/trazdf.F90 (revision 13540)
@@ -37,4 +37,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -84,11 +85,15 @@
IF( l_trdtra ) THEN ! save the vertical diffusive trends for further diagnostics
DO jk = 1, jpkm1
- ztrdt(:,:,jk) = ( ( pts(:,:,jk,jp_tem,Kaa)*e3t(:,:,jk,Kaa) - pts(:,:,jk,jp_tem,Kbb)*e3t(:,:,jk,Kbb) ) &
- & / (e3t(:,:,jk,Kmm)*rDt) ) - ztrdt(:,:,jk)
- ztrds(:,:,jk) = ( ( pts(:,:,jk,jp_sal,Kaa)*e3t(:,:,jk,Kaa) - pts(:,:,jk,jp_sal,Kbb)*e3t(:,:,jk,Kbb) ) &
- & / (e3t(:,:,jk,Kmm)*rDt) ) - ztrds(:,:,jk)
+ ztrdt(:,:,jk) = ( ( pts(:,:,jk,jp_tem,Kaa)*e3t(:,:,jk,Kaa) &
+ & - pts(:,:,jk,jp_tem,Kbb)*e3t(:,:,jk,Kbb) ) &
+ & / ( e3t(:,:,jk,Kmm)*rDt ) ) &
+ & - ztrdt(:,:,jk)
+ ztrds(:,:,jk) = ( ( pts(:,:,jk,jp_sal,Kaa)*e3t(:,:,jk,Kaa) &
+ & - pts(:,:,jk,jp_sal,Kbb)*e3t(:,:,jk,Kbb) ) &
+ & / ( e3t(:,:,jk,Kmm)*rDt ) ) &
+ & - ztrds(:,:,jk)
END DO
!!gm this should be moved in trdtra.F90 and done on all trends
- CALL lbc_lnk_multi( 'trazdf', ztrdt, 'T', 1. , ztrds, 'T', 1. )
+ CALL lbc_lnk_multi( 'trazdf', ztrdt, 'T', 1.0_wp , ztrds, 'T', 1.0_wp )
!!gm
CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_zdf, ztrdt )
@@ -156,9 +161,9 @@
IF( l_ldfslp ) THEN ! isoneutral diffusion: add the contribution
IF( ln_traldf_msc ) THEN ! MSC iso-neutral operator
- DO_3D_00_00( 2, jpkm1 )
+ 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_00_00( 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
zwt(ji,jj,jk) = zwt(ji,jj,jk) + ah_wslp2(ji,jj,jk)
END_3D
@@ -168,5 +173,5 @@
! 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_00_00( 1, jpkm1 )
+ 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)
@@ -177,5 +182,5 @@
END_3D
ELSE
- DO_3D_00_00( 1, jpkm1 )
+ 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)
@@ -203,8 +208,8 @@
! used as a work space array: its value is modified.
!
- DO_2D_00_00
+ 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)
END_2D
- DO_3D_00_00( 2, jpkm1 )
+ 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
@@ -212,16 +217,18 @@
ENDIF
!
- DO_2D_00_00
- 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)
+ 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_00_00( 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
+ 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_00_00
+ 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_00_00( jpk-2, 1, -1 )
+ 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)
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/zpshde.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/zpshde.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRA/zpshde.F90 (revision 13540)
@@ -32,4 +32,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -65,11 +66,11 @@
!! ___ | | | ___ | | |
!!
- !! case 1-> e3w(i+1) >= e3w(i) ( and e3w(j+1) >= e3w(j) ) then
- !! t~ = t(i+1,j ,k) + (e3w(i+1) - e3w(i)) * dk(Ti+1)/e3w(i+1)
- !! ( t~ = t(i ,j+1,k) + (e3w(j+1) - e3w(j)) * dk(Tj+1)/e3w(j+1) )
+ !! case 1-> e3w(i+1,:,:,Kmm) >= e3w(i,:,:,Kmm) ( and e3w(:,j+1,:,Kmm) >= e3w(:,j,:,Kmm) ) then
+ !! t~ = t(i+1,j ,k) + (e3w(i+1,j,k,Kmm) - e3w(i,j,k,Kmm)) * dk(Ti+1)/e3w(i+1,j,k,Kmm)
+ !! ( t~ = t(i ,j+1,k) + (e3w(i,j+1,k,Kmm) - e3w(i,j,k,Kmm)) * dk(Tj+1)/e3w(i,j+1,k,Kmm) )
!! or
- !! case 2-> e3w(i+1) <= e3w(i) ( and e3w(j+1) <= e3w(j) ) then
- !! t~ = t(i,j,k) + (e3w(i) - e3w(i+1)) * dk(Ti)/e3w(i )
- !! ( t~ = t(i,j,k) + (e3w(j) - e3w(j+1)) * dk(Tj)/e3w(j ) )
+ !! case 2-> e3w(i+1,:,:,Kmm) <= e3w(i,:,:,Kmm) ( and e3w(:,j+1,:,Kmm) <= e3w(:,j,:,Kmm) ) then
+ !! t~ = t(i,j,k) + (e3w(i,j,k,Kmm) - e3w(i+1,j,k,Kmm)) * dk(Ti)/e3w(i,j,k,Kmm)
+ !! ( t~ = t(i,j,k) + (e3w(i,j,k,Kmm) - e3w(i,j+1,k,Kmm)) * dk(Tj)/e3w(i,j,k,Kmm) )
!! Idem for di(s) and dj(s)
!!
@@ -106,8 +107,8 @@
DO jn = 1, kjpt !== Interpolation of tracers at the last ocean level ==!
!
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
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
-!!gm BUG ? when applied to before fields, e3w(:,:,:,Kbb) should be used....
+!!gm BUG ? when applied to before fields, e3w(:,:,k,Kbb) should be used....
ze3wu = e3w(ji+1,jj ,iku,Kmm) - e3w(ji,jj,iku,Kmm)
ze3wv = e3w(ji ,jj+1,ikv,Kmm) - e3w(ji,jj,ikv,Kmm)
@@ -145,10 +146,10 @@
END DO
!
- CALL lbc_lnk_multi( 'zpshde', pgtu(:,:,:), 'U', -1. , pgtv(:,:,:), 'V', -1. ) ! Lateral boundary cond.
+ CALL lbc_lnk_multi( '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_10_10
+ DO_2D( 1, 0, 1, 0 )
iku = mbku(ji,jj)
ikv = mbkv(ji,jj)
@@ -166,5 +167,5 @@
CALL eos( ztj, zhj, zrj ) ! at the partial step depth output in zri, zrj
!
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 ) ! Gradient of density at the last level
iku = mbku(ji,jj)
ikv = mbkv(ji,jj)
@@ -178,5 +179,5 @@
ENDIF
END_2D
- CALL lbc_lnk_multi( 'zpshde', pgru , 'U', -1. , pgrv , 'V', -1. ) ! Lateral boundary conditions
+ CALL lbc_lnk_multi( 'zpshde', pgru , 'U', -1.0_wp , pgrv , 'V', -1.0_wp ) ! Lateral boundary conditions
!
END IF
@@ -214,11 +215,11 @@
!! ___ | | | ___ | | |
!!
- !! case 1-> e3w(i+1) >= e3w(i) ( and e3w(j+1) >= e3w(j) ) then
- !! t~ = t(i+1,j ,k) + (e3w(i+1) - e3w(i)) * dk(Ti+1)/e3w(i+1)
- !! ( t~ = t(i ,j+1,k) + (e3w(j+1) - e3w(j)) * dk(Tj+1)/e3w(j+1) )
+ !! case 1-> e3w(i+1,j,k,Kmm) >= e3w(i,j,k,Kmm) ( and e3w(i,j+1,k,Kmm) >= e3w(i,j,k,Kmm) ) then
+ !! t~ = t(i+1,j ,k) + (e3w(i+1,j ,k,Kmm) - e3w(i,j,k,Kmm)) * dk(Ti+1)/e3w(i+1,j ,k,Kmm)
+ !! ( t~ = t(i ,j+1,k) + (e3w(i ,j+1,k,Kmm) - e3w(i,j,k,Kmm)) * dk(Tj+1)/e3w(i ,j+1,k,Kmm) )
!! or
- !! case 2-> e3w(i+1) <= e3w(i) ( and e3w(j+1) <= e3w(j) ) then
- !! t~ = t(i,j,k) + (e3w(i) - e3w(i+1)) * dk(Ti)/e3w(i )
- !! ( t~ = t(i,j,k) + (e3w(j) - e3w(j+1)) * dk(Tj)/e3w(j ) )
+ !! case 2-> e3w(i+1,j,k,Kmm) <= e3w(i,j,k,Kmm) ( and e3w(i,j+1,k,Kmm) <= e3w(i,j,k,Kmm) ) then
+ !! t~ = t(i,j,k) + (e3w(i,j,k,Kmm) - e3w(i+1,j ,k,Kmm)) * dk(Ti)/e3w(i,j,k,Kmm)
+ !! ( t~ = t(i,j,k) + (e3w(i,j,k,Kmm) - e3w(i ,j+1,k,Kmm)) * dk(Tj)/e3w(i,j,k,Kmm) )
!! Idem for di(s) and dj(s)
!!
@@ -261,5 +262,5 @@
DO jn = 1, kjpt !== Interpolation of tracers at the last ocean level ==!
!
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
iku = mbku(ji,jj); ikum1 = MAX( iku - 1 , 1 ) ! last and before last ocean level at u- & v-points
@@ -301,5 +302,5 @@
END DO
!
- CALL lbc_lnk_multi( 'zpshde', pgtu(:,:,:), 'U', -1. , pgtv(:,:,:), 'V', -1. ) ! Lateral boundary cond.
+ CALL lbc_lnk_multi( 'zpshde', pgtu(:,:,:), 'U', -1.0_wp , pgtv(:,:,:), 'V', -1.0_wp ) ! Lateral boundary cond.
! horizontal derivative of density anomalies (rd)
@@ -307,5 +308,5 @@
pgru(:,:)=0.0_wp ; pgrv(:,:)=0.0_wp ;
!
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
iku = mbku(ji,jj)
@@ -328,5 +329,5 @@
CALL eos( ztj, zhj, zrj )
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 ) ! Gradient of density at the last level
iku = mbku(ji,jj)
ikv = mbkv(ji,jj)
@@ -343,5 +344,5 @@
END_2D
- CALL lbc_lnk_multi( 'zpshde', pgru , 'U', -1. , pgrv , 'V', -1. ) ! Lateral boundary conditions
+ CALL lbc_lnk_multi( 'zpshde', pgru , 'U', -1.0_wp , pgrv , 'V', -1.0_wp ) ! Lateral boundary conditions
!
END IF
@@ -350,5 +351,5 @@
!
DO jn = 1, kjpt !== Interpolation of tracers at the last ocean level ==! !
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 )
iku = miku(ji,jj); ikup1 = miku(ji,jj) + 1
ikv = mikv(ji,jj); ikvp1 = mikv(ji,jj) + 1
@@ -356,5 +357,5 @@
! (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(i,j) - e3w(i,j+1) is not the distance between Tj~ and Tj
+ ! in this case e3w(i,j,k,Kmm) - e3w(i,j+1,k,Kmm) 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(ji,jj,iku,Kmm) - gdept(ji+1,jj,iku,Kmm)
@@ -394,10 +395,10 @@
!
END DO
- CALL lbc_lnk_multi( 'zpshde', pgtui(:,:,:), 'U', -1. , pgtvi(:,:,:), 'V', -1. ) ! Lateral boundary cond.
+ CALL lbc_lnk_multi( '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_10_10
+ DO_2D( 1, 0, 1, 0 )
iku = miku(ji,jj)
@@ -419,5 +420,5 @@
CALL eos( ztj, zhj, zrj ) ! at the partial step depth output in zri, zrj
!
- DO_2D_10_10
+ DO_2D( 1, 0, 1, 0 ) ! Gradient of density at the last level
iku = miku(ji,jj)
ikv = mikv(ji,jj)
@@ -433,5 +434,5 @@
END_2D
- CALL lbc_lnk_multi( 'zpshde', pgrui, 'U', -1. , pgrvi, 'V', -1. ) ! Lateral boundary conditions
+ CALL lbc_lnk_multi( 'zpshde', pgrui, 'U', -1.0_wp , pgrvi, 'V', -1.0_wp ) ! Lateral boundary conditions
!
END IF
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRD/trddyn.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRD/trddyn.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRD/trddyn.F90 (revision 13540)
@@ -37,4 +37,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -123,9 +124,9 @@
z3dx(:,:,:) = 0._wp ! U.dxU & V.dyV (approximation)
z3dy(:,:,:) = 0._wp
- DO_3D_00_00( 1, jpkm1 )
+ 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
- CALL lbc_lnk_multi( 'trddyn', z3dx, 'U', -1., z3dy, 'V', -1. )
+ CALL lbc_lnk_multi( 'trddyn', z3dx, 'U', -1.0_wp, z3dy, 'V', -1.0_wp )
CALL iom_put( "utrd_udx", z3dx )
CALL iom_put( "vtrd_vdy", z3dy )
@@ -163,5 +164,5 @@
! END DO
! END DO
-! CALL lbc_lnk_multi( 'trddyn', z3dx, 'U', -1., z3dy, 'V', -1. )
+! CALL lbc_lnk_multi( 'trddyn', z3dx, 'U', -1.0_wp, z3dy, 'V', -1.0_wp )
! CALL iom_put( "utrd_bfr", z3dx )
! CALL iom_put( "vtrd_bfr", z3dy )
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRD/trdglo.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRD/trdglo.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRD/trdglo.F90 (revision 13540)
@@ -52,4 +52,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -85,5 +86,5 @@
!
CASE( 'TRA' ) !== Tracers (T & S) ==!
- DO_3D_11_11( 1, jpkm1 )
+ 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
@@ -114,5 +115,5 @@
!
CASE( 'DYN' ) !== Momentum and KE ==!
- DO_3D_10_10( 1, jpkm1 )
+ DO_3D( 1, 0, 1, 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)
@@ -126,5 +127,5 @@
IF( ktrd == jpdyn_zdf ) THEN ! zdf trend: compute separately the surface forcing trend
z1_2rho0 = 0.5_wp / rho0
- DO_2D_10_10
+ 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)
@@ -210,10 +211,12 @@
zcof = 0.5_wp / rho0 ! Density flux at u and v-points
- DO_3D_10_10( 1, jpkm1 )
- zkx(ji,jj,jk) = zcof * 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) * vv(ji,jj,jk,Kmm) * ( rhop(ji,jj,jk) + rhop(ji,jj+1,jk) )
+ DO_3D( 1, 0, 1, 0, 1, jpkm1 )
+ zkx(ji,jj,jk) = zcof * 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) &
+ & * vv(ji,jj,jk,Kmm) * ( rhop(ji,jj,jk) + rhop(ji,jj+1,jk) )
END_3D
- DO_3D_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! Density flux divergence at t-point
zkepe(ji,jj,jk) = - ( zkz(ji,jj,jk) - zkz(ji ,jj ,jk+1) &
& + zkx(ji,jj,jk) - zkx(ji-1,jj ,jk ) &
@@ -226,5 +229,6 @@
peke = 0._wp
DO jk = 1, jpkm1
- peke = peke + SUM( zkepe(:,:,jk) * gdept(:,:,jk,Kmm) * e1e2t(:,:) * e3t(:,:,jk,Kmm) )
+ peke = peke + SUM( zkepe(:,:,jk) * gdept(:,:,jk,Kmm) * e1e2t(:,:) &
+ & * e3t(:,:,jk,Kmm) )
END DO
peke = grav * peke
@@ -523,7 +527,9 @@
tvolv = 0._wp
- DO_3D_00_00( 1, jpk )
- tvolu = tvolu + e1u(ji,jj) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm) * tmask_i(ji+1,jj ) * tmask_i(ji,jj) * umask(ji,jj,jk)
- tvolv = tvolv + e1v(ji,jj) * e2v(ji,jj) * e3v(ji,jj,jk,Kmm) * tmask_i(ji ,jj+1) * tmask_i(ji,jj) * vmask(ji,jj,jk)
+ DO_3D( 0, 0, 0, 0, 1, jpk )
+ tvolu = tvolu + e1u(ji,jj) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm) &
+ & * tmask_i(ji+1,jj ) * tmask_i(ji,jj) * umask(ji,jj,jk)
+ tvolv = tvolv + e1v(ji,jj) * e2v(ji,jj) * e3v(ji,jj,jk,Kmm) &
+ & * tmask_i(ji ,jj+1) * tmask_i(ji,jj) * vmask(ji,jj,jk)
END_3D
CALL mpp_sum( 'trdglo', tvolu ) ! sums over the global domain
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRD/trdken.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRD/trdken.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRD/trdken.F90 (revision 13540)
@@ -41,4 +41,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -89,5 +90,5 @@
!!----------------------------------------------------------------------
!
- CALL lbc_lnk_multi( 'trdken', putrd, 'U', -1. , pvtrd, 'V', -1. ) ! lateral boundary conditions
+ CALL lbc_lnk_multi( 'trdken', putrd, 'U', -1.0_wp , pvtrd, 'V', -1.0_wp ) ! lateral boundary conditions
!
nkstp = kt
@@ -101,5 +102,5 @@
zke(1,:, : ) = 0._wp
zke(:,1, : ) = 0._wp
- DO_3D_01_01( 1, jpkm1 )
+ DO_3D( 0, 1, 0, 1, 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) &
@@ -122,5 +123,5 @@
z2dy(:,:) = vv(:,:,1,Kmm) * ( vtau_b(:,:) + vtau(:,:) ) * e1e2v(:,:) * vmask(:,:,1)
zke2d(1,:) = 0._wp ; zke2d(:,1) = 0._wp
- DO_2D_01_01
+ DO_2D( 0, 1, 0, 1 )
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)
@@ -218,5 +219,5 @@
! conv value on T-point
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 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)
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRD/trdmxl.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRD/trdmxl.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRD/trdmxl.F90 (revision 13540)
@@ -70,4 +70,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -119,6 +120,8 @@
!
wkx(:,:,:) = 0._wp !== now ML weights for vertical averaging ==!
- DO_3D_11_11( 1, jpktrd )
- IF( jk - kmxln(ji,jj) < 0 ) wkx(ji,jj,jk) = e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk)
+ DO_3D( 1, 1, 1, 1, 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)
+ ENDIF
END_3D
hmxl(:,:) = 0._wp ! NOW mixed-layer depth
@@ -151,5 +154,5 @@
!!gm to be put juste before the output !
! ! Lateral boundary conditions
-! CALL lbc_lnk_multi( 'trdmxl', tmltrd(:,:,jl), 'T', 1. , smltrd(:,:,jl), 'T', 1. )
+! CALL lbc_lnk_multi( 'trdmxl', tmltrd(:,:,jl), 'T', 1.0_wp , smltrd(:,:,jl), 'T', 1.0_wp )
!!gm end
@@ -469,7 +472,7 @@
!-- Lateral boundary conditions
! ... temperature ... ... salinity ...
- CALL lbc_lnk_multi( 'trdmxl', ztmltot , 'T', 1., zsmltot , 'T', 1., &
- & ztmlres , 'T', 1., zsmlres , 'T', 1., &
- & ztmlatf , 'T', 1., zsmlatf , 'T', 1. )
+ CALL lbc_lnk_multi( '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 )
@@ -520,8 +523,8 @@
!-- Lateral boundary conditions
! ... temperature ... ... salinity ...
- CALL lbc_lnk_multi( 'trdmxl', ztmltot2, 'T', 1., zsmltot2, 'T', 1., &
- & ztmlres2, 'T', 1., zsmlres2, 'T', 1. )
- !
- CALL lbc_lnk_multi( 'trdmxl', ztmltrd2(:,:,:), 'T', 1., zsmltrd2(:,:,:), 'T', 1. ) ! / in the NetCDF trends file
+ CALL lbc_lnk_multi( 'trdmxl', ztmltot2, 'T', 1.0_wp, zsmltot2, 'T', 1.0_wp, &
+ & ztmlres2, 'T', 1.0_wp, zsmlres2, 'T', 1.0_wp )
+ !
+ CALL lbc_lnk_multi( 'trdmxl', ztmltrd2(:,:,:), 'T', 1.0_wp, zsmltrd2(:,:,:), 'T', 1.0_wp ) ! / in the NetCDF trends file
! III.3 Time evolution array swap
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRD/trdmxl_rst.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRD/trdmxl_rst.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRD/trdmxl_rst.F90 (revision 13540)
@@ -149,36 +149,36 @@
IF( ln_trdmxl_instant ) THEN
!-- Temperature
- CALL iom_get( inum, jpdom_autoglo, 'tmlbb' , tmlbb )
- CALL iom_get( inum, jpdom_autoglo, 'tmlbn' , tmlbn )
- CALL iom_get( inum, jpdom_autoglo, 'tmlatfb' , tmlatfb )
+ CALL iom_get( inum, jpdom_auto, 'tmlbb' , tmlbb )
+ CALL iom_get( inum, jpdom_auto, 'tmlbn' , tmlbn )
+ CALL iom_get( inum, jpdom_auto, 'tmlatfb' , tmlatfb )
!
!-- Salinity
- CALL iom_get( inum, jpdom_autoglo, 'smlbb' , smlbb )
- CALL iom_get( inum, jpdom_autoglo, 'smlbn' , smlbn )
- CALL iom_get( inum, jpdom_autoglo, 'smlatfb' , smlatfb )
+ CALL iom_get( inum, jpdom_auto, 'smlbb' , smlbb )
+ CALL iom_get( inum, jpdom_auto, 'smlbn' , smlbn )
+ CALL iom_get( inum, jpdom_auto, 'smlatfb' , smlatfb )
ELSE
- CALL iom_get( inum, jpdom_autoglo, 'hmxlbn' , hmxlbn ) ! needed for hmxl_sum
+ CALL iom_get( inum, jpdom_auto, 'hmxlbn' , hmxlbn ) ! needed for hmxl_sum
!
!-- Temperature
- CALL iom_get( inum, jpdom_autoglo, 'tmlbn' , tmlbn ) ! needed for tml_sum
- CALL iom_get( inum, jpdom_autoglo, 'tml_sumb' , tml_sumb )
+ CALL iom_get( inum, jpdom_auto, 'tmlbn' , tmlbn ) ! needed for tml_sum
+ CALL iom_get( inum, jpdom_auto, 'tml_sumb' , tml_sumb )
DO jk = 1, jpltrd
IF( jk < 10 ) THEN ; WRITE(charout,FMT="('tmltrd_csum_ub_', I1)") jk
ELSE ; WRITE(charout,FMT="('tmltrd_csum_ub_', I2)") jk
ENDIF
- CALL iom_get( inum, jpdom_autoglo, charout, tmltrd_csum_ub(:,:,jk) )
+ CALL iom_get( inum, jpdom_auto, charout, tmltrd_csum_ub(:,:,jk) )
END DO
- CALL iom_get( inum, jpdom_autoglo, 'tmltrd_atf_sumb' , tmltrd_atf_sumb)
+ CALL iom_get( inum, jpdom_auto, 'tmltrd_atf_sumb' , tmltrd_atf_sumb)
!
!-- Salinity
- CALL iom_get( inum, jpdom_autoglo, 'smlbn' , smlbn ) ! needed for sml_sum
- CALL iom_get( inum, jpdom_autoglo, 'sml_sumb' , sml_sumb )
+ CALL iom_get( inum, jpdom_auto, 'smlbn' , smlbn ) ! needed for sml_sum
+ CALL iom_get( inum, jpdom_auto, 'sml_sumb' , sml_sumb )
DO jk = 1, jpltrd
IF( jk < 10 ) THEN ; WRITE(charout,FMT="('smltrd_csum_ub_', I1)") jk
ELSE ; WRITE(charout,FMT="('smltrd_csum_ub_', I2)") jk
ENDIF
- CALL iom_get( inum, jpdom_autoglo, charout, smltrd_csum_ub(:,:,jk) )
+ CALL iom_get( inum, jpdom_auto, charout, smltrd_csum_ub(:,:,jk) )
END DO
- CALL iom_get( inum, jpdom_autoglo, 'smltrd_atf_sumb' , smltrd_atf_sumb)
+ CALL iom_get( inum, jpdom_auto, 'smltrd_atf_sumb' , smltrd_atf_sumb)
!
CALL iom_close( inum )
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRD/trdpen.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRD/trdpen.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRD/trdpen.F90 (revision 13540)
@@ -35,4 +35,6 @@
REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: rab_pe ! partial derivatives of PE anomaly with respect to T and S
+ !! * Substitutions
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -40,4 +42,5 @@
!! Software governed by the CeCILL license (see ./LICENSE)
!!----------------------------------------------------------------------
+
CONTAINS
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRD/trdtra.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRD/trdtra.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRD/trdtra.F90 (revision 13540)
@@ -42,4 +42,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -82,5 +83,6 @@
REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: ptra ! now tracer variable
!
- INTEGER :: jk ! loop indices
+ INTEGER :: jk ! loop indices
+ INTEGER :: i01 ! 0 or 1
REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztrds ! 3D workspace
REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zwt, zws, ztrdt ! 3D workspace
@@ -90,8 +92,10 @@
IF( trd_tra_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'trd_tra : unable to allocate arrays' )
ENDIF
-
+ !
+ i01 = COUNT( (/ PRESENT(pu) .OR. ( ktrd /= jptra_xad .AND. ktrd /= jptra_yad .AND. ktrd /= jptra_zad ) /) )
+ !
IF( ctype == 'TRA' .AND. ktra == jp_tem ) THEN !== Temperature trend ==!
!
- SELECT CASE( ktrd )
+ SELECT CASE( ktrd*i01 )
! ! advection: transform the advective flux into a trend
CASE( jptra_xad ) ; CALL trd_tra_adv( ptrd, pu, ptra, 'X', trdtx, Kmm )
@@ -112,5 +116,5 @@
IF( ctype == 'TRA' .AND. ktra == jp_sal ) THEN !== Salinity trends ==!
!
- SELECT CASE( ktrd )
+ SELECT CASE( ktrd*i01 )
! ! advection: transform the advective flux into a trend
! ! and send T & S trends to trd_tra_mng
@@ -128,6 +132,8 @@
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)
+ 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
!
@@ -142,6 +148,8 @@
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)
+ 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
!
@@ -163,5 +171,5 @@
IF( ctype == 'TRC' ) THEN !== passive tracer trend ==!
!
- SELECT CASE( ktrd )
+ SELECT CASE( ktrd*i01 )
! ! advection: transform the advective flux into a masked trend
CASE( jptra_xad ) ; CALL trd_tra_adv( ptrd , pu , ptra, 'X', ztrds, Kmm )
@@ -202,5 +210,5 @@
!!----------------------------------------------------------------------
!
- SELECT CASE( cdir ) ! shift depending on the direction
+ SELECT CASE( cdir ) ! shift depending on the direction
CASE( 'X' ) ; ii = 1 ; ij = 0 ; ik = 0 ! i-trend
CASE( 'Y' ) ; ii = 0 ; ij = 1 ; ik = 0 ! j-trend
@@ -208,10 +216,10 @@
END SELECT
!
- ! ! set to zero uncomputed values
+ ! ! 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
!
- DO_3D_00_00( 1, jpkm1 )
+ 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) &
& - ( pu(ji,jj,jk) - pu(ji-ii,jj-ij,jk-ik) ) * pt(ji,jj,jk) ) &
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRD/trdtrc.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRD/trdtrc.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRD/trdtrc.F90 (revision 13540)
@@ -1,3 +1,4 @@
MODULE trdtrc
+ USE par_kind
!!======================================================================
!! *** MODULE trdtrc ***
@@ -12,5 +13,5 @@
INTEGER :: kt, kjn, ktrd
INTEGER :: Kmm ! time level index
- REAL :: ptrtrd(:,:,:)
+ REAL(wp):: ptrtrd(:,:,:)
WRITE(*,*) 'trd_trc : You should not have seen this print! error?', ptrtrd(1,1,1)
WRITE(*,*) ' " " : You should not have seen this print! error?', kjn, ktrd, kt
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRD/trdvor.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRD/trdvor.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/TRD/trdvor.F90 (revision 13540)
@@ -57,4 +57,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -102,7 +103,7 @@
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
+ CASE( jpdyn_zdf ) ! Vertical Diffusion
ztswu(:,:) = 0.e0 ; ztswv(:,:) = 0.e0
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 ) ! 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 )
@@ -161,5 +162,5 @@
zudpvor(:,:) = 0._wp ; zvdpvor(:,:) = 0._wp ! Initialisation
- CALL lbc_lnk_multi( 'trdvor', putrdvor, 'U', -1. , pvtrdvor, 'V', -1. ) ! lateral boundary condition
+ CALL lbc_lnk_multi( 'trdvor', putrdvor, 'U', -1.0_wp , pvtrdvor, 'V', -1.0_wp ) ! lateral boundary condition
@@ -171,5 +172,5 @@
!
CASE( jpvor_bfr ) ! bottom friction
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
ikbu = mbkv(ji,jj)
ikbv = mbkv(ji,jj)
@@ -192,5 +193,6 @@
DO jj = 1, jpjm1
vortrd(ji,jj,ktrd) = ( zvdpvor(ji+1,jj) - zvdpvor(ji,jj) &
- & - ( zudpvor(ji,jj+1) - zudpvor(ji,jj) ) ) / ( e1f(ji,jj) * e2f(ji,jj) )
+ & - ( zudpvor(ji,jj+1) - zudpvor(ji,jj) ) ) &
+ & / ( e1f(ji,jj) * e2f(ji,jj) )
END DO
END DO
@@ -249,5 +251,5 @@
zvdpvor(:,:) = 0._wp
! ! lateral boundary condition on input momentum trends
- CALL lbc_lnk_multi( 'trdvor', putrdvor, 'U', -1. , pvtrdvor, 'V', -1. )
+ CALL lbc_lnk_multi( 'trdvor', putrdvor, 'U', -1.0_wp , pvtrdvor, 'V', -1.0_wp )
! =====================================
@@ -268,5 +270,6 @@
DO jj = 1, jpjm1
vortrd(ji,jj,jpvor_bev) = ( zvbet(ji+1,jj) - zvbet(ji,jj) &
- & - ( zubet(ji,jj+1) - zubet(ji,jj) ) ) / ( e1f(ji,jj) * e2f(ji,jj) )
+ & - ( zubet(ji,jj+1) - zubet(ji,jj) ) ) &
+ & / ( e1f(ji,jj) * e2f(ji,jj) )
END DO
END DO
@@ -283,5 +286,6 @@
DO jj=1,jpjm1
vortrd(ji,jj,ktrd) = ( zvdpvor(ji+1,jj) - zvdpvor(ji,jj) &
- & - ( zudpvor(ji,jj+1) - zudpvor(ji,jj) ) ) / ( e1f(ji,jj) * e2f(ji,jj) )
+ & - ( zudpvor(ji,jj+1) - zudpvor(ji,jj) ) ) &
+ & / ( e1f(ji,jj) * e2f(ji,jj) )
END DO
END DO
@@ -345,5 +349,6 @@
DO jj = 1, jpjm1
vor_avr(ji,jj) = ( ( zvv(ji+1,jj) - zvv(ji,jj) ) &
- & - ( zuu(ji,jj+1) - zuu(ji,jj) ) ) / ( e1f(ji,jj) * e2f(ji,jj) ) * fmask(ji,jj,1)
+ & - ( zuu(ji,jj+1) - zuu(ji,jj) ) ) &
+ & / ( e1f(ji,jj) * e2f(ji,jj) ) * fmask(ji,jj,1)
END DO
END DO
@@ -395,5 +400,5 @@
! Boundary conditions
- CALL lbc_lnk_multi( 'trdvor', vor_avrtot, 'F', 1. , vor_avrres, 'F', 1. )
+ CALL lbc_lnk_multi( 'trdvor', vor_avrtot, 'F', 1.0_wp , vor_avrres, 'F', 1.0_wp )
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/USR/usrdef_fmask.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/USR/usrdef_fmask.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/USR/usrdef_fmask.F90 (revision 13540)
@@ -58,5 +58,5 @@
!!----------------------------------------------------------------------
!
- IF( TRIM( cd_cfg ) == "orca" ) THEN !== ORCA Configurations ==!
+ IF( TRIM( cd_cfg ) == "orca" .OR. TRIM( cd_cfg ) == "ORCA" ) THEN !== ORCA Configurations ==!
!
SELECT CASE ( kcfg )
@@ -68,14 +68,18 @@
!
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
- ij0 = 102 ; ij1 = 102
- ii0 = 139 ; ii1 = 140 ; pfmsk( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 0.5_wp
+ 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
+ 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
!
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
- ij0 = 88 ; ij1 = 88
- ii0 = 159 ; ii1 = 159 ; pfmsk( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 1._wp
+ 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
+ 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
!
! We keep this as an example but it is instable in this case
@@ -94,39 +98,47 @@
!!gm ! Currently these hard-wired indices relate to configuration with extend grid (jpjglo=332)
!
- isrow = 332 - jpjglo
+ isrow = 332 - (Nj0glo + 1) ! was 332 - jpjglo -> jpjglo_old_version = Nj0glo + 1
!
IF(lwp) WRITE(numout,*)
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
+ 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
!
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
+ 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
!
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
+ 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
!
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
+ 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
!
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
+ 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
!
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
+ 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
!
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
+ 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
!
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
+ 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
!
CASE DEFAULT
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/USR/usrdef_hgr.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/USR/usrdef_hgr.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/USR/usrdef_hgr.F90 (revision 13540)
@@ -13,5 +13,5 @@
!! usr_def_hgr : initialize the horizontal mesh
!!----------------------------------------------------------------------
- USE dom_oce , ONLY: nimpp, njmpp ! ocean space and time domain
+ USE dom_oce ! ocean space and time domain
USE par_oce ! ocean space and time domain
USE phycst ! physical constants
@@ -90,14 +90,15 @@
zcos_alpha = SQRT( 2._wp ) * 0.5_wp
ze1deg = ze1 / (ra * rad)
- zlam0 = zlam1 + zcos_alpha * ze1deg * REAL( jpjglo-2 , wp )
- zphi0 = zphi1 + zsin_alpha * ze1deg * REAL( jpjglo-2 , wp )
+ zlam0 = zlam1 + zcos_alpha * ze1deg * REAL( Ni0glo - 2, wp )
+ zphi0 = zphi1 + zsin_alpha * ze1deg * REAL( Nj0glo - 2, wp )
#if defined key_agrif
! ! Upper left longitude and latitude from parent:
+ ! Laurent: Should be modify in case of an east-west cyclic parent grid
IF (.NOT.Agrif_root()) THEN
- zlam0 = zlam1 + Agrif_irhox() * REAL(Agrif_Parent(jpjglo)-2 , wp) * ze1deg * zcos_alpha &
+ zlam0 = zlam1 + Agrif_irhox() * REAL(Agrif_Parent(Ni0glo) -2, wp) * ze1deg * zcos_alpha &
& + ( Agrif_Ix()*Agrif_irhox()-(0.5_wp+nbghostcells)) * ze1deg * zcos_alpha &
& + ( Agrif_Iy()*Agrif_irhoy()-(0.5_wp+nbghostcells)) * ze1deg * zsin_alpha
- zphi0 = zphi1 + Agrif_irhoy() * REAL(Agrif_Parent(jpjglo)-2 , wp) * ze1deg * zsin_alpha &
+ zphi0 = zphi1 + Agrif_irhoy() * REAL(Agrif_Parent(Nj0glo) -2, wp) * ze1deg * zsin_alpha &
& - ( Agrif_Ix()*Agrif_irhox()-nbghostcells ) * ze1deg * zsin_alpha &
& + ( Agrif_Iy()*Agrif_irhoy()-nbghostcells ) * ze1deg * zcos_alpha
@@ -109,12 +110,12 @@
CALL ctl_warn( ' GYRE used as Benchmark: e1=e2=106km, no need to adjust rn_Dt, ahm,aht ' )
ENDIF
- IF( nprint==1 .AND. lwp ) THEN
+ IF( lwp ) THEN
WRITE(numout,*) 'ze1', ze1, 'cosalpha', zcos_alpha, 'sinalpha', zsin_alpha
WRITE(numout,*) 'ze1deg', ze1deg, 'zlam0', zlam0, 'zphi0', zphi0
ENDIF
!
- DO_2D_11_11
- zim1 = REAL( ji + nimpp - 1 ) - 1. ; zim05 = REAL( ji + nimpp - 1 ) - 1.5
- zjm1 = REAL( jj + njmpp - 1 ) - 1. ; zjm05 = REAL( jj + njmpp - 1 ) - 1.5
+ DO_2D( 1, 1, 1, 1 )
+ zim1 = REAL( mig0_oldcmp(ji), wp ) - 1. ; zim05 = REAL( mig0_oldcmp(ji), wp ) - 1.5
+ zjm1 = REAL( mjg0_oldcmp(jj), wp ) - 1. ; zjm05 = REAL( mjg0_oldcmp(jj), wp ) - 1.5
!
!glamt(i,j) longitude at T-point
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/USR/usrdef_istate.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/USR/usrdef_istate.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/USR/usrdef_istate.F90 (revision 13540)
@@ -57,9 +57,9 @@
IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~ Ocean at rest, with an horizontally uniform T and S profiles'
!
- pu (:,:,:) = 0._wp ! ocean at rest
+ pu (:,:,:) = 0._wp ! ocean at rest
pv (:,:,:) = 0._wp
pssh(:,:) = 0._wp
!
- DO_3D_11_11( 1, jpk )
+ DO_3D( 1, 1, 1, 1, 1, jpk ) ! horizontally uniform T & S profiles
pts(ji,jj,jk,jp_tem) = ( ( 16. - 12. * TANH( (pdept(ji,jj,jk) - 400) / 700 ) ) &
& * (-TANH( (500. - pdept(ji,jj,jk)) / 150. ) + 1.) / 2. &
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/USR/usrdef_nam.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/USR/usrdef_nam.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/USR/usrdef_nam.F90 (revision 13540)
@@ -14,5 +14,5 @@
!! usr_def_hgr : initialize the horizontal mesh
!!----------------------------------------------------------------------
- USE dom_oce , ONLY: nimpp, njmpp ! ocean space and time domain
+ USE dom_oce
USE par_oce ! ocean space and time domain
USE phycst ! physical constants
@@ -70,10 +70,12 @@
kk_cfg = nn_GYRE
!
- kpi = 30 * nn_GYRE + 2 ! Global Domain size
+ kpi = 30 * nn_GYRE + 2 !
kpj = 20 * nn_GYRE + 2
#if defined key_agrif
- IF( .NOT. Agrif_Root() ) THEN
- kpi = nbcellsx + 2 + 2*nbghostcells
- kpj = nbcellsy + 2 + 2*nbghostcells
+ IF( .NOT.Agrif_Root() ) THEN ! Global Domain size: add 1 land point on each side
+ kpi = nbcellsx + 2 * ( nbghostcells + 1 )
+ kpj = nbcellsy + 2 * ( nbghostcells + 1 )
+!!$ kpi = nbcellsx + nbghostcells_x + nbghostcells_x + 2
+!!$ kpj = nbcellsy + nbghostcells_y_s + nbghostcells_y_n + 2
ENDIF
#endif
@@ -93,12 +95,12 @@
IF( Agrif_Root() ) THEN
#endif
- WRITE(numout,*) ' jpiglo = 30*nn_GYRE+2 jpiglo = ', kpi
- WRITE(numout,*) ' jpjglo = 20*nn_GYRE+2 jpjglo = ', kpj
+ WRITE(numout,*) ' Ni0glo = 30*nn_GYRE Ni0glo = ', kpi
+ WRITE(numout,*) ' Nj0glo = 20*nn_GYRE Nj0glo = ', kpj
#if defined key_agrif
ENDIF
#endif
- WRITE(numout,*) ' number of model levels jpkglo = ', kpk
+ WRITE(numout,*) ' number of model levels jpkglo = ', kpk
WRITE(numout,*) ' '
- WRITE(numout,*) ' Lateral b.c. of the global domain set to closed jperio = ', kperio
+ WRITE(numout,*) ' Lateral b.c. of the global domain set to closed jperio = ', kperio
ENDIF
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/USR/usrdef_sbc.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/USR/usrdef_sbc.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/USR/usrdef_sbc.F90 (revision 13540)
@@ -110,5 +110,5 @@
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_11_11
+ DO_2D( 1, 1, 1, 1 )
! 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 :
@@ -165,5 +165,5 @@
ztau_sais = 0.015
ztaun = ztau - ztau_sais * COS( (ztime - ztimemax) / (ztimemin - ztimemax) * rpi )
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
! domain from 15deg to 50deg and 1/2 period along 14deg
! so 5/4 of half period with seasonal cycle
@@ -174,5 +174,5 @@
! module of wind stress and wind speed at T-point
zcoef = 1. / ( zrhoa * zcdrag )
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
ztx = utau(ji-1,jj ) + utau(ji,jj)
zty = vtau(ji ,jj-1) + vtau(ji,jj)
@@ -181,5 +181,5 @@
wndm(ji,jj) = SQRT( zmod * zcoef )
END_2D
- CALL lbc_lnk_multi( 'usrdef_sbc', taum(:,:), 'T', 1. , wndm(:,:), 'T', 1. )
+ CALL lbc_lnk_multi( 'usrdef_sbc', taum(:,:), 'T', 1.0_wp , wndm(:,:), 'T', 1.0_wp )
! ---------------------------------- !
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/USR/usrdef_zgr.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/USR/usrdef_zgr.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/USR/usrdef_zgr.F90 (revision 13540)
@@ -198,9 +198,7 @@
IF(lwp) WRITE(numout,*) ' GYRE case : closed flat box ocean without ocean cavities'
!
- z2d(:,:) = REAL( jpkm1 , wp ) ! flat bottom
- !
- CALL lbc_lnk( 'usrdef_zgr', z2d, 'T', 1. ) ! set surrounding land to zero (here jperio=0 ==>> closed)
- !
- k_bot(:,:) = NINT( z2d(:,:) ) ! =jpkm1 over the ocean point, =0 elsewhere
+ z2d(:,:) = REAL( jpkm1 , wp ) ! flat bottom
+ !
+ k_bot(:,:) = NINT( z2d(:,:) ) ! =jpkm1 over the ocean point, =0 elsewhere
!
k_top(:,:) = MIN( 1 , k_bot(:,:) ) ! = 1 over the ocean point, =0 elsewhere
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/ZDF/zdfddm.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/ZDF/zdfddm.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/ZDF/zdfddm.F90 (revision 13540)
@@ -77,6 +77,8 @@
REAL(wp) :: zaw, zbw, zrw ! local scalars
REAL(wp) :: zdt, zds
- REAL(wp) :: zinr, zrr ! - -
- REAL(wp) :: zavft, zavfs ! - -
+ REAL(wp) :: zinr ! - -
+ REAL(dp) :: zrr ! - -
+ REAL(wp) :: zavft ! - -
+ REAL(dp) :: zavfs ! - -
REAL(wp) :: zavdt, zavds ! - -
REAL(wp), DIMENSION(jpi,jpj) :: zrau, zmsks, zmskf, zmskd1, zmskd2, zmskd3
@@ -92,7 +94,7 @@
!!gm and many acces in memory
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 ) !== R=zrau = (alpha / beta) (dk[t] / dk[s]) ==!
zrw = ( gdepw(ji,jj,jk ,Kmm) - gdept(ji,jj,jk,Kmm) ) &
-!!gm please, use e3w(:,:,:,Kmm) below
+!!gm please, use e3w at Kmm below
& / ( gdept(ji,jj,jk-1,Kmm) - gdept(ji,jj,jk,Kmm) )
!
@@ -108,5 +110,5 @@
END_2D
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 ) !== 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
@@ -138,5 +140,5 @@
! ------------------
! Constant eddy coefficient: reset to the background value
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
zinr = 1._wp / zrau(ji,jj)
! salt fingering
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/ZDF/zdfdrg.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/ZDF/zdfdrg.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/ZDF/zdfdrg.F90 (revision 13540)
@@ -32,4 +32,5 @@
USE lib_mpp ! distributed memory computing
USE prtctl ! Print control
+ USE sbc_oce , ONLY : nn_ice
IMPLICIT NONE
@@ -41,10 +42,10 @@
! !!* Namelist namdrg: nature of drag coefficient namelist *
- LOGICAL :: ln_OFF ! free-slip : Cd = 0
+ LOGICAL , PUBLIC :: ln_drg_OFF ! free-slip : Cd = 0
LOGICAL :: ln_lin ! linear drag: Cd = Cd0_lin
LOGICAL :: ln_non_lin ! non-linear drag: Cd = Cd0_nl |U|
LOGICAL :: ln_loglayer ! logarithmic drag: Cd = vkarmn/log(z/z0)
LOGICAL , PUBLIC :: ln_drgimp ! implicit top/bottom friction flag
-
+ LOGICAL , PUBLIC :: ln_drgice_imp ! implicit ice-ocean drag
! !!* Namelist namdrg_top & _bot: TOP or BOTTOM coefficient namelist *
REAL(wp) :: rn_Cd0 !: drag coefficient [ - ]
@@ -74,4 +75,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -115,5 +117,5 @@
!
IF( l_log_not_linssh ) THEN !== "log layer" ==! compute Cd and -Cd*|U|
- DO_2D_00_00
+ 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
@@ -127,5 +129,5 @@
END_2D
ELSE !== standard Cd ==!
- DO_2D_00_00
+ 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
@@ -174,5 +176,5 @@
ENDIF
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
ikbu = mbku(ji,jj) ! deepest wet ocean u- & v-levels
ikbv = mbkv(ji,jj)
@@ -187,5 +189,5 @@
!
IF( ln_isfcav ) THEN ! ocean cavities
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
ikbu = miku(ji,jj) ! first wet ocean u- & v-levels
ikbv = mikv(ji,jj)
@@ -225,5 +227,5 @@
INTEGER :: ios, ioptio ! local integers
!!
- NAMELIST/namdrg/ ln_OFF, ln_lin, ln_non_lin, ln_loglayer, ln_drgimp
+ NAMELIST/namdrg/ ln_drg_OFF, ln_lin, ln_non_lin, ln_loglayer, ln_drgimp, ln_drgice_imp
!!----------------------------------------------------------------------
!
@@ -236,4 +238,6 @@
IF(lwm) WRITE ( numond, namdrg )
!
+ IF ( ln_drgice_imp .AND. nn_ice /= 2 ) ln_drgice_imp = .FALSE.
+ !
IF(lwp) THEN
WRITE(numout,*)
@@ -241,13 +245,14 @@
WRITE(numout,*) '~~~~~~~~~~~~'
WRITE(numout,*) ' Namelist namdrg : top/bottom friction choices'
- WRITE(numout,*) ' free-slip : Cd = 0 ln_OFF = ', ln_OFF
+ WRITE(numout,*) ' free-slip : Cd = 0 ln_drg_OFF = ', ln_drg_OFF
WRITE(numout,*) ' linear drag : Cd = Cd0 ln_lin = ', ln_lin
WRITE(numout,*) ' non-linear drag: Cd = Cd0_nl |U| ln_non_lin = ', ln_non_lin
WRITE(numout,*) ' logarithmic drag: Cd = vkarmn/log(z/z0) ln_loglayer = ', ln_loglayer
WRITE(numout,*) ' implicit friction ln_drgimp = ', ln_drgimp
+ WRITE(numout,*) ' implicit ice-ocean drag ln_drgice_imp =', ln_drgice_imp
ENDIF
!
ioptio = 0 ! set ndrg and control check
- IF( ln_OFF ) THEN ; ndrg = np_OFF ; ioptio = ioptio + 1 ; ENDIF
+ IF( ln_drg_OFF ) THEN ; ndrg = np_OFF ; ioptio = ioptio + 1 ; ENDIF
IF( ln_lin ) THEN ; ndrg = np_lin ; ioptio = ioptio + 1 ; ENDIF
IF( ln_non_lin ) THEN ; ndrg = np_non_lin ; ioptio = ioptio + 1 ; ENDIF
@@ -256,4 +261,6 @@
IF( ioptio /= 1 ) CALL ctl_stop( 'zdf_drg_init: Choose ONE type of drag coef in namdrg' )
!
+ IF ( ln_drgice_imp.AND.(.NOT.ln_drgimp) ) &
+ & CALL ctl_stop( 'zdf_drg_init: ln_drgice_imp=T requires ln_drgimp=T' )
!
! !== BOTTOM drag setting ==! (applied at seafloor)
@@ -262,10 +269,13 @@
CALL drg_init( 'BOTTOM' , mbkt , & ! <== in
& r_Cdmin_bot, r_Cdmax_bot, r_z0_bot, r_ke0_bot, rCd0_bot, rCdU_bot ) ! ==> out
-
!
! !== TOP drag setting ==! (applied at the top of ocean cavities)
!
- IF( ln_isfcav ) THEN ! Ocean cavities: top friction setting
- ALLOCATE( rCd0_top(jpi,jpj), rCdU_top(jpi,jpj) )
+ IF( ln_isfcav.OR.ln_drgice_imp ) THEN ! Ocean cavities: top friction setting
+ ALLOCATE( rCdU_top(jpi,jpj) )
+ ENDIF
+ !
+ IF( ln_isfcav ) THEN
+ ALLOCATE( rCd0_top(jpi,jpj))
CALL drg_init( 'TOP ' , mikt , & ! <== in
& r_Cdmin_top, r_Cdmax_top, r_z0_top, r_ke0_top, rCd0_top, rCdU_top ) ! ==> out
@@ -362,5 +372,5 @@
! cl_varname is a coefficient in [0,1] giving where to apply the regional boost
CALL iom_open ( TRIM(cl_file), inum )
- CALL iom_get ( inum, jpdom_data, TRIM(cl_varname), zmsk_boost, 1 )
+ CALL iom_get ( inum, jpdom_global, TRIM(cl_varname), zmsk_boost, 1 )
CALL iom_close( inum)
zmsk_boost(:,:) = 1._wp + rn_boost * zmsk_boost(:,:)
@@ -421,5 +431,5 @@
l_log_not_linssh = .FALSE. !- don't update Cd at each time step
!
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 ) ! pCd0 = mask (and boosted) logarithmic drag coef.
zzz = 0.5_wp * e3t_0(ji,jj,k_mk(ji,jj))
zcd = ( vkarmn / LOG( zzz / rn_z0 ) )**2
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/ZDF/zdfevd.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/ZDF/zdfevd.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/ZDF/zdfevd.F90 (revision 13540)
@@ -87,5 +87,5 @@
! END WHERE
!
- DO_3D_00_00( 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)
@@ -103,5 +103,5 @@
! END WHERE
- DO_3D_00_00( 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)
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/ZDF/zdfgls.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/ZDF/zdfgls.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/ZDF/zdfgls.F90 (revision 13540)
@@ -19,4 +19,5 @@
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
@@ -53,4 +54,5 @@
INTEGER :: nn_bc_bot ! bottom boundary condition (=0/1)
INTEGER :: nn_z0_met ! Method for surface roughness computation
+ INTEGER :: nn_z0_ice ! Roughness accounting for sea ice
INTEGER :: nn_stab_func ! stability functions G88, KC or Canuto (=0/1/2)
INTEGER :: nn_clos ! closure 0/1/2/3 MY82/k-eps/k-w/gen
@@ -61,4 +63,5 @@
REAL(wp) :: rn_crban ! Craig and Banner constant for surface breaking waves mixing
REAL(wp) :: rn_hsro ! Minimum surface roughness
+ REAL(wp) :: rn_hsri ! Ice ocean roughness
REAL(wp) :: rn_frac_hs ! Fraction of wave height as surface roughness (if nn_z0_met > 1)
@@ -105,4 +108,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -151,4 +155,5 @@
REAL(wp), DIMENSION(jpi,jpj) :: zflxs ! Turbulence fluxed induced by internal waves
REAL(wp), DIMENSION(jpi,jpj) :: zhsro ! Surface roughness (surface waves)
+ REAL(wp), DIMENSION(jpi,jpj) :: zice_fra ! Tapering of wave breaking under sea ice
REAL(wp), DIMENSION(jpi,jpj,jpk) :: eb ! tke at time before
REAL(wp), DIMENSION(jpi,jpj,jpk) :: hmxl_b ! mixing length at time before
@@ -166,24 +171,33 @@
ustar2_bot (:,:) = 0._wp
+ SELECT CASE ( nn_z0_ice )
+ CASE( 0 ) ; zice_fra(:,:) = 0._wp
+ CASE( 1 ) ; zice_fra(:,:) = TANH( fr_i(:,:) * 10._wp )
+ CASE( 2 ) ; zice_fra(:,:) = fr_i(:,:)
+ CASE( 3 ) ; zice_fra(:,:) = MIN( 4._wp * fr_i(:,:) , 1._wp )
+ END SELECT
+
! Compute surface, top and bottom friction at T-points
- DO_2D_00_00
- !
- ! surface friction
- ustar2_surf(ji,jj) = r1_rho0 * taum(ji,jj) * tmask(ji,jj,1)
- !
-!!gm Rq we may add here r_ke0(_top/_bot) ? ==>> think about that...
- ! bottom friction (explicit before friction)
- zmsku = ( 2._wp - umask(ji-1,jj,mbkt(ji,jj)) * umask(ji,jj,mbkt(ji,jj)) )
- zmskv = ( 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 )
+ 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
- IF( ln_isfcav ) THEN !top friction
- DO_2D_00_00
- 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)) ) ! (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 &
- & + ( zmskv*( vv(ji,jj,mikt(ji,jj),Kbb)+vv(ji,jj-1,mikt(ji,jj),Kbb) ) )**2 )
+ !
+ !!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( 0, 0, 0, 0 ) ! bottom friction (explicit before friction)
+ zmsku = ( 2._wp - umask(ji-1,jj,mbkt(ji,jj)) * umask(ji,jj,mbkt(ji,jj)) )
+ zmskv = ( 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( 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)) ) ! (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 &
+ & + ( zmskv*( vv(ji,jj,mikt(ji,jj),Kbb)+vv(ji,jj-1,mikt(ji,jj),Kbb) ) )**2 )
+ END_2D
+ ENDIF
ENDIF
@@ -200,8 +214,11 @@
zhsro(:,:) = MAX(rsbc_zs2 * ustar2_surf(:,:) * zdep(:,:)**1.5, rn_hsro) ! zhsro = rn_frac_hs * Hsw (eq. 11)
CASE ( 3 ) ! Roughness given by the wave model (coupled or read in file)
- zhsro(:,:) = rn_frac_hs * hsw(:,:) ! (rn_frac_hs=1.6 see Eq. (5) of Rascle et al. 2008 )
+ zhsro(:,:) = MAX(rn_frac_hs * hsw(:,:), rn_hsro) ! (rn_frac_hs=1.6 see Eq. (5) of Rascle et al. 2008 )
END SELECT
!
- DO_3D_10_10( 2, jpkm1 )
+ ! adapt roughness where there is sea ice
+ zhsro(:,:) = ( (1._wp-zice_fra(:,:)) * zhsro(:,:) + zice_fra(:,:) * rn_hsri )*tmask(:,:,1) + (1._wp - tmask(:,:,1))*rn_hsro
+ !
+ 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
@@ -212,5 +229,5 @@
IF( nn_clos == 0 ) THEN ! Mellor-Yamada
- DO_3D_00_00( 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) )
@@ -233,5 +250,5 @@
! Warning : after this step, en : right hand side of the matrix
- DO_3D_00_00( 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
!
buoy = - p_avt(ji,jj,jk) * rn2(ji,jj,jk) ! stratif. destruction
@@ -263,7 +280,9 @@
zcof = rfact_tke * tmask(ji,jj,jk)
! ! lower diagonal, in fact not used for jk = 2 (see surface conditions)
- zd_lw(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk ) + p_avm(ji,jj,jk-1) ) / ( e3t(ji,jj,jk-1,Kmm) * e3w(ji,jj,jk,Kmm) )
+ zd_lw(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk ) + p_avm(ji,jj,jk-1) ) &
+ & / ( e3t(ji,jj,jk-1,Kmm) * e3w(ji,jj,jk,Kmm) )
! ! upper diagonal, in fact not used for jk = ibotm1 (see bottom conditions)
- zd_up(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk+1) + p_avm(ji,jj,jk ) ) / ( e3t(ji,jj,jk ,Kmm) * e3w(ji,jj,jk,Kmm) )
+ zd_up(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk+1) + p_avm(ji,jj,jk ) ) &
+ & / ( e3t(ji,jj,jk ,Kmm) * e3w(ji,jj,jk,Kmm) )
! ! diagonal
zdiag(ji,jj,jk) = 1._wp - zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) + rn_Dt * zdiss * wmask(ji,jj,jk)
@@ -285,5 +304,5 @@
CASE ( 0 ) ! Dirichlet boundary condition (set e at k=1 & 2)
! First level
- en (:,:,1) = MAX( rn_emin , rc02r * ustar2_surf(:,:) * (1._wp + rsbc_tke1)**r2_3 )
+ en (:,:,1) = MAX( rn_emin , rc02r * ustar2_surf(:,:) * (1._wp + (1._wp-zice_fra(:,:))*rsbc_tke1)**r2_3 )
zd_lw(:,:,1) = en(:,:,1)
zd_up(:,:,1) = 0._wp
@@ -291,6 +310,6 @@
!
! One level below
- en (:,:,2) = MAX( rc02r * ustar2_surf(:,:) * ( 1._wp + rsbc_tke1 * ((zhsro(:,:)+gdepw(:,:,2,Kmm)) &
- & / zhsro(:,:) )**(1.5_wp*ra_sf) )**(2._wp/3._wp) , rn_emin )
+ en (:,:,2) = MAX( rc02r * ustar2_surf(:,:) * ( 1._wp + (1._wp-zice_fra(:,:))*rsbc_tke1 * ((zhsro(:,:)+gdepw(:,:,2,Kmm)) &
+ & / zhsro(:,:) )**(1.5_wp*ra_sf) )**(2._wp/3._wp) , rn_emin )
zd_lw(:,:,2) = 0._wp
zd_up(:,:,2) = 0._wp
@@ -301,5 +320,5 @@
!
! Dirichlet conditions at k=1
- en (:,:,1) = MAX( rc02r * ustar2_surf(:,:) * (1._wp + rsbc_tke1)**r2_3 , rn_emin )
+ en (:,:,1) = MAX( rc02r * ustar2_surf(:,:) * (1._wp + (1._wp-zice_fra(:,:))*rsbc_tke1)**r2_3 , rn_emin )
zd_lw(:,:,1) = en(:,:,1)
zd_up(:,:,1) = 0._wp
@@ -311,5 +330,5 @@
zd_lw(:,:,2) = 0._wp
zkar (:,:) = (rl_sf + (vkarmn-rl_sf)*(1.-EXP(-rtrans*gdept(:,:,1,Kmm)/zhsro(:,:)) ))
- zflxs(:,:) = rsbc_tke2 * ustar2_surf(:,:)**1.5_wp * zkar(:,:) &
+ zflxs(:,:) = rsbc_tke2 * (1._wp-zice_fra(:,:)) * ustar2_surf(:,:)**1.5_wp * zkar(:,:) &
& * ( ( zhsro(:,:)+gdept(:,:,1,Kmm) ) / zhsro(:,:) )**(1.5_wp*ra_sf)
!!gm why not : * ( 1._wp + gdept(:,:,1,Kmm) / zhsro(:,:) )**(1.5_wp*ra_sf)
@@ -327,5 +346,5 @@
! ! en(ibot) = u*^2 / Co2 and hmxl_n(ibot) = rn_lmin
! ! Balance between the production and the dissipation terms
- DO_2D_00_00
+ 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 ???
@@ -345,5 +364,5 @@
!
IF( ln_isfcav) THEN ! top boundary (ocean cavity)
- DO_2D_00_00
+ 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
@@ -363,5 +382,5 @@
CASE ( 1 ) ! Neumman boundary condition
!
- DO_2D_00_00
+ 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
@@ -377,5 +396,5 @@
END_2D
IF( ln_isfcav) THEN ! top boundary (ocean cavity)
- DO_2D_00_00
+ 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
@@ -397,11 +416,11 @@
! ----------------------------------------------------------
!
- DO_3D_00_00( 2, jpkm1 )
+ 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_00_00( 2, jpk )
+ DO_3D( 0, 0, 0, 0, 2, jpk ) ! 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_00_00( jpk-1, 2, -1 )
+ DO_3DS( 0, 0, 0, 0, jpk-1, 2, -1 ) ! thrid 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
@@ -418,20 +437,20 @@
!
CASE( 0 ) ! k-kl (Mellor-Yamada)
- DO_3D_00_00( 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_00_00( 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_00_00( 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_00_00( 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
@@ -446,5 +465,5 @@
! Warning : after this step, en : right hand side of the matrix
- DO_3D_00_00( 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
!
! psi / k
@@ -473,7 +492,9 @@
zcof = rfact_psi * zwall_psi(ji,jj,jk) * tmask(ji,jj,jk)
! ! lower diagonal
- zd_lw(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk ) + p_avm(ji,jj,jk-1) ) / ( e3t(ji,jj,jk-1,Kmm) * e3w(ji,jj,jk,Kmm) )
+ zd_lw(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk ) + p_avm(ji,jj,jk-1) ) &
+ & / ( e3t(ji,jj,jk-1,Kmm) * e3w(ji,jj,jk,Kmm) )
! ! upper diagonal
- zd_up(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk+1) + p_avm(ji,jj,jk ) ) / ( e3t(ji,jj,jk ,Kmm) * e3w(ji,jj,jk,Kmm) )
+ zd_up(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk+1) + p_avm(ji,jj,jk ) ) &
+ & / ( e3t(ji,jj,jk ,Kmm) * e3w(ji,jj,jk,Kmm) )
! ! diagonal
zdiag(ji,jj,jk) = 1._wp - zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) + rn_Dt * zdiss * wmask(ji,jj,jk)
@@ -522,5 +543,6 @@
zkar (:,:) = rl_sf + (vkarmn-rl_sf)*(1._wp-EXP(-rtrans*gdept(:,:,1,Kmm)/zhsro(:,:) )) ! Lengh scale slope
zdep (:,:) = ((zhsro(:,:) + gdept(:,:,1,Kmm)) / zhsro(:,:))**(rmm*ra_sf)
- zflxs(:,:) = (rnn + rsbc_tke1 * (rnn + rmm*ra_sf) * zdep(:,:))*(1._wp + rsbc_tke1*zdep(:,:))**(2._wp*rmm/3._wp-1_wp)
+ zflxs(:,:) = (rnn + (1._wp-zice_fra(:,:))*rsbc_tke1 * (rnn + rmm*ra_sf) * zdep(:,:)) &
+ & *(1._wp + (1._wp-zice_fra(:,:))*rsbc_tke1*zdep(:,:))**(2._wp*rmm/3._wp-1_wp)
zdep (:,:) = rsbc_psi1 * (zwall_psi(:,:,1)*p_avm(:,:,1)+zwall_psi(:,:,2)*p_avm(:,:,2)) * &
& ustar2_surf(:,:)**rmm * zkar(:,:)**rnn * (zhsro(:,:) + gdept(:,:,1,Kmm))**(rnn-1.)
@@ -541,5 +563,5 @@
! ! en(ibot) = u*^2 / Co2 and hmxl_n(ibot) = vkarmn * r_z0_bot
! ! Balance between the production and the dissipation terms
- DO_2D_00_00
+ 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
@@ -560,5 +582,5 @@
CASE ( 1 ) ! Neumman boundary condition
!
- DO_2D_00_00
+ 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
@@ -588,11 +610,11 @@
! ----------------
!
- DO_3D_00_00( 2, jpkm1 )
+ 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_00_00( 2, jpk )
+ DO_3D( 0, 0, 0, 0, 2, jpk ) ! 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_00_00( jpk-1, 2, -1 )
+ DO_3DS( 0, 0, 0, 0, jpk-1, 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
@@ -604,15 +626,15 @@
!
CASE( 0 ) ! k-kl (Mellor-Yamada)
- DO_3D_00_00( 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_00_00( 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_00_00( 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
@@ -622,5 +644,5 @@
zex1 = ( 1.5_wp + rmm/rnn )
zex2 = -1._wp / rnn
- DO_3D_00_00( 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
@@ -630,5 +652,5 @@
! Limit dissipation rate under stable stratification
! --------------------------------------------------
- DO_3D_00_00( 1, jpkm1 )
+ 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 )
@@ -646,5 +668,5 @@
!
CASE ( 0 , 1 ) ! Galperin or Kantha-Clayson stability functions
- DO_3D_00_00( 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) )
@@ -663,5 +685,5 @@
!
CASE ( 2, 3 ) ! Canuto stability functions
- DO_3D_00_00( 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) )
@@ -695,5 +717,5 @@
! default value, in case jpk > mbkt(ji,jj)+1. Not needed but avoid a bug when looking for undefined values (-fpe0)
zstm(:,:,jpk) = 0.
- DO_2D_00_00
+ 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
@@ -710,5 +732,5 @@
! 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_00_00( 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)
@@ -745,8 +767,8 @@
REAL(wp):: zcr ! local scalar
!!
- NAMELIST/namzdf_gls/rn_emin, rn_epsmin, ln_length_lim, &
- & rn_clim_galp, ln_sigpsi, rn_hsro, &
- & rn_crban, rn_charn, rn_frac_hs, &
- & nn_bc_surf, nn_bc_bot, nn_z0_met, &
+ NAMELIST/namzdf_gls/rn_emin, rn_epsmin, ln_length_lim, &
+ & rn_clim_galp, ln_sigpsi, rn_hsro, rn_hsri, &
+ & rn_crban, rn_charn, rn_frac_hs, &
+ & nn_bc_surf, nn_bc_bot, nn_z0_met, nn_z0_ice, &
& nn_stab_func, nn_clos
!!----------------------------------------------------------
@@ -774,8 +796,18 @@
WRITE(numout,*) ' Charnock coefficient rn_charn = ', rn_charn
WRITE(numout,*) ' Surface roughness formula nn_z0_met = ', nn_z0_met
+ WRITE(numout,*) ' surface wave breaking under ice nn_z0_ice = ', nn_z0_ice
+ SELECT CASE( nn_z0_ice )
+ CASE( 0 ) ; WRITE(numout,*) ' ==>>> no impact of ice cover on surface wave breaking'
+ CASE( 1 ) ; WRITE(numout,*) ' ==>>> roughness uses rn_hsri and is weigthed by 1-TANH( fr_i(:,:) * 10 )'
+ CASE( 2 ) ; WRITE(numout,*) ' ==>>> roughness uses rn_hsri and is weighted by 1-fr_i(:,:)'
+ CASE( 3 ) ; WRITE(numout,*) ' ==>>> roughness uses rn_hsri and is weighted by 1-MIN( 1, 4 * fr_i(:,:) )'
+ CASE DEFAULT
+ CALL ctl_stop( 'zdf_gls_init: wrong value for nn_z0_ice, should be 0,1,2, or 3')
+ END SELECT
WRITE(numout,*) ' Wave height frac. (used if nn_z0_met=2) rn_frac_hs = ', rn_frac_hs
WRITE(numout,*) ' Stability functions nn_stab_func = ', nn_stab_func
WRITE(numout,*) ' Type of closure nn_clos = ', nn_clos
WRITE(numout,*) ' Surface roughness (m) rn_hsro = ', rn_hsro
+ WRITE(numout,*) ' Ice-ocean roughness (used if nn_z0_ice/=0) rn_hsri = ', rn_hsri
WRITE(numout,*)
WRITE(numout,*) ' Namelist namdrg_top/_bot: used values:'
@@ -789,10 +821,10 @@
! !* Check of some namelist values
- IF( nn_bc_surf < 0 .OR. nn_bc_surf > 1 ) CALL ctl_stop( 'zdf_gls_init: bad flag: nn_bc_surf is 0 or 1' )
- IF( nn_bc_surf < 0 .OR. nn_bc_surf > 1 ) CALL ctl_stop( 'zdf_gls_init: bad flag: nn_bc_surf is 0 or 1' )
- IF( nn_z0_met < 0 .OR. nn_z0_met > 3 ) CALL ctl_stop( 'zdf_gls_init: bad flag: nn_z0_met is 0, 1, 2 or 3' )
- IF( nn_z0_met == 3 .AND. .NOT.ln_wave ) CALL ctl_stop( 'zdf_gls_init: nn_z0_met=3 requires ln_wave=T' )
- IF( nn_stab_func < 0 .OR. nn_stab_func > 3 ) CALL ctl_stop( 'zdf_gls_init: bad flag: nn_stab_func is 0, 1, 2 and 3' )
- IF( nn_clos < 0 .OR. nn_clos > 3 ) CALL ctl_stop( 'zdf_gls_init: bad flag: nn_clos is 0, 1, 2 or 3' )
+ IF( nn_bc_surf < 0 .OR. nn_bc_surf > 1 ) CALL ctl_stop( 'zdf_gls_init: bad flag: nn_bc_surf is 0 or 1' )
+ IF( nn_bc_surf < 0 .OR. nn_bc_surf > 1 ) CALL ctl_stop( 'zdf_gls_init: bad flag: nn_bc_surf is 0 or 1' )
+ IF( nn_z0_met < 0 .OR. nn_z0_met > 3 ) CALL ctl_stop( 'zdf_gls_init: bad flag: nn_z0_met is 0, 1, 2 or 3' )
+ IF( nn_z0_met == 3 .AND. .NOT. (ln_wave .AND. ln_sdw ) ) CALL ctl_stop( 'zdf_gls_init: nn_z0_met=3 requires ln_wave=T and ln_sdw=T' )
+ IF( nn_stab_func < 0 .OR. nn_stab_func > 3 ) CALL ctl_stop( 'zdf_gls_init: bad flag: nn_stab_func is 0, 1, 2 and 3' )
+ IF( nn_clos < 0 .OR. nn_clos > 3 ) CALL ctl_stop( 'zdf_gls_init: bad flag: nn_clos is 0, 1, 2 or 3' )
SELECT CASE ( nn_clos ) !* set the parameters for the chosen closure
@@ -1065,8 +1097,8 @@
!
IF( MIN( id1, id2, id3, id4 ) > 0 ) THEN ! all required arrays exist
- CALL iom_get( numror, jpdom_autoglo, 'en' , en , ldxios = lrxios )
- CALL iom_get( numror, jpdom_autoglo, 'avt_k' , avt_k , ldxios = lrxios )
- CALL iom_get( numror, jpdom_autoglo, 'avm_k' , avm_k , ldxios = lrxios )
- CALL iom_get( numror, jpdom_autoglo, 'hmxl_n', hmxl_n, ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'en' , en , ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'avt_k' , avt_k , ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'avm_k' , avm_k , ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'hmxl_n', hmxl_n, ldxios = lrxios )
ELSE
IF(lwp) WRITE(numout,*)
@@ -1100,3 +1132,2 @@
!!======================================================================
END MODULE zdfgls
-
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/ZDF/zdfiwm.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/ZDF/zdfiwm.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/ZDF/zdfiwm.F90 (revision 13540)
@@ -23,4 +23,5 @@
USE phycst ! physical constants
!
+ USE fldread ! field read
USE prtctl ! Print control
USE in_out_manager ! I/O manager
@@ -50,4 +51,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -93,5 +95,5 @@
!! 2. Pycnocline-intensified low-mode dissipation
!! zemx_iwm(z) = ( epyc_iwm / rho0 ) * ( sqrt(rn2(z))^nn_zpyc )
- !! / SUM( sqrt(rn2(z))^nn_zpyc * e3w(z) )
+ !! / SUM( sqrt(rn2(z))^nn_zpyc * e3w[z) )
!! where epyc_iwm is a map of available power, and nn_zpyc
!! is the chosen stratification-dependence of the internal wave
@@ -99,10 +101,10 @@
!! 3. WKB-height dependent high mode dissipation
!! zemx_iwm(z) = ( ebot_iwm / rho0 ) * rn2(z) * EXP(-z_wkb(z)/hbot_iwm)
- !! / SUM( rn2(z) * EXP(-z_wkb(z)/hbot_iwm) * e3w(z) )
+ !! / SUM( rn2(z) * EXP(-z_wkb(z)/hbot_iwm) * e3w[z) )
!! where hbot_iwm is the characteristic length scale of the WKB bottom
!! intensification, ebot_iwm is a map of available power, and z_wkb is the
!! WKB-stretched height above bottom defined as
- !! z_wkb(z) = H * SUM( sqrt(rn2(z'>=z)) * e3w(z'>=z) )
- !! / SUM( sqrt(rn2(z')) * e3w(z') )
+ !! z_wkb(z) = H * SUM( sqrt(rn2(z'>=z)) * e3w[z'>=z) )
+ !! / SUM( sqrt(rn2(z')) * e3w[z') )
!!
!! - update the model vertical eddy viscosity and diffusivity:
@@ -138,8 +140,21 @@
!!----------------------------------------------------------------------
!
- ! !* Set to zero the 1st and last vertical levels of appropriate variables
- zemx_iwm (:,:,1) = 0._wp ; zemx_iwm (:,:,jpk) = 0._wp
- zav_ratio(:,:,1) = 0._wp ; zav_ratio(:,:,jpk) = 0._wp
- zav_wave (:,:,1) = 0._wp ; zav_wave (:,:,jpk) = 0._wp
+ !
+ ! Set to zero the 1st and last vertical levels of appropriate variables
+ IF( iom_use("emix_iwm") ) THEN
+ DO_2D( 0, 0, 0, 0 )
+ zemx_iwm (ji,jj,1) = 0._wp ; zemx_iwm (ji,jj,jpk) = 0._wp
+ END_2D
+ ENDIF
+ IF( iom_use("av_ratio") ) THEN
+ DO_2D( 0, 0, 0, 0 )
+ zav_ratio(ji,jj,1) = 0._wp ; zav_ratio(ji,jj,jpk) = 0._wp
+ END_2D
+ ENDIF
+ IF( iom_use("av_wave") .OR. sn_cfctl%l_prtctl ) THEN
+ DO_2D( 0, 0, 0, 0 )
+ zav_wave (ji,jj,1) = 0._wp ; zav_wave (ji,jj,jpk) = 0._wp
+ END_2D
+ ENDIF
!
! ! ----------------------------- !
@@ -149,5 +164,5 @@
! !* Critical slope mixing: distribute energy over the time-varying ocean depth,
! using an exponential decay from the seafloor.
- DO_2D_11_11
+ DO_2D( 0, 0, 0, 0 ) ! part independent of the level
zhdep(ji,jj) = gdepw_0(ji,jj,mbkt(ji,jj)+1) ! depth of the ocean
zfact(ji,jj) = rho0 * ( 1._wp - EXP( -zhdep(ji,jj) / hcri_iwm(ji,jj) ) )
@@ -155,5 +170,5 @@
END_2D
!!gm gde3w ==>>> check for ssh taken into account.... seem OK gde3w_n=gdept(:,:,:,Kmm) - ssh(:,:,Kmm)
- DO_3D_11_11( 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! complete with the level-dependent part
IF ( zfact(ji,jj) == 0._wp .OR. wmask(ji,jj,jk) == 0._wp ) THEN ! optimization
zemx_iwm(ji,jj,jk) = 0._wp
@@ -175,31 +190,35 @@
CASE ( 1 ) ! Dissipation scales as N (recommended)
!
- zfact(:,:) = 0._wp
- DO jk = 2, jpkm1 ! part independent of the level
- zfact(:,:) = zfact(:,:) + e3w(:,:,jk,Kmm) * SQRT( MAX( 0._wp, rn2(:,:,jk) ) ) * wmask(:,:,jk)
- END DO
- !
- DO_2D_11_11
+ DO_2D( 0, 0, 0, 0 )
+ zfact(ji,jj) = 0._wp
+ END_2D
+ 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) ) ) * wmask(ji,jj,jk)
+ END_3D
+ !
+ DO_2D( 0, 0, 0, 0 )
IF( zfact(ji,jj) /= 0 ) zfact(ji,jj) = epyc_iwm(ji,jj) / ( rho0 * zfact(ji,jj) )
END_2D
!
- DO jk = 2, jpkm1 ! complete with the level-dependent part
- zemx_iwm(:,:,jk) = zemx_iwm(:,:,jk) + zfact(:,:) * SQRT( MAX( 0._wp, rn2(:,:,jk) ) ) * wmask(:,:,jk)
- END DO
+ 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) ) ) * wmask(ji,jj,jk)
+ END_3D
!
CASE ( 2 ) ! Dissipation scales as N^2
!
- zfact(:,:) = 0._wp
- DO jk = 2, jpkm1 ! part independent of the level
- zfact(:,:) = zfact(:,:) + e3w(:,:,jk,Kmm) * MAX( 0._wp, rn2(:,:,jk) ) * wmask(:,:,jk)
- END DO
- !
- DO_2D_11_11
+ DO_2D( 0, 0, 0, 0 )
+ zfact(ji,jj) = 0._wp
+ END_2D
+ 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) ) * wmask(ji,jj,jk)
+ END_3D
+ !
+ DO_2D( 0, 0, 0, 0 )
IF( zfact(ji,jj) /= 0 ) zfact(ji,jj) = epyc_iwm(ji,jj) / ( rho0 * zfact(ji,jj) )
END_2D
!
- DO jk = 2, jpkm1 ! complete with the level-dependent part
- zemx_iwm(:,:,jk) = zemx_iwm(:,:,jk) + zfact(:,:) * MAX( 0._wp, rn2(:,:,jk) ) * wmask(:,:,jk)
- END DO
+ 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) ) * wmask(ji,jj,jk)
+ END_3D
!
END SELECT
@@ -208,26 +227,24 @@
! !* ocean depth as proportional to rn2 * exp(-z_wkb/rn_hbot)
!
- zwkb (:,:,:) = 0._wp
- zfact(:,:) = 0._wp
- DO jk = 2, jpkm1
- zfact(:,:) = zfact(:,:) + e3w(:,:,jk,Kmm) * SQRT( MAX( 0._wp, rn2(:,:,jk) ) ) * wmask(:,:,jk)
- zwkb(:,:,jk) = zfact(:,:)
- END DO
-!!gm even better:
-! DO jk = 2, jpkm1
-! zwkb(:,:) = zwkb(:,:) + e3w(:,:,jk,Kmm) * SQRT( MAX( 0._wp, rn2(:,:,jk) ) )
-! END DO
-! zfact(:,:) = zwkb(:,:,jpkm1)
-!!gm or just use zwkb(k=jpk-1) instead of zfact...
-!!gm
- !
- DO_3D_11_11( 2, jpkm1 )
+ DO_2D( 0, 0, 0, 0 )
+ zwkb(ji,jj,1) = 0._wp
+ END_2D
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
+ zwkb(ji,jj,jk) = zwkb(ji,jj,jk-1) + e3w(ji,jj,jk,Kmm) * SQRT( MAX( 0._wp, rn2(ji,jj,jk) ) ) * wmask(ji,jj,jk)
+ END_3D
+ DO_2D( 0, 0, 0, 0 )
+ zfact(ji,jj) = zwkb(ji,jj,jpkm1)
+ END_2D
+ !
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
IF( zfact(ji,jj) /= 0 ) zwkb(ji,jj,jk) = zhdep(ji,jj) * ( zfact(ji,jj) - zwkb(ji,jj,jk) ) &
& * wmask(ji,jj,jk) / zfact(ji,jj)
END_3D
- zwkb(:,:,1) = zhdep(:,:) * wmask(:,:,1)
- !
- DO_3D_11_11( 2, jpkm1 )
- IF ( rn2(ji,jj,jk) <= 0._wp .OR. wmask(ji,jj,jk) == 0._wp ) THEN ! optimization
+ DO_2D( 0, 0, 0, 0 )
+ zwkb (ji,jj,1) = zhdep(ji,jj) * wmask(ji,jj,1)
+ END_2D
+ !
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
+ IF ( rn2(ji,jj,jk) <= 0._wp .OR. wmask(ji,jj,jk) == 0._wp ) THEN ! optimization: EXP coast a lot
zweight(ji,jj,jk) = 0._wp
ELSE
@@ -237,40 +254,45 @@
END_3D
!
- zfact(:,:) = 0._wp
- DO jk = 2, jpkm1 ! part independent of the level
- zfact(:,:) = zfact(:,:) + zweight(:,:,jk)
- END DO
- !
- DO_2D_11_11
+ DO_2D( 0, 0, 0, 0 )
+ zfact(ji,jj) = 0._wp
+ END_2D
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! part independent of the level
+ zfact(ji,jj) = zfact(ji,jj) + zweight(ji,jj,jk)
+ END_3D
+ !
+ DO_2D( 0, 0, 0, 0 )
IF( zfact(ji,jj) /= 0 ) zfact(ji,jj) = ebot_iwm(ji,jj) / ( rho0 * zfact(ji,jj) )
END_2D
!
- DO jk = 2, jpkm1 ! complete with the level-dependent part
- zemx_iwm(:,:,jk) = zemx_iwm(:,:,jk) + zweight(:,:,jk) * zfact(:,:) * wmask(:,:,jk) &
- & / ( gde3w(:,:,jk) - gde3w(:,:,jk-1) )
-!!gm use of e3t(:,:,:,Kmm) just above?
- END DO
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! complete with the level-dependent part
+ zemx_iwm(ji,jj,jk) = zemx_iwm(ji,jj,jk) + zweight(ji,jj,jk) * zfact(ji,jj) * wmask(ji,jj,jk) &
+ & / ( gde3w(ji,jj,jk) - gde3w(ji,jj,jk-1) )
+!!gm use of e3t(ji,jj,:,Kmm) just above?
+ END_3D
!
!!gm this is to be replaced by just a constant value znu=1.e-6 m2/s
! Calculate molecular kinematic viscosity
- znu_t(:,:,:) = 1.e-4_wp * ( 17.91_wp - 0.53810_wp * ts(:,:,:,jp_tem,Kmm) + 0.00694_wp * ts(:,:,:,jp_tem,Kmm) * ts(:,:,:,jp_tem,Kmm) &
- & + 0.02305_wp * ts(:,:,:,jp_sal,Kmm) ) * tmask(:,:,:) * r1_rho0
- DO jk = 2, jpkm1
- znu_w(:,:,jk) = 0.5_wp * ( znu_t(:,:,jk-1) + znu_t(:,:,jk) ) * wmask(:,:,jk)
- END DO
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ znu_t(ji,jj,jk) = 1.e-4_wp * ( 17.91_wp - 0.53810_wp * ts(ji,jj,jk,jp_tem,Kmm) &
+ & + 0.00694_wp * ts(ji,jj,jk,jp_tem,Kmm) * ts(ji,jj,jk,jp_tem,Kmm) &
+ & + 0.02305_wp * ts(ji,jj,jk,jp_sal,Kmm) ) * tmask(ji,jj,jk) * r1_rho0
+ END_3D
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
+ znu_w(ji,jj,jk) = 0.5_wp * ( znu_t(ji,jj,jk-1) + znu_t(ji,jj,jk) ) * wmask(ji,jj,jk)
+ END_3D
!!gm end
!
! Calculate turbulence intensity parameter Reb
- DO jk = 2, jpkm1
- zReb(:,:,jk) = zemx_iwm(:,:,jk) / MAX( 1.e-20_wp, znu_w(:,:,jk) * rn2(:,:,jk) )
- END DO
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
+ zReb(ji,jj,jk) = zemx_iwm(ji,jj,jk) / MAX( 1.e-20_wp, znu_w(ji,jj,jk) * rn2(ji,jj,jk) )
+ END_3D
!
! Define internal wave-induced diffusivity
- DO jk = 2, jpkm1
- zav_wave(:,:,jk) = znu_w(:,:,jk) * zReb(:,:,jk) * r1_6 ! This corresponds to a constant mixing efficiency of 1/6
- END DO
- !
- IF( ln_mevar ) THEN ! Variable mixing efficiency case : modify zav_wave in the
- DO_3D_11_11( 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
+ zav_wave(ji,jj,jk) = znu_w(ji,jj,jk) * zReb(ji,jj,jk) * r1_6 ! 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( 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 * znu_w(ji,jj,jk) * SQRT( zReb(ji,jj,jk) )
@@ -281,12 +303,12 @@
ENDIF
!
- DO jk = 2, jpkm1 ! Bound diffusivity by molecular value and 100 cm2/s
- zav_wave(:,:,jk) = MIN( MAX( 1.4e-7_wp, zav_wave(:,:,jk) ), 1.e-2_wp ) * wmask(:,:,jk)
- END DO
+ 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
!
IF( kt == nit000 ) THEN !* Control print at first time-step: diagnose the energy consumed by zav_wave
zztmp = 0._wp
!!gm used of glosum 3D....
- DO_3D_11_11( 2, jpkm1 )
+ 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)
@@ -308,7 +330,7 @@
! ! ----------------------- !
!
- IF( ln_tsdiff ) THEN !* Option for differential mixing of salinity and temperature
+ IF( ln_tsdiff ) THEN !* Option for differential mixing of salinity and temperature
ztmp1 = 0.505_wp + 0.495_wp * TANH( 0.92_wp * ( LOG10( 1.e-20_wp ) - 0.60_wp ) )
- DO_3D_11_11( 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! Calculate S/T diffusivity ratio as a function of Reb
ztmp2 = zReb(ji,jj,jk) * 5._wp * r1_6
IF ( ztmp2 > 1.e-20_wp .AND. wmask(ji,jj,jk) == 1._wp ) THEN
@@ -319,32 +341,47 @@
END_3D
CALL iom_put( "av_ratio", zav_ratio )
- DO jk = 2, jpkm1 !* update momentum & tracer diffusivity with wave-driven mixing
- p_avs(:,:,jk) = p_avs(:,:,jk) + zav_wave(:,:,jk) * zav_ratio(:,:,jk)
- p_avt(:,:,jk) = p_avt(:,:,jk) + zav_wave(:,:,jk)
- p_avm(:,:,jk) = p_avm(:,:,jk) + zav_wave(:,:,jk)
- END DO
- !
- ELSE !* update momentum & tracer diffusivity with wave-driven mixing
- DO jk = 2, jpkm1
- p_avs(:,:,jk) = p_avs(:,:,jk) + zav_wave(:,:,jk)
- p_avt(:,:,jk) = p_avt(:,:,jk) + zav_wave(:,:,jk)
- p_avm(:,:,jk) = p_avm(:,:,jk) + zav_wave(:,:,jk)
- END DO
- ENDIF
-
- ! !* output internal wave-driven mixing coefficient
+ 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)
+ END_3D
+ !
+ ELSE !* update momentum & tracer diffusivity with wave-driven mixing
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
+ p_avs(ji,jj,jk) = p_avs(ji,jj,jk) + zav_wave(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)
+ END_3D
+ ENDIF
+
+ ! !* output internal wave-driven mixing coefficient
CALL iom_put( "av_wave", zav_wave )
- !* output useful diagnostics: Kz*N^2 ,
+ !* output useful diagnostics: Kz*N^2 ,
!!gm Kz*N2 should take into account the ratio avs/avt if it is used.... (see diaar5)
- ! vertical integral of rho0 * Kz * N^2 , energy density (zemx_iwm)
+ ! vertical integral of rho0 * Kz * N^2 , energy density (zemx_iwm)
IF( iom_use("bflx_iwm") .OR. iom_use("pcmap_iwm") ) THEN
ALLOCATE( z2d(jpi,jpj) , z3d(jpi,jpj,jpk) )
- z3d(:,:,:) = MAX( 0._wp, rn2(:,:,:) ) * zav_wave(:,:,:)
- z2d(:,:) = 0._wp
- DO jk = 2, jpkm1
- z2d(:,:) = z2d(:,:) + e3w(:,:,jk,Kmm) * z3d(:,:,jk) * wmask(:,:,jk)
- END DO
- z2d(:,:) = rho0 * z2d(:,:)
- CALL iom_put( "bflx_iwm", z3d )
+ ! Initialisation for iom_put
+ DO_2D( 0, 0, 0, 0 )
+ z3d(ji,jj,1) = 0._wp ; z3d(ji,jj,jpk) = 0._wp
+ END_2D
+ z3d( 1:nn_hls,:,:) = 0._wp ; z3d(:, 1:nn_hls,:) = 0._wp
+ z3d(jpi-nn_hls+1:jpi ,:,:) = 0._wp ; z3d(:,jpj-nn_hls+1: jpj,:) = 0._wp
+ z2d( 1:nn_hls,: ) = 0._wp ; z2d(:, 1:nn_hls ) = 0._wp
+ z2d(jpi-nn_hls+1:jpi ,: ) = 0._wp ; z2d(:,jpj-nn_hls+1: jpj ) = 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)
+ END_3D
+ DO_2D( 0, 0, 0, 0 )
+ z2d(ji,jj) = 0._wp
+ END_2D
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
+ z2d(ji,jj) = z2d(ji,jj) + e3w(ji,jj,jk,Kmm) * z3d(ji,jj,jk) * wmask(ji,jj,jk)
+ END_3D
+ DO_2D( 0, 0, 0, 0 )
+ z2d(ji,jj) = rho0 * z2d(ji,jj)
+ END_2D
+ CALL iom_put( "bflx_iwm", z3d )
CALL iom_put( "pcmap_iwm", z2d )
DEALLOCATE( z2d , z3d )
@@ -383,9 +420,24 @@
!! de Lavergne et al. in prep., 2017
!!----------------------------------------------------------------------
- INTEGER :: inum ! local integer
+ INTEGER :: ifpr ! dummy loop indices
+ INTEGER :: inum ! local integer
INTEGER :: ios
REAL(wp) :: zbot, zpyc, zcri ! local scalars
- !!
- NAMELIST/namzdf_iwm/ nn_zpyc, ln_mevar, ln_tsdiff
+ !
+ CHARACTER(len=256) :: cn_dir ! Root directory for location of ssr files
+ INTEGER, PARAMETER :: jpiwm = 5 ! maximum number of files to read
+ INTEGER, PARAMETER :: jp_mpb = 1
+ INTEGER, PARAMETER :: jp_mpp = 2
+ INTEGER, PARAMETER :: jp_mpc = 3
+ INTEGER, PARAMETER :: jp_dsb = 4
+ INTEGER, PARAMETER :: jp_dsc = 5
+ !
+ TYPE(FLD_N), DIMENSION(jpiwm) :: slf_iwm ! array of namelist informations
+ TYPE(FLD_N) :: sn_mpb, sn_mpp, sn_mpc ! informations about Mixing Power field to be read
+ TYPE(FLD_N) :: sn_dsb, sn_dsc ! informations about Decay Scale field to be read
+ TYPE(FLD ), DIMENSION(jpiwm) :: sf_iwm ! structure of input fields (file informations, fields read)
+ !
+ NAMELIST/namzdf_iwm/ nn_zpyc, ln_mevar, ln_tsdiff, &
+ & cn_dir, sn_mpb, sn_mpp, sn_mpc, sn_dsb, sn_dsc
!!----------------------------------------------------------------------
!
@@ -422,32 +474,36 @@
IF( zdf_iwm_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'zdf_iwm_init : unable to allocate iwm arrays' )
!
+ ! store namelist information in an array
+ slf_iwm(jp_mpb) = sn_mpb ; slf_iwm(jp_mpp) = sn_mpp ; slf_iwm(jp_mpc) = sn_mpc
+ 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) )
+ 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 definition (to be defined in namelist ?)
+ sf_iwm(jp_mpb)%fnow(:,:,1) = 1.e-6
+ sf_iwm(jp_mpp)%fnow(:,:,1) = 1.e-6
+ sf_iwm(jp_mpc)%fnow(:,:,1) = 1.e-10
+ sf_iwm(jp_dsb)%fnow(:,:,1) = 100.
+ sf_iwm(jp_dsc)%fnow(:,:,1) = 100.
+
! ! read necessary fields
- CALL iom_open('mixing_power_bot',inum) ! energy flux for high-mode wave breaking [W/m2]
- CALL iom_get (inum, jpdom_data, 'field', ebot_iwm, 1 )
- CALL iom_close(inum)
- !
- CALL iom_open('mixing_power_pyc',inum) ! energy flux for pynocline-intensified wave breaking [W/m2]
- CALL iom_get (inum, jpdom_data, 'field', epyc_iwm, 1 )
- CALL iom_close(inum)
- !
- CALL iom_open('mixing_power_cri',inum) ! energy flux for critical slope wave breaking [W/m2]
- CALL iom_get (inum, jpdom_data, 'field', ecri_iwm, 1 )
- CALL iom_close(inum)
- !
- CALL iom_open('decay_scale_bot',inum) ! spatially variable decay scale for high-mode wave breaking [m]
- CALL iom_get (inum, jpdom_data, 'field', hbot_iwm, 1 )
- CALL iom_close(inum)
- !
- CALL iom_open('decay_scale_cri',inum) ! spatially variable decay scale for critical slope wave breaking [m]
- CALL iom_get (inum, jpdom_data, 'field', hcri_iwm, 1 )
- CALL iom_close(inum)
-
- ebot_iwm(:,:) = ebot_iwm(:,:) * ssmask(:,:)
- epyc_iwm(:,:) = epyc_iwm(:,:) * ssmask(:,:)
- ecri_iwm(:,:) = ecri_iwm(:,:) * ssmask(:,:)
+ CALL fld_read( nit000, 1, sf_iwm )
+
+ ebot_iwm(:,:) = sf_iwm(1)%fnow(:,:,1) * ssmask(:,:) ! energy flux for high-mode wave breaking [W/m2]
+ epyc_iwm(:,:) = sf_iwm(2)%fnow(:,:,1) * ssmask(:,:) ! energy flux for pynocline-intensified wave breaking [W/m2]
+ ecri_iwm(:,:) = sf_iwm(3)%fnow(:,:,1) * ssmask(:,:) ! energy flux for critical slope wave breaking [W/m2]
+ hbot_iwm(:,:) = sf_iwm(4)%fnow(:,:,1) ! spatially variable decay scale for high-mode wave breaking [m]
+ hcri_iwm(:,:) = sf_iwm(5)%fnow(:,:,1) ! spatially variable decay scale for critical slope wave breaking [m]
zbot = glob_sum( 'zdfiwm', e1e2t(:,:) * ebot_iwm(:,:) )
zpyc = glob_sum( 'zdfiwm', e1e2t(:,:) * epyc_iwm(:,:) )
zcri = glob_sum( 'zdfiwm', e1e2t(:,:) * ecri_iwm(:,:) )
+
IF(lwp) THEN
WRITE(numout,*) ' High-mode wave-breaking energy: ', zbot * 1.e-12_wp, 'TW'
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/ZDF/zdfmxl.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/ZDF/zdfmxl.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/ZDF/zdfmxl.F90 (revision 13540)
@@ -38,4 +38,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -95,20 +96,21 @@
!
! w-level of the mixing and mixed layers
- nmln(:,:) = nlb10 ! Initialization to the number of w ocean point
- hmlp(:,:) = 0._wp ! here hmlp used as a dummy variable, integrating vertically N^2
- zN2_c = grav * rho_c * r1_rho0 ! convert density criteria into N^2 criteria
- DO_3D_11_11( nlb10, jpkm1 )
+ nmln(:,:) = nlb10 ! Initialization to the number of w ocean point
+ hmlp(:,:) = 0._wp ! here hmlp used as a dummy variable, integrating vertically N^2
+ zN2_c = grav * rho_c * r1_rho0 ! convert density criteria into N^2 criteria
+ DO_3D( 1, 1, 1, 1, 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)
+ 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
!
! w-level of the turbocline and mixing layer (iom_use)
- imld(:,:) = mbkt(:,:) + 1 ! Initialization to the number of w ocean point
- DO_3DS_11_11( jpkm1, nlb10, -1 )
+ imld(:,:) = mbkt(:,:) + 1 ! Initialization to the number of w ocean point
+ DO_3DS( 1, 1, 1, 1, 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 and mixed layers
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
iiki = imld(ji,jj)
iikn = nmln(ji,jj)
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/ZDF/zdfosm.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/ZDF/zdfosm.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/ZDF/zdfosm.F90 (revision 13540)
@@ -103,6 +103,8 @@
INTEGER :: idebug = 236
INTEGER :: jdebug = 228
+
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -298,5 +300,5 @@
zz0 = rn_abs ! surface equi-partition in 2-bands
zz1 = 1. - rn_abs
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
! Surface downward irradiance (so always +ve)
zrad0(ji,jj) = qsr(ji,jj) * r1_rho0_rcp
@@ -308,5 +310,5 @@
END_2D
! Turbulent surface fluxes and fluxes averaged over depth of the OSBL
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
zthermal = rab_n(ji,jj,1,jp_tem)
zbeta = rab_n(ji,jj,1,jp_sal)
@@ -335,5 +337,5 @@
! Assume constant La#=0.3
CASE(0)
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
zus_x = zcos_wind(ji,jj) * zustar(ji,jj) / 0.3**2
zus_y = zsin_wind(ji,jj) * zustar(ji,jj) / 0.3**2
@@ -343,5 +345,5 @@
! Assume Pierson-Moskovitz wind-wave spectrum
CASE(1)
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
! Use wind speed wndm included in sbc_oce module
zustke(ji,jj) = MAX ( 0.016 * wndm(ji,jj), 1.0e-8 )
@@ -351,5 +353,5 @@
CASE(2)
zfac = 2.0_wp * rpi / 16.0_wp
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
! The Langmur number from the ECMWF model appears to give La<0.3 for wind-driven seas.
! The coefficient 0.8 gives La=0.3 in this situation.
@@ -364,5 +366,5 @@
! Langmuir velocity scale (zwstrl), La # (zla)
! mixed scale (zvstr), convective velocity scale (zwstrc)
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
! Langmuir velocity scale (zwstrl), at T-point
zwstrl(ji,jj) = ( zustar(ji,jj) * zustar(ji,jj) * zustke(ji,jj) )**pthird
@@ -400,5 +402,5 @@
hbl(:,:) = MAX(hbl(:,:), gdepw(:,:,3,Kmm) )
ibld(:,:) = 3
- DO_3D_00_00( 4, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 4, jpkm1 )
IF ( hbl(ji,jj) >= gdepw(ji,jj,jk,Kmm) ) THEN
ibld(ji,jj) = MIN(mbkt(ji,jj), jk)
@@ -406,5 +408,5 @@
END_3D
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
zthermal = rab_n(ji,jj,1,jp_tem) !ideally use ibld not 1??
zbeta = rab_n(ji,jj,1,jp_sal)
@@ -476,5 +478,5 @@
zdhdt(:,:) = MIN(zdhdt(:,:), (zhbl_t(:,:) - hbl(:,:))/rn_Dt + ww(ji,jj,ibld(ji,jj))) ! adjustment to represent limiting by ocean bottom
- DO_3D_00_00( 4, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 4, jpkm1 )
IF ( zhbl_t(ji,jj) >= gdepw(ji,jj,jk,Kmm) ) THEN
ibld(ji,jj) = MIN(mbkt(ji,jj), jk)
@@ -485,5 +487,5 @@
! Step through model levels taking account of buoyancy change to determine the effect on dhdt
!
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
IF ( ibld(ji,jj) - imld(ji,jj) > 1 ) THEN
!
@@ -503,5 +505,6 @@
& - zbeta * ( zs_bl(ji,jj) - ts(ji,jj,jm,jp_sal,Kmm) ) ), 0.0 ) + zvel_max
- zhbl_s = zhbl_s + MIN( - zwb_ent(ji,jj) / zdb * rn_Dt / FLOAT(ibld(ji,jj)-imld(ji,jj) ), e3w(ji,jj,jk,Kmm) )
+ zhbl_s = zhbl_s + MIN( - zwb_ent(ji,jj) / zdb * rn_Dt / FLOAT(ibld(ji,jj)-imld(ji,jj) ), &
+ & e3w(ji,jj,jk,Kmm) )
zhbl_s = MIN(zhbl_s, ht(ji,jj))
@@ -549,5 +552,5 @@
! Consider later combining this into the loop above and looking for columns
! where the index for base of the boundary layer have changed
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
zthermal = rab_n(ji,jj,1,jp_tem) !ideally use ibld not 1??
zbeta = rab_n(ji,jj,1,jp_sal)
@@ -594,5 +597,6 @@
zwb_ent(ji,jj) = 0._wp
ENDIF
- inhml = MAX( INT( zari * zhbl(ji,jj) / e3t(ji,jj,ibld(ji,jj),Kmm) ) , 1 )
+ inhml = MAX( INT( zari * zhbl(ji,jj) &
+ & / e3t(ji,jj,ibld(ji,jj),Kmm) ), 1 )
imld(ji,jj) = MAX( ibld(ji,jj) - inhml, 1)
zhml(ji,jj) = gdepw(ji,jj,imld(ji,jj),Kmm)
@@ -610,5 +614,6 @@
zari = MIN( 4.5 * ( zvstr(ji,jj)**2 ) &
& / ( zdb_bl(ji,jj) * zhbl(ji,jj) ) + 0.01 , 0.2 )
- inhml = MAX( INT( zari * zhbl(ji,jj) / e3t(ji,jj,ibld(ji,jj),Kmm) ) , 1 )
+ inhml = MAX( INT( zari * zhbl(ji,jj) &
+ & / e3t(ji,jj,ibld(ji,jj),Kmm) ), 1 )
imld(ji,jj) = MAX( ibld(ji,jj) - inhml, 1)
zhml(ji,jj) = gdepw(ji,jj,imld(ji,jj),Kmm)
@@ -630,5 +635,5 @@
! Average over the depth of the mixed layer in the convective boundary layer
! Also calculate entrainment fluxes for temperature and salinity
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
zthermal = rab_n(ji,jj,1,jp_tem) !ideally use ibld not 1??
zbeta = rab_n(ji,jj,1,jp_sal)
@@ -700,5 +705,5 @@
!
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
ztemp = zu_ml(ji,jj)
zu_ml(ji,jj) = zu_ml(ji,jj) * zcos_wind(ji,jj) + zv_ml(ji,jj) * zsin_wind(ji,jj)
@@ -718,5 +723,5 @@
zuw_bse = 0._wp
zvw_bse = 0._wp
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
IF ( lconv(ji,jj) ) THEN
@@ -735,5 +740,5 @@
!<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
!
IF ( lconv (ji,jj) ) THEN
@@ -783,5 +788,5 @@
END_2D
!
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
!
IF ( lconv (ji,jj) ) THEN
@@ -827,5 +832,5 @@
! zvisml_sc = zwstrl * zhbl * EXP ( -( zhol / 0.183_wp )**2 )
! ENDWHERE
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
IF ( lconv(ji,jj) ) THEN
zdifml_sc(ji,jj) = zhml(ji,jj) * ( zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird
@@ -841,5 +846,5 @@
END_2D
!
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
IF ( lconv(ji,jj) ) THEN
DO jk = 2, imld(ji,jj) ! mixed layer diffusivity
@@ -891,5 +896,5 @@
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
IF ( lconv(ji,jj) ) THEN
DO jk = 2, imld(ji,jj)
@@ -924,5 +929,5 @@
ENDWHERE
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
IF ( lconv(ji,jj) ) THEN
DO jk = 2, imld(ji,jj)
@@ -956,5 +961,5 @@
ENDWHERE
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
IF (lconv(ji,jj) ) THEN
DO jk = 2, imld(ji,jj)
@@ -988,5 +993,5 @@
ENDWHERE
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
IF ( lconv(ji,jj) ) THEN
DO jk = 2 , imld(ji,jj)
@@ -1016,5 +1021,5 @@
ENDWHERE
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
IF ( lconv(ji,jj) ) THEN
DO jk = 2, imld(ji,jj)
@@ -1053,5 +1058,5 @@
ENDWHERE
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
IF ( lconv(ji,jj) ) THEN
DO jk = 2, imld(ji,jj)
@@ -1088,5 +1093,5 @@
! Make surface forced velocity non-gradient terms go to zero at the base of the mixed layer.
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
IF ( lconv(ji,jj) ) THEN
DO jk = 2, ibld(ji,jj)
@@ -1117,5 +1122,5 @@
! Temporary fix to avoid instabilities when zdb_bl becomes very very small
zsc_uw_1 = 0._wp ! 50.0 * zla**(8.0/3.0) * zustar**2 * zhbl / ( zdb_bl + epsln )
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
DO jk= 2, ibld(ji,jj)
znd = gdepw(ji,jj,jk,Kmm) / zhbl(ji,jj)
@@ -1130,5 +1135,5 @@
! Entrainment contribution.
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
IF ( lconv(ji,jj) ) THEN
DO jk = 1, imld(ji,jj) - 1
@@ -1165,5 +1170,5 @@
! rotate non-gradient velocity terms back to model reference frame
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
DO jk = 2, ibld(ji,jj)
ztemp = ghamu(ji,jj,jk)
@@ -1179,5 +1184,5 @@
! KPP-style Ri# mixing
IF( ln_kpprimix) THEN
- DO_3D_10_10( 2, jpkm1 )
+ DO_3D( 1, 0, 1, 0, 2, jpkm1 ) !* Shear production at uw- and vw-points (energy conserving form)
z3du(ji,jj,jk) = 0.5 * ( uu(ji,jj,jk-1,Kmm) - uu(ji ,jj,jk,Kmm) ) &
& * ( uu(ji,jj,jk-1,Kbb) - uu(ji ,jj,jk,Kbb) ) * wumask(ji,jj,jk) &
@@ -1188,5 +1193,5 @@
END_3D
!
- DO_3D_00_00( 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
! ! shear prod. at w-point weightened by mask
zesh2 = ( z3du(ji-1,jj,jk) + z3du(ji,jj,jk) ) / MAX( 1._wp , umask(ji-1,jj,jk) + umask(ji,jj,jk) ) &
@@ -1199,5 +1204,5 @@
END_3D
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
DO jk = ibld(ji,jj) + 1, jpkm1
zdiffut(ji,jj,jk) = zrimix(ji,jj,jk)*rn_difri
@@ -1210,5 +1215,5 @@
! KPP-style set diffusivity large if unstable below BL
IF( ln_convmix) THEN
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
DO jk = ibld(ji,jj) + 1, jpkm1
IF( MIN( rn2(ji,jj,jk), rn2b(ji,jj,jk) ) <= -1.e-12 ) zdiffut(ji,jj,jk) = rn_difconv
@@ -1218,16 +1223,16 @@
! Lateral boundary conditions on zvicos (sign unchanged), needed to caclulate viscosities on u and v grids
- CALL lbc_lnk( 'zdfosm', zviscos(:,:,:), 'W', 1. )
+ CALL lbc_lnk( 'zdfosm', zviscos(:,:,:), 'W', 1.0_wp )
! GN 25/8: need to change tmask --> wmask
- DO_3D_00_00( 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
! Lateral boundary conditions on ghamu and ghamv, currently on W-grid (sign unchanged), needed to caclulate gham[uv] on u and v grids
- CALL lbc_lnk_multi( 'zdfosm', p_avt, 'W', 1. , p_avm, 'W', 1., &
- & ghamu, 'W', 1. , ghamv, 'W', 1. )
- DO_3D_00_00( 2, jpkm1 )
+ CALL lbc_lnk_multi( 'zdfosm', p_avt, 'W', 1.0_wp , p_avm, 'W', 1.0_wp, &
+ & ghamu, 'W', 1.0_wp , ghamv, 'W', 1.0_wp )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
ghamu(ji,jj,jk) = ( ghamu(ji,jj,jk) + ghamu(ji+1,jj,jk) ) &
& / MAX( 1., tmask(ji,jj,jk) + tmask (ji + 1,jj,jk) ) * umask(ji,jj,jk)
@@ -1241,6 +1246,6 @@
! Lateral boundary conditions on final outputs for gham[ts], on W-grid (sign unchanged)
! Lateral boundary conditions on final outputs for gham[uv], on [UV]-grid (sign unchanged)
- CALL lbc_lnk_multi( 'zdfosm', ghamt, 'W', 1. , ghams, 'W', 1., &
- & ghamu, 'U', 1. , ghamv, 'V', 1. )
+ CALL lbc_lnk_multi( 'zdfosm', ghamt, 'W', 1.0_wp , ghams, 'W', 1.0_wp, &
+ & ghamu, 'U', 1.0_wp , ghamv, 'V', 1.0_wp )
IF(ln_dia_osm) THEN
@@ -1282,5 +1287,5 @@
END IF
! Lateral boundary conditions on p_avt (sign unchanged)
- CALL lbc_lnk( 'zdfosm', p_avt(:,:,:), 'W', 1. )
+ CALL lbc_lnk( 'zdfosm', p_avt(:,:,:), 'W', 1.0_wp )
!
END SUBROUTINE zdf_osm
@@ -1343,4 +1348,12 @@
ENDIF
+
+ ! ! Check wave coupling settings !
+ ! ! Further work needed - see ticket #2447 !
+ IF( nn_osm_wave == 2 ) THEN
+ IF (.NOT. ( ln_wave .AND. ln_sdw )) &
+ & CALL ctl_stop( 'zdf_osm_init : ln_zdfosm and nn_osm_wave=2, ln_wave and ln_sdw must be true' )
+ END IF
+
! ! allocate zdfosm arrays
IF( zdf_osm_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'zdf_osm_init : unable to allocate arrays' )
@@ -1382,5 +1395,5 @@
etmean(:,:,:) = 0.e0
- DO_3D_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
etmean(ji,jj,jk) = tmask(ji,jj,jk) &
& / MAX( 1., umask(ji-1,jj ,jk) + umask(ji,jj,jk) &
@@ -1396,5 +1409,5 @@
etmean(:,:,:) = 0.e0
- DO_3D_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
etmean(ji,jj,jk) = tmask(ji, jj,jk) &
& / MAX( 1., 2.* tmask(ji,jj,jk) &
@@ -1461,5 +1474,5 @@
id1 = iom_varid( numror, 'wn' , ldstop = .FALSE. )
IF( id1 > 0 ) THEN ! 'wn' exists; read
- CALL iom_get( numror, jpdom_autoglo, 'wn', ww, ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'wn', ww, ldxios = lrxios )
WRITE(numout,*) ' ===>>>> : ww read from restart file'
ELSE
@@ -1470,6 +1483,6 @@
id2 = iom_varid( numror, 'hbli' , ldstop = .FALSE. )
IF( id1 > 0 .AND. id2 > 0) THEN ! 'hbl' exists; read and return
- CALL iom_get( numror, jpdom_autoglo, 'hbl' , hbl , ldxios = lrxios )
- CALL iom_get( numror, jpdom_autoglo, 'hbli', hbli, ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'hbl' , hbl , ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'hbli', hbli, ldxios = lrxios )
WRITE(numout,*) ' ===>>>> : hbl & hbli read from restart file'
RETURN
@@ -1503,5 +1516,5 @@
!
hbl(:,:) = 0._wp ! here hbl used as a dummy variable, integrating vertically N^2
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 ) ! Mixed layer level: w-level
ikt = mbkt(ji,jj)
hbl(ji,jj) = hbl(ji,jj) + MAX( rn2(ji,jj,jk) , 0._wp ) * e3w(ji,jj,jk,Kmm)
@@ -1509,5 +1522,5 @@
END_3D
!
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
iiki = imld_rst(ji,jj)
hbl (ji,jj) = gdepw(ji,jj,iiki ,Kmm) * ssmask(ji,jj) ! Turbocline depth
@@ -1548,5 +1561,5 @@
! add non-local temperature and salinity flux
- DO_3D_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
pts(ji,jj,jk,jp_tem,Krhs) = pts(ji,jj,jk,jp_tem,Krhs) &
& - ( ghamt(ji,jj,jk ) &
@@ -1616,5 +1629,5 @@
!code saving tracer trends removed, replace with trdmxl_oce
- DO_3D_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! add non-local u and v fluxes
puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) &
& - ( ghamu(ji,jj,jk ) &
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/ZDF/zdfphy.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/ZDF/zdfphy.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/ZDF/zdfphy.F90 (revision 13540)
@@ -28,4 +28,5 @@
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
#if defined key_agrif
USE agrif_oce_interp ! interpavm
@@ -253,4 +254,14 @@
ENDIF
!
+#if defined key_si3
+ IF ( ln_drgice_imp) THEN
+ IF ( ln_isfcav ) THEN
+ rCdU_top(:,:) = rCdU_top(:,:) + ssmask(:,:) * tmask(:,:,1) * rCdU_ice(:,:)
+ ELSE
+ rCdU_top(:,:) = rCdU_ice(:,:)
+ ENDIF
+ ENDIF
+#endif
+ !
! !== Kz from chosen turbulent closure ==! (avm_k, avt_k)
!
@@ -302,13 +313,13 @@
! !* Lateral boundary conditions (sign unchanged)
IF( l_zdfsh2 ) THEN
- CALL lbc_lnk_multi( 'zdfphy', avm_k, 'W', 1. , avt_k, 'W', 1., &
- & avm , 'W', 1. , avt , 'W', 1. , avs , 'W', 1. )
+ CALL lbc_lnk_multi( '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_multi( 'zdfphy', avm , 'W', 1. , avt , 'W', 1. , avs , 'W', 1. )
+ CALL lbc_lnk_multi( 'zdfphy', avm , 'W', 1.0_wp , avt , 'W', 1.0_wp , avs , 'W', 1.0_wp )
ENDIF
!
IF( l_zdfdrg ) THEN ! drag have been updated (non-linear cases)
- IF( ln_isfcav ) THEN ; CALL lbc_lnk_multi( 'zdfphy', rCdU_top, 'T', 1. , rCdU_bot, 'T', 1. ) ! top & bot drag
- ELSE ; CALL lbc_lnk ( 'zdfphy', rCdU_bot, 'T', 1. ) ! bottom drag only
+ IF( ln_isfcav ) THEN ; CALL lbc_lnk_multi( '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
ENDIF
ENDIF
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/ZDF/zdfric.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/ZDF/zdfric.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/ZDF/zdfric.F90 (revision 13540)
@@ -160,5 +160,5 @@
!
! !== avm and avt = F(Richardson number) ==!
- DO_3D_10_10( 2, jpkm1 )
+ DO_3D( 1, 0, 1, 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
@@ -173,10 +173,10 @@
IF( ln_mldw ) THEN !== set a minimum value in the Ekman layer ==!
!
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 ) !* Ekman depth
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_00_00( 2, jpkm1 )
+ 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)
@@ -214,6 +214,6 @@
!
IF( MIN( id1, id2 ) > 0 ) THEN ! restart exists => read it
- CALL iom_get( numror, jpdom_autoglo, 'avt_k', avt_k, ldxios = lrxios )
- CALL iom_get( numror, jpdom_autoglo, 'avm_k', avm_k, ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'avt_k', avt_k, ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'avm_k', avm_k, ldxios = lrxios )
ENDIF
ENDIF
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/ZDF/zdfsh2.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/ZDF/zdfsh2.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/ZDF/zdfsh2.F90 (revision 13540)
@@ -24,4 +24,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -59,13 +60,17 @@
!
DO jk = 2, jpkm1
- DO_2D_10_10
+ 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) ) / ( e3uw(ji,jj,jk,Kmm) * e3uw(ji,jj,jk,Kbb) ) * wumask(ji,jj,jk)
+ & * ( uu(ji,jj,jk-1,Kbb) - uu(ji,jj,jk,Kbb) ) &
+ & / ( e3uw(ji,jj,jk ,Kmm) * e3uw(ji,jj,jk,Kbb) ) &
+ & * wumask(ji,jj,jk)
zsh2v(ji,jj) = ( p_avm(ji,jj+1,jk) + p_avm(ji,jj,jk) ) &
& * ( vv(ji,jj,jk-1,Kmm) - vv(ji,jj,jk,Kmm) ) &
- & * ( vv(ji,jj,jk-1,Kbb) - vv(ji,jj,jk,Kbb) ) / ( e3vw(ji,jj,jk,Kmm) * e3vw(ji,jj,jk,Kbb) ) * wvmask(ji,jj,jk)
+ & * ( vv(ji,jj,jk-1,Kbb) - vv(ji,jj,jk,Kbb) ) &
+ & / ( e3vw(ji,jj,jk ,Kmm) * e3vw(ji,jj,jk,Kbb) ) &
+ & * wvmask(ji,jj,jk)
END_2D
- DO_2D_00_00
+ 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) ) )
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/ZDF/zdfswm.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/ZDF/zdfswm.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/ZDF/zdfswm.F90 (revision 13540)
@@ -63,5 +63,5 @@
!
zcoef = 1._wp * 0.353553_wp
- DO_3D_00_00( 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)
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/ZDF/zdftke.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/ZDF/zdftke.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/ZDF/zdftke.F90 (revision 13540)
@@ -28,5 +28,5 @@
!! 3.6 ! 2014-11 (P. Mathiot) add ice shelf capability
!! 4.0 ! 2017-04 (G. Madec) remove CPP ddm key & avm at t-point only
- !! - ! 2017-05 (G. Madec) add top/bottom friction as boundary condition (ln_drg)
+ !! - ! 2017-05 (G. Madec) add top/bottom friction as boundary condition
!!----------------------------------------------------------------------
@@ -45,4 +45,10 @@
USE zdfdrg ! vertical physics: top/bottom drag coef.
USE zdfmxl ! vertical physics: mixed layer
+#if defined key_si3
+ USE ice, ONLY: hm_i, h_i
+#endif
+#if defined key_cice
+ USE sbc_ice, ONLY: h_i
+#endif
!
USE in_out_manager ! I/O manager
@@ -62,4 +68,6 @@
! !!** Namelist namzdf_tke **
LOGICAL :: ln_mxl0 ! mixing length scale surface value as function of wind stress or not
+ INTEGER :: nn_mxlice ! type of scaling under sea-ice (=0/1/2/3)
+ REAL(wp) :: rn_mxlice ! ice thickness value when scaling under sea-ice
INTEGER :: nn_mxl ! type of mixing length (=0/1/2/3)
REAL(wp) :: rn_mxl0 ! surface min value of mixing length (kappa*z_o=0.4*0.1 m) [m]
@@ -71,11 +79,10 @@
REAL(wp) :: rn_emin0 ! surface minimum value of tke [m2/s2]
REAL(wp) :: rn_bshear ! background shear (>0) currently a numerical threshold (do not change it)
- LOGICAL :: ln_drg ! top/bottom friction forcing flag
INTEGER :: nn_etau ! type of depth penetration of surface tke (=0/1/2/3)
INTEGER :: nn_htau ! type of tke profile of penetration (=0/1)
REAL(wp) :: rn_efr ! fraction of TKE surface value which penetrates in the ocean
- REAL(wp) :: rn_eice ! =0 ON below sea-ice, =4 OFF when ice fraction > 1/4
LOGICAL :: ln_lc ! Langmuir cells (LC) as a source term of TKE or not
REAL(wp) :: rn_lc ! coef to compute vertical velocity of Langmuir cells
+ INTEGER :: nn_eice ! attenutaion of langmuir & surface wave breaking under ice (=0/1/2/3)
REAL(wp) :: ri_cri ! critic Richardson number (deduced from rn_ediff and rn_ediss values)
@@ -90,4 +97,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -191,36 +199,44 @@
REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: p_avm, p_avt ! vertical eddy viscosity & diffusivity (w-points)
!
- INTEGER :: ji, jj, jk ! dummy loop arguments
+ INTEGER :: ji, jj, jk ! dummy loop arguments
REAL(wp) :: zetop, zebot, zmsku, zmskv ! local scalars
REAL(wp) :: zrhoa = 1.22 ! Air density kg/m3
REAL(wp) :: zcdrag = 1.5e-3 ! drag coefficient
- REAL(wp) :: zbbrau, zri ! local scalars
- REAL(wp) :: zfact1, zfact2, zfact3 ! - -
- REAL(wp) :: ztx2 , zty2 , zcof ! - -
- REAL(wp) :: ztau , zdif ! - -
- REAL(wp) :: zus , zwlc , zind ! - -
- REAL(wp) :: zzd_up, zzd_lw ! - -
+ REAL(wp) :: zbbrau, zbbirau, zri ! local scalars
+ REAL(wp) :: zfact1, zfact2, zfact3 ! - -
+ REAL(wp) :: ztx2 , zty2 , zcof ! - -
+ REAL(wp) :: ztau , zdif ! - -
+ REAL(wp) :: zus , zwlc , zind ! - -
+ REAL(wp) :: zzd_up, zzd_lw ! - -
INTEGER , DIMENSION(jpi,jpj) :: imlc
- REAL(wp), DIMENSION(jpi,jpj) :: zhlc, zfr_i
+ REAL(wp), DIMENSION(jpi,jpj) :: zice_fra, zhlc, zus3
REAL(wp), DIMENSION(jpi,jpj,jpk) :: zpelc, zdiag, zd_up, zd_lw
!!--------------------------------------------------------------------
!
- zbbrau = rn_ebb / rho0 ! Local constant initialisation
- zfact1 = -.5_wp * rn_Dt
- zfact2 = 1.5_wp * rn_Dt * rn_ediss
- zfact3 = 0.5_wp * rn_ediss
+ zbbrau = rn_ebb / rho0 ! Local constant initialisation
+ zbbirau = 3.75_wp / rho0
+ zfact1 = -.5_wp * rn_Dt
+ zfact2 = 1.5_wp * rn_Dt * rn_ediss
+ zfact3 = 0.5_wp * rn_ediss
+ !
+ ! 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(:,:) * 10._wp )
+ CASE( 2 ) ; zice_fra(:,:) = fr_i(:,:)
+ CASE( 3 ) ; zice_fra(:,:) = MIN( 4._wp * fr_i(:,:) , 1._wp )
+ END SELECT
!
! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
! ! Surface/top/bottom boundary condition on tke
! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
-
- DO_2D_00_00
+ !
+ DO_2D( 0, 0, 0, 0 ) ! en(1) = rn_ebb taum / rau0 (min value rn_emin0)
+!! clem: this should be the right formulation but it makes the model unstable unless drags are calculated implicitly
+!! one way around would be to increase zbbirau
+!! en(ji,jj,1) = MAX( rn_emin0, ( ( 1._wp - fr_i(ji,jj) ) * zbbrau + &
+!! & fr_i(ji,jj) * zbbirau ) * taum(ji,jj) ) * tmask(ji,jj,1)
en(ji,jj,1) = MAX( rn_emin0, zbbrau * taum(ji,jj) ) * tmask(ji,jj,1)
END_2D
- IF ( ln_isfcav ) THEN
- DO_2D_00_00
- en(ji,jj,mikt(ji,jj)) = rn_emin * tmask(ji,jj,1)
- END_2D
- ENDIF
!
! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
@@ -232,7 +248,7 @@
! Note that stress averaged is done using an wet-only calculation of u and v at t-point like in zdfsh2
!
- IF( ln_drg ) THEN !== friction used as top/bottom boundary condition on TKE
- !
- DO_2D_00_00
+ IF( .NOT.ln_drg_OFF ) THEN !== friction used as top/bottom boundary condition on TKE
+ !
+ 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)) )
@@ -242,6 +258,6 @@
en(ji,jj,mbkt(ji,jj)+1) = MAX( zebot, rn_emin ) * ssmask(ji,jj)
END_2D
- IF( ln_isfcav ) THEN ! top friction
- DO_2D_00_00
+ IF( ln_isfcav ) THEN
+ 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)) )
@@ -249,5 +265,7 @@
zetop = - 0.001875_wp * rCdU_top(ji,jj) * SQRT( ( zmsku*( uu(ji,jj,mikt(ji,jj),Kbb)+uu(ji-1,jj,mikt(ji,jj),Kbb) ) )**2 &
& + ( zmskv*( vv(ji,jj,mikt(ji,jj),Kbb)+vv(ji,jj-1,mikt(ji,jj),Kbb) ) )**2 )
- en(ji,jj,mikt(ji,jj)) = MAX( zetop, rn_emin ) * (1._wp - tmask(ji,jj,1)) ! masked at ocean surface
+ ! (1._wp - tmask(ji,jj,1)) * ssmask(ji,jj) = 1 where ice shelves are present
+ en(ji,jj,mikt(ji,jj)) = en(ji,jj,1) * tmask(ji,jj,1) &
+ & + MAX( zetop, rn_emin ) * (1._wp - tmask(ji,jj,1)) * ssmask(ji,jj)
END_2D
ENDIF
@@ -262,31 +280,30 @@
zpelc(:,:,1) = MAX( rn2b(:,:,1), 0._wp ) * gdepw(:,:,1,Kmm) * e3w(:,:,1,Kmm)
DO jk = 2, jpk
- zpelc(:,:,jk) = zpelc(:,:,jk-1) + MAX( rn2b(:,:,jk), 0._wp ) * gdepw(:,:,jk,Kmm) * e3w(:,:,jk,Kmm)
+ zpelc(:,:,jk) = zpelc(:,:,jk-1) + &
+ & MAX( rn2b(:,:,jk), 0._wp ) * gdepw(:,:,jk,Kmm) * e3w(:,:,jk,Kmm)
END DO
! !* finite Langmuir Circulation depth
zcof = 0.5 * 0.016 * 0.016 / ( zrhoa * zcdrag )
imlc(:,:) = mbkt(:,:) + 1 ! Initialization to the number of w ocean point (=2 over land)
- DO_3DS_11_11( jpkm1, 2, -1 )
- zus = zcof * taum(ji,jj)
+ DO_3DS( 1, 1, 1, 1, jpkm1, 2, -1 ) ! Last w-level at which zpelc>=0.5*us*us
+ zus = zcof * taum(ji,jj) ! with us=0.016*wind(starting from jpk-1)
IF( zpelc(ji,jj,jk) > zus ) imlc(ji,jj) = jk
END_3D
! ! finite LC depth
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
zhlc(ji,jj) = gdepw(ji,jj,imlc(ji,jj),Kmm)
END_2D
zcof = 0.016 / SQRT( zrhoa * zcdrag )
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
zus = zcof * SQRT( taum(ji,jj) ) ! Stokes drift
- zfr_i(ji,jj) = ( 1._wp - 4._wp * fr_i(ji,jj) ) * zus * zus * zus * tmask(ji,jj,1) ! zus > 0. ok
- IF (zfr_i(ji,jj) < 0. ) zfr_i(ji,jj) = 0.
+ 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_00_00( 2, jpkm1 )
- IF ( zfr_i(ji,jj) /= 0. ) THEN
- ! vertical velocity due to LC
+ 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
- zwlc = rn_lc * SIN( rpi * gdepw(ji,jj,jk,Kmm) / zhlc(ji,jj) ) ! warning: optimization: zus^3 is in zfr_i
+ zwlc = rn_lc * SIN( rpi * gdepw(ji,jj,jk,Kmm) / zhlc(ji,jj) )
! ! TKE Langmuir circulation source term
- en(ji,jj,jk) = en(ji,jj,jk) + rn_Dt * zfr_i(ji,jj) * ( zwlc * zwlc * zwlc ) / zhlc(ji,jj)
+ en(ji,jj,jk) = en(ji,jj,jk) + rn_Dt * zus3(ji,jj) * ( zwlc * zwlc * zwlc ) / zhlc(ji,jj)
ENDIF
ENDIF
@@ -302,8 +319,12 @@
! ! zdiag : diagonal zd_up : upper diagonal zd_lw : lower diagonal
!
- IF( nn_pdl == 1 ) THEN !* Prandtl number = F( Ri )
- DO_3D_00_00( 2, jpkm1 )
+ IF( nn_pdl == 1 ) THEN !* Prandtl number = F( Ri )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
! ! local Richardson number
- zri = MAX( rn2b(ji,jj,jk), 0._wp ) * p_avm(ji,jj,jk) / ( p_sh2(ji,jj,jk) + rn_bshear )
+ IF (rn2b(ji,jj,jk) <= 0.0_wp) then
+ zri = 0.0_wp
+ ELSE
+ zri = rn2b(ji,jj,jk) * p_avm(ji,jj,jk) / ( p_sh2(ji,jj,jk) + rn_bshear )
+ ENDIF
! ! inverse of Prandtl number
apdlr(ji,jj,jk) = MAX( 0.1_wp, ri_cri / MAX( ri_cri , zri ) )
@@ -311,5 +332,5 @@
ENDIF
!
- DO_3D_00_00( 2, jpkm1 )
+ 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
@@ -331,20 +352,20 @@
END_3D
! !* Matrix inversion from level 2 (tke prescribed at level 1)
- DO_3D_00_00( 3, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 3, 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_2D_00_00
+ DO_2D( 0, 0, 0, 0 ) ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1
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_00_00( 3, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 3, 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_00_00
+ 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_00_00( 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_00_00( 2, jpkm1 )
+ 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
@@ -355,19 +376,20 @@
!!gm BUG : in the exp remove the depth of ssh !!!
!!gm i.e. use gde3w in argument (gdepw(:,:,:,Kmm))
-
-
+ !
+ ! 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_00_00( 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.,1._wp - rn_eice *fr_i(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1)
+ & * 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_00_00
+ 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.,1._wp - rn_eice *fr_i(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1)
+ & * 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_00_00( 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
ztx2 = utau(ji-1,jj ) + utau(ji,jj)
zty2 = vtau(ji ,jj-1) + vtau(ji,jj)
@@ -376,5 +398,5 @@
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) ) &
- & * MAX(0.,1._wp - rn_eice *fr_i(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1)
+ & * MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1)
END_3D
ENDIF
@@ -425,5 +447,5 @@
REAL(wp) :: zrn2, zraug, zcoef, zav ! local scalars
REAL(wp) :: zdku, zdkv, zsqen ! - -
- REAL(wp) :: zemxl, zemlm, zemlp ! - -
+ REAL(wp) :: zemxl, zemlm, zemlp, zmaxice ! - -
REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmxlm, zmxld ! 3D workspace
!!--------------------------------------------------------------------
@@ -438,15 +460,58 @@
zmxlm(:,:,:) = rmxl_min
zmxld(:,:,:) = rmxl_min
- !
- IF( ln_mxl0 ) THEN ! surface mixing length = F(stress) : l=vkarmn*2.e5*taum/(rho0*g)
+ !
+ IF( ln_mxl0 ) THEN ! surface mixing length = F(stress) : l=vkarmn*2.e5*taum/(rho0*g)
+ !
zraug = vkarmn * 2.e5_wp / ( rho0 * grav )
- DO_2D_00_00
- zmxlm(ji,jj,1) = MAX( rn_mxl0, zraug * taum(ji,jj) * tmask(ji,jj,1) )
+#if ! defined key_si3 && ! defined key_cice
+ DO_2D( 0, 0, 0, 0 ) ! No sea-ice
+ zmxlm(ji,jj,1) = zraug * taum(ji,jj) * tmask(ji,jj,1)
END_2D
- ELSE
+#else
+ SELECT CASE( nn_mxlice ) ! Type of scaling under sea-ice
+ !
+ CASE( 0 ) ! No scaling under sea-ice
+ 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( 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( 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)
+#elif defined key_cice
+ 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)
+#endif
+ END_2D
+ !
+ CASE( 3 ) ! scaling with max sea-ice thickness
+ 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)
+ END_2D
+ !
+ END SELECT
+#endif
+ !
+ DO_2D( 0, 0, 0, 0 )
+ zmxlm(ji,jj,1) = MAX( rn_mxl0, zmxlm(ji,jj,1) )
+ END_2D
+ !
+ ELSE
zmxlm(:,:,1) = rn_mxl0
ENDIF
- !
- DO_3D_00_00( 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 ) )
@@ -463,14 +528,16 @@
! where wmask = 0 set zmxlm == e3w(:,:,:,Kmm)
CASE ( 0 ) ! bounded by the distance to surface and bottom
- DO_3D_00_00( 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)
- zmxlm(ji,jj,jk) = zemxl * wmask(ji,jj,jk) + MIN( zmxlm(ji,jj,jk) , e3w(ji,jj,jk,Kmm) ) * (1 - wmask(ji,jj,jk))
- zmxld(ji,jj,jk) = zemxl * wmask(ji,jj,jk) + MIN( zmxlm(ji,jj,jk) , e3w(ji,jj,jk,Kmm) ) * (1 - wmask(ji,jj,jk))
+ zmxlm(ji,jj,jk) = zemxl * wmask(ji,jj,jk) &
+ & + MIN( zmxlm(ji,jj,jk) , e3w(ji,jj,jk,Kmm) ) * (1 - wmask(ji,jj,jk))
+ zmxld(ji,jj,jk) = zemxl * wmask(ji,jj,jk) &
+ & + MIN( zmxlm(ji,jj,jk) , e3w(ji,jj,jk,Kmm) ) * (1 - wmask(ji,jj,jk))
END_3D
!
CASE ( 1 ) ! bounded by the vertical scale factor
- DO_3D_00_00( 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
@@ -479,8 +546,9 @@
!
CASE ( 2 ) ! |dk[xml]| bounded by e3t :
- DO_3D_00_00( 2, jpkm1 )
- zmxlm(ji,jj,jk) = MIN( zmxlm(ji,jj,jk-1) + e3t(ji,jj,jk-1,Kmm), zmxlm(ji,jj,jk) )
- END_3D
- DO_3DS_00_00( jpkm1, 2, -1 )
+ 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( 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
@@ -489,11 +557,13 @@
!
CASE ( 3 ) ! lup and ldown, |dk[xml]| bounded by e3t :
- DO_3D_00_00( 2, jpkm1 )
- zmxld(ji,jj,jk) = MIN( zmxld(ji,jj,jk-1) + e3t(ji,jj,jk-1,Kmm), zmxlm(ji,jj,jk) )
- END_3D
- DO_3DS_00_00( jpkm1, 2, -1 )
- zmxlm(ji,jj,jk) = MIN( zmxlm(ji,jj,jk+1) + e3t(ji,jj,jk+1,Kmm), zmxlm(ji,jj,jk) )
- END_3D
- DO_3D_00_00( 2, jpkm1 )
+ 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( 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( 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) )
@@ -507,5 +577,5 @@
! ! Vertical eddy viscosity and diffusivity (avm and avt)
! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
- DO_3D_00_00( 1, jpkm1 )
+ 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
@@ -516,7 +586,7 @@
!
!
- IF( nn_pdl == 1 ) THEN !* Prandtl number case: update avt
- DO_3D_00_00( 2, jpkm1 )
- p_avt(ji,jj,jk) = MAX( apdlr(ji,jj,jk) * p_avt(ji,jj,jk), avtb_2d(ji,jj) * avtb(jk) ) * tmask(ji,jj,jk)
+ IF( nn_pdl == 1 ) THEN !* Prandtl number case: update avt
+ 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
@@ -550,8 +620,9 @@
INTEGER :: ios
!!
- NAMELIST/namzdf_tke/ rn_ediff, rn_ediss , rn_ebb , rn_emin , &
- & rn_emin0, rn_bshear, nn_mxl , ln_mxl0 , &
- & rn_mxl0 , nn_pdl , ln_drg , ln_lc , rn_lc, &
- & nn_etau , nn_htau , rn_efr , rn_eice
+ NAMELIST/namzdf_tke/ rn_ediff, rn_ediss , rn_ebb , rn_emin , &
+ & rn_emin0, rn_bshear, nn_mxl , ln_mxl0 , &
+ & rn_mxl0 , nn_mxlice, rn_mxlice, &
+ & nn_pdl , ln_lc , rn_lc , &
+ & nn_etau , nn_htau , rn_efr , nn_eice
!!----------------------------------------------------------------------
!
@@ -580,5 +651,17 @@
WRITE(numout,*) ' surface mixing length = F(stress) or not ln_mxl0 = ', ln_mxl0
WRITE(numout,*) ' surface mixing length minimum value rn_mxl0 = ', rn_mxl0
- WRITE(numout,*) ' top/bottom friction forcing flag ln_drg = ', ln_drg
+ IF( ln_mxl0 ) THEN
+ WRITE(numout,*) ' type of scaling under sea-ice nn_mxlice = ', nn_mxlice
+ IF( nn_mxlice == 1 ) &
+ WRITE(numout,*) ' ice thickness when scaling under sea-ice rn_mxlice = ', rn_mxlice
+ SELECT CASE( nn_mxlice ) ! Type of scaling under sea-ice
+ CASE( 0 ) ; WRITE(numout,*) ' ==>>> No scaling under sea-ice'
+ CASE( 1 ) ; WRITE(numout,*) ' ==>>> scaling with constant sea-ice thickness'
+ CASE( 2 ) ; WRITE(numout,*) ' ==>>> scaling with mean sea-ice thickness'
+ CASE( 3 ) ; WRITE(numout,*) ' ==>>> scaling with max sea-ice thickness'
+ CASE DEFAULT
+ CALL ctl_stop( 'zdf_tke_init: wrong value for nn_mxlice, should be 0,1,2,3 or 4')
+ END SELECT
+ ENDIF
WRITE(numout,*) ' Langmuir cells parametrization ln_lc = ', ln_lc
WRITE(numout,*) ' coef to compute vertical velocity of LC rn_lc = ', rn_lc
@@ -586,7 +669,14 @@
WRITE(numout,*) ' type of tke penetration profile nn_htau = ', nn_htau
WRITE(numout,*) ' fraction of TKE that penetrates rn_efr = ', rn_efr
- WRITE(numout,*) ' below sea-ice: =0 ON rn_eice = ', rn_eice
- WRITE(numout,*) ' =4 OFF when ice fraction > 1/4 '
- IF( ln_drg ) THEN
+ WRITE(numout,*) ' langmuir & surface wave breaking under ice nn_eice = ', nn_eice
+ SELECT CASE( nn_eice )
+ CASE( 0 ) ; WRITE(numout,*) ' ==>>> no impact of ice cover on langmuir & surface wave breaking'
+ CASE( 1 ) ; WRITE(numout,*) ' ==>>> weigthed by 1-TANH( fr_i(:,:) * 10 )'
+ CASE( 2 ) ; WRITE(numout,*) ' ==>>> weighted by 1-fr_i(:,:)'
+ CASE( 3 ) ; WRITE(numout,*) ' ==>>> weighted by 1-MIN( 1, 4 * fr_i(:,:) )'
+ CASE DEFAULT
+ CALL ctl_stop( 'zdf_tke_init: wrong value for nn_eice, should be 0,1,2, or 3')
+ END SELECT
+ IF( .NOT.ln_drg_OFF ) THEN
WRITE(numout,*)
WRITE(numout,*) ' Namelist namdrg_top/_bot: used values:'
@@ -674,8 +764,8 @@
!
IF( MIN( id1, id2, id3, id4 ) > 0 ) THEN ! fields exist
- CALL iom_get( numror, jpdom_autoglo, 'en' , en , ldxios = lrxios )
- CALL iom_get( numror, jpdom_autoglo, 'avt_k', avt_k, ldxios = lrxios )
- CALL iom_get( numror, jpdom_autoglo, 'avm_k', avm_k, ldxios = lrxios )
- CALL iom_get( numror, jpdom_autoglo, 'dissl', dissl, ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'en' , en , ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'avt_k', avt_k, ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'avm_k', avm_k, ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'dissl', dissl, ldxios = lrxios )
ELSE ! start TKE from rest
IF(lwp) WRITE(numout,*)
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/do_loop_substitute.h90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/do_loop_substitute.h90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/do_loop_substitute.h90 (revision 13540)
@@ -8,6 +8,6 @@
! between version 4.0 and 4.2. The primary aim of these macros is to assist in future applications of tiling
! to improve performance. This is expected to be achieved by alternative versions of these macros in selected
-! locations. The initial introduction of these macros simply replaces all identifiable nested 2D- and 3D-loops
-! with single line statements (and adjusts indenting accordingly). Do loops are identifiable if they comform
+! locations. The initial introduction of these macros simply replaced all identifiable nested 2D- and 3D-loops
+! with single line statements (and adjusts indenting accordingly). Do loops were identifiable if they comformed
! to either:
! DO jk = ....
@@ -21,9 +21,9 @@
! and white-space variants thereof.
!
-! Additionally, only loops with recognised jj and ji loops limits are treated; these are:
+! Additionally, only loops with recognised jj and ji loops limits were treated; these were:
! Lower limits of 1, 2 or fs_2
! Upper limits of jpi, jpim1 or fs_jpim1 (for ji) or jpj, jpjm1 or fs_jpjm1 (for jj)
!
-! The macro naming convention takes the form: DO_2D_BT_LR where:
+! The macro naming convention takes the form: DO_2D( B, T, L, R) where:
! B is the Bottom offset from the PE's inner domain;
! T is the Top offset from the PE's inner domain;
@@ -42,61 +42,26 @@
! with:
!
-! DO_2D_01_10
+! DO_2D( 0, 1, 1, 0 )
! .
! .
! END_2D
!
-! similar conventions apply to the 3D loops macros. jk loop limits are retained through macro arguments and are not restricted. This
-! includes the possibility of strides for which an extra set of DO_3DS macros are defined.
+! similar conventions apply to the 3D loops macros. jk loop limits are retained through macro arguments
+! and are not restricted. This includes the possibility of strides for which an extra set of DO_3DS
+! macros are defined.
!
-! In the following definitions the inner PE domain is defined by start indices of (___kIs_, __kJs_) and end indices of (__kIe_, __kJe_)
-! The following macros are defined just below: ___kIs_, __kJs_, ___kIsm1_, __kJsm1_, ___kIe_, __kJe_, ___kIep1_, __kJep1_.
-! These names are chosen to, hopefully, avoid any future, unintended matches elsewhere in the code.
+! In the following definitions the inner PE domain is defined by start indices of (Nis0, Njs0) and end
+! indices of (Nie0, Nje0) where:
!
+! Nis0 = 1 + nn_hls Njs0 = 1 + nn_hls
+! Nie0 = jpi - nn_hls Nje0 = jpj - nn_hls
+!
#endif
-#define __kIs_ 2
-#define __kJs_ 2
-#define __kIsm1_ 1
-#define __kJsm1_ 1
-#define __kIe_ jpim1
-#define __kJe_ jpjm1
-#define __kIep1_ jpi
-#define __kJep1_ jpj
+#define DO_2D(B, T, L, R) DO jj = Njs0-(B), Nje0+(T) ; DO ji = Nis0-(L), Nie0+(R)
-#define DO_2D_00_00 DO jj = __kJs_, __kJe_ ; DO ji = __kIs_, __kIe_
-#define DO_2D_00_01 DO jj = __kJs_, __kJe_ ; DO ji = __kIs_, __kIep1_
-#define DO_2D_00_10 DO jj = __kJs_, __kJe_ ; DO ji = __kIsm1_, __kIe_
-#define DO_2D_00_11 DO jj = __kJs_, __kJe_ ; DO ji = __kIsm1_, __kIep1_
-
-#define DO_2D_01_00 DO jj = __kJs_, __kJep1_ ; DO ji = __kIs_, __kIe_
-#define DO_2D_01_01 DO jj = __kJs_, __kJep1_ ; DO ji = __kIs_, __kIep1_
-#define DO_2D_01_10 DO jj = __kJs_, __kJep1_ ; DO ji = __kIsm1_, __kIe_
-#define DO_2D_01_11 DO jj = __kJs_, __kJep1_ ; DO ji = __kIsm1_, __kIep1_
-
-#define DO_2D_10_00 DO jj = __kJsm1_, __kJe_ ; DO ji = __kIs_, __kIe_
-#define DO_2D_10_10 DO jj = __kJsm1_, __kJe_ ; DO ji = __kIsm1_, __kIe_
-#define DO_2D_10_11 DO jj = __kJsm1_, __kJe_ ; DO ji = __kIsm1_, __kIep1_
-
-#define DO_2D_11_00 DO jj = __kJsm1_, __kJep1_ ; DO ji = __kIs_, __kIe_
-#define DO_2D_11_01 DO jj = __kJsm1_, __kJep1_ ; DO ji = __kIs_, __kIep1_
-#define DO_2D_11_10 DO jj = __kJsm1_, __kJep1_ ; DO ji = __kIsm1_, __kIe_
-#define DO_2D_11_11 DO jj = __kJsm1_, __kJep1_ ; DO ji = __kIsm1_, __kIep1_
+#define DO_3D(B, T, L, R, ks, ke) DO jk = ks, ke ; DO_2D(B, T, L, R)
-#define DO_3D_00_00(ks,ke) DO jk = ks, ke ; DO_2D_00_00
-#define DO_3D_00_10(ks,ke) DO jk = ks, ke ; DO_2D_00_10
-
-#define DO_3D_01_01(ks,ke) DO jk = ks, ke ; DO_2D_01_01
-
-#define DO_3D_10_00(ks,ke) DO jk = ks, ke ; DO_2D_10_00
-#define DO_3D_10_10(ks,ke) DO jk = ks, ke ; DO_2D_10_10
-#define DO_3D_10_11(ks,ke) DO jk = ks, ke ; DO_2D_10_11
-
-#define DO_3D_11_11(ks,ke) DO jk = ks, ke ; DO_2D_11_11
-
-#define DO_3DS_00_00(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_00_00
-#define DO_3DS_01_01(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_01_01
-#define DO_3DS_10_10(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_10_10
-#define DO_3DS_11_11(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_11_11
+#define DO_3DS(B, T, L, R, ks, ke, ki) DO jk = ks, ke, ki ; DO_2D(B, T, L, R)
#define END_2D END DO ; END DO
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/lib_fortran.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/lib_fortran.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/lib_fortran.F90 (revision 13540)
@@ -143,9 +143,9 @@
!!----------------------------------------------------------------------
REAL(wp), INTENT(in ) :: ptab(:,:) ! array on which operation is applied
- COMPLEX(wp) :: local_sum_2d
- !
- !!-----------------------------------------------------------------------
- !
- COMPLEX(wp):: ctmp
+ COMPLEX(dp) :: local_sum_2d
+ !
+ !!-----------------------------------------------------------------------
+ !
+ COMPLEX(dp):: ctmp
REAL(wp) :: ztmp
INTEGER :: ji, jj ! dummy loop indices
@@ -161,5 +161,5 @@
DO ji = 1, ipi
ztmp = ptab(ji,jj) * tmask_i(ji,jj)
- CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
+ CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp )
END DO
END DO
@@ -172,9 +172,9 @@
!!----------------------------------------------------------------------
REAL(wp), INTENT(in ) :: ptab(:,:,:) ! array on which operation is applied
- COMPLEX(wp) :: local_sum_3d
- !
- !!-----------------------------------------------------------------------
- !
- COMPLEX(wp):: ctmp
+ COMPLEX(dp) :: local_sum_3d
+ !
+ !!-----------------------------------------------------------------------
+ !
+ COMPLEX(dp):: ctmp
REAL(wp) :: ztmp
INTEGER :: ji, jj, jk ! dummy loop indices
@@ -192,5 +192,5 @@
DO ji = 1, ipi
ztmp = ptab(ji,jj,jk) * tmask_i(ji,jj)
- CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
+ CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp )
END DO
END DO
@@ -217,6 +217,9 @@
IF( SIZE(p2d,2) /= jpj ) CALL ctl_stop( 'STOP', 'wrong call of sum3x3_2d, the second dimension is not equal to jpj' )
!
- DO_2D_11_11
- IF( MOD(mig(ji), 3) == 1 .AND. MOD(mjg(jj), 3) == 1 ) THEN ! bottom left corber of a 3x3 box
+ ! 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. &
+ & 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
@@ -226,22 +229,25 @@
ENDIF
END_2D
- CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1. )
- IF( nbondi /= -1 ) THEN
- IF( MOD(mig( 1), 3) == 1 ) p2d( 1,:) = p2d( 2,:)
- IF( MOD(mig( 1), 3) == 2 ) p2d( 2,:) = p2d( 1,:)
+ CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1.0_wp )
+ ! no need for 2nd exchange when nn_hls = 2
+ IF( nn_hls /= 2 ) THEN
+ IF( nbondi /= -1 ) THEN
+ IF( MOD(mig( 1), 3) == 1 ) p2d( 1,:) = p2d( 2,:)
+ IF( MOD(mig( 1), 3) == 2 ) p2d( 2,:) = p2d( 1,:)
+ ENDIF
+ IF( nbondi /= 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,:)
+ ENDIF
+ IF( nbondj /= -1 ) THEN
+ IF( MOD(mjg( 1), 3) == 1 ) p2d(:, 1) = p2d(:, 2)
+ IF( MOD(mjg( 1), 3) == 2 ) p2d(:, 2) = p2d(:, 1)
+ ENDIF
+ IF( nbondj /= 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)
+ ENDIF
+ CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1.0_wp )
ENDIF
- IF( nbondi /= 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,:)
- ENDIF
- IF( nbondj /= -1 ) THEN
- IF( MOD(mjg( 1), 3) == 1 ) p2d(:, 1) = p2d(:, 2)
- IF( MOD(mjg( 1), 3) == 2 ) p2d(:, 2) = p2d(:, 1)
- ENDIF
- IF( nbondj /= 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)
- ENDIF
- CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1. )
END SUBROUTINE sum3x3_2d
@@ -264,6 +270,10 @@
!
DO jn = 1, ipn
- DO_2D_11_11
- IF( MOD(mig(ji), 3) == 1 .AND. MOD(mjg(jj), 3) == 1 ) THEN ! bottom left corber of a 3x3 box
+ !
+ ! 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. &
+ & 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
@@ -274,22 +284,25 @@
END_2D
END DO
- CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1. )
- IF( nbondi /= -1 ) THEN
- IF( MOD(mig( 1), 3) == 1 ) p3d( 1,:,:) = p3d( 2,:,:)
- IF( MOD(mig( 1), 3) == 2 ) p3d( 2,:,:) = p3d( 1,:,:)
+ CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1.0_wp )
+ ! no need for 2nd exchange when nn_hls = 2
+ IF( nn_hls /= 2 ) THEN
+ IF( nbondi /= -1 ) THEN
+ IF( MOD(mig( 1), 3) == 1 ) p3d( 1,:,:) = p3d( 2,:,:)
+ IF( MOD(mig( 1), 3) == 2 ) p3d( 2,:,:) = p3d( 1,:,:)
+ ENDIF
+ IF( nbondi /= 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,:,:)
+ ENDIF
+ IF( nbondj /= -1 ) THEN
+ IF( MOD(mjg( 1), 3) == 1 ) p3d(:, 1,:) = p3d(:, 2,:)
+ IF( MOD(mjg( 1), 3) == 2 ) p3d(:, 2,:) = p3d(:, 1,:)
+ ENDIF
+ IF( nbondj /= 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,:)
+ ENDIF
+ CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1.0_wp )
ENDIF
- IF( nbondi /= 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,:,:)
- ENDIF
- IF( nbondj /= -1 ) THEN
- IF( MOD(mjg( 1), 3) == 1 ) p3d(:, 1,:) = p3d(:, 2,:)
- IF( MOD(mjg( 1), 3) == 2 ) p3d(:, 2,:) = p3d(:, 1,:)
- ENDIF
- IF( nbondj /= 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,:)
- ENDIF
- CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1. )
END SUBROUTINE sum3x3_3d
@@ -313,8 +326,8 @@
!! Yun HE and Chris H. Q. DING, Journal of Supercomputing 18, 259-277, 2001
!!----------------------------------------------------------------------
- COMPLEX(wp), INTENT(in ) :: ydda
- COMPLEX(wp), INTENT(inout) :: yddb
- !
- REAL(wp) :: zerr, zt1, zt2 ! local work variables
+ COMPLEX(dp), INTENT(in ) :: ydda
+ COMPLEX(dp), INTENT(inout) :: yddb
+ !
+ REAL(dp) :: zerr, zt1, zt2 ! local work variables
!!-----------------------------------------------------------------------
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/lib_fortran_generic.h90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/lib_fortran_generic.h90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/lib_fortran_generic.h90 (revision 13540)
@@ -40,5 +40,5 @@
REAL(wp) :: FUNCTION_GLOB_OP ! global sum
!!
- COMPLEX(wp):: ctmp
+ COMPLEX(dp):: ctmp
REAL(wp) :: ztmp
INTEGER :: ji, jj, jk ! dummy loop indices
@@ -50,5 +50,5 @@
ipk = K_SIZE(ptab) ! 3rd dimension
!
- ctmp = CMPLX( 0.e0, 0.e0, wp ) ! warning ctmp is cumulated
+ ctmp = CMPLX( 0.e0, 0.e0, dp ) ! warning ctmp is cumulated
DO jk = 1, ipk
@@ -56,5 +56,5 @@
DO ji = 1, ipi
ztmp = ARRAY_IN(ji,jj,jk) * MASK_ARRAY(ji,jj)
- CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
+ CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp )
END DO
END DO
@@ -109,5 +109,5 @@
REAL(wp) :: FUNCTION_GLOB_OP ! global sum
!!
- COMPLEX(wp):: ctmp
+ COMPLEX(dp):: ctmp
REAL(wp) :: ztmp
INTEGER :: jk ! dummy loop indices
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/module_example
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/module_example (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/module_example (revision 13540)
@@ -93,5 +93,5 @@
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, zbbrau ! temporary scalars (DOCTOR : start with z)
+ REAL(wp) :: zmlmin, zbbrho ! temporary scalars (DOCTOR : start with z)
REAL(wp) :: zfact1, zfact2 ! do not use continuation lines in declaration
REAL(wp), DIMENSION(jpi,jpj) :: zwrk_2d ! 2D workspace
@@ -101,5 +101,5 @@
zmlmin = 1.e-8 ! Local constant initialization
- zbbrau = .5 * ebb / rau0
+ zbbrho = .5 * ebb / rho0
zfact1 = -.5 * rdt * efave
zfact2 = 1.5 * rdt * ediss
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/nemogcm.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/nemogcm.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/nemogcm.F90 (revision 13540)
@@ -47,5 +47,4 @@
USE usrdef_nam ! user defined configuration
USE tide_mod, ONLY : tide_init ! tidal components initialization (tide_init routine)
- USE bdy_oce, ONLY : ln_bdy
USE bdyini ! open boundary cond. setting (bdy_init routine)
USE istate ! initial state setting (istate_init routine)
@@ -60,5 +59,9 @@
USE diacfl ! CFL diagnostics (dia_cfl_init routine)
USE diamlr ! IOM context management for multiple-linear-regression analysis
+#if defined key_qco
+ USE stepMLF ! NEMO time-stepping (stp_MLF routine)
+#else
USE step ! NEMO time-stepping (stp routine)
+#endif
USE isfstp ! ice shelf (isf_stp_init routine)
USE icbini ! handle bergs, initialisation
@@ -84,7 +87,9 @@
#endif
!
+ USE prtctl ! Print control
+ USE in_out_manager ! I/O manager
USE lib_mpp ! distributed memory computing
USE mppini ! shared/distributed memory setting (mpp_init routine)
- USE lbcnfd , ONLY : isendto, nsndto, nfsloop, nfeloop ! Setup of north fold exchanges
+ USE lbcnfd , ONLY : isendto, nsndto ! Setup of north fold exchanges
USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)
#if defined key_iomput
@@ -94,4 +99,5 @@
USE agrif_all_update ! Master Agrif update
#endif
+ USE halo_mng
IMPLICIT NONE
@@ -142,11 +148,7 @@
#if defined key_agrif
Kbb_a = Nbb; Kmm_a = Nnn; Krhs_a = Nrhs ! agrif_oce module copies of time level indices
- CALL Agrif_Declare_Var_dom ! AGRIF: set the meshes for DOM
- CALL Agrif_Declare_Var ! " " " " " DYN/TRA
+ CALL Agrif_Declare_Var ! " " " " " DYN/TRA
# if defined key_top
CALL Agrif_Declare_Var_top ! " " " " " TOP
-# endif
-# if defined key_si3
- CALL Agrif_Declare_Var_ice ! " " " " " Sea ice
# endif
#endif
@@ -181,14 +183,11 @@
!
DO WHILE( istp <= nitend .AND. nstop == 0 )
+#if defined key_qco
+ CALL stp_MLF
+#else
CALL stp
+#endif
istp = istp + 1
END DO
- !
- IF( .NOT. Agrif_Root() ) THEN
- CALL Agrif_ParentGrid_To_ChildGrid()
- IF( ln_diaobs ) CALL dia_obs_wri
- IF( ln_timing ) CALL timing_finalize
- CALL Agrif_ChildGrid_To_ParentGrid()
- ENDIF
!
# else
@@ -205,5 +204,9 @@
ENDIF
+#if defined key_qco
+ CALL stp_MLF ( istp )
+#else
CALL stp ( istp )
+#endif
istp = istp + 1
@@ -236,5 +239,13 @@
IF( nstop /= 0 .AND. lwp ) THEN ! error print
WRITE(ctmp1,*) ' ==>>> nemo_gcm: a total of ', nstop, ' errors have been found'
- CALL ctl_stop( ctmp1 )
+ IF( ngrdstop > 0 ) THEN
+ WRITE(ctmp9,'(i2)') ngrdstop
+ WRITE(ctmp2,*) ' E R R O R detected in Agrif grid '//TRIM(ctmp9)
+ WRITE(ctmp3,*) ' Look for "E R R O R" messages in all existing '//TRIM(ctmp9)//'_ocean_output* files'
+ CALL ctl_stop( ' ', ctmp1, ' ', ctmp2, ' ', ctmp3 )
+ ELSE
+ WRITE(ctmp2,*) ' Look for "E R R O R" messages in all existing ocean_output* files'
+ CALL ctl_stop( ' ', ctmp1, ' ', ctmp2 )
+ ENDIF
ENDIF
!
@@ -248,5 +259,5 @@
#else
IF ( lk_oasis ) THEN ; CALL cpl_finalize ! end coupling and mpp communications with OASIS
- ELSEIF( lk_mpp ) THEN ; CALL mppstop ! end mpp communications
+ ELSEIF( lk_mpp ) THEN ; CALL mppstop ! end mpp communications
ENDIF
#endif
@@ -269,7 +280,6 @@
INTEGER :: ios, ilocal_comm ! local integers
!!
- NAMELIST/namctl/ sn_cfctl, nn_print, nn_ictls, nn_ictle, &
- & nn_isplt , nn_jsplt, nn_jctls, nn_jctle, &
- & ln_timing, ln_diacfl
+ NAMELIST/namctl/ sn_cfctl, ln_timing, ln_diacfl, &
+ & nn_isplt, nn_jsplt, nn_ictls, nn_ictle, nn_jctls, nn_jctle
NAMELIST/namcfg/ ln_read_cfg, cn_domcfg, ln_closea, ln_write_cfg, cn_domcfg_out, ln_use_jattr
!!----------------------------------------------------------------------
@@ -317,6 +327,11 @@
IF( lwm ) CALL ctl_opn( numond, 'output.namelist.dyn', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. )
! open /dev/null file to be able to supress output write easily
+ IF( Agrif_Root() ) THEN
CALL ctl_opn( numnul, '/dev/null', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. )
- !
+#ifdef key_agrif
+ ELSE
+ numnul = Agrif_Parent(numnul)
+#endif
+ ENDIF
! !--------------------!
! ! Open listing units ! -> need sn_cfctl from namctl to define lwp
@@ -329,20 +344,6 @@
!
! finalize the definition of namctl variables
- IF( sn_cfctl%l_allon ) THEN
- ! Turn on all options.
- CALL nemo_set_cfctl( sn_cfctl, .TRUE., .TRUE. )
- ! Ensure all processors are active
- sn_cfctl%procmin = 0 ; sn_cfctl%procmax = 1000000 ; sn_cfctl%procincr = 1
- ELSEIF( sn_cfctl%l_config ) THEN
- ! Activate finer control of report outputs
- ! optionally switch off output from selected areas (note this only
- ! applies to output which does not involve global communications)
- IF( ( narea < sn_cfctl%procmin .OR. narea > sn_cfctl%procmax ) .OR. &
- & ( MOD( narea - sn_cfctl%procmin, sn_cfctl%procincr ) /= 0 ) ) &
- & CALL nemo_set_cfctl( sn_cfctl, .FALSE., .FALSE. )
- ELSE
- ! turn off all options.
- CALL nemo_set_cfctl( sn_cfctl, .FALSE., .TRUE. )
- ENDIF
+ IF( narea < sn_cfctl%procmin .OR. narea > sn_cfctl%procmax .OR. MOD( narea - sn_cfctl%procmin, sn_cfctl%procincr ) /= 0 ) &
+ & CALL nemo_set_cfctl( sn_cfctl, .FALSE. )
!
lwp = (narea == 1) .OR. sn_cfctl%l_oceout ! control of all listing output print
@@ -373,4 +374,12 @@
WRITE(numout,*) " ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ "
WRITE(numout,*)
+
+ ! Print the working precision to ocean.output
+ IF (wp == dp) THEN
+ WRITE(numout,*) "Working precision = double-precision"
+ ELSE
+ WRITE(numout,*) "Working precision = single-precision"
+ ENDIF
+ WRITE(numout,*)
!
WRITE(numout,cform_aaa) ! Flag AAAAAAA
@@ -390,7 +399,7 @@
!
IF( ln_read_cfg ) THEN ! Read sizes in domain configuration file
- CALL domain_cfg ( cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio )
+ CALL domain_cfg ( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, jperio )
ELSE ! user-defined namelist
- CALL usr_def_nam( cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio )
+ CALL usr_def_nam( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, jperio )
ENDIF
!
@@ -402,4 +411,5 @@
CALL mpp_init
+ CALL halo_mng_init()
! Now we know the dimensions of the grid and numout has been set: we can allocate arrays
CALL nemo_alloc()
@@ -407,5 +417,7 @@
! Initialise time level indices
Nbb = 1; Nnn = 2; Naa = 3; Nrhs = Naa
-
+#if defined key_agrif
+ Kbb_a = Nbb; Kmm_a = Nnn; Krhs_a = Nrhs ! agrif_oce module copies of time level indices
+#endif
! !-------------------------------!
! ! NEMO general initialization !
@@ -422,4 +434,8 @@
IF( lk_c1d ) CALL c1d_init ! 1D column configuration
CALL wad_init ! Wetting and drying options
+
+#if defined key_agrif
+ CALL Agrif_Declare_Var_ini ! " " " " " DOM
+#endif
CALL dom_init( Nbb, Nnn, Naa, "OPA") ! Domain
IF( ln_crs ) CALL crs_init( Nnn ) ! coarsened grid: domain initialization
@@ -443,5 +459,5 @@
ENDIF
!
-
+
CALL istate_init( Nbb, Nnn, Naa ) ! ocean initial state (Dynamics and tracers)
@@ -528,7 +544,4 @@
WRITE(numout,*) '~~~~~~~~'
WRITE(numout,*) ' Namelist namctl'
- WRITE(numout,*) ' sn_cfctl%l_glochk = ', sn_cfctl%l_glochk
- WRITE(numout,*) ' sn_cfctl%l_allon = ', sn_cfctl%l_allon
- WRITE(numout,*) ' finer control over o/p sn_cfctl%l_config = ', sn_cfctl%l_config
WRITE(numout,*) ' sn_cfctl%l_runstat = ', sn_cfctl%l_runstat
WRITE(numout,*) ' sn_cfctl%l_trcstat = ', sn_cfctl%l_trcstat
@@ -542,23 +555,9 @@
WRITE(numout,*) ' sn_cfctl%procincr = ', sn_cfctl%procincr
WRITE(numout,*) ' sn_cfctl%ptimincr = ', sn_cfctl%ptimincr
- WRITE(numout,*) ' level of print nn_print = ', nn_print
- WRITE(numout,*) ' Start i indice for SUM control nn_ictls = ', nn_ictls
- WRITE(numout,*) ' End i indice for SUM control nn_ictle = ', nn_ictle
- WRITE(numout,*) ' Start j indice for SUM control nn_jctls = ', nn_jctls
- WRITE(numout,*) ' End j indice for SUM control nn_jctle = ', nn_jctle
- WRITE(numout,*) ' number of proc. following i nn_isplt = ', nn_isplt
- WRITE(numout,*) ' number of proc. following j nn_jsplt = ', nn_jsplt
WRITE(numout,*) ' timing by routine ln_timing = ', ln_timing
WRITE(numout,*) ' CFL diagnostics ln_diacfl = ', ln_diacfl
ENDIF
!
- nprint = nn_print ! convert DOCTOR namelist names into OLD names
- nictls = nn_ictls
- nictle = nn_ictle
- njctls = nn_jctls
- njctle = nn_jctle
- isplt = nn_isplt
- jsplt = nn_jsplt
-
+ IF( .NOT.ln_read_cfg ) ln_closea = .false. ! dealing possible only with a domcfg file
IF(lwp) THEN ! control print
WRITE(numout,*)
@@ -571,44 +570,4 @@
WRITE(numout,*) ' use file attribute if exists as i/p j-start ln_use_jattr = ', ln_use_jattr
ENDIF
- IF( .NOT.ln_read_cfg ) ln_closea = .false. ! dealing possible only with a domcfg file
- !
- ! ! Parameter control
- !
- IF( sn_cfctl%l_prtctl .OR. sn_cfctl%l_prttrc ) THEN ! sub-domain area indices for the control prints
- IF( lk_mpp .AND. jpnij > 1 ) THEN
- isplt = jpni ; jsplt = jpnj ; ijsplt = jpni*jpnj ! the domain is forced to the real split domain
- ELSE
- IF( isplt == 1 .AND. jsplt == 1 ) THEN
- CALL ctl_warn( ' - isplt & jsplt are equal to 1', &
- & ' - the print control will be done over the whole domain' )
- ENDIF
- ijsplt = isplt * jsplt ! total number of processors ijsplt
- ENDIF
- IF(lwp) WRITE(numout,*)' - The total number of processors over which the'
- IF(lwp) WRITE(numout,*)' print control will be done is ijsplt : ', ijsplt
- !
- ! ! indices used for the SUM control
- IF( nictls+nictle+njctls+njctle == 0 ) THEN ! print control done over the default area
- lsp_area = .FALSE.
- ELSE ! print control done over a specific area
- lsp_area = .TRUE.
- IF( nictls < 1 .OR. nictls > jpiglo ) THEN
- CALL ctl_warn( ' - nictls must be 1<=nictls>=jpiglo, it is forced to 1' )
- nictls = 1
- ENDIF
- IF( nictle < 1 .OR. nictle > jpiglo ) THEN
- CALL ctl_warn( ' - nictle must be 1<=nictle>=jpiglo, it is forced to jpiglo' )
- nictle = jpiglo
- ENDIF
- IF( njctls < 1 .OR. njctls > jpjglo ) THEN
- CALL ctl_warn( ' - njctls must be 1<=njctls>=jpjglo, it is forced to 1' )
- njctls = 1
- ENDIF
- IF( njctle < 1 .OR. njctle > jpjglo ) THEN
- CALL ctl_warn( ' - njctle must be 1<=njctle>=jpjglo, it is forced to jpjglo' )
- njctle = jpjglo
- ENDIF
- ENDIF
- ENDIF
!
IF( 1._wp /= SIGN(1._wp,-0._wp) ) CALL ctl_stop( 'nemo_ctl: The intrinsec SIGN function follows f2003 standard.', &
@@ -678,25 +637,18 @@
- SUBROUTINE nemo_set_cfctl(sn_cfctl, setto, for_all )
+ SUBROUTINE nemo_set_cfctl(sn_cfctl, setto )
!!----------------------------------------------------------------------
!! *** ROUTINE nemo_set_cfctl ***
!!
!! ** Purpose : Set elements of the output control structure to setto.
- !! for_all should be .false. unless all areas are to be
- !! treated identically.
!!
!! ** Method : Note this routine can be used to switch on/off some
- !! types of output for selected areas but any output types
- !! that involve global communications (e.g. mpp_max, glob_sum)
- !! should be protected from selective switching by the
- !! for_all argument
- !!----------------------------------------------------------------------
- LOGICAL :: setto, for_all
- TYPE(sn_ctl) :: sn_cfctl
- !!----------------------------------------------------------------------
- IF( for_all ) THEN
- sn_cfctl%l_runstat = setto
- sn_cfctl%l_trcstat = setto
- ENDIF
+ !! types of output for selected areas.
+ !!----------------------------------------------------------------------
+ TYPE(sn_ctl), INTENT(inout) :: sn_cfctl
+ LOGICAL , INTENT(in ) :: setto
+ !!----------------------------------------------------------------------
+ sn_cfctl%l_runstat = setto
+ sn_cfctl%l_trcstat = setto
sn_cfctl%l_oceout = setto
sn_cfctl%l_layout = setto
@@ -708,3 +660,2 @@
!!======================================================================
END MODULE nemogcm
-
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/oce.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/oce.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/oce.F90 (revision 13540)
@@ -32,6 +32,6 @@
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: Cu_adv !: vertical Courant number (adaptive-implicit)
- !! free surface ! before ! now ! after !
- !! ------------ ! fields ! fields ! fields !
+ !! free surface
+ !! ------------
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ssh, uu_b, vv_b !: SSH [m] and barotropic velocities [m/s]
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/par_kind.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/par_kind.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/par_kind.F90 (revision 13540)
@@ -24,5 +24,9 @@
INTEGER, PUBLIC, PARAMETER :: sp = SELECTED_REAL_KIND( 6, 37) !: single precision (real 4)
INTEGER, PUBLIC, PARAMETER :: dp = SELECTED_REAL_KIND(12,307) !: double precision (real 8)
+# if defined key_single
+ INTEGER, PUBLIC, PARAMETER :: wp = sp !: working precision
+# else
INTEGER, PUBLIC, PARAMETER :: wp = dp !: working precision
+# endif
! !!** Integer **
@@ -31,5 +35,6 @@
! !!** Integer **
- INTEGER, PUBLIC, PARAMETER :: lc = 256 !: Lenght of Character strings
+ INTEGER, PUBLIC, PARAMETER :: lc = 256 !: Lenght of Character strings
+ INTEGER, PUBLIC, PARAMETER :: lca = 400 !: Lenght of Character arrays
!!----------------------------------------------------------------------
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/par_oce.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/par_oce.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/par_oce.F90 (revision 13540)
@@ -47,7 +47,10 @@
! global domain size for AGRIF !!! * total AGRIF computational domain *
INTEGER, PUBLIC :: nbug_in_agrif_conv_do_not_remove_or_modify = 1 - 1
- INTEGER, PUBLIC, PARAMETER :: nbghostcells = 3 !: number of ghost cells
- INTEGER, PUBLIC :: nbcellsx ! = jpiglo - 2 - 2*nbghostcells !: number of cells in i-direction
- INTEGER, PUBLIC :: nbcellsy ! = jpjglo - 2 - 2*nbghostcells !: number of cells in j-direction
+ INTEGER, PUBLIC, PARAMETER :: nbghostcells = 3 !: number of ghost cells: default value
+ INTEGER, PUBLIC :: nbghostcells_x !: number of ghost cells in i-direction
+ INTEGER, PUBLIC :: nbghostcells_y_s !: number of ghost cells in j-direction at south
+ INTEGER, PUBLIC :: nbghostcells_y_n !: number of ghost cells in j-direction at north
+ INTEGER, PUBLIC :: nbcellsx !: number of cells in i-direction
+ INTEGER, PUBLIC :: nbcellsy !: number of cells in j-direction
! local domain size !!! * local computational domain *
@@ -59,6 +62,6 @@
INTEGER, PUBLIC :: jpkm1 ! = jpk-1 !: - - -
INTEGER, PUBLIC :: jpij ! = jpi*jpj !: jpi x jpj
- INTEGER, PUBLIC :: jpimax! = ( jpiglo-2*nn_hls + (jpni-1) ) / jpni + 2*nn_hls !: maximum jpi
- INTEGER, PUBLIC :: jpjmax! = ( jpjglo-2*nn_hls + (jpnj-1) ) / jpnj + 2*nn_hls !: maximum jpj
+ INTEGER, PUBLIC :: jpimax! = ( Ni0glo + jpni-1 ) / jpni + 2*nn_hls !: maximum jpi
+ INTEGER, PUBLIC :: jpjmax! = ( Nj0glo + jpnj-1 ) / jpnj + 2*nn_hls !: maximum jpj
!!---------------------------------------------------------------------
@@ -78,5 +81,13 @@
INTEGER, PUBLIC, PARAMETER :: jpr2di = 0 !: number of columns for extra outer halo
INTEGER, PUBLIC, PARAMETER :: jpr2dj = 0 !: number of rows for extra outer halo
- INTEGER, PUBLIC, PARAMETER :: nn_hls = 1 !: halo width (applies to both rows and columns)
+
+ ! halo with and starting/inding DO-loop indices
+ INTEGER, PUBLIC :: nn_hls !: halo width (applies to both rows and columns)
+ INTEGER, PUBLIC :: Nis0, Nis1, Nis1nxt2, Nis2 !: start I-index (_0: without halo, _1 or _2: with 1 or 2 halos)
+ INTEGER, PUBLIC :: Nie0, Nie1, Nie1nxt2, Nie2 !: end I-index (_0: without halo, _1 or _2: with 1 or 2 halos)
+ INTEGER, PUBLIC :: Njs0, Njs1, Njs1nxt2, Njs2 !: start J-index (_0: without halo, _1 or _2: with 1 or 2 halos)
+ INTEGER, PUBLIC :: Nje0, Nje1, Nje1nxt2, Nje2 !: end J-index (_0: without halo, _1 or _2: with 1 or 2 halos)
+ INTEGER, PUBLIC :: Ni_0, Nj_0, Ni_1, Nj_1, Ni_2, Nj_2 !: domain size (_0: without halo, _1 or _2: with 1 or 2 halos)
+ INTEGER, PUBLIC :: Ni0glo, Nj0glo
!!----------------------------------------------------------------------
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/step.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/step.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/step.F90 (revision 13540)
@@ -33,5 +33,9 @@
!! 4.1 ! 2019-08 (A. Coward, D. Storkey) rewrite in preparation for new timestepping scheme
!!----------------------------------------------------------------------
-
+#if defined key_qco
+ !!----------------------------------------------------------------------
+ !! 'key_qco' EMPTY MODULE Quasi-Eulerian vertical coordonate
+ !!----------------------------------------------------------------------
+#else
!!----------------------------------------------------------------------
!! stp : OPA system time-stepping
@@ -82,9 +86,9 @@
!!----------------------------------------------------------------------
INTEGER :: ji, jj, jk ! dummy loop indice
- INTEGER :: indic ! error indicator if < 0
!!gm kcall can be removed, I guess
INTEGER :: kcall ! optional integer argument (dom_vvl_sf_nxt)
!! ---------------------------------------------------------------------
#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
@@ -114,8 +118,6 @@
! update I/O and calendar
!<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
- indic = 0 ! reset to no error condition
-
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 passible AGRIF zoom)
+ 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
@@ -181,5 +183,5 @@
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, ww, Naa ) ! now cross-level velocity
+ 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
@@ -210,5 +212,5 @@
CALL dyn_zdf ( kstp, Nbb, Nnn, Nrhs, uu, vv, Naa ) ! vertical diffusion
IF( ln_dynspg_ts ) THEN ! vertical scale factors and vertical velocity need to be updated
- CALL wzv ( kstp, Nbb, Nnn, ww, Naa ) ! now cross-level velocity
+ CALL wzv ( kstp, Nbb, Nnn, Naa, ww ) ! now cross-level velocity
IF( ln_zad_Aimp ) CALL wAimp ( kstp, Nnn ) ! Adaptive-implicit vertical advection partitioning
ENDIF
@@ -309,20 +311,29 @@
#if defined key_agrif
!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
- ! 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
- IF( Agrif_NbStepint() == 0 ) THEN
- CALL Agrif_update_all( ) ! Update all components
- ENDIF
-#endif
- IF( ln_diaobs ) CALL dia_obs ( kstp, Nnn ) ! obs-minus-model (assimilation) diagnostics (call after dynamics update)
-
+#endif
!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
! Control
!<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
- CALL stp_ctl ( kstp, Nbb, Nnn, indic )
-
+ CALL stp_ctl ( kstp, Nnn )
+
+#if defined key_agrif
+ !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ ! AGRIF update
+ !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ IF( Agrif_NbStepint() == 0 .AND. nstop == 0 ) THEN
+ CALL Agrif_update_all( ) ! Update all components
+ ENDIF
+
+#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
@@ -334,11 +345,13 @@
! Coupled mode
!<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
-!!gm why lk_oasis and not lk_cpl ????
- IF( lk_oasis ) CALL sbc_cpl_snd( kstp, Nbb, Nnn ) ! coupled mode : field exchanges
+ IF( lk_oasis .AND. nstop == 0 ) CALL sbc_cpl_snd( kstp, Nbb, Nnn ) ! coupled mode : field exchanges
!
#if defined key_iomput
- IF( kstp == nitend .OR. indic < 0 ) THEN
+ !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ ! 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(lrxios) CALL iom_context_finalize( crxios_context )
+ IF( lrxios ) CALL iom_context_finalize( crxios_context )
IF( ln_crs ) CALL iom_context_finalize( trim(cxios_context)//"_crs" ) !
ENDIF
@@ -355,4 +368,5 @@
END SUBROUTINE stp
!
+#endif
!!======================================================================
END MODULE step
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/stpMLF.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/stpMLF.F90 (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/stpMLF.F90 (revision 13540)
@@ -0,0 +1,473 @@
+MODULE stepMLF
+ !!======================================================================
+ !! *** 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
+ !!----------------------------------------------------------------------
+
+ !!----------------------------------------------------------------------
+ !! stp_MLF : OPA system time-stepping
+ !!----------------------------------------------------------------------
+ USE step_oce ! time stepping definition modules
+ !
+ USE iom ! xIOs server
+ USE domqco
+ USE traatfqco ! time filtering (tra_atf_qco routine)
+ USE dynatfqco ! time filtering (dyn_atf_qco routine)
+ USE dynspg_ts ! surface pressure gradient: split-explicit scheme (define un_adv)
+ USE bdydyn ! ocean open boundary conditions (define bdy_dyn)
+
+ IMPLICIT NONE
+ PRIVATE
+
+#if ! defined key_qco
+ !!----------------------------------------------------------------------
+ !! 'key_qco' EMPTY MODULE Quasi-Eulerian vertical coordonate
+ !!----------------------------------------------------------------------
+#else
+ PUBLIC stp_MLF ! called by nemogcm.F90
+
+ !!----------------------------------------------------------------------
+ !! time level indices
+ !!----------------------------------------------------------------------
+ INTEGER, PUBLIC :: Nbb, Nnn, Naa, Nrhs !! used by nemo_init
+# include "domzgr_substitute.h90"
+ !!----------------------------------------------------------------------
+ !! NEMO/OCE 4.0 , NEMO Consortium (2018)
+ !! $Id: step.F90 12377 2020-02-12 14:39:06Z acc $
+ !! Software governed by the CeCILL license (see ./LICENSE)
+ !!----------------------------------------------------------------------
+CONTAINS
+
+#if defined key_agrif
+ RECURSIVE SUBROUTINE stp_MLF( )
+ INTEGER :: kstp ! ocean time-step index
+#else
+ SUBROUTINE stp_MLF( kstp )
+ INTEGER, INTENT(in) :: kstp ! ocean time-step index
+#endif
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE stp_MLF ***
+ !!
+ !! ** Purpose : - Time stepping of OPA (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 ! dummy loop indice
+ INTEGER :: indic ! error indicator if < 0
+!!gm kcall can be removed, I guess
+ INTEGER :: kcall ! optional integer argument (dom_vvl_sf_nxt)
+!!st patch
+ REAL(wp), DIMENSION(jpi,jpj,jpk) :: zgdept
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zssh_f
+ !! ---------------------------------------------------------------------
+#if defined key_agrif
+ 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_iomput
+ IF( Agrif_Nbstepint() == 0 ) CALL iom_swap( cxios_context )
+# endif
+#endif
+ !
+ IF( ln_timing ) CALL timing_start('stp_MLF')
+ !
+ !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ ! 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
+ !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ indic = 0 ! reset to no error condition
+
+ 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 passible 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 /= 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
+ CALL zdf_phy( kstp, Nbb, Nnn, Nrhs ) ! vertical physics update (top/bot drag, avt, avs, avm + MLD)
+
+ ! LATERAL PHYSICS
+ !
+ IF( l_ldfslp ) THEN ! slope of lateral mixing
+ CALL eos( ts(:,:,:,:,Nbb), rhd, gdept_0(:,:,:) ) ! before in situ density
+
+ IF( ln_zps .AND. .NOT. ln_isfcav) &
+ & CALL zps_hde ( kstp, Nnn, 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, Nnn, 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( 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
+ !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ DO jk = 1, jpk
+ zgdept(:,:,jk) = gdept(:,:,jk,Nnn)
+ END DO
+ CALL ssh_nxt ( kstp, Nbb, Nnn, ssh, Naa ) ! after ssh (includes call to div_hor)
+ IF( .NOT.ln_linssh ) CALL dom_qco_r3c ( ssh(:,:,Naa), r3t(:,:,Naa), r3u(:,:,Naa), r3v(:,:,Naa) ) ! "after" ssh./h._0 ratio
+ CALL wzv ( kstp, Nbb, Nnn, Naa, ww ) ! Nnn cross-level velocity
+ IF( ln_zad_Aimp ) CALL wAimp ( kstp, Nnn ) ! Adaptive-implicit vertical advection partitioning
+ CALL eos ( ts(:,:,:,:,Nnn), rhd, rhop, zgdept ) ! now in situ density for hpg computation
+
+
+ uu(:,:,:,Nrhs) = 0._wp ! set dynamics trends to zero
+ vv(:,:,:,Nrhs) = 0._wp
+
+ 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_bdy ) CALL bdy_dyn3d_dmp ( kstp, Nbb, uu, vv, Nrhs ) ! bdy damping trends
+#if defined key_agrif
+ IF(.NOT. Agrif_Root()) &
+ & CALL Agrif_Sponge_dyn ! momentum sponge
+#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
+ 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
+ CALL div_hor ( kstp, Nbb, Nnn ) ! Horizontal divergence (2nd call in time-split case)
+ IF(.NOT.ln_linssh) CALL dom_qco_r3c ( ssh(:,:,Naa), r3t(:,:,Naa), r3u(:,:,Naa), r3v(:,:,Naa), r3f(:,:) ) ! "after" ssh./h._0 ratio
+ ENDIF
+ CALL dyn_zdf ( kstp, Nbb, Nnn, Nrhs, uu, vv, Naa ) ! vertical diffusion
+ 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
+
+ !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ ! Now ssh filtering
+ !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ CALL ssh_atf ( kstp, Nbb, Nnn, Naa, ssh ) ! time filtering of "now" sea surface height
+ CALL dom_qco_r3c( ssh(:,:,Nnn), r3t_f, r3u_f, r3v_f ) ! "now" ssh/h_0 ratio from filtrered ssh
+#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( 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
+#if defined key_agrif
+ IF(.NOT. Agrif_Root()) &
+ & CALL Agrif_Sponge_tra ! tracers sponge
+#endif
+ CALL tra_adv ( kstp, Nbb, Nnn, ts, Nrhs ) ! hor. + vert. advection ==> RHS
+ IF( ln_zdfosm ) CALL tra_osm ( kstp, Nnn, ts, Nrhs ) ! OSMOSIS non-local tracer fluxes ==> RHS
+ IF( lrst_oce .AND. ln_zdfosm ) &
+ & CALL osm_rst ( kstp, Nnn, 'WRITE' ) ! write OSMOSIS outputs + ww (so must do here) to restarts
+ 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
+
+ !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ ! 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.
+!!
+ CALL mlf_baro_corr ( Nnn, Naa, uu, vv ) ! barotrope ajustment
+ CALL finalize_sbc ( kstp, Nbb, Naa, uu, vv, ts ) ! boundary condifions
+ CALL tra_atf_qco ( kstp, Nbb, Nnn, Naa, ts ) ! time filtering of "now" tracer arrays
+ CALL dyn_atf_qco ( kstp, Nbb, Nnn, Naa, uu, vv ) ! time filtering of "now" velocities and scale factors
+ r3t(:,:,Nnn) = r3t_f(:,:)
+ r3u(:,:,Nnn) = r3u_f(:,:)
+ r3v(:,:,Nnn) = r3v_f(:,:)
+
+ !
+ ! Swap time levels
+ Nrhs = Nbb
+ Nbb = Nnn
+ Nnn = Naa
+ Naa = Nrhs
+ !
+ !
+ 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
+ !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ Kbb_a = Nbb; Kmm_a = Nnn; Krhs_a = Nrhs ! agrif_oce module copies of time level indices
+ CALL Agrif_Integrate_ChildGrids( stp_MLF ) ! allows to finish all the Child Grids before updating
+
+ IF( Agrif_NbStepint() == 0 ) THEN
+ CALL Agrif_update_all( ) ! Update all components
+ ENDIF
+#endif
+ IF( ln_diaobs ) CALL dia_obs ( kstp, Nnn ) ! obs-minus-model (assimilation) diagnostics (call after dynamics update)
+
+ !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ ! Control
+ !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ CALL stp_ctl ( kstp, Nbb, Nnn, indic )
+
+ IF( kstp == nit000 ) THEN ! 1st time step only
+ CALL iom_close( numror ) ! close input ocean restart file
+ 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
+ !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+!!gm why lk_oasis and not lk_cpl ????
+ IF( lk_oasis ) CALL sbc_cpl_snd( kstp, Nbb, Nnn ) ! coupled mode : field exchanges
+ !
+#if defined key_iomput
+ IF( kstp == nitend .OR. indic < 0 ) THEN
+ CALL iom_context_finalize( cxios_context ) ! needed for XIOS+AGRIF
+ IF(lrxios) CALL iom_context_finalize( crxios_context )
+ 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_MLF')
+ !
+ END SUBROUTINE stp_MLF
+
+
+ SUBROUTINE mlf_baro_corr (Kmm, Kaa, puu, pvv)
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE mlf_baro_corr ***
+ !!
+ !! ** Purpose : Finalize after horizontal velocity.
+ !!
+ !! ** Method : * Ensure after velocities transport matches time splitting
+ !! estimate (ln_dynspg_ts=T)
+ !!
+ !! ** Action : puu(Kmm),pvv(Kmm),puu(Kaa),pvv(Kaa) now and after horizontal velocity
+ !!----------------------------------------------------------------------
+ INTEGER , INTENT(in ) :: Kmm, Kaa ! before and after time level indices
+ REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! velocities
+ !
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zue, zve
+ !
+ INTEGER :: jk ! dummy loop indices
+ !!----------------------------------------------------------------------
+
+ IF ( ln_dynspg_ts ) THEN
+ ALLOCATE( zue(jpi,jpj) , zve(jpi,jpj) )
+ ! Ensure below that barotropic velocities match time splitting estimate
+ ! Compute actual transport and replace it with ts estimate at "after" time step
+ zue(:,:) = e3u(:,:,1,Kaa) * puu(:,:,1,Kaa) * umask(:,:,1)
+ zve(:,:) = e3v(:,:,1,Kaa) * pvv(:,:,1,Kaa) * vmask(:,:,1)
+ DO jk = 2, jpkm1
+ zue(:,:) = zue(:,:) + e3u(:,:,jk,Kaa) * puu(:,:,jk,Kaa) * umask(:,:,jk)
+ zve(:,:) = zve(:,:) + e3v(:,:,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
+ !
+ DEALLOCATE( zue, zve )
+ !
+ ENDIF
+ !
+ END SUBROUTINE mlf_baro_corr
+
+
+ SUBROUTINE finalize_sbc (kt, Kbb, Kaa, puu, pvv, pts)
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE finalize_sbc ***
+ !!
+ !! ** Purpose : Apply the boundary condition on the after velocity
+ !!
+ !! ** Method : * 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)
+ !!
+ !! ** Action : puu(Kaa),pvv(Kaa) after horizontal velocity and tracers
+ !!----------------------------------------------------------------------
+ INTEGER , INTENT(in ) :: kt ! ocean time-step index
+ INTEGER , INTENT(in ) :: Kbb, 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,jpts,jpt), INTENT(inout) :: pts ! active tracers
+ !
+ ! Update after tracer and velocity on domain lateral boundaries
+ !
+#if defined key_agrif
+ CALL Agrif_tra ! AGRIF zoom boundaries
+ CALL Agrif_dyn( kt ) !* AGRIF zoom boundaries
+#endif
+ ! ! local domain boundaries (T-point, unchanged sign)
+ CALL lbc_lnk_multi( 'finalize_sbc', puu(:,:,:, Kaa), 'U', -1., pvv(:,:,: ,Kaa), 'V', -1. &
+ & , pts(:,:,:,jp_tem,Kaa), 'T', 1., pts(:,:,:,jp_sal,Kaa), 'T', 1. ) !* local domain boundaries
+ !
+ ! !* BDY open boundaries
+ IF( ln_bdy ) THEN
+ CALL bdy_tra( kt, Kbb, pts, Kaa )
+ IF( ln_dynspg_exp ) CALL bdy_dyn( kt, Kbb, puu, pvv, Kaa )
+ IF( ln_dynspg_ts ) CALL bdy_dyn( kt, Kbb, puu, pvv, Kaa, dyn3d_only=.true. )
+ ENDIF
+ !
+ END SUBROUTINE finalize_sbc
+#endif
+ !
+ !!======================================================================
+END MODULE stepMLF
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/stpctl.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/stpctl.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/stpctl.F90 (revision 13540)
@@ -19,12 +19,12 @@
USE dom_oce ! ocean space and time domain variables
USE c1d ! 1D vertical configuration
+ USE zdf_oce , ONLY : ln_zad_Aimp ! ocean vertical physics variables
+ USE wet_dry, ONLY : ll_wd, ssh_ref ! reference depth for negative bathy
+ !
USE diawri ! Standard run outputs (dia_wri_state routine)
- !
USE in_out_manager ! I/O manager
USE lbclnk ! ocean lateral boundary conditions (or mpp link)
USE lib_mpp ! distributed memory computing
- USE zdf_oce , ONLY : ln_zad_Aimp ! ocean vertical physics variables
- USE wet_dry, ONLY : ll_wd, ssh_ref ! reference depth for negative bathy
-
+ !
USE netcdf ! NetCDF library
IMPLICIT NONE
@@ -33,6 +33,6 @@
PUBLIC stp_ctl ! routine called by step.F90
- INTEGER :: idrun, idtime, idssh, idu, ids1, ids2, idt1, idt2, idc1, idw1, istatus
- LOGICAL :: lsomeoce
+ INTEGER :: nrunid ! netcdf file id
+ INTEGER, DIMENSION(8) :: nvarid ! netcdf variable id
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -42,5 +42,5 @@
CONTAINS
- SUBROUTINE stp_ctl( kt, Kbb, Kmm, kindic )
+ SUBROUTINE stp_ctl( kt, Kmm )
!!----------------------------------------------------------------------
!! *** ROUTINE stp_ctl ***
@@ -49,6 +49,5 @@
!!
!! ** Method : - Save the time step in numstp
- !! - Print it each 50 time steps
- !! - Stop the run IF problem encountered by setting indic=-3
+ !! - Stop the run IF problem encountered by setting nstop > 0
!! Problems checked: |ssh| maximum larger than 10 m
!! |U| maximum larger than 10 m/s
@@ -57,143 +56,256 @@
!! ** Actions : "time.step" file = last ocean time-step
!! "run.stat" file = run statistics
- !! nstop indicator sheared among all local domain (lk_mpp=T)
+ !! nstop indicator sheared among all local domain
!!----------------------------------------------------------------------
INTEGER, INTENT(in ) :: kt ! ocean time-step index
- INTEGER, INTENT(in ) :: Kbb, Kmm ! ocean time level index
- INTEGER, INTENT(inout) :: kindic ! error indicator
- !!
- INTEGER :: ji, jj, jk ! dummy loop indices
- INTEGER, DIMENSION(2) :: ih ! min/max loc indices
- INTEGER, DIMENSION(3) :: iu, is1, is2 ! min/max loc indices
- REAL(wp) :: zzz ! local real
- REAL(wp), DIMENSION(9) :: zmax
- LOGICAL :: ll_wrtstp, ll_colruns, ll_wrtruns
- CHARACTER(len=20) :: clname
- !!----------------------------------------------------------------------
- !
- ll_wrtstp = ( MOD( kt, sn_cfctl%ptimincr ) == 0 ) .OR. ( kt == nitend )
- ll_colruns = ll_wrtstp .AND. ( sn_cfctl%l_runstat )
- ll_wrtruns = ll_colruns .AND. lwm
- IF( kt == nit000 .AND. lwp ) THEN
- WRITE(numout,*)
- WRITE(numout,*) 'stp_ctl : time-stepping control'
- WRITE(numout,*) '~~~~~~~'
- ! ! open time.step file
- IF( lwm ) CALL ctl_opn( numstp, 'time.step', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea )
- ! ! open run.stat file(s) at start whatever
- ! ! the value of sn_cfctl%ptimincr
- IF( lwm .AND. ( sn_cfctl%l_runstat ) ) THEN
+ INTEGER, INTENT(in ) :: Kmm ! ocean time level index
+ !!
+ INTEGER :: ji ! dummy loop indices
+ INTEGER :: idtime, istatus
+ INTEGER , DIMENSION(9) :: iareasum, iareamin, iareamax
+ INTEGER , DIMENSION(3,4) :: iloc ! min/max loc indices
+ REAL(wp) :: zzz ! local real
+ REAL(wp), DIMENSION(9) :: zmax, zmaxlocal
+ LOGICAL :: ll_wrtstp, ll_colruns, ll_wrtruns
+ LOGICAL, DIMENSION(jpi,jpj,jpk) :: llmsk
+ CHARACTER(len=20) :: clname
+ !!----------------------------------------------------------------------
+ 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
+ !
+ IF( kt == nit000 ) THEN
+ !
+ IF( lwp ) THEN
+ WRITE(numout,*)
+ WRITE(numout,*) 'stp_ctl : time-stepping control'
+ WRITE(numout,*) '~~~~~~~'
+ ENDIF
+ ! ! open time.step ascii file, done only by 1st subdomain
+ IF( lwm ) CALL ctl_opn( numstp, 'time.step', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea )
+ !
+ IF( ll_wrtruns ) THEN
+ ! ! open run.stat ascii file, done only by 1st subdomain
CALL ctl_opn( numrun, 'run.stat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea )
+ ! ! open run.stat.nc netcdf file, done only by 1st subdomain
clname = 'run.stat.nc'
IF( .NOT. Agrif_Root() ) clname = TRIM(Agrif_CFixed())//"_"//TRIM(clname)
- istatus = NF90_CREATE( TRIM(clname), NF90_CLOBBER, idrun )
- istatus = NF90_DEF_DIM( idrun, 'time', NF90_UNLIMITED, idtime )
- istatus = NF90_DEF_VAR( idrun, 'abs_ssh_max', NF90_DOUBLE, (/ idtime /), idssh )
- istatus = NF90_DEF_VAR( idrun, 'abs_u_max', NF90_DOUBLE, (/ idtime /), idu )
- istatus = NF90_DEF_VAR( idrun, 's_min', NF90_DOUBLE, (/ idtime /), ids1 )
- istatus = NF90_DEF_VAR( idrun, 's_max', NF90_DOUBLE, (/ idtime /), ids2 )
- istatus = NF90_DEF_VAR( idrun, 't_min', NF90_DOUBLE, (/ idtime /), idt1 )
- istatus = NF90_DEF_VAR( idrun, 't_max', NF90_DOUBLE, (/ idtime /), idt2 )
+ istatus = NF90_CREATE( TRIM(clname), NF90_CLOBBER, nrunid )
+ istatus = NF90_DEF_DIM( nrunid, 'time', NF90_UNLIMITED, idtime )
+ istatus = NF90_DEF_VAR( nrunid, 'abs_ssh_max', NF90_DOUBLE, (/ idtime /), nvarid(1) )
+ istatus = NF90_DEF_VAR( nrunid, 'abs_u_max', NF90_DOUBLE, (/ idtime /), nvarid(2) )
+ istatus = NF90_DEF_VAR( nrunid, 's_min', NF90_DOUBLE, (/ idtime /), nvarid(3) )
+ istatus = NF90_DEF_VAR( nrunid, 's_max', NF90_DOUBLE, (/ idtime /), nvarid(4) )
+ istatus = NF90_DEF_VAR( nrunid, 't_min', NF90_DOUBLE, (/ idtime /), nvarid(5) )
+ istatus = NF90_DEF_VAR( nrunid, 't_max', NF90_DOUBLE, (/ idtime /), nvarid(6) )
IF( ln_zad_Aimp ) THEN
- istatus = NF90_DEF_VAR( idrun, 'abs_wi_max', NF90_DOUBLE, (/ idtime /), idw1 )
- istatus = NF90_DEF_VAR( idrun, 'Cf_max', NF90_DOUBLE, (/ idtime /), idc1 )
+ istatus = NF90_DEF_VAR( nrunid, 'Cf_max', NF90_DOUBLE, (/ idtime /), nvarid(7) )
+ istatus = NF90_DEF_VAR( nrunid,'abs_wi_max',NF90_DOUBLE, (/ idtime /), nvarid(8) )
ENDIF
- istatus = NF90_ENDDEF(idrun)
- zmax(8:9) = 0._wp ! initialise to zero in case ln_zad_Aimp option is not in use
- ENDIF
- ENDIF
- IF( kt == nit000 ) lsomeoce = COUNT( ssmask(:,:) == 1._wp ) > 0
- !
- IF(lwm .AND. ll_wrtstp) THEN !== current time step ==! ("time.step" file)
+ istatus = NF90_ENDDEF(nrunid)
+ ENDIF
+ !
+ ENDIF
+ !
+ ! !== write current time step ==!
+ ! !== done only by 1st subdomain at writting timestep ==!
+ IF( lwm .AND. ll_wrtstp ) THEN
WRITE ( numstp, '(1x, i8)' ) kt
REWIND( numstp )
ENDIF
- !
- ! !== test of extrema ==!
+ ! !== test of local extrema ==!
+ ! !== done by all processes at every time step ==!
+ !
+ llmsk( 1:Nis1,:,:) = .FALSE. ! exclude halos from the checked region
+ llmsk(Nie1: jpi,:,:) = .FALSE.
+ llmsk(:, 1:Njs1,:) = .FALSE.
+ llmsk(:,Nje1: jpj,:) = .FALSE.
+ !
+ llmsk(Nis0:Nie0,Njs0:Nje0,1) = ssmask(Nis0:Nie0,Njs0:Nje0) == 1._wp ! define only the inner domain
IF( ll_wd ) THEN
- zmax(1) = MAXVAL( ABS( ssh(:,:,Kmm) + ssh_ref*tmask(:,:,1) ) ) ! ssh max
+ zmax(1) = MAXVAL( ABS( ssh(:,:,Kmm) + ssh_ref ), mask = llmsk(:,:,1) ) ! ssh max
ELSE
- zmax(1) = MAXVAL( ABS( ssh(:,:,Kmm) ) ) ! ssh max
- ENDIF
- zmax(2) = MAXVAL( ABS( uu(:,:,:,Kmm) ) ) ! velocity max (zonal only)
- zmax(3) = MAXVAL( -ts(:,:,:,jp_sal,Kmm) , mask = tmask(:,:,:) == 1._wp ) ! minus salinity max
- zmax(4) = MAXVAL( ts(:,:,:,jp_sal,Kmm) , mask = tmask(:,:,:) == 1._wp ) ! salinity max
- zmax(5) = MAXVAL( -ts(:,:,:,jp_tem,Kmm) , mask = tmask(:,:,:) == 1._wp ) ! minus temperature max
- zmax(6) = MAXVAL( ts(:,:,:,jp_tem,Kmm) , mask = tmask(:,:,:) == 1._wp ) ! temperature max
- zmax(7) = REAL( nstop , wp ) ! stop indicator
- IF( ln_zad_Aimp ) THEN
- zmax(8) = MAXVAL( ABS( wi(:,:,:) ) , mask = wmask(:,:,:) == 1._wp ) ! implicit vertical vel. max
- zmax(9) = MAXVAL( Cu_adv(:,:,:) , mask = tmask(:,:,:) == 1._wp ) ! partitioning coeff. max
- ENDIF
- !
+ zmax(1) = MAXVAL( ABS( ssh(:,:,Kmm) ), mask = llmsk(:,:,1) ) ! ssh max
+ ENDIF
+ llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain
+ zmax(2) = MAXVAL( ABS( uu(:,:,:,Kmm) ), mask = llmsk ) ! velocity max (zonal only)
+ llmsk(Nis0:Nie0,Njs0:Nje0,:) = tmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain
+ zmax(3) = MAXVAL( -ts(:,:,:,jp_sal,Kmm), mask = llmsk ) ! minus salinity max
+ zmax(4) = MAXVAL( ts(:,:,:,jp_sal,Kmm), mask = llmsk ) ! salinity max
+ IF( ll_colruns .OR. jpnij == 1 ) THEN ! following variables are used only in the netcdf file
+ zmax(5) = MAXVAL( -ts(:,:,:,jp_tem,Kmm), mask = llmsk ) ! minus temperature max
+ zmax(6) = MAXVAL( ts(:,:,:,jp_tem,Kmm), mask = llmsk ) ! temperature max
+ IF( ln_zad_Aimp ) THEN
+ zmax(7) = MAXVAL( Cu_adv(:,:,:) , mask = llmsk ) ! partitioning coeff. max
+ llmsk(:,:,:) = wmask(:,:,:) == 1._wp
+ zmax(8) = MAXVAL( ABS( wi(:,:,:) ) , mask = llmsk ) ! implicit vertical vel. max
+ ELSE
+ zmax(7:8) = 0._wp
+ ENDIF
+ ELSE
+ zmax(5:8) = 0._wp
+ ENDIF
+ zmax(9) = REAL( nstop, wp ) ! stop indicator
+ ! !== get global extrema ==!
+ ! !== done by all processes if writting run.stat ==!
IF( ll_colruns ) THEN
+ zmaxlocal(:) = zmax(:)
CALL mpp_max( "stpctl", zmax ) ! max over the global domain
- nstop = NINT( zmax(7) ) ! nstop indicator sheared among all local domains
- ENDIF
- ! !== run statistics ==! ("run.stat" files)
+ nstop = NINT( zmax(9) ) ! update nstop indicator (now sheared among all local domains)
+ ENDIF
+ ! !== write "run.stat" files ==!
+ ! !== done only by 1st subdomain at writting timestep ==!
IF( ll_wrtruns ) THEN
WRITE(numrun,9500) kt, zmax(1), zmax(2), -zmax(3), zmax(4)
- istatus = NF90_PUT_VAR( idrun, idssh, (/ zmax(1)/), (/kt/), (/1/) )
- istatus = NF90_PUT_VAR( idrun, idu, (/ zmax(2)/), (/kt/), (/1/) )
- istatus = NF90_PUT_VAR( idrun, ids1, (/-zmax(3)/), (/kt/), (/1/) )
- istatus = NF90_PUT_VAR( idrun, ids2, (/ zmax(4)/), (/kt/), (/1/) )
- istatus = NF90_PUT_VAR( idrun, idt1, (/-zmax(5)/), (/kt/), (/1/) )
- istatus = NF90_PUT_VAR( idrun, idt2, (/ zmax(6)/), (/kt/), (/1/) )
+ istatus = NF90_PUT_VAR( nrunid, nvarid(1), (/ zmax(1)/), (/kt/), (/1/) )
+ istatus = NF90_PUT_VAR( nrunid, nvarid(2), (/ zmax(2)/), (/kt/), (/1/) )
+ istatus = NF90_PUT_VAR( nrunid, nvarid(3), (/-zmax(3)/), (/kt/), (/1/) )
+ istatus = NF90_PUT_VAR( nrunid, nvarid(4), (/ zmax(4)/), (/kt/), (/1/) )
+ istatus = NF90_PUT_VAR( nrunid, nvarid(5), (/-zmax(5)/), (/kt/), (/1/) )
+ istatus = NF90_PUT_VAR( nrunid, nvarid(6), (/ zmax(6)/), (/kt/), (/1/) )
IF( ln_zad_Aimp ) THEN
- istatus = NF90_PUT_VAR( idrun, idw1, (/ zmax(8)/), (/kt/), (/1/) )
- istatus = NF90_PUT_VAR( idrun, idc1, (/ zmax(9)/), (/kt/), (/1/) )
- ENDIF
- IF( MOD( kt , 100 ) == 0 ) istatus = NF90_SYNC(idrun)
- IF( kt == nitend ) istatus = NF90_CLOSE(idrun)
+ istatus = NF90_PUT_VAR( nrunid, nvarid(7), (/ zmax(7)/), (/kt/), (/1/) )
+ istatus = NF90_PUT_VAR( nrunid, nvarid(8), (/ zmax(8)/), (/kt/), (/1/) )
+ ENDIF
+ IF( kt == nitend ) istatus = NF90_CLOSE(nrunid)
END IF
- ! !== error handling ==!
- IF( ( sn_cfctl%l_glochk .OR. lsomeoce ) .AND. ( & ! domain contains some ocean points, check for sensible ranges
- & zmax(1) > 20._wp .OR. & ! too large sea surface height ( > 20 m )
- & zmax(2) > 10._wp .OR. & ! too large velocity ( > 10 m/s)
- & zmax(3) >= 0._wp .OR. & ! negative or zero sea surface salinity
- & zmax(4) >= 100._wp .OR. & ! too large sea surface salinity ( > 100 )
- & zmax(4) < 0._wp .OR. & ! too large sea surface salinity (keep this line for sea-ice)
- & ISNAN( zmax(1) + zmax(2) + zmax(3) ) ) ) THEN ! NaN encounter in the tests
- IF( lk_mpp .AND. sn_cfctl%l_glochk ) THEN
- ! have use mpp_max (because sn_cfctl%l_glochk=.T. and distributed)
- CALL mpp_maxloc( 'stpctl', ABS(ssh(:,:,Kmm)) , ssmask(:,:) , zzz, ih )
- CALL mpp_maxloc( 'stpctl', ABS(uu(:,:,:,Kmm)) , umask (:,:,:), zzz, iu )
- CALL mpp_minloc( 'stpctl', ts(:,:,:,jp_sal,Kmm), tmask (:,:,:), zzz, is1 )
- CALL mpp_maxloc( 'stpctl', ts(:,:,:,jp_sal,Kmm), tmask (:,:,:), zzz, is2 )
+ ! !== error handling ==!
+ ! !== done by all processes at every time step ==!
+ !
+ IF( zmax(1) > 20._wp .OR. & ! too large sea surface height ( > 20 m )
+ & zmax(2) > 10._wp .OR. & ! too large velocity ( > 10 m/s)
+ & zmax(3) >= 0._wp .OR. & ! negative or zero sea surface salinity
+ & zmax(4) >= 100._wp .OR. & ! too large sea surface salinity ( > 100 )
+ & zmax(4) < 0._wp .OR. & ! too large sea surface salinity (keep this line for sea-ice)
+ & ISNAN( zmax(1) + zmax(2) + zmax(3) ) .OR. & ! NaN encounter in the tests
+ & ABS( zmax(1) + zmax(2) + zmax(3) ) > HUGE(1._wp) ) THEN ! Infinity encounter in the tests
+ !
+ iloc(:,:) = 0
+ IF( ll_colruns ) THEN ! zmax is global, so it is the same on all subdomains -> no dead lock with mpp_maxloc
+ ! 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
+ llmsk(Nis0:Nie0,Njs0:Nje0,1) = ssmask(Nis0:Nie0,Njs0:Nje0 ) == 1._wp ! define only the inner domain
+ CALL mpp_maxloc( 'stpctl', ABS(ssh(:,:, Kmm)), llmsk(:,:,1), zzz, iloc(1:2,1) ) ! mpp_maxloc ok if mask = F
+ llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain
+ CALL mpp_maxloc( 'stpctl', ABS( uu(:,:,:, Kmm)), llmsk(:,:,:), zzz, iloc(1:3,2) )
+ llmsk(Nis0:Nie0,Njs0:Nje0,:) = tmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain
+ CALL mpp_minloc( 'stpctl', ts(:,:,:,jp_sal,Kmm) , llmsk(:,:,:), zzz, iloc(1:3,3) )
+ CALL mpp_maxloc( 'stpctl', ts(:,:,:,jp_sal,Kmm) , llmsk(:,:,:), zzz, iloc(1:3,4) )
+ ! find which subdomain has the max.
+ iareamin(:) = jpnij+1 ; iareamax(:) = 0 ; iareasum(:) = 0
+ DO ji = 1, 9
+ IF( zmaxlocal(ji) == zmax(ji) ) THEN
+ iareamin(ji) = narea ; iareamax(ji) = narea ; iareasum(ji) = 1
+ ENDIF
+ END DO
+ CALL mpp_min( "stpctl", iareamin ) ! min over the global domain
+ CALL mpp_max( "stpctl", iareamax ) ! max over the global domain
+ 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
+ llmsk(Nis0:Nie0,Njs0:Nje0,1) = ssmask(Nis0:Nie0,Njs0:Nje0 ) == 1._wp ! define only the inner domain
+ iloc(1:2,1) = MAXLOC( ABS( ssh(:,:, Kmm)), mask = llmsk(:,:,1) )
+ 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(:,:,:) )
+ llmsk(Nis0:Nie0,Njs0:Nje0,:) = tmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain
+ 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, 4 ! local domain indices ==> global domain indices, excluding halos
+ iloc(1:2,ji) = (/ mig0(iloc(1,ji)), mjg0(iloc(2,ji)) /)
+ END DO
+ iareamin(:) = narea ; iareamax(:) = narea ; iareasum(:) = 1 ! this is local information
+ ENDIF
+ !
+ WRITE(ctmp1,*) ' stp_ctl: |ssh| > 20 m or |U| > 10 m/s or S <= 0 or S >= 100 or NaN encounter in the tests'
+ CALL wrt_line( ctmp2, kt, '|ssh| max', zmax(1), iloc(:,1), iareasum(1), iareamin(1), iareamax(1) )
+ CALL wrt_line( ctmp3, kt, '|U| max', zmax(2), iloc(:,2), iareasum(2), iareamin(2), iareamax(2) )
+ CALL wrt_line( ctmp4, kt, 'Sal min', -zmax(3), iloc(:,3), iareasum(3), iareamin(3), iareamax(3) )
+ CALL wrt_line( ctmp5, kt, 'Sal max', zmax(4), iloc(:,4), iareasum(4), iareamin(4), iareamax(4) )
+ IF( Agrif_Root() ) THEN
+ WRITE(ctmp6,*) ' ===> output of last computed fields in output.abort* files'
ELSE
- ! find local min and max locations
- ih(:) = MAXLOC( ABS( ssh(:,:,Kmm) ) ) + (/ nimpp - 1, njmpp - 1 /)
- iu(:) = MAXLOC( ABS( uu (:,:,:,Kmm) ) ) + (/ nimpp - 1, njmpp - 1, 0 /)
- is1(:) = MINLOC( ts(:,:,:,jp_sal,Kmm), mask = tmask(:,:,:) == 1._wp ) + (/ nimpp - 1, njmpp - 1, 0 /)
- is2(:) = MAXLOC( ts(:,:,:,jp_sal,Kmm), mask = tmask(:,:,:) == 1._wp ) + (/ nimpp - 1, njmpp - 1, 0 /)
- ENDIF
-
- WRITE(ctmp1,*) ' stp_ctl: |ssh| > 20 m or |U| > 10 m/s or S <= 0 or S >= 100 or NaN encounter in the tests'
- WRITE(ctmp2,9100) kt, zmax(1), ih(1) , ih(2)
- WRITE(ctmp3,9200) kt, zmax(2), iu(1) , iu(2) , iu(3)
- WRITE(ctmp4,9300) kt, - zmax(3), is1(1), is1(2), is1(3)
- WRITE(ctmp5,9400) kt, zmax(4), is2(1), is2(2), is2(3)
- WRITE(ctmp6,*) ' ===> output of last computed fields in output.abort.nc file'
-
+ WRITE(ctmp6,*) ' ===> output of last computed fields in '//TRIM(Agrif_CFixed())//'_output.abort* files'
+ ENDIF
+ !
CALL dia_wri_state( Kmm, 'output.abort' ) ! create an output.abort file
-
- IF( .NOT. sn_cfctl%l_glochk ) THEN
- WRITE(ctmp8,*) 'E R R O R message from sub-domain: ', narea
- CALL ctl_stop( 'STOP', ctmp1, ' ', ctmp8, ' ', ctmp2, ctmp3, ctmp4, ctmp5, ctmp6 )
- ELSE
- CALL ctl_stop( ctmp1, ' ', ctmp2, ctmp3, ctmp4, ctmp5, ' ', ctmp6, ' ' )
- ENDIF
-
- kindic = -3
- !
- ENDIF
- !
-9100 FORMAT (' kt=',i8,' |ssh| max: ',1pg11.4,', at i j : ',2i5)
-9200 FORMAT (' kt=',i8,' |U| max: ',1pg11.4,', at i j k: ',3i5)
-9300 FORMAT (' kt=',i8,' S min: ',1pg11.4,', at i j k: ',3i5)
-9400 FORMAT (' kt=',i8,' S max: ',1pg11.4,', at i j k: ',3i5)
+ !
+ 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 )
+ 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 )
+ ENDIF
+ !
+ ENDIF
+ !
+ IF( nstop > 0 ) THEN ! an error was detected and we did not abort yet...
+ ngrdstop = Agrif_Fixed() ! store which grid got this error
+ IF( .NOT. ll_colruns .AND. jpnij > 1 ) CALL ctl_stop( 'STOP' ) ! we must abort here to avoid MPI deadlock
+ ENDIF
+ !
9500 FORMAT(' it :', i8, ' |ssh|_max: ', D23.16, ' |U|_max: ', D23.16,' S_min: ', D23.16,' S_max: ', D23.16)
!
END SUBROUTINE stp_ctl
+
+
+ SUBROUTINE wrt_line( cdline, kt, cdprefix, pval, kloc, ksum, kmin, kmax )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE wrt_line ***
+ !!
+ !! ** Purpose : write information line
+ !!
+ !!----------------------------------------------------------------------
+ CHARACTER(len=*), INTENT( out) :: cdline
+ CHARACTER(len=*), INTENT(in ) :: cdprefix
+ REAL(wp), INTENT(in ) :: pval
+ INTEGER, DIMENSION(3), INTENT(in ) :: kloc
+ INTEGER, INTENT(in ) :: kt, ksum, kmin, kmax
+ !
+ CHARACTER(len=80) :: clsuff
+ CHARACTER(len=9 ) :: clkt, clsum, clmin, clmax
+ CHARACTER(len=9 ) :: cli, clj, clk
+ CHARACTER(len=1 ) :: clfmt
+ CHARACTER(len=4 ) :: cl4 ! needed to be able to compile with Agrif, I don't know why
+ INTEGER :: ifmtk
+ !!----------------------------------------------------------------------
+ WRITE(clkt , '(i9)') kt
+
+ WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpnij ,wp))) + 1 ! how many digits to we need to write ? (we decide max = 9)
+ !!! WRITE(clsum, '(i'//clfmt//')') ksum ! this is creating a compilation error with AGRIF
+ cl4 = '(i'//clfmt//')' ; WRITE(clsum, cl4) ksum
+ WRITE(clfmt, '(i1)') INT(LOG10(REAL(MAX(1,jpnij-1),wp))) + 1 ! how many digits to we need to write ? (we decide max = 9)
+ cl4 = '(i'//clfmt//')' ; WRITE(clmin, cl4) kmin-1
+ WRITE(clmax, cl4) kmax-1
+ !
+ WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpiglo,wp))) + 1 ! how many digits to we need to write jpiglo? (we decide max = 9)
+ cl4 = '(i'//clfmt//')' ; WRITE(cli, cl4) kloc(1) ! this is ok with AGRIF
+ WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpjglo,wp))) + 1 ! how many digits to we need to write jpjglo? (we decide max = 9)
+ cl4 = '(i'//clfmt//')' ; WRITE(clj, cl4) kloc(2) ! this is ok with AGRIF
+ !
+ IF( ksum == 1 ) THEN ; WRITE(clsuff,9100) TRIM(clmin)
+ ELSE ; WRITE(clsuff,9200) TRIM(clsum), TRIM(clmin), TRIM(clmax)
+ ENDIF
+ IF(kloc(3) == 0) THEN
+ ifmtk = INT(LOG10(REAL(jpk,wp))) + 1 ! how many digits to we need to write jpk? (we decide max = 9)
+ clk = REPEAT(' ', ifmtk) ! create the equivalent in blank string
+ WRITE(cdline,9300) TRIM(ADJUSTL(clkt)), TRIM(ADJUSTL(cdprefix)), pval, TRIM(cli), TRIM(clj), clk(1:ifmtk), TRIM(clsuff)
+ ELSE
+ WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpk,wp))) + 1 ! how many digits to we need to write jpk? (we decide max = 9)
+ !!! WRITE(clk, '(i'//clfmt//')') kloc(3) ! this is creating a compilation error with AGRIF
+ cl4 = '(i'//clfmt//')' ; WRITE(clk, cl4) kloc(3) ! this is ok with AGRIF
+ WRITE(cdline,9400) TRIM(ADJUSTL(clkt)), TRIM(ADJUSTL(cdprefix)), pval, TRIM(cli), TRIM(clj), TRIM(clk), TRIM(clsuff)
+ ENDIF
+ !
+9100 FORMAT('MPI rank ', a)
+9200 FORMAT('found in ', a, ' MPI tasks, spread out among ranks ', a, ' to ', a)
+9300 FORMAT('kt ', a, ' ', a, ' ', 1pg11.4, ' at i j ', a, ' ', a, ' ', a, ' ', a)
+9400 FORMAT('kt ', a, ' ', a, ' ', 1pg11.4, ' at i j k ', a, ' ', a, ' ', a, ' ', a)
+ !
+ END SUBROUTINE wrt_line
+
!!======================================================================
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/timing.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/timing.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/timing.F90 (revision 13540)
@@ -213,5 +213,5 @@
- SUBROUTINE timing_init
+ SUBROUTINE timing_init( clname )
!!----------------------------------------------------------------------
!! *** ROUTINE timing_init ***
@@ -221,10 +221,16 @@
REAL(wp) :: zdum
LOGICAL :: ll_f
-
+ CHARACTER(len=*), INTENT(in), OPTIONAL :: clname
+ CHARACTER(len=20) :: cln
+
+ IF( PRESENT(clname) ) THEN ; cln = clname
+ ELSE ; cln = 'timing.output'
+ ENDIF
+
IF( ln_onefile ) THEN
- IF( lwp) CALL ctl_opn( numtime, 'timing.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout,.TRUE., narea )
+ IF( lwp) CALL ctl_opn( numtime, cln, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout,.TRUE., narea )
lwriter = lwp
ELSE
- CALL ctl_opn( numtime, 'timing.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout,.FALSE., narea )
+ CALL ctl_opn( numtime, cln, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout,.FALSE., narea )
lwriter = .TRUE.
ENDIF
Index: /NEMO/branches/2020/r12377_ticket2386/src/OCE/trc_oce.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OCE/trc_oce.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OCE/trc_oce.F90 (revision 13540)
@@ -158,5 +158,4 @@
zchl = zrgb(1,jc)
irgb = NINT( 41 + 20.* LOG10( zchl ) + 1.e-15 )
- IF(lwp .AND. nn_print >= 1 ) WRITE(numout,*) ' jc =', jc, ' Chl = ', zchl, ' irgb = ', irgb
IF( irgb /= jc ) THEN
IF(lwp) WRITE(numout,*) ' jc =', jc, ' Chl = ', zchl, ' Chl class = ', irgb
Index: /NEMO/branches/2020/r12377_ticket2386/src/OFF/dtadyn.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OFF/dtadyn.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OFF/dtadyn.F90 (revision 13540)
@@ -23,5 +23,9 @@
USE c1d ! 1D configuration: lk_c1d
USE dom_oce ! ocean domain: variables
+#if ! defined key_qco
USE domvvl ! variable volume
+#else
+ USE domqco
+#endif
USE zdf_oce ! ocean vertical physics: variables
USE sbc_oce ! surface module: variables
@@ -52,5 +56,7 @@
PUBLIC dta_dyn_sed ! called by nemo_gcm
PUBLIC dta_dyn_atf ! called by nemo_gcm
+#if ! defined key_qco
PUBLIC dta_dyn_sf_interp ! called by nemo_gcm
+#endif
CHARACTER(len=100) :: cn_dir !: Root directory for location of ssr files
@@ -65,5 +71,5 @@
INTEGER , SAVE :: jf_uwd ! index of u-transport
INTEGER , SAVE :: jf_vwd ! index of v-transport
- INTEGER , SAVE :: jf_wwd ! index of v-transport
+ INTEGER , SAVE :: jf_wwd ! index of w-transport
INTEGER , SAVE :: jf_avt ! index of Kz
INTEGER , SAVE :: jf_mld ! index of mixed layer deptht
@@ -122,5 +128,5 @@
!
IF( kt == nit000 ) THEN ; nprevrec = 0
- ELSE ; nprevrec = sf_dyn(jf_tem)%nrec_a(2)
+ ELSE ; nprevrec = sf_dyn(jf_tem)%nrec(2,sf_dyn(jf_tem)%naa)
ENDIF
CALL fld_read( kt, 1, sf_dyn ) != read data at kt time step ==!
@@ -149,5 +155,10 @@
emp_b (:,:) = sf_dyn(jf_empb)%fnow(:,:,1) * tmask(:,:,1) ! E-P
zemp (:,:) = ( 0.5_wp * ( emp(:,:) + emp_b(:,:) ) + rnf(:,:) + fwbcorr ) * tmask(:,:,1)
- CALL dta_dyn_ssh( kt, zhdivtr, ssh(:,:,Kbb), zemp, ssh(:,:,Kaa), e3t(:,:,:,Kaa) ) != ssh, vertical scale factor & vertical transport
+#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
+#endif
DEALLOCATE( zemp , zhdivtr )
! Write in the tracer restart file
@@ -283,4 +294,11 @@
! ! fill sf with slf_i and control print
CALL fld_fill( sf_dyn, slf_d, cn_dir, 'dta_dyn_init', 'Data in file', 'namdta_dyn' )
+ sf_dyn(jf_uwd)%cltype = 'U' ; sf_dyn(jf_uwd)%zsgn = -1._wp
+ sf_dyn(jf_vwd)%cltype = 'V' ; sf_dyn(jf_vwd)%zsgn = -1._wp
+ !
+ IF( ln_trabbl ) THEN
+ sf_dyn(jf_ubl)%cltype = 'U' ; sf_dyn(jf_ubl)%zsgn = 1._wp
+ sf_dyn(jf_vbl)%cltype = 'V' ; sf_dyn(jf_vbl)%zsgn = 1._wp
+ END IF
!
! Open file for each variable to get his number of dimension
@@ -319,16 +337,20 @@
iom_varid( numrtr, 'sshn', ldstop = .FALSE. ) > 0 ) THEN
IF(lwp) WRITE(numout,*) ' ssh(:,:,Kmm) forcing fields read in the restart file for initialisation'
- CALL iom_get( numrtr, jpdom_autoglo, 'sshn', ssh(:,:,Kmm) )
- CALL iom_get( numrtr, jpdom_autoglo, 'sshb', ssh(:,:,Kbb) )
+ CALL iom_get( numrtr, jpdom_auto, 'sshn', ssh(:,:,Kmm) )
+ CALL iom_get( numrtr, jpdom_auto, 'sshb', ssh(:,:,Kbb) )
ELSE
IF(lwp) WRITE(numout,*) ' ssh(:,:,Kmm) forcing fields read in the restart file for initialisation'
CALL iom_open( 'restart', inum )
- CALL iom_get( inum, jpdom_autoglo, 'sshn', ssh(:,:,Kmm) )
- CALL iom_get( inum, jpdom_autoglo, 'sshb', ssh(:,:,Kbb) )
+ CALL iom_get( inum, jpdom_auto, 'sshn', ssh(:,:,Kmm) )
+ CALL iom_get( inum, jpdom_auto, 'sshb', ssh(:,:,Kbb) )
CALL iom_close( inum ) ! close file
ENDIF
!
+#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) * tmask(:,:,1) / ( ht_0(:,:) + 1.0 - tmask(:,:,1) ) )
+ e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * ( 1._wp + ssh(:,:,Kmm) * r1_ht_0(:,:) * tmask(:,:,jk) )
ENDDO
e3t(:,:,jpk,Kaa) = e3t_0(:,:,jpk)
@@ -342,5 +364,5 @@
! ------------------------------------
CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3w(:,:,:,Kmm), 'W' )
-
+!!gm this should be computed from ssh(Kbb)
e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm)
e3u(:,:,:,Kbb) = e3u(:,:,:,Kmm)
@@ -352,5 +374,5 @@
gdepw(:,:,1,Kmm) = 0.0_wp
- DO_3D_11_11( 2, jpk )
+ DO_3D( 1, 1, 1, 1, 2, jpk )
! zcoef = (tmask(ji,jj,jk) - wmask(ji,jj,jk)) ! 0 everywhere
! tmask = wmask, ie everywhere expect at jk = mikt
@@ -367,4 +389,5 @@
!
ENDIF
+#endif
!
IF( ln_dynrnf .AND. ln_dynrnf_depth ) THEN ! read depht over which runoffs are distributed
@@ -372,9 +395,9 @@
IF(lwp) WRITE(numout,*) ' read in the file depht over which runoffs are distributed'
CALL iom_open ( "runoffs", inum ) ! open file
- CALL iom_get ( inum, jpdom_data, 'rodepth', h_rnf ) ! read the river mouth array
+ CALL iom_get ( inum, jpdom_global, 'rodepth', h_rnf ) ! read the river mouth array
CALL iom_close( inum ) ! close file
!
nk_rnf(:,:) = 0 ! set the number of level over which river runoffs are applied
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
IF( h_rnf(ji,jj) > 0._wp ) THEN
jk = 2
@@ -389,5 +412,5 @@
ENDIF
END_2D
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 ) ! set the associated depth
h_rnf(ji,jj) = 0._wp
DO jk = 1, nk_rnf(ji,jj)
@@ -413,4 +436,5 @@
END SUBROUTINE dta_dyn_init
+
SUBROUTINE dta_dyn_sed( kt, Kmm )
!!----------------------------------------------------------------------
@@ -434,5 +458,5 @@
!
IF( kt == nit000 ) THEN ; nprevrec = 0
- ELSE ; nprevrec = sf_dyn(jf_tem)%nrec_a(2)
+ ELSE ; nprevrec = sf_dyn(jf_tem)%nrec(2,sf_dyn(jf_tem)%naa)
ENDIF
CALL fld_read( kt, 1, sf_dyn ) != read data at kt time step ==!
@@ -529,4 +553,5 @@
END SUBROUTINE dta_dyn_sed_init
+
SUBROUTINE dta_dyn_atf( kt, Kbb, Kmm, Kaa )
!!---------------------------------------------------------------------
@@ -552,4 +577,6 @@
END SUBROUTINE dta_dyn_atf
+
+#if ! defined key_qco
SUBROUTINE dta_dyn_sf_interp( kt, Kmm )
!!---------------------------------------------------------------------
@@ -580,5 +607,5 @@
gdepw(:,:,1,Kmm) = 0.0_wp
!
- DO_3D_11_11( 2, jpk )
+ DO_3D( 1, 1, 1, 1, 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)
@@ -588,4 +615,6 @@
!
END SUBROUTINE dta_dyn_sf_interp
+#endif
+
SUBROUTINE dta_dyn_ssh( kt, phdivtr, psshb, pemp, pssha, pe3ta )
@@ -606,5 +635,5 @@
!! The boundary conditions are w=0 at the bottom (no flux)
!!
- !! ** action : ssh(:,:,Kaa) / e3t(:,:,:,Kaa) / ww
+ !! ** action : ssh(:,:,Kaa) / e3t(:,:,k,Kaa) / ww
!!
!! Reference : Leclair, M., and G. Madec, 2009, Ocean Modelling.
@@ -630,9 +659,10 @@
! ! Sea surface elevation time-stepping
pssha(:,:) = ( psshb(:,:) - z2dt * ( r1_rho0 * pemp(:,:) + zhdiv(:,:) ) ) * ssmask(:,:)
- ! !
- ! ! After acale factors at t-points ( z_star coordinate )
+ !
+ IF( PRESENT( pe3ta ) ) THEN ! After acale factors at t-points ( z_star coordinate )
DO jk = 1, jpkm1
- pe3ta(:,:,jk) = e3t_0(:,:,jk) * ( 1._wp + pssha(:,:) * tmask(:,:,1) / ( ht_0(:,:) + 1.0 - tmask(:,:,1) ) )
+ pe3ta(:,:,jk) = e3t_0(:,:,jk) * ( 1._wp + pssha(:,:) * r1_ht_0(:,:) * tmask(:,:,jk) )
END DO
+ ENDIF
!
END SUBROUTINE dta_dyn_ssh
@@ -657,5 +687,5 @@
!!----------------------------------------------------------------------
!
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 ) ! 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
@@ -686,10 +716,11 @@
!!---------------------------------------------------------------------
!
- IF( sf_dyn(jf_tem)%ln_tint ) THEN ! Computes slopes (here avt is used as workspace)
+ IF( sf_dyn(jf_tem)%ln_tint ) THEN ! Computes slopes (here avt is used as workspace)
+ !
IF( kt == nit000 ) THEN
IF(lwp) WRITE(numout,*) ' Compute new slopes at kt = ', kt
- zts(:,:,:,jp_tem) = sf_dyn(jf_tem)%fdta(:,:,:,1) * tmask(:,:,:) ! temperature
- zts(:,:,:,jp_sal) = sf_dyn(jf_sal)%fdta(:,:,:,1) * tmask(:,:,:) ! salinity
- avt(:,:,:) = sf_dyn(jf_avt)%fdta(:,:,:,1) * tmask(:,:,:) ! vertical diffusive coef.
+ 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.
CALL compute_slopes( kt, zts, zuslp, zvslp, zwslpi, zwslpj, Kbb, Kmm )
uslpdta (:,:,:,1) = zuslp (:,:,:)
@@ -698,7 +729,7 @@
wslpjdta(:,:,:,1) = zwslpj(:,:,:)
!
- zts(:,:,:,jp_tem) = sf_dyn(jf_tem)%fdta(:,:,:,2) * tmask(:,:,:) ! temperature
- zts(:,:,:,jp_sal) = sf_dyn(jf_sal)%fdta(:,:,:,2) * tmask(:,:,:) ! salinity
- avt(:,:,:) = sf_dyn(jf_avt)%fdta(:,:,:,2) * tmask(:,:,:) ! vertical diffusive coef.
+ 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.
CALL compute_slopes( kt, zts, zuslp, zvslp, zwslpi, zwslpj, Kbb, Kmm )
uslpdta (:,:,:,2) = zuslp (:,:,:)
@@ -709,6 +740,6 @@
!
iswap = 0
- IF( sf_dyn(jf_tem)%nrec_a(2) - nprevrec /= 0 ) iswap = 1
- IF( nsecdyn > sf_dyn(jf_tem)%nrec_b(2) .AND. iswap == 1 ) THEN ! read/update the after data
+ IF( sf_dyn(jf_tem)%nrec(2,sf_dyn(jf_tem)%naa) - nprevrec /= 0 ) iswap = 1
+ IF( nsecdyn > sf_dyn(jf_tem)%nrec(2,sf_dyn(jf_tem)%nbb) .AND. iswap == 1 ) THEN ! read/update the after data
IF(lwp) WRITE(numout,*) ' Compute new slopes at kt = ', kt
uslpdta (:,:,:,1) = uslpdta (:,:,:,2) ! swap the data
@@ -717,7 +748,7 @@
wslpjdta(:,:,:,1) = wslpjdta(:,:,:,2)
!
- zts(:,:,:,jp_tem) = sf_dyn(jf_tem)%fdta(:,:,:,2) * tmask(:,:,:) ! temperature
- zts(:,:,:,jp_sal) = sf_dyn(jf_sal)%fdta(:,:,:,2) * tmask(:,:,:) ! salinity
- avt(:,:,:) = sf_dyn(jf_avt)%fdta(:,:,:,2) * tmask(:,:,:) ! vertical diffusive coef.
+ 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.
CALL compute_slopes( kt, zts, zuslp, zvslp, zwslpi, zwslpj, Kbb, Kmm )
!
@@ -731,6 +762,6 @@
!
IF( sf_dyn(jf_tem)%ln_tint ) THEN
- ztinta = REAL( nsecdyn - sf_dyn(jf_tem)%nrec_b(2), wp ) &
- & / REAL( sf_dyn(jf_tem)%nrec_a(2) - sf_dyn(jf_tem)%nrec_b(2), wp )
+ ztinta = REAL( nsecdyn - sf_dyn(jf_tem)%nrec(2,sf_dyn(jf_tem)%nbb), wp ) &
+ & / REAL( sf_dyn(jf_tem)%nrec(2,sf_dyn(jf_tem)%naa) - sf_dyn(jf_tem)%nrec(2,sf_dyn(jf_tem)%nbb), wp )
ztintb = 1. - ztinta
IF( l_ldfslp .AND. .NOT.lk_c1d ) THEN ! Computes slopes (here avt is used as workspace)
Index: /NEMO/branches/2020/r12377_ticket2386/src/OFF/nemogcm.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/OFF/nemogcm.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/OFF/nemogcm.F90 (revision 13540)
@@ -28,4 +28,8 @@
USE usrdef_nam ! user defined configuration
USE eosbn2 ! equation of state (eos bn2 routine)
+#if defined key_qco
+ USE domqco ! tools for scale factor (dom_qco_r3c routine)
+#endif
+ USE bdyini ! open boundary cond. setting (bdy_init routine)
! ! ocean physics
USE ldftra ! lateral diffusivity setting (ldf_tra_init routine)
@@ -59,6 +63,7 @@
USE timing ! Timing
USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)
- USE lbcnfd , ONLY : isendto, nsndto, nfsloop, nfeloop ! Setup of north fold exchanges
+ USE lbcnfd , ONLY : isendto, nsndto ! Setup of north fold exchanges
USE step, ONLY : Nbb, Nnn, Naa, Nrhs ! time level indices
+ USE halo_mng
IMPLICIT NONE
@@ -90,5 +95,5 @@
!! Madec, 2008, internal report, IPSL.
!!----------------------------------------------------------------------
- INTEGER :: istp, indic ! time step index
+ INTEGER :: istp ! time step index
!!----------------------------------------------------------------------
@@ -117,7 +122,17 @@
CALL dta_dyn ( istp, Nbb, Nnn, Naa ) ! Interpolation of the dynamical fields
#endif
+#if ! defined key_sed_off
+ IF( .NOT.ln_linssh ) THEN
+ CALL dta_dyn_atf( istp, Nbb, Nnn, Naa ) ! time filter of sea surface height and vertical scale factors
+# if defined key_qco
+ CALL dom_qco_r3c( ssh(:,:,Kmm), r3t_f, r3u_f, r3v_f )
+# endif
+ ENDIF
CALL trc_stp ( istp, Nbb, Nnn, Nrhs, Naa ) ! time-stepping
-#if ! defined key_sed_off
- IF( .NOT.ln_linssh ) CALL dta_dyn_atf( istp, Nbb, Nnn, Naa ) ! time filter of sea surface height and vertical scale factors
+# if defined key_qco
+ !r3t(:,:,Kmm) = r3t_f(:,:) ! update ssh to h0 ratio
+ !r3u(:,:,Kmm) = r3u_f(:,:)
+ !r3v(:,:,Kmm) = r3v_f(:,:)
+# endif
#endif
! Swap time levels
@@ -127,8 +142,10 @@
Naa = Nrhs
!
+#if ! defined key_qco
#if ! defined key_sed_off
IF( .NOT.ln_linssh ) CALL dta_dyn_sf_interp( istp, Nnn ) ! calculate now grid parameters
#endif
- CALL stp_ctl ( istp, indic ) ! Time loop: control and print
+#endif
+ CALL stp_ctl ( istp ) ! Time loop: control and print
istp = istp + 1
END DO
@@ -145,5 +162,6 @@
IF( nstop /= 0 .AND. lwp ) THEN ! error print
WRITE(ctmp1,*) ' ==>>> nemo_gcm: a total of ', nstop, ' errors have been found'
- CALL ctl_stop( ctmp1 )
+ WRITE(ctmp2,*) ' Look for "E R R O R" messages in all existing ocean_output* files'
+ CALL ctl_stop( ' ', ctmp1, ' ', ctmp2 )
ENDIF
!
@@ -175,11 +193,11 @@
INTEGER :: ios, ilocal_comm ! local integers
!!
- NAMELIST/namctl/ sn_cfctl, nn_print, nn_ictls, nn_ictle, &
- & nn_isplt , nn_jsplt, nn_jctls, nn_jctle, &
- & ln_timing, ln_diacfl
+ NAMELIST/namctl/ sn_cfctl, ln_timing, ln_diacfl, &
+ & nn_isplt, nn_jsplt, nn_ictls, nn_ictle, nn_jctls, nn_jctle
NAMELIST/namcfg/ ln_read_cfg, cn_domcfg, ln_closea, ln_write_cfg, cn_domcfg_out, ln_use_jattr
!!----------------------------------------------------------------------
!
cxios_context = 'nemo'
+ nn_hls = 1
!
! !-------------------------------------------------!
@@ -209,5 +227,11 @@
IF( lwm ) CALL ctl_opn( numond, 'output.namelist.dyn', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. )
! open /dev/null file to be able to supress output write easily
+ IF( Agrif_Root() ) THEN
CALL ctl_opn( numnul, '/dev/null', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. )
+#ifdef key_agrif
+ ELSE
+ numnul = Agrif_Parent(numnul)
+#endif
+ ENDIF
!
! !--------------------!
@@ -221,20 +245,6 @@
!
! finalize the definition of namctl variables
- IF( sn_cfctl%l_allon ) THEN
- ! Turn on all options.
- CALL nemo_set_cfctl( sn_cfctl, .TRUE., .TRUE. )
- ! Ensure all processors are active
- sn_cfctl%procmin = 0 ; sn_cfctl%procmax = 1000000 ; sn_cfctl%procincr = 1
- ELSEIF( sn_cfctl%l_config ) THEN
- ! Activate finer control of report outputs
- ! optionally switch off output from selected areas (note this only
- ! applies to output which does not involve global communications)
- IF( ( narea < sn_cfctl%procmin .OR. narea > sn_cfctl%procmax ) .OR. &
- & ( MOD( narea - sn_cfctl%procmin, sn_cfctl%procincr ) /= 0 ) ) &
- & CALL nemo_set_cfctl( sn_cfctl, .FALSE., .FALSE. )
- ELSE
- ! turn off all options.
- CALL nemo_set_cfctl( sn_cfctl, .FALSE., .TRUE. )
- ENDIF
+ IF( narea < sn_cfctl%procmin .OR. narea > sn_cfctl%procmax .OR. MOD( narea - sn_cfctl%procmin, sn_cfctl%procincr ) /= 0 ) &
+ & CALL nemo_set_cfctl( sn_cfctl, .FALSE. )
!
lwp = (narea == 1) .OR. sn_cfctl%l_oceout ! control of all listing output print
@@ -282,7 +292,7 @@
!
IF( ln_read_cfg ) THEN ! Read sizes in domain configuration file
- CALL domain_cfg ( cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio )
+ CALL domain_cfg ( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, jperio )
ELSE ! user-defined namelist
- CALL usr_def_nam( cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio )
+ CALL usr_def_nam( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, jperio )
ENDIF
!
@@ -296,4 +306,5 @@
CALL mpp_init
+ CALL halo_mng_init()
! Now we know the dimensions of the grid and numout has been set: we can allocate arrays
CALL nemo_alloc()
@@ -301,5 +312,4 @@
! Initialise time level indices
Nbb = 1; Nnn = 2; Naa = 3; Nrhs = Naa
-
! !-------------------------------!
@@ -323,4 +333,5 @@
CALL sbc_init( Nbb, Nnn, Naa ) ! Forcings : surface module
+ CALL bdy_init ! Open boundaries initialisation
! ! Tracer physics
@@ -365,7 +376,4 @@
WRITE(numout,*) '~~~~~~~~'
WRITE(numout,*) ' Namelist namctl'
- WRITE(numout,*) ' sn_cfctl%l_glochk = ', sn_cfctl%l_glochk
- WRITE(numout,*) ' sn_cfctl%l_allon = ', sn_cfctl%l_allon
- WRITE(numout,*) ' finer control over o/p sn_cfctl%l_config = ', sn_cfctl%l_config
WRITE(numout,*) ' sn_cfctl%l_runstat = ', sn_cfctl%l_runstat
WRITE(numout,*) ' sn_cfctl%l_trcstat = ', sn_cfctl%l_trcstat
@@ -379,23 +387,9 @@
WRITE(numout,*) ' sn_cfctl%procincr = ', sn_cfctl%procincr
WRITE(numout,*) ' sn_cfctl%ptimincr = ', sn_cfctl%ptimincr
- WRITE(numout,*) ' level of print nn_print = ', nn_print
- WRITE(numout,*) ' Start i indice for SUM control nn_ictls = ', nn_ictls
- WRITE(numout,*) ' End i indice for SUM control nn_ictle = ', nn_ictle
- WRITE(numout,*) ' Start j indice for SUM control nn_jctls = ', nn_jctls
- WRITE(numout,*) ' End j indice for SUM control nn_jctle = ', nn_jctle
- WRITE(numout,*) ' number of proc. following i nn_isplt = ', nn_isplt
- WRITE(numout,*) ' number of proc. following j nn_jsplt = ', nn_jsplt
WRITE(numout,*) ' timing by routine ln_timing = ', ln_timing
WRITE(numout,*) ' CFL diagnostics ln_diacfl = ', ln_diacfl
ENDIF
- !
- nprint = nn_print ! convert DOCTOR namelist names into OLD names
- nictls = nn_ictls
- nictle = nn_ictle
- njctls = nn_jctls
- njctle = nn_jctle
- isplt = nn_isplt
- jsplt = nn_jsplt
-
+
+ IF( .NOT.ln_read_cfg ) ln_closea = .false. ! dealing possible only with a domcfg file
IF(lwp) THEN ! control print
WRITE(numout,*)
@@ -408,44 +402,4 @@
WRITE(numout,*) ' use file attribute if exists as i/p j-start ln_use_jattr = ', ln_use_jattr
ENDIF
- IF( .NOT.ln_read_cfg ) ln_closea = .false. ! dealing possible only with a domcfg file
- !
- ! ! Parameter control
- !
- IF( sn_cfctl%l_prtctl .OR. sn_cfctl%l_prttrc ) THEN ! sub-domain area indices for the control prints
- IF( lk_mpp .AND. jpnij > 1 ) THEN
- isplt = jpni ; jsplt = jpnj ; ijsplt = jpni*jpnj ! the domain is forced to the real split domain
- ELSE
- IF( isplt == 1 .AND. jsplt == 1 ) THEN
- CALL ctl_warn( ' - isplt & jsplt are equal to 1', &
- & ' - the print control will be done over the whole domain' )
- ENDIF
- ijsplt = isplt * jsplt ! total number of processors ijsplt
- ENDIF
- IF(lwp) WRITE(numout,*)' - The total number of processors over which the'
- IF(lwp) WRITE(numout,*)' print control will be done is ijsplt : ', ijsplt
- !
- ! ! indices used for the SUM control
- IF( nictls+nictle+njctls+njctle == 0 ) THEN ! print control done over the default area
- lsp_area = .FALSE.
- ELSE ! print control done over a specific area
- lsp_area = .TRUE.
- IF( nictls < 1 .OR. nictls > jpiglo ) THEN
- CALL ctl_warn( ' - nictls must be 1<=nictls>=jpiglo, it is forced to 1' )
- nictls = 1
- ENDIF
- IF( nictle < 1 .OR. nictle > jpiglo ) THEN
- CALL ctl_warn( ' - nictle must be 1<=nictle>=jpiglo, it is forced to jpiglo' )
- nictle = jpiglo
- ENDIF
- IF( njctls < 1 .OR. njctls > jpjglo ) THEN
- CALL ctl_warn( ' - njctls must be 1<=njctls>=jpjglo, it is forced to 1' )
- njctls = 1
- ENDIF
- IF( njctle < 1 .OR. njctle > jpjglo ) THEN
- CALL ctl_warn( ' - njctle must be 1<=njctle>=jpjglo, it is forced to jpjglo' )
- njctle = jpjglo
- ENDIF
- ENDIF
- ENDIF
!
IF( 1._wp /= SIGN(1._wp,-0._wp) ) CALL ctl_stop( 'nemo_ctl: The intrinsec SIGN function follows f2003 standard.', &
@@ -486,4 +440,5 @@
USE zdf_oce, ONLY : zdf_oce_alloc
USE trc_oce, ONLY : trc_oce_alloc
+ USE bdy_oce, ONLY : bdy_oce_alloc
!
INTEGER :: ierr
@@ -495,4 +450,5 @@
ierr = ierr + zdf_oce_alloc() ! ocean vertical physics
ierr = ierr + trc_oce_alloc() ! shared TRC / TRA arrays
+ ierr = ierr + bdy_oce_alloc() ! bdy masks (incl. initialization)
!
CALL mpp_sum( 'nemogcm', ierr )
@@ -501,25 +457,18 @@
END SUBROUTINE nemo_alloc
- SUBROUTINE nemo_set_cfctl(sn_cfctl, setto, for_all )
+ SUBROUTINE nemo_set_cfctl(sn_cfctl, setto )
!!----------------------------------------------------------------------
!! *** ROUTINE nemo_set_cfctl ***
!!
!! ** Purpose : Set elements of the output control structure to setto.
- !! for_all should be .false. unless all areas are to be
- !! treated identically.
- !!
+ !!
!! ** Method : Note this routine can be used to switch on/off some
- !! types of output for selected areas but any output types
- !! that involve global communications (e.g. mpp_max, glob_sum)
- !! should be protected from selective switching by the
- !! for_all argument
- !!----------------------------------------------------------------------
- LOGICAL :: setto, for_all
- TYPE(sn_ctl) :: sn_cfctl
- !!----------------------------------------------------------------------
- IF( for_all ) THEN
- sn_cfctl%l_runstat = setto
- sn_cfctl%l_trcstat = setto
- ENDIF
+ !! types of output for selected areas.
+ !!----------------------------------------------------------------------
+ TYPE(sn_ctl), INTENT(inout) :: sn_cfctl
+ LOGICAL , INTENT(in ) :: setto
+ !!----------------------------------------------------------------------
+ sn_cfctl%l_runstat = setto
+ sn_cfctl%l_trcstat = setto
sn_cfctl%l_oceout = setto
sn_cfctl%l_layout = setto
@@ -551,5 +500,5 @@
- SUBROUTINE stp_ctl( kt, kindic )
+ SUBROUTINE stp_ctl( kt )
!!----------------------------------------------------------------------
!! *** ROUTINE stp_ctl ***
@@ -562,5 +511,4 @@
!!----------------------------------------------------------------------
INTEGER, INTENT(in ) :: kt ! ocean time-step index
- INTEGER, INTENT(inout) :: kindic ! indicator of solver convergence
!!----------------------------------------------------------------------
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/SAO/nemogcm.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/SAO/nemogcm.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/SAO/nemogcm.F90 (revision 13540)
@@ -29,11 +29,14 @@
USE sao_intp
!
+ USE prtctl ! Print control
+ USE in_out_manager ! I/O manager
USE lib_mpp ! distributed memory computing
USE mppini ! shared/distributed memory setting (mpp_init routine)
- USE lbcnfd , ONLY : isendto, nsndto, nfsloop, nfeloop ! Setup of north fold exchanges
+ USE lbcnfd , ONLY : isendto, nsndto ! Setup of north fold exchanges
USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)
#if defined key_iomput
USE xios ! xIOserver
#endif
+ USE halo_mng
IMPLICIT NONE
@@ -91,11 +94,11 @@
INTEGER :: ios, ilocal_comm ! local integer
!
- NAMELIST/namctl/ sn_cfctl, nn_print, nn_ictls, nn_ictle, &
- & nn_isplt , nn_jsplt, nn_jctls, nn_jctle, &
- & ln_timing, ln_diacfl
+ NAMELIST/namctl/ sn_cfctl, ln_timing, ln_diacfl, &
+ & nn_isplt, nn_jsplt, nn_ictls, nn_ictle, nn_jctls, nn_jctle
NAMELIST/namcfg/ ln_read_cfg, cn_domcfg, ln_closea, ln_write_cfg, cn_domcfg_out, ln_use_jattr
!!----------------------------------------------------------------------
!
cxios_context = 'nemo'
+ nn_hls = 1
!
! !-------------------------------------------------!
@@ -139,5 +142,11 @@
IF( lwm ) CALL ctl_opn( numond, 'output.namelist.dyn', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. )
! open /dev/null file to be able to supress output write easily
+ IF( Agrif_Root() ) THEN
CALL ctl_opn( numnul, '/dev/null', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. )
+#ifdef key_agrif
+ ELSE
+ numnul = Agrif_Parent(numnul)
+#endif
+ ENDIF
!
! !--------------------!
@@ -151,20 +160,6 @@
!
! finalize the definition of namctl variables
- IF( sn_cfctl%l_allon ) THEN
- ! Turn on all options.
- CALL nemo_set_cfctl( sn_cfctl, .TRUE., .TRUE. )
- ! Ensure all processors are active
- sn_cfctl%procmin = 0 ; sn_cfctl%procmax = 1000000 ; sn_cfctl%procincr = 1
- ELSEIF( sn_cfctl%l_config ) THEN
- ! Activate finer control of report outputs
- ! optionally switch off output from selected areas (note this only
- ! applies to output which does not involve global communications)
- IF( ( narea < sn_cfctl%procmin .OR. narea > sn_cfctl%procmax ) .OR. &
- & ( MOD( narea - sn_cfctl%procmin, sn_cfctl%procincr ) /= 0 ) ) &
- & CALL nemo_set_cfctl( sn_cfctl, .FALSE., .FALSE. )
- ELSE
- ! turn off all options.
- CALL nemo_set_cfctl( sn_cfctl, .FALSE., .TRUE. )
- ENDIF
+ IF( narea < sn_cfctl%procmin .OR. narea > sn_cfctl%procmax .OR. MOD( narea - sn_cfctl%procmin, sn_cfctl%procincr ) /= 0 ) &
+ & CALL nemo_set_cfctl( sn_cfctl, .FALSE. )
!
lwp = (narea == 1) .OR. sn_cfctl%l_oceout ! control of all listing output print
@@ -212,7 +207,7 @@
!
IF( ln_read_cfg ) THEN ! Read sizes in domain configuration file
- CALL domain_cfg ( cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio )
+ CALL domain_cfg ( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, jperio )
ELSE ! user-defined namelist
- CALL usr_def_nam( cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio )
+ CALL usr_def_nam( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, jperio )
ENDIF
!
@@ -224,4 +219,5 @@
CALL mpp_init
+ CALL halo_mng_init()
! Now we know the dimensions of the grid and numout has been set: we can allocate arrays
CALL nemo_alloc()
@@ -263,7 +259,4 @@
WRITE(numout,*) '~~~~~~~~'
WRITE(numout,*) ' Namelist namctl'
- WRITE(numout,*) ' sn_cfctl%l_glochk = ', sn_cfctl%l_glochk
- WRITE(numout,*) ' sn_cfctl%l_allon = ', sn_cfctl%l_allon
- WRITE(numout,*) ' finer control over o/p sn_cfctl%l_config = ', sn_cfctl%l_config
WRITE(numout,*) ' sn_cfctl%l_runstat = ', sn_cfctl%l_runstat
WRITE(numout,*) ' sn_cfctl%l_trcstat = ', sn_cfctl%l_trcstat
@@ -277,23 +270,9 @@
WRITE(numout,*) ' sn_cfctl%procincr = ', sn_cfctl%procincr
WRITE(numout,*) ' sn_cfctl%ptimincr = ', sn_cfctl%ptimincr
- WRITE(numout,*) ' level of print nn_print = ', nn_print
- WRITE(numout,*) ' Start i indice for SUM control nn_ictls = ', nn_ictls
- WRITE(numout,*) ' End i indice for SUM control nn_ictle = ', nn_ictle
- WRITE(numout,*) ' Start j indice for SUM control nn_jctls = ', nn_jctls
- WRITE(numout,*) ' End j indice for SUM control nn_jctle = ', nn_jctle
- WRITE(numout,*) ' number of proc. following i nn_isplt = ', nn_isplt
- WRITE(numout,*) ' number of proc. following j nn_jsplt = ', nn_jsplt
WRITE(numout,*) ' timing by routine ln_timing = ', ln_timing
WRITE(numout,*) ' CFL diagnostics ln_diacfl = ', ln_diacfl
ENDIF
!
- nprint = nn_print ! convert DOCTOR namelist names into OLD names
- nictls = nn_ictls
- nictle = nn_ictle
- njctls = nn_jctls
- njctle = nn_jctle
- isplt = nn_isplt
- jsplt = nn_jsplt
-
+ IF( .NOT.ln_read_cfg ) ln_closea = .false. ! dealing possible only with a domcfg file
IF(lwp) THEN ! control print
WRITE(numout,*)
@@ -305,44 +284,4 @@
WRITE(numout,*) ' filename to be written cn_domcfg_out = ', TRIM(cn_domcfg_out)
WRITE(numout,*) ' use file attribute if exists as i/p j-start ln_use_jattr = ', ln_use_jattr
- ENDIF
- IF( .NOT.ln_read_cfg ) ln_closea = .false. ! dealing possible only with a domcfg file
- !
- ! ! Parameter control
- !
- IF( sn_cfctl%l_prtctl .OR. sn_cfctl%l_prttrc ) THEN ! sub-domain area indices for the control prints
- IF( lk_mpp .AND. jpnij > 1 ) THEN
- isplt = jpni ; jsplt = jpnj ; ijsplt = jpni*jpnj ! the domain is forced to the real split domain
- ELSE
- IF( isplt == 1 .AND. jsplt == 1 ) THEN
- CALL ctl_warn( ' - isplt & jsplt are equal to 1', &
- & ' - the print control will be done over the whole domain' )
- ENDIF
- ijsplt = isplt * jsplt ! total number of processors ijsplt
- ENDIF
- IF(lwp) WRITE(numout,*)' - The total number of processors over which the'
- IF(lwp) WRITE(numout,*)' print control will be done is ijsplt : ', ijsplt
- !
- ! ! indices used for the SUM control
- IF( nictls+nictle+njctls+njctle == 0 ) THEN ! print control done over the default area
- lsp_area = .FALSE.
- ELSE ! print control done over a specific area
- lsp_area = .TRUE.
- IF( nictls < 1 .OR. nictls > jpiglo ) THEN
- CALL ctl_warn( ' - nictls must be 1<=nictls>=jpiglo, it is forced to 1' )
- nictls = 1
- ENDIF
- IF( nictle < 1 .OR. nictle > jpiglo ) THEN
- CALL ctl_warn( ' - nictle must be 1<=nictle>=jpiglo, it is forced to jpiglo' )
- nictle = jpiglo
- ENDIF
- IF( njctls < 1 .OR. njctls > jpjglo ) THEN
- CALL ctl_warn( ' - njctls must be 1<=njctls>=jpjglo, it is forced to 1' )
- njctls = 1
- ENDIF
- IF( njctle < 1 .OR. njctle > jpjglo ) THEN
- CALL ctl_warn( ' - njctle must be 1<=njctle>=jpjglo, it is forced to jpjglo' )
- njctle = jpjglo
- ENDIF
- ENDIF
ENDIF
!
@@ -403,25 +342,18 @@
END SUBROUTINE nemo_alloc
- SUBROUTINE nemo_set_cfctl(sn_cfctl, setto, for_all )
+ SUBROUTINE nemo_set_cfctl(sn_cfctl, setto )
!!----------------------------------------------------------------------
!! *** ROUTINE nemo_set_cfctl ***
!!
!! ** Purpose : Set elements of the output control structure to setto.
- !! for_all should be .false. unless all areas are to be
- !! treated identically.
!!
!! ** Method : Note this routine can be used to switch on/off some
- !! types of output for selected areas but any output types
- !! that involve global communications (e.g. mpp_max, glob_sum)
- !! should be protected from selective switching by the
- !! for_all argument
- !!----------------------------------------------------------------------
- LOGICAL :: setto, for_all
- TYPE(sn_ctl) :: sn_cfctl
- !!----------------------------------------------------------------------
- IF( for_all ) THEN
- sn_cfctl%l_runstat = setto
- sn_cfctl%l_trcstat = setto
- ENDIF
+ !! types of output for selected areas.
+ !!----------------------------------------------------------------------
+ TYPE(sn_ctl), INTENT(inout) :: sn_cfctl
+ LOGICAL , INTENT(in ) :: setto
+ !!----------------------------------------------------------------------
+ sn_cfctl%l_runstat = setto
+ sn_cfctl%l_trcstat = setto
sn_cfctl%l_oceout = setto
sn_cfctl%l_layout = setto
Index: /NEMO/branches/2020/r12377_ticket2386/src/SAO/sao_read.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/SAO/sao_read.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/SAO/sao_read.F90 (revision 13540)
@@ -10,5 +10,5 @@
USE netcdf
USE oce, ONLY: tsn, sshn
- USE dom_oce, ONLY: nlci, nlcj, nimpp, njmpp, tmask
+ USE dom_oce, ONLY: nimpp, njmpp, tmask
USE par_oce, ONLY: jpi, jpj, jpk
!
@@ -94,7 +94,7 @@
IF (ifcst .LE. ntimes) THEN
! Allocate temporary temperature array
- ALLOCATE(temp_tn(nlci,nlcj,jpk))
- ALLOCATE(temp_sn(nlci,nlcj,jpk))
- ALLOCATE(temp_sshn(nlci,nlcj))
+ ALLOCATE(temp_tn(jpi,jpj,jpk))
+ ALLOCATE(temp_sn(jpi,jpj,jpk))
+ ALLOCATE(temp_sshn(jpi,jpj))
! Set temp_tn, temp_sn to 0.
@@ -104,8 +104,8 @@
! Create start and count arrays
- start_n = (/ nimpp, njmpp, 1, ifcst /)
- count_n = (/ nlci, nlcj, jpk, 1 /)
- start_s = (/ nimpp, njmpp, ifcst /)
- count_s = (/ nlci, nlcj, 1 /)
+ start_n = (/ nimpp, njmpp, 1, ifcst /)
+ count_n = (/ jpi, jpj, jpk, 1 /)
+ start_s = (/ nimpp, njmpp , ifcst /)
+ count_s = (/ jpi, jpj, 1 /)
! Read information into temporary arrays
@@ -138,22 +138,8 @@
! Mask out missing data index
- tsn(1:nlci,1:nlcj,1:jpk,1) = temp_tn(:,:,:) * tmask(1:nlci,1:nlcj,1:jpk)
- tsn(1:nlci,1:nlcj,1:jpk,2) = temp_sn(:,:,:) * tmask(1:nlci,1:nlcj,1:jpk)
- sshn(1:nlci,1:nlcj) = temp_sshn(:,:) * tmask(1:nlci,1:nlcj,1)
-
- ! Remove halo from tmask, tsn, sshn to prevent double obs counting
- IF (jpi > nlci) THEN
- tmask(nlci+1:,:,:) = 0
- tsn(nlci+1:,:,:,1) = 0
- tsn(nlci+1:,:,:,2) = 0
- sshn(nlci+1:,:) = 0
- END IF
- IF (jpj > nlcj) THEN
- tmask(:,nlcj+1:,:) = 0
- tsn(:,nlcj+1:,:,1) = 0
- tsn(:,nlcj+1:,:,2) = 0
- sshn(:,nlcj+1:) = 0
- END IF
-
+ tsn(1:jpi,1:jpj,1:jpk,1) = temp_tn(:,:,:) * tmask(1:jpi,1:jpj,1:jpk)
+ tsn(1:jpi,1:jpj,1:jpk,2) = temp_sn(:,:,:) * tmask(1:jpi,1:jpj,1:jpk)
+ sshn(1:jpi,1:jpj) = temp_sshn(:,:) * tmask(1:jpi,1:jpj,1)
+
! Deallocate arrays
DEALLOCATE(temp_tn, temp_sn, temp_sshn)
Index: /NEMO/branches/2020/r12377_ticket2386/src/SAS/diawri.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/SAS/diawri.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/SAS/diawri.F90 (revision 13540)
@@ -99,5 +99,5 @@
! Output the initial state and forcings
IF( ninist == 1 ) THEN
- CALL dia_wri_state( 'output.init', Kmm )
+ CALL dia_wri_state( Kmm, 'output.init' )
ninist = 0
ENDIF
@@ -126,5 +126,5 @@
END FUNCTION dia_wri_alloc_abl
- SUBROUTINE dia_wri( kt )
+ SUBROUTINE dia_wri( kt, Kmm )
!!---------------------------------------------------------------------
!! *** ROUTINE dia_wri ***
@@ -138,6 +138,6 @@
!! Each nn_write time step, output the instantaneous or mean fields
!!----------------------------------------------------------------------
- !!
INTEGER, INTENT( in ) :: kt ! ocean time-step index
+ INTEGER, INTENT( in ) :: Kmm ! ocean time level index
!!
LOGICAL :: ll_print = .FALSE. ! =T print and flush numout
@@ -154,5 +154,5 @@
! Output the initial state and forcings
IF( ninist == 1 ) THEN
- CALL dia_wri_state( 'output.init' )
+ CALL dia_wri_state( Kmm, 'output.init' )
ninist = 0
ENDIF
@@ -257,5 +257,5 @@
IF( ln_abl ) THEN
! Define the ABL grid FILE ( nid_A )
- CALL dia_nam( clhstnam, nwrite, 'grid_ABL' )
+ CALL dia_nam( clhstnam, nn_write, 'grid_ABL' )
IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam ! filename
CALL histbeg( clhstnam, jpi, glamt, jpj, gphit, & ! Horizontal grid: glamt and gphit
@@ -414,5 +414,5 @@
#endif
- SUBROUTINE dia_wri_state( cdfile_name, Kmm )
+ SUBROUTINE dia_wri_state( Kmm, cdfile_name )
!!---------------------------------------------------------------------
!! *** ROUTINE dia_wri_state ***
@@ -427,6 +427,6 @@
!! File 'output.abort.nc' is created in case of abnormal job end
!!----------------------------------------------------------------------
+ INTEGER , INTENT( in ) :: Kmm ! ocean time levelindex
CHARACTER (len=* ), INTENT( in ) :: cdfile_name ! name of the file created
- INTEGER , INTENT( in ) :: Kmm ! ocean time levelindex
!!
INTEGER :: inum
@@ -437,11 +437,7 @@
IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~ and forcing fields file created '
IF(lwp) WRITE(numout,*) ' and named :', cdfile_name, '...nc'
-
-#if defined key_si3
- CALL iom_open( TRIM(cdfile_name), inum, ldwrt = .TRUE., kdlev = jpl )
-#else
- CALL iom_open( TRIM(cdfile_name), inum, ldwrt = .TRUE. )
-#endif
-
+ !
+ CALL iom_open( TRIM(cdfile_name), inum, ldwrt = .TRUE. )
+ !
CALL iom_rstput( 0, 0, inum, 'votemper', ts (:,:,:,jp_tem,Kmm) ) ! now temperature
CALL iom_rstput( 0, 0, inum, 'vosaline', ts (:,:,:,jp_sal,Kmm) ) ! now salinity
@@ -456,13 +452,15 @@
CALL iom_rstput( 0, 0, inum, 'sozotaux', utau ) ! i-wind stress
CALL iom_rstput( 0, 0, inum, 'sometauy', vtau ) ! j-wind stress
-
+ !
+ CALL iom_close( inum )
+ !
#if defined key_si3
IF( nn_ice == 2 ) THEN ! condition needed in case agrif + ice-model but no-ice in child grid
+ CALL iom_open( TRIM(cdfile_name)//'_ice', inum, ldwrt = .TRUE., kdlev = jpl, cdcomp = 'ICE' )
CALL ice_wri_state( inum )
- ENDIF
-#endif
- !
- CALL iom_close( inum )
- !
+ CALL iom_close( inum )
+ ENDIF
+ !
+#endif
END SUBROUTINE dia_wri_state
Index: /NEMO/branches/2020/r12377_ticket2386/src/SAS/nemogcm.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/SAS/nemogcm.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/SAS/nemogcm.F90 (revision 13540)
@@ -35,7 +35,9 @@
USE step_diu ! diurnal bulk SST timestepping (called from here if run offline)
!
+ USE prtctl ! Print control
+ USE in_out_manager ! I/O manager
USE lib_mpp ! distributed memory computing
USE mppini ! shared/distributed memory setting (mpp_init routine)
- USE lbcnfd , ONLY : isendto, nsndto, nfsloop, nfeloop ! Setup of north fold exchanges
+ USE lbcnfd , ONLY : isendto, nsndto ! Setup of north fold exchanges
USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)
#if defined key_iomput
@@ -45,4 +47,5 @@
USE agrif_ice_update ! ice update
#endif
+ USE halo_mng
IMPLICIT NONE
@@ -90,12 +93,8 @@
#if defined key_agrif
Kbb_a = Nbb; Kmm_a = Nnn; Krhs_a = Nrhs ! agrif_oce module copies of time level indices
- CALL Agrif_Declare_Var_dom ! AGRIF: set the meshes for DOM
CALL Agrif_Declare_Var ! " " " " " DYN/TRA
# if defined key_top
CALL Agrif_Declare_Var_top ! " " " " " TOP
# endif
-# if defined key_si3
- CALL Agrif_Declare_Var_ice ! " " " " " Sea ice
-# endif
#endif
! check that all process are still there... If some process have an error,
@@ -124,10 +123,4 @@
istp = istp + 1
END DO
- !
- IF( .NOT. Agrif_Root() ) THEN
- CALL Agrif_ParentGrid_To_ChildGrid()
- IF( ln_timing ) CALL timing_finalize
- CALL Agrif_ChildGrid_To_ParentGrid()
- ENDIF
!
#else
@@ -165,5 +158,13 @@
IF( nstop /= 0 .AND. lwp ) THEN ! error print
WRITE(ctmp1,*) ' ==>>> nemo_gcm: a total of ', nstop, ' errors have been found'
- CALL ctl_stop( ctmp1 )
+ IF( ngrdstop > 0 ) THEN
+ WRITE(ctmp9,'(i2)') ngrdstop
+ WRITE(ctmp2,*) ' E R R O R detected in Agrif grid '//TRIM(ctmp9)
+ WRITE(ctmp3,*) ' Look for "E R R O R" messages in all existing '//TRIM(ctmp9)//'_ocean_output* files'
+ CALL ctl_stop( ' ', ctmp1, ' ', ctmp2, ' ', ctmp3 )
+ ELSE
+ WRITE(ctmp2,*) ' Look for "E R R O R" messages in all existing ocean_output* files'
+ CALL ctl_stop( ' ', ctmp1, ' ', ctmp2 )
+ ENDIF
ENDIF
!
@@ -198,7 +199,6 @@
INTEGER :: ios, ilocal_comm ! local integers
!!
- NAMELIST/namctl/ sn_cfctl, nn_print, nn_ictls, nn_ictle, &
- & nn_isplt , nn_jsplt, nn_jctls, nn_jctle, &
- & ln_timing, ln_diacfl
+ NAMELIST/namctl/ sn_cfctl, ln_timing, ln_diacfl, &
+ & nn_isplt, nn_jsplt, nn_ictls, nn_ictle, nn_jctls, nn_jctle
NAMELIST/namcfg/ ln_read_cfg, cn_domcfg, ln_closea, ln_write_cfg, cn_domcfg_out, ln_use_jattr
!!----------------------------------------------------------------------
@@ -207,4 +207,5 @@
ELSE ; cxios_context = 'nemo'
ENDIF
+ nn_hls = 1
!
! !-------------------------------------------------!
@@ -256,5 +257,11 @@
ENDIF
! open /dev/null file to be able to supress output write easily
+ IF( Agrif_Root() ) THEN
CALL ctl_opn( numnul, '/dev/null', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. )
+#ifdef key_agrif
+ ELSE
+ numnul = Agrif_Parent(numnul)
+#endif
+ ENDIF
!
! !--------------------!
@@ -268,20 +275,6 @@
!
! finalize the definition of namctl variables
- IF( sn_cfctl%l_allon ) THEN
- ! Turn on all options.
- CALL nemo_set_cfctl( sn_cfctl, .TRUE., .TRUE. )
- ! Ensure all processors are active
- sn_cfctl%procmin = 0 ; sn_cfctl%procmax = 1000000 ; sn_cfctl%procincr = 1
- ELSEIF( sn_cfctl%l_config ) THEN
- ! Activate finer control of report outputs
- ! optionally switch off output from selected areas (note this only
- ! applies to output which does not involve global communications)
- IF( ( narea < sn_cfctl%procmin .OR. narea > sn_cfctl%procmax ) .OR. &
- & ( MOD( narea - sn_cfctl%procmin, sn_cfctl%procincr ) /= 0 ) ) &
- & CALL nemo_set_cfctl( sn_cfctl, .FALSE., .FALSE. )
- ELSE
- ! turn off all options.
- CALL nemo_set_cfctl( sn_cfctl, .FALSE., .TRUE. )
- ENDIF
+ IF( narea < sn_cfctl%procmin .OR. narea > sn_cfctl%procmax .OR. MOD( narea - sn_cfctl%procmin, sn_cfctl%procincr ) /= 0 ) &
+ & CALL nemo_set_cfctl( sn_cfctl, .FALSE. )
!
lwp = (narea == 1) .OR. sn_cfctl%l_oceout ! control of all listing output print
@@ -333,7 +326,7 @@
!
IF( ln_read_cfg ) THEN ! Read sizes in domain configuration file
- CALL domain_cfg ( cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio )
+ CALL domain_cfg ( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, jperio )
ELSE ! user-defined namelist
- CALL usr_def_nam( cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio )
+ CALL usr_def_nam( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, jperio )
ENDIF
!
@@ -345,4 +338,5 @@
CALL mpp_init
+ CALL halo_mng_init()
! Now we know the dimensions of the grid and numout has been set: we can allocate arrays
CALL nemo_alloc()
@@ -350,4 +344,7 @@
! Initialise time level indices
Nbb = 1; Nnn = 2; Naa = 3; Nrhs = Naa
+#if defined key_agrif
+ Kbb_a = Nbb; Kmm_a = Nnn; Krhs_a = Nrhs ! agrif_oce module copies of time level indices
+#endif
! !-------------------------------!
@@ -358,9 +355,12 @@
!
! ! General initialization
- IF( ln_timing ) CALL timing_init ! timing
+ IF( ln_timing ) CALL timing_init ( 'timing_sas.output' )
IF( ln_timing ) CALL timing_start( 'nemo_init')
CALL phy_cst ! Physical constants
CALL eos_init ! Equation of seawater
+#if defined key_agrif
+ CALL Agrif_Declare_Var_ini ! " " " " " DOM
+#endif
CALL dom_init( Nbb, Nnn, Naa, 'SAS') ! Domain
IF( sn_cfctl%l_prtctl ) &
@@ -401,7 +401,4 @@
WRITE(numout,*) '~~~~~~~~'
WRITE(numout,*) ' Namelist namctl'
- WRITE(numout,*) ' sn_cfctl%l_glochk = ', sn_cfctl%l_glochk
- WRITE(numout,*) ' sn_cfctl%l_allon = ', sn_cfctl%l_allon
- WRITE(numout,*) ' finer control over o/p sn_cfctl%l_config = ', sn_cfctl%l_config
WRITE(numout,*) ' sn_cfctl%l_runstat = ', sn_cfctl%l_runstat
WRITE(numout,*) ' sn_cfctl%l_trcstat = ', sn_cfctl%l_trcstat
@@ -415,23 +412,9 @@
WRITE(numout,*) ' sn_cfctl%procincr = ', sn_cfctl%procincr
WRITE(numout,*) ' sn_cfctl%ptimincr = ', sn_cfctl%ptimincr
- WRITE(numout,*) ' level of print nn_print = ', nn_print
- WRITE(numout,*) ' Start i indice for SUM control nn_ictls = ', nn_ictls
- WRITE(numout,*) ' End i indice for SUM control nn_ictle = ', nn_ictle
- WRITE(numout,*) ' Start j indice for SUM control nn_jctls = ', nn_jctls
- WRITE(numout,*) ' End j indice for SUM control nn_jctle = ', nn_jctle
- WRITE(numout,*) ' number of proc. following i nn_isplt = ', nn_isplt
- WRITE(numout,*) ' number of proc. following j nn_jsplt = ', nn_jsplt
WRITE(numout,*) ' timing by routine ln_timing = ', ln_timing
WRITE(numout,*) ' CFL diagnostics ln_diacfl = ', ln_diacfl
ENDIF
!
- nprint = nn_print ! convert DOCTOR namelist names into OLD names
- nictls = nn_ictls
- nictle = nn_ictle
- njctls = nn_jctls
- njctle = nn_jctle
- isplt = nn_isplt
- jsplt = nn_jsplt
-
+ IF( .NOT.ln_read_cfg ) ln_closea = .FALSE. ! dealing possible only with a domcfg file
IF(lwp) THEN ! control print
WRITE(numout,*)
@@ -444,44 +427,4 @@
WRITE(numout,*) ' use file attribute if exists as i/p j-start ln_use_jattr = ', ln_use_jattr
ENDIF
- IF( .NOT.ln_read_cfg ) ln_closea = .false. ! dealing possible only with a domcfg file
- !
- ! ! Parameter control
- !
- IF( sn_cfctl%l_prtctl .OR. sn_cfctl%l_prttrc ) THEN ! sub-domain area indices for the control prints
- IF( lk_mpp .AND. jpnij > 1 ) THEN
- isplt = jpni ; jsplt = jpnj ; ijsplt = jpni*jpnj ! the domain is forced to the real split domain
- ELSE
- IF( isplt == 1 .AND. jsplt == 1 ) THEN
- CALL ctl_warn( ' - isplt & jsplt are equal to 1', &
- & ' - the print control will be done over the whole domain' )
- ENDIF
- ijsplt = isplt * jsplt ! total number of processors ijsplt
- ENDIF
- IF(lwp) WRITE(numout,*)' - The total number of processors over which the'
- IF(lwp) WRITE(numout,*)' print control will be done is ijsplt : ', ijsplt
- !
- ! ! indices used for the SUM control
- IF( nictls+nictle+njctls+njctle == 0 ) THEN ! print control done over the default area
- lsp_area = .FALSE.
- ELSE ! print control done over a specific area
- lsp_area = .TRUE.
- IF( nictls < 1 .OR. nictls > jpiglo ) THEN
- CALL ctl_warn( ' - nictls must be 1<=nictls>=jpiglo, it is forced to 1' )
- nictls = 1
- ENDIF
- IF( nictle < 1 .OR. nictle > jpiglo ) THEN
- CALL ctl_warn( ' - nictle must be 1<=nictle>=jpiglo, it is forced to jpiglo' )
- nictle = jpiglo
- ENDIF
- IF( njctls < 1 .OR. njctls > jpjglo ) THEN
- CALL ctl_warn( ' - njctls must be 1<=njctls>=jpjglo, it is forced to 1' )
- njctls = 1
- ENDIF
- IF( njctle < 1 .OR. njctle > jpjglo ) THEN
- CALL ctl_warn( ' - njctle must be 1<=njctle>=jpjglo, it is forced to jpjglo' )
- njctle = jpjglo
- ENDIF
- ENDIF
- ENDIF
!
IF( 1._wp /= SIGN(1._wp,-0._wp) ) CALL ctl_stop( 'nemo_ctl: The intrinsec SIGN function follows f2003 standard.', &
@@ -537,5 +480,5 @@
ierr = dia_wri_alloc()
ierr = ierr + dom_oce_alloc() ! ocean domain
- ierr = ierr + oce_alloc () ! (tsn...) needed for agrif and/or SI3 and bdy
+ ierr = ierr + oce_alloc () ! (ts...) needed for agrif and/or SI3 and bdy
ierr = ierr + bdy_oce_alloc() ! bdy masks (incl. initialization)
!
@@ -545,25 +488,18 @@
END SUBROUTINE nemo_alloc
- SUBROUTINE nemo_set_cfctl(sn_cfctl, setto, for_all )
+ SUBROUTINE nemo_set_cfctl(sn_cfctl, setto )
!!----------------------------------------------------------------------
!! *** ROUTINE nemo_set_cfctl ***
!!
!! ** Purpose : Set elements of the output control structure to setto.
- !! for_all should be .false. unless all areas are to be
- !! treated identically.
!!
!! ** Method : Note this routine can be used to switch on/off some
- !! types of output for selected areas but any output types
- !! that involve global communications (e.g. mpp_max, glob_sum)
- !! should be protected from selective switching by the
- !! for_all argument
- !!----------------------------------------------------------------------
- LOGICAL :: setto, for_all
- TYPE(sn_ctl) :: sn_cfctl
- !!----------------------------------------------------------------------
- IF( for_all ) THEN
- sn_cfctl%l_runstat = setto
- sn_cfctl%l_trcstat = setto
- ENDIF
+ !! types of output for selected areas.
+ !!----------------------------------------------------------------------
+ TYPE(sn_ctl), INTENT(inout) :: sn_cfctl
+ LOGICAL , INTENT(in ) :: setto
+ !!----------------------------------------------------------------------
+ sn_cfctl%l_runstat = setto
+ sn_cfctl%l_trcstat = setto
sn_cfctl%l_oceout = setto
sn_cfctl%l_layout = setto
Index: /NEMO/branches/2020/r12377_ticket2386/src/SAS/sbcssm.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/SAS/sbcssm.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/SAS/sbcssm.F90 (revision 13540)
@@ -26,5 +26,5 @@
USE lib_mpp ! distributed memory computing library
USE prtctl ! print control
- USE fldread ! read input fields
+ USE fldread ! read input fields
USE timing ! Timing
@@ -38,5 +38,5 @@
LOGICAL :: ln_3d_uve ! specify whether input velocity data is 3D
LOGICAL :: ln_read_frq ! specify whether we must read frq or not
-
+
LOGICAL :: l_sasread ! Ice intilisation: =T read a file ; =F anaytical initilaistion
LOGICAL :: l_initdone = .false.
@@ -69,10 +69,10 @@
!! for an off-line simulation using surface processes only
!!
- !! ** Method : calculates the position of data
+ !! ** Method : calculates the position of data
!! - interpolates data if needed
!!----------------------------------------------------------------------
INTEGER, INTENT(in) :: kt ! ocean time-step index
INTEGER, INTENT(in) :: Kbb, Kmm ! ocean time level indices
- ! (not needed for SAS but needed to keep a consistent interface in sbcmod.F90)
+ ! (not needed for SAS but needed to keep a consistent interface in sbcmod.F90)
!
INTEGER :: ji, jj ! dummy loop indices
@@ -82,25 +82,25 @@
!
IF( ln_timing ) CALL timing_start( 'sbc_ssm')
-
+
IF ( l_sasread ) THEN
IF( nfld_3d > 0 ) CALL fld_read( kt, 1, sf_ssm_3d ) !== read data at kt time step ==!
IF( nfld_2d > 0 ) CALL fld_read( kt, 1, sf_ssm_2d ) !== read data at kt time step ==!
- !
+ !
IF( ln_3d_uve ) THEN
IF( .NOT. ln_linssh ) THEN
- e3t_m(:,:) = sf_ssm_3d(jf_e3t)%fnow(:,:,1) * tmask(:,:,1) ! vertical scale factor
+ e3t_m(:,:) = sf_ssm_3d(jf_e3t)%fnow(:,:,1) * tmask(:,:,1) ! vertical scale factor
ELSE
e3t_m(:,:) = e3t_0(:,:,1) ! vertical scale factor
ENDIF
ssu_m(:,:) = sf_ssm_3d(jf_usp)%fnow(:,:,1) * umask(:,:,1) ! u-velocity
- ssv_m(:,:) = sf_ssm_3d(jf_vsp)%fnow(:,:,1) * vmask(:,:,1) ! v-velocity
+ ssv_m(:,:) = sf_ssm_3d(jf_vsp)%fnow(:,:,1) * vmask(:,:,1) ! v-velocity
ELSE
IF( .NOT. ln_linssh ) THEN
- e3t_m(:,:) = sf_ssm_2d(jf_e3t)%fnow(:,:,1) * tmask(:,:,1) ! vertical scale factor
+ e3t_m(:,:) = sf_ssm_2d(jf_e3t)%fnow(:,:,1) * tmask(:,:,1) ! vertical scale factor
ELSE
e3t_m(:,:) = e3t_0(:,:,1) ! vertical scale factor
ENDIF
ssu_m(:,:) = sf_ssm_2d(jf_usp)%fnow(:,:,1) * umask(:,:,1) ! u-velocity
- ssv_m(:,:) = sf_ssm_2d(jf_vsp)%fnow(:,:,1) * vmask(:,:,1) ! v-velocity
+ ssv_m(:,:) = sf_ssm_2d(jf_vsp)%fnow(:,:,1) * vmask(:,:,1) ! v-velocity
ENDIF
!
@@ -123,5 +123,5 @@
ssh (:,:,Kmm) = 0._wp ! - -
ENDIF
-
+
IF ( nn_ice == 1 ) THEN
ts(:,:,1,jp_tem,Kmm) = sst_m(:,:)
@@ -132,5 +132,5 @@
uu (:,:,1,Kbb) = ssu_m(:,:)
vv (:,:,1,Kbb) = ssv_m(:,:)
-
+
IF(sn_cfctl%l_prtctl) THEN ! print control
CALL prt_ctl(tab2d_1=sst_m, clinfo1=' sst_m - : ', mask1=tmask )
@@ -162,8 +162,8 @@
!! *** ROUTINE sbc_ssm_init ***
!!
- !! ** Purpose : Initialisation of sea surface mean data
- !!----------------------------------------------------------------------
- INTEGER, INTENT(in) :: Kbb, Kmm ! ocean time level indices
- ! (not needed for SAS but needed to keep a consistent interface in sbcmod.F90)
+ !! ** Purpose : Initialisation of sea surface mean data
+ !!----------------------------------------------------------------------
+ INTEGER, INTENT(in) :: Kbb, Kmm ! ocean time level indices
+ ! (not needed for SAS but needed to keep a consistent interface in sbcmod.F90)
INTEGER :: ierr, ierr0, ierr1, ierr2, ierr3 ! return error code
INTEGER :: ifpr ! dummy loop indice
@@ -195,8 +195,8 @@
902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_sas in configuration namelist' )
IF(lwm) WRITE ( numond, namsbc_sas )
- !
+ !
IF(lwp) THEN ! Control print
WRITE(numout,*) ' Namelist namsbc_sas'
- WRITE(numout,*) ' Initialisation using an input file l_sasread = ', l_sasread
+ WRITE(numout,*) ' Initialisation using an input file l_sasread = ', l_sasread
WRITE(numout,*) ' Are we supplying a 3D u,v and e3 field ln_3d_uve = ', ln_3d_uve
WRITE(numout,*) ' Are we reading frq (fraction of qsr absorbed in the 1st T level) ln_read_frq = ', ln_read_frq
@@ -226,8 +226,8 @@
ln_closea = .false.
ENDIF
-
- !
+
+ !
IF( l_sasread ) THEN ! store namelist information in an array
- !
+ !
!! following code is a bit messy, but distinguishes between when u,v are 3d arrays and
!! when we have other 3d arrays that we need to read in
@@ -275,5 +275,5 @@
ENDIF
!
- ierr1 = 0 ! default definition if slf_?d(ifpr)%ln_tint = .false.
+ ierr1 = 0 ! default definition if slf_?d(ifpr)%ln_tint = .false.
IF( nfld_3d > 0 ) THEN
ALLOCATE( sf_ssm_3d(nfld_3d), STAT=ierr ) ! set sf structure
@@ -282,5 +282,5 @@
ENDIF
DO ifpr = 1, nfld_3d
- ALLOCATE( sf_ssm_3d(ifpr)%fnow(jpi,jpj,jpk) , STAT=ierr0 )
+ ALLOCATE( sf_ssm_3d(ifpr)%fnow(jpi,jpj,jpk) , STAT=ierr0 )
IF( slf_3d(ifpr)%ln_tint ) ALLOCATE( sf_ssm_3d(ifpr)%fdta(jpi,jpj,jpk,2) , STAT=ierr1 )
IF( ierr0 + ierr1 > 0 ) THEN
@@ -290,4 +290,6 @@
! ! fill sf with slf_i and control print
CALL fld_fill( sf_ssm_3d, slf_3d, cn_dir, 'sbc_ssm_init', '3D Data in file', 'namsbc_ssm' )
+ sf_ssm_3d(jf_usp)%cltype = 'U' ; sf_ssm_3d(jf_usp)%zsgn = -1._wp
+ sf_ssm_3d(jf_vsp)%cltype = 'V' ; sf_ssm_3d(jf_vsp)%zsgn = -1._wp
ENDIF
!
@@ -298,5 +300,5 @@
ENDIF
DO ifpr = 1, nfld_2d
- ALLOCATE( sf_ssm_2d(ifpr)%fnow(jpi,jpj,1) , STAT=ierr0 )
+ ALLOCATE( sf_ssm_2d(ifpr)%fnow(jpi,jpj,1) , STAT=ierr0 )
IF( slf_2d(ifpr)%ln_tint ) ALLOCATE( sf_ssm_2d(ifpr)%fdta(jpi,jpj,1,2) , STAT=ierr1 )
IF( ierr0 + ierr1 > 0 ) THEN
@@ -306,4 +308,8 @@
!
CALL fld_fill( sf_ssm_2d, slf_2d, cn_dir, 'sbc_ssm_init', '2D Data in file', 'namsbc_ssm' )
+ IF( .NOT. ln_3d_uve ) THEN
+ sf_ssm_2d(jf_usp)%cltype = 'U' ; sf_ssm_2d(jf_usp)%zsgn = -1._wp
+ sf_ssm_2d(jf_vsp)%cltype = 'V' ; sf_ssm_2d(jf_vsp)%zsgn = -1._wp
+ ENDIF
ENDIF
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/SAS/step.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/SAS/step.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/SAS/step.F90 (revision 13540)
@@ -74,23 +74,18 @@
!! -2- Outputs and diagnostics
!!----------------------------------------------------------------------
- INTEGER :: indic ! error indicator if < 0
- !! ---------------------------------------------------------------------
#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()
+ 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( kstp == nit000 + 1 ) lk_agrif_fstep = .FALSE.
# if defined key_iomput
IF( Agrif_Nbstepint() == 0 ) CALL iom_swap( cxios_context )
# endif
#endif
- indic = 0 ! although indic is not changed in stp_ctl
- ! need to keep the same interface
IF( kstp == nit000 ) CALL iom_init( cxios_context ) ! iom_put initialization (must be done after nemo_init for AGRIF+XIOS+OASIS)
IF( kstp /= nit000 ) CALL day( kstp ) ! Calendar (day was already called at nit000 in day_init)
@@ -109,29 +104,34 @@
#if defined key_agrif
!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
- ! AGRIF
+ ! AGRIF recursive integration
!<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
- CALL Agrif_Integrate_ChildGrids( stp )
+ CALL Agrif_Integrate_ChildGrids( stp )
+
+#endif
+ !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ ! Control
+ !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ CALL stp_ctl( kstp, Nnn )
- IF( Agrif_NbStepint() == 0 ) THEN ! AGRIF Update from zoom N to zoom 1 then to Parent
+#if defined key_agrif
+ !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ ! AGRIF update
+ !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ IF( Agrif_NbStepint() == 0 .AND. nstop == 0 ) THEN ! AGRIF Update from zoom N to zoom 1 then to Parent
#if defined key_si3
CALL Agrif_Update_ice( ) ! update sea-ice
#endif
ENDIF
+
#endif
-
!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
- ! Control
- !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
- CALL stp_ctl( kstp, indic )
- IF( indic < 0 ) THEN
- CALL ctl_stop( 'step: indic < 0' )
- CALL dia_wri_state( 'output.abort', Nnn )
- ENDIF
- IF( kstp == nit000 ) CALL iom_close( numror ) ! close input ocean restart file
+ ! File manipulation at the end of the first time step
+ !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ IF( kstp == nit000 ) CALL iom_close( numror ) ! close input ocean restart file
!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
! Coupled mode
!<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
- IF( lk_oasis ) CALL sbc_cpl_snd( kstp, Nbb, Nnn ) ! coupled mode : field exchanges if OASIS-coupled ice
+ IF( lk_oasis .AND. nstop == 0 ) CALL sbc_cpl_snd( kstp, Nbb, Nnn ) ! coupled mode : field exchanges if OASIS-coupled ice
#if defined key_iomput
@@ -144,6 +144,6 @@
lrst_oce = .FALSE.
ENDIF
- IF( kstp == nitend .OR. indic < 0 ) THEN
- CALL iom_context_finalize( cxios_context ) ! needed for XIOS+AGRIF
+ IF( kstp == nitend .OR. nstop > 0 ) THEN
+ CALL iom_context_finalize( cxios_context ) ! needed for XIOS+AGRIF
ENDIF
#endif
Index: /NEMO/branches/2020/r12377_ticket2386/src/SAS/stpctl.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/SAS/stpctl.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/SAS/stpctl.F90 (revision 13540)
@@ -20,9 +20,12 @@
USE dom_oce ! ocean space and time domain variables
USE ice , ONLY : vt_i, u_ice, tm_i
+ USE phycst , ONLY : rt0
+ USE sbc_oce , ONLY : lk_oasis
!
+ USE diawri ! Standard run outputs (dia_wri_state routine)
USE in_out_manager ! I/O manager
USE lbclnk ! ocean lateral boundary conditions (or mpp link)
USE lib_mpp ! distributed memory computing
-
+ !
USE netcdf ! NetCDF library
IMPLICIT NONE
@@ -31,6 +34,6 @@
PUBLIC stp_ctl ! routine called by step.F90
- INTEGER :: idrun, idtime, idssh, idu, ids, istatus
- LOGICAL :: lsomeoce
+ INTEGER :: nrunid ! netcdf file id
+ INTEGER, DIMENSION(3) :: nvarid ! netcdf variable id
!!----------------------------------------------------------------------
!! NEMO/SAS 4.0 , NEMO Consortium (2018)
@@ -38,8 +41,7 @@
!! Software governed by the CeCILL license (see ./LICENSE)
!!----------------------------------------------------------------------
-
CONTAINS
- SUBROUTINE stp_ctl( kt, kindic )
+ SUBROUTINE stp_ctl( kt, Kmm )
!!----------------------------------------------------------------------
!! *** ROUTINE stp_ctl ***
@@ -48,67 +50,232 @@
!!
!! ** Method : - Save the time step in numstp
- !! - Print it each 50 time steps
+ !! - Stop the run IF problem encountered by setting nstop > 0
+ !! Problems checked: ice thickness maximum > 100 m
+ !! ice velocity maximum > 10 m/s
+ !! min ice temperature < -100 degC
!!
!! ** Actions : "time.step" file = last ocean time-step
!! "run.stat" file = run statistics
- !!
- !!----------------------------------------------------------------------
- INTEGER, INTENT( in ) :: kt ! ocean time-step index
- INTEGER, INTENT( inout ) :: kindic ! indicator of solver convergence
- !!
- REAL(wp), DIMENSION(3) :: zmax
- LOGICAL :: ll_wrtstp, ll_colruns, ll_wrtruns
- CHARACTER(len=20) :: clname
- !!----------------------------------------------------------------------
- !
- ll_wrtstp = ( MOD( kt, sn_cfctl%ptimincr ) == 0 ) .OR. ( kt == nitend )
- ll_colruns = ll_wrtstp .AND. ( sn_cfctl%l_runstat )
- ll_wrtruns = ll_colruns .AND. lwm
- IF( kt == nit000 .AND. lwp ) THEN
- WRITE(numout,*)
- WRITE(numout,*) 'stp_ctl : time-stepping control'
- WRITE(numout,*) '~~~~~~~'
- ! ! open time.step file
- IF( lwm ) CALL ctl_opn( numstp, 'time.step', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea )
- ! ! open run.stat file(s) at start whatever
- ! ! the value of sn_cfctl%ptimincr
- IF( lwm .AND. ( sn_cfctl%l_runstat ) ) THEN
- CALL ctl_opn( numrun, 'run.stat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea )
- clname = 'run.stat.nc'
+ !! nstop indicator sheared among all local domain
+ !!----------------------------------------------------------------------
+ INTEGER, INTENT(in ) :: kt ! ocean time-step index
+ INTEGER, INTENT(in ) :: Kmm ! ocean time level index
+ !!
+ INTEGER :: ji ! dummy loop indices
+ INTEGER :: idtime, istatus
+ INTEGER , DIMENSION(4) :: iareasum, iareamin, iareamax
+ INTEGER , DIMENSION(3,3) :: iloc ! min/max loc indices
+ REAL(wp) :: zzz ! local real
+ REAL(wp), DIMENSION(4) :: zmax, zmaxlocal
+ LOGICAL :: ll_wrtstp, ll_colruns, ll_wrtruns
+ LOGICAL, DIMENSION(jpi,jpj) :: llmsk
+ CHARACTER(len=20) :: clname
+ !!----------------------------------------------------------------------
+ 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
+ !
+ IF( kt == nit000 ) THEN
+ !
+ IF( lwp ) THEN
+ WRITE(numout,*)
+ WRITE(numout,*) 'stp_ctl : time-stepping control'
+ WRITE(numout,*) '~~~~~~~'
+ ENDIF
+ ! ! open time.step ascii file, done only by 1st subdomain
+ IF( lk_oasis ) THEN ; clname = 'time_sas.step'
+ ELSE ; clname = 'time.step'
+ ENDIF
+ IF( lwm ) CALL ctl_opn( numstp, clname, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea )
+ !
+ IF( ll_wrtruns ) THEN
+ IF( lk_oasis ) THEN ; clname = 'run_sas.stat'
+ ELSE ; clname = 'run.stat'
+ ENDIF
+ ! ! open run.stat ascii file, done only by 1st subdomain
+ CALL ctl_opn( numrun, clname, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea )
+ ! ! open run.stat.nc netcdf file, done only by 1st subdomain
+ clname = clname//'.nc'
IF( .NOT. Agrif_Root() ) clname = TRIM(Agrif_CFixed())//"_"//TRIM(clname)
- istatus = NF90_CREATE( 'run.stat.nc', NF90_CLOBBER, idrun )
- istatus = NF90_DEF_DIM( idrun, 'time' , NF90_UNLIMITED, idtime )
- istatus = NF90_DEF_VAR( idrun, 'vt_i_max' , NF90_DOUBLE, (/ idtime /), idssh )
- istatus = NF90_DEF_VAR( idrun, 'abs_u_max', NF90_DOUBLE, (/ idtime /), idu )
- istatus = NF90_DEF_VAR( idrun, 'tm_i_min' , NF90_DOUBLE, (/ idtime /), ids )
- istatus = NF90_ENDDEF(idrun)
- ENDIF
- ENDIF
- IF( kt == nit000 ) lsomeoce = COUNT( ssmask(:,:) == 1._wp ) > 0
- !
- IF(lwm .AND. ll_wrtstp) THEN !== current time step ==! ("time.step" file)
+ istatus = NF90_CREATE( TRIM(clname), NF90_CLOBBER, nrunid )
+ istatus = NF90_DEF_DIM( nrunid, 'time' , NF90_UNLIMITED, idtime )
+ istatus = NF90_DEF_VAR( nrunid, 'vt_i_max' , NF90_DOUBLE, (/ idtime /), nvarid(1) )
+ istatus = NF90_DEF_VAR( nrunid, 'abs_u_max', NF90_DOUBLE, (/ idtime /), nvarid(2) )
+ istatus = NF90_DEF_VAR( nrunid, 'tm_i_min' , NF90_DOUBLE, (/ idtime /), nvarid(3) )
+ istatus = NF90_ENDDEF(nrunid)
+ ENDIF
+ !
+ ENDIF
+ !
+ ! !== write current time step ==!
+ ! !== done only by 1st subdomain at writting timestep ==!
+ IF( lwm .AND. ll_wrtstp ) THEN
WRITE ( numstp, '(1x, i8)' ) kt
REWIND( numstp )
ENDIF
- ! !== test of extrema ==!
+ ! !== test of local extrema ==!
+ ! !== done by all processes at every time step ==!
+ !
+ llmsk( 1:Nis1,:) = .FALSE. ! exclude halos from the checked region
+ llmsk(Nie1: jpi,:) = .FALSE.
+ llmsk(:, 1:Njs1) = .FALSE.
+ llmsk(:,Nje1: jpj) = .FALSE.
+ !
+ llmsk(Nis0:Nie0,Njs0:Nje0) = tmask(Nis0:Nie0,Njs0:Nje0,1) == 1._wp ! test only the inner domain
+ IF( COUNT( llmsk(:,:) ) > 0 ) THEN ! avoid huge values sent back for land processors...
+ 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)
+ ELSE
+ IF( ll_colruns ) THEN ! default value: must not be kept when calling mpp_max -> must be as small as possible
+ zmax(1:3) = -HUGE(1._wp)
+ ELSE ! default value: must not give true for any of the tests bellow (-> avoid manipulating HUGE...)
+ zmax(1:3) = 0._wp
+ ENDIF
+ ENDIF
+ zmax(4) = REAL( nstop, wp ) ! stop indicator
+ ! !== get global extrema ==!
+ ! !== done by all processes if writting run.stat ==!
IF( ll_colruns ) THEN
- zmax(1) = MAXVAL( vt_i (:,:) ) ! max ice thickness
- zmax(2) = MAXVAL( ABS( u_ice(:,:) ) ) ! max ice velocity (zonal only)
- zmax(3) = MAXVAL( -tm_i (:,:)+273.15_wp , mask = ssmask(:,:) == 1._wp ) ! min ice temperature
- CALL mpp_max( "stpctl", zmax ) ! max over the global domain
+ zmaxlocal(:) = zmax(:)
+ CALL mpp_max( "stpctl", zmax ) ! max over the global domain
+ nstop = NINT( zmax(4) ) ! update nstop indicator (now sheared among all local domains)
+ ENDIF
+ ! !== write "run.stat" files ==!
+ ! !== done only by 1st subdomain at writting timestep ==!
+ IF( ll_wrtruns ) THEN
+ WRITE(numrun,9500) kt, zmax(1), zmax(2), -zmax(3)
+ istatus = NF90_PUT_VAR( nrunid, nvarid(1), (/ zmax(1)/), (/kt/), (/1/) )
+ istatus = NF90_PUT_VAR( nrunid, nvarid(2), (/ zmax(2)/), (/kt/), (/1/) )
+ istatus = NF90_PUT_VAR( nrunid, nvarid(3), (/-zmax(3)/), (/kt/), (/1/) )
+ IF( kt == nitend ) istatus = NF90_CLOSE(nrunid)
END IF
- ! !== run statistics ==! ("run.stat" file)
- IF( ll_wrtruns ) THEN
- WRITE(numrun,9500) kt, zmax(1), zmax(2), - zmax(3)
- istatus = NF90_PUT_VAR( idrun, idssh, (/ zmax(1)/), (/kt/), (/1/) )
- istatus = NF90_PUT_VAR( idrun, idu, (/ zmax(2)/), (/kt/), (/1/) )
- istatus = NF90_PUT_VAR( idrun, ids, (/-zmax(3)/), (/kt/), (/1/) )
- IF( MOD( kt , 100 ) == 0 ) istatus = NF90_SYNC(idrun)
- IF( kt == nitend ) istatus = NF90_CLOSE(idrun)
- END IF
+ ! !== error handling ==!
+ ! !== done by all processes at every time step ==!
+ !
+ IF( zmax(1) > 100._wp .OR. & ! too large ice thickness maximum ( > 100 m)
+ & zmax(2) > 10._wp .OR. & ! too large ice velocity ( > 10 m/s)
+ & zmax(3) > 101._wp .OR. & ! too cold ice temperature ( < -100 degC)
+ & ISNAN( zmax(1) + zmax(2) + zmax(3) ) .OR. & ! NaN encounter in the tests
+ & ABS( zmax(1) + zmax(2) + zmax(3) ) > HUGE(1._wp) ) THEN ! Infinity encounter in the tests
+ !
+ iloc(:,:) = 0
+ IF( ll_colruns ) THEN ! zmax is global, so it is the same on all subdomains -> no dead lock with mpp_maxloc
+ ! 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) )
+ ! find which subdomain has the max.
+ iareamin(:) = jpnij+1 ; iareamax(:) = 0 ; iareasum(:) = 0
+ DO ji = 1, 4
+ IF( zmaxlocal(ji) == zmax(ji) ) THEN
+ iareamin(ji) = narea ; iareamax(ji) = narea ; iareasum(ji) = 1
+ ENDIF
+ END DO
+ CALL mpp_min( "stpctl", iareamin ) ! min over the global domain
+ CALL mpp_max( "stpctl", iareamax ) ! max over the global domain
+ 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 )
+ DO ji = 1, 3 ! local domain indices ==> global domain indices, excluding halos
+ iloc(1:2,ji) = (/ mig0(iloc(1,ji)), mjg0(iloc(2,ji)) /)
+ END DO
+ iareamin(:) = narea ; iareamax(:) = narea ; iareasum(:) = 1 ! this is local information
+ ENDIF
+ !
+ WRITE(ctmp1,*) ' stp_ctl: ice_thick > 100 m or |ice_vel| > 10 m/s or ice_temp < -100 degC or NaN encounter in the tests'
+ CALL wrt_line( ctmp2, kt, 'ice_thick max', zmax(1), iloc(:,1), iareasum(1), iareamin(1), iareamax(1) )
+ CALL wrt_line( ctmp3, kt, '|ice_vel| max', zmax(2), iloc(:,2), iareasum(2), iareamin(2), iareamax(2) )
+ CALL wrt_line( ctmp4, kt, 'ice_temp min', -zmax(3), iloc(:,3), iareasum(3), iareamin(3), iareamax(3) )
+ IF( Agrif_Root() ) THEN
+ WRITE(ctmp6,*) ' ===> output of last computed fields in output.abort* files'
+ ELSE
+ WRITE(ctmp6,*) ' ===> output of last computed fields in '//TRIM(Agrif_CFixed())//'_output.abort* files'
+ ENDIF
+ !
+ 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 )
+ 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 )
+ ENDIF
+ !
+ ENDIF
+ !
+ IF( nstop > 0 ) THEN ! an error was detected and we did not abort yet...
+ ngrdstop = Agrif_Fixed() ! store which grid got this error
+ IF( .NOT. ll_colruns .AND. jpnij > 1 ) CALL ctl_stop( 'STOP' ) ! we must abort here to avoid MPI deadlock
+ ENDIF
!
9500 FORMAT(' it :', i8, ' vt_i_max: ', D23.16, ' |u|_max: ', D23.16,' tm_i_min: ', D23.16)
!
END SUBROUTINE stp_ctl
+
+
+ SUBROUTINE wrt_line( cdline, kt, cdprefix, pval, kloc, ksum, kmin, kmax )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE wrt_line ***
+ !!
+ !! ** Purpose : write information line
+ !!
+ !!----------------------------------------------------------------------
+ CHARACTER(len=*), INTENT( out) :: cdline
+ CHARACTER(len=*), INTENT(in ) :: cdprefix
+ REAL(wp), INTENT(in ) :: pval
+ INTEGER, DIMENSION(3), INTENT(in ) :: kloc
+ INTEGER, INTENT(in ) :: kt, ksum, kmin, kmax
+ !
+ CHARACTER(len=80) :: clsuff
+ CHARACTER(len=9 ) :: clkt, clsum, clmin, clmax
+ CHARACTER(len=9 ) :: cli, clj, clk
+ CHARACTER(len=1 ) :: clfmt
+ CHARACTER(len=4 ) :: cl4 ! needed to be able to compile with Agrif, I don't know why
+ INTEGER :: ifmtk
+ !!----------------------------------------------------------------------
+ WRITE(clkt , '(i9)') kt
+
+ WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpnij ,wp))) + 1 ! how many digits to we need to write ? (we decide max = 9)
+ !!! WRITE(clsum, '(i'//clfmt//')') ksum ! this is creating a compilation error with AGRIF
+ cl4 = '(i'//clfmt//')' ; WRITE(clsum, cl4) ksum
+ WRITE(clfmt, '(i1)') INT(LOG10(REAL(MAX(1,jpnij-1),wp))) + 1 ! how many digits to we need to write ? (we decide max = 9)
+ cl4 = '(i'//clfmt//')' ; WRITE(clmin, cl4) kmin-1
+ WRITE(clmax, cl4) kmax-1
+ !
+ WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpiglo,wp))) + 1 ! how many digits to we need to write jpiglo? (we decide max = 9)
+ cl4 = '(i'//clfmt//')' ; WRITE(cli, cl4) kloc(1) ! this is ok with AGRIF
+ WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpjglo,wp))) + 1 ! how many digits to we need to write jpjglo? (we decide max = 9)
+ cl4 = '(i'//clfmt//')' ; WRITE(clj, cl4) kloc(2) ! this is ok with AGRIF
+ !
+ IF( ksum == 1 ) THEN ; WRITE(clsuff,9100) TRIM(clmin)
+ ELSE ; WRITE(clsuff,9200) TRIM(clsum), TRIM(clmin), TRIM(clmax)
+ ENDIF
+ IF(kloc(3) == 0) THEN
+ ifmtk = INT(LOG10(REAL(jpk,wp))) + 1 ! how many digits to we need to write jpk? (we decide max = 9)
+ clk = REPEAT(' ', ifmtk) ! create the equivalent in blank string
+ WRITE(cdline,9300) TRIM(ADJUSTL(clkt)), TRIM(ADJUSTL(cdprefix)), pval, TRIM(cli), TRIM(clj), clk(1:ifmtk), TRIM(clsuff)
+ ELSE
+ WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpk,wp))) + 1 ! how many digits to we need to write jpk? (we decide max = 9)
+ !!! WRITE(clk, '(i'//clfmt//')') kloc(3) ! this is creating a compilation error with AGRIF
+ cl4 = '(i'//clfmt//')' ; WRITE(clk, cl4) kloc(3) ! this is ok with AGRIF
+ WRITE(cdline,9400) TRIM(ADJUSTL(clkt)), TRIM(ADJUSTL(cdprefix)), pval, TRIM(cli), TRIM(clj), TRIM(clk), TRIM(clsuff)
+ ENDIF
+ !
+9100 FORMAT('MPI rank ', a)
+9200 FORMAT('found in ', a, ' MPI tasks, spread out among ranks ', a, ' to ', a)
+9300 FORMAT('kt ', a, ' ', a, ' ', 1pg11.4, ' at i j ', a, ' ', a, ' ', a, ' ', a)
+9400 FORMAT('kt ', a, ' ', a, ' ', 1pg11.4, ' at i j k ', a, ' ', a, ' ', a, ' ', a)
+ !
+ END SUBROUTINE wrt_line
+
!!======================================================================
Index: /NEMO/branches/2020/r12377_ticket2386/src/SWE/asminc.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/SWE/asminc.F90 (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/src/SWE/asminc.F90 (revision 13540)
@@ -0,0 +1,1030 @@
+MODULE asminc
+ !!======================================================================
+ !! *** MODULE asminc ***
+ !! Assimilation increment : Apply an increment generated by data
+ !! assimilation
+ !!======================================================================
+ !! History : ! 2007-03 (M. Martin) Met Office version
+ !! ! 2007-04 (A. Weaver) calc_date original code
+ !! ! 2007-04 (A. Weaver) Merge with OPAVAR/NEMOVAR
+ !! NEMO 3.3 ! 2010-05 (D. Lea) Update to work with NEMO v3.2
+ !! - ! 2010-05 (D. Lea) add calc_month_len routine based on day_init
+ !! 3.4 ! 2012-10 (A. Weaver and K. Mogensen) Fix for direct initialization
+ !! ! 2014-09 (D. Lea) Local calc_date removed use routine from OBS
+ !! ! 2015-11 (D. Lea) Handle non-zero initial time of day
+ !!----------------------------------------------------------------------
+
+ !!----------------------------------------------------------------------
+ !! asm_inc_init : Initialize the increment arrays and IAU weights
+ !! tra_asm_inc : Apply the tracer (T and S) increments
+ !! dyn_asm_inc : Apply the dynamic (u and v) increments
+ !! ssh_asm_inc : Apply the SSH increment
+ !! ssh_asm_div : Apply divergence associated with SSH increment
+ !! seaice_asm_inc : Apply the seaice increment
+ !!----------------------------------------------------------------------
+ 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
+ USE sbc_oce ! Surface boundary condition variables.
+ USE diaobs , ONLY : calc_date ! Compute the calendar date on a given step
+#if defined key_si3
+ USE ice , ONLY : hm_i, at_i, at_i_b
+#endif
+ !
+ USE in_out_manager ! I/O manager
+ USE iom ! Library to read input files
+ USE lib_mpp ! MPP library
+
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC asm_inc_init !: Initialize the increment arrays and IAU weights
+ PUBLIC tra_asm_inc !: Apply the tracer (T and S) increments
+ PUBLIC dyn_asm_inc !: Apply the dynamic (u and v) increments
+ PUBLIC ssh_asm_inc !: Apply the SSH increment
+ PUBLIC ssh_asm_div !: Apply the SSH divergence
+ PUBLIC seaice_asm_inc !: Apply the seaice increment
+
+#if defined key_asminc
+ LOGICAL, PUBLIC, PARAMETER :: lk_asminc = .TRUE. !: Logical switch for assimilation increment interface
+#else
+ LOGICAL, PUBLIC, PARAMETER :: lk_asminc = .FALSE. !: No assimilation increments
+#endif
+ LOGICAL, PUBLIC :: ln_bkgwri !: No output of the background state fields
+ LOGICAL, PUBLIC :: ln_asmiau !: No applying forcing with an assimilation increment
+ LOGICAL, PUBLIC :: ln_asmdin !: No direct initialization
+ LOGICAL, PUBLIC :: ln_trainc !: No tracer (T and S) assimilation increments
+ LOGICAL, PUBLIC :: ln_dyninc !: No dynamics (u and v) assimilation increments
+ LOGICAL, PUBLIC :: ln_sshinc !: No sea surface height assimilation increment
+ LOGICAL, PUBLIC :: ln_seaiceinc !: No sea ice concentration increment
+ LOGICAL, PUBLIC :: ln_salfix !: Apply minimum salinity check
+ LOGICAL, PUBLIC :: ln_temnofreeze = .FALSE. !: Don't allow the temperature to drop below freezing
+ INTEGER, PUBLIC :: nn_divdmp !: Apply divergence damping filter nn_divdmp times
+
+ REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: t_bkg , s_bkg !: Background temperature and salinity
+ REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: u_bkg , v_bkg !: Background u- & v- velocity components
+ REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: t_bkginc, s_bkginc !: Increment to the background T & S
+ REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: u_bkginc, v_bkginc !: Increment to the u- & v-components
+ REAL(wp), PUBLIC, DIMENSION(:) , ALLOCATABLE :: wgtiau !: IAU weights for each time step
+#if defined key_asminc
+ REAL(wp), PUBLIC, DIMENSION(:,:) , ALLOCATABLE :: ssh_iau !: IAU-weighted sea surface height increment
+#endif
+ ! !!! time steps relative to the cycle interval [0,nitend-nit000-1]
+ INTEGER , PUBLIC :: nitbkg !: Time step of the background state used in the Jb term
+ INTEGER , PUBLIC :: nitdin !: Time step of the background state for direct initialization
+ INTEGER , PUBLIC :: nitiaustr !: Time step of the start of the IAU interval
+ INTEGER , PUBLIC :: nitiaufin !: Time step of the end of the IAU interval
+ !
+ INTEGER , PUBLIC :: niaufn !: Type of IAU weighing function: = 0 Constant weighting
+ ! !: = 1 Linear hat-like, centred in middle of IAU interval
+ REAL(wp), PUBLIC :: salfixmin !: Ensure that the salinity is larger than this value if (ln_salfix)
+
+ REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ssh_bkg, ssh_bkginc ! Background sea surface height and its increment
+ REAL(wp), DIMENSION(:,:), ALLOCATABLE :: seaice_bkginc ! Increment to the background sea ice conc
+#if defined key_cice && defined key_asminc
+ REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ndaice_da ! ice increment tendency into CICE
+#endif
+
+ !! * Substitutions
+# include "do_loop_substitute.h90"
+!!st10
+# include "domzgr_substitute.h90"
+!!st10
+ !!----------------------------------------------------------------------
+ !! NEMO/OCE 4.0 , NEMO Consortium (2018)
+ !! $Id: asminc.F90 12614 2020-03-26 14:59:52Z gm $
+ !! Software governed by the CeCILL license (see ./LICENSE)
+ !!----------------------------------------------------------------------
+CONTAINS
+
+ SUBROUTINE asm_inc_init( Kbb, Kmm, Krhs )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE asm_inc_init ***
+ !!
+ !! ** Purpose : Initialize the assimilation increment and IAU weights.
+ !!
+ !! ** Method : Initialize the assimilation increment and IAU weights.
+ !!
+ !! ** Action :
+ !!----------------------------------------------------------------------
+ INTEGER, INTENT(in) :: Kbb, Kmm, Krhs ! time level indices
+ !
+ INTEGER :: ji, jj, jk, jt ! dummy loop indices
+ INTEGER :: imid, inum ! local integers
+ INTEGER :: ios ! Local integer output status for namelist read
+ INTEGER :: iiauper ! Number of time steps in the IAU period
+ INTEGER :: icycper ! Number of time steps in the cycle
+ REAL(KIND=dp) :: ditend_date ! Date YYYYMMDD.HHMMSS of final time step
+ REAL(KIND=dp) :: ditbkg_date ! Date YYYYMMDD.HHMMSS of background time step for Jb term
+ REAL(KIND=dp) :: ditdin_date ! Date YYYYMMDD.HHMMSS of background time step for DI
+ REAL(KIND=dp) :: ditiaustr_date ! Date YYYYMMDD.HHMMSS of IAU interval start time step
+ REAL(KIND=dp) :: ditiaufin_date ! Date YYYYMMDD.HHMMSS of IAU interval final time step
+
+ REAL(wp) :: znorm ! Normalization factor for IAU weights
+ REAL(wp) :: ztotwgt ! Value of time-integrated IAU weights (should be equal to one)
+ REAL(wp) :: z_inc_dateb ! Start date of interval on which increment is valid
+ REAL(wp) :: z_inc_datef ! End date of interval on which increment is valid
+ REAL(wp) :: zdate_bkg ! Date in background state file for DI
+ REAL(wp) :: zdate_inc ! Time axis in increments file
+ !
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zhdiv ! 2D workspace
+ !!
+ NAMELIST/nam_asminc/ ln_bkgwri, &
+ & ln_trainc, ln_dyninc, ln_sshinc, &
+ & ln_asmdin, ln_asmiau, &
+ & nitbkg, nitdin, nitiaustr, nitiaufin, niaufn, &
+ & ln_salfix, salfixmin, nn_divdmp
+ !!----------------------------------------------------------------------
+
+ !-----------------------------------------------------------------------
+ ! Read Namelist nam_asminc : assimilation increment interface
+ !-----------------------------------------------------------------------
+ ln_seaiceinc = .FALSE.
+ ln_temnofreeze = .FALSE.
+
+ READ ( numnam_ref, nam_asminc, IOSTAT = ios, ERR = 901)
+901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_asminc in reference namelist' )
+ READ ( numnam_cfg, nam_asminc, IOSTAT = ios, ERR = 902 )
+902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam_asminc in configuration namelist' )
+ IF(lwm) WRITE ( numond, nam_asminc )
+
+ ! Control print
+ IF(lwp) THEN
+ WRITE(numout,*)
+ WRITE(numout,*) 'asm_inc_init : Assimilation increment initialization :'
+ WRITE(numout,*) '~~~~~~~~~~~~'
+ WRITE(numout,*) ' Namelist namasm : set assimilation increment parameters'
+ WRITE(numout,*) ' Logical switch for writing out background state ln_bkgwri = ', ln_bkgwri
+ WRITE(numout,*) ' Logical switch for applying tracer increments ln_trainc = ', ln_trainc
+ WRITE(numout,*) ' Logical switch for applying velocity increments ln_dyninc = ', ln_dyninc
+ WRITE(numout,*) ' Logical switch for applying SSH increments ln_sshinc = ', ln_sshinc
+ WRITE(numout,*) ' Logical switch for Direct Initialization (DI) ln_asmdin = ', ln_asmdin
+ WRITE(numout,*) ' Logical switch for applying sea ice increments ln_seaiceinc = ', ln_seaiceinc
+ WRITE(numout,*) ' Logical switch for Incremental Analysis Updating (IAU) ln_asmiau = ', ln_asmiau
+ WRITE(numout,*) ' Timestep of background in [0,nitend-nit000-1] nitbkg = ', nitbkg
+ WRITE(numout,*) ' Timestep of background for DI in [0,nitend-nit000-1] nitdin = ', nitdin
+ WRITE(numout,*) ' Timestep of start of IAU interval in [0,nitend-nit000-1] nitiaustr = ', nitiaustr
+ WRITE(numout,*) ' Timestep of end of IAU interval in [0,nitend-nit000-1] nitiaufin = ', nitiaufin
+ WRITE(numout,*) ' Type of IAU weighting function niaufn = ', niaufn
+ WRITE(numout,*) ' Logical switch for ensuring that the sa > salfixmin ln_salfix = ', ln_salfix
+ WRITE(numout,*) ' Minimum salinity after applying the increments salfixmin = ', salfixmin
+ ENDIF
+
+ nitbkg_r = nitbkg + nit000 - 1 ! Background time referenced to nit000
+ nitdin_r = nitdin + nit000 - 1 ! Background time for DI referenced to nit000
+ nitiaustr_r = nitiaustr + nit000 - 1 ! Start of IAU interval referenced to nit000
+ nitiaufin_r = nitiaufin + nit000 - 1 ! End of IAU interval referenced to nit000
+
+ iiauper = nitiaufin_r - nitiaustr_r + 1 ! IAU interval length
+ icycper = nitend - nit000 + 1 ! Cycle interval length
+
+ CALL calc_date( nitend , ditend_date ) ! Date of final time step
+ CALL calc_date( nitbkg_r , ditbkg_date ) ! Background time for Jb referenced to ndate0
+ CALL calc_date( nitdin_r , ditdin_date ) ! Background time for DI referenced to ndate0
+ CALL calc_date( nitiaustr_r, ditiaustr_date ) ! IAU start time referenced to ndate0
+ CALL calc_date( nitiaufin_r, ditiaufin_date ) ! IAU end time referenced to ndate0
+
+ IF(lwp) THEN
+ WRITE(numout,*)
+ WRITE(numout,*) ' Time steps referenced to current cycle:'
+ WRITE(numout,*) ' iitrst = ', nit000 - 1
+ WRITE(numout,*) ' nit000 = ', nit000
+ WRITE(numout,*) ' nitend = ', nitend
+ WRITE(numout,*) ' nitbkg_r = ', nitbkg_r
+ WRITE(numout,*) ' nitdin_r = ', nitdin_r
+ WRITE(numout,*) ' nitiaustr_r = ', nitiaustr_r
+ WRITE(numout,*) ' nitiaufin_r = ', nitiaufin_r
+ WRITE(numout,*)
+ WRITE(numout,*) ' Dates referenced to current cycle:'
+ WRITE(numout,*) ' ndastp = ', ndastp
+ WRITE(numout,*) ' ndate0 = ', ndate0
+ WRITE(numout,*) ' nn_time0 = ', nn_time0
+ WRITE(numout,*) ' ditend_date = ', ditend_date
+ WRITE(numout,*) ' ditbkg_date = ', ditbkg_date
+ WRITE(numout,*) ' ditdin_date = ', ditdin_date
+ WRITE(numout,*) ' ditiaustr_date = ', ditiaustr_date
+ WRITE(numout,*) ' ditiaufin_date = ', ditiaufin_date
+ ENDIF
+
+
+ IF ( ( ln_asmdin ).AND.( ln_asmiau ) ) &
+ & CALL ctl_stop( ' ln_asmdin and ln_asmiau :', &
+ & ' Choose Direct Initialization OR Incremental Analysis Updating')
+
+ IF ( ( ( .NOT. ln_asmdin ).AND.( .NOT. ln_asmiau ) ) &
+ .AND.( ( ln_trainc ).OR.( ln_dyninc ).OR.( ln_sshinc ) .OR. ( ln_seaiceinc) )) &
+ & CALL ctl_stop( ' One or more of ln_trainc, ln_dyninc, ln_sshinc and ln_seaiceinc is set to .true.', &
+ & ' but ln_asmdin and ln_asmiau are both set to .false. :', &
+ & ' Inconsistent options')
+
+ IF ( ( niaufn /= 0 ).AND.( niaufn /= 1 ) ) &
+ & CALL ctl_stop( ' niaufn /= 0 or niaufn /=1 :', &
+ & ' Type IAU weighting function is invalid')
+
+ IF ( ( .NOT. ln_trainc ).AND.( .NOT. ln_dyninc ).AND.( .NOT. ln_sshinc ).AND.( .NOT. ln_seaiceinc ) &
+ & ) &
+ & CALL ctl_warn( ' ln_trainc, ln_dyninc, ln_sshinc and ln_seaiceinc are set to .false. :', &
+ & ' The assimilation increments are not applied')
+
+ IF ( ( ln_asmiau ).AND.( nitiaustr == nitiaufin ) ) &
+ & CALL ctl_stop( ' nitiaustr = nitiaufin :', &
+ & ' IAU interval is of zero length')
+
+ IF ( ( ln_asmiau ).AND.( ( nitiaustr_r < nit000 ).OR.( nitiaufin_r > nitend ) ) ) &
+ & CALL ctl_stop( ' nitiaustr or nitiaufin :', &
+ & ' IAU starting or final time step is outside the cycle interval', &
+ & ' Valid range nit000 to nitend')
+
+ IF ( ( nitbkg_r < nit000 - 1 ).OR.( nitbkg_r > nitend ) ) &
+ & CALL ctl_stop( ' nitbkg :', &
+ & ' Background time step is outside the cycle interval')
+
+ IF ( ( nitdin_r < nit000 - 1 ).OR.( nitdin_r > nitend ) ) &
+ & CALL ctl_stop( ' nitdin :', &
+ & ' Background time step for Direct Initialization is outside', &
+ & ' the cycle interval')
+
+ IF ( nstop > 0 ) RETURN ! if there are any errors then go no further
+
+ !--------------------------------------------------------------------
+ ! Initialize the Incremental Analysis Updating weighting function
+ !--------------------------------------------------------------------
+
+ IF( ln_asmiau ) THEN
+ !
+ ALLOCATE( wgtiau( icycper ) )
+ !
+ wgtiau(:) = 0._wp
+ !
+ ! !---------------------------------------------------------
+ IF( niaufn == 0 ) THEN ! Constant IAU forcing
+ ! !---------------------------------------------------------
+ DO jt = 1, iiauper
+ wgtiau(jt+nitiaustr-1) = 1.0 / REAL( iiauper )
+ END DO
+ ! !---------------------------------------------------------
+ ELSEIF ( niaufn == 1 ) THEN ! Linear hat-like, centred in middle of IAU interval
+ ! !---------------------------------------------------------
+ ! Compute the normalization factor
+ znorm = 0._wp
+ IF( MOD( iiauper, 2 ) == 0 ) THEN ! Even number of time steps in IAU interval
+ imid = iiauper / 2
+ DO jt = 1, imid
+ znorm = znorm + REAL( jt )
+ END DO
+ znorm = 2.0 * znorm
+ ELSE ! Odd number of time steps in IAU interval
+ imid = ( iiauper + 1 ) / 2
+ DO jt = 1, imid - 1
+ znorm = znorm + REAL( jt )
+ END DO
+ znorm = 2.0 * znorm + REAL( imid )
+ ENDIF
+ znorm = 1.0 / znorm
+ !
+ DO jt = 1, imid - 1
+ wgtiau(jt+nitiaustr-1) = REAL( jt ) * znorm
+ END DO
+ DO jt = imid, iiauper
+ wgtiau(jt+nitiaustr-1) = REAL( iiauper - jt + 1 ) * znorm
+ END DO
+ !
+ ENDIF
+
+ ! Test that the integral of the weights over the weighting interval equals 1
+ IF(lwp) THEN
+ WRITE(numout,*)
+ WRITE(numout,*) 'asm_inc_init : IAU weights'
+ WRITE(numout,*) '~~~~~~~~~~~~'
+ WRITE(numout,*) ' time step IAU weight'
+ WRITE(numout,*) ' ========= ====================='
+ ztotwgt = 0.0
+ DO jt = 1, icycper
+ ztotwgt = ztotwgt + wgtiau(jt)
+ WRITE(numout,*) ' ', jt, ' ', wgtiau(jt)
+ END DO
+ WRITE(numout,*) ' ==================================='
+ WRITE(numout,*) ' Time-integrated weight = ', ztotwgt
+ WRITE(numout,*) ' ==================================='
+ ENDIF
+
+ ENDIF
+
+ !--------------------------------------------------------------------
+ ! Allocate and initialize the increment arrays
+ !--------------------------------------------------------------------
+
+ ALLOCATE( t_bkginc (jpi,jpj,jpk) ) ; t_bkginc (:,:,:) = 0._wp
+ ALLOCATE( s_bkginc (jpi,jpj,jpk) ) ; s_bkginc (:,:,:) = 0._wp
+ ALLOCATE( u_bkginc (jpi,jpj,jpk) ) ; u_bkginc (:,:,:) = 0._wp
+ ALLOCATE( v_bkginc (jpi,jpj,jpk) ) ; v_bkginc (:,:,:) = 0._wp
+ ALLOCATE( ssh_bkginc (jpi,jpj) ) ; ssh_bkginc (:,:) = 0._wp
+ ALLOCATE( seaice_bkginc(jpi,jpj) ) ; seaice_bkginc(:,:) = 0._wp
+#if defined key_asminc
+ ALLOCATE( ssh_iau (jpi,jpj) ) ; ssh_iau (:,:) = 0._wp
+#endif
+#if defined key_cice && defined key_asminc
+ ALLOCATE( ndaice_da (jpi,jpj) ) ; ndaice_da (:,:) = 0._wp
+#endif
+ !
+ IF ( ln_trainc .OR. ln_dyninc .OR. & !--------------------------------------
+ & ln_sshinc .OR. ln_seaiceinc ) THEN ! Read the increments from file
+ ! !--------------------------------------
+ CALL iom_open( c_asminc, inum )
+ !
+ CALL iom_get( inum, 'time' , zdate_inc )
+ CALL iom_get( inum, 'z_inc_dateb', z_inc_dateb )
+ CALL iom_get( inum, 'z_inc_datef', z_inc_datef )
+ z_inc_dateb = zdate_inc
+ z_inc_datef = zdate_inc
+ !
+ IF(lwp) THEN
+ WRITE(numout,*)
+ WRITE(numout,*) 'asm_inc_init : Assimilation increments valid between dates ', z_inc_dateb,' and ', z_inc_datef
+ WRITE(numout,*) '~~~~~~~~~~~~'
+ ENDIF
+ !
+ IF ( ( z_inc_dateb < ndastp + nn_time0*0.0001_wp ) .OR. &
+ & ( z_inc_datef > ditend_date ) ) &
+ & CALL ctl_warn( ' Validity time of assimilation increments is ', &
+ & ' outside the assimilation interval' )
+
+ IF ( ( ln_asmdin ).AND.( zdate_inc /= ditdin_date ) ) &
+ & CALL ctl_warn( ' Validity time of assimilation increments does ', &
+ & ' not agree with Direct Initialization time' )
+
+ IF ( ln_trainc ) THEN
+ CALL iom_get( inum, jpdom_auto, 'bckint', t_bkginc, 1 )
+ CALL iom_get( inum, jpdom_auto, 'bckins', s_bkginc, 1 )
+ ! Apply the masks
+ t_bkginc(:,:,:) = t_bkginc(:,:,:) * tmask(:,:,:)
+ s_bkginc(:,:,:) = s_bkginc(:,:,:) * tmask(:,:,:)
+ ! Set missing increments to 0.0 rather than 1e+20
+ ! to allow for differences in masks
+ WHERE( ABS( t_bkginc(:,:,:) ) > 1.0e+10 ) t_bkginc(:,:,:) = 0.0
+ WHERE( ABS( s_bkginc(:,:,:) ) > 1.0e+10 ) s_bkginc(:,:,:) = 0.0
+ ENDIF
+
+ IF ( ln_dyninc ) THEN
+ CALL iom_get( inum, jpdom_auto, 'bckinu', u_bkginc, 1 )
+ CALL iom_get( inum, jpdom_auto, 'bckinv', v_bkginc, 1 )
+ ! Apply the masks
+ u_bkginc(:,:,:) = u_bkginc(:,:,:) * umask(:,:,:)
+ v_bkginc(:,:,:) = v_bkginc(:,:,:) * vmask(:,:,:)
+ ! Set missing increments to 0.0 rather than 1e+20
+ ! to allow for differences in masks
+ WHERE( ABS( u_bkginc(:,:,:) ) > 1.0e+10 ) u_bkginc(:,:,:) = 0.0
+ WHERE( ABS( v_bkginc(:,:,:) ) > 1.0e+10 ) v_bkginc(:,:,:) = 0.0
+ ENDIF
+
+ IF ( ln_sshinc ) THEN
+ CALL iom_get( inum, jpdom_auto, 'bckineta', ssh_bkginc, 1 )
+ ! Apply the masks
+ ssh_bkginc(:,:) = ssh_bkginc(:,:) * tmask(:,:,1)
+ ! Set missing increments to 0.0 rather than 1e+20
+ ! to allow for differences in masks
+ WHERE( ABS( ssh_bkginc(:,:) ) > 1.0e+10 ) ssh_bkginc(:,:) = 0.0
+ ENDIF
+
+ IF ( ln_seaiceinc ) THEN
+ CALL iom_get( inum, jpdom_auto, 'bckinseaice', seaice_bkginc, 1 )
+ ! Apply the masks
+ seaice_bkginc(:,:) = seaice_bkginc(:,:) * tmask(:,:,1)
+ ! Set missing increments to 0.0 rather than 1e+20
+ ! to allow for differences in masks
+ WHERE( ABS( seaice_bkginc(:,:) ) > 1.0e+10 ) seaice_bkginc(:,:) = 0.0
+ ENDIF
+ !
+ CALL iom_close( inum )
+ !
+ ENDIF
+ !
+ ! !--------------------------------------
+ IF ( ln_dyninc .AND. nn_divdmp > 0 ) THEN ! Apply divergence damping filter
+ ! !--------------------------------------
+ ALLOCATE( zhdiv(jpi,jpj) )
+ !
+ DO jt = 1, nn_divdmp
+ !
+ DO jk = 1, jpkm1 ! zhdiv = e1e1 * div
+ zhdiv(:,:) = 0._wp
+ DO_2D( 0, 0, 0, 0 )
+ zhdiv(ji,jj) = ( e2u(ji ,jj) * e3u(ji ,jj,jk,Kmm) * u_bkginc(ji ,jj,jk) &
+ & - e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm) * u_bkginc(ji-1,jj,jk) &
+ & + e1v(ji,jj ) * e3v(ji,jj ,jk,Kmm) * v_bkginc(ji,jj ,jk) &
+ & - e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) * v_bkginc(ji,jj-1,jk) ) &
+ & / e3t(ji,jj,jk,Kmm)
+ END_2D
+ CALL lbc_lnk( 'asminc', zhdiv, 'T', 1. ) ! lateral boundary cond. (no sign change)
+ !
+ DO_2D( 0, 0, 0, 0 )
+ u_bkginc(ji,jj,jk) = u_bkginc(ji,jj,jk) &
+ & + 0.2_wp * ( zhdiv(ji+1,jj) - zhdiv(ji ,jj) ) * r1_e1u(ji,jj) * umask(ji,jj,jk)
+ v_bkginc(ji,jj,jk) = v_bkginc(ji,jj,jk) &
+ & + 0.2_wp * ( zhdiv(ji,jj+1) - zhdiv(ji,jj ) ) * r1_e2v(ji,jj) * vmask(ji,jj,jk)
+ END_2D
+ END DO
+ !
+ END DO
+ !
+ DEALLOCATE( zhdiv )
+ !
+ ENDIF
+ !
+ ! !-----------------------------------------------------
+ IF ( ln_asmdin ) THEN ! Allocate and initialize the background state arrays
+ ! !-----------------------------------------------------
+ !
+ ALLOCATE( t_bkg (jpi,jpj,jpk) ) ; t_bkg (:,:,:) = 0._wp
+ ALLOCATE( s_bkg (jpi,jpj,jpk) ) ; s_bkg (:,:,:) = 0._wp
+ ALLOCATE( u_bkg (jpi,jpj,jpk) ) ; u_bkg (:,:,:) = 0._wp
+ ALLOCATE( v_bkg (jpi,jpj,jpk) ) ; v_bkg (:,:,:) = 0._wp
+ ALLOCATE( ssh_bkg(jpi,jpj) ) ; ssh_bkg(:,:) = 0._wp
+ !
+ !
+ !--------------------------------------------------------------------
+ ! Read from file the background state at analysis time
+ !--------------------------------------------------------------------
+ !
+ CALL iom_open( c_asmdin, inum )
+ !
+ CALL iom_get( inum, 'rdastp', zdate_bkg )
+ !
+ IF(lwp) THEN
+ WRITE(numout,*)
+ WRITE(numout,*) ' ==>>> Assimilation background state valid at : ', zdate_bkg
+ WRITE(numout,*)
+ ENDIF
+ !
+ IF ( zdate_bkg /= ditdin_date ) &
+ & CALL ctl_warn( ' Validity time of assimilation background state does', &
+ & ' not agree with Direct Initialization time' )
+ !
+ IF ( ln_trainc ) THEN
+ CALL iom_get( inum, jpdom_auto, 'tn', t_bkg )
+ CALL iom_get( inum, jpdom_auto, 'sn', s_bkg )
+ t_bkg(:,:,:) = t_bkg(:,:,:) * tmask(:,:,:)
+ s_bkg(:,:,:) = s_bkg(:,:,:) * tmask(:,:,:)
+ ENDIF
+ !
+ IF ( ln_dyninc ) THEN
+ CALL iom_get( inum, jpdom_auto, 'un', u_bkg )
+ CALL iom_get( inum, jpdom_auto, 'vn', v_bkg )
+ u_bkg(:,:,:) = u_bkg(:,:,:) * umask(:,:,:)
+ v_bkg(:,:,:) = v_bkg(:,:,:) * vmask(:,:,:)
+ ENDIF
+ !
+ IF ( ln_sshinc ) THEN
+ CALL iom_get( inum, jpdom_auto, 'sshn', ssh_bkg )
+ ssh_bkg(:,:) = ssh_bkg(:,:) * tmask(:,:,1)
+ ENDIF
+ !
+ CALL iom_close( inum )
+ !
+ ENDIF
+ !
+ IF(lwp) WRITE(numout,*) ' ==>>> Euler time step switch is ', l_1st_euler
+ !
+ IF( lk_asminc ) THEN !== data assimilation ==!
+ IF( ln_bkgwri ) CALL asm_bkg_wri( nit000 - 1, Kmm ) ! Output background fields
+ IF( ln_asmdin ) THEN ! Direct initialization
+ IF( ln_trainc ) CALL tra_asm_inc( nit000 - 1, Kbb, Kmm, ts , Krhs ) ! Tracers
+ IF( ln_dyninc ) CALL dyn_asm_inc( nit000 - 1, Kbb, Kmm, uu, vv, Krhs ) ! Dynamics
+ IF( ln_sshinc ) CALL ssh_asm_inc( nit000 - 1, Kbb, Kmm ) ! SSH
+ ENDIF
+ ENDIF
+ !
+ END SUBROUTINE asm_inc_init
+
+
+ SUBROUTINE tra_asm_inc( kt, Kbb, Kmm, pts, Krhs )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE tra_asm_inc ***
+ !!
+ !! ** Purpose : Apply the tracer (T and S) assimilation increments
+ !!
+ !! ** Method : Direct initialization or Incremental Analysis Updating
+ !!
+ !! ** Action :
+ !!----------------------------------------------------------------------
+ INTEGER , INTENT(in ) :: kt ! Current time step
+ 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
+ INTEGER :: it
+ REAL(wp) :: zincwgt ! IAU weight for current time step
+ REAL (wp), DIMENSION(jpi,jpj,jpk) :: fzptnz ! 3d 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
+ DO jk = 1, jpkm1
+ CALL eos_fzp( pts(:,:,jk,jp_sal,Kmm), fzptnz(:,:,jk), gdept(:,:,jk,Kmm) )
+ END DO
+ !
+ ! !--------------------------------------
+ IF ( ln_asmiau ) THEN ! Incremental Analysis Updating
+ ! !--------------------------------------
+ !
+ IF ( ( kt >= nitiaustr_r ).AND.( kt <= nitiaufin_r ) ) THEN
+ !
+ it = kt - nit000 + 1
+ zincwgt = wgtiau(it) / rn_Dt ! IAU weight for the current time step
+ !
+ IF(lwp) THEN
+ WRITE(numout,*)
+ WRITE(numout,*) 'tra_asm_inc : Tracer IAU at time step = ', kt,' with IAU weight = ', wgtiau(it)
+ WRITE(numout,*) '~~~~~~~~~~~~'
+ ENDIF
+ !
+ ! 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(:,:,jk) > 0.0_wp .OR. &
+ & pts(:,:,jk,jp_tem,Kmm) + pts(:,:,jk,jp_tem,Krhs) + t_bkginc(:,:,jk) * wgtiau(it) > fzptnz(:,:,jk) )
+ pts(:,:,jk,jp_tem,Krhs) = pts(:,:,jk,jp_tem,Krhs) + t_bkginc(:,:,jk) * zincwgt
+ END WHERE
+ ELSE
+ pts(:,:,jk,jp_tem,Krhs) = pts(:,:,jk,jp_tem,Krhs) + t_bkginc(:,:,jk) * zincwgt
+ ENDIF
+ IF (ln_salfix) THEN
+ ! Do not apply negative increments if the salinity will fall below a specified
+ ! minimum value salfixmin
+ WHERE(s_bkginc(:,:,jk) > 0.0_wp .OR. &
+ & pts(:,:,jk,jp_sal,Kmm) + pts(:,:,jk,jp_sal,Krhs) + s_bkginc(:,:,jk) * wgtiau(it) > salfixmin )
+ pts(:,:,jk,jp_sal,Krhs) = pts(:,:,jk,jp_sal,Krhs) + s_bkginc(:,:,jk) * zincwgt
+ END WHERE
+ ELSE
+ pts(:,:,jk,jp_sal,Krhs) = pts(:,:,jk,jp_sal,Krhs) + s_bkginc(:,:,jk) * zincwgt
+ ENDIF
+ END DO
+ !
+ ENDIF
+ !
+ IF ( kt == nitiaufin_r + 1 ) THEN ! For bias crcn to work
+ DEALLOCATE( t_bkginc )
+ DEALLOCATE( s_bkginc )
+ ENDIF
+ ! !--------------------------------------
+ ELSEIF ( ln_asmdin ) THEN ! Direct Initialization
+ ! !--------------------------------------
+ !
+ IF ( kt == nitdin_r ) THEN
+ !
+ l_1st_euler = .TRUE. ! Force Euler forward step
+ !
+ ! 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
+ ELSE
+ pts(:,:,:,jp_tem,Kmm) = t_bkg(:,:,:) + t_bkginc(:,:,:)
+ ENDIF
+ IF (ln_salfix) THEN
+ ! Do not apply negative increments if the salinity will fall below a specified
+ ! minimum value salfixmin
+ WHERE( s_bkginc(:,:,:) > 0.0_wp .OR. pts(:,:,:,jp_sal,Kmm) + s_bkginc(:,:,:) > salfixmin )
+ pts(:,:,:,jp_sal,Kmm) = s_bkg(:,:,:) + s_bkginc(:,:,:)
+ END WHERE
+ ELSE
+ pts(:,:,:,jp_sal,Kmm) = s_bkg(:,:,:) + s_bkginc(:,:,:)
+ 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. lk_c1d .AND. .NOT. ln_isfcav) &
+ & CALL zps_hde ( kt, Kmm, 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. lk_c1d .AND. ln_isfcav) &
+ & CALL zps_hde_isf( nit000, Kmm, 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
+
+ DEALLOCATE( t_bkginc )
+ DEALLOCATE( s_bkginc )
+ DEALLOCATE( t_bkg )
+ DEALLOCATE( s_bkg )
+ ENDIF
+ !
+ ENDIF
+ ! Perhaps the following call should be in step
+ IF ( ln_seaiceinc ) CALL seaice_asm_inc ( kt ) ! apply sea ice concentration increment
+ !
+ END SUBROUTINE tra_asm_inc
+
+
+ SUBROUTINE dyn_asm_inc( kt, Kbb, Kmm, puu, pvv, Krhs )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE dyn_asm_inc ***
+ !!
+ !! ** Purpose : Apply the dynamics (u and v) assimilation increments.
+ !!
+ !! ** Method : Direct initialization or Incremental Analysis Updating.
+ !!
+ !! ** Action :
+ !!----------------------------------------------------------------------
+ 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 :: jk
+ INTEGER :: it
+ REAL(wp) :: zincwgt ! IAU weight for current time step
+ !!----------------------------------------------------------------------
+ !
+ ! !--------------------------------------------
+ IF ( ln_asmiau ) THEN ! Incremental Analysis Updating
+ ! !--------------------------------------------
+ !
+ IF ( ( kt >= nitiaustr_r ).AND.( kt <= nitiaufin_r ) ) THEN
+ !
+ it = kt - nit000 + 1
+ zincwgt = wgtiau(it) / rn_Dt ! IAU weight for the current time step
+ !
+ IF(lwp) THEN
+ WRITE(numout,*)
+ WRITE(numout,*) 'dyn_asm_inc : Dynamics IAU at time step = ', kt,' with IAU weight = ', wgtiau(it)
+ WRITE(numout,*) '~~~~~~~~~~~~'
+ ENDIF
+ !
+ ! Update the dynamic tendencies
+ DO jk = 1, jpkm1
+ puu(:,:,jk,Krhs) = puu(:,:,jk,Krhs) + u_bkginc(:,:,jk) * zincwgt
+ pvv(:,:,jk,Krhs) = pvv(:,:,jk,Krhs) + v_bkginc(:,:,jk) * zincwgt
+ END DO
+ !
+ IF ( kt == nitiaufin_r ) THEN
+ DEALLOCATE( u_bkginc )
+ DEALLOCATE( v_bkginc )
+ ENDIF
+ !
+ ENDIF
+ ! !-----------------------------------------
+ ELSEIF ( ln_asmdin ) THEN ! Direct Initialization
+ ! !-----------------------------------------
+ !
+ IF ( kt == nitdin_r ) THEN
+ !
+ l_1st_euler = .TRUE. ! Force Euler forward step
+ !
+ ! Initialize the now fields with the background + increment
+ puu(:,:,:,Kmm) = u_bkg(:,:,:) + u_bkginc(:,:,:)
+ pvv(:,:,:,Kmm) = v_bkg(:,:,:) + v_bkginc(:,:,:)
+ !
+ puu(:,:,:,Kbb) = puu(:,:,:,Kmm) ! Update before fields
+ pvv(:,:,:,Kbb) = pvv(:,:,:,Kmm)
+ !
+ DEALLOCATE( u_bkg )
+ DEALLOCATE( v_bkg )
+ DEALLOCATE( u_bkginc )
+ DEALLOCATE( v_bkginc )
+ ENDIF
+ !
+ ENDIF
+ !
+ END SUBROUTINE dyn_asm_inc
+
+
+ SUBROUTINE ssh_asm_inc( kt, Kbb, Kmm )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE ssh_asm_inc ***
+ !!
+ !! ** Purpose : Apply the sea surface height assimilation increment.
+ !!
+ !! ** Method : Direct initialization or Incremental Analysis Updating.
+ !!
+ !! ** Action :
+ !!----------------------------------------------------------------------
+ INTEGER, INTENT(IN) :: kt ! Current time step
+ INTEGER, INTENT(IN) :: Kbb, Kmm ! Current time step
+ !
+ INTEGER :: it
+ INTEGER :: jk
+ REAL(wp) :: zincwgt ! IAU weight for current time step
+ !!----------------------------------------------------------------------
+ !
+ ! !-----------------------------------------
+ IF ( ln_asmiau ) THEN ! Incremental Analysis Updating
+ ! !-----------------------------------------
+ !
+ IF ( ( kt >= nitiaustr_r ).AND.( kt <= nitiaufin_r ) ) THEN
+ !
+ it = kt - nit000 + 1
+ zincwgt = wgtiau(it) / rn_Dt ! IAU weight for the current time step
+ !
+ IF(lwp) THEN
+ WRITE(numout,*)
+ WRITE(numout,*) 'ssh_asm_inc : SSH IAU at time step = ', &
+ & kt,' with IAU weight = ', wgtiau(it)
+ WRITE(numout,*) '~~~~~~~~~~~~'
+ ENDIF
+ !
+ ! Save the tendency associated with the IAU weighted SSH increment
+ ! (applied in dynspg.*)
+#if defined key_asminc
+ ssh_iau(:,:) = ssh_bkginc(:,:) * zincwgt
+#endif
+ !
+ ELSE IF( kt == nitiaufin_r+1 ) THEN
+ !
+ ! test on ssh_bkginc needed as ssh_asm_inc is called twice by time step
+ IF (ALLOCATED(ssh_bkginc)) DEALLOCATE( ssh_bkginc )
+ !
+#if defined key_asminc
+ ssh_iau(:,:) = 0._wp
+#endif
+ !
+ ENDIF
+ ! !-----------------------------------------
+ ELSEIF ( ln_asmdin ) THEN ! Direct Initialization
+ ! !-----------------------------------------
+ !
+ IF ( kt == nitdin_r ) THEN
+ !
+ l_1st_euler = .TRUE. ! Force Euler forward step
+ !
+ ssh(:,:,Kmm) = ssh_bkg(:,:) + ssh_bkginc(:,:) ! Initialize the now fields the background + increment
+ !
+ ssh(:,:,Kbb) = ssh(:,:,Kmm) ! Update before fields
+!!st11
+#if ! defined key_qco
+ e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm)
+#endif
+!!st11
+!!gm why not e3u(:,:,:,Kbb), e3v(:,:,:,Kbb), gdept(:,:,jk,Kbb) ????
+ !
+ DEALLOCATE( ssh_bkg )
+ DEALLOCATE( ssh_bkginc )
+ !
+ ENDIF
+ !
+ ENDIF
+ !
+ END SUBROUTINE ssh_asm_inc
+
+
+ SUBROUTINE ssh_asm_div( kt, Kbb, Kmm, phdivn )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE ssh_asm_div ***
+ !!
+ !! ** Purpose : ssh increment with z* is incorporated via a correction of the local divergence
+ !! across all the water column
+ !!
+ !! ** Method :
+ !! CAUTION : sshiau is positive (inflow) decreasing the
+ !! divergence and expressed in m/s
+ !!
+ !! ** Action : phdivn decreased by the ssh increment
+ !!----------------------------------------------------------------------
+ INTEGER, INTENT(IN) :: kt ! ocean time-step index
+ INTEGER, INTENT(IN) :: Kbb, Kmm ! time level indices
+ REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: phdivn ! horizontal divergence
+ !!
+ INTEGER :: jk ! dummy loop index
+ REAL(wp), DIMENSION(:,:) , POINTER :: ztim ! local array
+ !!----------------------------------------------------------------------
+ !
+#if defined key_asminc
+ CALL ssh_asm_inc( kt, Kbb, Kmm ) !== (calculate increments)
+ !
+ IF( ln_linssh ) THEN
+ phdivn(:,:,1) = phdivn(:,:,1) - ssh_iau(:,:) / e3t(:,:,1,Kmm) * tmask(:,:,1)
+ ELSE
+ ALLOCATE( ztim(jpi,jpj) )
+ ztim(:,:) = ssh_iau(:,:) / ( ht(:,:) + 1.0 - ssmask(:,:) )
+ DO jk = 1, jpkm1
+ phdivn(:,:,jk) = phdivn(:,:,jk) - ztim(:,:) * tmask(:,:,jk)
+ END DO
+ !
+ DEALLOCATE(ztim)
+ ENDIF
+#endif
+ !
+ END SUBROUTINE ssh_asm_div
+
+
+ SUBROUTINE seaice_asm_inc( kt, kindic )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE seaice_asm_inc ***
+ !!
+ !! ** Purpose : Apply the sea ice assimilation increment.
+ !!
+ !! ** Method : Direct initialization or Incremental Analysis Updating.
+ !!
+ !! ** Action :
+ !!
+ !!----------------------------------------------------------------------
+ INTEGER, INTENT(in) :: kt ! Current time step
+ INTEGER, INTENT(in), OPTIONAL :: kindic ! flag for disabling the deallocation
+ !
+ INTEGER :: it
+ REAL(wp) :: zincwgt ! IAU weight for current time step
+#if defined key_si3
+ REAL(wp), DIMENSION(jpi,jpj) :: zofrld, zohicif, zseaicendg, zhicifinc
+ REAL(wp) :: zhicifmin = 0.5_wp ! ice minimum depth in metres
+#endif
+ !!----------------------------------------------------------------------
+ !
+ ! !-----------------------------------------
+ IF ( ln_asmiau ) THEN ! Incremental Analysis Updating
+ ! !-----------------------------------------
+ !
+ IF ( ( kt >= nitiaustr_r ).AND.( kt <= nitiaufin_r ) ) THEN
+ !
+ it = kt - nit000 + 1
+ zincwgt = wgtiau(it) ! IAU weight for the current time step
+ ! note this is not a tendency so should not be divided by rn_Dt (as with the tracer and other increments)
+ !
+ IF(lwp) THEN
+ WRITE(numout,*)
+ WRITE(numout,*) 'seaice_asm_inc : sea ice conc IAU at time step = ', kt,' with IAU weight = ', wgtiau(it)
+ WRITE(numout,*) '~~~~~~~~~~~~'
+ ENDIF
+ !
+ ! Sea-ice : SI3 case
+ !
+#if defined key_si3
+ zofrld (:,:) = 1._wp - at_i(:,:)
+ zohicif(:,:) = hm_i(:,:)
+ !
+ at_i (:,:) = 1. - MIN( MAX( 1.-at_i (:,:) - seaice_bkginc(:,:) * zincwgt, 0.0_wp), 1.0_wp)
+ at_i_b(:,:) = 1. - MIN( MAX( 1.-at_i_b(:,:) - seaice_bkginc(:,:) * zincwgt, 0.0_wp), 1.0_wp)
+ fr_i(:,:) = at_i(:,:) ! adjust ice fraction
+ !
+ zseaicendg(:,:) = zofrld(:,:) - (1. - at_i(:,:)) ! find out actual sea ice nudge applied
+ !
+ ! Nudge sea ice depth to bring it up to a required minimum depth
+ WHERE( zseaicendg(:,:) > 0.0_wp .AND. hm_i(:,:) < zhicifmin )
+ zhicifinc(:,:) = (zhicifmin - hm_i(:,:)) * zincwgt
+ ELSEWHERE
+ zhicifinc(:,:) = 0.0_wp
+ END WHERE
+ !
+ ! nudge ice depth
+ hm_i (:,:) = hm_i (:,:) + zhicifinc(:,:)
+ !
+ ! seaice salinity balancing (to add)
+#endif
+ !
+#if defined key_cice && defined key_asminc
+ ! Sea-ice : CICE case. Pass ice increment tendency into CICE
+ ndaice_da(:,:) = seaice_bkginc(:,:) * zincwgt / rn_Dt
+#endif
+ !
+ IF ( kt == nitiaufin_r ) THEN
+ DEALLOCATE( seaice_bkginc )
+ ENDIF
+ !
+ ELSE
+ !
+#if defined key_cice && defined key_asminc
+ ndaice_da(:,:) = 0._wp ! Sea-ice : CICE case. Zero ice increment tendency into CICE
+#endif
+ !
+ ENDIF
+ ! !-----------------------------------------
+ ELSEIF ( ln_asmdin ) THEN ! Direct Initialization
+ ! !-----------------------------------------
+ !
+ IF ( kt == nitdin_r ) THEN
+ !
+ l_1st_euler = .TRUE. ! Force Euler forward step
+ !
+ ! Sea-ice : SI3 case
+ !
+#if defined key_si3
+ zofrld (:,:) = 1._wp - at_i(:,:)
+ zohicif(:,:) = hm_i(:,:)
+ !
+ ! Initialize the now fields the background + increment
+ at_i(:,:) = 1. - MIN( MAX( 1.-at_i(:,:) - seaice_bkginc(:,:), 0.0_wp), 1.0_wp)
+ at_i_b(:,:) = at_i(:,:)
+ fr_i(:,:) = at_i(:,:) ! adjust ice fraction
+ !
+ zseaicendg(:,:) = zofrld(:,:) - (1. - at_i(:,:)) ! find out actual sea ice nudge applied
+ !
+ ! Nudge sea ice depth to bring it up to a required minimum depth
+ WHERE( zseaicendg(:,:) > 0.0_wp .AND. hm_i(:,:) < zhicifmin )
+ zhicifinc(:,:) = zhicifmin - hm_i(:,:)
+ ELSEWHERE
+ zhicifinc(:,:) = 0.0_wp
+ END WHERE
+ !
+ ! nudge ice depth
+ hm_i (:,:) = hm_i (:,:) + zhicifinc(:,:)
+ !
+ ! seaice salinity balancing (to add)
+#endif
+ !
+#if defined key_cice && defined key_asminc
+ ! Sea-ice : CICE case. Pass ice increment tendency into CICE
+ ndaice_da(:,:) = seaice_bkginc(:,:) / rn_Dt
+#endif
+ IF ( .NOT. PRESENT(kindic) ) THEN
+ DEALLOCATE( seaice_bkginc )
+ END IF
+ !
+ ELSE
+ !
+#if defined key_cice && defined key_asminc
+ ndaice_da(:,:) = 0._wp ! Sea-ice : CICE case. Zero ice increment tendency into CICE
+#endif
+ !
+ ENDIF
+
+!#if defined defined key_si3 || defined key_cice
+!
+! IF (ln_seaicebal ) THEN
+! !! balancing salinity increments
+! !! simple case from limflx.F90 (doesn't include a mass flux)
+! !! assumption is that as ice concentration is reduced or increased
+! !! the snow and ice depths remain constant
+! !! note that snow is being created where ice concentration is being increased
+! !! - could be more sophisticated and
+! !! not do this (but would need to alter h_snow)
+!
+! usave(:,:,:)=sb(:,:,:) ! use array as a temporary store
+!
+! DO jj = 1, jpj
+! DO ji = 1, jpi
+! ! calculate change in ice and snow mass per unit area
+! ! positive values imply adding salt to the ocean (results from ice formation)
+! ! fwf : ice formation and melting
+!
+! zfons = ( -nfresh_da(ji,jj)*soce + nfsalt_da(ji,jj) )*rn_Dt
+!
+! ! change salinity down to mixed layer depth
+! mld=hmld_kara(ji,jj)
+!
+! ! prevent small mld
+! ! less than 10m can cause salinity instability
+! IF (mld < 10) mld=10
+!
+! ! set to bottom of a level
+! DO jk = jpk-1, 2, -1
+! IF ((mld > gdepw(ji,jj,jk,Kmm)) .and. (mld < gdepw(ji,jj,jk+1,Kmm))) THEN
+! mld=gdepw(ji,jj,jk+1,Kmm)
+! jkmax=jk
+! ENDIF
+! ENDDO
+!
+! ! avoid applying salinity balancing in shallow water or on land
+! !
+!
+! ! dsal_ocn (psu kg m^-2) / (kg m^-3 * m)
+!
+! dsal_ocn=0.0_wp
+! sal_thresh=5.0_wp ! minimum salinity threshold for salinity balancing
+!
+! if (tmask(ji,jj,1) > 0 .AND. tmask(ji,jj,jkmax) > 0 ) &
+! dsal_ocn = zfons / (rhop(ji,jj,1) * mld)
+!
+! ! put increments in for levels in the mixed layer
+! ! but prevent salinity below a threshold value
+!
+! DO jk = 1, jkmax
+!
+! IF (dsal_ocn > 0.0_wp .or. sb(ji,jj,jk)+dsal_ocn > sal_thresh) THEN
+! sb(ji,jj,jk) = sb(ji,jj,jk) + dsal_ocn
+! sn(ji,jj,jk) = sn(ji,jj,jk) + dsal_ocn
+! ENDIF
+!
+! ENDDO
+!
+! ! ! salt exchanges at the ice/ocean interface
+! ! zpmess = zfons / rDt_ice ! rDt_ice is ice timestep
+! !
+! !! Adjust fsalt. A +ve fsalt means adding salt to ocean
+! !! fsalt(ji,jj) = fsalt(ji,jj) + zpmess ! adjust fsalt
+! !!
+! !! emps(ji,jj) = emps(ji,jj) + zpmess ! or adjust emps (see icestp1d)
+! !! ! E-P (kg m-2 s-2)
+! ! emp(ji,jj) = emp(ji,jj) + zpmess ! E-P (kg m-2 s-2)
+! ENDDO !ji
+! ENDDO !jj!
+!
+! ENDIF !ln_seaicebal
+!
+!#endif
+ !
+ ENDIF
+ !
+ END SUBROUTINE seaice_asm_inc
+
+ !!======================================================================
+END MODULE asminc
Index: /NEMO/branches/2020/r12377_ticket2386/src/SWE/diawri.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/SWE/diawri.F90 (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/src/SWE/diawri.F90 (revision 13540)
@@ -0,0 +1,985 @@
+MODULE diawri
+ !!======================================================================
+ !! *** MODULE diawri ***
+ !! Ocean diagnostics : write ocean output files
+ !!=====================================================================
+ !! History : OPA ! 1991-03 (M.-A. Foujols) Original code
+ !! 4.0 ! 1991-11 (G. Madec)
+ !! ! 1992-06 (M. Imbard) correction restart file
+ !! ! 1992-07 (M. Imbard) split into diawri and rstwri
+ !! ! 1993-03 (M. Imbard) suppress writibm
+ !! ! 1998-01 (C. Levy) NETCDF format using ioipsl INTERFACE
+ !! ! 1999-02 (E. Guilyardi) name of netCDF files + variables
+ !! 8.2 ! 2000-06 (M. Imbard) Original code (diabort.F)
+ !! NEMO 1.0 ! 2002-06 (A.Bozec, E. Durand) Original code (diainit.F)
+ !! - ! 2002-09 (G. Madec) F90: Free form and module
+ !! - ! 2002-12 (G. Madec) merge of diabort and diainit, F90
+ !! ! 2005-11 (V. Garnier) Surface pressure gradient organization
+ !! 3.2 ! 2008-11 (B. Lemaire) creation from old diawri
+ !! 3.7 ! 2014-01 (G. Madec) remove eddy induced velocity from no-IOM output
+ !! ! change name of output variables in dia_wri_state
+ !!----------------------------------------------------------------------
+
+ !!----------------------------------------------------------------------
+ !! dia_wri : create the standart output files
+ !! dia_wri_state : create an output NetCDF file for a single instantaeous ocean state and forcing fields
+ !!----------------------------------------------------------------------
+ USE oce ! ocean dynamics and tracers
+ USE isf_oce
+ USE isfcpl
+ USE abl ! abl variables in case ln_abl = .true.
+ USE dom_oce ! ocean space and time domain
+ USE phycst ! physical constants
+ USE dianam ! build name of file (routine)
+ USE diahth ! thermocline diagnostics
+ USE dynadv , ONLY: ln_dynadv_vec
+ USE icb_oce ! Icebergs
+ USE icbdia ! Iceberg budgets
+ USE ldftra ! lateral physics: eddy diffusivity coef.
+ USE ldfdyn ! lateral physics: eddy viscosity coef.
+ USE sbc_oce ! Surface boundary condition: ocean fields
+ USE sbc_ice ! Surface boundary condition: ice fields
+ USE sbcssr ! restoring term toward SST/SSS climatology
+ USE sbcwave ! wave parameters
+ USE wet_dry ! wetting and drying
+ USE zdf_oce ! ocean vertical physics
+ USE zdfdrg ! ocean vertical physics: top/bottom friction
+ USE zdfmxl ! mixed layer
+ !
+ USE lbclnk ! ocean lateral boundary conditions (or mpp link)
+ USE in_out_manager ! I/O manager
+ USE dia25h ! 25h Mean output
+ USE iom !
+ USE ioipsl !
+
+#if defined key_si3
+ USE ice
+ USE icewri
+#endif
+ USE lib_mpp ! MPP library
+ USE timing ! preformance summary
+ USE diu_bulk ! diurnal warm layer
+ USE diu_coolskin ! Cool skin
+
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC dia_wri ! routines called by step.F90
+ PUBLIC dia_wri_state
+ PUBLIC dia_wri_alloc ! Called by nemogcm module
+#if ! defined key_iomput
+ PUBLIC dia_wri_alloc_abl ! Called by sbcabl module (if ln_abl = .true.)
+#endif
+ INTEGER :: nid_T, nz_T, nh_T, ndim_T, ndim_hT ! grid_T file
+ INTEGER :: nb_T , ndim_bT ! grid_T file
+ INTEGER :: nid_U, nz_U, nh_U, ndim_U, ndim_hU ! grid_U file
+ INTEGER :: nid_V, nz_V, nh_V, ndim_V, ndim_hV ! grid_V file
+ INTEGER :: nid_W, nz_W, nh_W ! grid_W file
+ INTEGER :: nid_A, nz_A, nh_A, ndim_A, ndim_hA ! grid_ABL file
+ INTEGER :: ndex(1) ! ???
+ INTEGER, SAVE, ALLOCATABLE, DIMENSION(:) :: ndex_hT, ndex_hU, ndex_hV
+ INTEGER, SAVE, ALLOCATABLE, DIMENSION(:) :: ndex_hA, ndex_A ! ABL
+ INTEGER, SAVE, ALLOCATABLE, DIMENSION(:) :: ndex_T, ndex_U, ndex_V
+ INTEGER, SAVE, ALLOCATABLE, DIMENSION(:) :: ndex_bT
+
+ !! * Substitutions
+# include "do_loop_substitute.h90"
+!!st12
+# include "domzgr_substitute.h90"
+ !!----------------------------------------------------------------------
+ !! NEMO/OCE 4.0 , NEMO Consortium (2018)
+ !! $Id: diawri.F90 12667 2020-04-03 14:22:29Z gm $
+ !! Software governed by the CeCILL license (see ./LICENSE)
+ !!----------------------------------------------------------------------
+CONTAINS
+
+#if defined key_iomput
+ !!----------------------------------------------------------------------
+ !! 'key_iomput' use IOM library
+ !!----------------------------------------------------------------------
+ INTEGER FUNCTION dia_wri_alloc()
+ !
+ dia_wri_alloc = 0
+ !
+ END FUNCTION dia_wri_alloc
+
+
+ SUBROUTINE dia_wri( kt, Kmm )
+ !!---------------------------------------------------------------------
+ !! *** ROUTINE dia_wri ***
+ !!
+ !! ** Purpose : Standard output of opa: dynamics and tracer fields
+ !! NETCDF format is used by default
+ !!
+ !! ** Method : use iom_put
+ !!----------------------------------------------------------------------
+ INTEGER, INTENT( in ) :: kt ! ocean time-step index
+ INTEGER, INTENT( in ) :: Kmm ! ocean time level index
+ !!
+ INTEGER :: ji, jj, jk ! dummy loop indices
+ INTEGER :: ikbot ! local integer
+ REAL(wp):: zztmp , zztmpx ! local scalar
+ REAL(wp):: zztmp2, zztmpy ! - -
+ REAL(wp):: ze3 ! - -
+ REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace
+ REAL(wp), DIMENSION(jpi,jpj,jpk) :: z3d ! 3D workspace
+ !!----------------------------------------------------------------------
+ !
+ IF( ln_timing ) CALL timing_start('dia_wri')
+ !
+ ! Output the initial state and forcings
+ IF( ninist == 1 ) THEN
+ CALL dia_wri_state( Kmm, 'output.init' )
+ ninist = 0
+ ENDIF
+
+ ! 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(:,:,:) )
+ !
+!!st13
+#if ! defined key_qco
+ IF ( iom_use("e3t") .OR. iom_use("e3tdef") ) THEN ! time-varying e3t
+ DO jk = 1, jpk
+ z3d(:,:,jk) = e3t(:,:,jk,Kmm)
+ END DO
+ CALL iom_put( "e3t" , z3d(:,:,:) )
+ CALL iom_put( "e3tdef" , ( ( z3d(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 )
+ 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(:,:,:) )
+ 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(:,:,:) )
+ ENDIF
+ IF ( iom_use("e3w") ) THEN ! time-varying e3w
+ DO jk = 1, jpk
+ z3d(:,:,jk) = e3w(:,:,jk,Kmm)
+ END DO
+ CALL iom_put( "e3w" , z3d(:,:,:) )
+ ENDIF
+#endif
+!!st13
+ IF( ll_wd ) THEN
+ CALL iom_put( "ssh" , (ssh(:,:,Kmm)+ssh_ref)*tmask(:,:,1) ) ! sea surface height (brought back to the reference used for wetting and drying)
+ ELSE
+ CALL iom_put( "ssh" , ssh(:,:,Kmm) ) ! sea surface height
+ ENDIF
+
+!!an
+ IF( iom_use("ht") ) & ! water column at t-point
+ CALL iom_put( "ht" , ht_0(:,:) + ssh(:,:,Kmm) )
+ !
+ IF( iom_use("hu") ) THEN ! water column at u-point
+ z2d(:,:) = 0._wp
+ DO_2D( 1, 0, 1, 0 )
+ z2d(ji,jj) = 0.5_wp * ( e3t(ji ,jj,1,Kmm) * e1e2t(ji ,jj) &
+ & + e3t(ji+1,jj,1,Kmm) * e1e2t(ji+1,jj) ) * r1_e1e2u(ji,jj)
+ END_2D
+ CALL lbc_lnk( 'diawri', z2d, 'U', 1._wp )
+ CALL iom_put( "hu", z2d )
+ ENDIF
+ !
+ IF( iom_use("hv") ) THEN ! water column at v-point
+ z2d(:,:) = 0._wp
+ DO_2D( 1, 0, 1, 0 )
+ z2d(ji,jj) = 0.5_wp * ( e3t(ji,jj+1,1,Kmm) * e1e2t(ji,jj+1) &
+ & + e3t(ji,jj ,1,Kmm) * e1e2t(ji,jj ) ) * r1_e1e2v(ji,jj)
+ END_2D
+ CALL lbc_lnk( 'diawri', z2d, 'V', 1._wp )
+ CALL iom_put( "hv", z2d )
+ ENDIF
+ !
+ IF( iom_use("hf") ) THEN ! water column at f-point
+ z2d(:,:) = 0._wp
+ DO_2D( 1, 0, 1, 0 )
+ z2d(ji,jj) = 0.25_wp * ( 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)
+ END_2D
+ z2d(:,:) = z2d(:,:) * ssfmask(:,:)
+ CALL lbc_lnk( 'diawri', z2d, 'F', 1._wp )
+ CALL iom_put( "hf", z2d )
+ ENDIF
+!!an
+
+ IF( iom_use("wetdep") ) & ! wet depth
+ CALL iom_put( "wetdep" , ht_0(:,:) + ssh(:,:,Kmm) )
+
+ IF ( iom_use("taubot") ) THEN ! bottom stress
+ zztmp = rho0 * 0.25
+ z2d(:,:) = 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)
+ !
+ END_2D
+ CALL lbc_lnk( 'diawri', z2d, 'T', 1. )
+ CALL iom_put( "taubot", z2d )
+ ENDIF
+ !
+ CALL iom_put( "ssu" , uu(:,:,1,Kmm) ) ! surface i-current
+ CALL iom_put( "ssv" , vv(:,:,1,Kmm) ) ! surface j-current
+ CALL iom_put( "woce", ww ) ! vertical velocity
+ !
+
+ IF ( iom_use("sKE") ) THEN ! surface kinetic energy at T point
+ z2d(:,:) = 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) &
+ & + 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) * tmask(ji,jj,1)
+ END_2D
+ !
+ CALL lbc_lnk( 'diawri', z2d, 'T', 1. )
+ IF ( iom_use("sKE" ) ) CALL iom_put( "sKE" , z2d )
+
+ ENDIF
+
+!!an sKEf
+ IF ( iom_use("sKEf") ) THEN ! surface kinetic energy at F point
+ z2d(:,:) = 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) &
+ & + 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 lbc_lnk( 'diawri', z2d, 'F', 1. )
+ CALL iom_put( "sKEf", z2d )
+ ENDIF
+!!an
+ !
+ CALL iom_put( "hdiv", hdiv ) ! Horizontal divergence
+ !
+ ! Output of vorticity terms
+ IF ( iom_use("relvor") .OR. iom_use("plavor") .OR. &
+ & iom_use("relpotvor") .OR. iom_use("abspotvor") .OR. &
+ & iom_use("Ens") ) THEN
+ !
+ z2d(:,:) = 0._wp
+ ze3 = 0._wp
+ DO_2D( 1, 0, 1, 0 )
+ z2d(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 lbc_lnk( 'diawri', z2d, 'F', 1. )
+ CALL iom_put( "relvor", z2d ) ! relative vorticity ( zeta )
+ !
+ CALL iom_put( "plavor", ff_f ) ! planetary vorticity ( f )
+ !
+ DO_2D( 1, 0, 1, 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)
+ IF( ze3 /= 0._wp ) THEN ; ze3 = 4._wp / ze3
+ ELSE ; ze3 = 0._wp
+ ENDIF
+ z2d(ji,jj) = ze3 * z2d(ji,jj)
+ END_2D
+ CALL lbc_lnk( 'diawri', z2d, 'F', 1. )
+ CALL iom_put( "relpotvor", z2d ) ! relative potential vorticity (zeta/h)
+ !
+ DO_2D( 1, 0, 1, 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)
+ 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)
+ END_2D
+ CALL lbc_lnk( 'diawri', z2d, 'F', 1. )
+ CALL iom_put( "abspotvor", z2d ) ! absolute potential vorticity ( q )
+ !
+ DO_2D( 1, 0, 1, 0 )
+ z2d(ji,jj) = 0.5_wp * z2d(ji,jj) * z2d(ji,jj)
+ END_2D
+ CALL lbc_lnk( 'diawri', z2d, 'F', 1. )
+ CALL iom_put( "Ens", z2d ) ! potential enstrophy ( 1/2*q2 )
+ !
+ ENDIF
+
+ !
+ IF( ln_timing ) CALL timing_stop('dia_wri')
+ !
+ END SUBROUTINE dia_wri
+
+#else
+ !!----------------------------------------------------------------------
+ !! Default option use IOIPSL library
+ !!----------------------------------------------------------------------
+
+ INTEGER FUNCTION dia_wri_alloc()
+ !!----------------------------------------------------------------------
+ INTEGER, DIMENSION(2) :: ierr
+ !!----------------------------------------------------------------------
+ IF( nn_write == -1 ) THEN
+ dia_wri_alloc = 0
+ ELSE
+ ierr = 0
+ ALLOCATE( ndex_hT(jpi*jpj) , ndex_T(jpi*jpj*jpk) , &
+ & ndex_hU(jpi*jpj) , ndex_U(jpi*jpj*jpk) , &
+ & ndex_hV(jpi*jpj) , ndex_V(jpi*jpj*jpk) , STAT=ierr(1) )
+ !
+ dia_wri_alloc = MAXVAL(ierr)
+ CALL mpp_sum( 'diawri', dia_wri_alloc )
+ !
+ ENDIF
+ !
+ END FUNCTION dia_wri_alloc
+
+ INTEGER FUNCTION dia_wri_alloc_abl()
+ !!----------------------------------------------------------------------
+ ALLOCATE( ndex_hA(jpi*jpj), ndex_A (jpi*jpj*jpkam1), STAT=dia_wri_alloc_abl)
+ CALL mpp_sum( 'diawri', dia_wri_alloc_abl )
+ !
+ END FUNCTION dia_wri_alloc_abl
+
+
+ SUBROUTINE dia_wri( kt, Kmm )
+ !!---------------------------------------------------------------------
+ !! *** ROUTINE dia_wri ***
+ !!
+ !! ** Purpose : Standard output of opa: dynamics and tracer fields
+ !! NETCDF format is used by default
+ !!
+ !! ** Method : At the beginning of the first time step (nit000),
+ !! define all the NETCDF files and fields
+ !! At each time step call histdef to compute the mean if ncessary
+ !! Each nn_write time step, output the instantaneous or mean fields
+ !!----------------------------------------------------------------------
+ INTEGER, INTENT( in ) :: kt ! ocean time-step index
+ INTEGER, INTENT( in ) :: Kmm ! ocean time level index
+ !
+ LOGICAL :: ll_print = .FALSE. ! =T print and flush numout
+ CHARACTER (len=40) :: clhstnam, clop, clmx ! local names
+ INTEGER :: inum = 11 ! temporary logical unit
+ INTEGER :: ji, jj, jk ! dummy loop indices
+ INTEGER :: ierr ! error code return from allocation
+ INTEGER :: iimi, iima, ipk, it, itmod, ijmi, ijma ! local integers
+ INTEGER :: ipka ! ABL
+ INTEGER :: jn, ierror ! local integers
+ REAL(wp) :: zsto, zout, zmax, zjulian ! local scalars
+ !
+ REAL(wp), DIMENSION(jpi,jpj) :: zw2d ! 2D workspace
+!!st14
+ REAL(wp), DIMENSION(jpi,jpj,jpk) :: zw3d, ze3t, zgdept ! 3D workspace
+ REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zw3d_abl ! ABL 3D workspace
+ !!----------------------------------------------------------------------
+ !
+ IF( ninist == 1 ) THEN !== Output the initial state and forcings ==!
+ CALL dia_wri_state( Kmm, 'output.init' )
+ ninist = 0
+ ENDIF
+ !
+ IF( nn_write == -1 ) RETURN ! we will never do any output
+ !
+ IF( ln_timing ) CALL timing_start('dia_wri')
+ !
+ ! 0. Initialisation
+ ! -----------------
+
+ ll_print = .FALSE. ! local variable for debugging
+ ll_print = ll_print .AND. lwp
+
+ ! Define frequency of output and means
+ clop = "x" ! no use of the mask value (require less cpu time and otherwise the model crashes)
+#if defined key_diainstant
+ zsto = nn_write * rn_Dt
+ clop = "inst("//TRIM(clop)//")"
+#else
+ zsto=rn_Dt
+ clop = "ave("//TRIM(clop)//")"
+#endif
+ zout = nn_write * rn_Dt
+ zmax = ( nitend - nit000 + 1 ) * rn_Dt
+
+ ! Define indices of the horizontal output zoom and vertical limit storage
+ iimi = 1 ; iima = jpi
+ ijmi = 1 ; ijma = jpj
+ ipk = jpk
+ IF(ln_abl) ipka = jpkam1
+
+ ! define time axis
+ it = kt
+ itmod = kt - nit000 + 1
+!!st15
+ ! store e3t for subsitute
+ DO jk = 1, jpk
+ ze3t (:,:,jk) = e3t (:,:,jk,Kmm)
+ zgdept(:,:,jk) = gdept(:,:,jk,Kmm)
+ END DO
+!!st15
+
+ ! 1. Define NETCDF files and fields at beginning of first time step
+ ! -----------------------------------------------------------------
+
+ IF( kt == nit000 ) THEN
+
+ ! Define the NETCDF files (one per grid)
+
+ ! Compute julian date from starting date of the run
+ CALL ymds2ju( nyear, nmonth, nday, rn_Dt, zjulian )
+ zjulian = zjulian - adatrj ! set calendar origin to the beginning of the experiment
+ IF(lwp)WRITE(numout,*)
+ IF(lwp)WRITE(numout,*) 'Date 0 used :', nit000, ' YEAR ', nyear, &
+ & ' MONTH ', nmonth, ' DAY ', nday, 'Julian day : ', zjulian
+ IF(lwp)WRITE(numout,*) ' indexes of zoom = ', iimi, iima, ijmi, ijma, &
+ ' limit storage in depth = ', ipk
+
+ ! WRITE root name in date.file for use by postpro
+ IF(lwp) THEN
+ CALL dia_nam( clhstnam, nn_write,' ' )
+ CALL ctl_opn( inum, 'date.file', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea )
+ WRITE(inum,*) clhstnam
+ CLOSE(inum)
+ ENDIF
+
+ ! Define the T grid FILE ( nid_T )
+
+ CALL dia_nam( clhstnam, nn_write, 'grid_T' )
+ IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam ! filename
+ CALL histbeg( clhstnam, jpi, glamt, jpj, gphit, & ! Horizontal grid: glamt and gphit
+ & iimi, iima-iimi+1, ijmi, ijma-ijmi+1, &
+ & nit000-1, zjulian, rn_Dt, nh_T, nid_T, domain_id=nidom, snc4chunks=snc4set )
+ CALL histvert( nid_T, "deptht", "Vertical T levels", & ! Vertical grid: gdept
+ & "m", ipk, gdept_1d, nz_T, "down" )
+ ! ! Index of ocean points
+ CALL wheneq( jpi*jpj*ipk, tmask, 1, 1., ndex_T , ndim_T ) ! volume
+ CALL wheneq( jpi*jpj , tmask, 1, 1., ndex_hT, ndim_hT ) ! surface
+ !
+ IF( ln_icebergs ) THEN
+ !
+ !! allocation cant go in dia_wri_alloc because ln_icebergs is only set after
+ !! that routine is called from nemogcm, so do it here immediately before its needed
+ ALLOCATE( ndex_bT(jpi*jpj*nclasses), STAT=ierror )
+ CALL mpp_sum( 'diawri', ierror )
+ IF( ierror /= 0 ) THEN
+ CALL ctl_stop('dia_wri: failed to allocate iceberg diagnostic array')
+ RETURN
+ ENDIF
+ !
+ !! iceberg vertical coordinate is class number
+ CALL histvert( nid_T, "class", "Iceberg class", & ! Vertical grid: class
+ & "number", nclasses, class_num, nb_T )
+ !
+ !! each class just needs the surface index pattern
+ ndim_bT = 3
+ DO jn = 1,nclasses
+ ndex_bT((jn-1)*jpi*jpj+1:jn*jpi*jpj) = ndex_hT(1:jpi*jpj)
+ ENDDO
+ !
+ ENDIF
+
+ ! Define the U grid FILE ( nid_U )
+
+ CALL dia_nam( clhstnam, nn_write, 'grid_U' )
+ IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam ! filename
+ CALL histbeg( clhstnam, jpi, glamu, jpj, gphiu, & ! Horizontal grid: glamu and gphiu
+ & iimi, iima-iimi+1, ijmi, ijma-ijmi+1, &
+ & nit000-1, zjulian, rn_Dt, nh_U, nid_U, domain_id=nidom, snc4chunks=snc4set )
+ CALL histvert( nid_U, "depthu", "Vertical U levels", & ! Vertical grid: gdept
+ & "m", ipk, gdept_1d, nz_U, "down" )
+ ! ! Index of ocean points
+ CALL wheneq( jpi*jpj*ipk, umask, 1, 1., ndex_U , ndim_U ) ! volume
+ CALL wheneq( jpi*jpj , umask, 1, 1., ndex_hU, ndim_hU ) ! surface
+
+ ! Define the V grid FILE ( nid_V )
+
+ CALL dia_nam( clhstnam, nn_write, 'grid_V' ) ! filename
+ IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam
+ CALL histbeg( clhstnam, jpi, glamv, jpj, gphiv, & ! Horizontal grid: glamv and gphiv
+ & iimi, iima-iimi+1, ijmi, ijma-ijmi+1, &
+ & nit000-1, zjulian, rn_Dt, nh_V, nid_V, domain_id=nidom, snc4chunks=snc4set )
+ CALL histvert( nid_V, "depthv", "Vertical V levels", & ! Vertical grid : gdept
+ & "m", ipk, gdept_1d, nz_V, "down" )
+ ! ! Index of ocean points
+ CALL wheneq( jpi*jpj*ipk, vmask, 1, 1., ndex_V , ndim_V ) ! volume
+ CALL wheneq( jpi*jpj , vmask, 1, 1., ndex_hV, ndim_hV ) ! surface
+
+ ! Define the W grid FILE ( nid_W )
+
+ CALL dia_nam( clhstnam, nn_write, 'grid_W' ) ! filename
+ IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam
+ CALL histbeg( clhstnam, jpi, glamt, jpj, gphit, & ! Horizontal grid: glamt and gphit
+ & iimi, iima-iimi+1, ijmi, ijma-ijmi+1, &
+ & nit000-1, zjulian, rn_Dt, nh_W, nid_W, domain_id=nidom, snc4chunks=snc4set )
+ CALL histvert( nid_W, "depthw", "Vertical W levels", & ! Vertical grid: gdepw
+ & "m", ipk, gdepw_1d, nz_W, "down" )
+
+ IF( ln_abl ) THEN
+ ! Define the ABL grid FILE ( nid_A )
+ CALL dia_nam( clhstnam, nn_write, 'grid_ABL' )
+ IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam ! filename
+ CALL histbeg( clhstnam, jpi, glamt, jpj, gphit, & ! Horizontal grid: glamt and gphit
+ & iimi, iima-iimi+1, ijmi, ijma-ijmi+1, &
+ & nit000-1, zjulian, rn_Dt, nh_A, nid_A, domain_id=nidom, snc4chunks=snc4set )
+ CALL histvert( nid_A, "ght_abl", "Vertical T levels", & ! Vertical grid: gdept
+ & "m", ipka, ght_abl(2:jpka), nz_A, "up" )
+ ! ! Index of ocean points
+ ALLOCATE( zw3d_abl(jpi,jpj,ipka) )
+ zw3d_abl(:,:,:) = 1._wp
+ CALL wheneq( jpi*jpj*ipka, zw3d_abl, 1, 1., ndex_A , ndim_A ) ! volume
+ CALL wheneq( jpi*jpj , zw3d_abl, 1, 1., ndex_hA, ndim_hA ) ! surface
+ DEALLOCATE(zw3d_abl)
+ ENDIF
+
+ ! Declare all the output fields as NETCDF variables
+
+ ! !!! nid_T : 3D
+ CALL histdef( nid_T, "votemper", "Temperature" , "C" , & ! tn
+ & jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout )
+ CALL histdef( nid_T, "vosaline", "Salinity" , "PSU" , & ! sn
+ & jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout )
+ IF( .NOT.ln_linssh ) THEN
+ CALL histdef( nid_T, "vovvle3t", "Level thickness" , "m" ,& ! ze3t(:,:,:,Kmm)
+ & jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout )
+ CALL histdef( nid_T, "vovvldep", "T point depth" , "m" ,& ! ze3t(:,:,:,Kmm)
+ & jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout )
+ CALL histdef( nid_T, "vovvldef", "Squared level deformation" , "%^2" ,& ! ze3t(:,:,:,Kmm)
+ & jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout )
+ ENDIF
+ ! !!! nid_T : 2D
+ CALL histdef( nid_T, "sosstsst", "Sea Surface temperature" , "C" , & ! sst
+ & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
+ CALL histdef( nid_T, "sosaline", "Sea Surface Salinity" , "PSU" , & ! sss
+ & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
+ CALL histdef( nid_T, "sossheig", "Sea Surface Height" , "m" , & ! ssh
+ & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
+ CALL histdef( nid_T, "sowaflup", "Net Upward Water Flux" , "Kg/m2/s", & ! (emp-rnf)
+ & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
+ CALL histdef( nid_T, "sorunoff", "River runoffs" , "Kg/m2/s", & ! runoffs
+ & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
+ CALL histdef( nid_T, "sosfldow", "downward salt flux" , "PSU/m2/s", & ! sfx
+ & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
+ IF( ln_linssh ) THEN
+ CALL histdef( nid_T, "sosst_cd", "Concentration/Dilution term on temperature" & ! emp * ts(:,:,1,jp_tem,Kmm)
+ & , "KgC/m2/s", & ! sosst_cd
+ & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
+ CALL histdef( nid_T, "sosss_cd", "Concentration/Dilution term on salinity" & ! emp * ts(:,:,1,jp_sal,Kmm)
+ & , "KgPSU/m2/s",& ! sosss_cd
+ & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
+ ENDIF
+ CALL histdef( nid_T, "sohefldo", "Net Downward Heat Flux" , "W/m2" , & ! qns + qsr
+ & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
+ CALL histdef( nid_T, "soshfldo", "Shortwave Radiation" , "W/m2" , & ! qsr
+ & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
+ CALL histdef( nid_T, "somixhgt", "Turbocline Depth" , "m" , & ! hmld
+ & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
+ CALL histdef( nid_T, "somxl010", "Mixed Layer Depth 0.01" , "m" , & ! hmlp
+ & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
+ CALL histdef( nid_T, "soicecov", "Ice fraction" , "[0,1]" , & ! fr_i
+ & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
+ CALL histdef( nid_T, "sowindsp", "wind speed at 10m" , "m/s" , & ! wndm
+ & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
+ !
+ IF( ln_abl ) THEN
+ CALL histdef( nid_A, "t_abl", "Potential Temperature" , "K" , & ! t_abl
+ & jpi, jpj, nh_A, ipka, 1, ipka, nz_A, 32, clop, zsto, zout )
+ CALL histdef( nid_A, "q_abl", "Humidity" , "kg/kg" , & ! q_abl
+ & jpi, jpj, nh_A, ipka, 1, ipka, nz_A, 32, clop, zsto, zout )
+ CALL histdef( nid_A, "u_abl", "Atmospheric U-wind " , "m/s" , & ! u_abl
+ & jpi, jpj, nh_A, ipka, 1, ipka, nz_A, 32, clop, zsto, zout )
+ CALL histdef( nid_A, "v_abl", "Atmospheric V-wind " , "m/s" , & ! v_abl
+ & jpi, jpj, nh_A, ipka, 1, ipka, nz_A, 32, clop, zsto, zout )
+ CALL histdef( nid_A, "tke_abl", "Atmospheric TKE " , "m2/s2" , & ! tke_abl
+ & jpi, jpj, nh_A, ipka, 1, ipka, nz_A, 32, clop, zsto, zout )
+ CALL histdef( nid_A, "avm_abl", "Atmospheric turbulent viscosity", "m2/s" , & ! avm_abl
+ & jpi, jpj, nh_A, ipka, 1, ipka, nz_A, 32, clop, zsto, zout )
+ CALL histdef( nid_A, "avt_abl", "Atmospheric turbulent diffusivity", "m2/s2", & ! avt_abl
+ & jpi, jpj, nh_A, ipka, 1, ipka, nz_A, 32, clop, zsto, zout )
+ CALL histdef( nid_A, "pblh", "Atmospheric boundary layer height " , "m", & ! pblh
+ & jpi, jpj, nh_A, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
+#if defined key_si3
+ CALL histdef( nid_A, "oce_frac", "Fraction of open ocean" , " ", & ! ato_i
+ & jpi, jpj, nh_A, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
+#endif
+ CALL histend( nid_A, snc4chunks=snc4set )
+ ENDIF
+ !
+ IF( ln_icebergs ) THEN
+ CALL histdef( nid_T, "calving" , "calving mass input" , "kg/s" , &
+ & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
+ CALL histdef( nid_T, "calving_heat" , "calving heat flux" , "XXXX" , &
+ & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
+ CALL histdef( nid_T, "berg_floating_melt" , "Melt rate of icebergs + bits" , "kg/m2/s", &
+ & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
+ CALL histdef( nid_T, "berg_stored_ice" , "Accumulated ice mass by class" , "kg" , &
+ & jpi, jpj, nh_T, nclasses , 1, nclasses , nb_T , 32, clop, zsto, zout )
+ IF( ln_bergdia ) THEN
+ CALL histdef( nid_T, "berg_melt" , "Melt rate of icebergs" , "kg/m2/s", &
+ & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
+ CALL histdef( nid_T, "berg_buoy_melt" , "Buoyancy component of iceberg melt rate" , "kg/m2/s", &
+ & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
+ CALL histdef( nid_T, "berg_eros_melt" , "Erosion component of iceberg melt rate" , "kg/m2/s", &
+ & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
+ CALL histdef( nid_T, "berg_conv_melt" , "Convective component of iceberg melt rate", "kg/m2/s", &
+ & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
+ CALL histdef( nid_T, "berg_virtual_area" , "Virtual coverage by icebergs" , "m2" , &
+ & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
+ CALL histdef( nid_T, "bits_src" , "Mass source of bergy bits" , "kg/m2/s", &
+ & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
+ CALL histdef( nid_T, "bits_melt" , "Melt rate of bergy bits" , "kg/m2/s", &
+ & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
+ CALL histdef( nid_T, "bits_mass" , "Bergy bit density field" , "kg/m2" , &
+ & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
+ CALL histdef( nid_T, "berg_mass" , "Iceberg density field" , "kg/m2" , &
+ & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
+ CALL histdef( nid_T, "berg_real_calving" , "Calving into iceberg class" , "kg/s" , &
+ & jpi, jpj, nh_T, nclasses , 1, nclasses , nb_T , 32, clop, zsto, zout )
+ ENDIF
+ ENDIF
+
+ IF( ln_ssr ) THEN
+ CALL histdef( nid_T, "sohefldp", "Surface Heat Flux: Damping" , "W/m2" , & ! qrp
+ & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
+ CALL histdef( nid_T, "sowafldp", "Surface Water Flux: Damping" , "Kg/m2/s", & ! erp
+ & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
+ CALL histdef( nid_T, "sosafldp", "Surface salt flux: damping" , "Kg/m2/s", & ! erp * sn
+ & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
+ ENDIF
+
+ clmx ="l_max(only(x))" ! max index on a period
+! CALL histdef( nid_T, "sobowlin", "Bowl Index" , "W-point", & ! bowl INDEX
+! & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clmx, zsto, zout )
+#if defined key_diahth
+ CALL histdef( nid_T, "sothedep", "Thermocline Depth" , "m" , & ! hth
+ & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
+ CALL histdef( nid_T, "so20chgt", "Depth of 20C isotherm" , "m" , & ! hd20
+ & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
+ CALL histdef( nid_T, "so28chgt", "Depth of 28C isotherm" , "m" , & ! hd28
+ & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
+ 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 histend( nid_T, snc4chunks=snc4set )
+
+ ! !!! nid_U : 3D
+ CALL histdef( nid_U, "vozocrtx", "Zonal Current" , "m/s" , & ! uu(:,:,:,Kmm)
+ & jpi, jpj, nh_U, ipk, 1, ipk, nz_U, 32, clop, zsto, zout )
+ IF( ln_wave .AND. ln_sdw) THEN
+ 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
+ CALL histdef( nid_V, "vomecrty", "Meridional Current" , "m/s" , & ! vv(:,:,:,Kmm)
+ & jpi, jpj, nh_V, ipk, 1, ipk, nz_V, 32, clop, zsto, zout )
+ IF( ln_wave .AND. ln_sdw) THEN
+ 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
+ CALL histdef( nid_W, "vovecrtz", "Vertical Velocity" , "m/s" , & ! ww
+ & jpi, jpj, nh_W, ipk, 1, ipk, nz_W, 32, clop, zsto, zout )
+ CALL histdef( nid_W, "votkeavt", "Vertical Eddy Diffusivity" , "m2/s" , & ! avt
+ & jpi, jpj, nh_W, ipk, 1, ipk, nz_W, 32, clop, zsto, zout )
+ CALL histdef( nid_W, "votkeavm", "Vertical Eddy Viscosity" , "m2/s" , & ! avm
+ & jpi, jpj, nh_W, ipk, 1, ipk, nz_W, 32, clop, zsto, zout )
+
+ IF( ln_zdfddm ) THEN
+ CALL histdef( nid_W,"voddmavs","Salt Vertical Eddy Diffusivity" , "m2/s" , & ! avs
+ & jpi, jpj, nh_W, ipk, 1, ipk, nz_W, 32, clop, zsto, zout )
+ ENDIF
+
+ IF( ln_wave .AND. ln_sdw) THEN
+ CALL histdef( nid_W, "sdvecrtz", "Stokes Drift Vertical Current" , "m/s" , & ! wsd
+ & jpi, jpj, nh_W, ipk, 1, ipk, nz_W, 32, clop, zsto, zout )
+ ENDIF
+ ! !!! nid_W : 2D
+ CALL histend( nid_W, snc4chunks=snc4set )
+
+ IF(lwp) WRITE(numout,*)
+ IF(lwp) WRITE(numout,*) 'End of NetCDF Initialization'
+ IF(ll_print) CALL FLUSH(numout )
+
+ ENDIF
+
+ ! 2. Start writing data
+ ! ---------------------
+
+ ! ndex(1) est utilise ssi l'avant dernier argument est different de
+ ! la taille du tableau en sortie. Dans ce cas , l'avant dernier argument
+ ! donne le nombre d'elements, et ndex la liste des indices a sortir
+
+ IF( lwp .AND. MOD( itmod, nn_write ) == 0 ) THEN
+ WRITE(numout,*) 'dia_wri : write model outputs in NetCDF files at ', kt, 'time-step'
+ WRITE(numout,*) '~~~~~~ '
+ ENDIF
+!!st16
+ IF( .NOT.ln_linssh ) THEN
+ CALL histwrite( nid_T, "votemper", it, ts(:,:,:,jp_tem,Kmm) * ze3t(:,:,:) , ndim_T , ndex_T ) ! heat content
+ CALL histwrite( nid_T, "vosaline", it, ts(:,:,:,jp_sal,Kmm) * ze3t(:,:,:) , ndim_T , ndex_T ) ! salt content
+ CALL histwrite( nid_T, "sosstsst", it, ts(:,:,1,jp_tem,Kmm) * ze3t(:,:,1) , ndim_hT, ndex_hT ) ! sea surface heat content
+ CALL histwrite( nid_T, "sosaline", it, ts(:,:,1,jp_sal,Kmm) * ze3t(:,:,1) , ndim_hT, ndex_hT ) ! sea surface salinity content
+!!st16
+ 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
+ CALL histwrite( nid_T, "sosstsst", it, ts(:,:,1,jp_tem,Kmm) , ndim_hT, ndex_hT ) ! sea surface temperature
+ CALL histwrite( nid_T, "sosaline", it, ts(:,:,1,jp_sal,Kmm) , ndim_hT, ndex_hT ) ! sea surface salinity
+ ENDIF
+ IF( .NOT.ln_linssh ) THEN
+!!st17 if ! defined key_qco
+ zw3d(:,:,:) = ( ( ze3t(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2
+ CALL histwrite( nid_T, "vovvle3t", it, ze3t (:,:,:) , ndim_T , ndex_T ) ! level thickness
+ CALL histwrite( nid_T, "vovvldep", it, zgdept , ndim_T , ndex_T ) ! t-point depth
+!!st17
+ CALL histwrite( nid_T, "vovvldef", it, zw3d , ndim_T , ndex_T ) ! level thickness deformation
+ ENDIF
+ CALL histwrite( nid_T, "sossheig", it, ssh(:,:,Kmm) , ndim_hT, ndex_hT ) ! sea surface height
+ CALL histwrite( nid_T, "sowaflup", it, ( emp-rnf ) , 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
+ zw2d(:,:) = emp (:,:) * ts(:,:,1,jp_tem,Kmm)
+ CALL histwrite( nid_T, "sosst_cd", it, zw2d, ndim_hT, ndex_hT ) ! c/d term on sst
+ zw2d(:,:) = emp (:,:) * ts(:,:,1,jp_sal,Kmm)
+ CALL histwrite( nid_T, "sosss_cd", it, zw2d, ndim_hT, ndex_hT ) ! c/d term on sss
+ ENDIF
+ CALL histwrite( nid_T, "sohefldo", it, qns + qsr , ndim_hT, ndex_hT ) ! total heat flux
+ CALL histwrite( nid_T, "soshfldo", it, qsr , ndim_hT, ndex_hT ) ! solar heat flux
+ CALL histwrite( nid_T, "somixhgt", it, hmld , ndim_hT, ndex_hT ) ! turbocline depth
+ CALL histwrite( nid_T, "somxl010", it, hmlp , ndim_hT, ndex_hT ) ! mixed layer depth
+ 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
+ !
+ IF( ln_abl ) THEN
+ ALLOCATE( zw3d_abl(jpi,jpj,jpka) )
+ IF( ln_mskland ) THEN
+ DO jk=1,jpka
+ zw3d_abl(:,:,jk) = tmask(:,:,1)
+ END DO
+ ELSE
+ zw3d_abl(:,:,:) = 1._wp
+ ENDIF
+ CALL histwrite( nid_A, "pblh" , it, pblh(:,:) *zw3d_abl(:,:,1 ), ndim_hA, ndex_hA ) ! pblh
+ CALL histwrite( nid_A, "u_abl" , it, u_abl (:,:,2:jpka,nt_n )*zw3d_abl(:,:,2:jpka), ndim_A , ndex_A ) ! u_abl
+ CALL histwrite( nid_A, "v_abl" , it, v_abl (:,:,2:jpka,nt_n )*zw3d_abl(:,:,2:jpka), ndim_A , ndex_A ) ! v_abl
+ CALL histwrite( nid_A, "t_abl" , it, tq_abl (:,:,2:jpka,nt_n,1)*zw3d_abl(:,:,2:jpka), ndim_A , ndex_A ) ! t_abl
+ CALL histwrite( nid_A, "q_abl" , it, tq_abl (:,:,2:jpka,nt_n,2)*zw3d_abl(:,:,2:jpka), ndim_A , ndex_A ) ! q_abl
+ CALL histwrite( nid_A, "tke_abl", it, tke_abl (:,:,2:jpka,nt_n )*zw3d_abl(:,:,2:jpka), ndim_A , ndex_A ) ! tke_abl
+ CALL histwrite( nid_A, "avm_abl", it, avm_abl (:,:,2:jpka )*zw3d_abl(:,:,2:jpka), ndim_A , ndex_A ) ! avm_abl
+ CALL histwrite( nid_A, "avt_abl", it, avt_abl (:,:,2:jpka )*zw3d_abl(:,:,2:jpka), ndim_A , ndex_A ) ! avt_abl
+#if defined key_si3
+ CALL histwrite( nid_A, "oce_frac" , it, ato_i(:,:) , ndim_hA, ndex_hA ) ! ato_i
+#endif
+ DEALLOCATE(zw3d_abl)
+ ENDIF
+ !
+ IF( ln_icebergs ) THEN
+ !
+ CALL histwrite( nid_T, "calving" , it, berg_grid%calving , ndim_hT, ndex_hT )
+ CALL histwrite( nid_T, "calving_heat" , it, berg_grid%calving_hflx , ndim_hT, ndex_hT )
+ CALL histwrite( nid_T, "berg_floating_melt" , it, berg_grid%floating_melt, ndim_hT, ndex_hT )
+ !
+ CALL histwrite( nid_T, "berg_stored_ice" , it, berg_grid%stored_ice , ndim_bT, ndex_bT )
+ !
+ IF( ln_bergdia ) THEN
+ CALL histwrite( nid_T, "berg_melt" , it, berg_melt , ndim_hT, ndex_hT )
+ CALL histwrite( nid_T, "berg_buoy_melt" , it, buoy_melt , ndim_hT, ndex_hT )
+ CALL histwrite( nid_T, "berg_eros_melt" , it, eros_melt , ndim_hT, ndex_hT )
+ CALL histwrite( nid_T, "berg_conv_melt" , it, conv_melt , ndim_hT, ndex_hT )
+ CALL histwrite( nid_T, "berg_virtual_area" , it, virtual_area , ndim_hT, ndex_hT )
+ CALL histwrite( nid_T, "bits_src" , it, bits_src , ndim_hT, ndex_hT )
+ CALL histwrite( nid_T, "bits_melt" , it, bits_melt , ndim_hT, ndex_hT )
+ CALL histwrite( nid_T, "bits_mass" , it, bits_mass , ndim_hT, ndex_hT )
+ CALL histwrite( nid_T, "berg_mass" , it, berg_mass , ndim_hT, ndex_hT )
+ !
+ CALL histwrite( nid_T, "berg_real_calving" , it, real_calving , ndim_bT, ndex_bT )
+ ENDIF
+ ENDIF
+
+ IF( ln_ssr ) THEN
+ 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
+ zw2d(:,:) = erp(:,:) * ts(:,:,1,jp_sal,Kmm) * tmask(:,:,1)
+ CALL histwrite( nid_T, "sosafldp", it, zw2d , ndim_hT, ndex_hT ) ! salt flux damping
+ ENDIF
+! zw2d(:,:) = FLOAT( nmln(:,:) ) * tmask(:,:,1)
+! CALL histwrite( nid_T, "sobowlin", it, zw2d , ndim_hT, ndex_hT ) ! ???
+
+#if defined key_diahth
+ CALL histwrite( nid_T, "sothedep", it, hth , ndim_hT, ndex_hT ) ! depth of the thermocline
+ CALL histwrite( nid_T, "so20chgt", it, hd20 , ndim_hT, ndex_hT ) ! depth of the 20 isotherm
+ 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_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
+ CALL histwrite( nid_W, "vovecrtz", it, ww + wi , ndim_T, ndex_T ) ! vert. current
+ ELSE
+ CALL histwrite( nid_W, "vovecrtz", it, ww , ndim_T, ndex_T ) ! vert. current
+ ENDIF
+ CALL histwrite( nid_W, "votkeavt", it, avt , ndim_T, ndex_T ) ! T vert. eddy diff. coef.
+ CALL histwrite( nid_W, "votkeavm", it, avm , ndim_T, ndex_T ) ! T vert. eddy visc. coef.
+ IF( ln_zdfddm ) THEN
+ CALL histwrite( nid_W, "voddmavs", it, avs , ndim_T, ndex_T ) ! S vert. eddy diff. coef.
+ ENDIF
+
+ IF( ln_wave .AND. ln_sdw ) THEN
+ CALL histwrite( nid_U, "sdzocrtx", it, usd , ndim_U , ndex_U ) ! i-StokesDrift-current
+ CALL histwrite( nid_V, "sdmecrty", it, vsd , ndim_V , ndex_V ) ! j-StokesDrift-current
+ CALL histwrite( nid_W, "sdvecrtz", it, wsd , ndim_T , ndex_T ) ! StokesDrift vert. current
+ ENDIF
+
+ ! 3. Close all files
+ ! ---------------------------------------
+ IF( kt == nitend ) THEN
+ CALL histclo( nid_T )
+ CALL histclo( nid_U )
+ CALL histclo( nid_V )
+ CALL histclo( nid_W )
+ IF(ln_abl) CALL histclo( nid_A )
+ ENDIF
+ !
+ IF( ln_timing ) CALL timing_stop('dia_wri')
+ !
+ END SUBROUTINE dia_wri
+#endif
+
+ SUBROUTINE dia_wri_state( Kmm, cdfile_name )
+ !!---------------------------------------------------------------------
+ !! *** ROUTINE dia_wri_state ***
+ !!
+ !! ** Purpose : create a NetCDF file named cdfile_name which contains
+ !! the instantaneous ocean state and forcing fields.
+ !! Used to find errors in the initial state or save the last
+ !! ocean state in case of abnormal end of a simulation
+ !!
+ !! ** Method : NetCDF files using ioipsl
+ !! File 'output.init.nc' is created if ninist = 1 (namelist)
+ !! File 'output.abort.nc' is created in case of abnormal job end
+ !!----------------------------------------------------------------------
+ INTEGER , INTENT( in ) :: Kmm ! time level index
+ CHARACTER (len=* ), INTENT( in ) :: cdfile_name ! name of the file created
+ !!
+ INTEGER :: inum, jk
+!!st18 TBR
+ REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t, zgdept ! 3D workspace !!st patch to use substitution
+ !!----------------------------------------------------------------------
+ !
+ IF(lwp) WRITE(numout,*)
+ IF(lwp) WRITE(numout,*) 'dia_wri_state : single instantaneous ocean state'
+ IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~ and forcing fields file created '
+ IF(lwp) WRITE(numout,*) ' and named :', cdfile_name, '...nc'
+!!st19 TBR
+ DO jk = 1, jpk
+ ze3t(:,:,jk) = e3t(:,:,jk,Kmm)
+ zgdept(:,:,jk) = gdept(:,:,jk,Kmm)
+ END DO
+!!st19
+#if defined key_si3
+ CALL iom_open( TRIM(cdfile_name), inum, ldwrt = .TRUE., kdlev = jpl )
+#else
+ CALL iom_open( TRIM(cdfile_name), inum, ldwrt = .TRUE. )
+#endif
+
+ CALL iom_rstput( 0, 0, inum, 'votemper', ts(:,:,:,jp_tem,Kmm) ) ! now temperature
+ CALL iom_rstput( 0, 0, inum, 'vosaline', ts(:,:,:,jp_sal,Kmm) ) ! now salinity
+ CALL iom_rstput( 0, 0, inum, 'sossheig', ssh(:,:,Kmm) ) ! sea surface height
+ CALL iom_rstput( 0, 0, inum, 'vozocrtx', uu(:,:,:,Kmm) ) ! now i-velocity
+ CALL iom_rstput( 0, 0, inum, 'vomecrty', vv(:,:,:,Kmm) ) ! now j-velocity
+ IF( ln_zad_Aimp ) THEN
+ CALL iom_rstput( 0, 0, inum, 'vovecrtz', ww + wi ) ! now k-velocity
+ ELSE
+ CALL iom_rstput( 0, 0, inum, 'vovecrtz', ww ) ! now k-velocity
+ ENDIF
+ CALL iom_rstput( 0, 0, inum, 'risfdep', risfdep ) ! now k-velocity
+ CALL iom_rstput( 0, 0, inum, 'ht' , ht(:,:) ) ! now water column height
+
+ IF ( ln_isf ) THEN
+ IF (ln_isfcav_mlt) THEN
+ CALL iom_rstput( 0, 0, inum, 'fwfisf_cav', fwfisf_cav ) ! now k-velocity
+ CALL iom_rstput( 0, 0, inum, 'rhisf_cav_tbl', rhisf_tbl_cav ) ! now k-velocity
+ CALL iom_rstput( 0, 0, inum, 'rfrac_cav_tbl', rfrac_tbl_cav ) ! now k-velocity
+ CALL iom_rstput( 0, 0, inum, 'misfkb_cav', REAL(misfkb_cav,wp) ) ! now k-velocity
+ CALL iom_rstput( 0, 0, inum, 'misfkt_cav', REAL(misfkt_cav,wp) ) ! now k-velocity
+ CALL iom_rstput( 0, 0, inum, 'mskisf_cav', REAL(mskisf_cav,wp), ktype = jp_i1 )
+ END IF
+ IF (ln_isfpar_mlt) THEN
+ CALL iom_rstput( 0, 0, inum, 'isfmsk_par', REAL(mskisf_par,wp) ) ! now k-velocity
+ CALL iom_rstput( 0, 0, inum, 'fwfisf_par', fwfisf_par ) ! now k-velocity
+ CALL iom_rstput( 0, 0, inum, 'rhisf_par_tbl', rhisf_tbl_par ) ! now k-velocity
+ CALL iom_rstput( 0, 0, inum, 'rfrac_par_tbl', rfrac_tbl_par ) ! now k-velocity
+ CALL iom_rstput( 0, 0, inum, 'misfkb_par', REAL(misfkb_par,wp) ) ! now k-velocity
+ CALL iom_rstput( 0, 0, inum, 'misfkt_par', REAL(misfkt_par,wp) ) ! now k-velocity
+ CALL iom_rstput( 0, 0, inum, 'mskisf_par', REAL(mskisf_par,wp), ktype = jp_i1 )
+ END IF
+ END IF
+ !
+ IF( ALLOCATED(ahtu) ) THEN
+ CALL iom_rstput( 0, 0, inum, 'ahtu', ahtu ) ! aht at u-point
+ CALL iom_rstput( 0, 0, inum, 'ahtv', ahtv ) ! aht at v-point
+ ENDIF
+ IF( ALLOCATED(ahmt) ) THEN
+ CALL iom_rstput( 0, 0, inum, 'ahmt', ahmt ) ! ahmt at u-point
+ CALL iom_rstput( 0, 0, inum, 'ahmf', ahmf ) ! ahmf at v-point
+ ENDIF
+ CALL iom_rstput( 0, 0, inum, 'sowaflup', emp - rnf ) ! freshwater budget
+ CALL iom_rstput( 0, 0, inum, 'sohefldo', qsr + qns ) ! 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
+!!st20 TBR
+ IF( .NOT.ln_linssh ) THEN
+ CALL iom_rstput( 0, 0, inum, 'vovvldep', zgdept ) ! T-cell depth
+ CALL iom_rstput( 0, 0, inum, 'vovvle3t', ze3t ) ! T-cell thickness
+ END IF
+ IF( ln_wave .AND. ln_sdw ) THEN
+ CALL iom_rstput( 0, 0, inum, 'sdzocrtx', usd ) ! now StokesDrift i-velocity
+ CALL iom_rstput( 0, 0, inum, 'sdmecrty', vsd ) ! now StokesDrift j-velocity
+ CALL iom_rstput( 0, 0, inum, 'sdvecrtz', wsd ) ! now StokesDrift k-velocity
+ ENDIF
+ IF ( ln_abl ) THEN
+ CALL iom_rstput ( 0, 0, inum, "uz1_abl", u_abl(:,:,2,nt_a ) ) ! now first level i-wind
+ CALL iom_rstput ( 0, 0, inum, "vz1_abl", v_abl(:,:,2,nt_a ) ) ! now first level j-wind
+ CALL iom_rstput ( 0, 0, inum, "tz1_abl", tq_abl(:,:,2,nt_a,1) ) ! now first level temperature
+ CALL iom_rstput ( 0, 0, inum, "qz1_abl", tq_abl(:,:,2,nt_a,2) ) ! now first level humidity
+ ENDIF
+
+#if defined key_si3
+ IF( nn_ice == 2 ) THEN ! condition needed in case agrif + ice-model but no-ice in child grid
+ CALL ice_wri_state( inum )
+ ENDIF
+#endif
+ !
+ CALL iom_close( inum )
+ !
+ END SUBROUTINE dia_wri_state
+
+ !!======================================================================
+END MODULE diawri
Index: /NEMO/branches/2020/r12377_ticket2386/src/SWE/dom_oce.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/SWE/dom_oce.F90 (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/src/SWE/dom_oce.F90 (revision 13540)
@@ -0,0 +1,335 @@
+MODULE dom_oce
+ !!======================================================================
+ !! *** MODULE dom_oce ***
+ !!
+ !! ** Purpose : Define in memory all the ocean space domain variables
+ !!======================================================================
+ !! History : 1.0 ! 2005-10 (A. Beckmann, G. Madec) reactivate s-coordinate
+ !! 3.3 ! 2010-11 (G. Madec) add mbk. arrays associated to the deepest ocean level
+ !! 3.4 ! 2011-01 (A. R. Porter, STFC Daresbury) dynamical allocation
+ !! 3.5 ! 2012 (S. Mocavero, I. Epicoco) Add arrays associated
+ !! to the optimization of BDY communications
+ !! 3.7 ! 2015-11 (G. Madec) introduce surface and scale factor ratio
+ !! - ! 2015-11 (G. Madec, A. Coward) time varying zgr by default
+ !! 4.1 ! 2019-08 (A. Coward, D. Storkey) rename prognostic variables in preparation for new time scheme.
+ !!----------------------------------------------------------------------
+
+ !!----------------------------------------------------------------------
+ !! Agrif_Root : dummy function used when lk_agrif=F
+ !! Agrif_CFixed : dummy function used when lk_agrif=F
+ !! dom_oce_alloc : dynamical allocation of dom_oce arrays
+ !!----------------------------------------------------------------------
+ USE par_oce ! ocean parameters
+
+ IMPLICIT NONE
+ PUBLIC ! allows the acces to par_oce when dom_oce is used (exception to coding rules)
+
+ PUBLIC dom_oce_alloc ! Called from nemogcm.F90
+
+ !!----------------------------------------------------------------------
+ !! time & space domain namelist
+ !! ----------------------------
+ ! !!* Namelist namdom : time & space domain *
+ LOGICAL , PUBLIC :: ln_linssh !: =T linear free surface ==>> model level are fixed in time
+ LOGICAL , PUBLIC :: ln_meshmask !: =T create a mesh-mask file (mesh_mask.nc)
+ REAL(wp), PUBLIC :: rn_Dt !: time step for the dynamics and tracer
+ REAL(wp), PUBLIC :: rn_atfp !: asselin time filter parameter
+ 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
+
+ !! Free surface parameters
+ !! =======================
+ LOGICAL , PUBLIC :: ln_dynspg_exp !: Explicit free surface flag
+ LOGICAL , PUBLIC :: ln_dynspg_ts !: Split-Explicit free surface flag
+
+ !! Time splitting parameters
+ !! =========================
+ LOGICAL, PUBLIC :: ln_bt_fw !: Forward integration of barotropic sub-stepping
+ LOGICAL, PUBLIC :: ln_bt_av !: Time averaging of barotropic variables
+ LOGICAL, PUBLIC :: ln_bt_auto !: Set number of barotropic iterations automatically
+ INTEGER, PUBLIC :: nn_bt_flt !: Filter choice
+ INTEGER, PUBLIC :: nn_e !: Number of barotropic iterations during one baroclinic step (rn_Dt)
+ REAL(wp), PUBLIC :: rn_bt_cmax !: Maximum allowed courant number (used if ln_bt_auto=T)
+ REAL(wp), PUBLIC :: rn_bt_alpha !: Time stepping diffusion parameter
+
+
+ ! !!! associated variables
+ LOGICAL , PUBLIC :: l_1st_euler !: Euler 1st time-step flag (=T if ln_restart=F or ln_1st_euler=T)
+ REAL(wp), PUBLIC :: rDt, r1_Dt !: Current model timestep and reciprocal
+ !: rDt = 2 * rn_Dt if leapfrog and l_1st_euler = F
+ !: = rn_Dt if leapfrog and l_1st_euler = T
+ !: = rn_Dt if RK3
+
+ !!----------------------------------------------------------------------
+ !! space domain parameters
+ !!----------------------------------------------------------------------
+ INTEGER, PUBLIC :: jperio !: Global domain lateral boundary type (between 0 and 7)
+ ! ! = 0 closed ; = 1 cyclic East-West
+ ! ! = 2 cyclic North-South ; = 3 North fold T-point pivot
+ ! ! = 4 cyclic East-West AND North fold T-point pivot
+ ! ! = 5 North fold F-point pivot
+ ! ! = 6 cyclic East-West AND North fold F-point pivot
+ ! ! = 7 bi-cyclic East-West AND North-South
+ LOGICAL, PUBLIC :: l_Iperio, l_Jperio ! should we explicitely take care I/J periodicity
+
+ ! !: domain MPP decomposition parameters
+ INTEGER , PUBLIC :: nimpp, njmpp !: i- & j-indexes for mpp-subdomain left bottom
+ INTEGER , PUBLIC :: nreci, nrecj !: overlap region in i and j
+ INTEGER , PUBLIC :: nproc !: number for local processor
+ INTEGER , PUBLIC :: narea !: number for local area
+ INTEGER , PUBLIC :: nbondi, nbondj !: mark of i- and j-direction local boundaries
+ INTEGER, ALLOCATABLE, PUBLIC :: nbondi_bdy(:) !: mark i-direction local boundaries for BDY open boundaries
+ INTEGER, ALLOCATABLE, PUBLIC :: nbondj_bdy(:) !: mark j-direction local boundaries for BDY open boundaries
+ INTEGER, ALLOCATABLE, PUBLIC :: nbondi_bdy_b(:) !: mark i-direction of neighbours local boundaries for BDY open boundaries
+ INTEGER, ALLOCATABLE, PUBLIC :: nbondj_bdy_b(:) !: mark j-direction of neighbours local boundaries for BDY open boundaries
+
+ INTEGER, PUBLIC :: npolj !: north fold mark (0, 3 or 4)
+ INTEGER, PUBLIC :: nlci, nldi, nlei !: i-dimensions of the local subdomain and its first and last indoor indices
+ INTEGER, PUBLIC :: nlcj, nldj, nlej !: i-dimensions of the local subdomain and its first and last indoor indices
+ INTEGER, PUBLIC :: noea, nowe !: index of the local neighboring processors in
+ INTEGER, PUBLIC :: noso, nono !: east, west, south and north directions
+ INTEGER, PUBLIC :: nidom !: ???
+
+ INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mig !: local ==> global domain i-index
+ INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mjg !: local ==> global domain j-index
+ INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mi0, mi1 !: global ==> local domain i-index (mi0=1 and mi1=0 if the global index
+ ! ! is not in the local domain)
+ INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mj0, mj1 !: global ==> local domain j-index (mj0=1 and mj1=0 if the global index
+ ! ! is not in the local domain)
+ INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nimppt, njmppt !: i-, j-indexes for each processor
+ INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ibonit, ibonjt !: i-, j- processor neighbour existence
+ INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nlcit , nlcjt !: dimensions of every subdomain
+ INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nldit , nldjt !: first, last indoor index for each i-domain
+ INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nleit , nlejt !: first, last indoor index for each j-domain
+ INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: nfiimpp, nfipproc, nfilcit
+
+ !!----------------------------------------------------------------------
+ !! 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, 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, SAVE, DIMENSION(:,:) :: ff_f , ff_t !: Coriolis factor at f- & t-points [1/s]
+ !!----------------------------------------------------------------------
+ !! vertical coordinate and scale factors
+ !! ---------------------------------------------------------------------
+ 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
+!!st1
+#if ! defined key_qco
+ 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]
+#endif
+ ! ! time-dependent ratio ssh / h_0
+ 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]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gde3w_0 !: w- depth (sum of e3w) [m]
+ ! ! time-dependent depths of cells
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: gdept, gdepw
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gde3w
+!!st2
+ ! ! 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
+#if ! defined key_qco
+ 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]
+#endif
+!!st2
+
+ 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)
+
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: risfdep, bathy
+
+ !!----------------------------------------------------------------------
+ !! 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
+!!gm
+ INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mbkt, mbku, mbkv !: bottom last wet T-, U- and V-level
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tmask_i !: interior domain T-point mask
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tmask_h !: internal domain T-point mask (Figure 8.5 NEMO book)
+
+ INTEGER , PUBLIC, ALLOCATABLE, SAVE, 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, fmask !: land/ocean mask at T-, U-, V- and F-pts
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: wmask, wumask, wvmask !: land/ocean mask at WT-, WU- and WV-pts
+
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: tpol, fpol !: north fold mask (jperio= 3 or 4)
+
+ !!----------------------------------------------------------------------
+ !! calendar variables
+ !! ---------------------------------------------------------------------
+ INTEGER , PUBLIC :: nyear !: current year
+ INTEGER , PUBLIC :: nmonth !: current month
+ INTEGER , PUBLIC :: nday !: current day of the month
+ INTEGER , PUBLIC :: nhour !: current hour
+ INTEGER , PUBLIC :: nminute !: current minute
+ INTEGER , PUBLIC :: ndastp !: time step date in yyyymmdd format
+ INTEGER , PUBLIC :: nday_year !: current day counted from jan 1st of the current year
+ INTEGER , PUBLIC :: nsec_year !: seconds between 00h jan 1st of the current year and half of the current time step
+ INTEGER , PUBLIC :: nsec_month !: seconds between 00h 1st day of the current month and half of the current time step
+ INTEGER , PUBLIC :: nsec_monday !: seconds between 00h of the last Monday and half of the current time step
+ INTEGER , PUBLIC :: nsec_day !: seconds between 00h of the current day and half of the current time step
+ REAL(wp), PUBLIC :: fjulday !: current julian day
+ REAL(wp), PUBLIC :: fjulstartyear !: first day of the current year in julian days
+ REAL(wp), PUBLIC :: adatrj !: number of elapsed days since the begining of the whole simulation
+ ! !: (cumulative duration of previous runs that may have used different time-step size)
+ INTEGER , PUBLIC, DIMENSION( 0: 2) :: nyear_len !: length in days of the previous/current/next year
+ INTEGER , PUBLIC, DIMENSION(-11:25) :: nmonth_len !: length in days of the months of the current year
+ INTEGER , PUBLIC, DIMENSION(-11:25) :: nmonth_beg !: second since Jan 1st 0h of the current year and the half of the months
+ INTEGER , PUBLIC :: nsec1jan000 !: second since Jan 1st 0h of nit000 year and Jan 1st 0h the current year
+ INTEGER , PUBLIC :: nsec000_1jan000 !: second since Jan 1st 0h of nit000 year and nit000
+ INTEGER , PUBLIC :: nsecend_1jan000 !: second since Jan 1st 0h of nit000 year and nitend
+
+ !!----------------------------------------------------------------------
+ !! agrif domain
+ !!----------------------------------------------------------------------
+#if defined key_agrif
+ LOGICAL, PUBLIC, PARAMETER :: lk_agrif = .TRUE. !: agrif flag
+#else
+ LOGICAL, PUBLIC, PARAMETER :: lk_agrif = .FALSE. !: agrif flag
+#endif
+
+ !!----------------------------------------------------------------------
+ !! NEMO/OCE 4.0 , NEMO Consortium (2018)
+ !! $Id: dom_oce.F90 12614 2020-03-26 14:59:52Z gm $
+ !! Software governed by the CeCILL license (see ./LICENSE)
+ !!----------------------------------------------------------------------
+CONTAINS
+
+#if ! defined key_agrif
+ !!----------------------------------------------------------------------
+ !! NOT 'key_agrif' dummy function No AGRIF zoom
+ !!----------------------------------------------------------------------
+ LOGICAL FUNCTION Agrif_Root()
+ Agrif_Root = .TRUE.
+ END FUNCTION Agrif_Root
+
+ CHARACTER(len=3) FUNCTION Agrif_CFixed()
+ Agrif_CFixed = '0'
+ END FUNCTION Agrif_CFixed
+#endif
+!!st3: dom_oce_alloc modified to ease the ifdef if necessary (gm stuff)
+ INTEGER FUNCTION dom_oce_alloc()
+ !!----------------------------------------------------------------------
+ INTEGER :: ii
+ INTEGER, DIMENSION(30) :: ierr
+ !!----------------------------------------------------------------------
+ ii = 0 ; ierr(:) = 0
+ !
+ ii = ii+1
+ ALLOCATE( mig(jpi), mjg(jpj), STAT=ierr(ii) )
+ !
+ ii = ii+1
+ ALLOCATE( mi0 (jpiglo) , mi1 (jpiglo), mj0(jpjglo) , mj1 (jpjglo) , &
+ & tpol(jpiglo) , fpol(jpiglo) , STAT=ierr(ii) )
+ !
+ ii = ii+1
+ ALLOCATE( glamt(jpi,jpj) , glamu(jpi,jpj) , glamv(jpi,jpj) , glamf(jpi,jpj) , &
+ & gphit(jpi,jpj) , gphiu(jpi,jpj) , gphiv(jpi,jpj) , gphif(jpi,jpj) , &
+ & e1t (jpi,jpj) , e2t (jpi,jpj) , r1_e1t(jpi,jpj) , r1_e2t(jpi,jpj) , &
+ & e1u (jpi,jpj) , e2u (jpi,jpj) , r1_e1u(jpi,jpj) , r1_e2u(jpi,jpj) , &
+ & e1v (jpi,jpj) , e2v (jpi,jpj) , r1_e1v(jpi,jpj) , r1_e2v(jpi,jpj) , &
+ & e1f (jpi,jpj) , e2f (jpi,jpj) , r1_e1f(jpi,jpj) , r1_e2f(jpi,jpj) , &
+ & e1e2t(jpi,jpj) , r1_e1e2t(jpi,jpj) , &
+ & e1e2u(jpi,jpj) , r1_e1e2u(jpi,jpj) , e2_e1u(jpi,jpj) , &
+ & 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) )
+ !
+ 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) , STAT=ierr(ii) )
+ !
+ ii = ii+1
+ ALLOCATE( gdept_0(jpi,jpj,jpk) , gdepw_0(jpi,jpj,jpk) , gde3w_0(jpi,jpj,jpk) , &
+ & gdept (jpi,jpj,jpk,jpt) , gdepw (jpi,jpj,jpk,jpt) , gde3w (jpi,jpj,jpk) , STAT=ierr(ii) )
+ !
+!!st4
+#if ! defined key_qco
+ 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) )
+#endif
+!!st4
+ !
+ 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) )
+ !
+ 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
+ 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
+ !
+ ii = ii+1
+ ALLOCATE( risfdep(jpi,jpj) , bathy(jpi,jpj) , STAT=ierr(ii) )
+ !
+ ii = ii+1
+ ALLOCATE( gdept_1d(jpk) , gdepw_1d(jpk) , e3t_1d(jpk) , e3w_1d(jpk) , STAT=ierr(ii) )
+ !
+ ii = ii+1
+ ALLOCATE( tmask_i(jpi,jpj) , tmask_h(jpi,jpj) , &
+ & ssmask (jpi,jpj) , ssumask(jpi,jpj) , ssvmask(jpi,jpj) , ssfmask(jpi,jpj) , &
+ & mbkt (jpi,jpj) , mbku (jpi,jpj) , mbkv (jpi,jpj) , STAT=ierr(ii) )
+ !
+ ii = ii+1
+ ALLOCATE( mikt(jpi,jpj), miku(jpi,jpj), mikv(jpi,jpj), mikf(jpi,jpj), STAT=ierr(ii) )
+ !
+ ii = ii+1
+ ALLOCATE( tmask(jpi,jpj,jpk) , umask(jpi,jpj,jpk) , &
+ & vmask(jpi,jpj,jpk) , fmask(jpi,jpj,jpk) , STAT=ierr(ii) )
+ !
+ ii = ii+1
+ ALLOCATE( wmask(jpi,jpj,jpk) , wumask(jpi,jpj,jpk), wvmask(jpi,jpj,jpk) , STAT=ierr(ii) )
+ !
+ dom_oce_alloc = MAXVAL(ierr)
+ !
+ END FUNCTION dom_oce_alloc
+
+ !!======================================================================
+END MODULE dom_oce
Index: /NEMO/branches/2020/r12377_ticket2386/src/SWE/domain.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/SWE/domain.F90 (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/src/SWE/domain.F90 (revision 13540)
@@ -0,0 +1,741 @@
+MODULE domain
+ !!==============================================================================
+ !! *** MODULE domain ***
+ !! Ocean initialization : domain initialization
+ !!==============================================================================
+ !! History : OPA ! 1990-10 (C. Levy - G. Madec) Original code
+ !! ! 1992-01 (M. Imbard) insert time step initialization
+ !! ! 1996-06 (G. Madec) generalized vertical coordinate
+ !! ! 1997-02 (G. Madec) creation of domwri.F
+ !! ! 2001-05 (E.Durand - G. Madec) insert closed sea
+ !! NEMO 1.0 ! 2002-08 (G. Madec) F90: Free form and module
+ !! 2.0 ! 2005-11 (V. Garnier) Surface pressure gradient organization
+ !! 3.3 ! 2010-11 (G. Madec) initialisation in C1D configuration
+ !! 3.6 ! 2013 ( J. Simeon, C. Calone, G. Madec, C. Ethe ) Online coarsening of outputs
+ !! 3.7 ! 2015-11 (G. Madec, A. Coward) time varying zgr by default
+ !! 4.0 ! 2016-10 (G. Madec, S. Flavoni) domain configuration / user defined interface
+ !!----------------------------------------------------------------------
+
+ !!----------------------------------------------------------------------
+ !! dom_init : initialize the space and time domain
+ !! dom_glo : initialize global domain <--> local domain indices
+ !! dom_nam : read and contral domain namelists
+ !! dom_ctl : control print for the ocean domain
+ !! domain_cfg : read the global domain size in domain configuration file
+ !! cfg_write : create the domain configuration file
+ !!----------------------------------------------------------------------
+ USE oce ! ocean variables
+ USE dom_oce ! domain: ocean
+ USE sbc_oce ! surface boundary condition: ocean
+ USE trc_oce ! shared ocean & passive tracers variab
+ USE phycst ! physical constants
+ USE domhgr ! domain: set the horizontal mesh
+ USE domzgr ! domain: set the vertical mesh
+ USE dommsk ! domain: set the mask system
+ USE domwri ! domain: write the meshmask file
+!!st5
+#if ! defined key_qco
+ USE domvvl ! variable volume
+#else
+ USE domqco ! variable volume
+#endif
+!!st5
+ USE c1d ! 1D configuration
+ USE dyncor_c1d ! 1D configuration: Coriolis term (cor_c1d routine)
+ USE wet_dry, ONLY : ll_wd
+ USE closea , ONLY : dom_clo ! closed seas
+ !
+ USE in_out_manager ! I/O manager
+ USE iom ! I/O library
+ USE lbclnk ! ocean lateral boundary condition (or mpp link)
+ USE lib_mpp ! distributed memory computing library
+!!an45
+! USE usrdef_nam, ONLY : ln_45machin
+ !
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC dom_init ! called by nemogcm.F90
+ PUBLIC domain_cfg ! called by nemogcm.F90
+# include "do_loop_substitute.h90"
+ !!-------------------------------------------------------------------------
+ !! NEMO/OCE 4.0 , NEMO Consortium (2018)
+ !! $Id: domain.F90 12822 2020-04-28 09:10:38Z gm $
+ !! Software governed by the CeCILL license (see ./LICENSE)
+ !!-------------------------------------------------------------------------
+CONTAINS
+
+ SUBROUTINE dom_init( Kbb, Kmm, Kaa, cdstr )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE dom_init ***
+ !!
+ !! ** Purpose : Domain initialization. Call the routines that are
+ !! required to create the arrays which define the space
+ !! and time domain of the ocean model.
+ !!
+ !! ** Method : - dom_msk: compute the masks from the bathymetry file
+ !! - dom_hgr: compute or read the horizontal grid-point position
+ !! and scale factors, and the coriolis factor
+ !! - dom_zgr: define the vertical coordinate and the bathymetry
+ !! - dom_wri: create the meshmask file (ln_meshmask=T)
+ !! - 1D configuration, move Coriolis, u and v at T-point
+ !!----------------------------------------------------------------------
+ INTEGER , INTENT(in) :: Kbb, Kmm, Kaa ! ocean time level indices
+ CHARACTER (len=*), INTENT(in) :: cdstr ! model: NEMO or SAS. Determines core restart variables
+ !
+!!st6
+ INTEGER :: ji, jj, jk, jt ! dummy loop indices
+!!st6
+ INTEGER :: iconf = 0 ! local integers
+ CHARACTER (len=64) :: cform = "(A12, 3(A13, I7))"
+ INTEGER , DIMENSION(jpi,jpj) :: ik_top , ik_bot ! top and bottom ocean level
+ REAL(wp), DIMENSION(jpi,jpj) :: z1_hu_0, z1_hv_0
+ REAL(wp):: zcoeff ! local real
+
+ !!----------------------------------------------------------------------
+ !
+ IF(lwp) THEN ! Ocean domain Parameters (control print)
+ WRITE(numout,*)
+ WRITE(numout,*) 'dom_init : domain initialization'
+ WRITE(numout,*) '~~~~~~~~'
+ !
+ WRITE(numout,*) ' Domain info'
+ WRITE(numout,*) ' dimension of model:'
+ WRITE(numout,*) ' Local domain Global domain Data domain '
+ WRITE(numout,cform) ' ',' jpi : ', jpi, ' jpiglo : ', jpiglo
+ WRITE(numout,cform) ' ',' jpj : ', jpj, ' jpjglo : ', jpjglo
+ WRITE(numout,cform) ' ',' jpk : ', jpk, ' jpkglo : ', jpkglo
+ WRITE(numout,cform) ' ' ,' jpij : ', jpij
+ WRITE(numout,*) ' mpp local domain info (mpp):'
+ WRITE(numout,*) ' jpni : ', jpni, ' nn_hls : ', nn_hls
+ WRITE(numout,*) ' jpnj : ', jpnj, ' nn_hls : ', nn_hls
+ WRITE(numout,*) ' jpnij : ', jpnij
+ WRITE(numout,*) ' lateral boundary of the Global domain : jperio = ', jperio
+ SELECT CASE ( jperio )
+ CASE( 0 ) ; WRITE(numout,*) ' (i.e. closed)'
+ CASE( 1 ) ; WRITE(numout,*) ' (i.e. cyclic east-west)'
+ CASE( 2 ) ; WRITE(numout,*) ' (i.e. cyclic north-south)'
+ CASE( 3 ) ; WRITE(numout,*) ' (i.e. north fold with T-point pivot)'
+ CASE( 4 ) ; WRITE(numout,*) ' (i.e. cyclic east-west and north fold with T-point pivot)'
+ CASE( 5 ) ; WRITE(numout,*) ' (i.e. north fold with F-point pivot)'
+ CASE( 6 ) ; WRITE(numout,*) ' (i.e. cyclic east-west and north fold with F-point pivot)'
+ CASE( 7 ) ; WRITE(numout,*) ' (i.e. cyclic east-west and north-south)'
+ CASE DEFAULT
+ CALL ctl_stop( 'dom_init: jperio is out of range' )
+ END SELECT
+ WRITE(numout,*) ' Ocean model configuration used:'
+ WRITE(numout,*) ' cn_cfg = ', TRIM( cn_cfg ), ' nn_cfg = ', nn_cfg
+ ENDIF
+ lwxios = .FALSE.
+ ln_xios_read = .FALSE.
+ !
+ ! !== Reference coordinate system ==!
+ !
+ CALL dom_glo ! global domain versus local domain
+ CALL dom_nam ! read namelist ( namrun, namdom )
+ !
+ IF( lwxios ) THEN
+!define names for restart write and set core output (restart.F90)
+ CALL iom_set_rst_vars(rst_wfields)
+ CALL iom_set_rstw_core(cdstr)
+ ENDIF
+!reset namelist for SAS
+ IF(cdstr == 'SAS') THEN
+ IF(lrxios) THEN
+ IF(lwp) write(numout,*) 'Disable reading restart file using XIOS for SAS'
+ lrxios = .FALSE.
+ ENDIF
+ ENDIF
+ !
+ CALL dom_hgr ! Horizontal mesh
+
+ IF( ln_closea ) CALL dom_clo ! Read in masks to define closed seas and lakes
+
+ CALL dom_zgr( ik_top, ik_bot ) ! Vertical mesh and bathymetry (return top and bottom ocean t-level indices)
+
+ CALL dom_msk( ik_top, ik_bot ) ! Masks
+ !
+ ht_0(:,:) = 0._wp ! Reference ocean thickness
+ hu_0(:,:) = 0._wp
+ hv_0(:,:) = 0._wp
+ hf_0(:,:) = 0._wp
+ DO jk = 1, jpkm1
+ ht_0(:,:) = ht_0(:,:) + e3t_0(:,:,jk) * tmask(:,:,jk)
+ hu_0(:,:) = hu_0(:,:) + e3u_0(:,:,jk) * umask(:,:,jk)
+ hv_0(:,:) = hv_0(:,:) + e3v_0(:,:,jk) * vmask(:,:,jk)
+ hf_0(:,:) = hf_0(:,:) + e3f_0(:,:,jk) * ssfmask(:,:) ! CAUTION : only valid in SWE, not with bathymetry
+ END DO
+ !
+!!anhf hf_0 = mean(ht_0*tmask) so hf = mimj( ht0 + ssht)
+! ne pas combiner avec an45 tout de suite
+! DO_2D( 1, 0, 1, 0 )
+! hf_0(ji,jj) = 0.25_wp * ( ht_0(ji,jj+1) * tmask(ji,jj+1,1) + ht_0(ji+1,jj+1) * tmask(ji+1,jj+1,1) &
+! & + ht_0(ji,jj ) * tmask(ji,jj ,1) + ht_0(ji+1,jj ) * tmask(ji+1,jj ,1) )
+! END_2D
+! CALL lbc_lnk( 'domain', hf_0, 'F', 1. ) ! Lateral boundary conditions
+!!anhf
+ ! ! Inverse of reference ocean thickness
+ r1_ht_0(:,:) = ssmask(:,:) / ( ht_0(:,:) + 1._wp - ssmask(:,:) )
+ r1_hu_0(:,:) = ssumask(:,:) / ( hu_0(:,:) + 1._wp - ssumask(:,:) )
+ r1_hv_0(:,:) = ssvmask(:,:) / ( hv_0(:,:) + 1._wp - ssvmask(:,:) )
+ r1_hf_0(:,:) = ssfmask(:,:) / ( hf_0(:,:) + 1._wp - ssfmask(:,:) )
+ !
+!!an45 Ligne de cote a 45deg : e1e2t *= ( mi(umask) + mj(vmask) ) /2
+!! idem pour e1e2f
+! DO_2D( 1, 0, 1, 0 )
+! zcoeff = 0.25_wp * ( umask(ji,jj+1,1) + umask(ji+1,jj+1,1) &
+! & + vmask(ji,jj ,1) + vmask(ji+1,jj ,1) )
+! IF ( zcoeff /= 0._wp ) THEN
+! e1e2t(ji,jj) = e1e2t(ji,jj) * zcoeff
+! r1_e1e2t(ji,jj) = r1_e1e2t(ji,jj) / zcoeff
+! ENDIF
+! END_2D
+! WRITE(numout,*) ' an45 half T cell e1e2t '
+! zcoeff = 0.25_wp * ( umask(ji,jj+1,1) + umask(ji+1,jj+1,1) &
+! & + vmask(ji,jj ,1) + vmask(ji+1,jj ,1) )
+! IF ( zcoeff /= 0._wp ) THEN
+! e1e2t(ji,jj) = e1e2t(ji,jj) * zcoeff
+! r1_e1e2t(ji,jj) = r1_e1e2t(ji,jj) / zcoeff
+!!an45
+!!st7 : make it easier to use key_qco condition (gm stuff)
+#if defined key_qco
+ ! !== initialisation of time varying coordinate ==! Quasi-Euerian coordinate case
+ !
+ IF( .NOT.l_offline ) CALL dom_qco_init( Kbb, Kmm, Kaa )
+ !
+ IF( ln_linssh ) CALL ctl_stop('STOP','domain: key_qco and ln_linssh = T are incompatible')
+ !
+#else
+ ! !== time varying part of coordinate system ==!
+ !
+ 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
+!!st7
+ !
+ IF( lk_c1d ) CALL cor_c1d ! 1D configuration: Coriolis set at T-point
+ !
+
+#if defined key_agrif
+ IF( .NOT. Agrif_Root() ) CALL Agrif_Init_Domain( Kbb, Kmm, Kaa )
+#endif
+ IF( ln_meshmask ) CALL dom_wri ! Create a domain file
+ IF( .NOT.ln_rstart ) CALL dom_ctl ! Domain control
+ !
+ IF( ln_write_cfg ) CALL cfg_write ! create the configuration file
+ !
+ IF(lwp) THEN
+ WRITE(numout,*)
+ WRITE(numout,*) 'dom_init : ==>>> END of domain initialization'
+ WRITE(numout,*) '~~~~~~~~'
+ WRITE(numout,*)
+ ENDIF
+ !
+ END SUBROUTINE dom_init
+
+
+ SUBROUTINE dom_glo
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE dom_glo ***
+ !!
+ !! ** Purpose : initialization of global domain <--> local domain indices
+ !!
+ !! ** Method :
+ !!
+ !! ** Action : - mig , mjg : local domain indices ==> global domain, including halos, indices
+ !! - mig0, mjg0: local domain indices ==> global domain, excluding halos, 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
+ !!----------------------------------------------------------------------
+ !
+ 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
+ ! WARNING: to keep compatibility with the trunk that was including periodocity into the input data,
+ ! we must define mig0 and mjg0 as bellow.
+ ! Once we decide to forget trunk compatibility, we must simply define mig0 and mjg0 as:
+ mig0_oldcmp(:) = mig0(:) + COUNT( (/ jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7 /) )
+ mjg0_oldcmp(:) = mjg0(:) + COUNT( (/ jperio == 2 .OR. jperio == 7 /) )
+ !
+ ! ! 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
+ IF(lwp) THEN ! control print
+ WRITE(numout,*)
+ WRITE(numout,*) 'dom_glo : domain: global <<==>> local '
+ WRITE(numout,*) '~~~~~~~ '
+ WRITE(numout,*) ' global domain: jpiglo = ', jpiglo, ' jpjglo = ', jpjglo, ' jpkglo = ', jpkglo
+ WRITE(numout,*) ' local domain: jpi = ', jpi , ' jpj = ', jpj , ' jpk = ', jpk
+ WRITE(numout,*)
+ ENDIF
+ !
+ END SUBROUTINE dom_glo
+
+
+ SUBROUTINE dom_nam
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE dom_nam ***
+ !!
+ !! ** Purpose : read domaine namelists and print the variables.
+ !!
+ !! ** input : - namrun namelist
+ !! - namdom namelist
+ !! - namnc4 namelist ! "key_netcdf4" only
+ !!----------------------------------------------------------------------
+ USE ioipsl
+ !!
+ INTEGER :: ios ! Local integer
+ !
+ NAMELIST/namrun/ cn_ocerst_indir, cn_ocerst_outdir, nn_stocklist, ln_rst_list, &
+ & nn_no , cn_exp , cn_ocerst_in, cn_ocerst_out, ln_rstart , nn_rstctl , &
+ & nn_it000, nn_itend , nn_date0 , nn_time0 , nn_leapy , nn_istate , &
+ & nn_stock, nn_write , ln_mskland , ln_clobber , nn_chunksz, ln_1st_euler , &
+ & ln_cfmeta, ln_xios_read, nn_wxios
+ NAMELIST/namdom/ ln_linssh, rn_Dt, rn_atfp, ln_crs, ln_meshmask
+#if defined key_netcdf4
+ NAMELIST/namnc4/ nn_nchunks_i, nn_nchunks_j, nn_nchunks_k, ln_nc4zip
+#endif
+ !!----------------------------------------------------------------------
+ !
+ IF(lwp) THEN
+ WRITE(numout,*)
+ WRITE(numout,*) 'dom_nam : domain initialization through namelist read'
+ WRITE(numout,*) '~~~~~~~ '
+ ENDIF
+ !
+ !
+ READ ( numnam_ref, namrun, IOSTAT = ios, ERR = 901)
+901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namrun in reference namelist' )
+ READ ( numnam_cfg, namrun, IOSTAT = ios, ERR = 902 )
+902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namrun in configuration namelist' )
+ IF(lwm) WRITE ( numond, namrun )
+
+#if defined key_agrif
+ IF( .NOT. Agrif_Root() ) THEN
+ nn_it000 = (Agrif_Parent(nn_it000)-1)*Agrif_IRhot() + 1
+ nn_itend = Agrif_Parent(nn_itend) *Agrif_IRhot()
+ ENDIF
+#endif
+ !
+ IF(lwp) THEN ! control print
+ WRITE(numout,*) ' Namelist : namrun --- run parameters'
+ WRITE(numout,*) ' Assimilation cycle nn_no = ', nn_no
+ WRITE(numout,*) ' experiment name for output cn_exp = ', TRIM( cn_exp )
+ WRITE(numout,*) ' file prefix restart input cn_ocerst_in = ', TRIM( cn_ocerst_in )
+ WRITE(numout,*) ' restart input directory cn_ocerst_indir = ', TRIM( cn_ocerst_indir )
+ WRITE(numout,*) ' file prefix restart output cn_ocerst_out = ', TRIM( cn_ocerst_out )
+ WRITE(numout,*) ' restart output directory cn_ocerst_outdir= ', TRIM( cn_ocerst_outdir )
+ WRITE(numout,*) ' restart logical ln_rstart = ', ln_rstart
+ WRITE(numout,*) ' start with forward time step ln_1st_euler = ', ln_1st_euler
+ WRITE(numout,*) ' control of time step nn_rstctl = ', nn_rstctl
+ WRITE(numout,*) ' number of the first time step nn_it000 = ', nn_it000
+ WRITE(numout,*) ' number of the last time step nn_itend = ', nn_itend
+ WRITE(numout,*) ' initial calendar date aammjj nn_date0 = ', nn_date0
+ WRITE(numout,*) ' initial time of day in hhmm nn_time0 = ', nn_time0
+ WRITE(numout,*) ' leap year calendar (0/1) nn_leapy = ', nn_leapy
+ WRITE(numout,*) ' initial state output nn_istate = ', nn_istate
+ IF( ln_rst_list ) THEN
+ WRITE(numout,*) ' list of restart dump times nn_stocklist =', nn_stocklist
+ ELSE
+ WRITE(numout,*) ' frequency of restart file nn_stock = ', nn_stock
+ ENDIF
+#if ! defined key_iomput
+ WRITE(numout,*) ' frequency of output file nn_write = ', nn_write
+#endif
+ WRITE(numout,*) ' mask land points ln_mskland = ', ln_mskland
+ WRITE(numout,*) ' additional CF standard metadata ln_cfmeta = ', ln_cfmeta
+ WRITE(numout,*) ' overwrite an existing file ln_clobber = ', ln_clobber
+ WRITE(numout,*) ' NetCDF chunksize (bytes) nn_chunksz = ', nn_chunksz
+ IF( TRIM(Agrif_CFixed()) == '0' ) THEN
+ WRITE(numout,*) ' READ restart for a single file using XIOS ln_xios_read =', ln_xios_read
+ WRITE(numout,*) ' Write restart using XIOS nn_wxios = ', nn_wxios
+ ELSE
+ WRITE(numout,*) " AGRIF: nn_wxios will be ingored. See setting for parent"
+ WRITE(numout,*) " AGRIF: ln_xios_read will be ingored. See setting for parent"
+ ENDIF
+ ENDIF
+
+ cexper = cn_exp ! conversion DOCTOR names into model names (this should disappear soon)
+ nrstdt = nn_rstctl
+ nit000 = nn_it000
+ nitend = nn_itend
+ ndate0 = nn_date0
+ nleapy = nn_leapy
+ ninist = nn_istate
+ l_1st_euler = ln_1st_euler
+ IF( .NOT. l_1st_euler .AND. .NOT. ln_rstart ) THEN
+ IF(lwp) WRITE(numout,*)
+ IF(lwp) WRITE(numout,*)' ==>>> Start from rest (ln_rstart=F)'
+ IF(lwp) WRITE(numout,*)' an Euler initial time step is used : l_1st_euler is forced to .true. '
+ l_1st_euler = .true.
+ ENDIF
+ ! ! control of output frequency
+ IF( .NOT. ln_rst_list ) THEN ! we use nn_stock
+ IF( nn_stock == -1 ) CALL ctl_warn( 'nn_stock = -1 --> no restart will be done' )
+ IF( nn_stock == 0 .OR. nn_stock > nitend ) THEN
+ WRITE(ctmp1,*) 'nn_stock = ', nn_stock, ' it is forced to ', nitend
+ CALL ctl_warn( ctmp1 )
+ nn_stock = nitend
+ ENDIF
+ ENDIF
+#if ! defined key_iomput
+ IF( nn_write == -1 ) CALL ctl_warn( 'nn_write = -1 --> no output files will be done' )
+ IF ( nn_write == 0 ) THEN
+ WRITE(ctmp1,*) 'nn_write = ', nn_write, ' it is forced to ', nitend
+ CALL ctl_warn( ctmp1 )
+ nn_write = nitend
+ ENDIF
+#endif
+
+ IF( Agrif_Root() ) THEN
+ IF(lwp) WRITE(numout,*)
+ SELECT CASE ( nleapy ) ! Choose calendar for IOIPSL
+ CASE ( 1 )
+ CALL ioconf_calendar('gregorian')
+ IF(lwp) WRITE(numout,*) ' ==>>> The IOIPSL calendar is "gregorian", i.e. leap year'
+ CASE ( 0 )
+ CALL ioconf_calendar('noleap')
+ IF(lwp) WRITE(numout,*) ' ==>>> The IOIPSL calendar is "noleap", i.e. no leap year'
+ CASE ( 30 )
+ CALL ioconf_calendar('360d')
+ IF(lwp) WRITE(numout,*) ' ==>>> The IOIPSL calendar is "360d", i.e. 360 days in a year'
+ END SELECT
+ ENDIF
+
+ READ ( numnam_ref, namdom, IOSTAT = ios, ERR = 903)
+903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdom in reference namelist' )
+ READ ( numnam_cfg, namdom, IOSTAT = ios, ERR = 904 )
+904 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdom in configuration namelist' )
+ IF(lwm) WRITE( numond, namdom )
+ !
+#if defined key_agrif
+ IF( .NOT. Agrif_Root() ) THEN
+ rn_Dt = Agrif_Parent(rn_Dt) / Agrif_Rhot()
+ ENDIF
+#endif
+ !
+ IF(lwp) THEN
+ WRITE(numout,*)
+ WRITE(numout,*) ' Namelist : namdom --- space & time domain'
+ WRITE(numout,*) ' linear free surface (=T) ln_linssh = ', ln_linssh
+ WRITE(numout,*) ' create mesh/mask file ln_meshmask = ', ln_meshmask
+ WRITE(numout,*) ' ocean time step rn_Dt = ', rn_Dt
+ WRITE(numout,*) ' asselin time filter parameter rn_atfp = ', rn_atfp
+ WRITE(numout,*) ' online coarsening of dynamical fields ln_crs = ', ln_crs
+ ENDIF
+ !
+ !! Initialise current model timestep rDt = 2*rn_Dt if MLF or rDt = rn_Dt if RK3
+ rDt = 2._wp * rn_Dt
+ r1_Dt = 1._wp / rDt
+
+ IF( TRIM(Agrif_CFixed()) == '0' ) THEN
+ lrxios = ln_xios_read.AND.ln_rstart
+!set output file type for XIOS based on NEMO namelist
+ IF (nn_wxios > 0) lwxios = .TRUE.
+ nxioso = nn_wxios
+ ENDIF
+
+#if defined key_netcdf4
+ ! ! NetCDF 4 case ("key_netcdf4" defined)
+ READ ( numnam_ref, namnc4, IOSTAT = ios, ERR = 907)
+907 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namnc4 in reference namelist' )
+ READ ( numnam_cfg, namnc4, IOSTAT = ios, ERR = 908 )
+908 IF( ios > 0 ) CALL ctl_nam ( ios , 'namnc4 in configuration namelist' )
+ IF(lwm) WRITE( numond, namnc4 )
+
+ IF(lwp) THEN ! control print
+ WRITE(numout,*)
+ WRITE(numout,*) ' Namelist namnc4 - Netcdf4 chunking parameters'
+ WRITE(numout,*) ' number of chunks in i-dimension nn_nchunks_i = ', nn_nchunks_i
+ WRITE(numout,*) ' number of chunks in j-dimension nn_nchunks_j = ', nn_nchunks_j
+ WRITE(numout,*) ' number of chunks in k-dimension nn_nchunks_k = ', nn_nchunks_k
+ WRITE(numout,*) ' apply netcdf4/hdf5 chunking & compression ln_nc4zip = ', ln_nc4zip
+ ENDIF
+
+ ! Put the netcdf4 settings into a simple structure (snc4set, defined in in_out_manager module)
+ ! Note the chunk size in the unlimited (time) dimension will be fixed at 1
+ snc4set%ni = nn_nchunks_i
+ snc4set%nj = nn_nchunks_j
+ snc4set%nk = nn_nchunks_k
+ snc4set%luse = ln_nc4zip
+#else
+ snc4set%luse = .FALSE. ! No NetCDF 4 case
+#endif
+ !
+ END SUBROUTINE dom_nam
+
+
+ SUBROUTINE dom_ctl
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE dom_ctl ***
+ !!
+ !! ** Purpose : Domain control.
+ !!
+ !! ** Method : compute and print extrema of masked scale factors
+ !!----------------------------------------------------------------------
+ LOGICAL, DIMENSION(jpi,jpj) :: llmsk
+ INTEGER, DIMENSION(2) :: imil, imip, imi1, imi2, imal, imap, ima1, ima2
+ REAL(wp) :: zglmin, zglmax, zgpmin, zgpmax, ze1min, ze1max, ze2min, ze2max
+ !!----------------------------------------------------------------------
+ !
+ llmsk = tmask_h(:,:) == 1._wp
+ !
+ CALL mpp_minloc( 'domain', glamt(:,:), llmsk, zglmin, imil )
+ CALL mpp_minloc( 'domain', gphit(:,:), llmsk, zgpmin, imip )
+ CALL mpp_minloc( 'domain', e1t(:,:), llmsk, ze1min, imi1 )
+ CALL mpp_minloc( 'domain', e2t(:,:), llmsk, ze2min, imi2 )
+ CALL mpp_maxloc( 'domain', glamt(:,:), llmsk, zglmax, imal )
+ CALL mpp_maxloc( 'domain', gphit(:,:), llmsk, zgpmax, imap )
+ CALL mpp_maxloc( 'domain', e1t(:,:), llmsk, ze1max, ima1 )
+ CALL mpp_maxloc( 'domain', e2t(:,:), llmsk, ze2max, ima2 )
+ !
+ IF(lwp) THEN
+ WRITE(numout,*)
+ WRITE(numout,*) 'dom_ctl : extrema of the masked scale factors'
+ WRITE(numout,*) '~~~~~~~'
+ WRITE(numout,"(14x,'glamt mini: ',1f10.2,' at i = ',i5,' j= ',i5)") zglmin, imil(1), imil(2)
+ WRITE(numout,"(14x,'glamt maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") zglmax, imal(1), imal(2)
+ WRITE(numout,"(14x,'gphit mini: ',1f10.2,' at i = ',i5,' j= ',i5)") zgpmin, imip(1), imip(2)
+ WRITE(numout,"(14x,'gphit maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") zgpmax, imap(1), imap(2)
+ WRITE(numout,"(14x,' e1t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1min, imi1(1), imi1(2)
+ WRITE(numout,"(14x,' e1t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1max, ima1(1), ima1(2)
+ WRITE(numout,"(14x,' e2t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2min, imi2(1), imi2(2)
+ WRITE(numout,"(14x,' e2t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2max, ima2(1), ima2(2)
+ ENDIF
+ !
+ END SUBROUTINE dom_ctl
+
+
+ SUBROUTINE domain_cfg( cd_cfg, kk_cfg, kpi, kpj, kpk, kperio )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE dom_nam ***
+ !!
+ !! ** Purpose : read the domain size in domain configuration file
+ !!
+ !! ** Method : read the cn_domcfg NetCDF file
+ !!----------------------------------------------------------------------
+ CHARACTER(len=*) , INTENT(out) :: cd_cfg ! configuration name
+ INTEGER , INTENT(out) :: kk_cfg ! configuration resolution
+ INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes
+ INTEGER , INTENT(out) :: kperio ! lateral global domain b.c.
+ !
+ INTEGER :: inum ! local integer
+ REAL(wp) :: zorca_res ! local scalars
+ REAL(wp) :: zperio ! - -
+ INTEGER, DIMENSION(4) :: idvar, idimsz ! size of dimensions
+ !!----------------------------------------------------------------------
+ !
+ IF(lwp) THEN
+ WRITE(numout,*) ' '
+ WRITE(numout,*) 'domain_cfg : domain size read in ', TRIM( cn_domcfg ), ' file'
+ WRITE(numout,*) '~~~~~~~~~~ '
+ ENDIF
+ !
+ CALL iom_open( cn_domcfg, inum )
+ !
+ ! !- ORCA family specificity
+ IF( iom_varid( inum, 'ORCA' , ldstop = .FALSE. ) > 0 .AND. &
+ & iom_varid( inum, 'ORCA_index' , ldstop = .FALSE. ) > 0 ) THEN
+ !
+ cd_cfg = 'ORCA'
+ CALL iom_get( inum, 'ORCA_index', zorca_res ) ; kk_cfg = NINT( zorca_res )
+ !
+ IF(lwp) THEN
+ WRITE(numout,*) ' .'
+ WRITE(numout,*) ' ==>>> ORCA configuration '
+ WRITE(numout,*) ' .'
+ ENDIF
+ !
+ ELSE !- cd_cfg & k_cfg are not used
+ cd_cfg = 'UNKNOWN'
+ kk_cfg = -9999999
+ !- or they may be present as global attributes
+ !- (netcdf only)
+ CALL iom_getatt( inum, 'cn_cfg', cd_cfg ) ! returns ! if not found
+ CALL iom_getatt( inum, 'nn_cfg', kk_cfg ) ! returns -999 if not found
+ IF( TRIM(cd_cfg) == '!') cd_cfg = 'UNKNOWN'
+ IF( kk_cfg == -999 ) kk_cfg = -9999999
+ !
+ ENDIF
+ !
+ idvar = iom_varid( inum, 'e3t_0', kdimsz = idimsz ) ! use e3t_0, that must exist, to get jp(ijk)glo
+ kpi = idimsz(1)
+ kpj = idimsz(2)
+ kpk = idimsz(3)
+ CALL iom_get( inum, 'jperio', zperio ) ; kperio = NINT( zperio )
+ CALL iom_close( inum )
+ !
+ IF(lwp) THEN
+ WRITE(numout,*) ' cn_cfg = ', TRIM(cd_cfg), ' nn_cfg = ', kk_cfg
+ WRITE(numout,*) ' Ni0glo = ', kpi
+ WRITE(numout,*) ' Nj0glo = ', kpj
+ WRITE(numout,*) ' jpkglo = ', kpk
+ WRITE(numout,*) ' type of global domain lateral boundary jperio = ', kperio
+ ENDIF
+ !
+ END SUBROUTINE domain_cfg
+
+
+ SUBROUTINE cfg_write
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE cfg_write ***
+ !!
+ !! ** Purpose : Create the "cn_domcfg_out" file, a NetCDF file which
+ !! contains all the ocean domain informations required to
+ !! define an ocean configuration.
+ !!
+ !! ** Method : Write in a file all the arrays required to set up an
+ !! ocean configuration.
+ !!
+ !! ** output file : domcfg_out.nc : domain size, characteristics, horizontal
+ !! mesh, Coriolis parameter, and vertical scale factors
+ !! NB: also contain ORCA family information
+ !!----------------------------------------------------------------------
+ INTEGER :: ji, jj, jk ! dummy loop indices
+ INTEGER :: izco, izps, isco, icav
+ INTEGER :: inum ! local units
+ CHARACTER(len=21) :: clnam ! filename (mesh and mask informations)
+ REAL(wp), DIMENSION(jpi,jpj) :: z2d ! workspace
+ !!----------------------------------------------------------------------
+ !
+ IF(lwp) WRITE(numout,*)
+ IF(lwp) WRITE(numout,*) 'cfg_write : create the domain configuration file (', TRIM(cn_domcfg_out),'.nc)'
+ IF(lwp) WRITE(numout,*) '~~~~~~~~~'
+ !
+ ! ! ============================= !
+ ! ! create 'domcfg_out.nc' file !
+ ! ! ============================= !
+ !
+ clnam = cn_domcfg_out ! filename (configuration information)
+ CALL iom_open( TRIM(clnam), inum, ldwrt = .TRUE. )
+ !
+ ! !== ORCA family specificities ==!
+ IF( TRIM(cn_cfg) == "orca" .OR. TRIM(cn_cfg) == "ORCA" ) THEN
+ CALL iom_rstput( 0, 0, inum, 'ORCA' , 1._wp , ktype = jp_i4 )
+ CALL iom_rstput( 0, 0, inum, 'ORCA_index', REAL( nn_cfg, wp), ktype = jp_i4 )
+ ENDIF
+ !
+ ! !== domain characteristics ==!
+ !
+ ! ! lateral boundary of the global domain
+ CALL iom_rstput( 0, 0, inum, 'jperio', REAL( jperio, wp), ktype = jp_i4 )
+ !
+ ! ! type of vertical coordinate
+ CALL iom_rstput( 0, 0, inum, 'ln_zco', REAL(COUNT((/ln_zco/)), wp), ktype = jp_i4 )
+ CALL iom_rstput( 0, 0, inum, 'ln_zps', REAL(COUNT((/ln_zps/)), wp), ktype = jp_i4 )
+ CALL iom_rstput( 0, 0, inum, 'ln_sco', REAL(COUNT((/ln_sco/)), wp), ktype = jp_i4 )
+ !
+ ! ! ocean cavities under iceshelves
+ CALL iom_rstput( 0, 0, inum, 'ln_isfcav', REAL(COUNT((/ln_isfcav/)), wp), ktype = jp_i4 )
+ !
+ ! !== horizontal mesh !
+ !
+ CALL iom_rstput( 0, 0, inum, 'glamt', glamt, ktype = jp_r8 ) ! latitude
+ CALL iom_rstput( 0, 0, inum, 'glamu', glamu, ktype = jp_r8 )
+ CALL iom_rstput( 0, 0, inum, 'glamv', glamv, ktype = jp_r8 )
+ CALL iom_rstput( 0, 0, inum, 'glamf', glamf, ktype = jp_r8 )
+ !
+ CALL iom_rstput( 0, 0, inum, 'gphit', gphit, ktype = jp_r8 ) ! longitude
+ CALL iom_rstput( 0, 0, inum, 'gphiu', gphiu, ktype = jp_r8 )
+ CALL iom_rstput( 0, 0, inum, 'gphiv', gphiv, ktype = jp_r8 )
+ CALL iom_rstput( 0, 0, inum, 'gphif', gphif, ktype = jp_r8 )
+ !
+ CALL iom_rstput( 0, 0, inum, 'e1t' , e1t , ktype = jp_r8 ) ! i-scale factors (e1.)
+ CALL iom_rstput( 0, 0, inum, 'e1u' , e1u , ktype = jp_r8 )
+ CALL iom_rstput( 0, 0, inum, 'e1v' , e1v , ktype = jp_r8 )
+ CALL iom_rstput( 0, 0, inum, 'e1f' , e1f , ktype = jp_r8 )
+ !
+ CALL iom_rstput( 0, 0, inum, 'e2t' , e2t , ktype = jp_r8 ) ! j-scale factors (e2.)
+ CALL iom_rstput( 0, 0, inum, 'e2u' , e2u , ktype = jp_r8 )
+ CALL iom_rstput( 0, 0, inum, 'e2v' , e2v , ktype = jp_r8 )
+ CALL iom_rstput( 0, 0, inum, 'e2f' , e2f , ktype = jp_r8 )
+ !
+ CALL iom_rstput( 0, 0, inum, 'ff_f' , ff_f , ktype = jp_r8 ) ! coriolis factor
+ CALL iom_rstput( 0, 0, inum, 'ff_t' , ff_t , ktype = jp_r8 )
+ !
+ ! !== vertical mesh ==!
+ !
+ 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 )
+ !
+ ! !== 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)
+ CALL dom_stiff( z2d )
+ CALL iom_rstput( 0, 0, inum, 'stiffness', z2d ) ! ! Max. grid stiffness ratio
+ ENDIF
+ !
+ IF( ll_wd ) THEN ! wetting and drying domain
+ CALL iom_rstput( 0, 0, inum, 'ht_0' , ht_0 , ktype = jp_r8 )
+ ENDIF
+ !
+ ! Add some global attributes ( netcdf only )
+ CALL iom_putatt( inum, 'nn_cfg', nn_cfg )
+ CALL iom_putatt( inum, 'cn_cfg', TRIM(cn_cfg) )
+ !
+ ! ! ============================
+ ! ! close the files
+ ! ! ============================
+ CALL iom_close( inum )
+ !
+ END SUBROUTINE cfg_write
+
+ !!======================================================================
+END MODULE domain
Index: /NEMO/branches/2020/r12377_ticket2386/src/SWE/dommsk.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/SWE/dommsk.F90 (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/src/SWE/dommsk.F90 (revision 13540)
@@ -0,0 +1,295 @@
+MODULE dommsk
+ !!======================================================================
+ !! *** MODULE dommsk ***
+ !! Ocean initialization : domain land/sea mask
+ !!======================================================================
+ !! History : OPA ! 1987-07 (G. Madec) Original code
+ !! 6.0 ! 1993-03 (M. Guyon) symetrical conditions (M. Guyon)
+ !! 7.0 ! 1996-01 (G. Madec) suppression of common work arrays
+ !! - ! 1996-05 (G. Madec) mask computed from tmask
+ !! 8.0 ! 1997-02 (G. Madec) mesh information put in domhgr.F
+ !! 8.1 ! 1997-07 (G. Madec) modification of kbat and fmask
+ !! - ! 1998-05 (G. Roullet) free surface
+ !! 8.2 ! 2000-03 (G. Madec) no slip accurate
+ !! - ! 2001-09 (J.-M. Molines) Open boundaries
+ !! NEMO 1.0 ! 2002-08 (G. Madec) F90: Free form and module
+ !! - ! 2005-11 (V. Garnier) Surface pressure gradient organization
+ !! 3.2 ! 2009-07 (R. Benshila) Suppression of rigid-lid option
+ !! 3.6 ! 2015-05 (P. Mathiot) ISF: add wmask,wumask and wvmask
+ !! 4.0 ! 2016-06 (G. Madec, S. Flavoni) domain configuration / user defined interface
+ !!----------------------------------------------------------------------
+
+ !!----------------------------------------------------------------------
+ !! dom_msk : compute land/ocean mask
+ !!----------------------------------------------------------------------
+ USE oce ! ocean dynamics and tracers
+ USE dom_oce ! ocean space and time domain
+ USE usrdef_fmask ! user defined fmask
+ USE bdy_oce ! open boundary
+ !
+ USE in_out_manager ! I/O manager
+ USE iom ! IOM library
+ USE lbclnk ! ocean lateral boundary conditions (or mpp link)
+ USE lib_mpp ! Massively Parallel Processing library
+
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC dom_msk ! routine called by inidom.F90
+
+ ! !!* Namelist namlbc : lateral boundary condition *
+ REAL(wp) :: rn_shlat ! type of lateral boundary condition on velocity
+ LOGICAL, PUBLIC :: ln_vorlat ! consistency of vorticity boundary condition
+ ! with analytical eqs.
+
+ !! * Substitutions
+# include "do_loop_substitute.h90"
+ !!----------------------------------------------------------------------
+ !! NEMO/OCE 4.0 , NEMO Consortium (2018)
+ !! $Id: dommsk.F90 12614 2020-03-26 14:59:52Z gm $
+ !! Software governed by the CeCILL license (see ./LICENSE)
+ !!----------------------------------------------------------------------
+CONTAINS
+
+ SUBROUTINE dom_msk( k_top, k_bot )
+ !!---------------------------------------------------------------------
+ !! *** ROUTINE dom_msk ***
+ !!
+ !! ** Purpose : Compute land/ocean mask arrays at tracer points, hori-
+ !! zontal velocity points (u & v), vorticity points (f) points.
+ !!
+ !! ** Method : The ocean/land mask at t-point is deduced from ko_top
+ !! and ko_bot, the indices of the fist and last ocean t-levels which
+ !! are either defined in usrdef_zgr or read in zgr_read.
+ !! The velocity masks (umask, vmask, wmask, wumask, wvmask)
+ !! are deduced from a product of the two neighboring tmask.
+ !! The vorticity mask (fmask) is deduced from tmask taking
+ !! into account the choice of lateral boundary condition (rn_shlat) :
+ !! rn_shlat = 0, free slip (no shear along the coast)
+ !! rn_shlat = 2, no slip (specified zero velocity at the coast)
+ !! 0 < rn_shlat < 2, partial slip | non-linear velocity profile
+ !! 2 < rn_shlat, strong slip | in the lateral boundary layer
+ !!
+ !! tmask_i : interior ocean mask at t-point, i.e. excluding duplicated
+ !! rows/lines due to cyclic or North Fold boundaries as well
+ !! as MPP halos.
+ !! tmask_h : halo mask at t-point, i.e. excluding duplicated rows/lines
+ !! due to cyclic or North Fold boundaries as well as MPP halos.
+ !!
+ !! ** Action : tmask, umask, vmask, wmask, wumask, wvmask : land/ocean mask
+ !! at t-, u-, v- w, wu-, and wv-points (=0. or 1.)
+ !! fmask : land/ocean mask at f-point (=0., or =1., or
+ !! =rn_shlat along lateral boundaries)
+ !! tmask_i : interior ocean mask
+ !! tmask_h : halo mask
+ !! ssmask , ssumask, ssvmask, ssfmask : 2D ocean mask
+ !!----------------------------------------------------------------------
+ INTEGER, DIMENSION(:,:), INTENT(in) :: k_top, k_bot ! first and last ocean level
+ !
+ INTEGER :: ji, jj, jk ! dummy loop indices
+ INTEGER :: iif, iil ! local integers
+ INTEGER :: ijf, ijl ! - -
+ INTEGER :: iktop, ikbot ! - -
+ INTEGER :: ios, inum
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zwf ! 2D workspace
+ !!
+ NAMELIST/namlbc/ rn_shlat, ln_vorlat
+ NAMELIST/nambdy/ ln_bdy ,nb_bdy, ln_coords_file, cn_coords_file, &
+ & ln_mask_file, cn_mask_file, cn_dyn2d, nn_dyn2d_dta, &
+ & cn_dyn3d, nn_dyn3d_dta, cn_tra, nn_tra_dta, &
+ & ln_tra_dmp, ln_dyn3d_dmp, rn_time_dmp, rn_time_dmp_out, &
+ & cn_ice, nn_ice_dta, &
+ & ln_vol, nn_volctl, nn_rimwidth
+ !!---------------------------------------------------------------------
+ !
+ READ ( numnam_ref, namlbc, IOSTAT = ios, ERR = 901 )
+901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namlbc in reference namelist' )
+ READ ( numnam_cfg, namlbc, IOSTAT = ios, ERR = 902 )
+902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namlbc in configuration namelist' )
+ IF(lwm) WRITE ( numond, namlbc )
+
+ IF(lwp) THEN ! control print
+ WRITE(numout,*)
+ WRITE(numout,*) 'dommsk : ocean mask '
+ WRITE(numout,*) '~~~~~~'
+ WRITE(numout,*) ' Namelist namlbc'
+ WRITE(numout,*) ' lateral momentum boundary cond. rn_shlat = ',rn_shlat
+ WRITE(numout,*) ' consistency with analytical form ln_vorlat = ',ln_vorlat
+ ENDIF
+ !
+ IF(lwp) WRITE(numout,*)
+ IF ( rn_shlat == 0. ) THEN ; IF(lwp) WRITE(numout,*) ' ==>>> ocean lateral free-slip'
+ ELSEIF ( rn_shlat == 2. ) THEN ; IF(lwp) WRITE(numout,*) ' ==>>> ocean lateral no-slip'
+ ELSEIF ( 0. < rn_shlat .AND. rn_shlat < 2. ) THEN ; IF(lwp) WRITE(numout,*) ' ==>>> ocean lateral partial-slip'
+ ELSEIF ( 2. < rn_shlat ) THEN ; IF(lwp) WRITE(numout,*) ' ==>>> ocean lateral strong-slip'
+ ELSE
+ CALL ctl_stop( 'dom_msk: wrong value for rn_shlat (i.e. a negalive value). We stop.' )
+ ENDIF
+
+ ! Ocean/land mask at t-point (computed from ko_top and ko_bot)
+ ! ----------------------------
+ !
+ tmask(:,:,:) = 0._wp
+ DO_2D( 1, 1, 1, 1 )
+ iktop = k_top(ji,jj)
+ ikbot = k_bot(ji,jj)
+ IF( iktop /= 0 ) THEN ! water in the column
+ tmask(ji,jj,iktop:ikbot ) = 1._wp
+ ENDIF
+ END_2D
+ !
+ ! the following call is mandatory
+ ! it masks boundaries (bathy=0) where needed depending on the configuration (closed, periodic...)
+ CALL lbc_lnk( 'dommsk', tmask , 'T', 1._wp ) ! Lateral boundary conditions
+
+ ! Mask corrections for bdy (read in mppini2)
+ READ ( numnam_ref, nambdy, IOSTAT = ios, ERR = 903)
+903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy in reference namelist' )
+ READ ( numnam_cfg, nambdy, IOSTAT = ios, ERR = 904 )
+904 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambdy in configuration namelist' )
+ ! ------------------------
+ IF ( ln_bdy .AND. ln_mask_file ) THEN
+ CALL iom_open( cn_mask_file, inum )
+ CALL iom_get ( inum, jpdom_data, 'bdy_msk', bdytmask(:,:) )
+ CALL iom_close( inum )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
+ tmask(ji,jj,jk) = tmask(ji,jj,jk) * bdytmask(ji,jj)
+ END_3D
+ ENDIF
+
+ ! 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
+ DO jk = 1, jpk
+ DO jj = 1, jpjm1
+ DO ji = 1, jpim1 ! vector loop
+ umask(ji,jj,jk) = tmask(ji,jj ,jk) * tmask(ji+1,jj ,jk)
+ vmask(ji,jj,jk) = tmask(ji,jj ,jk) * tmask(ji ,jj+1,jk)
+ END DO
+ DO ji = 1, jpim1 ! NO vector opt.
+ fmask(ji,jj,jk) = tmask(ji,jj ,jk) * tmask(ji+1,jj ,jk) &
+ & * tmask(ji,jj+1,jk) * tmask(ji+1,jj+1,jk)
+ END DO
+ END DO
+ END DO
+ CALL lbc_lnk_multi( 'dommsk', umask, 'U', 1., vmask, 'V', 1., fmask, 'F', 1. ) ! Lateral boundary conditions
+
+ ! Ocean/land mask at wu-, wv- and w points (computed from tmask)
+ !-----------------------------------------
+ wmask (:,:,1) = tmask(:,:,1) ! surface
+ wumask(:,:,1) = umask(:,:,1)
+ wvmask(:,:,1) = vmask(:,:,1)
+ DO jk = 2, jpk ! interior values
+ wmask (:,:,jk) = tmask(:,:,jk) * tmask(:,:,jk-1)
+ wumask(:,:,jk) = umask(:,:,jk) * umask(:,:,jk-1)
+ wvmask(:,:,jk) = vmask(:,:,jk) * vmask(:,:,jk-1)
+ END DO
+
+
+ ! Ocean/land column mask at t-, u-, and v-points (i.e. at least 1 wet cell in the vertical)
+ ! ----------------------------------------------
+ ssmask (:,:) = MAXVAL( tmask(:,:,:), DIM=3 )
+ ssumask(:,:) = MAXVAL( umask(:,:,:), DIM=3 )
+ ssvmask(:,:) = MAXVAL( vmask(:,:,:), DIM=3 )
+!!an
+ ! ssfmask(:,:) = MAXVAL( fmask(:,:,:), DIM=3 )
+ DO_2D( 1, 0, 1, 0 )
+ ssfmask(ji,jj) = MAX( tmask(ji,jj+1,1), tmask(ji+1,jj+1,1), &
+ & tmask(ji,jj ,1), tmask(ji+1,jj ,1) )
+ END_2D
+ CALL lbc_lnk( 'dommsk', ssfmask, 'F', 1._wp )
+
+!!an
+
+ ! Interior domain mask (used for global sum)
+ ! --------------------
+ !
+ iif = nn_hls ; iil = nlci - nn_hls + 1
+ ijf = nn_hls ; ijl = nlcj - nn_hls + 1
+ !
+ ! ! halo mask : 0 on the halo and 1 elsewhere
+ tmask_h(:,:) = 1._wp
+ tmask_h( 1 :iif, : ) = 0._wp ! first columns
+ tmask_h(iil:jpi, : ) = 0._wp ! last columns (including mpp extra columns)
+ tmask_h( : , 1 :ijf) = 0._wp ! first rows
+ tmask_h( : ,ijl:jpj) = 0._wp ! last rows (including mpp extra rows)
+ !
+ ! ! north fold mask
+ tpol(1:jpiglo) = 1._wp
+ fpol(1:jpiglo) = 1._wp
+ IF( jperio == 3 .OR. jperio == 4 ) THEN ! T-point pivot
+ tpol(jpiglo/2+1:jpiglo) = 0._wp
+ fpol( 1 :jpiglo) = 0._wp
+ IF( mjg(nlej) == jpjglo ) THEN ! only half of the nlcj-1 row for tmask_h
+ DO ji = iif+1, iil-1
+ tmask_h(ji,nlej-1) = tmask_h(ji,nlej-1) * tpol(mig(ji))
+ END DO
+ ENDIF
+ ENDIF
+ !
+ IF( jperio == 5 .OR. jperio == 6 ) THEN ! F-point pivot
+ tpol( 1 :jpiglo) = 0._wp
+ fpol(jpiglo/2+1:jpiglo) = 0._wp
+ ENDIF
+ !
+ ! ! interior mask : 2D ocean mask x halo mask
+ tmask_i(:,:) = ssmask(:,:) * tmask_h(:,:)
+
+
+ ! Lateral boundary conditions on velocity (modify fmask)
+ ! ---------------------------------------
+ IF( rn_shlat /= 0 ) THEN ! Not free-slip lateral boundary condition
+ !
+ ALLOCATE( zwf(jpi,jpj) )
+ !
+ DO jk = 1, jpk
+ zwf(:,:) = fmask(:,:,jk)
+ DO_2D( 0, 0, 0, 0 )
+ IF( fmask(ji,jj,jk) == 0._wp ) THEN
+ fmask(ji,jj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(ji+1,jj), zwf(ji,jj+1), &
+ & zwf(ji-1,jj), zwf(ji,jj-1) ) )
+ ENDIF
+ END_2D
+ DO jj = 2, jpjm1
+ IF( fmask(1,jj,jk) == 0._wp ) THEN
+ fmask(1 ,jj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(2,jj), zwf(1,jj+1), zwf(1,jj-1) ) )
+ ENDIF
+ IF( fmask(jpi,jj,jk) == 0._wp ) THEN
+ fmask(jpi,jj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(jpi,jj+1), zwf(jpim1,jj), zwf(jpi,jj-1) ) )
+ ENDIF
+ END DO
+ DO ji = 2, jpim1
+ IF( fmask(ji,1,jk) == 0._wp ) THEN
+ fmask(ji, 1 ,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(ji+1,1), zwf(ji,2), zwf(ji-1,1) ) )
+ ENDIF
+ IF( fmask(ji,jpj,jk) == 0._wp ) THEN
+ fmask(ji,jpj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(ji+1,jpj), zwf(ji-1,jpj), zwf(ji,jpjm1) ) )
+ ENDIF
+ END DO
+#if defined key_agrif
+ IF( .NOT. AGRIF_Root() ) THEN
+ IF ((nbondi == 1).OR.(nbondi == 2)) fmask(nlci-1 , : ,jk) = 0.e0 ! east
+ IF ((nbondi == -1).OR.(nbondi == 2)) fmask(1 , : ,jk) = 0.e0 ! west
+ IF ((nbondj == 1).OR.(nbondj == 2)) fmask(: ,nlcj-1 ,jk) = 0.e0 ! north
+ IF ((nbondj == -1).OR.(nbondj == 2)) fmask(: ,1 ,jk) = 0.e0 ! south
+ ENDIF
+#endif
+ END DO
+ !
+ DEALLOCATE( zwf )
+ !
+ CALL lbc_lnk( 'dommsk', fmask, 'F', 1._wp ) ! Lateral boundary conditions on fmask
+ !
+ ! CAUTION : The fmask may be further modified in dyn_vor_init ( dynvor.F90 ) depending on ln_vorlat
+ !
+ ENDIF
+
+ ! User defined alteration of fmask (use to reduce ocean transport in specified straits)
+ ! --------------------------------
+ !
+ CALL usr_def_fmask( cn_cfg, nn_cfg, fmask )
+ !
+ END SUBROUTINE dom_msk
+
+ !!======================================================================
+END MODULE dommsk
Index: /NEMO/branches/2020/r12377_ticket2386/src/SWE/domvvl.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/SWE/domvvl.F90 (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/src/SWE/domvvl.F90 (revision 13540)
@@ -0,0 +1,1350 @@
+
+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
+ !!----------------------------------------------------------------------
+
+ 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
+ ! ! 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
+!!stoops
+#if defined key_qco
+ !!----------------------------------------------------------------------
+ !! 'key_qco' EMPTY MODULE Quasi-Eulerian vertical coordonate
+ !!----------------------------------------------------------------------
+#else
+ !!----------------------------------------------------------------------
+ !! Default key Old management of time varying vertical coordinate
+ !!----------------------------------------------------------------------
+!!st
+ !!----------------------------------------------------------------------
+ !! 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
+ PUBLIC dom_vvl_interpol_st! called by dynnxt.F90
+ PUBLIC dom_vvl_sf_nxt_st ! called by step.F90
+ PUBLIC dom_vvl_sf_update_st
+!!st
+
+ !! * Substitutions
+# include "do_loop_substitute.h90"
+ !!----------------------------------------------------------------------
+ !! NEMO/OCE 4.0 , NEMO Consortium (2018)
+ !! $Id: domvvl.F90 12614 2020-03-26 14:59:52Z gm $
+ !! 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_st(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( ssh(:,:,Kbb), e3u(:,:,:,Kbb), 'U' ) ! from T to U
+ CALL dom_vvl_interpol( ssh(:,:,Kmm), e3u(:,:,:,Kmm), 'U' )
+ CALL dom_vvl_interpol( ssh(:,:,Kbb), e3v(:,:,:,Kbb), 'V' ) ! from T to V
+ CALL dom_vvl_interpol( ssh(:,:,Kmm), e3v(:,:,:,Kmm), 'V' )
+ CALL dom_vvl_interpol( ssh(:,:,Kmm), e3f(:,:,:), 'F' ) ! from U to F
+ ! ! Vertical interpolation of e3t,u,v
+ CALL dom_vvl_interpol( ssh(:,:,Kmm), e3w (:,:,:,Kmm), 'W' ) ! from T to W
+ CALL dom_vvl_interpol( ssh(:,:,Kbb), e3w (:,:,:,Kbb), 'W' )
+ CALL dom_vvl_interpol( ssh(:,:,Kmm), e3uw(:,:,:,Kmm), 'UW' ) ! from U to UW
+ CALL dom_vvl_interpol( ssh(:,:,Kbb), e3uw(:,:,:,Kbb), 'UW' )
+ CALL dom_vvl_interpol( ssh(:,:,Kmm), e3vw(:,:,:,Kmm), 'VW' ) ! from V to UW
+ CALL dom_vvl_interpol( ssh(:,:,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( 1, 1, 1, 1, 2, jpk )
+ ! 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
+ !
+ IF(lwxios) THEN
+! define variables in restart file when writing with XIOS
+ CALL iom_set_rstw_var_active('e3t_b')
+ CALL iom_set_rstw_var_active('e3t_n')
+ ! ! ----------------------- !
+ IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! z_tilde and layer cases !
+ ! ! ----------------------- !
+ CALL iom_set_rstw_var_active('tilde_e3t_b')
+ CALL iom_set_rstw_var_active('tilde_e3t_n')
+ END IF
+ ! ! -------------!
+ IF( ln_vvl_ztilde ) THEN ! z_tilde case !
+ ! ! ------------ !
+ CALL iom_set_rstw_var_active('hdiv_lf')
+ ENDIF
+ !
+ ENDIF
+ !
+ END SUBROUTINE dom_vvl_zgr
+
+
+ SUBROUTINE dom_vvl_zgr_st(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_st( r3u(:,:,Kbb), e3u(:,:,:,Kbb), 'U' ) ! from T to U
+ CALL dom_vvl_interpol_st( r3u(:,:,Kmm), e3u(:,:,:,Kmm), 'U' )
+ CALL dom_vvl_interpol_st( r3v(:,:,Kbb), e3v(:,:,:,Kbb), 'V' ) ! from T to V
+ CALL dom_vvl_interpol_st( r3v(:,:,Kmm), e3v(:,:,:,Kmm), 'V' )
+ CALL dom_vvl_interpol_st( r3f(:,:), e3f(:,:,:), 'F' ) ! from U to F
+ ! ! Vertical interpolation of e3t,u,v
+ CALL dom_vvl_interpol_st( r3t(:,:,Kmm), e3w (:,:,:,Kmm), 'W' ) ! from T to W
+ CALL dom_vvl_interpol_st( r3t(:,:,Kbb), e3w (:,:,:,Kbb), 'W' )
+ CALL dom_vvl_interpol_st( r3u(:,:,Kmm), e3uw(:,:,:,Kmm), 'UW' ) ! from U to UW
+ CALL dom_vvl_interpol_st( r3u(:,:,Kbb), e3uw(:,:,:,Kbb), 'UW' )
+ CALL dom_vvl_interpol_st( r3v(:,:,Kmm), e3vw(:,:,:,Kmm), 'VW' ) ! from V to UW
+ CALL dom_vvl_interpol_st( r3v(:,:,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)
+ !
+ DO_3D( 1, 1, 1, 1, 1, jpk )
+ gdepw(ji,jj,jk,Kmm) = gdepw_0(ji,jj,jk) * (1._wp + r3t(ji,jj,Kmm))
+ gdept(ji,jj,jk,Kmm) = gdept_0(ji,jj,jk) * (1._wp + r3t(ji,jj,Kmm))
+ gde3w(ji,jj,jk ) = gdept(ji,jj,jk,Kmm) - ssh(ji,jj,Kmm)
+ gdepw(ji,jj,jk,Kbb) = gdepw_0(ji,jj,jk) * (1._wp + r3t(ji,jj,Kbb))
+ gdept(ji,jj,jk,Kbb) = gdept_0(ji,jj,jk) * (1._wp + r3t(ji,jj,Kbb))
+ END_3D
+ !
+ ! !== thickness of the water column !! (ocean portion only)
+ ht(:,:) = ht_0(:,:) + ssh(:,:,Kmm)
+ hu(:,:,Kbb) = (hu_0(:,:)*(1._wp+r3u(:,:,Kbb)))
+ hv(:,:,Kbb) = (hv_0(:,:)*(1._wp+r3v(:,:,Kbb)))
+ hu(:,:,Kbb) = (hu_0(:,:)*(1._wp+r3u(:,:,Kmm)))
+ hv(:,:,Kbb) = (hv_0(:,:)*(1._wp+r3v(:,:,Kmm)))
+ ! !== 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(:,:) )
+ !
+ IF(lwxios) THEN
+! define variables in restart file when writing with XIOS
+ CALL iom_set_rstw_var_active('e3t_b')
+ CALL iom_set_rstw_var_active('e3t_n')
+ !
+ ENDIF
+ !
+ END SUBROUTINE dom_vvl_zgr_st
+
+
+ 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( 1, 0, 1, 0, 1, jpkm1 )
+ 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( 1, 1, 1, 1 )
+ 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 )
+ 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)
+ CALL lbc_lnk_multi( '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) )
+ ze3t(:,:,jpk) = 0._wp
+ DO jk = 1, jpkm1
+ ze3t(:,:,jk) = tilde_e3t_a(:,:,jk) / e3t_0(:,:,jk) * tmask(:,:,jk) * tmask_i(:,:)
+ END DO
+ !
+ llmsk( 1:Nis1,:,:) = .FALSE. ! exclude halos from the checked region
+ llmsk(Nie1: jpi,:,:) = .FALSE.
+ llmsk(:, 1:Njs1,:) = .FALSE.
+ llmsk(:,Nje1: 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
+
+ ! *********************************** !
+ ! After scale factors at u- v- points !
+ ! *********************************** !
+
+ CALL dom_vvl_interpol( ssh(:,:,Kaa), e3u(:,:,:,Kaa), 'U' )
+ CALL dom_vvl_interpol( ssh(:,:,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_nxt_st( 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
+ !!----------------------------------------------------------------------
+ !
+ 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 !
+ ! ******************************* !
+ !
+ DO jk = 1, jpkm1
+ e3t(:,:,jk,Kaa) = e3t_0(:,:,jk) * ( 1._wp + r3t(:,:,Kaa) )
+ e3u(:,:,jk,Kaa) = e3u_0(:,:,jk) * ( 1._wp + r3u(:,:,Kaa) )
+ e3v(:,:,jk,Kaa) = e3v_0(:,:,jk) * ( 1._wp + r3v(:,:,Kaa) )
+ END DO
+ !
+ ! *********************************** !
+ ! After scale factors at u- v- points !
+ ! *********************************** !
+
+ !!st CALL dom_vvl_interpol_st( r3u(:,:,Kaa), e3u(:,:,:,Kaa), 'U' )
+ !!st CALL dom_vvl_interpol_st( r3v(:,:,Kaa), e3v(:,:,:,Kaa), 'V' )
+
+ ! *********************************** !
+ ! After depths at u- v points !
+ ! *********************************** !
+
+ !!st hu(:,:,Kaa) = e3u(:,:,1,Kaa) * umask(:,:,1)
+ !!st hv(:,:,Kaa) = e3v(:,:,1,Kaa) * vmask(:,:,1)
+ !!st DO jk = 2, jpkm1
+ !!st hu(:,:,Kaa) = hu(:,:,Kaa) + e3u(:,:,jk,Kaa) * umask(:,:,jk)
+ !!st hv(:,:,Kaa) = hv(:,:,Kaa) + e3v(:,:,jk,Kaa) * vmask(:,:,jk)
+ !!st
+ !!st END DO
+ hu(:,:,Kaa) = (hu_0(:,:)*(1._wp+r3u(:,:,Kaa)))
+ hv(:,:,Kaa) = (hv_0(:,:)*(1._wp+r3v(:,:,Kaa)))
+ ! ! 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_st
+
+
+
+ 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( ssh(:,:,Kmm), e3f(:,:,:), 'F' )
+
+ ! Vertical scale factor interpolations
+ CALL dom_vvl_interpol( ssh(:,:,Kmm), e3w(:,:,:,Kmm), 'W' )
+ CALL dom_vvl_interpol( ssh(:,:,Kmm), e3uw(:,:,:,Kmm), 'UW' )
+ CALL dom_vvl_interpol( ssh(:,:,Kmm), e3vw(:,:,:,Kmm), 'VW' )
+ CALL dom_vvl_interpol( ssh(:,:,Kbb), e3w(:,:,:,Kbb), 'W' )
+ CALL dom_vvl_interpol( ssh(:,:,Kbb), e3uw(:,:,:,Kbb), 'UW' )
+ CALL dom_vvl_interpol( ssh(:,:,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( 1, 1, 1, 1, 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_sf_update_st( 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
+ !
+
+ ! 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_st( r3f(:,:), e3f(:,:,:), 'F' )
+
+ ! Vertical scale factor interpolations
+ CALL dom_vvl_interpol_st( r3t(:,:,Kmm), e3w(:,:,:,Kmm), 'W' )
+ CALL dom_vvl_interpol_st( r3u(:,:,Kmm), e3uw(:,:,:,Kmm), 'UW' )
+ CALL dom_vvl_interpol_st( r3v(:,:,Kmm), e3vw(:,:,:,Kmm), 'VW' )
+ CALL dom_vvl_interpol_st( r3t(:,:,Kbb), e3w(:,:,:,Kbb), 'W' )
+ CALL dom_vvl_interpol_st( r3u(:,:,Kbb), e3uw(:,:,:,Kbb), 'UW' )
+ CALL dom_vvl_interpol_st( r3v(:,:,Kbb), e3vw(:,:,:,Kbb), 'VW' )
+
+ ! t- and w- points depth (set the isf depth as it is in the initial step)
+ DO_3D( 1, 1, 1, 1, 1, jpk )
+ gdepw(ji,jj,jk,Kmm) = gdepw_0(ji,jj,jk) * (1._wp + r3t(ji,jj,Kmm))
+ gdept(ji,jj,jk,Kmm) = gdept_0(ji,jj,jk) * (1._wp + r3t(ji,jj,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(:,:) = ht_0(:,:) + ssh(:,:,Kmm)
+
+ ! 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_st
+
+
+
+ SUBROUTINE dom_vvl_interpol_st( rc3, pe3, cdp )
+ !!---------------------------------------------------------------------
+ !! *** 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(:,:) , INTENT(in ) :: rc3 ! input e3 NOT used here (ssh is used instead)
+ REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pe3 ! scale factor e3 to be updated [m]
+ CHARACTER(LEN=*) , INTENT(in ) :: cdp ! grid point of the scale factor ( 'U', 'V', 'W, 'F', 'UW' or 'VW' )
+ !
+ INTEGER :: ji, jj, jk ! dummy loop indices
+ REAL(wp), DIMENSION(jpi,jpj) :: zc3 ! 2D workspace
+ !!----------------------------------------------------------------------
+ !
+ SELECT CASE ( cdp ) !== type of interpolation ==!
+ !
+ CASE( 'U' ) !* from T- to U-point : hor. surface weighted mean
+ DO jk = 1, jpkm1
+ pe3(:,:,jk) = e3u_0(:,:,jk) * ( 1.0_wp + rc3(:,:) )
+ END DO
+ !
+ CASE( 'V' ) !* from T- to V-point : hor. surface weighted mean
+ DO jk = 1, jpkm1
+ pe3(:,:,jk) = e3v_0(:,:,jk) * ( 1.0_wp + rc3(:,:) )
+ END DO
+ !
+ CASE( 'F' ) !* from U-point to F-point : hor. surface weighted mean
+ DO jk = 1, jpkm1 ! Horizontal interpolation of e3f from ssh
+ e3f(:,:,jk) = e3f_0(:,:,jk) * ( 1._wp + rc3(:,:) )
+ END DO
+ !
+ CASE( 'W' ) !* from T- to W-point : vertical simple mean
+ DO jk = 1, jpk
+ pe3(:,:,jk) = e3w_0(:,:,jk) * ( 1.0_wp + rc3(:,:) )
+ END DO
+ !
+ CASE( 'UW' ) !* from U- to UW-point
+ DO jk = 1, jpk
+ pe3(:,:,jk) = e3uw_0(:,:,jk) * ( 1.0_wp + rc3(:,:) )
+ END DO
+ CASE( 'VW' ) !* from U- to UW-point : vertical simple mean
+ DO jk = 1, jpk
+ pe3(:,:,jk) = e3vw_0(:,:,jk) * ( 1.0_wp + rc3(:,:) )
+ END DO
+ !
+ END SELECT
+ !
+ END SUBROUTINE dom_vvl_interpol_st
+
+
+ SUBROUTINE dom_vvl_interpol( pssh, pe3, cdp )
+ !!---------------------------------------------------------------------
+ !! *** 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(:,:) , INTENT(in ) :: pssh ! input e3 NOT used here (ssh is used instead)
+ REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pe3 ! scale factor e3 to be updated [m]
+ CHARACTER(LEN=*) , INTENT(in ) :: cdp ! grid point of the scale factor ( 'U', 'V', 'W, 'F', 'UW' or 'VW' )
+ !
+ INTEGER :: ji, jj, jk ! dummy loop indices
+ REAL(wp), DIMENSION(jpi,jpj) :: zc3 ! 2D workspace
+ !!----------------------------------------------------------------------
+ !
+ SELECT CASE ( cdp ) !== type of interpolation ==!
+ !
+ CASE( 'U' ) !* from T- to U-point : hor. surface weighted mean
+ DO_2D( 0, 0, 0, 0 )
+ zc3(ji,jj) = 0.5_wp * ( e1e2t(ji ,jj) * pssh(ji ,jj) &
+ & + e1e2t(ji+1,jj) * pssh(ji+1,jj) ) * r1_hu_0(ji,jj) * r1_e1e2u(ji,jj)
+ END_2D
+ CALL lbc_lnk( 'domvvl', zc3(:,:), 'U', 1._wp )
+ !
+ DO jk = 1, jpkm1
+ pe3(:,:,jk) = e3u_0(:,:,jk) * ( 1.0_wp + zc3(:,:) )
+ END DO
+ !
+ CASE( 'V' ) !* from T- to V-point : hor. surface weighted mean
+ DO_2D( 0, 0, 0, 0 )
+ zc3(ji,jj) = 0.5_wp * ( e1e2t(ji,jj ) * pssh(ji,jj ) &
+ & + e1e2t(ji,jj+1) * pssh(ji,jj+1) ) * r1_hv_0(ji,jj) * r1_e1e2v(ji,jj)
+ END_2D
+ CALL lbc_lnk( 'domvvl', zc3(:,:), 'V', 1._wp )
+ !
+ DO jk = 1, jpkm1
+ pe3(:,:,jk) = e3v_0(:,:,jk) * ( 1.0_wp + zc3(:,:) )
+ END DO
+ !
+ CASE( 'F' ) !* from U-point to F-point : hor. surface weighted mean
+ DO_2D( 1, 0, 1, 0 )
+ zc3(ji,jj) = 0.25_wp * ( e1e2t(ji ,jj ) * pssh(ji ,jj ) &
+ & + e1e2t(ji+1,jj ) * pssh(ji+1,jj ) &
+ & + e1e2t(ji ,jj+1) * pssh(ji ,jj+1) &
+ & + e1e2t(ji+1,jj+1) * pssh(ji+1,jj+1) ) * r1_hf_0(ji,jj) * r1_e1e2f(ji,jj)
+ END_2D
+ CALL lbc_lnk( 'domvvl', zc3(:,:), 'F', 1._wp )
+ !
+ DO jk = 1, jpkm1 ! Horizontal interpolation of e3f from ssh
+ e3f(:,:,jk) = e3f_0(:,:,jk) * ( 1._wp + zc3(:,:) )
+ END DO
+ !
+ CASE( 'W' ) !* from T- to W-point : vertical simple mean
+ zc3(:,:) = pssh(:,:) * r1_ht_0(:,:)
+ !
+ DO jk = 1, jpk
+ pe3(:,:,jk) = e3w_0(:,:,jk) * ( 1.0_wp + zc3(:,:) )
+ END DO
+ !
+ CASE( 'UW' ) !* from U- to UW-point
+ !
+ DO_2D( 0, 0, 0, 0 )
+ zc3(ji,jj) = 0.5_wp * ( e1e2t(ji ,jj) * pssh(ji ,jj) &
+ & + e1e2t(ji+1,jj) * pssh(ji+1,jj) ) * r1_hu_0(ji,jj) * r1_e1e2u(ji,jj)
+ END_2D
+ CALL lbc_lnk( 'domvvl', zc3(:,:), 'U', 1._wp )
+ !
+ DO jk = 1, jpk
+ pe3(:,:,jk) = e3uw_0(:,:,jk) * ( 1.0_wp + zc3(:,:) )
+ END DO
+ CASE( 'VW' ) !* from U- to UW-point : vertical simple mean
+ !
+ DO_2D( 0, 0, 0, 0 )
+ zc3(ji,jj) = 0.5_wp * ( e1e2t(ji,jj ) * pssh(ji,jj ) &
+ & + e1e2t(ji,jj+1) * pssh(ji,jj+1) ) * r1_hv_0(ji,jj) * r1_e1e2v(ji,jj)
+ END_2D
+ CALL lbc_lnk( 'domvvl', zc3(:,:), 'V', 1._wp )
+ !
+ DO jk = 1, jpk
+ pe3(:,:,jk) = e3vw_0(:,:,jk) * ( 1.0_wp + zc3(:,:) )
+ 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 : use of IOM library
+ !! if the restart does not contain vertical scale factors,
+ !! they are set to the _0 values
+ !! if the restart does not contain vertical scale factors increments (z_tilde),
+ !! they are set to 0.
+ !!----------------------------------------------------------------------
+ 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
+ INTEGER :: id1, 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
+ CALL iom_get( numror, jpdom_auto, 'sshn' , ssh(:,:,Kmm), ldxios = lrxios )
+ !
+ id1 = iom_varid( numror, 'e3t_b', ldstop = .FALSE. )
+ id2 = iom_varid( numror, 'e3t_n', ldstop = .FALSE. )
+ 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. )
+ !
+ ! ! --------- !
+ ! ! all cases !
+ ! ! --------- !
+ !
+ IF( MIN( id1, id2 ) > 0 ) THEN ! all required arrays exist
+ CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb), ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm), ldxios = lrxios )
+ ! needed to restart if land processor not computed
+ IF(lwp) write(numout,*) 'dom_vvl_rst : e3t(:,:,:,Kbb) and e3t(:,:,:,Kmm) found in restart files'
+ WHERE ( tmask(:,:,:) == 0.0_wp )
+ e3t(:,:,:,Kmm) = e3t_0(:,:,:)
+ e3t(:,:,:,Kbb) = e3t_0(:,:,:)
+ END WHERE
+ IF( l_1st_euler ) THEN
+ e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm)
+ ENDIF
+ ELSE IF( id1 > 0 ) THEN
+ IF(lwp) write(numout,*) 'dom_vvl_rst WARNING : e3t(:,:,:,Kmm) not found in restart files'
+ IF(lwp) write(numout,*) 'e3t_n set equal to e3t_b.'
+ IF(lwp) write(numout,*) 'l_1st_euler is forced to true'
+ CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb), ldxios = lrxios )
+ e3t(:,:,:,Kmm) = e3t(:,:,:,Kbb)
+ l_1st_euler = .true.
+ ELSE IF( id2 > 0 ) THEN
+ IF(lwp) write(numout,*) 'dom_vvl_rst WARNING : e3t(:,:,:,Kbb) not found in restart files'
+ IF(lwp) write(numout,*) 'e3t_b set equal to e3t_n.'
+ IF(lwp) write(numout,*) 'l_1st_euler is forced to true'
+ CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm), ldxios = lrxios )
+ e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm)
+ l_1st_euler = .true.
+ ELSE
+ IF(lwp) write(numout,*) 'dom_vvl_rst WARNING : e3t(:,:,:,Kmm) not found in restart file'
+ IF(lwp) write(numout,*) 'Compute scale factor from sshn'
+ IF(lwp) write(numout,*) 'l_1st_euler is forced to true'
+ DO jk = 1, jpk
+ e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * ( ht_0(:,:) + ssh(:,:,Kmm) ) &
+ & / ( ht_0(:,:) + 1._wp - ssmask(:,:) ) * tmask(:,:,jk) &
+ & + e3t_0(:,:,jk) * (1._wp -tmask(:,:,jk))
+ END DO
+ e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm)
+ l_1st_euler = .true.
+ 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( MIN( id3, id4 ) > 0 ) THEN ! all required arrays exist
+ CALL iom_get( numror, jpdom_auto, 'tilde_e3t_b', tilde_e3t_b(:,:,:), ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'tilde_e3t_n', tilde_e3t_n(:,:,:), ldxios = lrxios )
+ ELSE ! one at least array is missing
+ 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(:,:,:), ldxios = lrxios )
+ ELSE ! array is missing
+ hdiv_lf(:,:,:) = 0.0_wp
+ ENDIF
+ ENDIF
+ ENDIF
+ !
+ ELSE !* Initialize at "rest"
+ !
+
+ IF( ll_wd ) THEN ! MJB ll_wd edits start here - these are essential
+ !
+ IF( cn_cfg == 'wad' ) THEN
+ ! Wetting and drying test case
+ CALL usr_def_istate( gdept(:,:,:,Kbb), tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb), ssh(:,:,Kbb) )
+!!an ts (:,:,:,:,Kmm) = ts (:,:,:,:,Kbb) ! set now values from to before ones
+ ssh (:,:,Kmm) = ssh(:,:,Kbb)
+ uu (:,:,:,Kmm) = uu (:,:,:,Kbb)
+ vv (:,:,:,Kmm) = vv (:,:,:,Kbb)
+ ELSE
+ ! if not test case
+ ssh(:,:,Kmm) = -ssh_ref
+ ssh(:,:,Kbb) = -ssh_ref
+
+ DO_2D( 1, 1, 1, 1 )
+ IF( ht_0(ji,jj)-ssh_ref < rn_wdmin1 ) THEN ! if total depth is less than min depth
+ ssh(ji,jj,Kbb) = rn_wdmin1 - (ht_0(ji,jj) )
+ ssh(ji,jj,Kmm) = rn_wdmin1 - (ht_0(ji,jj) )
+ ENDIF
+ END_2D
+ ENDIF !If test case else
+
+ ! Adjust vertical metrics for all wad
+ DO jk = 1, jpk
+ e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * ( ht_0(:,:) + ssh(:,:,Kmm) ) &
+ & / ( ht_0(:,:) + 1._wp - ssmask(:,:) ) * tmask(:,:,jk) &
+ & + e3t_0(:,:,jk) * ( 1._wp - tmask(:,:,jk) )
+ END DO
+ e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm)
+
+ DO ji = 1, jpi
+ DO jj = 1, jpj
+ IF ( ht_0(ji,jj) .LE. 0.0 .AND. NINT( ssmask(ji,jj) ) .EQ. 1) THEN
+ CALL ctl_stop( 'dom_vvl_rst: ht_0 must be positive at potentially wet points' )
+ ENDIF
+ END DO
+ END DO
+ !
+ ELSE
+ !
+ ! Just to read set ssh in fact, called latter once vertical grid
+ ! is set up:
+! CALL usr_def_istate( gdept_0, tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb), ssh(:,:,Kbb) )
+! !
+! DO jk=1,jpk
+! e3t(:,:,jk,Kbb) = e3t_0(:,:,jk) * ( ht_0(:,:) + ssh(:,:,Kbb) ) &
+! & / ( ht_0(:,:) + 1._wp -ssmask(:,:) ) * tmask(:,:,jk)
+! END DO
+! e3t(:,:,:,Kmm) = e3t(:,:,:,Kbb)
+ ssh(:,:,Kmm)=0._wp
+ ssh(:,:,Kbb)=0._wp
+ e3t(:,:,:,Kmm)=e3t_0(:,:,:)
+ e3t(:,:,:,Kbb)=e3t_0(:,:,:)
+ !
+ END IF ! end of ll_wd edits
+
+ 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
+ END IF
+ ENDIF
+ !
+ ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN ! Create restart file
+ ! ! ===================
+ IF(lwp) WRITE(numout,*) '---- dom_vvl_rst ----'
+ IF( lwxios ) CALL iom_swap( cwxios_context )
+ ! ! --------- !
+ ! ! all cases !
+ ! ! --------- !
+ CALL iom_rstput( kt, nitrst, numrow, 'e3t_b', e3t(:,:,:,Kbb), ldxios = lwxios )
+ CALL iom_rstput( kt, nitrst, numrow, 'e3t_n', e3t(:,:,:,Kmm), ldxios = lwxios )
+ ! ! ----------------------- !
+ 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(:,:,:), ldxios = lwxios)
+ CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_n', tilde_e3t_n(:,:,:), ldxios = lwxios)
+ END IF
+ ! ! -------------!
+ IF( ln_vvl_ztilde ) THEN ! z_tilde case !
+ ! ! ------------ !
+ CALL iom_rstput( kt, nitrst, numrow, 'hdiv_lf', hdiv_lf(:,:,:), ldxios = lwxios)
+ ENDIF
+ !
+ IF( lwxios ) CALL iom_swap( cxios_context )
+ 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
+ !!----------------------------------------------------------------------
+ !
+ 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
+ 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(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
+!!stoops
+
+ !!======================================================================
+END MODULE domvvl
Index: /NEMO/branches/2020/r12377_ticket2386/src/SWE/domzgr_substitute.h90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/SWE/domzgr_substitute.h90 (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/src/SWE/domzgr_substitute.h90 (revision 13540)
@@ -0,0 +1,30 @@
+!!----------------------------------------------------------------------
+!! *** domzgr_substitute.h90 ***
+!!----------------------------------------------------------------------
+!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale
+!! factors depending on the vertical coord. used, using CPP macro.
+!!----------------------------------------------------------------------
+!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate
+!!----------------------------------------------------------------------
+!! 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)))
+# define e3u(i,j,k,t) (e3u_0(i,j,k)*(1._wp+r3u(i,j,t)))
+# define e3v(i,j,k,t) (e3v_0(i,j,k)*(1._wp+r3v(i,j,t)))
+# define e3f(i,j,k) (e3f_0(i,j,k)*(1._wp+r3f(i,j)))
+# 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 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))
+#endif
+!!----------------------------------------------------------------------
Index: /NEMO/branches/2020/r12377_ticket2386/src/SWE/dynadv.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/SWE/dynadv.F90 (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/src/SWE/dynadv.F90 (revision 13540)
@@ -0,0 +1,153 @@
+MODULE dynadv
+ !!==============================================================================
+ !! *** MODULE dynadv ***
+ !! Ocean active tracers: advection scheme control
+ !!==============================================================================
+ !! History : 1.0 ! 2006-11 (G. Madec) Original code
+ !! 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
+ !!----------------------------------------------------------------------
+
+ !!----------------------------------------------------------------------
+ !! dyn_adv : compute the momentum advection trend
+ !! dyn_adv_init : control the different options of advection scheme
+ !!----------------------------------------------------------------------
+ USE dom_oce ! ocean space and time domain
+ USE dynadv_cen2 ! centred flux form advection (dyn_adv_cen2 routine)
+ USE dynadv_ubs ! UBS flux form advection (dyn_adv_ubs routine)
+ USE dynkeg ! kinetic energy gradient (dyn_keg routine)
+ USE dynzad ! vertical advection (dyn_zad routine)
+ !
+ USE in_out_manager ! I/O manager
+ USE lib_mpp ! MPP library
+ USE timing ! Timing
+
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC dyn_adv ! routine called by step module
+ PUBLIC dyn_adv_init ! routine called by opa module
+
+ ! !!* namdyn_adv namelist *
+ LOGICAL, PUBLIC :: ln_dynadv_OFF !: linear dynamics (no momentum advection)
+ LOGICAL, PUBLIC :: ln_dynadv_vec !: vector form
+ INTEGER, PUBLIC :: nn_dynkeg !: scheme of grad(KE): =0 C2 ; =1 Hollingsworth
+ LOGICAL, PUBLIC :: ln_dynadv_cen2 !: flux form - 2nd order centered scheme flag
+ LOGICAL, PUBLIC :: ln_dynadv_ubs !: flux form - 3rd order UBS scheme flag
+
+ INTEGER, PUBLIC :: n_dynadv !: choice of the formulation and scheme for momentum advection
+ ! ! associated indices:
+ INTEGER, PUBLIC, PARAMETER :: np_LIN_dyn = 0 ! no advection: linear dynamics
+ INTEGER, PUBLIC, PARAMETER :: np_VEC_c2 = 1 ! vector form : 2nd order centered scheme
+ INTEGER, PUBLIC, PARAMETER :: np_FLX_c2 = 2 ! flux form : 2nd order centered scheme
+ INTEGER, PUBLIC, PARAMETER :: np_FLX_ubs = 3 ! flux form : 3rd order Upstream Biased Scheme
+
+ !!----------------------------------------------------------------------
+ !! NEMO/OCE 4.0 , NEMO Consortium (2018)
+ !! $Id: dynadv.F90 12822 2020-04-28 09:10:38Z gm $
+ !! Software governed by the CeCILL license (see ./LICENSE)
+ !!----------------------------------------------------------------------
+CONTAINS
+
+ SUBROUTINE dyn_adv( kt, Kbb, Kmm, puu, pvv, Krhs )
+ !!---------------------------------------------------------------------
+ !! *** ROUTINE dyn_adv ***
+ !!
+ !! ** Purpose : compute the ocean momentum advection trend.
+ !!
+ !! ** Method : - Update (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) with the advection term following n_dynadv
+ !!
+ !! NB: in flux form advection (ln_dynadv_cen2 or ln_dynadv_ubs=T)
+ !! a metric term is add to the coriolis term while in vector form
+ !! it is the relative vorticity which is added to coriolis term
+ !! (see dynvor 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
+ !!----------------------------------------------------------------------
+ !
+ IF( ln_timing ) CALL timing_start( 'dyn_adv' )
+ !
+ SELECT CASE( n_dynadv ) !== compute advection trend and add it to general trend ==!
+ CASE( np_VEC_c2 )
+ CALL dyn_keg ( kt, nn_dynkeg, Kmm, puu, pvv, Krhs ) ! vector form : horizontal gradient of kinetic energy
+ CALL dyn_zad ( kt, Kmm, puu, pvv, Krhs ) ! vector form : vertical advection
+ CASE( np_FLX_c2 )
+ CALL dyn_adv_cen2( kt, Kmm, puu, pvv, Krhs ) ! 2nd order centered scheme
+ CASE( np_FLX_ubs )
+ CALL dyn_adv_ubs ( kt, Kbb, Kmm, puu, pvv, Krhs ) ! 3rd order UBS scheme (UP3)
+ END SELECT
+ !
+ IF( ln_timing ) CALL timing_stop( 'dyn_adv' )
+ !
+ END SUBROUTINE dyn_adv
+
+
+ SUBROUTINE dyn_adv_init
+ !!---------------------------------------------------------------------
+ !! *** ROUTINE dyn_adv_init ***
+ !!
+ !! ** Purpose : Control the consistency between namelist options for
+ !! momentum advection formulation & scheme and set n_dynadv
+ !!----------------------------------------------------------------------
+ INTEGER :: ioptio, ios ! Local integer
+ !
+ NAMELIST/namdyn_adv/ ln_dynadv_OFF, ln_dynadv_vec, nn_dynkeg, ln_dynadv_cen2, ln_dynadv_ubs
+ !!----------------------------------------------------------------------
+ !
+ IF(lwp) THEN
+ WRITE(numout,*)
+ WRITE(numout,*) 'dyn_adv_init : choice/control of the momentum advection scheme'
+ WRITE(numout,*) '~~~~~~~~~~~~'
+ ENDIF
+ !
+ READ ( numnam_ref, namdyn_adv, IOSTAT = ios, ERR = 901)
+901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_adv in reference namelist' )
+ READ ( numnam_cfg, namdyn_adv, IOSTAT = ios, ERR = 902 )
+902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdyn_adv in configuration namelist' )
+ IF(lwm) WRITE ( numond, namdyn_adv )
+
+ IF(lwp) THEN ! Namelist print
+ WRITE(numout,*) ' Namelist namdyn_adv : chose a advection formulation & scheme for momentum'
+ WRITE(numout,*) ' linear dynamics : no momentum advection ln_dynadv_OFF = ', ln_dynadv_OFF
+ WRITE(numout,*) ' Vector form: 2nd order centered scheme ln_dynadv_vec = ', ln_dynadv_vec
+!!an45
+ WRITE(numout,*) ' with Hollingsworth scheme (=1) or not (=0,2) nn_dynkeg = ', nn_dynkeg
+!!an45
+ WRITE(numout,*) ' flux form: 2nd order centred scheme ln_dynadv_cen2 = ', ln_dynadv_cen2
+ WRITE(numout,*) ' 3rd order UBS scheme ln_dynadv_ubs = ', ln_dynadv_ubs
+ ENDIF
+
+ ioptio = 0 ! parameter control and set n_dynadv
+ IF( ln_dynadv_OFF ) THEN ; ioptio = ioptio + 1 ; n_dynadv = np_LIN_dyn ; ENDIF
+ IF( ln_dynadv_vec ) THEN ; ioptio = ioptio + 1 ; n_dynadv = np_VEC_c2 ; ENDIF
+ IF( ln_dynadv_cen2 ) THEN ; ioptio = ioptio + 1 ; n_dynadv = np_FLX_c2 ; ENDIF
+ IF( ln_dynadv_ubs ) THEN ; ioptio = ioptio + 1 ; n_dynadv = np_FLX_ubs ; ENDIF
+
+ IF( ioptio /= 1 ) CALL ctl_stop( 'choose ONE and only ONE advection scheme' )
+!!an45
+ IF( nn_dynkeg /= nkeg_C2 .AND. nn_dynkeg /= nkeg_C2_wpo .AND. nn_dynkeg /= nkeg_HW ) &
+ & CALL ctl_stop( 'KEG scheme wrong value of nn_dynkeg' )
+!!an45
+
+ IF(lwp) THEN ! Print the choice
+ WRITE(numout,*)
+ SELECT CASE( n_dynadv )
+ CASE( np_LIN_dyn ) ; WRITE(numout,*) ' ==>>> linear dynamics : no momentum advection used'
+ CASE( np_VEC_c2 ) ; WRITE(numout,*) ' ==>>> vector form : keg + zad + vor is used'
+ IF( nn_dynkeg == nkeg_C2 ) WRITE(numout,*) ' with Centered standard keg scheme'
+!!an45
+ IF( nn_dynkeg == nkeg_C2_wpo ) WRITE(numout,*) ' with Centered standard keg scheme (wet point only)'
+!!an45
+ IF( nn_dynkeg == nkeg_HW ) WRITE(numout,*) ' with Hollingsworth keg scheme'
+ CASE( np_FLX_c2 ) ; WRITE(numout,*) ' ==>>> flux form : 2nd order scheme is used'
+ CASE( np_FLX_ubs ) ; WRITE(numout,*) ' ==>>> flux form : UBS scheme is used'
+ END SELECT
+ ENDIF
+ !
+ END SUBROUTINE dyn_adv_init
+
+ !!======================================================================
+END MODULE dynadv
Index: /NEMO/branches/2020/r12377_ticket2386/src/SWE/dynatf.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/SWE/dynatf.F90 (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/src/SWE/dynatf.F90 (revision 13540)
@@ -0,0 +1,334 @@
+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
+#if defined key_agrif
+ USE agrif_oce_interp
+#endif
+
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC dyn_atf ! routine called by step.F90
+!!st22
+#if defined key_qco
+ !!----------------------------------------------------------------------
+ !! 'key_qco' EMPTY ROUTINE Quasi-Eulerian vertical coordonate
+ !!----------------------------------------------------------------------
+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 12614 2020-03-26 14:59:52Z gm $
+ !! 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, z1_2dt ! - -
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zue, zve, zwfld
+ 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_multi( 'dynatf', puu(:,:,:,Kaa), 'U', -1., pvv(:,:,:,Kaa), 'V', -1. ) !* 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( 1, 1, 1, 1, 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( ssh(:,:,Kmm), pe3u(:,:,:,Kmm), 'U' )
+ CALL dom_vvl_interpol( ssh(:,:,Kmm), pe3v(:,:,:,Kmm), 'V' )
+ DO_3D( 1, 1, 1, 1, 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( ssh(:,:,Kmm), ze3u_f, 'U' )
+ CALL dom_vvl_interpol( ssh(:,:,Kmm), ze3v_f, 'V' )
+ DO_3D( 1, 1, 1, 1, 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
+ !
+ ! 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(:,:,:) ) * z1_2dt
+ zva(:,:,:) = ( pvv(:,:,:,Kmm) - zva(:,:,:) ) * z1_2dt
+ CALL trd_dyn( zua, zva, jpdyn_atf, kt, Kmm )
+ 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
+!!st22
+ !!=========================================================================
+END MODULE dynatf
Index: /NEMO/branches/2020/r12377_ticket2386/src/SWE/dynkeg.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/SWE/dynkeg.F90 (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/src/SWE/dynkeg.F90 (revision 13540)
@@ -0,0 +1,159 @@
+MODULE dynkeg
+ !!======================================================================
+ !! *** MODULE dynkeg ***
+ !! Ocean dynamics: kinetic energy gradient trend
+ !!======================================================================
+ !! 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
+ !!----------------------------------------------------------------------
+
+ !!----------------------------------------------------------------------
+ !! dyn_keg : update the momentum trend with the horizontal tke
+ !!----------------------------------------------------------------------
+ USE oce ! ocean dynamics and tracers
+ USE dom_oce ! ocean space and time domain
+ USE trd_oce ! trends: ocean variables
+ USE trddyn ! trend manager: dynamics
+ !
+ USE in_out_manager ! I/O manager
+ USE lbclnk ! ocean lateral boundary conditions (or mpp link)
+ USE lib_mpp ! MPP library
+ USE prtctl ! Print control
+ USE timing ! Timing
+ USE bdy_oce ! ocean open boundary conditions
+
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC dyn_keg ! routine called by step module
+
+ INTEGER, PARAMETER, PUBLIC :: nkeg_C2 = 0 !: 2nd order centered scheme (standard scheme)
+!!an45
+ INTEGER, PARAMETER, PUBLIC :: nkeg_C2_wpo = 2 !: 2nd order centered scheme (wet point only : coastline at 45 degrees)
+ INTEGER, PARAMETER, PUBLIC :: nkeg_HW = 1 !: Hollingsworth et al., QJRMS, 1983
+ !
+ REAL(wp) :: r1_48 = 1._wp / 48._wp !: =1/(4*2*6)
+
+ !! * Substitutions
+# include "do_loop_substitute.h90"
+ !!----------------------------------------------------------------------
+ !! NEMO/OCE 4.0 , NEMO Consortium (2018)
+ !! $Id: dynkeg.F90 12377 2020-02-12 14:39:06Z acc $
+ !! Software governed by the CeCILL license (see ./LICENSE)
+ !!----------------------------------------------------------------------
+CONTAINS
+
+ SUBROUTINE dyn_keg( kt, kscheme, Kmm, puu, pvv, Krhs )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE dyn_keg ***
+ !!
+ !! ** Purpose : Compute the now momentum trend due to the horizontal
+ !! gradient of the horizontal kinetic energy and add it to the
+ !! general momentum trend.
+ !!
+ !! ** Method : * kscheme = nkeg_C2 : 2nd order centered scheme that
+ !! conserve kinetic energy. Compute the now horizontal kinetic energy
+ !! zhke = 1/2 [ mi-1( un^2 ) + mj-1( vn^2 ) ]
+ !! * kscheme = nkeg_HW : Hollingsworth correction following
+ !! Arakawa (2001). The now horizontal kinetic energy is given by:
+ !! zhke = 1/6 [ mi-1( 2 * un^2 + ((u(j+1)+u(j-1))/2)^2 )
+ !! + mj-1( 2 * vn^2 + ((v(i+1)+v(i-1))/2)^2 ) ]
+ !!
+ !! Take its horizontal gradient and add it to the general momentum
+ !! trend.
+ !! u(rhs) = u(rhs) - 1/e1u di[ zhke ]
+ !! v(rhs) = v(rhs) - 1/e2v dj[ zhke ]
+ !!
+ !! ** Action : - Update the (puu(:,:,:,Krhs), pvv(:,:,:,Krhs)) with the hor. ke gradient trend
+ !! - send this trends to trd_dyn (l_trddyn=T) for post-processing
+ !!
+ !! ** 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/2 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(jpi,jpj,jpk) :: zhke
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdu, ztrdv
+ !!----------------------------------------------------------------------
+ !
+ IF( ln_timing ) CALL timing_start('dyn_keg')
+ !
+ IF( kt == nit000 ) THEN
+ IF(lwp) WRITE(numout,*)
+ IF(lwp) WRITE(numout,*) 'dyn_keg : kinetic energy gradient trend, scheme number=', kscheme
+ IF(lwp) WRITE(numout,*) '~~~~~~~'
+ ENDIF
+
+ IF( l_trddyn ) THEN ! Save the input trends
+ ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) )
+ ztrdu(:,:,:) = puu(:,:,:,Krhs)
+ ztrdv(:,:,:) = pvv(:,:,:,Krhs)
+ ENDIF
+
+ zhke(:,:,jpk) = 0._wp
+
+ SELECT CASE ( kscheme ) !== Horizontal kinetic energy at T-point ==!
+!!an45 to be ADDED : que cas C2 - "wet points only" il suffit de x2 le terme quadratic a la coast (nn_dynkeg_adv = 2)
+ CASE ( nkeg_C2_wpo ) !-- 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) ) * ( 2._wp - umask(ji-1,jj,jk) * umask(ji,jj,jk) )
+ zv = ( pvv(ji ,jj-1,jk,Kmm) * pvv(ji ,jj-1,jk,Kmm) &
+ & + pvv(ji ,jj ,jk,Kmm) * pvv(ji ,jj ,jk,Kmm) ) * ( 2._wp - vmask(ji,jj-1,jk) * vmask(ji,jj,jk) )
+ zhke(ji,jj,jk) = 0.25_wp * ( zv + zu )
+ END_3D
+!!an45
+ !
+ 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, 0, 0, 0, 1, jpkm1 )
+ 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) )
+ !
+ 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) )
+ zhke(ji,jj,jk) = r1_48 * ( zv + zu )
+ END_3D
+ CALL lbc_lnk( 'dynkeg', zhke, 'T', 1. )
+ !
+ END SELECT
+ !
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ 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
+ !
+ 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 )
+ ENDIF
+ !
+ IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' keg - Ua: ', mask1=umask, &
+ & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' )
+ !
+ IF( ln_timing ) CALL timing_stop('dyn_keg')
+ !
+ END SUBROUTINE dyn_keg
+
+ !!======================================================================
+END MODULE dynkeg
Index: /NEMO/branches/2020/r12377_ticket2386/src/SWE/dynldf_lap_blp.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/SWE/dynldf_lap_blp.F90 (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/src/SWE/dynldf_lap_blp.F90 (revision 13540)
@@ -0,0 +1,241 @@
+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 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)
+
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC dyn_ldf_lap ! called by dynldf.F90
+ PUBLIC dyn_ldf_blp ! called by dynldf.F90
+!!anSYM
+ INTEGER, PUBLIC, PARAMETER :: np_dynldf_lap_rot = 1 ! div-rot laplacian
+ INTEGER, PUBLIC, PARAMETER :: np_dynldf_lap_sym = 2 ! symmetric laplacian (Griffies&Hallberg 2000)
+ INTEGER, PUBLIC, PARAMETER :: np_dynldf_lap_symN = 3 ! symmetric laplacian (cartesian)
+
+ INTEGER, PUBLIC, PARAMETER :: ln_dynldf_lap_typ = 1 ! choose type of laplacian (ideally from namelist)
+!!anSYM
+ !! * Substitutions
+# include "do_loop_substitute.h90"
+!!st21
+# include "domzgr_substitute.h90"
+ !!----------------------------------------------------------------------
+ !! NEMO/OCE 4.0 , NEMO Consortium (2018)
+ !! $Id: dynldf_lap_blp.F90 12822 2020-04-28 09:10:38Z gm $
+ !! Software governed by the CeCILL license (see ./LICENSE)
+ !!----------------------------------------------------------------------
+CONTAINS
+
+ SUBROUTINE dyn_ldf_lap( kt, Kbb, Kmm, pu, pv, pu_rhs, pv_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) )
+ !! 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
+ REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pu, pv ! before velocity [m/s]
+ REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu_rhs, pv_rhs ! velocity trend [m/s2]
+ !
+ INTEGER :: ji, jj, jk ! dummy loop indices
+ REAL(wp) :: zsign ! local scalars
+ REAL(wp) :: zua, zva ! local scalars
+ REAL(wp), DIMENSION(jpi,jpj) :: zcur, zdiv
+ REAL(wp), DIMENSION(jpi,jpj) :: zten, zshe ! tension (diagonal) and shearing (anti-diagonal) terms
+ !!----------------------------------------------------------------------
+ !
+!!anSYM TO BE ADDED : reading of laplacian operator (ln_dynldf_lap_typ -> to be written nn_) shall be added in dyn_ldf_init
+!! as the writing
+!! and an integer as np_dynldf_lap for instance taken as argument by dyn_ldf_lap call in dyn_ldf
+ IF( kt == nit000 .AND. lwp ) THEN
+ WRITE(numout,*)
+ WRITE(numout,*) 'dyn_ldf : iso-level harmonic (laplacian) operator, pass=', kpass
+ WRITE(numout,*) '~~~~~~~ '
+ WRITE(numout,*) ' ln_dynldf_lap_typ = ', ln_dynldf_lap_typ
+ SELECT CASE( ln_dynldf_lap_typ ) ! print the choice of operator
+ CASE( np_dynldf_lap_rot ) ; WRITE(numout,*) ' ==>>> div-rot laplacian'
+ CASE( np_dynldf_lap_sym ) ; WRITE(numout,*) ' ==>>> symmetric laplacian (covariant form)'
+ CASE( np_dynldf_lap_symN) ; WRITE(numout,*) ' ==>>> symmetric laplacian (simple form)'
+ END SELECT
+ 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( ln_dynldf_lap_typ )
+ !
+ CASE ( np_dynldf_lap_rot ) !== Vorticity-Divergence form ==!
+ !
+ DO jk = 1, jpkm1 ! Horizontal slab
+ !
+ DO_2D( 0, 1, 0, 1 )
+ ! ! ahm * e3 * curl (computed from 1 to jpim1/jpjm1)
+!!gm open question here : e3f at before or now ? probably now...
+!!gm note that ahmf has already been multiplied by fmask
+ zcur(ji-1,jj-1) = &
+ & ahmf(ji-1,jj-1,jk) * e3f(ji-1,jj-1,jk) * r1_e1e2f(ji-1,jj-1) &
+ & * ( 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 (computed from 2 to jpi/jpj)
+!!gm note that ahmt has already been multiplied by tmask
+ zdiv(ji,jj) = ahmt(ji,jj,jk) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kbb) &
+ & * ( 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( 0, 0, 0, 0 )
+ pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zsign * ( &
+ & - ( 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 * ( &
+ & ( 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
+ !
+ CASE ( np_dynldf_lap_sym ) !== Symmetric form ==! (Griffies&Hallberg 2000)
+ !
+ DO jk = 1, jpkm1 ! Horizontal slab
+ !
+ DO_2D( 0, 1, 0, 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(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( 0, 0, 0, 0 )
+ 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 ! End of slab
+ !
+ CASE ( np_dynldf_lap_symN ) !== Symmetric form ==! (naive way)
+ !
+ DO jk = 1, jpkm1 ! Horizontal slab
+ !
+ DO_2D( 0, 1, 0, 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) &
+ & * ( r1_e2f(ji-1,jj-1) * ( pu(ji-1,jj ,jk) - pu(ji-1,jj-1,jk) ) &
+ & + r1_e1f(ji-1,jj-1) * ( pv(ji ,jj-1,jk) - pv(ji-1,jj-1,jk) ) )
+ ! ! tension stress component (T-point) NB : ahmt has already been multiplied by tmask
+ zten(ji,jj) = ahmt(ji,jj,jk) &
+ & * ( r1_e1t(ji,jj) * ( pu(ji,jj,jk) - pu(ji-1,jj ,jk) ) &
+ & - r1_e2t(ji,jj) * ( pv(ji,jj,jk) - pv(ji ,jj-1,jk) ) )
+ END_2D
+ !
+ DO_2D( 0, 0, 0, 0 )
+ 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 ) * e3t(ji+1,jj ,jk,Kmm) &
+ & - zten(ji ,jj ) * e2t(ji ,jj ) * e3t(ji ,jj ,jk,Kmm) &
+ & + zshe(ji ,jj ) * e1f(ji ,jj ) * e3f(ji ,jj ,jk) &
+ & - zshe(ji ,jj-1) * e1f(ji ,jj-1) * e3f(ji ,jj-1,jk) )
+ !
+ 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 ) * e3f(ji ,jj ,jk) &
+ & - zshe(ji-1,jj ) * e2f(ji-1,jj ) * e3f(ji-1,jj ,jk) &
+ & - zten(ji ,jj+1) * e1t(ji ,jj+1) * e3t(ji ,jj+1,jk,Kmm) &
+ & + zten(ji ,jj ) * e1t(ji ,jj ) * e3t(ji ,jj ,jk,Kmm) )
+ !
+ END_2D
+ !
+ END DO ! End of slab
+ !
+ CASE DEFAULT ! error
+ CALL ctl_stop('STOP','dyn_ldf_lap: wrong value for ln_dynldf_lap_typ' )
+ END SELECT
+ !
+ !
+ END SUBROUTINE dyn_ldf_lap
+
+
+ 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(jpi,jpj,jpk) :: zulap, zvlap ! laplacian at u- and v-point
+ !!----------------------------------------------------------------------
+ !
+ IF( kt == nit000 ) THEN
+ IF(lwp) WRITE(numout,*)
+ IF(lwp) WRITE(numout,*) 'dyn_ldf_blp : bilaplacian operator momentum '
+ IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~'
+ 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)
+ !
+ CALL lbc_lnk_multi( 'dynldf_lap_blp', zulap, 'U', -1., zvlap, 'V', -1. ) ! 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))
+ !
+ END SUBROUTINE dyn_ldf_blp
+
+ !!======================================================================
+END MODULE dynldf_lap_blp
Index: /NEMO/branches/2020/r12377_ticket2386/src/SWE/dynvor.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/SWE/dynvor.F90 (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/src/SWE/dynvor.F90 (revision 13540)
@@ -0,0 +1,880 @@
+MODULE dynvor
+ !!======================================================================
+ !! *** MODULE dynvor ***
+ !! Ocean dynamics: Update the momentum trend with the relative and
+ !! planetary vorticity trends
+ !!======================================================================
+ !! History : OPA ! 1989-12 (P. Andrich) vor_ens: Original code
+ !! 5.0 ! 1991-11 (G. Madec) vor_ene, vor_mix: Original code
+ !! 6.0 ! 1996-01 (G. Madec) s-coord, suppress work arrays
+ !! NEMO 0.5 ! 2002-08 (G. Madec) F90: Free form and module
+ !! 1.0 ! 2004-02 (G. Madec) vor_een: Original code
+ !! - ! 2003-08 (G. Madec) add vor_ctl
+ !! - ! 2005-11 (G. Madec) add dyn_vor (new step architecture)
+ !! 2.0 ! 2006-11 (G. Madec) flux form advection: add metric term
+ !! 3.2 ! 2009-04 (R. Benshila) vvl: correction of een scheme
+ !! 3.3 ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase
+ !! 3.7 ! 2014-04 (G. Madec) trend simplification: suppress jpdyn_trd_dat vorticity
+ !! - ! 2014-06 (G. Madec) suppression of velocity curl from in-core memory
+ !! - ! 2016-12 (G. Madec, E. Clementi) add Stokes-Coriolis trends (ln_stcor=T)
+ !! 4.0 ! 2017-07 (G. Madec) linear dynamics + trends diag. with Stokes-Coriolis
+ !! - ! 2018-03 (G. Madec) add two new schemes (ln_dynvor_enT and ln_dynvor_eet)
+ !! - ! 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
+ !!----------------------------------------------------------------------
+
+ !!----------------------------------------------------------------------
+ !! dyn_vor : Update the momentum trend with the vorticity trend
+ !! vor_ens : enstrophy conserving scheme (ln_dynvor_ens=T)
+ !! vor_ene : energy conserving scheme (ln_dynvor_ene=T)
+ !! vor_een : energy and enstrophy conserving (ln_dynvor_een=T)
+ !! dyn_vor_init : set and control of the different vorticity option
+ !!----------------------------------------------------------------------
+ USE oce ! ocean dynamics and tracers
+ USE dom_oce ! ocean space and time domain
+ USE dommsk ! ocean mask
+ USE dynadv ! momentum advection
+ USE trd_oce ! trends: ocean variables
+ USE trddyn ! trend manager: dynamics
+ USE sbcwave ! Surface Waves (add Stokes-Coriolis force)
+ USE sbc_oce , ONLY : ln_stcor ! use Stoke-Coriolis force
+ !
+ USE lbclnk ! ocean lateral boundary conditions (or mpp link)
+ USE prtctl ! Print control
+ USE in_out_manager ! I/O manager
+ USE lib_mpp ! MPP library
+ USE timing ! Timing
+
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC dyn_vor ! routine called by step.F90
+ PUBLIC dyn_vor_init ! routine called by nemogcm.F90
+
+ ! !!* Namelist namdyn_vor: vorticity term
+ LOGICAL, PUBLIC :: ln_dynvor_ens !: enstrophy conserving scheme (ENS)
+ LOGICAL, PUBLIC :: ln_dynvor_ene !: f-point energy conserving scheme (ENE)
+ LOGICAL, PUBLIC :: ln_dynvor_enT !: t-point energy conserving scheme (ENT)
+ LOGICAL, PUBLIC :: ln_dynvor_eeT !: t-point energy conserving scheme (EET)
+ LOGICAL, PUBLIC :: ln_dynvor_een !: energy & enstrophy conserving scheme (EEN)
+ INTEGER, PUBLIC :: nn_een_e3f !: e3f=masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1)
+ LOGICAL, PUBLIC :: ln_dynvor_mix !: mixed scheme (MIX)
+ LOGICAL, PUBLIC :: ln_dynvor_msk !: vorticity multiplied by fmask (=T) or not (=F) (all vorticity schemes)
+
+ INTEGER, PUBLIC :: nvor_scheme !: choice of the type of advection scheme
+ ! ! associated indices:
+ INTEGER, PUBLIC, PARAMETER :: np_ENS = 0 ! ENS scheme
+ INTEGER, PUBLIC, PARAMETER :: np_ENE = 1 ! ENE scheme
+ INTEGER, PUBLIC, PARAMETER :: np_ENT = 2 ! ENT scheme (t-point vorticity)
+ INTEGER, PUBLIC, PARAMETER :: np_EET = 3 ! EET scheme (EEN using e3t)
+ INTEGER, PUBLIC, PARAMETER :: np_EEN = 4 ! EEN scheme
+ INTEGER, PUBLIC, PARAMETER :: np_MIX = 5 ! MIX scheme
+
+ INTEGER :: ncor, nrvm, ntot ! choice of calculated vorticity
+ ! ! associated indices:
+ INTEGER, PUBLIC, PARAMETER :: np_COR = 1 ! Coriolis (planetary)
+ INTEGER, PUBLIC, PARAMETER :: np_RVO = 2 ! relative vorticity
+ INTEGER, PUBLIC, PARAMETER :: np_MET = 3 ! metric term
+ INTEGER, PUBLIC, PARAMETER :: np_CRV = 4 ! relative + planetary (total vorticity)
+ INTEGER, PUBLIC, PARAMETER :: np_CME = 5 ! Coriolis + metric term
+
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: di_e2u_2 ! = di(e2u)/2 used in T-point metric term calculation
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: dj_e1v_2 ! = dj(e1v)/2 - - - -
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: di_e2v_2e1e2f ! = di(e2u)/(2*e1e2f) used in F-point metric term calculation
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: dj_e1u_2e1e2f ! = dj(e1v)/(2*e1e2f) - - - -
+
+ REAL(wp) :: r1_4 = 0.250_wp ! =1/4
+ REAL(wp) :: r1_8 = 0.125_wp ! =1/8
+ REAL(wp) :: r1_12 = 1._wp / 12._wp ! 1/12
+
+ !! * Substitutions
+# include "do_loop_substitute.h90"
+!!st23
+# include "domzgr_substitute.h90"
+ !!----------------------------------------------------------------------
+ !! NEMO/OCE 4.0 , NEMO Consortium (2018)
+ !! $Id: dynvor.F90 12667 2020-04-03 14:22:29Z gm $
+ !! Software governed by the CeCILL license (see ./LICENSE)
+ !!----------------------------------------------------------------------
+CONTAINS
+
+ SUBROUTINE dyn_vor( kt, Kmm, puu, pvv, Krhs )
+ !!----------------------------------------------------------------------
+ !!
+ !! ** Purpose : compute the lateral ocean tracer physics.
+ !!
+ !! ** Action : - Update (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) with the now vorticity term trend
+ !! - save the trends in (ztrdu,ztrdv) in 2 parts (relative
+ !! and planetary vorticity trends) and send them to trd_dyn
+ !! for futher diagnostics (l_trddyn=T)
+ !!----------------------------------------------------------------------
+ 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 velocity field and RHS of momentum equation
+ !
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdu, ztrdv
+ !!----------------------------------------------------------------------
+ !
+ IF( ln_timing ) CALL timing_start('dyn_vor')
+ !
+ IF( l_trddyn ) THEN !== trend diagnostics case : split the added trend in two parts ==!
+ !
+ ALLOCATE( ztrdu(jpi,jpj,jpk), ztrdv(jpi,jpj,jpk) )
+ !
+ ztrdu(:,:,:) = puu(:,:,:,Krhs) !* planetary vorticity trend (including Stokes-Coriolis force)
+ ztrdv(:,:,:) = pvv(:,:,:,Krhs)
+ SELECT CASE( nvor_scheme )
+ CASE( np_ENS ) ; CALL vor_ens( kt, Kmm, ncor, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! enstrophy conserving scheme
+ IF( ln_stcor ) CALL vor_ens( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend
+ CASE( np_ENE, np_MIX ) ; CALL vor_ene( kt, Kmm, ncor, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! energy conserving scheme
+ IF( ln_stcor ) CALL vor_ene( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend
+ CASE( np_ENT ) ; CALL vor_enT( kt, Kmm, ncor, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! energy conserving scheme (T-pts)
+ IF( ln_stcor ) CALL vor_enT( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend
+ CASE( np_EET ) ; CALL vor_eeT( kt, Kmm, ncor, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! energy conserving scheme (een with e3t)
+ IF( ln_stcor ) CALL vor_eeT( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend
+ CASE( np_EEN ) ; CALL vor_een( kt, Kmm, ncor, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! energy & enstrophy scheme
+ IF( ln_stcor ) CALL vor_een( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend
+ END SELECT
+ ztrdu(:,:,:) = puu(:,:,:,Krhs) - ztrdu(:,:,:)
+ ztrdv(:,:,:) = pvv(:,:,:,Krhs) - ztrdv(:,:,:)
+ CALL trd_dyn( ztrdu, ztrdv, jpdyn_pvo, kt, Kmm )
+ !
+ IF( n_dynadv /= np_LIN_dyn ) THEN !* relative vorticity or metric trend (only in non-linear case)
+ ztrdu(:,:,:) = puu(:,:,:,Krhs)
+ ztrdv(:,:,:) = pvv(:,:,:,Krhs)
+ SELECT CASE( nvor_scheme )
+ CASE( np_ENT ) ; CALL vor_enT( kt, Kmm, nrvm, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! energy conserving scheme (T-pts)
+ CASE( np_EET ) ; CALL vor_eeT( kt, Kmm, nrvm, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! energy conserving scheme (een with e3t)
+ CASE( np_ENE ) ; CALL vor_ene( kt, Kmm, nrvm, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! energy conserving scheme
+ CASE( np_ENS, np_MIX ) ; CALL vor_ens( kt, Kmm, nrvm, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! enstrophy conserving scheme
+ CASE( np_EEN ) ; CALL vor_een( kt, Kmm, nrvm, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! energy & enstrophy scheme
+ END SELECT
+ ztrdu(:,:,:) = puu(:,:,:,Krhs) - ztrdu(:,:,:)
+ ztrdv(:,:,:) = pvv(:,:,:,Krhs) - ztrdv(:,:,:)
+ CALL trd_dyn( ztrdu, ztrdv, jpdyn_rvo, kt, Kmm )
+ ENDIF
+ !
+ DEALLOCATE( ztrdu, ztrdv )
+ !
+ ELSE !== total vorticity trend added to the general trend ==!
+ !
+ SELECT CASE ( nvor_scheme ) !== vorticity trend added to the general trend ==!
+ CASE( np_ENT ) !* energy conserving scheme (T-pts)
+ CALL vor_enT( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! total vorticity trend
+ IF( ln_stcor ) CALL vor_enT( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend
+ 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 ) CALL vor_eeT( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend
+ 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 ) CALL vor_ene( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend
+ CASE( np_ENS ) !* enstrophy conserving scheme
+ CALL vor_ens( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! total vorticity trend
+ IF( ln_stcor ) CALL vor_ens( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend
+ CASE( np_MIX ) !* mixed ene-ens scheme
+ CALL vor_ens( kt, Kmm, nrvm, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! relative vorticity or metric trend (ens)
+ CALL vor_ene( kt, Kmm, ncor, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! planetary vorticity trend (ene)
+ IF( ln_stcor ) CALL vor_ene( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend
+ 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 ) CALL vor_een( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend
+ END SELECT
+ !
+ ENDIF
+ !
+ ! ! print sum trends (used for debugging)
+ IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' vor - Ua: ', mask1=umask, &
+ & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' )
+ !
+ IF( ln_timing ) CALL timing_stop('dyn_vor')
+ !
+ END SUBROUTINE dyn_vor
+
+
+ SUBROUTINE vor_enT( kt, Kmm, kvor, pu, pv, pu_rhs, pv_rhs )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE vor_enT ***
+ !!
+ !! ** Purpose : Compute the now total vorticity trend and add it to
+ !! the general trend of the momentum equation.
+ !!
+ !! ** Method : Trend evaluated using now fields (centered in time)
+ !! and t-point evaluation of vorticity (planetary and relative).
+ !! conserves the horizontal kinetic energy.
+ !! The general trend of momentum is increased due to the vorticity
+ !! term which is given by:
+ !! voru = 1/bu mj[ ( mi(mj(bf*rvor))+bt*f_t)/e3t mj[vn] ]
+ !! vorv = 1/bv mi[ ( mi(mj(bf*rvor))+bt*f_t)/e3f mj[un] ]
+ !! where rvor is the relative vorticity at f-point
+ !!
+ !! ** Action : - Update (pu_rhs,pv_rhs) with the now vorticity term trend
+ !!----------------------------------------------------------------------
+ INTEGER , INTENT(in ) :: kt ! ocean time-step index
+ INTEGER , INTENT(in ) :: Kmm ! ocean time level index
+ INTEGER , INTENT(in ) :: kvor ! total, planetary, relative, or metric
+ REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu, pv ! now velocities
+ REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu_rhs, pv_rhs ! total v-trend
+ !
+ INTEGER :: ji, jj, jk ! dummy loop indices
+ REAL(wp) :: zx1, zy1, zx2, zy2 ! local scalars
+ REAL(wp), DIMENSION(jpi,jpj) :: zwx, zwy, zwt ! 2D workspace
+ REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwz ! 3D workspace
+ !!----------------------------------------------------------------------
+ !
+ IF( kt == nit000 ) THEN
+ IF(lwp) WRITE(numout,*)
+ IF(lwp) WRITE(numout,*) 'dyn:vor_enT : vorticity term: t-point energy conserving scheme'
+ IF(lwp) WRITE(numout,*) '~~~~~~~~~~~'
+ ENDIF
+ !
+ !
+ SELECT CASE( kvor ) !== relative vorticity considered ==!
+ CASE ( np_RVO , np_CRV ) !* relative vorticity at f-point is used
+ DO jk = 1, jpkm1 ! Horizontal slab
+ DO_2D( 1, 0, 1, 0 )
+ 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)
+ END_2D
+ IF( ln_dynvor_msk ) THEN ! mask relative vorticity
+ DO_2D( 1, 0, 1, 0 )
+ zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk)
+ END_2D
+ ENDIF
+ END DO
+ CALL lbc_lnk( 'dynvor', zwz, 'F', 1. )
+ !
+ END SELECT
+
+ ! ! ===============
+ DO jk = 1, jpkm1 ! Horizontal slab
+ ! ! ===============
+ !
+ SELECT CASE( kvor ) !== volume weighted vorticity considered ==!
+ !
+ CASE ( np_COR ) !* Coriolis (planetary vorticity)
+ zwt(:,:) = ff_t(:,:) * e1e2t(:,:)*e3t(:,:,jk,Kmm)
+ 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) ) &
+ & * e1e2t(ji,jj)*e3t(ji,jj,jk,Kmm)
+ END_2D
+ CASE ( np_MET ) !* metric term
+ DO_2D( 0, 1, 0, 1 )
+ zwt(ji,jj) = ( ( pv(ji,jj,jk) + pv(ji,jj-1,jk) ) * di_e2u_2(ji,jj) &
+ & - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj) ) &
+ & * e3t(ji,jj,jk,Kmm)
+ 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) ) ) &
+ & * e1e2t(ji,jj)*e3t(ji,jj,jk,Kmm)
+ END_2D
+ CASE ( np_CME ) !* Coriolis + metric
+ DO_2D( 0, 1, 0, 1 )
+ zwt(ji,jj) = ( ff_t(ji,jj) * e1e2t(ji,jj) &
+ & + ( pv(ji,jj,jk) + pv(ji,jj-1,jk) ) * di_e2u_2(ji,jj) &
+ & - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj) ) &
+ & * e3t(ji,jj,jk,Kmm)
+ END_2D
+ CASE DEFAULT ! error
+ CALL ctl_stop('STOP','dyn_vor: wrong value for kvor' )
+ END SELECT
+ !
+ ! !== compute and add the vorticity term trend =!
+ DO_2D( 0, 0, 0, 0 )
+ pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + r1_4 * r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm) &
+ & * ( zwt(ji+1,jj) * ( pv(ji+1,jj,jk) + pv(ji+1,jj-1,jk) ) &
+ & + zwt(ji ,jj) * ( pv(ji ,jj,jk) + pv(ji ,jj-1,jk) ) )
+ !
+ pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) - r1_4 * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm) &
+ & * ( zwt(ji,jj+1) * ( pu(ji,jj+1,jk) + pu(ji-1,jj+1,jk) ) &
+ & + zwt(ji,jj ) * ( pu(ji,jj ,jk) + pu(ji-1,jj ,jk) ) )
+ END_2D
+ ! ! ===============
+ END DO ! End of slab
+ ! ! ===============
+ END SUBROUTINE vor_enT
+
+
+ SUBROUTINE vor_ene( kt, Kmm, kvor, pu, pv, pu_rhs, pv_rhs )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE vor_ene ***
+ !!
+ !! ** Purpose : Compute the now total vorticity trend and add it to
+ !! the general trend of the momentum equation.
+ !!
+ !! ** Method : Trend evaluated using now fields (centered in time)
+ !! and the Sadourny (1975) flux form formulation : conserves the
+ !! horizontal kinetic energy.
+ !! The general trend of momentum is increased due to the vorticity
+ !! term which is given by:
+ !! voru = 1/e1u mj-1[ (rvor+f)/e3f mi(e1v*e3v pvv(:,:,:,Kmm)) ]
+ !! vorv = 1/e2v mi-1[ (rvor+f)/e3f mj(e2u*e3u puu(:,:,:,Kmm)) ]
+ !! where rvor is the relative vorticity
+ !!
+ !! ** Action : - Update (pu_rhs,pv_rhs) with the now vorticity term trend
+ !!
+ !! References : Sadourny, r., 1975, j. atmos. sciences, 32, 680-689.
+ !!----------------------------------------------------------------------
+ INTEGER , INTENT(in ) :: kt ! ocean time-step index
+ INTEGER , INTENT(in ) :: Kmm ! ocean time level index
+ INTEGER , INTENT(in ) :: kvor ! total, planetary, relative, or metric
+ REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu, pv ! now velocities
+ REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu_rhs, pv_rhs ! total v-trend
+ !
+ INTEGER :: ji, jj, jk ! dummy loop indices
+ REAL(wp) :: zx1, zy1, zx2, zy2 ! local scalars
+ REAL(wp), DIMENSION(jpi,jpj) :: zwx, zwy, zwz ! 2D workspace
+ !!----------------------------------------------------------------------
+ !
+ IF( kt == nit000 ) THEN
+ IF(lwp) WRITE(numout,*)
+ IF(lwp) WRITE(numout,*) 'dyn:vor_ene : vorticity term: energy conserving scheme'
+ IF(lwp) WRITE(numout,*) '~~~~~~~~~~~'
+ ENDIF
+ !
+ ! ! ===============
+ DO jk = 1, jpkm1 ! Horizontal slab
+ ! ! ===============
+ !
+ SELECT CASE( kvor ) !== vorticity considered ==!
+ CASE ( np_COR ) !* Coriolis (planetary vorticity)
+ zwz(:,:) = ff_f(:,:)
+ 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)
+ END_2D
+ IF( ln_dynvor_msk ) THEN ! mask the relative vorticity
+ DO_2D( 1, 0, 1, 0 )
+ zwz(ji,jj) = zwz(ji,jj) * fmask(ji,jj,jk)
+ END_2D
+ ENDIF
+ CASE ( np_MET ) !* metric term
+ DO_2D( 1, 0, 1, 0 )
+ 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( 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)
+ END_2D
+ IF( ln_dynvor_msk ) THEN ! mask the relative vorticity (NOT the Coriolis term)
+ DO_2D( 1, 0, 1, 0 )
+ 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( 1, 0, 1, 0 )
+ 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
+ !
+ ! !== horizontal fluxes and potential vorticity ==!
+ zwx(:,:) = e2u(:,:) * e3u(:,:,jk,Kmm) * pu(:,:,jk)
+ zwy(:,:) = e1v(:,:) * e3v(:,:,jk,Kmm) * pv(:,:,jk)
+ zwz(:,:) = zwz(:,:) / e3f(:,:,jk)
+ !
+ ! !== compute and add the vorticity term trend =!
+ DO_2D( 0, 0, 0, 0 )
+ zy1 = zwy(ji,jj-1) + zwy(ji+1,jj-1)
+ zy2 = zwy(ji,jj ) + zwy(ji+1,jj )
+ zx1 = zwx(ji-1,jj) + zwx(ji-1,jj+1)
+ zx2 = zwx(ji ,jj) + zwx(ji ,jj+1)
+ pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + r1_4 * r1_e1u(ji,jj) * ( zwz(ji ,jj-1) * zy1 + zwz(ji,jj) * zy2 )
+ pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) - r1_4 * r1_e2v(ji,jj) * ( zwz(ji-1,jj ) * zx1 + zwz(ji,jj) * zx2 )
+ END_2D
+ ! ! ===============
+ END DO ! End of slab
+ ! ! ===============
+ END SUBROUTINE vor_ene
+
+
+ SUBROUTINE vor_ens( kt, Kmm, kvor, pu, pv, pu_rhs, pv_rhs )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE vor_ens ***
+ !!
+ !! ** Purpose : Compute the now total vorticity trend and add it to
+ !! the general trend of the momentum equation.
+ !!
+ !! ** Method : Trend evaluated using now fields (centered in time)
+ !! and the Sadourny (1975) flux FORM formulation : conserves the
+ !! potential enstrophy of a horizontally non-divergent flow. the
+ !! trend of the vorticity term is given by:
+ !! voru = 1/e1u mj-1[ (rvor+f)/e3f ] mj-1[ mi(e1v*e3v pvv(:,:,:,Kmm)) ]
+ !! vorv = 1/e2v mi-1[ (rvor+f)/e3f ] mi-1[ mj(e2u*e3u puu(:,:,:,Kmm)) ]
+ !! Add this trend to the general momentum trend:
+ !! (u(rhs),v(Krhs)) = (u(rhs),v(Krhs)) + ( voru , vorv )
+ !!
+ !! ** Action : - Update (pu_rhs,pv_rhs)) arrays with the now vorticity term trend
+ !!
+ !! References : Sadourny, r., 1975, j. atmos. sciences, 32, 680-689.
+ !!----------------------------------------------------------------------
+ INTEGER , INTENT(in ) :: kt ! ocean time-step index
+ INTEGER , INTENT(in ) :: Kmm ! ocean time level index
+ INTEGER , INTENT(in ) :: kvor ! total, planetary, relative, or metric
+ REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu, pv ! now velocities
+ REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu_rhs, pv_rhs ! total v-trend
+ !
+ INTEGER :: ji, jj, jk ! dummy loop indices
+ REAL(wp) :: zuav, zvau ! local scalars
+ REAL(wp), DIMENSION(jpi,jpj) :: zwx, zwy, zwz, zww ! 2D workspace
+ !!----------------------------------------------------------------------
+ !
+ IF( kt == nit000 ) THEN
+ IF(lwp) WRITE(numout,*)
+ IF(lwp) WRITE(numout,*) 'dyn:vor_ens : vorticity term: enstrophy conserving scheme'
+ IF(lwp) WRITE(numout,*) '~~~~~~~~~~~'
+ ENDIF
+ ! ! ===============
+ DO jk = 1, jpkm1 ! Horizontal slab
+ ! ! ===============
+ !
+ SELECT CASE( kvor ) !== vorticity considered ==!
+ CASE ( np_COR ) !* Coriolis (planetary vorticity)
+ zwz(:,:) = ff_f(:,:)
+ 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)
+ END_2D
+ IF( ln_dynvor_msk ) THEN ! mask the relative vorticity
+ DO_2D( 1, 0, 1, 0 )
+ zwz(ji,jj) = ff_f(ji,jj) * fmask(ji,jj,jk)
+ END_2D
+ ENDIF
+ CASE ( np_MET ) !* metric term
+ DO_2D( 1, 0, 1, 0 )
+ 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( 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)
+ END_2D
+ IF( ln_dynvor_msk ) THEN ! mask the relative vorticity (NOT the Coriolis term)
+ DO_2D( 1, 0, 1, 0 )
+ 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( 1, 0, 1, 0 )
+ 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
+ !
+ !
+ ! !== horizontal fluxes and potential vorticity ==!
+ zwx(:,:) = e2u(:,:) * e3u(:,:,jk,Kmm) * pu(:,:,jk)
+ zwy(:,:) = e1v(:,:) * e3v(:,:,jk,Kmm) * pv(:,:,jk)
+ zwz(:,:) = zwz(:,:) / e3f(:,:,jk)
+ !
+ ! !== 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) )
+ 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
+ ! ! ===============
+ END DO ! End of slab
+ ! ! ===============
+ END SUBROUTINE vor_ens
+
+
+ SUBROUTINE vor_een( kt, Kmm, kvor, pu, pv, pu_rhs, pv_rhs )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE vor_een ***
+ !!
+ !! ** Purpose : Compute the now total vorticity trend and add it to
+ !! the general trend of the momentum equation.
+ !!
+ !! ** Method : Trend evaluated using now fields (centered in time)
+ !! and the Arakawa and Lamb (1980) flux form formulation : conserves
+ !! both the horizontal kinetic energy and the potential enstrophy
+ !! when horizontal divergence is zero (see the NEMO documentation)
+ !! Add this trend to the general momentum trend (pu_rhs,pv_rhs).
+ !!
+ !! ** Action : - Update (pu_rhs,pv_rhs) with the now vorticity term trend
+ !!
+ !! References : Arakawa and Lamb 1980, Mon. Wea. Rev., 109, 18-36
+ !!----------------------------------------------------------------------
+ INTEGER , INTENT(in ) :: kt ! ocean time-step index
+ INTEGER , INTENT(in ) :: Kmm ! ocean time level index
+ INTEGER , INTENT(in ) :: kvor ! total, planetary, relative, or metric
+ REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu, pv ! now velocities
+ REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu_rhs, pv_rhs ! total v-trend
+ !
+ INTEGER :: ji, jj, jk ! dummy loop indices
+ INTEGER :: ierr ! local integer
+ REAL(wp) :: zua, zva ! local scalars
+ REAL(wp) :: zmsk, ze3f ! local scalars
+ REAL(wp), DIMENSION(jpi,jpj) :: zwx , zwy , z1_e3f
+ REAL(wp), DIMENSION(jpi,jpj) :: ztnw, ztne, ztsw, ztse
+ REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwz
+ !!----------------------------------------------------------------------
+ !
+ IF( kt == nit000 ) THEN
+ IF(lwp) WRITE(numout,*)
+ IF(lwp) WRITE(numout,*) 'dyn:vor_een : vorticity term: energy and enstrophy conserving scheme'
+ IF(lwp) WRITE(numout,*) '~~~~~~~~~~~'
+ ENDIF
+ !
+ ! ! ===============
+ DO jk = 1, jpkm1 ! Horizontal slab
+ ! ! ===============
+ !
+ SELECT CASE( nn_een_e3f ) ! == reciprocal of e3 at F-point
+ 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) )
+ 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( 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) )
+ IF( ze3f /= 0._wp ) THEN ; z1_e3f(ji,jj) = zmsk / ze3f
+ ELSE ; z1_e3f(ji,jj) = 0._wp
+ ENDIF
+ END_2D
+ END SELECT
+ !
+ SELECT CASE( kvor ) !== vorticity considered ==!
+ CASE ( np_COR ) !* Coriolis (planetary vorticity)
+ DO_2D( 1, 0, 1, 0 )
+ zwz(ji,jj,jk) = ff_f(ji,jj) * z1_e3f(ji,jj)
+ END_2D
+ CASE ( np_RVO ) !* relative vorticity
+ DO_2D( 1, 0, 1, 0 )
+ 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)
+ END_2D
+ CASE ( np_MET ) !* metric term
+ DO_2D( 1, 0, 1, 0 )
+ 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)
+ END_2D
+ CASE ( np_CRV ) !* Coriolis + relative vorticity
+ DO_2D( 1, 0, 1, 0 )
+ 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) ) * z1_e3f(ji,jj)
+ END_2D
+ CASE ( np_CME ) !* Coriolis + metric
+ DO_2D( 1, 0, 1, 0 )
+ 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)
+ END_2D
+ CASE DEFAULT ! error
+ CALL ctl_stop('STOP','dyn_vor: wrong value for kvor' )
+ END SELECT
+ !
+ IF( ln_dynvor_msk ) THEN !== mask/unmask vorticity ==!
+ DO_2D( 1, 0, 1, 0 )
+ zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk)
+ END_2D
+ ENDIF
+ END DO ! End of slab
+ !
+ CALL lbc_lnk( 'dynvor', zwz, 'F', 1. )
+
+ DO jk = 1, jpkm1 ! Horizontal slab
+ !
+ ! !== horizontal fluxes ==!
+ zwx(:,:) = e2u(:,:) * e3u(:,:,jk,Kmm) * pu(:,:,jk)
+ zwy(:,:) = e1v(:,:) * e3v(:,:,jk,Kmm) * pv(:,:,jk)
+
+ ! !== compute and add the vorticity term trend =!
+ jj = 2
+ ztne(1,:) = 0 ; ztnw(1,:) = 0 ; ztse(1,:) = 0 ; ztsw(1,:) = 0
+ DO ji = 2, jpi ! split in 2 parts due to vector opt.
+ 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)
+ END DO
+ DO jj = 3, jpj
+ DO ji = 2, jpi ! vector opt. ok because we start at jj = 3
+ 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)
+ END DO
+ END DO
+ 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 ) )
+ 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 ! End of slab
+ ! ! ===============
+ END SUBROUTINE vor_een
+
+
+
+ SUBROUTINE vor_eeT( kt, Kmm, kvor, pu, pv, pu_rhs, pv_rhs )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE vor_eeT ***
+ !!
+ !! ** Purpose : Compute the now total vorticity trend and add it to
+ !! the general trend of the momentum equation.
+ !!
+ !! ** Method : Trend evaluated using now fields (centered in time)
+ !! and the Arakawa and Lamb (1980) vector form formulation using
+ !! a modified version of Arakawa and Lamb (1980) scheme (see vor_een).
+ !! The change consists in
+ !! Add this trend to the general momentum trend (pu_rhs,pv_rhs).
+ !!
+ !! ** Action : - Update (pu_rhs,pv_rhs) with the now vorticity term trend
+ !!
+ !! References : Arakawa and Lamb 1980, Mon. Wea. Rev., 109, 18-36
+ !!----------------------------------------------------------------------
+ INTEGER , INTENT(in ) :: kt ! ocean time-step index
+ INTEGER , INTENT(in ) :: Kmm ! ocean time level index
+ INTEGER , INTENT(in ) :: kvor ! total, planetary, relative, or metric
+ REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu, pv ! now velocities
+ REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu_rhs, pv_rhs ! total v-trend
+ !
+ INTEGER :: ji, jj, jk ! dummy loop indices
+ INTEGER :: ierr ! local integer
+ REAL(wp) :: zua, zva ! local scalars
+ REAL(wp) :: zmsk, z1_e3t ! local scalars
+ REAL(wp), DIMENSION(jpi,jpj) :: zwx , zwy
+ REAL(wp), DIMENSION(jpi,jpj) :: ztnw, ztne, ztsw, ztse
+ REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwz
+ !!----------------------------------------------------------------------
+ !
+ IF( kt == nit000 ) THEN
+ IF(lwp) WRITE(numout,*)
+ IF(lwp) WRITE(numout,*) 'dyn:vor_een : vorticity term: energy and enstrophy conserving scheme'
+ IF(lwp) WRITE(numout,*) '~~~~~~~~~~~'
+ ENDIF
+ !
+ ! ! ===============
+ DO jk = 1, jpkm1 ! Horizontal slab
+ ! ! ===============
+ !
+ !
+ SELECT CASE( kvor ) !== vorticity considered ==!
+ CASE ( np_COR ) !* Coriolis (planetary vorticity)
+ DO_2D( 1, 0, 1, 0 )
+ zwz(ji,jj,jk) = ff_f(ji,jj)
+ END_2D
+ CASE ( np_RVO ) !* relative vorticity
+ DO_2D( 1, 0, 1, 0 )
+ 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)
+ END_2D
+ CASE ( np_MET ) !* metric term
+ DO_2D( 1, 0, 1, 0 )
+ 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)
+ END_2D
+ CASE ( np_CRV ) !* Coriolis + relative vorticity
+ DO_2D( 1, 0, 1, 0 )
+ 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) )
+ END_2D
+ CASE ( np_CME ) !* Coriolis + metric
+ DO_2D( 1, 0, 1, 0 )
+ 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)
+ END_2D
+ CASE DEFAULT ! error
+ CALL ctl_stop('STOP','dyn_vor: wrong value for kvor' )
+ END SELECT
+ !
+ IF( ln_dynvor_msk ) THEN !== mask/unmask vorticity ==!
+ DO_2D( 1, 0, 1, 0 )
+ zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk)
+ END_2D
+ ENDIF
+ END DO
+ !
+ CALL lbc_lnk( 'dynvor', zwz, 'F', 1. )
+ !
+ DO jk = 1, jpkm1 ! Horizontal slab
+ !
+ ! !== horizontal fluxes ==!
+ zwx(:,:) = e2u(:,:) * e3u(:,:,jk,Kmm) * pu(:,:,jk)
+ zwy(:,:) = e1v(:,:) * e3v(:,:,jk,Kmm) * pv(:,:,jk)
+
+ ! !== compute and add the vorticity term trend =!
+ jj = 2
+ ztne(1,:) = 0 ; ztnw(1,:) = 0 ; ztse(1,:) = 0 ; ztsw(1,:) = 0
+ DO ji = 2, jpi ! split in 2 parts due to vector opt.
+ 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
+ END DO
+ DO jj = 3, jpj
+ DO ji = 2, jpi ! vector opt. ok because we start at jj = 3
+ 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
+ END DO
+ END DO
+ 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 ) )
+ 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 ! End of slab
+ ! ! ===============
+ END SUBROUTINE vor_eeT
+
+
+ SUBROUTINE dyn_vor_init
+ !!---------------------------------------------------------------------
+ !! *** ROUTINE dyn_vor_init ***
+ !!
+ !! ** Purpose : Control the consistency between cpp options for
+ !! tracer advection schemes
+ !!----------------------------------------------------------------------
+ INTEGER :: ji, jj, jk ! dummy loop indices
+ INTEGER :: ioptio, ios ! local integer
+ !!
+ NAMELIST/namdyn_vor/ ln_dynvor_ens, ln_dynvor_ene, ln_dynvor_enT, ln_dynvor_eeT, &
+ & ln_dynvor_een, nn_een_e3f , ln_dynvor_mix, ln_dynvor_msk
+ !!----------------------------------------------------------------------
+ !
+ IF(lwp) THEN
+ WRITE(numout,*)
+ WRITE(numout,*) 'dyn_vor_init : vorticity term : read namelist and control the consistency'
+ WRITE(numout,*) '~~~~~~~~~~~~'
+ ENDIF
+ !
+ READ ( numnam_ref, namdyn_vor, IOSTAT = ios, ERR = 901)
+901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_vor in reference namelist' )
+ READ ( numnam_cfg, namdyn_vor, IOSTAT = ios, ERR = 902 )
+902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdyn_vor in configuration namelist' )
+ IF(lwm) WRITE ( numond, namdyn_vor )
+ !
+ IF(lwp) THEN ! Namelist print
+ WRITE(numout,*) ' Namelist namdyn_vor : choice of the vorticity term scheme'
+ WRITE(numout,*) ' enstrophy conserving scheme ln_dynvor_ens = ', ln_dynvor_ens
+ WRITE(numout,*) ' f-point energy conserving scheme ln_dynvor_ene = ', ln_dynvor_ene
+ WRITE(numout,*) ' t-point energy conserving scheme ln_dynvor_enT = ', ln_dynvor_enT
+ WRITE(numout,*) ' energy conserving scheme (een using e3t) ln_dynvor_eeT = ', ln_dynvor_eeT
+ WRITE(numout,*) ' enstrophy and energy conserving scheme ln_dynvor_een = ', ln_dynvor_een
+ WRITE(numout,*) ' e3f = averaging /4 (=0) or /sum(tmask) (=1) nn_een_e3f = ', nn_een_e3f
+ WRITE(numout,*) ' mixed enstrophy/energy conserving scheme ln_dynvor_mix = ', ln_dynvor_mix
+ WRITE(numout,*) ' masked (=T) or unmasked(=F) vorticity ln_dynvor_msk = ', ln_dynvor_msk
+ ENDIF
+
+!!an IF( ln_dynvor_msk ) CALL ctl_stop( 'dyn_vor_init: masked vorticity is not currently not available')
+
+!!gm this should be removed when choosing a unique strategy for fmask at the coast
+ ! If energy, enstrophy or mixed advection of momentum in vector form change the value for masks
+ ! at angles with three ocean points and one land point
+ IF(lwp) WRITE(numout,*)
+ IF(lwp) WRITE(numout,*) ' change fmask value in the angles (T) ln_vorlat = ', ln_vorlat
+ IF( ln_vorlat .AND. ( ln_dynvor_ene .OR. ln_dynvor_ens .OR. ln_dynvor_mix ) ) THEN
+ DO_3D( 1, 0, 1, 0, 1, jpk )
+ IF( tmask(ji,jj+1,jk) + tmask(ji+1,jj+1,jk) &
+ & + tmask(ji,jj ,jk) + tmask(ji+1,jj+1,jk) == 3._wp ) fmask(ji,jj,jk) = 1._wp
+ END_3D
+ !
+ CALL lbc_lnk( 'dynvor', fmask, 'F', 1._wp ) ! Lateral boundary conditions on fmask
+ !
+ ENDIF
+!!gm end
+
+ ioptio = 0 ! type of scheme for vorticity (set nvor_scheme)
+ IF( ln_dynvor_ens ) THEN ; ioptio = ioptio + 1 ; nvor_scheme = np_ENS ; ENDIF
+ IF( ln_dynvor_ene ) THEN ; ioptio = ioptio + 1 ; nvor_scheme = np_ENE ; ENDIF
+ IF( ln_dynvor_enT ) THEN ; ioptio = ioptio + 1 ; nvor_scheme = np_ENT ; ENDIF
+ IF( ln_dynvor_eeT ) THEN ; ioptio = ioptio + 1 ; nvor_scheme = np_EET ; ENDIF
+ IF( ln_dynvor_een ) THEN ; ioptio = ioptio + 1 ; nvor_scheme = np_EEN ; ENDIF
+ IF( ln_dynvor_mix ) THEN ; ioptio = ioptio + 1 ; nvor_scheme = np_MIX ; ENDIF
+ !
+ IF( ioptio /= 1 ) CALL ctl_stop( ' use ONE and ONLY one vorticity scheme' )
+ !
+ IF(lwp) WRITE(numout,*) ! type of calculated vorticity (set ncor, nrvm, ntot)
+ ncor = np_COR ! planetary vorticity
+ SELECT CASE( n_dynadv )
+ CASE( np_LIN_dyn )
+ IF(lwp) WRITE(numout,*) ' ==>>> linear dynamics : total vorticity = Coriolis'
+ nrvm = np_COR ! planetary vorticity
+ ntot = np_COR ! - -
+ CASE( np_VEC_c2 )
+ IF(lwp) WRITE(numout,*) ' ==>>> vector form dynamics : total vorticity = Coriolis + relative vorticity'
+ nrvm = np_RVO ! relative vorticity
+ ntot = np_CRV ! relative + planetary vorticity
+ CASE( np_FLX_c2 , np_FLX_ubs )
+ IF(lwp) WRITE(numout,*) ' ==>>> flux form dynamics : total vorticity = Coriolis + metric term'
+ nrvm = np_MET ! metric term
+ ntot = np_CME ! Coriolis + metric term
+ !
+ SELECT CASE( nvor_scheme ) ! pre-computed gradients for the metric term:
+ CASE( np_ENT ) !* T-point metric term : pre-compute di(e2u)/2 and dj(e1v)/2
+ ALLOCATE( di_e2u_2(jpi,jpj), dj_e1v_2(jpi,jpj) )
+ DO_2D( 0, 0, 0, 0 )
+ di_e2u_2(ji,jj) = ( e2u(ji,jj) - e2u(ji-1,jj ) ) * 0.5_wp
+ dj_e1v_2(ji,jj) = ( e1v(ji,jj) - e1v(ji ,jj-1) ) * 0.5_wp
+ END_2D
+ CALL lbc_lnk_multi( 'dynvor', di_e2u_2, 'T', -1. , dj_e1v_2, 'T', -1. ) ! Lateral boundary conditions
+ !
+ CASE DEFAULT !* F-point metric term : pre-compute di(e2u)/(2*e1e2f) and dj(e1v)/(2*e1e2f)
+ ALLOCATE( di_e2v_2e1e2f(jpi,jpj), dj_e1u_2e1e2f(jpi,jpj) )
+ DO_2D( 1, 0, 1, 0 )
+ di_e2v_2e1e2f(ji,jj) = ( e2v(ji+1,jj ) - e2v(ji,jj) ) * 0.5 * r1_e1e2f(ji,jj)
+ dj_e1u_2e1e2f(ji,jj) = ( e1u(ji ,jj+1) - e1u(ji,jj) ) * 0.5 * r1_e1e2f(ji,jj)
+ END_2D
+ CALL lbc_lnk_multi( 'dynvor', di_e2v_2e1e2f, 'F', -1. , dj_e1u_2e1e2f, 'F', -1. ) ! Lateral boundary conditions
+ END SELECT
+ !
+ END SELECT
+
+ IF(lwp) THEN ! Print the choice
+ WRITE(numout,*)
+ SELECT CASE( nvor_scheme )
+ CASE( np_ENS ) ; WRITE(numout,*) ' ==>>> enstrophy conserving scheme (ENS)'
+ CASE( np_ENE ) ; WRITE(numout,*) ' ==>>> energy conserving scheme (Coriolis at F-points) (ENE)'
+ CASE( np_ENT ) ; WRITE(numout,*) ' ==>>> energy conserving scheme (Coriolis at T-points) (ENT)'
+ CASE( np_EET ) ; WRITE(numout,*) ' ==>>> energy conserving scheme (EEN scheme using e3t) (EET)'
+ CASE( np_EEN ) ; WRITE(numout,*) ' ==>>> energy and enstrophy conserving scheme (EEN)'
+ CASE( np_MIX ) ; WRITE(numout,*) ' ==>>> mixed enstrophy/energy conserving scheme (MIX)'
+ END SELECT
+ ENDIF
+ !
+ END SUBROUTINE dyn_vor_init
+
+ !!==============================================================================
+END MODULE dynvor
Index: /NEMO/branches/2020/r12377_ticket2386/src/SWE/ldfdyn.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/SWE/ldfdyn.F90 (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/src/SWE/ldfdyn.F90 (revision 13540)
@@ -0,0 +1,525 @@
+MODULE ldfdyn
+ !!======================================================================
+ !! *** MODULE ldfdyn ***
+ !! Ocean physics: lateral viscosity coefficient
+ !!=====================================================================
+ !! History : OPA ! 1997-07 (G. Madec) multi dimensional coefficients
+ !! NEMO 1.0 ! 2002-09 (G. Madec) F90: Free form and module
+ !! 3.7 ! 2014-01 (F. Lemarie, G. Madec) restructuration/simplification of ahm specification,
+ !! ! add velocity dependent coefficient and optional read in file
+ !!----------------------------------------------------------------------
+
+ !!----------------------------------------------------------------------
+ !! ldf_dyn_init : initialization, namelist read, and parameters control
+ !! ldf_dyn : update lateral eddy viscosity coefficients at each time step
+ !!----------------------------------------------------------------------
+ USE oce ! ocean dynamics and tracers
+ USE dom_oce ! ocean space and time domain
+ USE phycst ! physical constants
+ USE ldfslp ! lateral diffusion: slopes of mixing orientation
+ USE ldfc1d_c2d ! lateral diffusion: 1D and 2D cases
+ !
+ USE in_out_manager ! I/O manager
+ USE iom ! I/O module for ehanced bottom friction file
+ USE timing ! Timing
+ USE lib_mpp ! distribued memory computing library
+ USE lbclnk ! ocean lateral boundary conditions (or mpp link)
+
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC ldf_dyn_init ! called by nemogcm.F90
+ PUBLIC ldf_dyn ! called by step.F90
+
+ ! !!* Namelist namdyn_ldf : lateral mixing on momentum *
+ LOGICAL , PUBLIC :: ln_dynldf_OFF !: No operator (i.e. no explicit diffusion)
+ LOGICAL , PUBLIC :: ln_dynldf_lap !: laplacian operator
+ LOGICAL , PUBLIC :: ln_dynldf_blp !: bilaplacian operator
+ LOGICAL , PUBLIC :: ln_dynldf_lev !: iso-level direction
+ LOGICAL , PUBLIC :: ln_dynldf_hor !: horizontal (geopotential) direction
+! LOGICAL , PUBLIC :: ln_dynldf_iso !: iso-neutral direction (see ldfslp)
+ INTEGER , PUBLIC :: nn_ahm_ijk_t !: choice of time & space variations of the lateral eddy viscosity coef.
+ ! ! time invariant coefficients: aht = 1/2 Ud*Ld (lap case)
+ ! ! bht = 1/12 Ud*Ld^3 (blp case)
+ REAL(wp), PUBLIC :: rn_Uv !: lateral viscous velocity [m/s]
+ REAL(wp), PUBLIC :: rn_Lv !: lateral viscous length [m]
+ ! ! Smagorinsky viscosity (nn_ahm_ijk_t = 32)
+ REAL(wp), PUBLIC :: rn_csmc !: Smagorinsky constant of proportionality
+ REAL(wp), PUBLIC :: rn_minfac !: Multiplicative factor of theorectical minimum Smagorinsky viscosity
+ REAL(wp), PUBLIC :: rn_maxfac !: Multiplicative factor of theorectical maximum Smagorinsky viscosity
+ ! ! iso-neutral laplacian (ln_dynldf_lap=ln_dynldf_iso=T)
+ REAL(wp), PUBLIC :: rn_ahm_b !: lateral laplacian background eddy viscosity [m2/s]
+
+ ! !!* Parameter to control the type of lateral viscous operator
+ INTEGER, PARAMETER, PUBLIC :: np_ERROR =-10 !: error in setting the operator
+ INTEGER, PARAMETER, PUBLIC :: np_no_ldf = 00 !: without operator (i.e. no lateral viscous trend)
+ ! !! laplacian ! bilaplacian !
+ INTEGER, PARAMETER, PUBLIC :: np_lap = 10 , np_blp = 20 !: iso-level operator
+ INTEGER, PARAMETER, PUBLIC :: np_lap_i = 11 !: iso-neutral or geopotential operator
+ !
+ INTEGER , PUBLIC :: nldf_dyn !: type of lateral diffusion used defined from ln_dynldf_... (namlist logicals)
+ LOGICAL , PUBLIC :: l_ldfdyn_time !: flag for time variation of the lateral eddy viscosity coef.
+
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ahmt, ahmf !: eddy viscosity coef. at T- and F-points [m2/s or m4/s]
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: dtensq !: horizontal tension squared (Smagorinsky only)
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: dshesq !: horizontal shearing strain squared (Smagorinsky only)
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: esqt, esqf !: Square of the local gridscale (e1e2/(e1+e2))**2
+
+ REAL(wp) :: r1_2 = 0.5_wp ! =1/2
+ REAL(wp) :: r1_4 = 0.25_wp ! =1/4
+ REAL(wp) :: r1_8 = 0.125_wp ! =1/8
+ REAL(wp) :: r1_12 = 1._wp / 12._wp ! =1/12
+ REAL(wp) :: r1_288 = 1._wp / 288._wp ! =1/( 12^2 * 2 )
+
+ !! * Substitutions
+# include "do_loop_substitute.h90"
+ !!----------------------------------------------------------------------
+ !! NEMO/OCE 4.0 , NEMO Consortium (2018)
+ !! $Id: ldfdyn.F90 12822 2020-04-28 09:10:38Z gm $
+ !! Software governed by the CeCILL license (see ./LICENSE)
+ !!----------------------------------------------------------------------
+CONTAINS
+
+ SUBROUTINE ldf_dyn_init
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE ldf_dyn_init ***
+ !!
+ !! ** Purpose : set the horizontal ocean dynamics physics
+ !!
+ !! ** Method : the eddy viscosity coef. specification depends on:
+ !! - the operator:
+ !! ln_dynldf_lap = T laplacian operator
+ !! ln_dynldf_blp = T bilaplacian operator
+ !! - the parameter nn_ahm_ijk_t:
+ !! nn_ahm_ijk_t = 0 => = constant
+ !! = 10 => = F(z) : = constant with a reduction of 1/4 with depth
+ !! =-20 => = F(i,j) = shape read in 'eddy_viscosity.nc' file
+ !! = 20 = F(i,j) = F(e1,e2) or F(e1^3,e2^3) (lap or bilap case)
+ !! =-30 => = F(i,j,k) = shape read in 'eddy_viscosity.nc' file
+ !! = 30 = F(i,j,k) = 2D (case 20) + decrease with depth (case 10)
+ !! = 31 = F(i,j,k,t) = F(local velocity) ( |u|e /12 laplacian operator
+ !! or |u|e^3/12 bilaplacian operator )
+ !! = 32 = F(i,j,k,t) = F(local deformation rate and gridscale) (D and L) (Smagorinsky)
+ !! ( L^2|D| laplacian operator
+ !! or L^4|D|/8 bilaplacian operator )
+ !!----------------------------------------------------------------------
+ INTEGER :: ji, jj, jk ! dummy loop indices
+ INTEGER :: ioptio, ierr, inum, ios, inn ! local integer
+ REAL(wp) :: zah0, zah_max, zUfac ! local scalar
+ REAL(wp) :: zsum ! local scalar
+ CHARACTER(len=5) :: cl_Units ! units (m2/s or m4/s)
+ !!
+ NAMELIST/namdyn_ldf/ ln_dynldf_OFF, ln_dynldf_lap, ln_dynldf_blp, & ! type of operator
+ & ln_dynldf_lev, ln_dynldf_hor, ln_dynldf_iso, & ! acting direction of the operator
+ & nn_ahm_ijk_t , rn_Uv , rn_Lv, rn_ahm_b, & ! lateral eddy coefficient
+ & rn_csmc , rn_minfac , rn_maxfac ! Smagorinsky settings
+ !!----------------------------------------------------------------------
+ !
+ READ ( numnam_ref, namdyn_ldf, IOSTAT = ios, ERR = 901)
+901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_ldf in reference namelist' )
+
+ READ ( numnam_cfg, namdyn_ldf, IOSTAT = ios, ERR = 902 )
+902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdyn_ldf in configuration namelist' )
+ IF(lwm) WRITE ( numond, namdyn_ldf )
+
+ IF(lwp) THEN ! Parameter print
+ WRITE(numout,*)
+ WRITE(numout,*) 'ldf_dyn : lateral momentum physics'
+ WRITE(numout,*) '~~~~~~~'
+ WRITE(numout,*) ' Namelist namdyn_ldf : set lateral mixing parameters'
+ !
+ WRITE(numout,*) ' type :'
+ WRITE(numout,*) ' no explicit diffusion ln_dynldf_OFF = ', ln_dynldf_OFF
+ WRITE(numout,*) ' laplacian operator ln_dynldf_lap = ', ln_dynldf_lap
+ WRITE(numout,*) ' bilaplacian operator ln_dynldf_blp = ', ln_dynldf_blp
+ !
+ WRITE(numout,*) ' direction of action :'
+ WRITE(numout,*) ' iso-level ln_dynldf_lev = ', ln_dynldf_lev
+ WRITE(numout,*) ' horizontal (geopotential) ln_dynldf_hor = ', ln_dynldf_hor
+ WRITE(numout,*) ' iso-neutral ln_dynldf_iso = ', ln_dynldf_iso
+ !
+ WRITE(numout,*) ' coefficients :'
+ WRITE(numout,*) ' type of time-space variation nn_ahm_ijk_t = ', nn_ahm_ijk_t
+ WRITE(numout,*) ' lateral viscous velocity (if cst) rn_Uv = ', rn_Uv, ' m/s'
+ WRITE(numout,*) ' lateral viscous length (if cst) rn_Lv = ', rn_Lv, ' m'
+ WRITE(numout,*) ' background viscosity (iso-lap case) rn_ahm_b = ', rn_ahm_b, ' m2/s'
+ !
+ WRITE(numout,*) ' Smagorinsky settings (nn_ahm_ijk_t = 32) :'
+ WRITE(numout,*) ' Smagorinsky coefficient rn_csmc = ', rn_csmc
+ WRITE(numout,*) ' factor multiplier for eddy visc.'
+ WRITE(numout,*) ' lower limit (default 1.0) rn_minfac = ', rn_minfac
+ WRITE(numout,*) ' upper limit (default 1.0) rn_maxfac = ', rn_maxfac
+ ENDIF
+
+ !
+ ! !== type of lateral operator used ==! (set nldf_dyn)
+ ! !=====================================!
+ !
+ nldf_dyn = np_ERROR
+ ioptio = 0
+ IF( ln_dynldf_OFF ) THEN ; nldf_dyn = np_no_ldf ; ioptio = ioptio + 1 ; ENDIF
+ IF( ln_dynldf_lap ) THEN ; ioptio = ioptio + 1 ; ENDIF
+ IF( ln_dynldf_blp ) THEN ; ioptio = ioptio + 1 ; ENDIF
+ IF( ioptio /= 1 ) CALL ctl_stop( 'dyn_ldf_init: use ONE of the 3 operator options (NONE/lap/blp)' )
+ !
+ IF(.NOT.ln_dynldf_OFF ) THEN !== direction ==>> type of operator ==!
+ ioptio = 0
+ IF( ln_dynldf_lev ) ioptio = ioptio + 1
+ IF( ln_dynldf_hor ) ioptio = ioptio + 1
+ IF( ln_dynldf_iso ) ioptio = ioptio + 1
+ IF( ioptio /= 1 ) CALL ctl_stop( 'dyn_ldf_init: use ONE of the 3 direction options (level/hor/iso)' )
+ !
+ ! ! 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)
+ 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)
+ ENDIF
+ ENDIF
+ !
+ IF( ln_dynldf_blp ) THEN ! bilaplacian operator
+ IF( ln_zco ) THEN ! z-coordinate
+ 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( 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)
+ ENDIF
+ ENDIF
+ !
+ IF( ierr == 2 ) CALL ctl_stop( 'rotated bi-laplacian operator does not exist' )
+ !
+ IF( nldf_dyn == np_lap_i ) l_ldfslp = .TRUE. ! rotation require the computation of the slopes
+ !
+ ENDIF
+ !
+ IF(lwp) THEN
+ WRITE(numout,*)
+ SELECT CASE( nldf_dyn )
+ CASE( np_no_ldf ) ; WRITE(numout,*) ' ==>>> NO lateral viscosity'
+ CASE( np_lap ) ; WRITE(numout,*) ' ==>>> iso-level laplacian operator'
+ CASE( np_lap_i ) ; WRITE(numout,*) ' ==>>> rotated laplacian operator with iso-level background'
+ CASE( np_blp ) ; WRITE(numout,*) ' ==>>> iso-level bi-laplacian operator'
+ END SELECT
+ WRITE(numout,*)
+ ENDIF
+
+ !
+ ! !== Space/time variation of eddy coefficients ==!
+ ! !=================================================!
+ !
+ l_ldfdyn_time = .FALSE. ! no time variation except in case defined below
+ !
+ IF( ln_dynldf_OFF ) THEN
+ IF(lwp) WRITE(numout,*) ' ==>>> No viscous operator selected. ahmt and ahmf are not allocated'
+ RETURN
+ !
+ ELSE !== a lateral diffusion operator is used ==!
+ !
+ ! ! allocate the ahm arrays
+ ALLOCATE( ahmt(jpi,jpj,jpk) , ahmf(jpi,jpj,jpk) , STAT=ierr )
+ IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'ldf_dyn_init: failed to allocate arrays')
+ !
+ ahmt(:,:,:) = 0._wp ! init to 0 needed
+ ahmf(:,:,:) = 0._wp
+ !
+ ! ! value of lap/blp eddy mixing coef.
+ IF( ln_dynldf_lap ) THEN ; zUfac = r1_2 *rn_Uv ; inn = 1 ; cl_Units = ' m2/s' ! laplacian
+ ELSEIF( ln_dynldf_blp ) THEN ; zUfac = r1_12*rn_Uv ; inn = 3 ; cl_Units = ' m4/s' ! bilaplacian
+ ENDIF
+ zah0 = zUfac * rn_Lv**inn ! mixing coefficient
+ zah_max = zUfac * (ra*rad)**inn ! maximum reachable coefficient (value at the Equator)
+ !
+ SELECT CASE( nn_ahm_ijk_t ) !* Specification of space-time variations of ahmt, ahmf
+ !
+ CASE( 0 ) !== constant ==!
+ IF(lwp) WRITE(numout,*) ' ==>>> eddy viscosity. = constant = ', zah0, cl_Units
+ ahmt(:,:,1:jpkm1) = zah0
+ ahmf(:,:,1:jpkm1) = zah0
+ !
+ CASE( 10 ) !== fixed profile ==!
+ IF(lwp) WRITE(numout,*) ' ==>>> eddy viscosity = F( depth )'
+ IF(lwp) WRITE(numout,*) ' surface viscous coef. = constant = ', zah0, cl_Units
+ ahmt(:,:,1) = zah0 ! constant surface value
+ ahmf(:,:,1) = zah0
+ CALL ldf_c1d( 'DYN', ahmt(:,:,1), ahmf(:,:,1), ahmt, ahmf )
+ !
+ CASE ( -20 ) !== fixed horizontal shape read in file ==!
+ IF(lwp) WRITE(numout,*) ' ==>>> eddy viscosity = F(i,j) read in eddy_viscosity.nc file'
+ CALL iom_open( 'eddy_viscosity_2D.nc', inum )
+ CALL iom_get ( inum, jpdom_data, 'ahmt_2d', ahmt(:,:,1) )
+ CALL iom_get ( inum, jpdom_data, 'ahmf_2d', ahmf(:,:,1) )
+ CALL iom_close( inum )
+ DO jk = 2, jpkm1
+ ahmt(:,:,jk) = ahmt(:,:,1)
+ ahmf(:,:,jk) = ahmf(:,:,1)
+ END DO
+ !
+ CASE( 20 ) !== fixed horizontal shape ==!
+ IF(lwp) WRITE(numout,*) ' ==>>> eddy viscosity = F( e1, e2 ) or F( e1^3, e2^3 ) (lap. or blp. case)'
+ IF(lwp) WRITE(numout,*) ' using a fixed viscous velocity = ', rn_Uv ,' m/s and Lv = Max(e1,e2)'
+ IF(lwp) WRITE(numout,*) ' maximum reachable coefficient (at the Equator) = ', zah_max, cl_Units, ' for e1=1°)'
+ CALL ldf_c2d( 'DYN', zUfac , inn , ahmt, ahmf ) ! surface value proportional to scale factor^inn
+ !
+ CASE( -30 ) !== fixed 3D shape read in file ==!
+ IF(lwp) WRITE(numout,*) ' ==>>> eddy viscosity = F(i,j,k) read in eddy_viscosity_3D.nc file'
+ CALL iom_open( 'eddy_viscosity_3D.nc', inum )
+ CALL iom_get ( inum, jpdom_data, 'ahmt_3d', ahmt )
+ CALL iom_get ( inum, jpdom_data, 'ahmf_3d', ahmf )
+ CALL iom_close( inum )
+ !
+ CASE( 30 ) !== fixed 3D shape ==!
+ IF(lwp) WRITE(numout,*) ' ==>>> eddy viscosity = F( latitude, longitude, depth )'
+ IF(lwp) WRITE(numout,*) ' using a fixed viscous velocity = ', rn_Uv ,' m/s and Ld = Max(e1,e2)'
+ IF(lwp) WRITE(numout,*) ' maximum reachable coefficient (at the Equator) = ', zah_max, cl_Units, ' for e1=1°)'
+ CALL ldf_c2d( 'DYN', zUfac , inn , ahmt, ahmf ) ! surface value proportional to scale factor^inn
+ CALL ldf_c1d( 'DYN', ahmt(:,:,1), ahmf(:,:,1), ahmt, ahmf ) ! reduction with depth
+ !
+ CASE( 31 ) !== time varying 3D field ==!
+ IF(lwp) WRITE(numout,*) ' ==>>> eddy viscosity = F( latitude, longitude, depth , time )'
+ IF(lwp) WRITE(numout,*) ' proportional to the local velocity : 1/2 |u|e (lap) or 1/12 |u|e^3 (blp)'
+ !
+ l_ldfdyn_time = .TRUE. ! will be calculated by call to ldf_dyn routine in step.F90
+ !
+ CASE( 32 ) !== time varying 3D field ==!
+ IF(lwp) WRITE(numout,*) ' ==>>> eddy viscosity = F( latitude, longitude, depth , time )'
+ IF(lwp) WRITE(numout,*) ' proportional to the local deformation rate and gridscale (Smagorinsky)'
+ !
+ 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 )
+ IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'ldf_dyn_init: failed to allocate Smagorinsky arrays')
+ !
+ DO_2D( 1, 1, 1, 1 )
+ 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
+ !
+ CASE DEFAULT
+ CALL ctl_stop('ldf_dyn_init: wrong choice for nn_ahm_ijk_t, the type of space-time variation of ahm')
+ END SELECT
+ !
+ IF( .NOT.l_ldfdyn_time ) THEN !* No time variation
+ IF( ln_dynldf_lap ) THEN ! laplacian operator (mask only)
+ ahmt(:,:,1:jpkm1) = ahmt(:,:,1:jpkm1) * tmask(:,:,1:jpkm1)
+ WRITE(numout,*) ' ahmt tmask '
+!! mask tension at the coast (equivalent of ghostpoints at T)
+! DO jk = 1, jpk
+! DO jj = 1, jpjm1
+! DO ji = 1, jpim1 ! NO vector opt.
+! ! si sum(fmask)==3 = mouillé (on touche pas)
+! ! si sum = 2 alors on met a 0 zsum = fmask + fmask + fmask,.. et si zsum < 2 -> 0 sinon = 1
+! zsum = fmask(ji,jj ,jk) + fmask(ji+1,jj ,jk) &
+! & + fmask(ji,jj+1,jk) + fmask(ji+1,jj+1,jk)
+! IF ( zsum < 2._wp ) ahmt(ji,jj,jk) = 0
+! !
+! !ahmt(ji,jj,jk) = ahmt(ji,jj,jk) * fmask(ji,jj ,jk) * fmask(ji+1,jj ,jk) &
+! ! & * fmask(ji,jj+1,jk) * fmask(ji+1,jj+1,jk)
+! END DO
+! END DO
+! END DO
+! ahmt(jpi,:,1:jpkm1) = 0._wp
+! ahmt(:,jpj,1:jpkm1) = 0._wp
+! WRITE(numout,*) ' an45 ahmt x0'
+
+ ahmf(:,:,1:jpkm1) = ahmf(:,:,1:jpkm1) * fmask(:,:,1:jpkm1)
+ WRITE(numout,*) ' ahmf fmask '
+!!an apply no slip at the coast (ssfmask = 1 within the domain and at the coast contrary to fmask in free slip)
+! DO jk = 1, jpkm1
+! ahmf(:,:,jk) = ahmf(:,:,jk) * ( 2._wp * ssfmask(:,:) - fmask(:,:,jk) )
+! END DO
+! WRITE(numout,*) ' an45 ahmf x2'
+
+ ELSEIF( ln_dynldf_blp ) THEN ! bilaplacian operator (square root + mask)
+ ahmt(:,:,1:jpkm1) = SQRT( ahmt(:,:,1:jpkm1) ) * tmask(:,:,1:jpkm1)
+ ahmf(:,:,1:jpkm1) = SQRT( ahmf(:,:,1:jpkm1) ) * fmask(:,:,1:jpkm1)
+ ENDIF
+ ENDIF
+ !
+ ENDIF
+ !
+ END SUBROUTINE ldf_dyn_init
+
+
+ SUBROUTINE ldf_dyn( kt, Kbb )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE ldf_dyn ***
+ !!
+ !! ** Purpose : update at kt the momentum lateral mixing coeff. (ahmt and ahmf)
+ !!
+ !! ** Method : time varying eddy viscosity coefficients:
+ !!
+ !! nn_ahm_ijk_t = 31 ahmt, ahmf = F(i,j,k,t) = F(local velocity)
+ !! ( |u|e /12 or |u|e^3/12 for laplacian or bilaplacian operator )
+ !!
+ !! nn_ahm_ijk_t = 32 ahmt, ahmf = F(i,j,k,t) = F(local deformation rate and gridscale) (D and L) (Smagorinsky)
+ !! ( L^2|D| or L^4|D|/8 for laplacian or bilaplacian operator )
+ !!
+ !! ** note : in BLP cases the sqrt of the eddy coef is returned, since bilaplacian is en re-entrant laplacian
+ !! ** action : ahmt, ahmf updated at each time step
+ !!----------------------------------------------------------------------
+ INTEGER, INTENT(in) :: kt ! time step index
+ INTEGER, INTENT(in) :: Kbb ! ocean time level indices
+ !
+ INTEGER :: ji, jj, jk ! dummy loop indices
+ REAL(wp) :: zu2pv2_ij_p1, zu2pv2_ij, zu2pv2_ij_m1, zemax ! local scalar (option 31)
+ REAL(wp) :: zcmsmag, zstabf_lo, zstabf_up, zdelta, zdb ! local scalar (option 32)
+ !!----------------------------------------------------------------------
+ !
+ IF( ln_timing ) CALL timing_start('ldf_dyn')
+ !
+ SELECT CASE( nn_ahm_ijk_t ) !== Eddy vicosity coefficients ==!
+ !
+ CASE( 31 ) !== time varying 3D field ==! = F( local velocity )
+ !
+ IF( ln_dynldf_lap ) THEN ! laplacian operator : |u| e /12 = |u/144| e
+ DO jk = 1, jpkm1
+ DO_2D( 0, 0, 0, 0 )
+ zu2pv2_ij = uu(ji ,jj ,jk,Kbb) * uu(ji ,jj ,jk,Kbb) + vv(ji ,jj ,jk,Kbb) * vv(ji ,jj ,jk,Kbb)
+ 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)
+ zemax = MAX( e1t(ji,jj) , e2t(ji,jj) )
+ ahmt(ji,jj,jk) = SQRT( (zu2pv2_ij + zu2pv2_ij_m1) * r1_288 ) * zemax * tmask(ji,jj,jk) ! 288= 12*12 * 2
+ END_2D
+ DO_2D( 1, 0, 1, 0 )
+ 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)
+ zemax = MAX( e1f(ji,jj) , e2f(ji,jj) )
+ ahmf(ji,jj,jk) = SQRT( (zu2pv2_ij + zu2pv2_ij_p1) * r1_288 ) * zemax * fmask(ji,jj,jk) ! 288= 12*12 * 2
+ END_2D
+ END DO
+ ELSEIF( ln_dynldf_blp ) THEN ! bilaplacian operator : sqrt( |u| e^3 /12 ) = sqrt( |u/144| e ) * e
+ DO jk = 1, jpkm1
+ DO_2D( 0, 0, 0, 0 )
+ zu2pv2_ij = uu(ji ,jj ,jk,Kbb) * uu(ji ,jj ,jk,Kbb) + vv(ji ,jj ,jk,Kbb) * vv(ji ,jj ,jk,Kbb)
+ 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)
+ zemax = MAX( e1t(ji,jj) , e2t(ji,jj) )
+ ahmt(ji,jj,jk) = SQRT( SQRT( (zu2pv2_ij + zu2pv2_ij_m1) * r1_288 ) * zemax ) * zemax * tmask(ji,jj,jk)
+ END_2D
+ DO_2D( 1, 0, 1, 0 )
+ 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)
+ zemax = MAX( e1f(ji,jj) , e2f(ji,jj) )
+ ahmf(ji,jj,jk) = SQRT( SQRT( (zu2pv2_ij + zu2pv2_ij_p1) * r1_288 ) * zemax ) * zemax * fmask(ji,jj,jk)
+ END_2D
+ END DO
+ ENDIF
+ !
+ CALL lbc_lnk_multi( 'ldfdyn', ahmt, 'T', 1., ahmf, 'F', 1. )
+ !
+ !
+ CASE( 32 ) !== time varying 3D field ==! = F( local deformation rate and gridscale ) (Smagorinsky)
+ !
+ IF( ln_dynldf_lap .OR. ln_dynldf_blp ) THEN ! laplacian operator : (C_smag/pi)^2 L^2 |D|
+ !
+ zcmsmag = (rn_csmc/rpi)**2 ! (C_smag/pi)^2
+ zstabf_lo = rn_minfac * rn_minfac / ( 2._wp * 12._wp * 12._wp * zcmsmag ) ! lower limit stability factor scaling
+ zstabf_up = rn_maxfac / ( 4._wp * zcmsmag * 2._wp * rn_Dt ) ! upper limit stability factor scaling
+ IF( ln_dynldf_blp ) zstabf_lo = ( 16._wp / 9._wp ) * zstabf_lo ! provide |U|L^3/12 lower limit instead
+ ! ! 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)
+ 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)
+ dshesq(ji,jj,jk) = zdb * zdb * fmask(ji,jj,jk)
+ END_2D
+ !
+ END DO
+ !
+ CALL lbc_lnk_multi( 'ldfdyn', dtensq, 'T', 1. ) ! lbc_lnk on dshesq not needed
+ !
+ DO jk = 1, jpkm1
+ !
+ DO_2D( 0, 0, 0, 0 )
+ !
+ zu2pv2_ij = uu(ji ,jj ,jk,Kbb) * uu(ji ,jj ,jk,Kbb) + vv(ji ,jj ,jk,Kbb) * vv(ji ,jj ,jk,Kbb)
+ 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) = 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 )
+ !
+ 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) = 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)
+ !
+ END_2D
+ !
+ END DO
+ !
+ ENDIF
+ !
+ IF( ln_dynldf_blp ) THEN ! bilaplacian operator : sqrt( (C_smag/pi)^2 L^4 |D|/8)
+ ! ! = sqrt( A_lap_smag L^2/8 )
+ ! ! stability limits already applied to laplacian values
+ ! ! effective default limits are 1/12 |U|L^3 < B_hm < 1//(32*2dt) L^4
+ DO jk = 1, jpkm1
+ DO_2D( 0, 0, 0, 0 )
+ ahmt(ji,jj,jk) = SQRT( r1_8 * esqt(ji,jj) * ahmt(ji,jj,jk) )
+ END_2D
+ DO_2D( 1, 0, 1, 0 )
+ ahmf(ji,jj,jk) = SQRT( r1_8 * esqf(ji,jj) * ahmf(ji,jj,jk) )
+ END_2D
+ END DO
+ !
+ ENDIF
+ !
+ CALL lbc_lnk_multi( 'ldfdyn', ahmt, 'T', 1. , ahmf, 'F', 1. )
+ !
+ END SELECT
+ !
+ CALL iom_put( "ahmt_2d", ahmt(:,:,1) ) ! surface u-eddy diffusivity coeff.
+ CALL iom_put( "ahmf_2d", ahmf(:,:,1) ) ! surface v-eddy diffusivity coeff.
+ CALL iom_put( "ahmt_3d", ahmt(:,:,:) ) ! 3D u-eddy diffusivity coeff.
+ CALL iom_put( "ahmf_3d", ahmf(:,:,:) ) ! 3D v-eddy diffusivity coeff.
+ !
+ IF( ln_timing ) CALL timing_stop('ldf_dyn')
+ !
+ END SUBROUTINE ldf_dyn
+
+ !!======================================================================
+END MODULE ldfdyn
Index: /NEMO/branches/2020/r12377_ticket2386/src/SWE/nemogcm.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/SWE/nemogcm.F90 (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/src/SWE/nemogcm.F90 (revision 13540)
@@ -0,0 +1,622 @@
+MODULE nemogcm
+ !!======================================================================
+ !! *** MODULE nemogcm ***
+ !! Ocean system : NEMO GCM (ocean dynamics, on-line tracers, biochemistry and sea-ice)
+ !!======================================================================
+ !! History : OPA ! 1990-10 (C. Levy, G. Madec) Original code
+ !! 7.0 ! 1991-11 (M. Imbard, C. Levy, G. Madec)
+ !! 7.1 ! 1993-03 (M. Imbard, C. Levy, G. Madec, O. Marti, M. Guyon, A. Lazar,
+ !! P. Delecluse, C. Perigaud, G. Caniaux, B. Colot, C. Maes) release 7.1
+ !! - ! 1992-06 (L.Terray) coupling implementation
+ !! - ! 1993-11 (M.A. Filiberti) IGLOO sea-ice
+ !! 8.0 ! 1996-03 (M. Imbard, C. Levy, G. Madec, O. Marti, M. Guyon, A. Lazar,
+ !! P. Delecluse, L.Terray, M.A. Filiberti, J. Vialar, A.M. Treguier, M. Levy) release 8.0
+ !! 8.1 ! 1997-06 (M. Imbard, G. Madec)
+ !! 8.2 ! 1999-11 (M. Imbard, H. Goosse) sea-ice model
+ !! ! 1999-12 (V. Thierry, A-M. Treguier, M. Imbard, M-A. Foujols) OPEN-MP
+ !! ! 2000-07 (J-M Molines, M. Imbard) Open Boundary Conditions (CLIPPER)
+ !! NEMO 1.0 ! 2002-08 (G. Madec) F90: Free form and modules
+ !! - ! 2004-06 (R. Redler, NEC CCRLE, Germany) add OASIS[3/4] coupled interfaces
+ !! - ! 2004-08 (C. Talandier) New trends organization
+ !! - ! 2005-06 (C. Ethe) Add the 1D configuration possibility
+ !! - ! 2005-11 (V. Garnier) Surface pressure gradient organization
+ !! - ! 2006-03 (L. Debreu, C. Mazauric) Agrif implementation
+ !! - ! 2006-04 (G. Madec, R. Benshila) Step reorganization
+ !! - ! 2007-07 (J. Chanut, A. Sellar) Unstructured open boundaries (BDY)
+ !! 3.2 ! 2009-08 (S. Masson) open/write in the listing file in mpp
+ !! 3.3 ! 2010-05 (K. Mogensen, A. Weaver, M. Martin, D. Lea) Assimilation interface
+ !! - ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase
+ !! 3.3.1! 2011-01 (A. R. Porter, STFC Daresbury) dynamical allocation
+ !! - ! 2011-11 (C. Harris) decomposition changes for running with CICE
+ !! 3.6 ! 2012-05 (C. Calone, J. Simeon, G. Madec, C. Ethe) Add grid coarsening
+ !! - ! 2014-12 (G. Madec) remove KPP scheme and cross-land advection (cla)
+ !! 4.0 ! 2016-10 (G. Madec, S. Flavoni) domain configuration / user defined interface
+ !!----------------------------------------------------------------------
+
+ !!----------------------------------------------------------------------
+ !! nemo_gcm : solve ocean dynamics, tracer, biogeochemistry and/or sea-ice
+ !! nemo_init : initialization of the NEMO system
+ !! nemo_ctl : initialisation of the contol print
+ !! nemo_closefile: close remaining open files
+ !! nemo_alloc : dynamical allocation
+ !!----------------------------------------------------------------------
+ USE step_oce ! module used in the ocean time stepping module (step.F90)
+ USE phycst ! physical constant (par_cst routine)
+ USE domain ! domain initialization (dom_init & dom_cfg routines)
+ USE closea ! treatment of closed seas (for ln_closea)
+ USE usrdef_nam ! user defined configuration
+ USE tide_mod, ONLY : tide_init ! tidal components initialization (tide_init routine)
+ USE bdy_oce, ONLY : ln_bdy
+ USE bdyini ! open boundary cond. setting (bdy_init routine)
+ USE istate ! initial state setting (istate_init routine)
+ USE ldfdyn ! lateral viscosity setting (ldfdyn_init routine)
+ USE ldftra ! lateral diffusivity setting (ldftra_init routine)
+ USE trdini ! dyn/tra trends initialization (trd_init routine)
+ USE asminc ! assimilation increments
+ USE asmbkg ! writing out state trajectory
+ USE diaptr ! poleward transports (dia_ptr_init routine)
+ USE diadct ! sections transports (dia_dct_init routine)
+ USE diaobs ! Observation diagnostics (dia_obs_init routine)
+ USE diacfl ! CFL diagnostics (dia_cfl_init routine)
+ USE diamlr ! IOM context management for multiple-linear-regression analysis
+#if defined key_RK3
+ USE stpRK3
+#elif defined key_qco
+ USE stpLF
+#else
+ USE step ! NEMO time-stepping (stp routine)
+#endif
+ USE isfstp ! ice shelf (isf_stp_init routine)
+ USE icbini ! handle bergs, initialisation
+ USE icbstp ! handle bergs, calving, themodynamics and transport
+ USE cpl_oasis3 ! OASIS3 coupling
+ USE c1d ! 1D configuration
+ USE step_c1d ! Time stepping loop for the 1D configuration
+ USE dyndmp ! Momentum damping
+ USE stopar ! Stochastic param.: ???
+ USE stopts ! Stochastic param.: ???
+ USE diu_layers ! diurnal bulk SST and coolskin
+ USE crsini ! initialise grid coarsening utility
+ USE dia25h ! 25h mean output
+ USE diadetide ! Weights computation for daily detiding of model diagnostics
+ USE sbc_oce , ONLY : lk_oasis
+ USE wet_dry ! Wetting and drying setting (wad_init routine)
+#if defined key_top
+ USE trcini ! passive tracer initialisation
+#endif
+#if defined key_nemocice_decomp
+ USE ice_domain_size, only: nx_global, ny_global
+#endif
+ !
+ USE lib_mpp ! distributed memory computing
+ USE mppini ! shared/distributed memory setting (mpp_init routine)
+ USE lbcnfd , ONLY : isendto, nsndto, nfsloop, nfeloop ! Setup of north fold exchanges
+ USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)
+#if defined key_iomput
+ USE xios ! xIOserver
+#endif
+#if defined key_agrif
+ USE agrif_all_update ! Master Agrif update
+#endif
+
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC nemo_gcm ! called by model.F90
+ PUBLIC nemo_init ! needed by AGRIF
+ PUBLIC nemo_alloc ! needed by TAM
+
+ CHARACTER(lc) :: cform_aaa="( /, 'AAAAAAAA', / ) " ! flag for output listing
+
+#if defined key_mpp_mpi
+ ! need MPI_Wtime
+ INCLUDE 'mpif.h'
+#endif
+
+ !!----------------------------------------------------------------------
+ !! NEMO/OCE 4.0 , NEMO Consortium (2018)
+ !! $Id: nemogcm.F90 12614 2020-03-26 14:59:52Z gm $
+ !! Software governed by the CeCILL license (see ./LICENSE)
+ !!----------------------------------------------------------------------
+CONTAINS
+
+ SUBROUTINE nemo_gcm
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE nemo_gcm ***
+ !!
+ !! ** Purpose : NEMO solves the primitive equations on an orthogonal
+ !! curvilinear mesh on the sphere.
+ !!
+ !! ** Method : - model general initialization
+ !! - launch the time-stepping (stp routine)
+ !! - finalize the run by closing files and communications
+ !!
+ !! References : Madec, Delecluse, Imbard, and Levy, 1997: internal report, IPSL.
+ !! Madec, 2008, internal report, IPSL.
+ !!----------------------------------------------------------------------
+ INTEGER :: istp ! time step index
+ REAL(wp):: zstptiming ! elapsed time for 1 time step
+ !!----------------------------------------------------------------------
+ !
+#if defined key_agrif
+ CALL Agrif_Init_Grids() ! AGRIF: set the meshes
+#endif
+ ! !-----------------------!
+ CALL nemo_init !== Initialisations ==!
+ ! !-----------------------!
+
+#if defined key_agrif
+ Kbb_a = Nbb; Kmm_a = Nnn; Krhs_a = Nrhs ! agrif_oce module copies of time level indices
+ CALL Agrif_Declare_Var_dom ! AGRIF: set the meshes for DOM
+ CALL Agrif_Declare_Var ! " " " " " DYN/TRA
+# if defined key_top
+ CALL Agrif_Declare_Var_top ! " " " " " TOP
+# endif
+# if defined key_si3
+ CALL Agrif_Declare_Var_ice ! " " " " " Sea ice
+# endif
+#endif
+ ! check that all process are still there... If some process have an error,
+ ! they will never enter in step and other processes will wait until the end of the cpu time!
+ CALL mpp_max( 'nemogcm', nstop )
+
+ IF(lwp) WRITE(numout,cform_aaa) ! Flag AAAAAAA
+
+ ! !-----------------------!
+ ! !== time stepping ==!
+ ! !-----------------------!
+ !
+ ! !== set the model time-step ==!
+ !
+ istp = nit000
+ !
+ ! !== Standard time-stepping ==!
+ !
+ DO WHILE( istp <= nitend .AND. nstop == 0 )
+
+ ncom_stp = istp
+ IF( ln_timing ) THEN
+ zstptiming = MPI_Wtime()
+ IF ( istp == ( nit000 + 1 ) ) elapsed_time = zstptiming
+ IF ( istp == nitend ) elapsed_time = zstptiming - elapsed_time
+ ENDIF
+#if defined key_RK3
+ CALL stp_RK3 ( istp )
+#elif defined key_qco
+ CALL stp_LF ( istp )
+#else
+ CALL stp ( istp )
+#endif
+ istp = istp + 1
+
+ IF( lwp .AND. ln_timing ) WRITE(numtime,*) 'timing step ', istp-1, ' : ', MPI_Wtime() - zstptiming
+
+ END DO
+ !
+ !
+ ! !------------------------!
+ ! !== finalize the run ==!
+ ! !------------------------!
+ IF(lwp) WRITE(numout,cform_aaa) ! Flag AAAAAAA
+ !
+ IF( nstop /= 0 .AND. lwp ) THEN ! error print
+ WRITE(ctmp1,*) ' ==>>> nemo_gcm: a total of ', nstop, ' errors have been found'
+ CALL ctl_stop( ctmp1 )
+ ENDIF
+ !
+ IF( ln_timing ) CALL timing_finalize
+ !
+ CALL nemo_closefile
+ !
+#if defined key_iomput
+ CALL xios_finalize ! end mpp communications with xios
+#else
+ IF( lk_mpp ) CALL mppstop ! end mpp communications
+#endif
+ !
+ IF(lwm) THEN
+ IF( nstop == 0 ) THEN ; STOP 0
+ ELSE ; STOP 123
+ ENDIF
+ ENDIF
+ !
+ END SUBROUTINE nemo_gcm
+
+
+ SUBROUTINE nemo_init
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE nemo_init ***
+ !!
+ !! ** Purpose : initialization of the NEMO GCM
+ !!----------------------------------------------------------------------
+ INTEGER :: ios, ilocal_comm ! local integers
+ !!
+ NAMELIST/namctl/ sn_cfctl, nn_print, nn_ictls, nn_ictle, &
+ & nn_isplt , nn_jsplt, nn_jctls, nn_jctle, &
+ & ln_timing, ln_diacfl
+ NAMELIST/namcfg/ ln_read_cfg, cn_domcfg, ln_closea, ln_write_cfg, cn_domcfg_out, ln_use_jattr
+ !!----------------------------------------------------------------------
+ !
+ cxios_context = 'nemo'
+ !
+ ! !-------------------------------------------------!
+ ! ! set communicator & select the local rank !
+ ! ! must be done as soon as possible to get narea !
+ ! !-------------------------------------------------!
+ !
+#if defined key_iomput
+ IF( Agrif_Root() ) THEN
+ IF( lk_oasis ) THEN
+ CALL cpl_init( "oceanx", ilocal_comm ) ! nemo local communicator given by oasis
+ CALL xios_initialize( "not used" , local_comm =ilocal_comm ) ! send nemo communicator to xios
+ ELSE
+ CALL xios_initialize( "for_xios_mpi_id", return_comm=ilocal_comm ) ! nemo local communicator given by xios
+ ENDIF
+ ENDIF
+ CALL mpp_start( ilocal_comm )
+#else
+ IF( lk_oasis ) THEN
+ IF( Agrif_Root() ) THEN
+ CALL cpl_init( "oceanx", ilocal_comm ) ! nemo local communicator given by oasis
+ ENDIF
+ CALL mpp_start( ilocal_comm )
+ ELSE
+ CALL mpp_start( )
+ ENDIF
+#endif
+ !
+ narea = mpprank + 1 ! mpprank: the rank of proc (0 --> mppsize -1 )
+ lwm = (narea == 1) ! control of output namelists
+ !
+ ! !---------------------------------------------------------------!
+ ! ! Open output files, reference and configuration namelist files !
+ ! !---------------------------------------------------------------!
+ !
+ ! open ocean.output as soon as possible to get all output prints (including errors messages)
+ IF( lwm ) CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. )
+ ! open reference and configuration namelist files
+ CALL load_nml( numnam_ref, 'namelist_ref', -1, lwm )
+ CALL load_nml( numnam_cfg, 'namelist_cfg', -1, lwm )
+ IF( lwm ) CALL ctl_opn( numond, 'output.namelist.dyn', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. )
+ ! open /dev/null file to be able to supress output write easily
+ CALL ctl_opn( numnul, '/dev/null', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. )
+ !
+ ! !--------------------!
+ ! ! Open listing units ! -> need sn_cfctl from namctl to define lwp
+ ! !--------------------!
+ !
+ READ ( numnam_ref, namctl, IOSTAT = ios, ERR = 901 )
+901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namctl in reference namelist' )
+ READ ( numnam_cfg, namctl, IOSTAT = ios, ERR = 902 )
+902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namctl in configuration namelist' )
+ !
+ ! finalize the definition of namctl variables
+ IF( sn_cfctl%l_allon ) THEN
+ ! Turn on all options.
+ CALL nemo_set_cfctl( sn_cfctl, .TRUE., .TRUE. )
+ ! Ensure all processors are active
+ sn_cfctl%procmin = 0 ; sn_cfctl%procmax = 1000000 ; sn_cfctl%procincr = 1
+ ELSEIF( sn_cfctl%l_config ) THEN
+ ! Activate finer control of report outputs
+ ! optionally switch off output from selected areas (note this only
+ ! applies to output which does not involve global communications)
+ IF( ( narea < sn_cfctl%procmin .OR. narea > sn_cfctl%procmax ) .OR. &
+ & ( MOD( narea - sn_cfctl%procmin, sn_cfctl%procincr ) /= 0 ) ) &
+ & CALL nemo_set_cfctl( sn_cfctl, .FALSE., .FALSE. )
+ ELSE
+ ! turn off all options.
+ CALL nemo_set_cfctl( sn_cfctl, .FALSE., .TRUE. )
+ ENDIF
+ !
+ lwp = (narea == 1) .OR. sn_cfctl%l_oceout ! control of all listing output print
+ !
+ IF(lwp) THEN ! open listing units
+ !
+ IF( .NOT. lwm ) & ! alreay opened for narea == 1
+ & CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE., narea )
+ !
+ WRITE(numout,*)
+ WRITE(numout,*) ' CNRS - NERC - Met OFFICE - MERCATOR-ocean - CMCC'
+ WRITE(numout,*) ' NEMO team'
+ WRITE(numout,*) ' Ocean General Circulation Model'
+ WRITE(numout,*) ' NEMO version 4.0 (2019) '
+ WRITE(numout,*)
+ WRITE(numout,*) " ._ ._ ._ ._ ._ "
+ WRITE(numout,*) " _.-._)`\_.-._)`\_.-._)`\_.-._)`\_.-._)`\_ "
+ WRITE(numout,*)
+ WRITE(numout,*) " o _, _, "
+ WRITE(numout,*) " o .' ( .-' / "
+ WRITE(numout,*) " o _/..._'. .' / "
+ WRITE(numout,*) " ( o .-'` ` '-./ _.' "
+ WRITE(numout,*) " ) ( o) ;= <_ ( "
+ WRITE(numout,*) " ( '-.,\\__ __.-;`\ '. ) "
+ WRITE(numout,*) " ) ) \) |`\ \) '. \ ( ( "
+ WRITE(numout,*) " ( ( \_/ '-._\ ) ) "
+ WRITE(numout,*) " ) ) jgs ` ( ( "
+ WRITE(numout,*) " ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ "
+ WRITE(numout,*)
+ !
+ WRITE(numout,cform_aaa) ! Flag AAAAAAA
+ !
+ ENDIF
+ !
+ IF(lwm) WRITE( numond, namctl )
+ !
+ ! !------------------------------------!
+ ! ! Set global domain size parameters !
+ ! !------------------------------------!
+ !
+ READ ( numnam_ref, namcfg, IOSTAT = ios, ERR = 903 )
+903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcfg in reference namelist' )
+ READ ( numnam_cfg, namcfg, IOSTAT = ios, ERR = 904 )
+904 IF( ios > 0 ) CALL ctl_nam ( ios , 'namcfg in configuration namelist' )
+ !
+ IF( ln_read_cfg ) THEN ! Read sizes in domain configuration file
+ CALL domain_cfg ( cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio )
+ ELSE ! user-defined namelist
+ CALL usr_def_nam( cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio )
+ ENDIF
+ !
+ IF(lwm) WRITE( numond, namcfg )
+ !
+ ! !-----------------------------------------!
+ ! ! mpp parameters and domain decomposition !
+ ! !-----------------------------------------!
+ CALL mpp_init
+
+ ! Now we know the dimensions of the grid and numout has been set: we can allocate arrays
+ CALL nemo_alloc()
+
+ ! Initialise time level indices
+ Nbb = 1; Nnn = 2; Naa = 3; Nrhs = Naa
+
+ ! !-------------------------------!
+ ! ! NEMO general initialization !
+ ! !-------------------------------!
+
+ CALL nemo_ctl ! Control prints
+ !
+ ! ! General initialization
+ IF( ln_timing ) CALL timing_init ! timing
+ IF( ln_timing ) CALL timing_start( 'nemo_init')
+ !
+ CALL phy_cst ! Physical constants
+
+ CALL dom_init( Nbb, Nnn, Naa, "OPA") ! Domain
+
+ IF( sn_cfctl%l_prtctl ) &
+ & CALL prt_ctl_init ! Print control
+
+ CALL istate_init( Nbb, Nnn, Naa ) ! ocean initial state (Dynamics and tracers)
+
+ ! ! external forcing
+ CALL tide_init ! tidal harmonics
+
+ CALL sbc_init( Nbb, Nnn, Naa ) ! surface boundary conditions (including sea-ice)
+
+
+ ! ! Ocean physics
+ ! ! Lateral physics
+ CALL ldf_dyn_init ! Lateral ocean momentum physics
+
+
+ ! ! Dynamics
+ CALL dyn_adv_init ! advection (vector or flux form)
+
+ CALL dyn_vor_init ! vorticity term including Coriolis
+
+ CALL dyn_ldf_init ! lateral mixing
+
+ CALL dyn_spg_init ! surface pressure gradient
+
+ ! ! Diagnostics
+ CALL flo_init( Nnn ) ! drifting Floats
+
+ IF( ln_diacfl ) CALL dia_cfl_init ! Initialise CFL diagnostics
+
+ CALL trd_init( Nnn ) ! Mixed-layer/Vorticity/Integral constraints trends
+
+
+ IF(lwp) WRITE(numout,cform_aaa) ! Flag AAAAAAA
+ !
+ IF( ln_timing ) CALL timing_stop( 'nemo_init')
+ !
+
+ END SUBROUTINE nemo_init
+
+
+ SUBROUTINE nemo_ctl
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE nemo_ctl ***
+ !!
+ !! ** Purpose : control print setting
+ !!
+ !! ** Method : - print namctl and namcfg information and check some consistencies
+ !!----------------------------------------------------------------------
+ !
+ IF(lwp) THEN ! control print
+ WRITE(numout,*)
+ WRITE(numout,*) 'nemo_ctl: Control prints'
+ WRITE(numout,*) '~~~~~~~~'
+ WRITE(numout,*) ' Namelist namctl'
+ WRITE(numout,*) ' sn_cfctl%l_glochk = ', sn_cfctl%l_glochk
+ WRITE(numout,*) ' sn_cfctl%l_allon = ', sn_cfctl%l_allon
+ WRITE(numout,*) ' finer control over o/p sn_cfctl%l_config = ', sn_cfctl%l_config
+ WRITE(numout,*) ' sn_cfctl%l_runstat = ', sn_cfctl%l_runstat
+ WRITE(numout,*) ' sn_cfctl%l_trcstat = ', sn_cfctl%l_trcstat
+ WRITE(numout,*) ' sn_cfctl%l_oceout = ', sn_cfctl%l_oceout
+ WRITE(numout,*) ' sn_cfctl%l_layout = ', sn_cfctl%l_layout
+ WRITE(numout,*) ' sn_cfctl%l_prtctl = ', sn_cfctl%l_prtctl
+ WRITE(numout,*) ' sn_cfctl%l_prttrc = ', sn_cfctl%l_prttrc
+ WRITE(numout,*) ' sn_cfctl%l_oasout = ', sn_cfctl%l_oasout
+ WRITE(numout,*) ' sn_cfctl%procmin = ', sn_cfctl%procmin
+ WRITE(numout,*) ' sn_cfctl%procmax = ', sn_cfctl%procmax
+ WRITE(numout,*) ' sn_cfctl%procincr = ', sn_cfctl%procincr
+ WRITE(numout,*) ' sn_cfctl%ptimincr = ', sn_cfctl%ptimincr
+ WRITE(numout,*) ' level of print nn_print = ', nn_print
+ WRITE(numout,*) ' Start i indice for SUM control nn_ictls = ', nn_ictls
+ WRITE(numout,*) ' End i indice for SUM control nn_ictle = ', nn_ictle
+ WRITE(numout,*) ' Start j indice for SUM control nn_jctls = ', nn_jctls
+ WRITE(numout,*) ' End j indice for SUM control nn_jctle = ', nn_jctle
+ WRITE(numout,*) ' number of proc. following i nn_isplt = ', nn_isplt
+ WRITE(numout,*) ' number of proc. following j nn_jsplt = ', nn_jsplt
+ WRITE(numout,*) ' timing by routine ln_timing = ', ln_timing
+ WRITE(numout,*) ' CFL diagnostics ln_diacfl = ', ln_diacfl
+ ENDIF
+ !
+ nprint = nn_print ! convert DOCTOR namelist names into OLD names
+ nictls = nn_ictls
+ nictle = nn_ictle
+ njctls = nn_jctls
+ njctle = nn_jctle
+ isplt = nn_isplt
+ jsplt = nn_jsplt
+
+ IF(lwp) THEN ! control print
+ WRITE(numout,*)
+ WRITE(numout,*) ' Namelist namcfg'
+ WRITE(numout,*) ' read domain configuration file ln_read_cfg = ', ln_read_cfg
+ WRITE(numout,*) ' filename to be read cn_domcfg = ', TRIM(cn_domcfg)
+ WRITE(numout,*) ' keep closed seas in the domain (if exist) ln_closea = ', ln_closea
+ WRITE(numout,*) ' create a configuration definition file ln_write_cfg = ', ln_write_cfg
+ WRITE(numout,*) ' filename to be written cn_domcfg_out = ', TRIM(cn_domcfg_out)
+ WRITE(numout,*) ' use file attribute if exists as i/p j-start ln_use_jattr = ', ln_use_jattr
+ ENDIF
+ IF( .NOT.ln_read_cfg ) ln_closea = .false. ! dealing possible only with a domcfg file
+ !
+ ! ! Parameter control
+ !
+ IF( sn_cfctl%l_prtctl .OR. sn_cfctl%l_prttrc ) THEN ! sub-domain area indices for the control prints
+ IF( lk_mpp .AND. jpnij > 1 ) THEN
+ isplt = jpni ; jsplt = jpnj ; ijsplt = jpni*jpnj ! the domain is forced to the real split domain
+ ELSE
+ IF( isplt == 1 .AND. jsplt == 1 ) THEN
+ CALL ctl_warn( ' - isplt & jsplt are equal to 1', &
+ & ' - the print control will be done over the whole domain' )
+ ENDIF
+ ijsplt = isplt * jsplt ! total number of processors ijsplt
+ ENDIF
+ IF(lwp) WRITE(numout,*)' - The total number of processors over which the'
+ IF(lwp) WRITE(numout,*)' print control will be done is ijsplt : ', ijsplt
+ !
+ ! ! indices used for the SUM control
+ IF( nictls+nictle+njctls+njctle == 0 ) THEN ! print control done over the default area
+ lsp_area = .FALSE.
+ ELSE ! print control done over a specific area
+ lsp_area = .TRUE.
+ IF( nictls < 1 .OR. nictls > jpiglo ) THEN
+ CALL ctl_warn( ' - nictls must be 1<=nictls>=jpiglo, it is forced to 1' )
+ nictls = 1
+ ENDIF
+ IF( nictle < 1 .OR. nictle > jpiglo ) THEN
+ CALL ctl_warn( ' - nictle must be 1<=nictle>=jpiglo, it is forced to jpiglo' )
+ nictle = jpiglo
+ ENDIF
+ IF( njctls < 1 .OR. njctls > jpjglo ) THEN
+ CALL ctl_warn( ' - njctls must be 1<=njctls>=jpjglo, it is forced to 1' )
+ njctls = 1
+ ENDIF
+ IF( njctle < 1 .OR. njctle > jpjglo ) THEN
+ CALL ctl_warn( ' - njctle must be 1<=njctle>=jpjglo, it is forced to jpjglo' )
+ njctle = jpjglo
+ ENDIF
+ ENDIF
+ ENDIF
+ !
+ IF( 1._wp /= SIGN(1._wp,-0._wp) ) CALL ctl_stop( 'nemo_ctl: The intrinsec SIGN function follows f2003 standard.', &
+ & 'Compile with key_nosignedzero enabled:', &
+ & '--> add -Dkey_nosignedzero to the definition of %CPP in your arch file' )
+ !
+#if defined key_agrif
+ IF( ln_timing ) CALL ctl_stop( 'AGRIF not implemented with ln_timing = true')
+#endif
+ !
+ END SUBROUTINE nemo_ctl
+
+
+ SUBROUTINE nemo_closefile
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE nemo_closefile ***
+ !!
+ !! ** Purpose : Close the files
+ !!----------------------------------------------------------------------
+ !
+ IF( lk_mpp ) CALL mppsync
+ !
+ CALL iom_close ! close all input/output files managed by iom_*
+ !
+ IF( numstp /= -1 ) CLOSE( numstp ) ! time-step file
+ IF( numrun /= -1 ) CLOSE( numrun ) ! run statistics file
+ IF( lwm.AND.numond /= -1 ) CLOSE( numond ) ! oce output namelist
+ IF( lwm.AND.numoni /= -1 ) CLOSE( numoni ) ! ice output namelist
+ IF( numevo_ice /= -1 ) CLOSE( numevo_ice ) ! ice variables (temp. evolution)
+ IF( numout /= 6 ) CLOSE( numout ) ! standard model output file
+ IF( numdct_vol /= -1 ) CLOSE( numdct_vol ) ! volume transports
+ IF( numdct_heat /= -1 ) CLOSE( numdct_heat ) ! heat transports
+ IF( numdct_salt /= -1 ) CLOSE( numdct_salt ) ! salt transports
+ !
+ numout = 6 ! redefine numout in case it is used after this point...
+ !
+ END SUBROUTINE nemo_closefile
+
+
+ SUBROUTINE nemo_alloc
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE nemo_alloc ***
+ !!
+ !! ** Purpose : Allocate all the dynamic arrays of the OPA modules
+ !!
+ !! ** Method :
+ !!----------------------------------------------------------------------
+ USE diawri , ONLY : dia_wri_alloc
+ USE dom_oce , ONLY : dom_oce_alloc
+ USE trc_oce , ONLY : trc_oce_alloc
+ USE bdy_oce , ONLY : bdy_oce_alloc
+ !
+ INTEGER :: ierr
+ !!----------------------------------------------------------------------
+ !
+ ierr = oce_alloc () ! ocean
+ ierr = ierr + dia_wri_alloc()
+ ierr = ierr + dom_oce_alloc() ! ocean domain
+ ierr = ierr + zdf_oce_alloc() ! ocean vertical physics
+ ierr = ierr + trc_oce_alloc() ! shared TRC / TRA arrays
+ ierr = ierr + bdy_oce_alloc() ! bdy masks (incl. initialization)
+ !
+ CALL mpp_sum( 'nemogcm', ierr )
+ IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'nemo_alloc: unable to allocate standard ocean arrays' )
+ !
+ END SUBROUTINE nemo_alloc
+
+
+ SUBROUTINE nemo_set_cfctl(sn_cfctl, setto, for_all )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE nemo_set_cfctl ***
+ !!
+ !! ** Purpose : Set elements of the output control structure to setto.
+ !! for_all should be .false. unless all areas are to be
+ !! treated identically.
+ !!
+ !! ** Method : Note this routine can be used to switch on/off some
+ !! types of output for selected areas but any output types
+ !! that involve global communications (e.g. mpp_max, glob_sum)
+ !! should be protected from selective switching by the
+ !! for_all argument
+ !!----------------------------------------------------------------------
+ LOGICAL :: setto, for_all
+ TYPE(sn_ctl) :: sn_cfctl
+ !!----------------------------------------------------------------------
+ IF( for_all ) THEN
+ sn_cfctl%l_runstat = setto
+ sn_cfctl%l_trcstat = setto
+ ENDIF
+ sn_cfctl%l_oceout = setto
+ sn_cfctl%l_layout = setto
+ sn_cfctl%l_prtctl = setto
+ sn_cfctl%l_prttrc = setto
+ sn_cfctl%l_oasout = setto
+ END SUBROUTINE nemo_set_cfctl
+
+ !!======================================================================
+END MODULE nemogcm
+
Index: /NEMO/branches/2020/r12377_ticket2386/src/SWE/phycst.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/SWE/phycst.F90 (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/src/SWE/phycst.F90 (revision 13540)
@@ -0,0 +1,148 @@
+MODULE phycst
+ !!======================================================================
+ !! *** MODULE phycst ***
+ !! Definition of of both ocean and ice parameters used in the code
+ !!=====================================================================
+ !! History : OPA ! 1990-10 (C. Levy - G. Madec) Original code
+ !! 8.1 ! 1991-11 (G. Madec, M. Imbard) cosmetic changes
+ !! NEMO 1.0 ! 2002-08 (G. Madec, C. Ethe) F90, add ice constants
+ !! - ! 2006-08 (G. Madec) style
+ !! 3.2 ! 2006-08 (S. Masson, G. Madec) suppress useless variables + style
+ !! 3.4 ! 2011-11 (C. Harris) minor changes for CICE constants
+ !!----------------------------------------------------------------------
+
+ !!----------------------------------------------------------------------
+ !! phy_cst : define and print physical constant and domain parameters
+ !!----------------------------------------------------------------------
+ USE par_oce ! ocean parameters
+ USE in_out_manager ! I/O manager
+
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC phy_cst ! routine called by inipar.F90
+
+ REAL(wp), PUBLIC :: rpi = 3.141592653589793_wp !: pi
+ REAL(wp), PUBLIC :: rad = 3.141592653589793_wp / 180._wp !: conversion from degre into radian
+ REAL(wp), PUBLIC :: rsmall = 0.5 * EPSILON( 1.e0 ) !: smallest real computer value
+
+ REAL(wp), PUBLIC :: rday = 24.*60.*60. !: day [s]
+ REAL(wp), PUBLIC :: rsiyea !: sideral year [s]
+ REAL(wp), PUBLIC :: rsiday !: sideral day [s]
+ REAL(wp), PUBLIC :: raamo = 12._wp !: number of months in one year
+ REAL(wp), PUBLIC :: rjjhh = 24._wp !: number of hours in one day
+ REAL(wp), PUBLIC :: rhhmm = 60._wp !: number of minutes in one hour
+ REAL(wp), PUBLIC :: rmmss = 60._wp !: number of seconds in one minute
+ REAL(wp), PUBLIC :: omega !: earth rotation parameter [s-1]
+ REAL(wp), PUBLIC :: ra = 6371229._wp !: earth radius [m]
+ REAL(wp), PUBLIC :: grav = 9.80665_wp !: gravity [m/s2]
+ REAL(wp), PUBLIC :: rt0 = 273.15_wp !: freezing point of fresh water [Kelvin]
+
+ REAL(wp), PUBLIC :: rho0 !: volumic mass of reference [kg/m3]
+ REAL(wp), PUBLIC :: r1_rho0 !: = 1. / rho0 [m3/kg]
+ REAL(wp), PUBLIC :: rcp !: ocean specific heat [J/Kelvin]
+ REAL(wp), PUBLIC :: r1_rcp !: = 1. / rcp [Kelvin/J]
+ REAL(wp), PUBLIC :: rho0_rcp !: = rho0 * rcp
+ REAL(wp), PUBLIC :: r1_rho0_rcp !: = 1. / ( rho0 * rcp )
+
+ REAL(wp), PUBLIC :: emic = 0.97_wp !: emissivity of snow or ice (not used?)
+
+ REAL(wp), PUBLIC :: sice = 6.0_wp !: salinity of ice (for pisces) [psu]
+ REAL(wp), PUBLIC :: soce = 34.7_wp !: salinity of sea (for pisces and isf) [psu]
+ REAL(wp), PUBLIC :: rLevap = 2.5e+6_wp !: latent heat of evaporation (water)
+ REAL(wp), PUBLIC :: vkarmn = 0.4_wp !: von Karman constant
+ REAL(wp), PUBLIC :: stefan = 5.67e-8_wp !: Stefan-Boltzmann constant
+
+ REAL(wp), PUBLIC :: rhos = 330._wp !: volumic mass of snow [kg/m3]
+ REAL(wp), PUBLIC :: rhoi = 917._wp !: volumic mass of sea ice [kg/m3]
+ REAL(wp), PUBLIC :: rhow = 1000._wp !: volumic mass of freshwater in melt ponds [kg/m3]
+ REAL(wp), PUBLIC :: rcnd_i = 2.034396_wp !: thermal conductivity of fresh ice [W/m/K]
+ REAL(wp), PUBLIC :: rcpi = 2067.0_wp !: specific heat of fresh ice [J/kg/K]
+ REAL(wp), PUBLIC :: rLsub = 2.834e+6_wp !: pure ice latent heat of sublimation [J/kg]
+ REAL(wp), PUBLIC :: rLfus = 0.334e+6_wp !: latent heat of fusion of fresh ice [J/kg]
+ REAL(wp), PUBLIC :: rTmlt = 0.054_wp !: decrease of seawater meltpoint with salinity
+
+ REAL(wp), PUBLIC :: r1_rhoi !: 1 / rhoi
+ REAL(wp), PUBLIC :: r1_rhos !: 1 / rhos
+ REAL(wp), PUBLIC :: r1_rcpi !: 1 / rcpi
+
+ !!----------------------------------------------------------------------
+ !! NEMO/OCE 4.0 , NEMO Consortium (2018)
+ !! $Id: phycst.F90 12614 2020-03-26 14:59:52Z gm $
+ !! Software governed by the CeCILL license (see ./LICENSE)
+ !!----------------------------------------------------------------------
+
+CONTAINS
+
+ SUBROUTINE phy_cst
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE phy_cst ***
+ !!
+ !! ** Purpose : set and print the constants
+ !!----------------------------------------------------------------------
+
+ rsiyea = 365.25_wp * rday * 2._wp * rpi / 6.283076_wp
+ rsiday = rday / ( 1._wp + rday / rsiyea )
+#if defined key_cice
+ omega = 7.292116e-05
+#else
+ omega = 2._wp * rpi / rsiday
+#endif
+
+ r1_rhoi = 1._wp / rhoi
+ r1_rhos = 1._wp / rhos
+ r1_rcpi = 1._wp / rcpi
+ !
+ rho0 = 1026._wp !: volumic mass of reference [kg/m3]
+ rcp = 3991.86795711963_wp !: heat capacity [J/K]
+ !
+ rho0_rcp = rho0 * rcp
+ r1_rho0 = 1._wp / rho0
+ r1_rcp = 1._wp / rcp
+ r1_rho0_rcp = 1._wp / rho0_rcp
+ !
+ IF(lwp) THEN
+ WRITE(numout,*)
+ WRITE(numout,*) 'phy_cst : initialization of ocean parameters and constants'
+ WRITE(numout,*) '~~~~~~~'
+ WRITE(numout,*) ' mathematical constant rpi = ', rpi
+ WRITE(numout,*) ' day rday = ', rday, ' s'
+ WRITE(numout,*) ' sideral year rsiyea = ', rsiyea, ' s'
+ WRITE(numout,*) ' sideral day rsiday = ', rsiday, ' s'
+ WRITE(numout,*) ' omega omega = ', omega, ' s^-1'
+ WRITE(numout,*)
+ WRITE(numout,*) ' nb of months per year raamo = ', raamo, ' months'
+ WRITE(numout,*) ' nb of hours per day rjjhh = ', rjjhh, ' hours'
+ WRITE(numout,*) ' nb of minutes per hour rhhmm = ', rhhmm, ' mn'
+ WRITE(numout,*) ' nb of seconds per minute rmmss = ', rmmss, ' s'
+ WRITE(numout,*)
+ WRITE(numout,*) ' earth radius ra = ', ra , ' m'
+ WRITE(numout,*) ' gravity grav = ', grav , ' m/s^2'
+ WRITE(numout,*)
+ WRITE(numout,*) ' freezing point of water rt0 = ', rt0 , ' K'
+ WRITE(numout,*)
+ WRITE(numout,*) ' reference density and heat capacity now defined in eosbn2.f90'
+ WRITE(numout,*)
+ WRITE(numout,*) ' thermal conductivity of pure ice = ', rcnd_i , ' J/s/m/K'
+ WRITE(numout,*) ' thermal conductivity of snow is defined in a namelist '
+ WRITE(numout,*) ' fresh ice specific heat = ', rcpi , ' J/kg/K'
+ WRITE(numout,*) ' latent heat of fusion of fresh ice / snow = ', rLfus , ' J/kg'
+ WRITE(numout,*) ' latent heat of subl. of fresh ice / snow = ', rLsub , ' J/kg'
+ WRITE(numout,*) ' density of sea ice = ', rhoi , ' kg/m^3'
+ WRITE(numout,*) ' density of snow = ', rhos , ' kg/m^3'
+ WRITE(numout,*) ' density of freshwater (in melt ponds) = ', rhow , ' kg/m^3'
+ WRITE(numout,*) ' salinity of ice (for pisces) = ', sice , ' psu'
+ WRITE(numout,*) ' salinity of sea (for pisces and isf) = ', soce , ' psu'
+ WRITE(numout,*) ' latent heat of evaporation (water) = ', rLevap , ' J/m^3'
+ WRITE(numout,*) ' von Karman constant = ', vkarmn
+ WRITE(numout,*) ' Stefan-Boltzmann constant = ', stefan , ' J/s/m^2/K^4'
+ WRITE(numout,*)
+ WRITE(numout,*) ' conversion: degre ==> radian rad = ', rad
+ WRITE(numout,*)
+ WRITE(numout,*) ' smallest real computer value rsmall = ', rsmall
+ ENDIF
+
+ END SUBROUTINE phy_cst
+
+ !!======================================================================
+END MODULE phycst
Index: /NEMO/branches/2020/r12377_ticket2386/src/SWE/sbcice_cice.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/SWE/sbcice_cice.F90 (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/src/SWE/sbcice_cice.F90 (revision 13540)
@@ -0,0 +1,1060 @@
+MODULE sbcice_cice
+ !!======================================================================
+ !! *** MODULE sbcice_cice ***
+ !! To couple with sea ice model CICE (LANL)
+ !!=====================================================================
+#if defined key_cice
+ !!----------------------------------------------------------------------
+ !! 'key_cice' : CICE sea-ice model
+ !!----------------------------------------------------------------------
+ !! sbc_ice_cice : sea-ice model time-stepping and update ocean sbc over ice-covered area
+ !!----------------------------------------------------------------------
+ USE oce ! ocean dynamics and tracers
+ USE dom_oce ! ocean space and time domain
+!!st8
+# if ! defined key_qco
+ USE domvvl
+# else
+ USE domqco
+# endif
+!!st8
+ USE phycst, only : rcp, rho0, r1_rho0, rhos, rhoi
+ USE in_out_manager ! I/O manager
+ USE iom, ONLY : iom_put,iom_use ! I/O manager library !!Joakim edit
+ USE lib_mpp ! distributed memory computing library
+ USE lbclnk ! ocean lateral boundary conditions (or mpp link)
+ USE daymod ! calendar
+ USE fldread ! read input fields
+ USE sbc_oce ! Surface boundary condition: ocean fields
+ USE sbc_ice ! Surface boundary condition: ice fields
+ USE sbcblk ! Surface boundary condition: bulk
+ USE sbccpl
+
+ USE ice_kinds_mod
+ USE ice_blocks
+ USE ice_domain
+ USE ice_domain_size
+ USE ice_boundary
+ USE ice_constants
+ USE ice_gather_scatter
+ USE ice_calendar, only: dt
+ USE ice_state, only: aice,aicen,uvel,vvel,vsno,vsnon,vice,vicen
+# if defined key_cice4
+ USE ice_flux, only: strax,stray,strocnx,strocny,frain,fsnow, &
+ strocnxT,strocnyT, &
+ sst,sss,uocn,vocn,ss_tltx,ss_tlty,fsalt_gbm, &
+ fresh_gbm,fhocn_gbm,fswthru_gbm,frzmlt, &
+ flatn_f,fsurfn_f,fcondtopn_f, &
+ uatm,vatm,wind,fsw,flw,Tair,potT,Qa,rhoa,zlvl, &
+ swvdr,swvdf,swidr,swidf
+ USE ice_therm_vertical, only: calc_Tsfc
+#else
+ USE ice_flux, only: strax,stray,strocnx,strocny,frain,fsnow, &
+ strocnxT,strocnyT, &
+ sst,sss,uocn,vocn,ss_tltx,ss_tlty,fsalt_ai, &
+ fresh_ai,fhocn_ai,fswthru_ai,frzmlt, &
+ flatn_f,fsurfn_f,fcondtopn_f, &
+ uatm,vatm,wind,fsw,flw,Tair,potT,Qa,rhoa,zlvl, &
+ swvdr,swvdf,swidr,swidf
+ USE ice_therm_shared, only: calc_Tsfc
+#endif
+ USE ice_forcing, only: frcvdr,frcvdf,frcidr,frcidf
+ USE ice_atmo, only: calc_strair
+
+ USE CICE_InitMod
+ USE CICE_RunMod
+ USE CICE_FinalMod
+
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC cice_sbc_init ! routine called by sbc_init
+ PUBLIC cice_sbc_final ! routine called by sbc_final
+ PUBLIC sbc_ice_cice ! routine called by sbc
+
+ INTEGER :: ji_off
+ INTEGER :: jj_off
+
+ INTEGER , PARAMETER :: jpfld = 13 ! maximum number of files to read
+ INTEGER , PARAMETER :: jp_snow = 1 ! index of snow file
+ INTEGER , PARAMETER :: jp_rain = 2 ! index of rain file
+ INTEGER , PARAMETER :: jp_sblm = 3 ! index of sublimation file
+ INTEGER , PARAMETER :: jp_top1 = 4 ! index of category 1 topmelt file
+ INTEGER , PARAMETER :: jp_top2 = 5 ! index of category 2 topmelt file
+ INTEGER , PARAMETER :: jp_top3 = 6 ! index of category 3 topmelt file
+ INTEGER , PARAMETER :: jp_top4 = 7 ! index of category 4 topmelt file
+ INTEGER , PARAMETER :: jp_top5 = 8 ! index of category 5 topmelt file
+ INTEGER , PARAMETER :: jp_bot1 = 9 ! index of category 1 botmelt file
+ INTEGER , PARAMETER :: jp_bot2 = 10 ! index of category 2 botmelt file
+ INTEGER , PARAMETER :: jp_bot3 = 11 ! index of category 3 botmelt file
+ INTEGER , PARAMETER :: jp_bot4 = 12 ! index of category 4 botmelt file
+ INTEGER , PARAMETER :: jp_bot5 = 13 ! index of category 5 botmelt file
+ TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf ! structure of input fields (file informations, fields read)
+
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:), PRIVATE :: png ! local array used in sbc_cice_ice
+
+ !! * Substitutions
+# include "do_loop_substitute.h90"
+ !!----------------------------------------------------------------------
+ !! NEMO/OCE 4.0 , NEMO Consortium (2018)
+ !! $Id: sbcice_cice.F90 12614 2020-03-26 14:59:52Z gm $
+ !! Software governed by the CeCILL license (see ./LICENSE)
+ !!----------------------------------------------------------------------
+CONTAINS
+
+ INTEGER FUNCTION sbc_ice_cice_alloc()
+ !!----------------------------------------------------------------------
+ !! *** FUNCTION sbc_ice_cice_alloc ***
+ !!----------------------------------------------------------------------
+ ALLOCATE( png(jpi,jpj,jpnij), STAT=sbc_ice_cice_alloc )
+ CALL mpp_sum ( 'sbcice_cice', sbc_ice_cice_alloc )
+ IF( sbc_ice_cice_alloc > 0 ) CALL ctl_warn('sbc_ice_cice_alloc: allocation of arrays failed.')
+ END FUNCTION sbc_ice_cice_alloc
+
+ SUBROUTINE sbc_ice_cice( kt, ksbc )
+ !!---------------------------------------------------------------------
+ !! *** ROUTINE sbc_ice_cice ***
+ !!
+ !! ** Purpose : update the ocean surface boundary condition via the
+ !! CICE Sea Ice Model time stepping
+ !!
+ !! ** Method : - Get any extra forcing fields for CICE
+ !! - Prepare forcing fields
+ !! - CICE model time stepping
+ !! - call the routine that computes mass and
+ !! heat fluxes at the ice/ocean interface
+ !!
+ !! ** Action : - time evolution of the CICE sea-ice model
+ !! - update all sbc variables below sea-ice:
+ !! utau, vtau, qns , qsr, emp , sfx
+ !!---------------------------------------------------------------------
+ INTEGER, INTENT(in) :: kt ! ocean time step
+ INTEGER, INTENT(in) :: ksbc ! surface forcing type
+ !!----------------------------------------------------------------------
+ !
+ ! !----------------------!
+ IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN ! Ice time-step only !
+ ! !----------------------!
+
+ ! Make sure any fluxes required for CICE are set
+ IF ( ksbc == jp_flx ) THEN
+ CALL cice_sbc_force(kt)
+ ELSE IF( ksbc == jp_purecpl ) THEN
+ CALL sbc_cpl_ice_flx( fr_i )
+ ENDIF
+
+ CALL cice_sbc_in ( kt, ksbc )
+ CALL CICE_Run
+ CALL cice_sbc_out ( kt, ksbc )
+
+ IF( ksbc == jp_purecpl ) CALL cice_sbc_hadgam(kt+1)
+
+ ENDIF ! End sea-ice time step only
+ !
+ END SUBROUTINE sbc_ice_cice
+
+
+ SUBROUTINE cice_sbc_init( ksbc, Kbb, Kmm )
+ !!---------------------------------------------------------------------
+ !! *** ROUTINE cice_sbc_init ***
+ !! ** Purpose: Initialise ice related fields for NEMO and coupling
+ !!
+ !!---------------------------------------------------------------------
+ INTEGER, INTENT( in ) :: ksbc ! surface forcing type
+ INTEGER, INTENT( in ) :: Kbb, Kmm ! time level indices
+ REAL(wp), DIMENSION(jpi,jpj) :: ztmp1, ztmp2
+ REAL(wp) :: zcoefu, zcoefv, zcoeff ! local scalar
+ INTEGER :: ji, jj, jl, jk ! dummy loop indices
+ !!---------------------------------------------------------------------
+ !
+ IF(lwp) WRITE(numout,*)'cice_sbc_init'
+
+ ji_off = INT ( (jpiglo - nx_global) / 2 )
+ jj_off = INT ( (jpjglo - ny_global) / 2 )
+
+#if defined key_nemocice_decomp
+ ! Pass initial SST from NEMO to CICE so ice is initialised correctly if
+ ! there is no restart file.
+ ! Values from a CICE restart file would overwrite this
+ IF( .NOT. ln_rstart ) THEN
+ CALL nemo2cice( ts(:,:,1,jp_tem,Kmm) , sst , 'T' , 1.)
+ ENDIF
+#endif
+
+! Initialize CICE
+ CALL CICE_Initialize
+
+! Do some CICE consistency checks
+ IF( (ksbc == jp_flx) .OR. (ksbc == jp_purecpl) ) THEN
+ IF( calc_strair .OR. calc_Tsfc ) THEN
+ CALL ctl_stop( 'STOP', 'cice_sbc_init : Forcing option requires calc_strair=F and calc_Tsfc=F in ice_in' )
+ ENDIF
+ ELSEIF(ksbc == jp_blk) THEN
+ IF( .NOT. (calc_strair .AND. calc_Tsfc) ) THEN
+ CALL ctl_stop( 'STOP', 'cice_sbc_init : Forcing option requires calc_strair=T and calc_Tsfc=T in ice_in' )
+ ENDIF
+ ENDIF
+
+
+! allocate sbc_ice and sbc_cice arrays
+ IF( sbc_ice_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_ice_cice_alloc : unable to allocate arrays' )
+ IF( sbc_ice_cice_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_ice_cice_alloc : unable to allocate cice arrays' )
+
+! Ensure ocean temperatures are nowhere below freezing if not a NEMO restart
+ IF( .NOT. ln_rstart ) THEN
+ ts(:,:,:,jp_tem,Kmm) = MAX (ts(:,:,:,jp_tem,Kmm),Tocnfrz)
+ ts(:,:,:,jp_tem,Kbb) = ts(:,:,:,jp_tem,Kmm)
+ ENDIF
+
+ fr_iu(:,:)=0.0
+ fr_iv(:,:)=0.0
+
+ CALL cice2nemo(aice,fr_i, 'T', 1. )
+ IF( (ksbc == jp_flx) .OR. (ksbc == jp_purecpl) ) THEN
+ DO jl=1,ncat
+ CALL cice2nemo(aicen(:,:,jl,:),a_i(:,:,jl), 'T', 1. )
+ ENDDO
+ ENDIF
+
+! T point to U point
+! T point to V point
+ DO_2D( 1, 0, 1, 0 )
+ fr_iu(ji,jj)=0.5*(fr_i(ji,jj)+fr_i(ji+1,jj))*umask(ji,jj,1)
+ fr_iv(ji,jj)=0.5*(fr_i(ji,jj)+fr_i(ji,jj+1))*vmask(ji,jj,1)
+ END_2D
+
+ CALL lbc_lnk_multi( 'sbcice_cice', fr_iu , 'U', 1., fr_iv , 'V', 1. )
+
+ ! set the snow+ice mass
+ CALL cice2nemo(vsno(:,:,:),ztmp1,'T', 1. )
+ CALL cice2nemo(vice(:,:,:),ztmp2,'T', 1. )
+ snwice_mass (:,:) = ( rhos * ztmp1(:,:) + rhoi * ztmp2(:,:) )
+ snwice_mass_b(:,:) = snwice_mass(:,:)
+
+ IF( .NOT.ln_rstart ) THEN
+ IF( ln_ice_embd ) THEN ! embedded sea-ice: deplete the initial ssh below sea-ice area
+ ssh(:,:,Kmm) = ssh(:,:,Kmm) - snwice_mass(:,:) * r1_rho0
+ ssh(:,:,Kbb) = ssh(:,:,Kbb) - snwice_mass(:,:) * r1_rho0
+
+!!gm This should be put elsewhere.... (same remark for limsbc)
+!!gm especially here it is assumed zstar coordinate, but it can be ztilde....
+!!st9
+#if defined key_qco
+ IF( .NOT.ln_linssh ) CALL dom_qco_zgr( Kbb, Kmm, Kaa ) ! 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) )
+ END DO
+ e3t(:,:,:,Krhs) = e3t(:,:,:,Kbb)
+ ! Reconstruction of all vertical scale factors at now and before time-steps
+ ! =============================================================================
+ ! Horizontal scale factor interpolations
+ ! --------------------------------------
+ CALL dom_vvl_interpol( ssh(:,:,Kbb), e3u(:,:,:,Kbb), 'U' )
+ CALL dom_vvl_interpol( ssh(:,:,Kbb), e3v(:,:,:,Kbb), 'V' )
+ CALL dom_vvl_interpol( ssh(:,:,Kmm), e3u(:,:,:,Kmm), 'U' )
+ CALL dom_vvl_interpol( ssh(:,:,Kmm), e3v(:,:,:,Kmm), 'V' )
+ CALL dom_vvl_interpol( ssh(:,:,Kmm), e3f(:,:,:), 'F' )
+ ! Vertical scale factor interpolations
+ ! ------------------------------------
+ CALL dom_vvl_interpol( ssh(:,:,Kmm), e3w (:,:,:,Kmm), 'W' )
+ CALL dom_vvl_interpol( ssh(:,:,Kmm), e3uw(:,:,:,Kmm), 'UW' )
+ CALL dom_vvl_interpol( ssh(:,:,Kmm), e3vw(:,:,:,Kmm), 'VW' )
+ CALL dom_vvl_interpol( ssh(:,:,Kbb), e3uw(:,:,:,Kbb), 'UW' )
+ CALL dom_vvl_interpol( ssh(:,:,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
+#endif
+!!st9
+ ENDIF
+ ENDIF
+ !
+ END SUBROUTINE cice_sbc_init
+
+
+ SUBROUTINE cice_sbc_in( kt, ksbc )
+ !!---------------------------------------------------------------------
+ !! *** ROUTINE cice_sbc_in ***
+ !! ** Purpose: Set coupling fields and pass to CICE
+ !!---------------------------------------------------------------------
+ INTEGER, INTENT(in ) :: kt ! ocean time step
+ INTEGER, INTENT(in ) :: ksbc ! surface forcing type
+ !
+ INTEGER :: ji, jj, jl ! dummy loop indices
+ REAL(wp), DIMENSION(jpi,jpj) :: ztmp, zpice
+ REAL(wp), DIMENSION(jpi,jpj,ncat) :: ztmpn
+ REAL(wp) :: zintb, zintn ! dummy argument
+ !!---------------------------------------------------------------------
+ !
+ IF( kt == nit000 ) THEN
+ IF(lwp) WRITE(numout,*)'cice_sbc_in'
+ ENDIF
+
+ ztmp(:,:)=0.0
+
+! Aggregate ice concentration already set in cice_sbc_out (or cice_sbc_init on
+! the first time-step)
+
+! forced and coupled case
+
+ IF( (ksbc == jp_flx).OR.(ksbc == jp_purecpl) ) THEN
+
+ ztmpn(:,:,:)=0.0
+
+! x comp of wind stress (CI_1)
+! U point to F point
+ DO_2D( 1, 0, 1, 1 )
+ ztmp(ji,jj) = 0.5 * ( fr_iu(ji,jj) * utau(ji,jj) &
+ + fr_iu(ji,jj+1) * utau(ji,jj+1) ) * fmask(ji,jj,1)
+ END_2D
+ CALL nemo2cice(ztmp,strax,'F', -1. )
+
+! y comp of wind stress (CI_2)
+! V point to F point
+ DO_2D( 1, 1, 1, 0 )
+ ztmp(ji,jj) = 0.5 * ( fr_iv(ji,jj) * vtau(ji,jj) &
+ + fr_iv(ji+1,jj) * vtau(ji+1,jj) ) * fmask(ji,jj,1)
+ END_2D
+ CALL nemo2cice(ztmp,stray,'F', -1. )
+
+! Surface downward latent heat flux (CI_5)
+ IF(ksbc == jp_flx) THEN
+ DO jl=1,ncat
+ ztmpn(:,:,jl)=qla_ice(:,:,1)*a_i(:,:,jl)
+ ENDDO
+ ELSE
+! emp_ice is set in sbc_cpl_ice_flx as sublimation-snow
+ qla_ice(:,:,1)= - ( emp_ice(:,:)+sprecip(:,:) ) * rLsub
+! End of temporary code
+ DO_2D( 1, 1, 1, 1 )
+ IF(fr_i(ji,jj).eq.0.0) THEN
+ DO jl=1,ncat
+ ztmpn(ji,jj,jl)=0.0
+ ENDDO
+ ! This will then be conserved in CICE
+ ztmpn(ji,jj,1)=qla_ice(ji,jj,1)
+ ELSE
+ DO jl=1,ncat
+ ztmpn(ji,jj,jl)=qla_ice(ji,jj,1)*a_i(ji,jj,jl)/fr_i(ji,jj)
+ ENDDO
+ ENDIF
+ END_2D
+ ENDIF
+ DO jl=1,ncat
+ CALL nemo2cice(ztmpn(:,:,jl),flatn_f(:,:,jl,:),'T', 1. )
+
+! GBM conductive flux through ice (CI_6)
+! Convert to GBM
+ IF(ksbc == jp_flx) THEN
+ ztmp(:,:) = botmelt(:,:,jl)*a_i(:,:,jl)
+ ELSE
+ ztmp(:,:) = botmelt(:,:,jl)
+ ENDIF
+ CALL nemo2cice(ztmp,fcondtopn_f(:,:,jl,:),'T', 1. )
+
+! GBM surface heat flux (CI_7)
+! Convert to GBM
+ IF(ksbc == jp_flx) THEN
+ ztmp(:,:) = (topmelt(:,:,jl)+botmelt(:,:,jl))*a_i(:,:,jl)
+ ELSE
+ ztmp(:,:) = (topmelt(:,:,jl)+botmelt(:,:,jl))
+ ENDIF
+ CALL nemo2cice(ztmp,fsurfn_f(:,:,jl,:),'T', 1. )
+ ENDDO
+
+ ELSE IF(ksbc == jp_blk) THEN
+
+! Pass bulk forcing fields to CICE (which will calculate heat fluxes etc itself)
+! x comp and y comp of atmosphere surface wind (CICE expects on T points)
+ ztmp(:,:) = wndi_ice(:,:)
+ CALL nemo2cice(ztmp,uatm,'T', -1. )
+ ztmp(:,:) = wndj_ice(:,:)
+ CALL nemo2cice(ztmp,vatm,'T', -1. )
+ ztmp(:,:) = SQRT ( wndi_ice(:,:)**2 + wndj_ice(:,:)**2 )
+ CALL nemo2cice(ztmp,wind,'T', 1. ) ! Wind speed (m/s)
+ ztmp(:,:) = qsr_ice(:,:,1)
+ CALL nemo2cice(ztmp,fsw,'T', 1. ) ! Incoming short-wave (W/m^2)
+ ztmp(:,:) = qlw_ice(:,:,1)
+ CALL nemo2cice(ztmp,flw,'T', 1. ) ! Incoming long-wave (W/m^2)
+ ztmp(:,:) = tatm_ice(:,:)
+ CALL nemo2cice(ztmp,Tair,'T', 1. ) ! Air temperature (K)
+ CALL nemo2cice(ztmp,potT,'T', 1. ) ! Potential temp (K)
+! Following line uses MAX(....) to avoid problems if tatm_ice has unset halo rows
+ ztmp(:,:) = 101000. / ( 287.04 * MAX(1.0,tatm_ice(:,:)) )
+ ! Constant (101000.) atm pressure assumed
+ CALL nemo2cice(ztmp,rhoa,'T', 1. ) ! Air density (kg/m^3)
+ ztmp(:,:) = qatm_ice(:,:)
+ CALL nemo2cice(ztmp,Qa,'T', 1. ) ! Specific humidity (kg/kg)
+ ztmp(:,:)=10.0
+ CALL nemo2cice(ztmp,zlvl,'T', 1. ) ! Atmos level height (m)
+
+! May want to check all values are physically realistic (as in CICE routine
+! prepare_forcing)?
+
+! Divide shortwave into spectral bands (as in prepare_forcing)
+ ztmp(:,:)=qsr_ice(:,:,1)*frcvdr ! visible direct
+ CALL nemo2cice(ztmp,swvdr,'T', 1. )
+ ztmp(:,:)=qsr_ice(:,:,1)*frcvdf ! visible diffuse
+ CALL nemo2cice(ztmp,swvdf,'T', 1. )
+ ztmp(:,:)=qsr_ice(:,:,1)*frcidr ! near IR direct
+ CALL nemo2cice(ztmp,swidr,'T', 1. )
+ ztmp(:,:)=qsr_ice(:,:,1)*frcidf ! near IR diffuse
+ CALL nemo2cice(ztmp,swidf,'T', 1. )
+
+ ENDIF
+
+! Snowfall
+! Ensure fsnow is positive (as in CICE routine prepare_forcing)
+ IF( iom_use('snowpre') ) CALL iom_put('snowpre',MAX( (1.0-fr_i(:,:))*sprecip(:,:) ,0.0)) !!Joakim edit
+ ztmp(:,:)=MAX(fr_i(:,:)*sprecip(:,:),0.0)
+ CALL nemo2cice(ztmp,fsnow,'T', 1. )
+
+! Rainfall
+ IF( iom_use('precip') ) CALL iom_put('precip', (1.0-fr_i(:,:))*(tprecip(:,:)-sprecip(:,:)) ) !!Joakim edit
+ ztmp(:,:)=fr_i(:,:)*(tprecip(:,:)-sprecip(:,:))
+ CALL nemo2cice(ztmp,frain,'T', 1. )
+
+! Freezing/melting potential
+! Calculated over NEMO leapfrog timestep (hence 2*dt)
+ nfrzmlt(:,:) = rho0 * rcp * e3t_m(:,:) * ( Tocnfrz-sst_m(:,:) ) / ( 2.0*dt )
+
+ ztmp(:,:) = nfrzmlt(:,:)
+ CALL nemo2cice(ztmp,frzmlt,'T', 1. )
+
+! SST and SSS
+
+ CALL nemo2cice(sst_m,sst,'T', 1. )
+ CALL nemo2cice(sss_m,sss,'T', 1. )
+
+! x comp and y comp of surface ocean current
+! U point to F point
+ DO_2D( 1, 0, 1, 1 )
+ ztmp(ji,jj)=0.5*(ssu_m(ji,jj)+ssu_m(ji,jj+1))*fmask(ji,jj,1)
+ END_2D
+ CALL nemo2cice(ztmp,uocn,'F', -1. )
+
+! V point to F point
+ DO_2D( 1, 1, 1, 0 )
+ ztmp(ji,jj)=0.5*(ssv_m(ji,jj)+ssv_m(ji+1,jj))*fmask(ji,jj,1)
+ END_2D
+ CALL nemo2cice(ztmp,vocn,'F', -1. )
+
+ IF( ln_ice_embd ) THEN !== embedded sea ice: compute representative ice top surface ==!
+ !
+ ! average interpolation coeff as used in dynspg = (1/nn_fsbc) * {SUM[n/nn_fsbc], n=0,nn_fsbc-1}
+ ! = (1/nn_fsbc)^2 * {SUM[n], n=0,nn_fsbc-1}
+ zintn = REAL( nn_fsbc - 1 ) / REAL( nn_fsbc ) * 0.5_wp
+ !
+ ! average interpolation coeff as used in dynspg = (1/nn_fsbc) * {SUM[1-n/nn_fsbc], n=0,nn_fsbc-1}
+ ! = (1/nn_fsbc)^2 * (nn_fsbc^2 - {SUM[n], n=0,nn_fsbc-1})
+ zintb = REAL( nn_fsbc + 1 ) / REAL( nn_fsbc ) * 0.5_wp
+ !
+ zpice(:,:) = ssh_m(:,:) + ( zintn * snwice_mass(:,:) + zintb * snwice_mass_b(:,:) ) * r1_rho0
+ !
+ !
+ ELSE !== non-embedded sea ice: use ocean surface for slope calculation ==!
+ zpice(:,:) = ssh_m(:,:)
+ ENDIF
+
+! x comp and y comp of sea surface slope (on F points)
+! T point to F point
+ DO_2D( 1, 0, 1, 0 )
+ ztmp(ji,jj)=0.5 * ( (zpice(ji+1,jj )-zpice(ji,jj )) * r1_e1u(ji,jj ) &
+ & + (zpice(ji+1,jj+1)-zpice(ji,jj+1)) * r1_e1u(ji,jj+1) ) * fmask(ji,jj,1)
+ END_2D
+ CALL nemo2cice( ztmp,ss_tltx,'F', -1. )
+
+! T point to F point
+ DO_2D( 1, 0, 1, 0 )
+ ztmp(ji,jj)=0.5 * ( (zpice(ji ,jj+1)-zpice(ji ,jj)) * r1_e2v(ji ,jj) &
+ & + (zpice(ji+1,jj+1)-zpice(ji+1,jj)) * r1_e2v(ji+1,jj) ) * fmask(ji,jj,1)
+ END_2D
+ CALL nemo2cice(ztmp,ss_tlty,'F', -1. )
+ !
+ END SUBROUTINE cice_sbc_in
+
+
+ SUBROUTINE cice_sbc_out( kt, ksbc )
+ !!---------------------------------------------------------------------
+ !! *** ROUTINE cice_sbc_out ***
+ !! ** Purpose: Get fields from CICE and set surface fields for NEMO
+ !!---------------------------------------------------------------------
+ INTEGER, INTENT( in ) :: kt ! ocean time step
+ INTEGER, INTENT( in ) :: ksbc ! surface forcing type
+
+ INTEGER :: ji, jj, jl ! dummy loop indices
+ REAL(wp), DIMENSION(jpi,jpj) :: ztmp1, ztmp2
+ !!---------------------------------------------------------------------
+ !
+ IF( kt == nit000 ) THEN
+ IF(lwp) WRITE(numout,*)'cice_sbc_out'
+ ENDIF
+
+! x comp of ocean-ice stress
+ CALL cice2nemo(strocnx,ztmp1,'F', -1. )
+ ss_iou(:,:)=0.0
+! F point to U point
+ DO_2D( 0, 0, 0, 0 )
+ ss_iou(ji,jj) = 0.5 * ( ztmp1(ji,jj-1) + ztmp1(ji,jj) ) * umask(ji,jj,1)
+ END_2D
+ CALL lbc_lnk( 'sbcice_cice', ss_iou , 'U', -1. )
+
+! y comp of ocean-ice stress
+ CALL cice2nemo(strocny,ztmp1,'F', -1. )
+ ss_iov(:,:)=0.0
+! F point to V point
+
+ DO_2D( 1, 0, 0, 0 )
+ ss_iov(ji,jj) = 0.5 * ( ztmp1(ji-1,jj) + ztmp1(ji,jj) ) * vmask(ji,jj,1)
+ END_2D
+ CALL lbc_lnk( 'sbcice_cice', ss_iov , 'V', -1. )
+
+! x and y comps of surface stress
+! Combine wind stress and ocean-ice stress
+! [Note that fr_iu hasn't yet been updated, so still from start of CICE timestep]
+! strocnx and strocny already weighted by ice fraction in CICE so not done here
+
+ utau(:,:)=(1.0-fr_iu(:,:))*utau(:,:)-ss_iou(:,:)
+ vtau(:,:)=(1.0-fr_iv(:,:))*vtau(:,:)-ss_iov(:,:)
+
+! Also need ice/ocean stress on T points so that taum can be updated
+! This interpolation is already done in CICE so best to use those values
+ CALL cice2nemo(strocnxT,ztmp1,'T',-1.)
+ CALL cice2nemo(strocnyT,ztmp2,'T',-1.)
+
+! Update taum with modulus of ice-ocean stress
+! strocnxT and strocnyT are not weighted by ice fraction in CICE so must be done here
+taum(:,:)=(1.0-fr_i(:,:))*taum(:,:)+fr_i(:,:)*SQRT(ztmp1*ztmp1 + ztmp2*ztmp2)
+
+! Freshwater fluxes
+
+ IF(ksbc == jp_flx) THEN
+! Note that emp from the forcing files is evap*(1-aice)-(tprecip-aice*sprecip)
+! What we want here is evap*(1-aice)-tprecip*(1-aice) hence manipulation below
+! Not ideal since aice won't be the same as in the atmosphere.
+! Better to use evap and tprecip? (but for now don't read in evap in this case)
+ emp(:,:) = emp(:,:)+fr_i(:,:)*(tprecip(:,:)-sprecip(:,:))
+ ELSE IF(ksbc == jp_blk) THEN
+ emp(:,:) = (1.0-fr_i(:,:))*emp(:,:)
+ ELSE IF(ksbc == jp_purecpl) THEN
+! emp_tot is set in sbc_cpl_ice_flx (called from cice_sbc_in above)
+! This is currently as required with the coupling fields from the UM atmosphere
+ emp(:,:) = emp_tot(:,:)+tprecip(:,:)*fr_i(:,:)
+ ENDIF
+
+#if defined key_cice4
+ CALL cice2nemo(fresh_gbm,ztmp1,'T', 1. )
+ CALL cice2nemo(fsalt_gbm,ztmp2,'T', 1. )
+#else
+ CALL cice2nemo(fresh_ai,ztmp1,'T', 1. )
+ CALL cice2nemo(fsalt_ai,ztmp2,'T', 1. )
+#endif
+
+! Check to avoid unphysical expression when ice is forming (ztmp1 negative)
+! Otherwise we are effectively allowing ice of higher salinity than the ocean to form
+! which has to be compensated for by the ocean salinity potentially going negative
+! This check breaks conservation but seems reasonable until we have prognostic ice salinity
+! Note the 1000.0 below is to convert from kg salt to g salt (needed for PSU)
+ WHERE (ztmp1(:,:).lt.0.0) ztmp2(:,:)=MAX(ztmp2(:,:),ztmp1(:,:)*sss_m(:,:)/1000.0)
+ sfx(:,:)=ztmp2(:,:)*1000.0
+ emp(:,:)=emp(:,:)-ztmp1(:,:)
+ fmmflx(:,:) = ztmp1(:,:) !!Joakim edit
+
+ CALL lbc_lnk_multi( 'sbcice_cice', emp , 'T', 1., sfx , 'T', 1. )
+
+! Solar penetrative radiation and non solar surface heat flux
+
+! Scale qsr and qns according to ice fraction (bulk formulae only)
+
+ IF(ksbc == jp_blk) THEN
+ qsr(:,:)=qsr(:,:)*(1.0-fr_i(:,:))
+ qns(:,:)=qns(:,:)*(1.0-fr_i(:,:))
+ ENDIF
+! Take into account snow melting except for fully coupled when already in qns_tot
+ IF(ksbc == jp_purecpl) THEN
+ qsr(:,:)= qsr_tot(:,:)
+ qns(:,:)= qns_tot(:,:)
+ ELSE
+ qns(:,:)= qns(:,:)-sprecip(:,:)*Lfresh*(1.0-fr_i(:,:))
+ ENDIF
+
+! Now add in ice / snow related terms
+! [fswthru will be zero unless running with calc_Tsfc=T in CICE]
+#if defined key_cice4
+ CALL cice2nemo(fswthru_gbm,ztmp1,'T', 1. )
+#else
+ CALL cice2nemo(fswthru_ai,ztmp1,'T', 1. )
+#endif
+ qsr(:,:)=qsr(:,:)+ztmp1(:,:)
+ CALL lbc_lnk( 'sbcice_cice', qsr , 'T', 1. )
+
+ DO_2D( 1, 1, 1, 1 )
+ nfrzmlt(ji,jj)=MAX(nfrzmlt(ji,jj),0.0)
+ END_2D
+
+#if defined key_cice4
+ CALL cice2nemo(fhocn_gbm,ztmp1,'T', 1. )
+#else
+ CALL cice2nemo(fhocn_ai,ztmp1,'T', 1. )
+#endif
+ qns(:,:)=qns(:,:)+nfrzmlt(:,:)+ztmp1(:,:)
+
+ CALL lbc_lnk( 'sbcice_cice', qns , 'T', 1. )
+
+! Prepare for the following CICE time-step
+
+ CALL cice2nemo(aice,fr_i,'T', 1. )
+ IF( (ksbc == jp_flx).OR.(ksbc == jp_purecpl) ) THEN
+ DO jl=1,ncat
+ CALL cice2nemo(aicen(:,:,jl,:),a_i(:,:,jl), 'T', 1. )
+ ENDDO
+ ENDIF
+
+! T point to U point
+! T point to V point
+ DO_2D( 1, 0, 1, 0 )
+ fr_iu(ji,jj)=0.5*(fr_i(ji,jj)+fr_i(ji+1,jj))*umask(ji,jj,1)
+ fr_iv(ji,jj)=0.5*(fr_i(ji,jj)+fr_i(ji,jj+1))*vmask(ji,jj,1)
+ END_2D
+
+ CALL lbc_lnk_multi( 'sbcice_cice', fr_iu , 'U', 1., fr_iv , 'V', 1. )
+
+ ! set the snow+ice mass
+ CALL cice2nemo(vsno(:,:,:),ztmp1,'T', 1. )
+ CALL cice2nemo(vice(:,:,:),ztmp2,'T', 1. )
+ snwice_mass (:,:) = ( rhos * ztmp1(:,:) + rhoi * ztmp2(:,:) )
+ snwice_mass_b(:,:) = snwice_mass(:,:)
+ snwice_fmass (:,:) = ( snwice_mass(:,:) - snwice_mass_b(:,:) ) / dt
+ !
+ END SUBROUTINE cice_sbc_out
+
+
+ SUBROUTINE cice_sbc_hadgam( kt )
+ !!---------------------------------------------------------------------
+ !! *** ROUTINE cice_sbc_hadgam ***
+ !! ** Purpose: Prepare fields needed to pass to HadGAM3 atmosphere
+ !!
+ !!
+ !!---------------------------------------------------------------------
+ INTEGER, INTENT( in ) :: kt ! ocean time step
+ !!
+ INTEGER :: jl ! dummy loop index
+ INTEGER :: ierror
+ !!---------------------------------------------------------------------
+ !
+ IF( kt == nit000 ) THEN
+ IF(lwp) WRITE(numout,*)'cice_sbc_hadgam'
+ IF( sbc_cpl_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_cpl_alloc : unable to allocate arrays' )
+ ENDIF
+
+ ! ! =========================== !
+ ! ! Prepare Coupling fields !
+ ! ! =========================== !
+ !
+ ! x and y comp of ice velocity
+ !
+ CALL cice2nemo(uvel,u_ice,'F', -1. )
+ CALL cice2nemo(vvel,v_ice,'F', -1. )
+ !
+ ! Ice concentration (CO_1) = a_i calculated at end of cice_sbc_out
+ !
+ ! Snow and ice thicknesses (CO_2 and CO_3)
+ !
+ DO jl = 1, ncat
+ CALL cice2nemo( vsnon(:,:,jl,:), h_s(:,:,jl),'T', 1. )
+ CALL cice2nemo( vicen(:,:,jl,:), h_i(:,:,jl),'T', 1. )
+ END DO
+ !
+ END SUBROUTINE cice_sbc_hadgam
+
+
+ SUBROUTINE cice_sbc_final
+ !!---------------------------------------------------------------------
+ !! *** ROUTINE cice_sbc_final ***
+ !! ** Purpose: Finalize CICE
+ !!---------------------------------------------------------------------
+ !
+ IF(lwp) WRITE(numout,*)'cice_sbc_final'
+ !
+ CALL CICE_Finalize
+ !
+ END SUBROUTINE cice_sbc_final
+
+
+ SUBROUTINE cice_sbc_force (kt)
+ !!---------------------------------------------------------------------
+ !! *** ROUTINE cice_sbc_force ***
+ !! ** Purpose : Provide CICE forcing from files
+ !!
+ !!---------------------------------------------------------------------
+ !! ** Method : READ monthly flux file in NetCDF files
+ !!
+ !! snowfall
+ !! rainfall
+ !! sublimation rate
+ !! topmelt (category)
+ !! botmelt (category)
+ !!
+ !! History :
+ !!----------------------------------------------------------------------
+ USE iom
+ !!
+ INTEGER, INTENT( in ) :: kt ! ocean time step
+ !!
+ INTEGER :: ierror ! return error code
+ INTEGER :: ifpr ! dummy loop index
+ !!
+ CHARACTER(len=100) :: cn_dir ! Root directory for location of CICE forcing files
+ TYPE(FLD_N), DIMENSION(jpfld) :: slf_i ! array of namelist informations on the fields to read
+ TYPE(FLD_N) :: sn_snow, sn_rain, sn_sblm ! informations about the fields to be read
+ TYPE(FLD_N) :: sn_top1, sn_top2, sn_top3, sn_top4, sn_top5
+ TYPE(FLD_N) :: sn_bot1, sn_bot2, sn_bot3, sn_bot4, sn_bot5
+ !!
+ NAMELIST/namsbc_cice/ cn_dir, sn_snow, sn_rain, sn_sblm, &
+ & sn_top1, sn_top2, sn_top3, sn_top4, sn_top5, &
+ & sn_bot1, sn_bot2, sn_bot3, sn_bot4, sn_bot5
+ INTEGER :: ios
+ !!---------------------------------------------------------------------
+
+ ! ! ====================== !
+ IF( kt == nit000 ) THEN ! First call kt=nit000 !
+ ! ! ====================== !
+ ! namsbc_cice is not yet in the reference namelist
+ ! set file information (default values)
+ cn_dir = './' ! directory in which the model is executed
+
+ ! (NB: frequency positive => hours, negative => months)
+ ! ! file ! frequency ! variable ! time intep ! clim ! 'yearly' or ! weights ! rotation ! landmask
+ ! ! name ! (hours) ! name ! (T/F) ! (T/F) ! 'monthly' ! filename ! pairs ! file
+ sn_snow = FLD_N( 'snowfall_1m' , -1. , 'snowfall' , .true. , .true. , ' yearly' , '' , '' , '' )
+ sn_rain = FLD_N( 'rainfall_1m' , -1. , 'rainfall' , .true. , .true. , ' yearly' , '' , '' , '' )
+ sn_sblm = FLD_N( 'sublim_1m' , -1. , 'sublim' , .true. , .true. , ' yearly' , '' , '' , '' )
+ sn_top1 = FLD_N( 'topmeltn1_1m' , -1. , 'topmeltn1' , .true. , .true. , ' yearly' , '' , '' , '' )
+ sn_top2 = FLD_N( 'topmeltn2_1m' , -1. , 'topmeltn2' , .true. , .true. , ' yearly' , '' , '' , '' )
+ sn_top3 = FLD_N( 'topmeltn3_1m' , -1. , 'topmeltn3' , .true. , .true. , ' yearly' , '' , '' , '' )
+ sn_top4 = FLD_N( 'topmeltn4_1m' , -1. , 'topmeltn4' , .true. , .true. , ' yearly' , '' , '' , '' )
+ sn_top5 = FLD_N( 'topmeltn5_1m' , -1. , 'topmeltn5' , .true. , .true. , ' yearly' , '' , '' , '' )
+ sn_bot1 = FLD_N( 'botmeltn1_1m' , -1. , 'botmeltn1' , .true. , .true. , ' yearly' , '' , '' , '' )
+ sn_bot2 = FLD_N( 'botmeltn2_1m' , -1. , 'botmeltn2' , .true. , .true. , ' yearly' , '' , '' , '' )
+ sn_bot3 = FLD_N( 'botmeltn3_1m' , -1. , 'botmeltn3' , .true. , .true. , ' yearly' , '' , '' , '' )
+ sn_bot4 = FLD_N( 'botmeltn4_1m' , -1. , 'botmeltn4' , .true. , .true. , ' yearly' , '' , '' , '' )
+ sn_bot5 = FLD_N( 'botmeltn5_1m' , -1. , 'botmeltn5' , .true. , .true. , ' yearly' , '' , '' , '' )
+
+ READ ( numnam_ref, namsbc_cice, IOSTAT = ios, ERR = 901)
+901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_cice in reference namelist' )
+
+ READ ( numnam_cfg, namsbc_cice, IOSTAT = ios, ERR = 902 )
+902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_cice in configuration namelist' )
+ IF(lwm) WRITE ( numond, namsbc_cice )
+
+ ! store namelist information in an array
+ slf_i(jp_snow) = sn_snow ; slf_i(jp_rain) = sn_rain ; slf_i(jp_sblm) = sn_sblm
+ slf_i(jp_top1) = sn_top1 ; slf_i(jp_top2) = sn_top2 ; slf_i(jp_top3) = sn_top3
+ slf_i(jp_top4) = sn_top4 ; slf_i(jp_top5) = sn_top5 ; slf_i(jp_bot1) = sn_bot1
+ slf_i(jp_bot2) = sn_bot2 ; slf_i(jp_bot3) = sn_bot3 ; slf_i(jp_bot4) = sn_bot4
+ slf_i(jp_bot5) = sn_bot5
+
+ ! set sf structure
+ ALLOCATE( sf(jpfld), STAT=ierror )
+ IF( ierror > 0 ) THEN
+ CALL ctl_stop( 'cice_sbc_force: unable to allocate sf structure' ) ; RETURN
+ ENDIF
+
+ DO ifpr= 1, jpfld
+ ALLOCATE( sf(ifpr)%fnow(jpi,jpj,1) )
+ ALLOCATE( sf(ifpr)%fdta(jpi,jpj,1,2) )
+ END DO
+
+ ! fill sf with slf_i and control print
+ CALL fld_fill( sf, slf_i, cn_dir, 'cice_sbc_force', 'flux formulation for CICE', 'namsbc_cice' )
+ !
+ ENDIF
+
+ CALL fld_read( kt, nn_fsbc, sf ) ! Read input fields and provides the
+ ! ! input fields at the current time-step
+
+ ! set the fluxes from read fields
+ sprecip(:,:) = sf(jp_snow)%fnow(:,:,1)
+ tprecip(:,:) = sf(jp_snow)%fnow(:,:,1)+sf(jp_rain)%fnow(:,:,1)
+! May be better to do this conversion somewhere else
+ qla_ice(:,:,1) = -rLsub*sf(jp_sblm)%fnow(:,:,1)
+ topmelt(:,:,1) = sf(jp_top1)%fnow(:,:,1)
+ topmelt(:,:,2) = sf(jp_top2)%fnow(:,:,1)
+ topmelt(:,:,3) = sf(jp_top3)%fnow(:,:,1)
+ topmelt(:,:,4) = sf(jp_top4)%fnow(:,:,1)
+ topmelt(:,:,5) = sf(jp_top5)%fnow(:,:,1)
+ botmelt(:,:,1) = sf(jp_bot1)%fnow(:,:,1)
+ botmelt(:,:,2) = sf(jp_bot2)%fnow(:,:,1)
+ botmelt(:,:,3) = sf(jp_bot3)%fnow(:,:,1)
+ botmelt(:,:,4) = sf(jp_bot4)%fnow(:,:,1)
+ botmelt(:,:,5) = sf(jp_bot5)%fnow(:,:,1)
+
+ ! control print (if less than 100 time-step asked)
+ IF( nitend-nit000 <= 100 .AND. lwp ) THEN
+ WRITE(numout,*)
+ WRITE(numout,*) ' read forcing fluxes for CICE OK'
+ CALL FLUSH(numout)
+ ENDIF
+
+ END SUBROUTINE cice_sbc_force
+
+ SUBROUTINE nemo2cice( pn, pc, cd_type, psgn)
+ !!---------------------------------------------------------------------
+ !! *** ROUTINE nemo2cice ***
+ !! ** Purpose : Transfer field in NEMO array to field in CICE array.
+#if defined key_nemocice_decomp
+ !!
+ !! NEMO and CICE PE sub domains are identical, hence
+ !! there is no need to gather or scatter data from
+ !! one PE configuration to another.
+#else
+ !! Automatically gather/scatter between
+ !! different processors and blocks
+ !! ** Method : A. Ensure all haloes are filled in NEMO field (pn)
+ !! B. Gather pn into global array (png)
+ !! C. Map png into CICE global array (pcg)
+ !! D. Scatter pcg to CICE blocks (pc) + update haloes
+#endif
+ !!---------------------------------------------------------------------
+ CHARACTER(len=1), INTENT( in ) :: &
+ cd_type ! nature of pn grid-point
+ ! ! = T or F gridpoints
+ REAL(wp), INTENT( in ) :: &
+ psgn ! control of the sign change
+ ! ! =-1 , the sign is modified following the type of b.c. used
+ ! ! = 1 , no sign change
+ REAL(wp), DIMENSION(jpi,jpj) :: pn
+#if !defined key_nemocice_decomp
+ REAL(wp), DIMENSION(jpiglo,jpjglo) :: png2
+ REAL (kind=dbl_kind), dimension(nx_global,ny_global) :: pcg
+#endif
+ REAL (kind=dbl_kind), dimension(nx_block,ny_block,max_blocks) :: pc
+ INTEGER (int_kind) :: &
+ field_type, &! id for type of field (scalar, vector, angle)
+ grid_loc ! id for location on horizontal grid
+ ! (center, NEcorner, Nface, Eface)
+
+ INTEGER :: ji, jj, jn ! dummy loop indices
+ !!---------------------------------------------------------------------
+
+! A. Ensure all haloes are filled in NEMO field (pn)
+
+ CALL lbc_lnk( 'sbcice_cice', pn , cd_type, psgn )
+
+#if defined key_nemocice_decomp
+
+ ! Copy local domain data from NEMO to CICE field
+ pc(:,:,1)=0.0
+ DO jj=2,ny_block-1
+ DO ji=2,nx_block-1
+ pc(ji,jj,1)=pn(ji-1+ji_off,jj-1+jj_off)
+ ENDDO
+ ENDDO
+
+#else
+
+! B. Gather pn into global array (png)
+
+ IF( jpnij > 1) THEN
+ CALL mppsync
+ CALL mppgather (pn,0,png)
+ CALL mppsync
+ ELSE
+ png(:,:,1)=pn(:,:)
+ ENDIF
+
+! C. Map png into CICE global array (pcg)
+
+! Need to make sure this is robust to changes in NEMO halo rows....
+! (may be OK but not 100% sure)
+
+ IF(nproc==0) THEN
+! pcg(:,:)=0.0
+ DO jn=1,jpnij
+ DO jj=nldjt(jn),nlejt(jn)
+ DO ji=nldit(jn),nleit(jn)
+ png2(ji+nimppt(jn)-1,jj+njmppt(jn)-1)=png(ji,jj,jn)
+ ENDDO
+ ENDDO
+ ENDDO
+ DO jj=1,ny_global
+ DO ji=1,nx_global
+ pcg(ji,jj)=png2(ji+ji_off,jj+jj_off)
+ ENDDO
+ ENDDO
+ ENDIF
+
+#endif
+
+ SELECT CASE ( cd_type )
+ CASE ( 'T' )
+ grid_loc=field_loc_center
+ CASE ( 'F' )
+ grid_loc=field_loc_NEcorner
+ END SELECT
+
+ SELECT CASE ( NINT(psgn) )
+ CASE ( -1 )
+ field_type=field_type_vector
+ CASE ( 1 )
+ field_type=field_type_scalar
+ END SELECT
+
+#if defined key_nemocice_decomp
+ ! Ensure CICE halos are up to date
+ CALL ice_HaloUpdate (pc, halo_info, grid_loc, field_type)
+#else
+! D. Scatter pcg to CICE blocks (pc) + update halos
+ CALL scatter_global(pc, pcg, 0, distrb_info, grid_loc, field_type)
+#endif
+
+ END SUBROUTINE nemo2cice
+
+ SUBROUTINE cice2nemo ( pc, pn, cd_type, psgn )
+ !!---------------------------------------------------------------------
+ !! *** ROUTINE cice2nemo ***
+ !! ** Purpose : Transfer field in CICE array to field in NEMO array.
+#if defined key_nemocice_decomp
+ !!
+ !! NEMO and CICE PE sub domains are identical, hence
+ !! there is no need to gather or scatter data from
+ !! one PE configuration to another.
+#else
+ !! Automatically deal with scatter/gather between
+ !! different processors and blocks
+ !! ** Method : A. Gather CICE blocks (pc) into global array (pcg)
+ !! B. Map pcg into NEMO global array (png)
+ !! C. Scatter png into NEMO field (pn) for each processor
+ !! D. Ensure all haloes are filled in pn
+#endif
+ !!---------------------------------------------------------------------
+
+ CHARACTER(len=1), INTENT( in ) :: &
+ cd_type ! nature of pn grid-point
+ ! ! = T or F gridpoints
+ REAL(wp), INTENT( in ) :: &
+ psgn ! control of the sign change
+ ! ! =-1 , the sign is modified following the type of b.c. used
+ ! ! = 1 , no sign change
+ REAL(wp), DIMENSION(jpi,jpj) :: pn
+
+#if defined key_nemocice_decomp
+ INTEGER (int_kind) :: &
+ field_type, & ! id for type of field (scalar, vector, angle)
+ grid_loc ! id for location on horizontal grid
+ ! (center, NEcorner, Nface, Eface)
+#else
+ REAL (kind=dbl_kind), dimension(nx_global,ny_global) :: pcg
+#endif
+
+ REAL (kind=dbl_kind), dimension(nx_block,ny_block,max_blocks) :: pc
+
+ INTEGER :: ji, jj, jn ! dummy loop indices
+
+
+#if defined key_nemocice_decomp
+
+ SELECT CASE ( cd_type )
+ CASE ( 'T' )
+ grid_loc=field_loc_center
+ CASE ( 'F' )
+ grid_loc=field_loc_NEcorner
+ END SELECT
+
+ SELECT CASE ( NINT(psgn) )
+ CASE ( -1 )
+ field_type=field_type_vector
+ CASE ( 1 )
+ field_type=field_type_scalar
+ END SELECT
+
+ CALL ice_HaloUpdate (pc, halo_info, grid_loc, field_type)
+
+
+ pn(:,:)=0.0
+ DO_2D( 1, 0, 1, 0 )
+ pn(ji,jj)=pc(ji+1-ji_off,jj+1-jj_off,1)
+ END_2D
+
+#else
+
+! A. Gather CICE blocks (pc) into global array (pcg)
+
+ CALL gather_global(pcg, pc, 0, distrb_info)
+
+! B. Map pcg into NEMO global array (png)
+
+! Need to make sure this is robust to changes in NEMO halo rows....
+! (may be OK but not spent much time thinking about it)
+! Note that non-existent pcg elements may be used below, but
+! the lbclnk call on pn will replace these with sensible values
+
+ IF(nproc==0) THEN
+ png(:,:,:)=0.0
+ DO jn=1,jpnij
+ DO jj=nldjt(jn),nlejt(jn)
+ DO ji=nldit(jn),nleit(jn)
+ png(ji,jj,jn)=pcg(ji+nimppt(jn)-1-ji_off,jj+njmppt(jn)-1-jj_off)
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDIF
+
+! C. Scatter png into NEMO field (pn) for each processor
+
+ IF( jpnij > 1) THEN
+ CALL mppsync
+ CALL mppscatter (png,0,pn)
+ CALL mppsync
+ ELSE
+ pn(:,:)=png(:,:,1)
+ ENDIF
+
+#endif
+
+! D. Ensure all haloes are filled in pn
+
+ CALL lbc_lnk( 'sbcice_cice', pn , cd_type, psgn )
+
+ END SUBROUTINE cice2nemo
+
+#else
+ !!----------------------------------------------------------------------
+ !! Default option Dummy module NO CICE sea-ice model
+ !!----------------------------------------------------------------------
+CONTAINS
+
+ SUBROUTINE sbc_ice_cice ( kt, ksbc ) ! Dummy routine
+ IMPLICIT NONE
+ INTEGER, INTENT( in ) :: kt, ksbc
+ WRITE(*,*) 'sbc_ice_cice: You should not have seen this print! error?', kt
+ END SUBROUTINE sbc_ice_cice
+
+ SUBROUTINE cice_sbc_init (ksbc, Kbb, Kmm) ! Dummy routine
+ IMPLICIT NONE
+ INTEGER, INTENT( in ) :: ksbc
+ INTEGER, INTENT( in ) :: Kbb, Kmm
+ WRITE(*,*) 'cice_sbc_init: You should not have seen this print! error?', ksbc
+ END SUBROUTINE cice_sbc_init
+
+ SUBROUTINE cice_sbc_final ! Dummy routine
+ IMPLICIT NONE
+ WRITE(*,*) 'cice_sbc_final: You should not have seen this print! error?'
+ END SUBROUTINE cice_sbc_final
+
+#endif
+
+ !!======================================================================
+END MODULE sbcice_cice
Index: /NEMO/branches/2020/r12377_ticket2386/src/SWE/step.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/SWE/step.F90 (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/src/SWE/step.F90 (revision 13540)
@@ -0,0 +1,322 @@
+MODULE step
+ !!======================================================================
+ !! *** MODULE step ***
+ !! Time-stepping : manager of the shallow water equation time stepping
+ !!======================================================================
+ !! History : NEMO ! 2020-03 (A. Nasser, G. Madec) Original code from 4.0.2
+ !!----------------------------------------------------------------------
+#if defined key_qco
+ !!----------------------------------------------------------------------
+ !! 'key_qco' EMPTY MODULE Quasi-Eulerian vertical coordonate
+ !!----------------------------------------------------------------------
+#else
+ !!----------------------------------------------------------------------
+ !! stp : Shallow Water time-stepping
+ !!----------------------------------------------------------------------
+ USE step_oce ! time stepping definition modules
+ USE phycst ! physical constants
+ USE usrdef_nam
+ !
+ USE iom ! xIOs server
+
+ 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 12614 2020-03-26 14:59:52Z gm $
+ !! 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 shallow water (SHW) (momentum and ssh eqs.)
+ !!
+ !! ** Method : -1- Update forcings
+ !! -2- Update the ssh at Naa
+ !! -3- Compute the momentum trends (Nrhs)
+ !! -4- Update the horizontal velocity
+ !! -5- Apply Asselin time filter to uu,vv,ssh
+ !! -6- Outputs and diagnostics
+ !!----------------------------------------------------------------------
+ INTEGER :: ji, jj, jk ! dummy loop indice
+ INTEGER :: indic ! error indicator if < 0
+!!gm kcall can be removed, I guess
+ INTEGER :: kcall ! optional integer argument (dom_vvl_sf_nxt)
+ REAL(wp):: z1_2rho0 ! local scalars
+
+ REAL(wp) :: zue3a, zue3n, zue3b ! local scalars
+ REAL(wp) :: zve3a, zve3n, zve3b ! - -
+ REAL(wp) :: ze3t_tf, ze3u_tf, ze3v_tf, zua, zva
+ !! ---------------------------------------------------------------------
+#if defined key_agrif
+ 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_iomput
+ 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
+
+ IF ( kstp == nit000 ) ww(:,:,:) = 0._wp ! initialize vertical velocity one for all to zero
+
+ !
+ !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ ! update I/O and calendar
+ !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ indic = 0 ! reset to no error condition
+
+ 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 passible 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 /= 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
+ CALL sbc ( kstp, Nbb, Nnn ) ! Sea Boundary Condition
+
+ !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ ! Ocean physics update
+ !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ ! LATERAL PHYSICS
+ ! ! eddy diffusivity 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)
+ uu(:,:,:,Nrhs) = 0._wp ! set dynamics trends to zero
+ vv(:,:,:,Nrhs) = 0._wp
+
+ IF( .NOT.ln_linssh ) CALL dom_vvl_sf_nxt( kstp, Nbb, Nnn, Naa ) ! after vertical scale factors
+
+ IF( ln_bdy ) CALL bdy_dyn3d_dmp ( kstp, Nbb, uu, vv, Nrhs ) ! bdy damping trends
+
+#if defined key_agrif
+ IF(.NOT. Agrif_Root()) &
+ & CALL Agrif_Sponge_dyn ! momentum sponge
+#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
+
+!!an - calcul du gradient de pression horizontal (explicit)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ uu(ji,jj,jk,Nrhs) = uu(ji,jj,jk,Nrhs) - grav * ( ssh(ji+1,jj,Nnn) - ssh(ji,jj,Nnn) ) * r1_e1u(ji,jj)
+ vv(ji,jj,jk,Nrhs) = vv(ji,jj,jk,Nrhs) - grav * ( ssh(ji,jj+1,Nnn) - ssh(ji,jj,Nnn) ) * r1_e2v(ji,jj)
+ END_3D
+ !
+ ! add wind stress forcing and layer linear friction to the RHS
+ z1_2rho0 = 0.5_wp * r1_rho0
+ DO_3D( 0, 0, 0, 0,1,jpkm1)
+ uu(ji,jj,jk,Nrhs) = uu(ji,jj,jk,Nrhs) + z1_2rho0 * ( utau_b(ji,jj) + utau(ji,jj) ) / e3u(ji,jj,jk,Nnn) &
+ & - rn_rfr * uu(ji,jj,jk,Nbb)
+ vv(ji,jj,jk,Nrhs) = vv(ji,jj,jk,Nrhs) + z1_2rho0 * ( vtau_b(ji,jj) + vtau(ji,jj) ) / e3v(ji,jj,jk,Nnn) &
+ & - rn_rfr * vv(ji,jj,jk,Nbb)
+ END_3D
+!!an
+
+ !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ ! Leap-Frog time splitting + Robert-Asselin time filter on u,v,e3
+ !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+
+!! what about IF( .NOT.ln_linssh ) ?
+!!an futur module dyn_nxt (a la place de dyn_atf)
+
+ IF( ln_dynadv_vec ) THEN ! vector invariant form : applied on velocity
+ IF( l_1st_euler ) THEN ! Euler time stepping (no Asselin filter)
+ DO_3D( 0, 0, 0, 0,1,jpkm1)
+ uu(ji,jj,jk,Naa) = uu(ji,jj,jk,Nbb) + rDt * uu(ji,jj,jk,Nrhs) * umask(ji,jj,jk)
+ vv(ji,jj,jk,Naa) = vv(ji,jj,jk,Nbb) + rDt * vv(ji,jj,jk,Nrhs) * vmask(ji,jj,jk)
+ END_3D
+ ELSE ! Leap Frog time stepping + Asselin filter
+ DO_3D( 1, 1, 1, 1,1,jpkm1)
+ zua = uu(ji,jj,jk,Nbb) + rDt * uu(ji,jj,jk,Nrhs) * umask(ji,jj,jk)
+ zva = vv(ji,jj,jk,Nbb) + rDt * vv(ji,jj,jk,Nrhs) * vmask(ji,jj,jk)
+ ! ! Asselin time filter on u,v (Nnn)
+ uu(ji,jj,jk,Nnn) = uu(ji,jj,jk,Nnn) + rn_atfp * (uu(ji,jj,jk,Nbb) - 2._wp * uu(ji,jj,jk,Nnn) + zua)
+ vv(ji,jj,jk,Nnn) = vv(ji,jj,jk,Nnn) + rn_atfp * (vv(ji,jj,jk,Nbb) - 2._wp * vv(ji,jj,jk,Nnn) + zva)
+ !
+ ze3u_tf = e3u(ji,jj,jk,Nnn) + rn_atfp * ( e3u(ji,jj,jk,Nbb) - 2._wp * e3u(ji,jj,jk,Nnn) + e3u(ji,jj,jk,Naa) )
+ ze3v_tf = e3v(ji,jj,jk,Nnn) + rn_atfp * ( e3v(ji,jj,jk,Nbb) - 2._wp * e3v(ji,jj,jk,Nnn) + e3v(ji,jj,jk,Naa) )
+ ze3t_tf = e3t(ji,jj,jk,Nnn) + rn_atfp * ( e3t(ji,jj,jk,Nbb) - 2._wp * e3t(ji,jj,jk,Nnn) + e3t(ji,jj,jk,Naa) )
+ !
+ e3u(ji,jj,jk,Nnn) = ze3u_tf
+ e3v(ji,jj,jk,Nnn) = ze3v_tf
+ e3t(ji,jj,jk,Nnn) = ze3t_tf
+ !
+ uu(ji,jj,jk,Naa) = zua
+ vv(ji,jj,jk,Naa) = zva
+ END_3D
+ ENDIF
+ !
+ ELSE ! flux form : applied on thickness weighted velocity
+ IF( l_1st_euler ) THEN ! Euler time stepping (no Asselin filter)
+ DO_3D( 0, 0, 0, 0,1,jpkm1)
+ zue3b = e3u(ji,jj,jk,Nbb) * uu(ji,jj,jk,Nbb)
+ zve3b = e3v(ji,jj,jk,Nbb) * vv(ji,jj,jk,Nbb)
+ ! ! LF time stepping
+ zue3a = zue3b + rDt * e3u(ji,jj,jk,Nrhs) * uu(ji,jj,jk,Nrhs) * umask(ji,jj,jk)
+ zve3a = zve3b + rDt * e3v(ji,jj,jk,Nrhs) * vv(ji,jj,jk,Nrhs) * vmask(ji,jj,jk)
+ !
+ uu(ji,jj,jk,Naa) = zue3a / e3u(ji,jj,jk,Naa)
+ vv(ji,jj,jk,Naa) = zve3a / e3v(ji,jj,jk,Naa)
+ END_3D
+ ELSE ! Leap Frog time stepping + Asselin filter
+ DO_3D( 1, 1, 1, 1,1,jpkm1)
+ zue3n = e3u(ji,jj,jk,Nnn) * uu(ji,jj,jk,Nnn)
+ zve3n = e3v(ji,jj,jk,Nnn) * vv(ji,jj,jk,Nnn)
+ zue3b = e3u(ji,jj,jk,Nbb) * uu(ji,jj,jk,Nbb)
+ zve3b = e3v(ji,jj,jk,Nbb) * vv(ji,jj,jk,Nbb)
+ ! ! LF time stepping
+ zue3a = zue3b + rDt * e3u(ji,jj,jk,Nrhs) * uu(ji,jj,jk,Nrhs) * umask(ji,jj,jk)
+ zve3a = zve3b + rDt * e3v(ji,jj,jk,Nrhs) * vv(ji,jj,jk,Nrhs) * vmask(ji,jj,jk)
+ ! ! Asselin time filter on e3u/v/t
+ ze3u_tf = e3u(ji,jj,jk,Nnn) + rn_atfp * ( e3u(ji,jj,jk,Nbb) - 2._wp * e3u(ji,jj,jk,Nnn) + e3u(ji,jj,jk,Naa) )
+ ze3v_tf = e3v(ji,jj,jk,Nnn) + rn_atfp * ( e3v(ji,jj,jk,Nbb) - 2._wp * e3v(ji,jj,jk,Nnn) + e3v(ji,jj,jk,Naa) )
+ ze3t_tf = e3t(ji,jj,jk,Nnn) + rn_atfp * ( e3t(ji,jj,jk,Nbb) - 2._wp * e3t(ji,jj,jk,Nnn) + e3t(ji,jj,jk,Naa) )
+ ! ! Asselin time filter on u,v (Nnn)
+ uu(ji,jj,jk,Nnn) = ( zue3n + rn_atfp * ( zue3b - 2._wp * zue3n + zue3a ) ) / ze3u_tf
+ vv(ji,jj,jk,Nnn) = ( zve3n + rn_atfp * ( zve3b - 2._wp * zve3n + zve3a ) ) / ze3v_tf
+ !
+ e3u(ji,jj,jk,Nnn) = ze3u_tf
+ e3v(ji,jj,jk,Nnn) = ze3v_tf
+ e3t(ji,jj,jk,Nnn) = ze3t_tf
+ !
+ uu(ji,jj,jk,Naa) = zue3a / e3u(ji,jj,jk,Naa)
+ vv(ji,jj,jk,Naa) = zve3a / e3v(ji,jj,jk,Naa)
+ END_3D
+ ENDIF
+ ENDIF
+
+
+ CALL lbc_lnk_multi( 'stp', uu(:,:,:,Nnn), 'U', -1., vv(:,:,:,Nnn), 'V', -1., & !* local domain boundaries
+ & uu(:,:,:,Naa), 'U', -1., vv(:,:,:,Naa), 'V', -1. )
+
+!!an
+
+ !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ ! Set boundary conditions, time filter and swap time levels
+ !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+
+!!an TO BE ADDED : dyn_nxt
+!! CALL dyn_atf ( kstp, Nbb, Nnn, Naa, uu, vv, e3t, e3u, e3v ) ! time filtering of "now" velocities and scale factors
+!!an TO BE ADDED : a simplifier
+!! CALL ssh_atf ( kstp, Nbb, Nnn, Naa, ssh ) ! time filtering of "now" sea surface height
+ IF ( .NOT.( l_1st_euler ) ) THEN ! Only do time filtering for leapfrog timesteps
+ ! ! filtering "now" field
+ ssh(:,:,Nnn) = ssh(:,:,Nnn) + rn_atfp * ( ssh(:,:,Nbb) - 2 * ssh(:,:,Nnn) + ssh(:,:,Naa) )
+ ENDIF
+!!an
+
+
+ ! Swap time levels
+ Nrhs = Nbb
+ Nbb = Nnn
+ Nnn = Naa
+ Naa = Nrhs
+ !
+ CALL dom_vvl_sf_update( kstp, Nbb, Nnn, Naa ) ! recompute vertical scale factors
+ !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ ! 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_wri ( kstp, Nnn ) ! ocean model: outputs
+ !
+ IF( lrst_oce ) CALL rst_write ( kstp, Nbb, Nnn ) ! write output ocean restart file
+
+
+#if defined key_agrif
+ !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ ! AGRIF
+ !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ 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
+
+ IF( Agrif_NbStepint() == 0 ) THEN
+ CALL Agrif_update_all( ) ! Update all components
+ ENDIF
+#endif
+ IF( ln_diaobs ) CALL dia_obs ( kstp, Nnn ) ! obs-minus-model (assimilation) diagnostics (call after dynamics update)
+
+ !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ ! Control
+ !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ CALL stp_ctl ( kstp, Nnn )
+
+
+ IF( kstp == nit000 ) THEN ! 1st time step only
+ CALL iom_close( numror ) ! close input ocean restart file
+ IF(lwm) CALL FLUSH ( numond ) ! flush output namelist oce
+ IF(lwm .AND. numoni /= -1 ) CALL FLUSH ( numoni ) ! flush output namelist ice (if exist)
+ ENDIF
+
+ !
+#if defined key_iomput
+ IF( kstp == nitend .OR. indic < 0 ) THEN
+ CALL iom_context_finalize( cxios_context ) ! needed for XIOS+AGRIF
+ IF(lrxios) CALL iom_context_finalize( crxios_context )
+ 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
Index: /NEMO/branches/2020/r12377_ticket2386/src/SWE/stepLF.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/SWE/stepLF.F90 (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/src/SWE/stepLF.F90 (revision 13540)
@@ -0,0 +1,335 @@
+MODULE stpLF
+ !!======================================================================
+ !! *** MODULE step ***
+ !! Time-stepping : manager of the shallow water equation time stepping
+ !!======================================================================
+ !! History : NEMO ! 2020-03 (A. Nasser, G. Madec) Original code from 4.0.2
+ !!----------------------------------------------------------------------
+
+ !!----------------------------------------------------------------------
+ !! stp : Shallow Water time-stepping
+ !!----------------------------------------------------------------------
+ USE step_oce ! time stepping definition modules
+ USE phycst ! physical constants
+ USE usrdef_nam
+ !
+ USE iom ! xIOs server
+ USE domqco
+
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC stp_LF ! called by nemogcm.F90
+
+ !!----------------------------------------------------------------------
+ !! time level indices
+ !!----------------------------------------------------------------------
+ INTEGER, PUBLIC :: Nbb, Nnn, Naa, Nrhs !! used by nemo_init
+
+ !! * Substitutions
+# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
+ !!----------------------------------------------------------------------
+ !! NEMO/OCE 4.0 , NEMO Consortium (2018)
+ !! $Id: step.F90 12614 2020-03-26 14:59:52Z gm $
+ !! Software governed by the CeCILL license (see ./LICENSE)
+ !!----------------------------------------------------------------------
+CONTAINS
+
+#if defined key_agrif
+ RECURSIVE SUBROUTINE stp_LF( )
+ INTEGER :: kstp ! ocean time-step index
+#else
+ SUBROUTINE stp_LF( kstp )
+ INTEGER, INTENT(in) :: kstp ! ocean time-step index
+#endif
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE stp ***
+ !!
+ !! ** Purpose : - Time stepping of shallow water (SHW) (momentum and ssh eqs.)
+ !!
+ !! ** Method : -1- Update forcings
+ !! -2- Update the ssh at Naa
+ !! -3- Compute the momentum trends (Nrhs)
+ !! -4- Update the horizontal velocity
+ !! -5- Apply Asselin time filter to uu,vv,ssh
+ !! -6- Outputs and diagnostics
+ !!----------------------------------------------------------------------
+ INTEGER :: ji, jj, jk ! dummy loop indice
+ INTEGER :: indic ! error indicator if < 0
+!!gm kcall can be removed, I guess
+ INTEGER :: kcall ! optional integer argument (dom_vvl_sf_nxt)
+ REAL(wp):: z1_2rho0 ! local scalars
+
+ REAL(wp) :: zue3a, zue3n, zue3b ! local scalars
+ REAL(wp) :: zve3a, zve3n, zve3b ! - -
+ REAL(wp) :: ze3t_tf, ze3u_tf, ze3v_tf, zua, zva
+ !! ---------------------------------------------------------------------
+#if defined key_agrif
+ 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_iomput
+ IF( Agrif_Nbstepint() == 0 ) CALL iom_swap( cxios_context )
+# endif
+#endif
+ !
+ IF( ln_timing ) CALL timing_start('stp_LF')
+ !
+ !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ ! model timestep
+ !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ !
+ IF( l_1st_euler ) THEN ! start or restart with Euler 1st time-step
+ rDt = rn_Dt
+ r1_Dt = 1._wp / rDt
+ ENDIF
+
+ IF ( kstp == nit000 ) ww(:,:,:) = 0._wp ! initialize vertical velocity one for all to zero
+
+ !
+ !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ ! update I/O and calendar
+ !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ indic = 0 ! reset to no error condition
+
+ 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 passible 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 /= 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
+ CALL sbc ( kstp, Nbb, Nnn ) ! Sea Boundary Condition
+
+ !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ ! Ocean physics update
+ !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ ! LATERAL PHYSICS
+ ! ! eddy diffusivity 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)
+ uu(:,:,:,Nrhs) = 0._wp ! set dynamics trends to zero
+ vv(:,:,:,Nrhs) = 0._wp
+
+ IF( ln_bdy ) CALL bdy_dyn3d_dmp ( kstp, Nbb, uu, vv, Nrhs ) ! bdy damping trends
+
+#if defined key_agrif
+ IF(.NOT. Agrif_Root()) &
+ & CALL Agrif_Sponge_dyn ! momentum sponge
+#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( .NOT.ln_linssh ) CALL dom_qco_r3c ( ssh(:,:,Naa), r3t(:,:,Naa), r3u(:,:,Naa), r3v(:,:,Naa), r3f(:,:) ) ! "after" ssh./h._0 ratio explicit
+ !IF( .NOT.ln_linssh ) CALL dom_vvl_sf_nxt_st( kstp, Nbb, Nnn, Naa ) ! after vertical scale factors
+!!an - calcul du gradient de pression horizontal (explicit)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ uu(ji,jj,jk,Nrhs) = uu(ji,jj,jk,Nrhs) - grav * ( ssh(ji+1,jj,Nnn) - ssh(ji,jj,Nnn) ) * r1_e1u(ji,jj)
+ vv(ji,jj,jk,Nrhs) = vv(ji,jj,jk,Nrhs) - grav * ( ssh(ji,jj+1,Nnn) - ssh(ji,jj,Nnn) ) * r1_e2v(ji,jj)
+ END_3D
+ !
+ ! add wind stress forcing and layer linear friction to the RHS
+ z1_2rho0 = 0.5_wp * r1_rho0
+ DO_3D( 0, 0, 0, 0,1,jpkm1)
+ uu(ji,jj,jk,Nrhs) = uu(ji,jj,jk,Nrhs) + z1_2rho0 * ( utau_b(ji,jj) + utau(ji,jj) ) / e3u(ji,jj,jk,Nnn) &
+ & - rn_rfr * uu(ji,jj,jk,Nbb)
+ vv(ji,jj,jk,Nrhs) = vv(ji,jj,jk,Nrhs) + z1_2rho0 * ( vtau_b(ji,jj) + vtau(ji,jj) ) / e3v(ji,jj,jk,Nnn) &
+ & - rn_rfr * vv(ji,jj,jk,Nbb)
+ END_3D
+!!an
+
+ !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ ! Leap-Frog time splitting + Robert-Asselin time filter on u,v,e3
+ !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+!!st ssh_atf : add ssh filtering up there
+ IF ( .NOT.( l_1st_euler ) ) THEN ! Only do time filtering for leapfrog timesteps
+ ! ! filtering "now" field
+ ssh(:,:,Nnn) = ssh(:,:,Nnn) + rn_atfp * ( ssh(:,:,Nbb) - 2._wp * ssh(:,:,Nnn) + ssh(:,:,Naa) )
+ ENDIF
+!!st ssh_atf
+
+!! what about IF( .NOT.ln_linssh ) ?
+!!an futur module dyn_nxt (a la place de dyn_atf)
+
+ IF( ln_dynadv_vec ) THEN ! vector invariant form : applied on velocity
+ IF( l_1st_euler ) THEN ! Euler time stepping (no Asselin filter)
+ DO_3D( 0, 0, 0, 0,1,jpkm1)
+ uu(ji,jj,jk,Naa) = uu(ji,jj,jk,Nbb) + rDt * uu(ji,jj,jk,Nrhs) * umask(ji,jj,jk)
+ vv(ji,jj,jk,Naa) = vv(ji,jj,jk,Nbb) + rDt * vv(ji,jj,jk,Nrhs) * vmask(ji,jj,jk)
+ END_3D
+ ELSE ! Leap Frog time stepping + Asselin filter
+ DO_3D( 1, 1, 1, 1,1,jpkm1)
+ zua = uu(ji,jj,jk,Nbb) + rDt * uu(ji,jj,jk,Nrhs) * umask(ji,jj,jk)
+ zva = vv(ji,jj,jk,Nbb) + rDt * vv(ji,jj,jk,Nrhs) * vmask(ji,jj,jk)
+ ! ! Asselin time filter on u,v (Nnn)
+ uu(ji,jj,jk,Nnn) = uu(ji,jj,jk,Nnn) + rn_atfp * (uu(ji,jj,jk,Nbb) - 2._wp * uu(ji,jj,jk,Nnn) + zua)
+ vv(ji,jj,jk,Nnn) = vv(ji,jj,jk,Nnn) + rn_atfp * (vv(ji,jj,jk,Nbb) - 2._wp * vv(ji,jj,jk,Nnn) + zva)
+ !
+ uu(ji,jj,jk,Naa) = zua
+ vv(ji,jj,jk,Naa) = zva
+ END_3D
+ CALL dom_qco_r3c( ssh(:,:,Nnn), r3t(:,:,Nnn), r3u(:,:,Nnn), r3v(:,:,Nnn) ) ! "now" ssh/h_0 ratio from filtrered ssh
+#if ! defined key_qco
+ DO jk = 1, jpkm1
+ e3t(:,:,jk,Nnn) = e3t_0(:,:,jk) * ( 1._wp + r3t(:,:,Nnn) )
+ e3u(:,:,jk,Nnn) = e3u_0(:,:,jk) * ( 1._wp + r3u(:,:,Nnn) )
+ e3v(:,:,jk,Nnn) = e3v_0(:,:,jk) * ( 1._wp + r3v(:,:,Nnn) )
+ END DO
+#endif
+ ENDIF
+ !
+ ELSE ! flux form : applied on thickness weighted velocity
+ IF( l_1st_euler ) THEN ! Euler time stepping (no Asselin filter)
+ DO_3D( 0, 0, 0, 0,1,jpkm1)
+ zue3b = e3u(ji,jj,jk,Nbb) * uu(ji,jj,jk,Nbb)
+ zve3b = e3v(ji,jj,jk,Nbb) * vv(ji,jj,jk,Nbb)
+ ! ! LF time stepping
+ zue3a = zue3b + rDt * e3u(ji,jj,jk,Nrhs) * uu(ji,jj,jk,Nrhs) * umask(ji,jj,jk)
+ zve3a = zve3b + rDt * e3v(ji,jj,jk,Nrhs) * vv(ji,jj,jk,Nrhs) * vmask(ji,jj,jk)
+ !
+ uu(ji,jj,jk,Naa) = zue3a / e3u(ji,jj,jk,Naa)
+ vv(ji,jj,jk,Naa) = zve3a / e3v(ji,jj,jk,Naa)
+ END_3D
+ ELSE ! Leap Frog time stepping + Asselin filter
+ CALL dom_qco_r3c( ssh(:,:,Nnn), r3t_f(:,:), r3u_f(:,:), r3v_f(:,:) ) ! "now" ssh/h_0 ratio from filtrered ssh
+ DO_3D( 1, 1, 1, 1,1,jpkm1)
+ zue3n = e3u(ji,jj,jk,Nnn) * uu(ji,jj,jk,Nnn)
+ zve3n = e3v(ji,jj,jk,Nnn) * vv(ji,jj,jk,Nnn)
+ zue3b = e3u(ji,jj,jk,Nbb) * uu(ji,jj,jk,Nbb)
+ zve3b = e3v(ji,jj,jk,Nbb) * vv(ji,jj,jk,Nbb)
+ ! ! LF time stepping
+ zue3a = zue3b + rDt * e3u(ji,jj,jk,Nrhs) * uu(ji,jj,jk,Nrhs) * umask(ji,jj,jk)
+ zve3a = zve3b + rDt * e3v(ji,jj,jk,Nrhs) * vv(ji,jj,jk,Nrhs) * vmask(ji,jj,jk)
+ ! ! Asselin time filter on e3u/v/t
+ ze3u_tf = e3u(ji,jj,jk,Nnn) + rn_atfp * ( e3u(ji,jj,jk,Nbb) - 2._wp * e3u(ji,jj,jk,Nnn) + e3u(ji,jj,jk,Naa) )
+ ze3v_tf = e3v(ji,jj,jk,Nnn) + rn_atfp * ( e3v(ji,jj,jk,Nbb) - 2._wp * e3v(ji,jj,jk,Nnn) + e3v(ji,jj,jk,Naa) )
+ ze3t_tf = e3t(ji,jj,jk,Nnn) + rn_atfp * ( e3t(ji,jj,jk,Nbb) - 2._wp * e3t(ji,jj,jk,Nnn) + e3t(ji,jj,jk,Naa) )
+ ! ! Asselin time filter on u,v (Nnn)
+ uu(ji,jj,jk,Nnn) = ( zue3n + rn_atfp * ( zue3b - 2._wp * zue3n + zue3a ) ) / (e3u_0(ji,jj,jk) * ( 1._wp + r3u_f(ji,jj) ))
+ vv(ji,jj,jk,Nnn) = ( zve3n + rn_atfp * ( zve3b - 2._wp * zve3n + zve3a ) ) / (e3v_0(ji,jj,jk) * ( 1._wp + r3v_f(ji,jj) ))
+ !
+ uu(ji,jj,jk,Naa) = zue3a / e3u(ji,jj,jk,Naa)
+ vv(ji,jj,jk,Naa) = zve3a / e3v(ji,jj,jk,Naa)
+ END_3D
+ r3t(:,:,Nnn) = r3t_f(:,:)
+ r3u(:,:,Nnn) = r3u_f(:,:)
+ r3v(:,:,Nnn) = r3v_f(:,:)
+#if ! defined key_qco
+ DO jk = 1, jpkm1
+ e3t(:,:,jk,Nnn) = e3t_0(:,:,jk) * ( 1._wp + r3t(:,:,Nnn) )
+ e3u(:,:,jk,Nnn) = e3u_0(:,:,jk) * ( 1._wp + r3u(:,:,Nnn) )
+ e3v(:,:,jk,Nnn) = e3v_0(:,:,jk) * ( 1._wp + r3v(:,:,Nnn) )
+ END DO
+#endif
+ ENDIF
+ ENDIF
+
+
+ CALL lbc_lnk_multi( 'stp', uu(:,:,:,Nnn), 'U', -1., vv(:,:,:,Nnn), 'V', -1., & !* local domain boundaries
+ & uu(:,:,:,Naa), 'U', -1., vv(:,:,:,Naa), 'V', -1. )
+
+!!an
+
+ !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ ! Set boundary conditions, time filter and swap time levels
+ !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+
+!!an TO BE ADDED : dyn_nxt
+!! CALL dyn_atf ( kstp, Nbb, Nnn, Naa, uu, vv, e3t, e3u, e3v ) ! time filtering of "now" velocities and scale factors
+!!an TO BE ADDED : a simplifier
+! CALL ssh_atf ( kstp, Nbb, Nnn, Naa, ssh ) ! time filtering of "now" sea surface height
+!!st copied above
+!! IF ( .NOT.( l_1st_euler ) ) THEN ! Only do time filtering for leapfrog timesteps
+!! ! ! filtering "now" field
+!! ssh(:,:,Nnn) = ssh(:,:,Nnn) + rn_atfp * ( ssh(:,:,Nbb) - 2 * ssh(:,:,Nnn) + ssh(:,:,Naa) )
+!! ENDIF
+!!st
+!!an
+
+
+ ! Swap time levels
+ Nrhs = Nbb
+ Nbb = Nnn
+ Nnn = Naa
+ Naa = Nrhs
+ !
+! CALL dom_vvl_sf_update_st( kstp, Nbb, Nnn, Naa ) ! recompute vertical scale factors
+ !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ ! 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_wri ( kstp, Nnn ) ! ocean model: outputs
+
+ !
+ IF( lrst_oce ) CALL rst_write ( kstp, Nbb, Nnn ) ! write output ocean restart file
+
+
+#if defined key_agrif
+ !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ ! AGRIF
+ !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ Kbb_a = Nbb; Kmm_a = Nnn; Krhs_a = Nrhs ! agrif_oce module copies of time level indices
+ CALL Agrif_Integrate_ChildGrids( stp_LF ) ! allows to finish all the Child Grids before updating
+
+ IF( Agrif_NbStepint() == 0 ) THEN
+ CALL Agrif_update_all( ) ! Update all components
+ ENDIF
+#endif
+ IF( ln_diaobs ) CALL dia_obs ( kstp, Nnn ) ! obs-minus-model (assimilation) diagnostics (call after dynamics update)
+
+ !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ ! Control
+ !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ CALL stp_ctl ( kstp, Nbb, Nnn, indic )
+
+
+ IF( kstp == nit000 ) THEN ! 1st time step only
+ CALL iom_close( numror ) ! close input ocean restart file
+ IF(lwm) CALL FLUSH ( numond ) ! flush output namelist oce
+ IF(lwm .AND. numoni /= -1 ) CALL FLUSH ( numoni ) ! flush output namelist ice (if exist)
+ ENDIF
+
+ !
+#if defined key_iomput
+ IF( kstp == nitend .OR. indic < 0 ) THEN
+ CALL iom_context_finalize( cxios_context ) ! needed for XIOS+AGRIF
+ IF(lrxios) CALL iom_context_finalize( crxios_context )
+ 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_LF
+ !
+ !!======================================================================
+END MODULE stpLF
Index: /NEMO/branches/2020/r12377_ticket2386/src/SWE/stpRK3.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/SWE/stpRK3.F90 (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/src/SWE/stpRK3.F90 (revision 13540)
@@ -0,0 +1,378 @@
+MODULE stpRK3
+ !!======================================================================
+ !! *** MODULE step ***
+ !! Time-stepping : manager of the shallow water equation time stepping
+ !!======================================================================
+ !! History : NEMO ! 2020-03 (A. Nasser, G. Madec) Original code from 4.0.2
+ !!----------------------------------------------------------------------
+
+ !!----------------------------------------------------------------------
+ !! stpRK3 : Shallow Water time-stepping
+ !!----------------------------------------------------------------------
+ USE step_oce ! time stepping definition modules
+ USE phycst ! physical constants
+ USE usrdef_nam
+ !
+ USE iom ! xIOs server
+ USE domqco
+
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC stp_RK3 ! called by nemogcm.F90
+
+ !!----------------------------------------------------------------------
+ !! time level indices
+ !!----------------------------------------------------------------------
+ INTEGER, PUBLIC :: Nbb, Nnn, Naa, Nrhs !! used by nemo_init
+
+ !! * Substitutions
+# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
+ !!----------------------------------------------------------------------
+ !! NEMO/OCE 4.0 , NEMO Consortium (2018)
+ !! $Id: step.F90 12614 2020-03-26 14:59:52Z gm $
+ !! Software governed by the CeCILL license (see ./LICENSE)
+ !!----------------------------------------------------------------------
+CONTAINS
+
+#if defined key_agrif
+ RECURSIVE SUBROUTINE stp_RK3( )
+ INTEGER :: kstp ! ocean time-step index
+#else
+ SUBROUTINE stp_RK3( kstp )
+ INTEGER, INTENT(in) :: kstp ! ocean time-step index
+#endif
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE stp_RK3 ***
+ !!
+ !! ** Purpose : - Time stepping of shallow water (SHW) (momentum and ssh eqs.)
+ !!
+ !! ** Method : -1- Update forcings
+ !! -2- Update the ssh at Naa
+ !! -3- Compute the momentum trends (Nrhs)
+ !! -4- Update the horizontal velocity
+ !! -5- Apply Asselin time filter to uu,vv,ssh
+ !! -6- Outputs and diagnostics
+ !!----------------------------------------------------------------------
+ INTEGER :: ji, jj, jk ! dummy loop indice
+ INTEGER :: indic ! error indicator if < 0
+!!gm kcall can be removed, I guess
+ INTEGER :: kcall ! optional integer argument (dom_vvl_sf_nxt)
+ REAL(wp):: z1_2rho0, z5_6, z3_4 ! local scalars
+
+ REAL(wp) :: zue3a, zue3n, zue3b ! local scalars
+ REAL(wp) :: zve3a, zve3n, zve3b ! - -
+ REAL(wp) :: ze3t_tf, ze3u_tf, ze3v_tf, zua, zva
+ !! ---------------------------------------------------------------------
+#if defined key_agrif
+ 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_iomput
+ IF( Agrif_Nbstepint() == 0 ) CALL iom_swap( cxios_context )
+# endif
+#endif
+ !
+ IF( ln_timing ) CALL timing_start('stp_RK3')
+ !
+ !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ ! model timestep
+ !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ !
+ IF ( kstp == nit000 ) ww(:,:,:) = 0._wp ! initialize vertical velocity one for all to zero
+
+ !
+ !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ ! update I/O and calendar
+ !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ indic = 0 ! reset to no error condition
+
+ 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 passible 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 /= 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
+ CALL sbc ( kstp, Nbb, Nnn ) ! Sea Boundary Condition
+
+ !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ ! Ocean physics update
+ !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ ! LATERAL PHYSICS
+ ! ! eddy diffusivity coeff.
+ IF( l_ldfdyn_time ) CALL ldf_dyn( kstp, Nbb ) ! eddy viscosity coeff.
+
+
+ !======================================================================
+ !======================================================================
+ ! ===== RK3 =====
+ !======================================================================
+ !======================================================================
+
+
+ !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ ! RK3 1st stage Ocean dynamics : hdiv, ssh, e3, u, v, w
+ !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ rDt = rn_Dt / 3._wp
+ r1_Dt = 1._wp / rDt
+
+ CALL ssh_nxt ( kstp, Nbb, Nbb, ssh, Naa ) ! after ssh (includes call to div_hor)
+
+ uu(:,:,:,Nrhs) = 0._wp ! set dynamics trends to zero
+ vv(:,:,:,Nrhs) = 0._wp
+
+ CALL dyn_adv( kstp, Nbb, Nbb , uu, vv, Nrhs ) ! advection (VF or FF) ==> RHS
+
+ CALL dyn_vor( kstp, Nbb , uu, vv, Nrhs ) ! vorticity ==> RHS
+#if defined key_RK3all
+ CALL dyn_ldf( kstp, Nbb, Nbb , uu, vv, Nrhs ) ! lateral mixing
+#endif
+ !
+!!an - calcul du gradient de pression horizontal (explicit)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ uu(ji,jj,jk,Nrhs) = uu(ji,jj,jk,Nrhs) - grav * ( ssh(ji+1,jj,Nbb) - ssh(ji,jj,Nbb) ) * r1_e1u(ji,jj)
+ vv(ji,jj,jk,Nrhs) = vv(ji,jj,jk,Nrhs) - grav * ( ssh(ji,jj+1,Nbb) - ssh(ji,jj,Nbb) ) * r1_e2v(ji,jj)
+ END_3D
+ !
+#if defined key_RK3all
+ ! add wind stress forcing and layer linear friction to the RHS
+ z5_6 = 5._wp/6._wp
+ DO_3D( 0, 0, 0, 0,1,jpkm1)
+ uu(ji,jj,jk,Nrhs) = uu(ji,jj,jk,Nrhs) + r1_rho0 * ( z5_6*utau_b(ji,jj) + (1._wp - z5_6)*utau(ji,jj) ) / e3u(ji,jj,jk,Nbb) &
+ & - rn_rfr * uu(ji,jj,jk,Nbb)
+ vv(ji,jj,jk,Nrhs) = vv(ji,jj,jk,Nrhs) + r1_rho0 * ( z5_6*vtau_b(ji,jj) + (1._wp - z5_6)*vtau(ji,jj) ) / e3v(ji,jj,jk,Nbb) &
+ & - rn_rfr * vv(ji,jj,jk,Nbb)
+ END_3D
+#endif
+!!an
+ CALL dom_qco_r3c ( ssh(:,:,Naa), r3t(:,:,Naa), r3u(:,:,Naa), r3v(:,:,Naa), r3f(:,:) ) ! "after" ssh./h._0 ratio explicit
+ IF( ln_dynadv_vec ) THEN ! vector invariant form : applied on velocity
+ DO_3D( 0, 0, 0, 0,1,jpkm1)
+ uu(ji,jj,jk,Naa) = uu(ji,jj,jk,Nbb) + rDt * uu(ji,jj,jk,Nrhs) * umask(ji,jj,jk)
+ vv(ji,jj,jk,Naa) = vv(ji,jj,jk,Nbb) + rDt * vv(ji,jj,jk,Nrhs) * vmask(ji,jj,jk)
+ END_3D
+ ELSE
+ DO_3D( 0, 0, 0, 0,1,jpkm1) ! flux form : applied on thickness weighted velocity
+ uu(ji,jj,jk,Naa) = ( uu(ji,jj,jk,Nbb )*e3u(ji,jj,jk,Nbb) &
+ & + rDt * uu(ji,jj,jk,Nrhs)*e3t(ji,jj,jk,Nbb) * umask(ji,jj,jk) ) &
+ & / e3t(ji,jj,jk,Naa)
+ vv(ji,jj,jk,Naa) = ( vv(ji,jj,jk,Nbb )*e3v(ji,jj,jk,Nbb) &
+ & + rDt * vv(ji,jj,jk,Nrhs)*e3t(ji,jj,jk,Nbb) * vmask(ji,jj,jk) ) &
+ & / e3t(ji,jj,jk,Naa)
+ END_3D
+ ENDIF
+ ! Swap time levels
+ Nrhs= Nnn
+ Nnn = Naa
+ Naa = Nrhs
+
+
+ !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ ! RK3 2nd stage Ocean dynamics : hdiv, ssh, e3, u, v, w
+ !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ rDt = rn_Dt / 2._wp
+ r1_Dt = 1._wp / rDt
+
+ CALL ssh_nxt ( kstp, Nbb, Nnn, ssh, Naa ) ! after ssh (includes call to div_hor)
+
+ uu(:,:,:,Nrhs) = 0._wp ! set dynamics trends to zero
+ vv(:,:,:,Nrhs) = 0._wp
+!!st TBC for dyn_adv
+ CALL dyn_adv( kstp, Nbb, Nnn , uu, vv, Nrhs ) ! advection (VF or FF) ==> RHS
+
+ CALL dyn_vor( kstp, Nnn , uu, vv, Nrhs ) ! vorticity ==> RHS
+#if defined key_RK3all
+ CALL dyn_ldf( kstp, Nbb, Nbb , uu, vv, Nrhs ) ! lateral mixing
+#endif
+
+ !
+!!an - calcul du gradient de pression horizontal (explicit)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ uu(ji,jj,jk,Nrhs) = uu(ji,jj,jk,Nrhs) - grav * ( ssh(ji+1,jj,Nnn) - ssh(ji,jj,Nnn) ) * r1_e1u(ji,jj)
+ vv(ji,jj,jk,Nrhs) = vv(ji,jj,jk,Nrhs) - grav * ( ssh(ji,jj+1,Nnn) - ssh(ji,jj,Nnn) ) * r1_e2v(ji,jj)
+ END_3D
+ !
+ ! add wind stress forcing and layer linear friction to the RHS
+#if defined key_RK3all
+ z3_4 = 3._wp/4._wp
+ DO_3D( 0, 0, 0, 0,1,jpkm1)
+ uu(ji,jj,jk,Nrhs) = uu(ji,jj,jk,Nrhs) + r1_rho0 * ( z3_4*utau_b(ji,jj) + (1._wp - z3_4)*utau(ji,jj) ) / e3u(ji,jj,jk,Nbb) &
+ & - rn_rfr * uu(ji,jj,jk,Nbb)
+ vv(ji,jj,jk,Nrhs) = vv(ji,jj,jk,Nrhs) + r1_rho0 * ( z3_4*vtau_b(ji,jj) + (1._wp - z3_4)*vtau(ji,jj) ) / e3v(ji,jj,jk,Nbb) &
+ & - rn_rfr * vv(ji,jj,jk,Nbb)
+ END_3D
+#endif
+!!an
+ CALL dom_qco_r3c ( ssh(:,:,Naa), r3t(:,:,Naa), r3u(:,:,Naa), r3v(:,:,Naa), r3f(:,:) ) ! "after" ssh./h._0 ratio explicit
+ IF( ln_dynadv_vec ) THEN ! vector invariant form : applied on velocity
+ DO_3D( 0, 0, 0, 0,1,jpkm1)
+ uu(ji,jj,jk,Naa) = uu(ji,jj,jk,Nbb) + rDt * uu(ji,jj,jk,Nrhs) * umask(ji,jj,jk)
+ vv(ji,jj,jk,Naa) = vv(ji,jj,jk,Nbb) + rDt * vv(ji,jj,jk,Nrhs) * vmask(ji,jj,jk)
+ END_3D
+ ELSE
+ DO_3D( 0, 0, 0, 0,1,jpkm1) ! flux form : applied on thickness weighted velocity
+ uu(ji,jj,jk,Naa) = ( uu(ji,jj,jk,Nbb )*e3u(ji,jj,jk,Nbb) &
+ & + rDt * uu(ji,jj,jk,Nrhs)*e3t(ji,jj,jk,Nnn) * umask(ji,jj,jk) ) &
+ & / e3t(ji,jj,jk,Naa)
+ vv(ji,jj,jk,Naa) = ( vv(ji,jj,jk,Nbb )*e3v(ji,jj,jk,Nbb) &
+ & + rDt * vv(ji,jj,jk,Nrhs)*e3t(ji,jj,jk,Nnn) * vmask(ji,jj,jk) ) &
+ & / e3t(ji,jj,jk,Naa)
+ END_3D
+ ENDIF
+ ! Swap time levels
+ Nrhs= Nnn
+ Nnn = Naa
+ Naa = Nrhs
+
+ !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ ! RK3 3rd stage Ocean dynamics : hdiv, ssh, e3, u, v, w
+ !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ rDt = rn_Dt
+ r1_Dt = 1._wp / rDt
+
+ CALL ssh_nxt ( kstp, Nbb, Nnn, ssh, Naa ) ! after ssh (includes call to div_hor)
+
+ uu(:,:,:,Nrhs) = 0._wp ! set dynamics trends to zero
+ vv(:,:,:,Nrhs) = 0._wp
+
+ IF( ln_bdy ) CALL bdy_dyn3d_dmp ( kstp, Nbb, uu, vv, Nrhs ) ! bdy damping trends
+
+#if defined key_agrif
+ IF(.NOT. Agrif_Root()) &
+ & CALL Agrif_Sponge_dyn ! momentum sponge
+#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
+
+!!an - calcul du gradient de pression horizontal (explicit)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ uu(ji,jj,jk,Nrhs) = uu(ji,jj,jk,Nrhs) - grav * ( ssh(ji+1,jj,Nnn) - ssh(ji,jj,Nnn) ) * r1_e1u(ji,jj)
+ vv(ji,jj,jk,Nrhs) = vv(ji,jj,jk,Nrhs) - grav * ( ssh(ji,jj+1,Nnn) - ssh(ji,jj,Nnn) ) * r1_e2v(ji,jj)
+ END_3D
+ !
+ ! add wind stress forcing and layer linear friction to the RHS
+ z1_2rho0 = 0.5_wp * r1_rho0
+ DO_3D( 0, 0, 0, 0,1,jpkm1)
+ uu(ji,jj,jk,Nrhs) = uu(ji,jj,jk,Nrhs) + z1_2rho0 * ( utau_b(ji,jj) + utau(ji,jj) ) / e3u(ji,jj,jk,Nnn) &
+ & - rn_rfr * uu(ji,jj,jk,Nbb)
+ vv(ji,jj,jk,Nrhs) = vv(ji,jj,jk,Nrhs) + z1_2rho0 * ( vtau_b(ji,jj) + vtau(ji,jj) ) / e3v(ji,jj,jk,Nnn) &
+ & - rn_rfr * vv(ji,jj,jk,Nbb)
+ END_3D
+!!an
+ CALL dom_qco_r3c ( ssh(:,:,Naa), r3t(:,:,Naa), r3u(:,:,Naa), r3v(:,:,Naa), r3f(:,:) ) ! "after" ssh./h._0 ratio explicit
+ IF( ln_dynadv_vec ) THEN ! vector invariant form : applied on velocity
+ DO_3D( 1, 1, 1, 1,1,jpkm1)
+ zua = uu(ji,jj,jk,Nbb) + rDt * uu(ji,jj,jk,Nrhs) * umask(ji,jj,jk)
+ zva = vv(ji,jj,jk,Nbb) + rDt * vv(ji,jj,jk,Nrhs) * vmask(ji,jj,jk)
+ ! ! Asselin time filter on u,v (Nnn)
+ uu(ji,jj,jk,Nnn) = uu(ji,jj,jk,Nnn) + rn_atfp * (uu(ji,jj,jk,Nbb) - 2._wp * uu(ji,jj,jk,Nnn) + zua)
+ vv(ji,jj,jk,Nnn) = vv(ji,jj,jk,Nnn) + rn_atfp * (vv(ji,jj,jk,Nbb) - 2._wp * vv(ji,jj,jk,Nnn) + zva)
+ !
+ uu(ji,jj,jk,Naa) = zua
+ vv(ji,jj,jk,Naa) = zva
+ END_3D
+ !
+ ELSE ! flux form : applied on thickness weighted velocity
+ DO_3D( 1, 1, 1, 1,1,jpkm1)
+ zue3n = e3u(ji,jj,jk,Nnn) * uu(ji,jj,jk,Nnn)
+ zve3n = e3v(ji,jj,jk,Nnn) * vv(ji,jj,jk,Nnn)
+ zue3b = e3u(ji,jj,jk,Nbb) * uu(ji,jj,jk,Nbb)
+ zve3b = e3v(ji,jj,jk,Nbb) * vv(ji,jj,jk,Nbb)
+ ! ! LF time stepping
+ zue3a = zue3b + rDt * e3t(ji,jj,jk,Nbb) * uu(ji,jj,jk,Nrhs) * umask(ji,jj,jk)
+ zve3a = zve3b + rDt * e3t(ji,jj,jk,Nbb) * vv(ji,jj,jk,Nrhs) * vmask(ji,jj,jk)
+ !
+ uu(ji,jj,jk,Naa) = zue3a / e3t(ji,jj,jk,Naa)
+ vv(ji,jj,jk,Naa) = zve3a / e3t(ji,jj,jk,Naa)
+ END_3D
+!!st je ne comprends pas l'histoire des e3t et du Nbb et pas du Nnn pour le rhs ?
+ ENDIF
+
+
+ CALL lbc_lnk_multi( 'stp_RK3', uu(:,:,:,Nnn), 'U', -1., vv(:,:,:,Nnn), 'V', -1., & !* local domain boundaries
+ & uu(:,:,:,Naa), 'U', -1., vv(:,:,:,Naa), 'V', -1. )
+
+!!an
+
+
+ ! Swap time levels
+ Nrhs = Nbb
+ Nbb = Naa
+ Naa = Nrhs
+ !
+! CALL dom_vvl_sf_update_st( kstp, Nbb, Nnn, Naa ) ! recompute vertical scale factors
+ !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ ! 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_wri ( kstp, Nnn ) ! ocean model: outputs
+
+ !
+ IF( lrst_oce ) CALL rst_write ( kstp, Nbb, Nnn ) ! write output ocean restart file
+
+
+#if defined key_agrif
+ !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ ! AGRIF
+ !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ Kbb_a = Nbb; Kmm_a = Nnn; Krhs_a = Nrhs ! agrif_oce module copies of time level indices
+ CALL Agrif_Integrate_ChildGrids( stp_RK3 ) ! allows to finish all the Child Grids before updating
+
+ IF( Agrif_NbStepint() == 0 ) THEN
+ CALL Agrif_update_all( ) ! Update all components
+ ENDIF
+#endif
+ IF( ln_diaobs ) CALL dia_obs ( kstp, Nnn ) ! obs-minus-model (assimilation) diagnostics (call after dynamics update)
+
+ !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ ! Control
+ !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ CALL stp_ctl ( kstp, Nbb, Nnn, indic )
+
+
+ IF( kstp == nit000 ) THEN ! 1st time step only
+ CALL iom_close( numror ) ! close input ocean restart file
+ IF(lwm) CALL FLUSH ( numond ) ! flush output namelist oce
+ IF(lwm .AND. numoni /= -1 ) CALL FLUSH ( numoni ) ! flush output namelist ice (if exist)
+ ENDIF
+
+ !
+#if defined key_iomput
+ IF( kstp == nitend .OR. indic < 0 ) THEN
+ CALL iom_context_finalize( cxios_context ) ! needed for XIOS+AGRIF
+ IF(lrxios) CALL iom_context_finalize( crxios_context )
+ 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_RK3')
+ !
+ END SUBROUTINE stp_RK3
+ !
+ !!======================================================================
+END MODULE stpRK3
Index: /NEMO/branches/2020/r12377_ticket2386/src/SWE/stpctl.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/SWE/stpctl.F90 (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/src/SWE/stpctl.F90 (revision 13540)
@@ -0,0 +1,264 @@
+MODULE stpctl
+ !!======================================================================
+ !! *** MODULE stpctl ***
+ !! Ocean run control : gross check of the ocean time stepping
+ !!======================================================================
+ !! History : OPA ! 1991-03 (G. Madec) Original code
+ !! 6.0 ! 1992-06 (M. Imbard)
+ !! 8.0 ! 1997-06 (A.M. Treguier)
+ !! NEMO 1.0 ! 2002-06 (G. Madec) F90: Free form and module
+ !! 2.0 ! 2009-07 (G. Madec) Add statistic for time-spliting
+ !! 3.7 ! 2016-09 (G. Madec) Remove solver
+ !! 4.0 ! 2017-04 (G. Madec) regroup global communications
+ !!----------------------------------------------------------------------
+
+ !!----------------------------------------------------------------------
+ !! stp_ctl : Control the run
+ !!----------------------------------------------------------------------
+ USE oce ! ocean dynamics and tracers variables
+ USE dom_oce ! ocean space and time domain variables
+ USE c1d ! 1D vertical configuration
+ USE zdf_oce , ONLY : ln_zad_Aimp ! ocean vertical physics variables
+ USE wet_dry, ONLY : ll_wd, ssh_ref ! reference depth for negative bathy
+ !
+ USE diawri ! Standard run outputs (dia_wri_state routine)
+ USE in_out_manager ! I/O manager
+ USE lbclnk ! ocean lateral boundary conditions (or mpp link)
+ USE lib_mpp ! distributed memory computing
+ !
+ USE netcdf ! NetCDF library
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC stp_ctl ! routine called by step.F90
+
+ INTEGER :: nrunid ! netcdf file id
+ INTEGER, DIMENSION(2) :: nvarid ! netcdf variable id
+ !!----------------------------------------------------------------------
+ !! NEMO/OCE 4.0 , NEMO Consortium (2018)
+ !! $Id: stpctl.F90 13216 2020-07-02 09:25:49Z rblod $
+ !! Software governed by the CeCILL license (see ./LICENSE)
+ !!----------------------------------------------------------------------
+CONTAINS
+
+ SUBROUTINE stp_ctl( kt, Kmm )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE stp_ctl ***
+ !!
+ !! ** Purpose : Control the run
+ !!
+ !! ** Method : - Save the time step in numstp
+ !! - Stop the run IF problem encountered by setting nstop > 0
+ !! Problems checked: negative sea surface height
+ !! |U| maximum larger than 10 m/s
+ !!
+ !! ** Actions : "time.step" file = last ocean time-step
+ !! "run.stat" file = run statistics
+ !! nstop indicator sheared among all local domain
+ !!----------------------------------------------------------------------
+ INTEGER, INTENT(in ) :: kt ! ocean time-step index
+ INTEGER, INTENT(in ) :: Kmm ! ocean time level index
+ !!
+ INTEGER :: ji ! dummy loop indices
+ INTEGER :: idtime, istatus
+ INTEGER , DIMENSION(3) :: iareasum, iareamin, iareamax
+ INTEGER , DIMENSION(3,2) :: iloc ! min/max loc indices
+ REAL(wp) :: zzz ! local real
+ REAL(wp), DIMENSION(3) :: zmax, zmaxlocal
+ LOGICAL :: ll_wrtstp, ll_colruns, ll_wrtruns
+ LOGICAL, DIMENSION(jpi,jpj,jpk) :: llmsk
+ CHARACTER(len=20) :: clname
+ !!----------------------------------------------------------------------
+ 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
+ !
+ IF( kt == nit000 ) THEN
+ !
+ IF( lwp ) THEN
+ WRITE(numout,*)
+ WRITE(numout,*) 'stp_ctl : time-stepping control'
+ WRITE(numout,*) '~~~~~~~'
+ ENDIF
+ ! ! open time.step ascii file, done only by 1st subdomain
+ IF( lwm ) CALL ctl_opn( numstp, 'time.step', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea )
+ !
+ IF( ll_wrtruns ) THEN
+ ! ! open run.stat ascii file, done only by 1st subdomain
+ CALL ctl_opn( numrun, 'run.stat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea )
+ ! ! open run.stat.nc netcdf file, done only by 1st subdomain
+ clname = 'run.stat.nc'
+ IF( .NOT. Agrif_Root() ) clname = TRIM(Agrif_CFixed())//"_"//TRIM(clname)
+ istatus = NF90_CREATE( TRIM(clname), NF90_CLOBBER, nrunid )
+ istatus = NF90_DEF_DIM( nrunid, 'time', NF90_UNLIMITED, idtime )
+ istatus = NF90_DEF_VAR( nrunid, 'abs_ssh_max', NF90_DOUBLE, (/ idtime /), nvarid(1) )
+ istatus = NF90_DEF_VAR( nrunid, 'abs_u_max', NF90_DOUBLE, (/ idtime /), nvarid(2) )
+ istatus = NF90_ENDDEF(nrunid)
+ ENDIF
+ !
+ ENDIF
+ !
+ ! !== write current time step ==!
+ ! !== done only by 1st subdomain at writting timestep ==!
+ IF( lwm .AND. ll_wrtstp ) THEN
+ WRITE ( numstp, '(1x, i8)' ) kt
+ REWIND( numstp )
+ ENDIF
+ ! !== test of local extrema ==!
+ ! !== done by all processes at every time step ==!
+ !
+ llmsk( 1:Nis1,:,:) = .FALSE. ! exclude halos from the checked region
+ llmsk(Nie1: jpi,:,:) = .FALSE.
+ llmsk(:, 1:Njs1,:) = .FALSE.
+ llmsk(:,Nje1: jpj,:) = .FALSE.
+ !
+ llmsk(Nis0:Nie0,Njs0:Nje0,1) = tmask(Nis0:Nie0,Njs0:Nje0,1) == 1._wp ! define only the inner domain
+ zmax(1) = MAXVAL( -e3t(:,:,1,Kmm) ), mask = llmsk(:,:,1) ) ! ssh max
+ llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain
+ zmax(2) = MAXVAL( ABS( uu(:,:,:,Kmm) ), mask = llmsk(:,:,:) ) ! velocity max (zonal only)
+ zmax(3) = REAL( nstop, wp ) ! stop indicator
+ ! !== get global extrema ==!
+ ! !== done by all processes if writting run.stat ==!
+ IF( ll_colruns ) THEN
+ zmaxlocal(:) = zmax(:)
+ CALL mpp_max( "stpctl", zmax ) ! max over the global domain
+ nstop = NINT( zmax(3) ) ! update nstop indicator (now sheared among all local domains)
+ ENDIF
+ ! !== write "run.stat" files ==!
+ ! !== done only by 1st subdomain at writting timestep ==!
+ IF( ll_wrtruns ) THEN
+ WRITE(numrun,9500) kt, zmax(1), zmax(2)
+ istatus = NF90_PUT_VAR( nrunid, nvarid(1), (/ -zmax(1)/), (/kt/), (/1/) )
+ istatus = NF90_PUT_VAR( nrunid, nvarid(2), (/ zmax(2)/), (/kt/), (/1/) )
+ IF( kt == nitend ) istatus = NF90_CLOSE(nrunid)
+ END IF
+ ! !== error handling ==!
+ ! !== done by all processes at every time step ==!
+ !
+ IF( zmax(1) > 0._wp .OR. & ! negative sea surface height
+ & zmax(2) > 10._wp .OR. & ! too large velocity ( > 10 m/s)
+ & ISNAN( zmax(1) + zmax(2) ) .OR. & ! NaN encounter in the tests
+ & ABS( zmax(1) + zmax(2) ) > HUGE(1._wp) ) THEN ! Infinity encounter in the tests
+ !
+ iloc(:,:) = 0
+ IF( ll_colruns ) THEN ! zmax is global, so it is the same on all subdomains -> no dead lock with mpp_maxloc
+ ! 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
+ llmsk(Nis0:Nie0,Njs0:Nje0,1) = tmask(Nis0:Nie0,Njs0:Nje0,1) == 1._wp ! define only the inner domain
+ CALL mpp_maxloc( 'stpctl', -e3t(:,:,1,Kmm) , llmsk(:,:,1), zzz, iloc(1:2,1) ) ! mpp_maxloc ok if mask = F
+ llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain
+ CALL mpp_maxloc( 'stpctl', ABS(uu(:,:,:,Kmm)), llmsk(:,:,:), zzz, iloc(1:3,2) )
+ ! find which subdomain has the max.
+ iareamin(:) = jpnij+1 ; iareamax(:) = 0 ; iareasum(:) = 0
+ DO ji = 1, 3
+ IF( zmaxlocal(ji) == zmax(ji) ) THEN
+ iareamin(ji) = narea ; iareamax(ji) = narea ; iareasum(ji) = 1
+ ENDIF
+ END DO
+ CALL mpp_min( "stpctl", iareamin ) ! min over the global domain
+ CALL mpp_max( "stpctl", iareamax ) ! max over the global domain
+ 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
+ llmsk(Nis0:Nie0,Njs0:Nje0,1) = tmask(Nis0:Nie0,Njs0:Nje0,1) == 1._wp ! define only the inner domain
+ iloc(1:2,1) = MAXLOC( -e3t(:,:,1,Kmm) , mask = llmsk(:,:,1) )
+ 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, 2 ! local domain indices ==> global domain indices, excluding halos
+ iloc(1:2,ji) = (/ mig0(iloc(1,ji)), mjg0(iloc(2,ji)) /)
+ END DO
+ iareamin(:) = narea ; iareamax(:) = narea ; iareasum(:) = 1 ! this is local information
+ ENDIF
+ !
+ WRITE(ctmp1,*) ' stp_ctl: |ssh| > 20 m or |U| > 10 m/s or S <= 0 or S >= 100 or NaN encounter in the tests'
+ CALL wrt_line( ctmp2, kt, '|e3t| min', -zmax(1), iloc(:,1), iareasum(1), iareamin(1), iareamax(1) )
+ CALL wrt_line( ctmp3, kt, '|U| max', zmax(2), iloc(:,2), iareasum(2), iareamin(2), iareamax(2) )
+ IF( Agrif_Root() ) THEN
+ WRITE(ctmp6,*) ' ===> output of last computed fields in output.abort* files'
+ ELSE
+ WRITE(ctmp6,*) ' ===> output of last computed fields in '//TRIM(Agrif_CFixed())//'_output.abort* files'
+ ENDIF
+ !
+ 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, ' ', 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, ' ', ctmp6 )
+ ENDIF
+ !
+ ENDIF
+ !
+ IF( nstop > 0 ) THEN ! an error was detected and we did not abort yet...
+ ngrdstop = Agrif_Fixed() ! store which grid got this error
+ IF( .NOT. ll_colruns .AND. jpnij > 1 ) CALL ctl_stop( 'STOP' ) ! we must abort here to avoid MPI deadlock
+ ENDIF
+ !
+9500 FORMAT(' it :', i8, ' |ssh|_max: ', D23.16, ' |U|_max: ', D23.16,' S_min: ', D23.16,' S_max: ', D23.16)
+ !
+ END SUBROUTINE stp_ctl
+
+
+ SUBROUTINE wrt_line( cdline, kt, cdprefix, pval, kloc, ksum, kmin, kmax )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE wrt_line ***
+ !!
+ !! ** Purpose : write information line
+ !!
+ !!----------------------------------------------------------------------
+ CHARACTER(len=*), INTENT( out) :: cdline
+ CHARACTER(len=*), INTENT(in ) :: cdprefix
+ REAL(wp), INTENT(in ) :: pval
+ INTEGER, DIMENSION(3), INTENT(in ) :: kloc
+ INTEGER, INTENT(in ) :: kt, ksum, kmin, kmax
+ !
+ CHARACTER(len=80) :: clsuff
+ CHARACTER(len=9 ) :: clkt, clsum, clmin, clmax
+ CHARACTER(len=9 ) :: cli, clj, clk
+ CHARACTER(len=1 ) :: clfmt
+ CHARACTER(len=4 ) :: cl4 ! needed to be able to compile with Agrif, I don't know why
+ INTEGER :: ifmtk
+ !!----------------------------------------------------------------------
+ WRITE(clkt , '(i9)') kt
+
+ WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpnij ,wp))) + 1 ! how many digits to we need to write ? (we decide max = 9)
+ !!! WRITE(clsum, '(i'//clfmt//')') ksum ! this is creating a compilation error with AGRIF
+ cl4 = '(i'//clfmt//')' ; WRITE(clsum, cl4) ksum
+ WRITE(clfmt, '(i1)') INT(LOG10(REAL(MAX(1,jpnij-1),wp))) + 1 ! how many digits to we need to write ? (we decide max = 9)
+ cl4 = '(i'//clfmt//')' ; WRITE(clmin, cl4) kmin-1
+ WRITE(clmax, cl4) kmax-1
+ !
+ WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpiglo,wp))) + 1 ! how many digits to we need to write jpiglo? (we decide max = 9)
+ cl4 = '(i'//clfmt//')' ; WRITE(cli, cl4) kloc(1) ! this is ok with AGRIF
+ WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpjglo,wp))) + 1 ! how many digits to we need to write jpjglo? (we decide max = 9)
+ cl4 = '(i'//clfmt//')' ; WRITE(clj, cl4) kloc(2) ! this is ok with AGRIF
+ !
+ IF( ksum == 1 ) THEN ; WRITE(clsuff,9100) TRIM(clmin)
+ ELSE ; WRITE(clsuff,9200) TRIM(clsum), TRIM(clmin), TRIM(clmax)
+ ENDIF
+ IF(kloc(3) == 0) THEN
+ ifmtk = INT(LOG10(REAL(jpk,wp))) + 1 ! how many digits to we need to write jpk? (we decide max = 9)
+ clk = REPEAT(' ', ifmtk) ! create the equivalent in blank string
+ WRITE(cdline,9300) TRIM(ADJUSTL(clkt)), TRIM(ADJUSTL(cdprefix)), pval, TRIM(cli), TRIM(clj), clk(1:ifmtk), TRIM(clsuff)
+ ELSE
+ WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpk,wp))) + 1 ! how many digits to we need to write jpk? (we decide max = 9)
+ !!! WRITE(clk, '(i'//clfmt//')') kloc(3) ! this is creating a compilation error with AGRIF
+ cl4 = '(i'//clfmt//')' ; WRITE(clk, cl4) kloc(3) ! this is ok with AGRIF
+ WRITE(cdline,9400) TRIM(ADJUSTL(clkt)), TRIM(ADJUSTL(cdprefix)), pval, TRIM(cli), TRIM(clj), TRIM(clk), TRIM(clsuff)
+ ENDIF
+ !
+9100 FORMAT('MPI rank ', a)
+9200 FORMAT('found in ', a, ' MPI tasks, spread out among ranks ', a, ' to ', a)
+9300 FORMAT('kt ', a, ' ', a, ' ', 1pg11.4, ' at i j ', a, ' ', a, ' ', a, ' ', a)
+9400 FORMAT('kt ', a, ' ', a, ' ', 1pg11.4, ' at i j k ', a, ' ', a, ' ', a, ' ', a)
+ !
+ END SUBROUTINE wrt_line
+
+
+ !!======================================================================
+END MODULE stpctl
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/C14/trcatm_c14.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/C14/trcatm_c14.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/C14/trcatm_c14.F90 (revision 13540)
@@ -120,5 +120,5 @@
IF( ierr3 /= 0 ) CALL ctl_stop( 'STOP', 'trc_atm_c14_ini: unable to allocate fareaz' )
!
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 ) ! from C14b package
IF( gphit(ji,jj) >= yn40 ) THEN
fareaz(ji,jj,1) = 0.
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/C14/trcini_c14.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/C14/trcini_c14.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/C14/trcini_c14.F90 (revision 13540)
@@ -69,8 +69,8 @@
!
CALL iom_get( numrtr, 'co2sbc', co2sbc )
- CALL iom_get( numrtr, jpdom_autoglo, 'c14sbc', c14sbc )
- CALL iom_get( numrtr, jpdom_autoglo, 'exch_co2', exch_co2 )
- CALL iom_get( numrtr, jpdom_autoglo, 'exch_c14', exch_c14 )
- CALL iom_get( numrtr, jpdom_autoglo, 'qtr_c14', qtr_c14 )
+ CALL iom_get( numrtr, jpdom_auto, 'c14sbc', c14sbc )
+ CALL iom_get( numrtr, jpdom_auto, 'exch_co2', exch_co2 )
+ CALL iom_get( numrtr, jpdom_auto, 'exch_c14', exch_c14 )
+ CALL iom_get( numrtr, jpdom_auto, 'qtr_c14', qtr_c14 )
!
END IF
@@ -85,5 +85,5 @@
ELSE
!
- CALL iom_get( numrtr, jpdom_autoglo, 'qint_c14', qint_c14 )
+ CALL iom_get( numrtr, jpdom_auto, 'qint_c14', qint_c14 )
!
ENDIF
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/C14/trcsms_c14.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/C14/trcsms_c14.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/C14/trcsms_c14.F90 (revision 13540)
@@ -28,4 +28,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/TOP 4.0 , NEMO Consortium (2018)
@@ -80,5 +81,5 @@
! -------------------------------------------------------------------
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
IF( tmask(ji,jj,1) > 0. ) THEN
!
@@ -127,10 +128,10 @@
!
! Add the surface flux to the trend of jp_c14
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
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_11_11( 1, jpk )
+ DO_3D( 1, 1, 1, 1, 1, jpk )
!
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)
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/C14/trcwri_c14.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/C14/trcwri_c14.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/C14/trcwri_c14.F90 (revision 13540)
@@ -60,5 +60,5 @@
zz3d(:,:,:) = 0._wp
!
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
IF( tmask(ji,jj,jk) > 0._wp) THEN
z3d (ji,jj,jk) = tr(ji,jj,jk,jp_c14,Kmm)
@@ -71,5 +71,5 @@
z2d(:,:) =0._wp
jk = 1
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
ztemp = zres(ji,jj) / c14sbc(ji,jj)
IF( ztemp > 0._wp .AND. tmask(ji,jj,jk) > 0._wp ) z2d(ji,jj) = LOG( ztemp )
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/CFC/trcini_cfc.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/CFC/trcini_cfc.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/CFC/trcini_cfc.F90 (revision 13540)
@@ -132,5 +132,5 @@
!---------------------------------------------------------------------------------------
zyd = ylatn - ylats
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
IF( gphit(ji,jj) >= ylatn ) THEN ; xphem(ji,jj) = 1.e0
ELSEIF( gphit(ji,jj) <= ylats ) THEN ; xphem(ji,jj) = 0.e0
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/CFC/trcsms_cfc.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/CFC/trcsms_cfc.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/CFC/trcsms_cfc.F90 (revision 13540)
@@ -49,4 +49,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/TOP 4.0 , NEMO Consortium (2018)
@@ -125,6 +126,6 @@
! !------------!
- DO_2D_11_11
-
+ DO_2D( 1, 1, 1, 1 ) ! i-j loop !
+ ! !------------!
! space interpolation
zpp_cfc = xphem(ji,jj) * zpatm(1,jl) &
@@ -297,5 +298,5 @@
DO jn = jp_cfc0, jp_cfc1
jl = jl + 1
- CALL iom_get( numrtr, jpdom_autoglo, 'qint_'//ctrcnm(jn), qint_cfc(:,:,jl) )
+ CALL iom_get( numrtr, jpdom_auto, 'qint_'//ctrcnm(jn), qint_cfc(:,:,jl) )
END DO
ENDIF
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P2Z/p2zbio.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P2Z/p2zbio.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P2Z/p2zbio.F90 (revision 13540)
@@ -19,5 +19,5 @@
!
USE lbclnk !
- USE prtctl_trc ! Print control for debbuging
+ USE prtctl ! Print control for debbuging
USE iom !
@@ -58,4 +58,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/TOP 4.0 , NEMO Consortium (2018)
@@ -121,5 +122,5 @@
DO jk = 1, jpkbm1 ! Upper ocean (bio-layers) !
! ! -------------------------- !
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
! trophic variables( det, zoo, phy, no3, nh4, dom)
! ------------------------------------------------
@@ -241,5 +242,5 @@
DO jk = jpkb, jpkm1 ! Upper ocean (bio-layers) !
! ! -------------------------- !
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
! remineralisation of all quantities towards nitrate
@@ -338,6 +339,6 @@
!
IF( lk_iomput ) THEN
- CALL lbc_lnk( 'p2zbio', zw2d(:,:,:),'T', 1. )
- CALL lbc_lnk_multi( 'p2zbio', zw3d(:,:,:,1),'T', 1., zw3d(:,:,:,2),'T', 1., zw3d(:,:,:,3),'T', 1. )
+ CALL lbc_lnk( 'p2zbio', zw2d(:,:,:),'T', 1.0_wp )
+ CALL lbc_lnk_multi( '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) )
@@ -366,6 +367,6 @@
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
WRITE(charout, FMT="('bio')")
- CALL prt_ctl_trc_info(charout)
- CALL prt_ctl_trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)
+ CALL prt_ctl_info( charout, cdcomp = 'top' )
+ CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm)
ENDIF
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P2Z/p2zexp.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P2Z/p2zexp.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P2Z/p2zexp.F90 (revision 13540)
@@ -17,5 +17,5 @@
USE p2zsed
USE lbclnk
- USE prtctl_trc ! Print control for debbuging
+ USE prtctl ! Print control for debbuging
USE trd_oce
USE trdtrc
@@ -39,4 +39,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/TOP 4.0 , NEMO Consortium (2018)
@@ -81,5 +82,5 @@
! LAYERS IS DETERMINED BY DMIN3 DEFINED IN sms_p2z.F90
! ----------------------------------------------------------------------
- DO_3D_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
ze3t = 1. / e3t(ji,jj,jk,Kmm)
tr(ji,jj,jk,jpno3,Krhs) = tr(ji,jj,jk,jpno3,Krhs) + ze3t * dmin3(ji,jj,jk) * xksi(ji,jj)
@@ -92,5 +93,5 @@
zgeolpoc = 0.e0 ! Initialization
! Release of nutrients from the "simple" sediment
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
ikt = mbkt(ji,jj)
tr(ji,jj,ikt,jpno3,Krhs) = tr(ji,jj,ikt,jpno3,Krhs) + sedlam * sedpocn(ji,jj) / e3t(ji,jj,ikt,Kmm)
@@ -102,9 +103,9 @@
END_2D
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
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. )
+ CALL lbc_lnk( 'p2zexp', sedpocn, 'T', 1.0_wp )
! Oa & Ek: diagnostics depending on jpdia2d ! left as example
@@ -120,5 +121,5 @@
ELSE
!
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
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
@@ -139,6 +140,6 @@
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
WRITE(charout, FMT="('exp')")
- CALL prt_ctl_trc_info(charout)
- CALL prt_ctl_trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)
+ CALL prt_ctl_info( charout, cdcomp = 'top' )
+ CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm)
ENDIF
!
@@ -173,5 +174,5 @@
zdm0 = 0._wp
zrro = 1._wp
- DO_3D_11_11( jpkb, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 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
@@ -190,5 +191,5 @@
dminl(:,:) = 0._wp
dmin3(:,:,:) = zdm0
- DO_3D_11_11( 1, jpk )
+ DO_3D( 1, 1, 1, 1, 1, jpk )
IF( tmask(ji,jj,jk) == 0._wp ) THEN
dminl(ji,jj) = dminl(ji,jj) + dmin3(ji,jj,jk)
@@ -197,5 +198,5 @@
END_3D
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
IF( tmask(ji,jj,1) == 0 ) dmin3(ji,jj,1) = 0._wp
END_2D
@@ -203,5 +204,5 @@
! Coastal mask
cmask(:,:) = 0._wp
- DO_2D_00_00
+ DO_2D( 0, 0, 0, 0 )
IF( tmask(ji,jj,1) /= 0. ) THEN
zmaskt = tmask(ji+1,jj,1) * tmask(ji-1,jj,1) * tmask(ji,jj+1,1) * tmask(ji,jj-1,1)
@@ -209,10 +210,10 @@
END IF
END_2D
- CALL lbc_lnk( 'p2zexp', cmask , 'T', 1. ) ! lateral boundary conditions on cmask (sign unchanged)
+ CALL lbc_lnk( 'p2zexp', cmask , 'T', 1.0_wp ) ! lateral boundary conditions on cmask (sign unchanged)
areacot = glob_sum( 'p2zexp', e1e2t(:,:) * cmask(:,:) )
!
IF( ln_rsttr ) THEN
- CALL iom_get( numrtr, jpdom_autoglo, 'SEDB'//ctrcnm(jpdet), sedpocb(:,:) )
- CALL iom_get( numrtr, jpdom_autoglo, 'SEDN'//ctrcnm(jpdet), sedpocn(:,:) )
+ CALL iom_get( numrtr, jpdom_auto, 'SEDB'//ctrcnm(jpdet), sedpocb(:,:) )
+ CALL iom_get( numrtr, jpdom_auto, 'SEDN'//ctrcnm(jpdet), sedpocn(:,:) )
ELSE
sedpocb(:,:) = 0._wp
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P2Z/p2zopt.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P2Z/p2zopt.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P2Z/p2zopt.F90 (revision 13540)
@@ -18,5 +18,5 @@
USE trc
USE sms_pisces
- USE prtctl_trc ! Print control for debbuging
+ USE prtctl ! Print control for debbuging
IMPLICIT NONE
@@ -40,4 +40,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/TOP 4.0 , NEMO Consortium (2018)
@@ -94,5 +95,5 @@
! ! Photosynthetically Available Radiation (PAR)
zcoef = 12 * redf / rcchl / rpig ! --------------------------------------
- DO_3D_11_11( 2, jpk )
+ DO_3D( 1, 1, 1, 1, 2, jpk ) ! local par at w-levels
zpig = LOG( MAX( TINY(0.), tr(ji,jj,jk-1,jpphy,Kmm) ) * zcoef )
zkr = xkr0 + xkrp * EXP( xlr * zpig )
@@ -101,5 +102,5 @@
zparg(ji,jj,jk) = zparg(ji,jj,jk-1) * EXP( -zkg * e3t(ji,jj,jk-1,Kmm) )
END_3D
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 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 )
@@ -113,9 +114,9 @@
! ! --------------
neln(:,:) = 1 ! euphotic layer level
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 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_11_11
+ DO_2D( 1, 1, 1, 1 )
heup(ji,jj) = gdepw(ji,jj,neln(ji,jj),Kmm)
END_2D
@@ -124,6 +125,6 @@
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
WRITE(charout, FMT="('opt')")
- CALL prt_ctl_trc_info( charout )
- CALL prt_ctl_trc( tab4d=tr(:,:,:,:,Kmm), mask=tmask, clinfo=ctrcnm )
+ CALL prt_ctl_info( charout, cdcomp = 'top' )
+ CALL prt_ctl( tab4d_1=tr(:,:,:,:,Kmm), mask1=tmask, clinfo=ctrcnm )
ENDIF
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P2Z/p2zsed.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P2Z/p2zsed.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P2Z/p2zsed.F90 (revision 13540)
@@ -18,5 +18,5 @@
USE lbclnk !
USE iom !
- USE prtctl_trc ! Print control for debbuging
+ USE prtctl ! Print control for debbuging
IMPLICIT NONE
@@ -33,4 +33,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/TOP 4.0 , NEMO Consortium (2018)
@@ -88,5 +89,5 @@
! tracer flux divergence at t-point added to the general trend
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 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)
@@ -108,6 +109,6 @@
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
WRITE(charout, FMT="('sed')")
- CALL prt_ctl_trc_info(charout)
- CALL prt_ctl_trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)
+ CALL prt_ctl_info( charout, cdcomp = 'top' )
+ CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm)
ENDIF
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zagg.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zagg.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zagg.F90 (revision 13540)
@@ -17,5 +17,5 @@
USE trc ! passive tracers common variables
USE sms_pisces ! PISCES Source Minus Sink variables
- USE prtctl_trc ! print control for debugging
+ USE prtctl ! print control for debugging
IMPLICIT NONE
@@ -60,5 +60,5 @@
IF( ln_p4z ) THEN
!
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
!
zfact = xstep * xdiss(ji,jj,jk)
@@ -102,5 +102,5 @@
ELSE ! ln_p5z
!
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
!
zfact = xstep * xdiss(ji,jj,jk)
@@ -170,6 +170,6 @@
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
WRITE(charout, FMT="('agg')")
- CALL prt_ctl_trc_info(charout)
- CALL prt_ctl_trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)
+ CALL prt_ctl_info( charout, cdcomp = 'top' )
+ CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm)
ENDIF
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zbc.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zbc.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zbc.F90 (revision 13540)
@@ -48,4 +48,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/TOP 4.0 , NEMO Consortium (2018)
@@ -111,5 +112,5 @@
IF( ll_river ) THEN
jl = n_trc_indcbc(jpno3)
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
DO jk = 1, nk_rnf(ji,jj)
zcoef = rn_rfact / ( e1e2t(ji,jj) * h_rnf(ji,jj) * rn_cbc_time ) * tmask(ji,jj,1)
@@ -144,5 +145,5 @@
ALLOCATE( zironice(jpi,jpj) )
!
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
zdep = rfact / e3t(ji,jj,1,Kmm)
zwflux = fmmflx(ji,jj) / 1000._wp
@@ -287,5 +288,5 @@
CALL iom_open ( TRIM( sn_ironsed%clname ), numiron )
ALLOCATE( zcmask(jpi,jpj,jpk) )
- CALL iom_get ( numiron, jpdom_data, TRIM( sn_ironsed%clvar ), zcmask(:,:,:), 1 )
+ CALL iom_get ( numiron, jpdom_global, TRIM( sn_ironsed%clvar ), zcmask(:,:,:), 1 )
CALL iom_close( numiron )
!
@@ -296,5 +297,5 @@
IF(lwp) WRITE(numout,*)
IF(lwp) WRITE(numout,*) ' Level corresponding to 50m depth ', ik50,' ', gdept_1d(ik50+1)
- DO_3D_00_00( 1, ik50 )
+ DO_3D( 0, 0, 0, 0, 1, ik50 )
ze3t = e3t_0(ji,jj,jk)
zsurfc = e1u(ji,jj) * ( 1. - umask(ji ,jj ,jk) ) &
@@ -310,7 +311,7 @@
END_3D
!
- CALL lbc_lnk( 'p4zbc', zcmask , 'T', 1. ) ! lateral boundary conditions on cmask (sign unchanged)
- !
- DO_3D_11_11( 1, jpk )
+ CALL lbc_lnk( 'p4zbc', zcmask , 'T', 1.0_wp ) ! lateral boundary conditions on cmask (sign unchanged)
+ !
+ DO_3D( 1, 1, 1, 1, 1, jpk )
zexpide = MIN( 8.,( gdept(ji,jj,jk,Kmm) / 500. )**(-1.5) )
zdenitide = -0.9543 + 0.7662 * LOG( zexpide ) - 0.235 * LOG( zexpide )**2
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zbio.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zbio.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zbio.F90 (revision 13540)
@@ -30,5 +30,5 @@
USE p4zfechem
USE p4zligand ! Prognostic ligand model
- USE prtctl_trc ! print control for debugging
+ USE prtctl ! print control for debugging
USE iom ! I/O manager
@@ -40,4 +40,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/TOP 4.0 , NEMO Consortium (2018)
@@ -71,5 +72,5 @@
xdiss(:,:,:) = 1.
!!gm the use of nmld should be better here?
- DO_3D_11_11( 2, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 2, jpkm1 )
!!gm : use nmln and test on jk ... less memory acces
IF( gdepw(ji,jj,jk+1,Kmm) > hmld(ji,jj) ) xdiss(ji,jj,jk) = 0.01
@@ -107,6 +108,6 @@
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
WRITE(charout, FMT="('bio ')")
- CALL prt_ctl_trc_info(charout)
- CALL prt_ctl_trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)
+ CALL prt_ctl_info( charout, cdcomp = 'top' )
+ CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm)
ENDIF
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zche.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zche.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zche.F90 (revision 13540)
@@ -132,4 +132,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/TOP 4.0 , NEMO Consortium (2018)
@@ -178,5 +179,5 @@
! 0.04°C relative to an exact computation
! ---------------------------------------------------------------------
- DO_3D_11_11( 1, jpk )
+ DO_3D( 1, 1, 1, 1, 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) )
@@ -471,5 +472,5 @@
IF( ln_timing ) CALL timing_start('ahini_for_at')
!
- DO_3D_11_11( 1, jpk )
+ DO_3D( 1, 1, 1, 1, 1, jpk )
p_alkcb = tr(ji,jj,jk,jptal,Kbb) * 1000. / (rhop(ji,jj,jk) + rtrn)
p_dictot = tr(ji,jj,jk,jpdic,Kbb) * 1000. / (rhop(ji,jj,jk) + rtrn)
@@ -569,5 +570,5 @@
! TOTAL H+ scale: conversion factor for Htot = aphscale * Hfree
- DO_3D_11_11( 1, jpk )
+ DO_3D( 1, 1, 1, 1, 1, jpk )
IF (rmask(ji,jj,jk) == 1.) THEN
p_alktot = tr(ji,jj,jk,jptal,Kbb) * 1000. / (rhop(ji,jj,jk) + rtrn)
@@ -598,5 +599,5 @@
DO jn = 1, jp_maxniter_atgen
- DO_3D_11_11( 1, jpk )
+ DO_3D( 1, 1, 1, 1, 1, jpk )
IF (rmask(ji,jj,jk) == 1.) THEN
zfact = rhop(ji,jj,jk) / 1000. + rtrn
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zfechem.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zfechem.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zfechem.F90 (revision 13540)
@@ -16,5 +16,5 @@
USE p4zche ! chemical model
USE p4zbc ! Boundary conditions from sediments
- USE prtctl_trc ! print control for debugging
+ USE prtctl ! print control for debugging
USE iom ! I/O manager
@@ -33,4 +33,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/TOP 4.0 , NEMO Consortium (2018)
@@ -91,5 +92,5 @@
! Chemistry is supposed to be fast enough to be at equilibrium
! ------------------------------------------------------------
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
zTL1(ji,jj,jk) = ztotlig(ji,jj,jk)
zkeq = fekeq(ji,jj,jk)
@@ -106,5 +107,5 @@
zdust = 0. ! if no dust available
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 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]).
@@ -117,8 +118,4 @@
!
zfeequi = zFe3(ji,jj,jk) * 1E-9
- zhplus = max( rtrn, hi(ji,jj,jk) )
- fe3sol = fesol(ji,jj,jk,1) * ( zhplus**3 + fesol(ji,jj,jk,2) * zhplus**2 &
- & + fesol(ji,jj,jk,3) * zhplus + fesol(ji,jj,jk,4) &
- & + fesol(ji,jj,jk,5) / zhplus )
zfecoll = 0.5 * zFeL1(ji,jj,jk) * 1E-9
! precipitation of Fe3+, creation of nanoparticles
@@ -176,5 +173,5 @@
IF( ln_ligand ) THEN
!
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
zlam1a = ( 0.369 * 0.3 * tr(ji,jj,jk,jpdoc,Kbb) + 102.4 * tr(ji,jj,jk,jppoc,Kbb) ) * xdiss(ji,jj,jk) &
& + ( 114. * 0.3 * tr(ji,jj,jk,jpdoc,Kbb) )
@@ -221,6 +218,6 @@
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
WRITE(charout, FMT="('fechem')")
- CALL prt_ctl_trc_info(charout)
- CALL prt_ctl_trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)
+ CALL prt_ctl_info( charout, cdcomp = 'top' )
+ CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm)
ENDIF
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zflx.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zflx.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zflx.F90 (revision 13540)
@@ -19,5 +19,5 @@
USE sms_pisces ! PISCES Source Minus Sink variables
USE p4zche ! Chemical model
- USE prtctl_trc ! print control for debugging
+ USE prtctl ! print control for debugging
USE iom ! I/O manager
USE fldread ! read input fields
@@ -54,4 +54,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/TOP 4.0 , NEMO Consortium (2018)
@@ -109,5 +110,5 @@
IF( l_co2cpl ) satmco2(:,:) = atm_co2(:,:)
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
! DUMMY VARIABLES FOR DIC, H+, AND BORATE
zfact = rhop(ji,jj,1) / 1000. + rtrn
@@ -125,5 +126,5 @@
! -------------------------------------------
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
ztc = MIN( 35., ts(ji,jj,1,jp_tem,Kmm) )
ztc2 = ztc * ztc
@@ -144,5 +145,5 @@
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
ztkel = tempis(ji,jj,1) + 273.15
zsal = salinprac(ji,jj,1) + ( 1.- tmask(ji,jj,1) ) * 35.
@@ -177,6 +178,6 @@
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
WRITE(charout, FMT="('flx ')")
- CALL prt_ctl_trc_info(charout)
- CALL prt_ctl_trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)
+ CALL prt_ctl_info( charout, cdcomp = 'top' )
+ CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm)
ENDIF
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zligand.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zligand.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zligand.F90 (revision 13540)
@@ -12,5 +12,5 @@
USE trc ! passive tracers common variables
USE sms_pisces ! PISCES Source Minus Sink variables
- USE prtctl_trc ! print control for debugging
+ USE prtctl ! print control for debugging
USE iom ! I/O manager
@@ -52,5 +52,5 @@
IF( ln_timing ) CALL timing_start('p4z_ligand')
!
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
!
! ------------------------------------------------------------------
@@ -89,6 +89,6 @@
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
WRITE(charout, FMT="('ligand1')")
- CALL prt_ctl_trc_info(charout)
- CALL prt_ctl_trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)
+ CALL prt_ctl_info( charout, cdcomp = 'top' )
+ CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm)
ENDIF
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zlim.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zlim.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zlim.F90 (revision 13540)
@@ -98,5 +98,5 @@
IF( ln_timing ) CALL timing_start('p4z_lim')
!
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
! Tuning of the iron concentration to a minimum level that is set to the detection limit
@@ -161,5 +161,5 @@
zlim1 = xdiatno3(ji,jj,jk) + xdiatnh4(ji,jj,jk)
zlim2 = tr(ji,jj,jk,jppo4,Kbb) / ( tr(ji,jj,jk,jppo4,Kbb) + zconc1dnh4 )
- zlim3 = tr(ji,jj,jk,jpsil,Kbb) / ( tr(ji,jj,jk,jpsil,Kbb) + xksi(ji,jj) )
+ zlim3 = tr(ji,jj,jk,jpsil,Kbb) / ( tr(ji,jj,jk,jpsil,Kbb) + xksi(ji,jj) + rtrn )
zratio = tr(ji,jj,jk,jpdfe,Kbb) * z1_trbdia
zironmin = xcoef1 * tr(ji,jj,jk,jpdch,Kbb) * z1_trbdia + xcoef2 * zlim1 + xcoef3 * xdiatno3(ji,jj,jk)
@@ -173,5 +173,5 @@
! Compute the fraction of nanophytoplankton that is made of calcifiers
! --------------------------------------------------------------------
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
zlim1 = ( tr(ji,jj,jk,jpno3,Kbb) * concnnh4 + tr(ji,jj,jk,jpnh4,Kbb) * concnno3 ) &
& / ( concnno3 * concnnh4 + concnnh4 * tr(ji,jj,jk,jpno3,Kbb) + concnno3 * tr(ji,jj,jk,jpnh4,Kbb) )
@@ -193,5 +193,5 @@
END_3D
!
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 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) ) &
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zlys.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zlys.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zlys.F90 (revision 13540)
@@ -20,5 +20,5 @@
USE sms_pisces ! PISCES Source Minus Sink variables
USE p4zche ! Chemical model
- USE prtctl_trc ! print control for debugging
+ USE prtctl ! print control for debugging
USE iom ! I/O manager
@@ -75,5 +75,5 @@
CALL solve_at_general( zhinit, zhi, Kbb )
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 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 )
@@ -87,5 +87,5 @@
! ---------------------------------------------------------
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
! DEVIATION OF [CO3--] FROM SATURATION VALUE
@@ -130,6 +130,6 @@
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
WRITE(charout, FMT="('lys ')")
- CALL prt_ctl_trc_info(charout)
- CALL prt_ctl_trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)
+ CALL prt_ctl_info( charout, cdcomp = 'top' )
+ CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm)
ENDIF
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zmeso.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zmeso.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zmeso.F90 (revision 13540)
@@ -15,5 +15,5 @@
USE sms_pisces ! PISCES Source Minus Sink variables
USE p4zprod ! production
- USE prtctl_trc ! print control for debugging
+ USE prtctl ! print control for debugging
USE iom ! I/O manager
@@ -69,5 +69,6 @@
REAL(wp) :: zfact , zfood, zfoodlim, zproport, zbeta
REAL(wp) :: zmortzgoc, zfrac, zfracfe, zratio, zratio2, zfracal, zgrazcal
- REAL(wp) :: zepsherf, zepshert, zepsherv, zgrarsig, zgraztotc, zgraztotn, zgraztotf
+ REAL(wp) :: zepsherf, zepshert, zepsherv, zepsherq
+ REAL(wp) :: zgrarsig, zgraztotc, zgraztotn, zgraztotf
REAL(wp) :: zgrarem2, zgrafer2, zgrapoc2, zprcaca, zmortz, zgrasrat, zgrasratn
REAL(wp) :: zrespz, ztortz, zgrazd, zgrazz, zgrazpof
@@ -80,5 +81,5 @@
IF( ln_timing ) CALL timing_start('p4z_meso')
!
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
zcompam = MAX( ( tr(ji,jj,jk,jpmes,Kbb) - 1.e-9 ), 0.e0 )
zfact = xstep * tgfunc2(ji,jj,jk) * zcompam
@@ -156,6 +157,12 @@
zgrazing2(ji,jj,jk) = zgraztotc
- ! Mesozooplankton efficiency
- ! --------------------------
+ ! Mesozooplankton efficiency.
+ ! We adopt a formulation proposed by Mitra et al. (2007)
+ ! The gross growth efficiency is controled by the most limiting nutrient.
+ ! Growth is also further decreased when the food quality is poor. This is currently
+ ! hard coded : it can be decreased by up to 50% (zepsherq)
+ ! GGE can also be decreased when food quantity is high, zepsherf (Montagnes and
+ ! Fulton, 2012)
+ ! -----------------------------------------------------------------------------------
zgrasrat = ( zgraztotf + rtrn )/ ( zgraztotc + rtrn )
zgrasratn = ( zgraztotn + rtrn )/ ( zgraztotc + rtrn )
@@ -163,5 +170,6 @@
zbeta = MAX(0., (epsher2 - epsher2min) )
zepsherf = epsher2min + zbeta / ( 1.0 + 0.04E6 * 12. * zfood * zbeta )
- zepsherv = zepsherf * zepshert
+ zepsherq = 0.5 + (1.0 - 0.5) * zepshert * ( 1.0 + 1.0 ) / ( zepshert + 1.0 )
+ zepsherv = zepsherf * zepshert * zepsherq
zgrarem2 = zgraztotc * ( 1. - zepsherv - unass2 ) &
@@ -170,4 +178,5 @@
& + ferat3 * ( ( 1. - epsher2 - unass2 ) /( 1. - epsher2 ) * ztortz )
zgrapoc2 = zgraztotc * unass2
+
! Update the arrays TRA which contain the biological sources and sinks
@@ -237,6 +246,6 @@
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
WRITE(charout, FMT="('meso')")
- CALL prt_ctl_trc_info(charout)
- CALL prt_ctl_trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)
+ CALL prt_ctl_info( charout, cdcomp = 'top' )
+ CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm)
ENDIF
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zmicro.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zmicro.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zmicro.F90 (revision 13540)
@@ -17,5 +17,5 @@
USE p4zprod ! production
USE iom ! I/O manager
- USE prtctl_trc ! print control for debugging
+ USE prtctl ! print control for debugging
IMPLICIT NONE
@@ -67,5 +67,6 @@
REAL(wp) :: zgraze , zdenom, zdenom2
REAL(wp) :: zfact , zfood, zfoodlim, zbeta
- REAL(wp) :: zepsherf, zepshert, zepsherv, zgrarsig, zgraztotc, zgraztotn, zgraztotf
+ REAL(wp) :: zepsherf, zepshert, zepsherv, zepsherq
+ REAL(wp) :: zgrarsig, zgraztotc, zgraztotn, zgraztotf
REAL(wp) :: zgrarem, zgrafer, zgrapoc, zprcaca, zmortz
REAL(wp) :: zrespz, ztortz, zgrasrat, zgrasratn
@@ -78,5 +79,5 @@
IF( ln_timing ) CALL timing_start('p4z_micro')
!
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
zcompaz = MAX( ( tr(ji,jj,jk,jpzoo,Kbb) - 1.e-9 ), 0.e0 )
zfact = xstep * tgfunc2(ji,jj,jk) * zcompaz
@@ -119,6 +120,13 @@
zgrazing(ji,jj,jk) = zgraztotc
- ! Various remineralization and excretion terms
- ! --------------------------------------------
+
+ ! Microzooplankton efficiency.
+ ! We adopt a formulation proposed by Mitra et al. (2007)
+ ! The gross growth efficiency is controled by the most limiting nutrient.
+ ! Growth is also further decreased when the food quality is poor. This is currently
+ ! hard coded : it can be decreased by up to 50% (zepsherq)
+ ! GGE can also be decreased when food quantity is high, zepsherf (Montagnes and
+ ! Fulton, 2012)
+ ! -----------------------------------------------------------------------------
zgrasrat = ( zgraztotf + rtrn ) / ( zgraztotc + rtrn )
zgrasratn = ( zgraztotn + rtrn ) / ( zgraztotc + rtrn )
@@ -126,5 +134,6 @@
zbeta = MAX(0., (epsher - epshermin) )
zepsherf = epshermin + zbeta / ( 1.0 + 0.04E6 * 12. * zfood * zbeta )
- zepsherv = zepsherf * zepshert
+ zepsherq = 0.5 + (1.0 - 0.5) * zepshert * ( 1.0 + 1.0 ) / ( zepshert + 1.0 )
+ zepsherv = zepsherf * zepshert * zepsherq
zgrafer = zgraztotc * MAX( 0. , ( 1. - unass ) * zgrasrat - ferat3 * zepsherv )
@@ -193,6 +202,6 @@
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
WRITE(charout, FMT="('micro')")
- CALL prt_ctl_trc_info(charout)
- CALL prt_ctl_trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)
+ CALL prt_ctl_info( charout, cdcomp = 'top' )
+ CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm)
ENDIF
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zmort.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zmort.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zmort.F90 (revision 13540)
@@ -15,5 +15,5 @@
USE p4zprod ! Primary productivity
USE p4zlim ! Phytoplankton limitation terms
- USE prtctl_trc ! print control for debugging
+ USE prtctl ! print control for debugging
IMPLICIT NONE
@@ -77,5 +77,5 @@
!
prodcal(:,:,:) = 0._wp ! calcite production variable set to zero
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
zcompaph = MAX( ( tr(ji,jj,jk,jpphy,Kbb) - 1e-8 ), 0.e0 )
! When highly limited by macronutrients, very small cells
@@ -120,6 +120,6 @@
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
WRITE(charout, FMT="('nano')")
- CALL prt_ctl_trc_info(charout)
- CALL prt_ctl_trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)
+ CALL prt_ctl_info( charout, cdcomp = 'top' )
+ CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm)
ENDIF
!
@@ -152,5 +152,5 @@
! ------------------------------------------------------------
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
zcompadi = MAX( ( tr(ji,jj,jk,jpdia,Kbb) - 1e-9), 0. )
@@ -192,6 +192,6 @@
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
WRITE(charout, FMT="('diat')")
- CALL prt_ctl_trc_info(charout)
- CALL prt_ctl_trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)
+ CALL prt_ctl_info( charout, cdcomp = 'top' )
+ CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm)
ENDIF
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zopt.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zopt.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zopt.F90 (revision 13540)
@@ -16,5 +16,5 @@
USE iom ! I/O manager
USE fldread ! time interpolation
- USE prtctl_trc ! print control for debugging
+ USE prtctl ! print control for debugging
IMPLICIT NONE
@@ -37,11 +37,8 @@
REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: par_varsw ! PAR fraction of shortwave
REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ekb, ekg, ekr ! wavelength (Red-Green-Blue)
-
- INTEGER :: nksrp ! levels below which the light cannot penetrate ( depth larger than 391 m)
-
- REAL(wp), DIMENSION(3,61) :: xkrgb ! tabulated attenuation coefficients for RGB absorption
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/TOP 4.0 , NEMO Consortium (2018)
@@ -88,12 +85,12 @@
IF( ln_p5z ) zchl3d(:,:,:) = zchl3d(:,:,:) + tr(:,:,:,jppch,Kbb)
!
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
zchl = ( zchl3d(ji,jj,jk) + rtrn ) * 1.e6
zchl = MIN( 10. , MAX( 0.05, zchl ) )
irgb = NINT( 41 + 20.* LOG10( zchl ) + rtrn )
!
- ekb(ji,jj,jk) = xkrgb(1,irgb) * e3t(ji,jj,jk,Kmm)
- ekg(ji,jj,jk) = xkrgb(2,irgb) * e3t(ji,jj,jk,Kmm)
- ekr(ji,jj,jk) = xkrgb(3,irgb) * e3t(ji,jj,jk,Kmm)
+ ekb(ji,jj,jk) = rkrgb(1,irgb) * e3t(ji,jj,jk,Kmm)
+ ekg(ji,jj,jk) = rkrgb(2,irgb) * e3t(ji,jj,jk,Kmm)
+ ekr(ji,jj,jk) = rkrgb(3,irgb) * e3t(ji,jj,jk,Kmm)
END_3D
! !* Photosynthetically Available Radiation (PAR)
@@ -105,5 +102,5 @@
CALL p4z_opt_par( kt, Kmm, zqsr_corr, ze1, ze2, ze3, pqsr100 = zqsr100 )
!
- DO jk = 1, nksrp
+ 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)
@@ -111,5 +108,5 @@
END DO
IF( ln_p5z ) THEN
- DO jk = 1, nksrp
+ DO jk = 1, nksr
epico (:,:,jk) = 1.94 * ze1(:,:,jk) + 0.66 * ze2(:,:,jk) + 0.4 * ze3(:,:,jk)
END DO
@@ -120,5 +117,5 @@
CALL p4z_opt_par( kt, Kmm, zqsr_corr, ze1, ze2, ze3 )
!
- DO jk = 1, nksrp
+ DO jk = 1, nksr
etot(:,:,jk) = ze1(:,:,jk) + ze2(:,:,jk) + ze3(:,:,jk)
END DO
@@ -130,5 +127,5 @@
CALL p4z_opt_par( kt, Kmm, zqsr_corr, ze1, ze2, ze3, pqsr100 = zqsr100 )
!
- DO jk = 1, nksrp
+ 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)
@@ -136,5 +133,5 @@
END DO
IF( ln_p5z ) THEN
- DO jk = 1, nksrp
+ DO jk = 1, nksr
epico(:,:,jk) = 1.94 * ze1(:,:,jk) + 0.66 * ze2(:,:,jk) + 0.4 * ze3(:,:,jk)
END DO
@@ -149,5 +146,5 @@
!
etot3(:,:,1) = qsr(:,:) * tmask(:,:,1)
- DO jk = 2, nksrp + 1
+ DO jk = 2, nksr + 1
etot3(:,:,jk) = ( ze0(:,:,jk) + ze1(:,:,jk) + ze2(:,:,jk) + ze3(:,:,jk) ) * tmask(:,:,jk)
END DO
@@ -159,5 +156,5 @@
heup_01(:,:) = gdepw(:,:,2,Kmm)
- DO_3D_11_11( 2, nksrp )
+ DO_3D( 1, 1, 1, 1, 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
@@ -177,5 +174,5 @@
zetmp2 (:,:) = 0.e0
- DO_3D_11_11( 1, nksrp )
+ DO_3D( 1, 1, 1, 1, 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) ! remineralisation
@@ -188,5 +185,5 @@
zpar(:,:,:) = etot_ndcy(:,:,:) ! diagnostic : PAR with no diurnal cycle
!
- DO_3D_11_11( 1, nksrp )
+ DO_3D( 1, 1, 1, 1, 1, nksr )
IF( gdepw(ji,jj,jk+1,Kmm) <= hmld(ji,jj) ) THEN
z1_dep = 1. / ( zdepmoy(ji,jj) + rtrn )
@@ -200,5 +197,5 @@
zetmp4 (:,:) = 0.e0
!
- DO_3D_11_11( 1, nksrp )
+ DO_3D( 1, 1, 1, 1, 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) ! production
@@ -210,5 +207,5 @@
ediatm(:,:,:) = ediat(:,:,:)
!
- DO_3D_11_11( 1, nksrp )
+ DO_3D( 1, 1, 1, 1, 1, nksr )
IF( gdepw(ji,jj,jk+1,Kmm) <= hmld(ji,jj) ) THEN
z1_dep = 1. / ( zdepmoy(ji,jj) + rtrn )
@@ -220,5 +217,5 @@
IF( ln_p5z ) THEN
ALLOCATE( zetmp5(jpi,jpj) ) ; zetmp5 (:,:) = 0.e0
- DO_3D_11_11( 1, nksrp )
+ DO_3D( 1, 1, 1, 1, 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) ! production
@@ -228,5 +225,5 @@
epicom(:,:,:) = epico(:,:,:)
!
- DO_3D_11_11( 1, nksrp )
+ DO_3D( 1, 1, 1, 1, 1, nksr )
IF( gdepw(ji,jj,jk+1,Kmm) <= hmld(ji,jj) ) THEN
z1_dep = 1. / ( zdepmoy(ji,jj) + rtrn )
@@ -282,5 +279,5 @@
pe3(:,:,1) = zqsr(:,:)
!
- DO jk = 2, nksrp + 1
+ DO jk = 2, nksr + 1
DO jj = 1, jpj
DO ji = 1, jpi
@@ -301,5 +298,5 @@
pe3(:,:,1) = zqsr(:,:) * EXP( -0.5 * ekr(:,:,1) )
!
- DO_3D_11_11( 2, nksrp )
+ DO_3D( 1, 1, 1, 1, 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) ) )
@@ -399,9 +396,4 @@
ntimes_par = iom_getszuld( numpar ) ! get number of record in file
ENDIF
- !
- CALL trc_oce_rgb( xkrgb ) ! tabulated attenuation coefficients
- nksrp = trc_oce_ext_lev( r_si2, 0.33e2 ) ! max level of light extinction (Blue Chl=0.01)
- !
- IF(lwp) WRITE(numout,*) ' level of light extinction = ', nksrp, ' ref depth = ', gdepw_1d(nksrp+1), ' m'
!
ekr (:,:,:) = 0._wp
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zpoc.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zpoc.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zpoc.F90 (revision 13540)
@@ -15,5 +15,5 @@
USE trc ! passive tracers common variables
USE sms_pisces ! PISCES Source Minus Sink variables
- USE prtctl_trc ! print control for debugging
+ USE prtctl ! print control for debugging
USE iom ! I/O manager
@@ -39,4 +39,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/TOP 4.0 , NEMO Consortium (2018)
@@ -106,5 +107,5 @@
! -----------------------------------------------------------------------
ztremint(:,:,:) = zremigoc(:,:,:)
- DO_3D_11_11( 2, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 2, jpkm1 )
IF (tmask(ji,jj,jk) == 1.) THEN
zdep = hmld(ji,jj)
@@ -191,5 +192,5 @@
IF( ln_p4z ) THEN
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
! POC disaggregation by turbulence and bacterial activity.
! --------------------------------------------------------
@@ -211,5 +212,5 @@
END_3D
ELSE
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
! POC disaggregation by turbulence and bacterial activity.
! --------------------------------------------------------
@@ -241,6 +242,6 @@
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
WRITE(charout, FMT="('poc1')")
- CALL prt_ctl_trc_info(charout)
- CALL prt_ctl_trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)
+ CALL prt_ctl_info( charout, cdcomp = 'top' )
+ CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm)
ENDIF
@@ -259,5 +260,5 @@
! ----------------------------------------------------------------
!
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
zdep = hmld(ji,jj)
IF (tmask(ji,jj,jk) == 1. .AND. gdept(ji,jj,jk,Kmm) <= zdep ) THEN
@@ -274,5 +275,5 @@
! ---------------------------------------------------------------------
ztremint(:,:,:) = zremipoc(:,:,:)
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
IF (tmask(ji,jj,jk) == 1.) THEN
zdep = hmld(ji,jj)
@@ -309,5 +310,5 @@
! -----------------------------------------------------------------------
!
- DO_3D_11_11( 2, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 2, jpkm1 )
IF (tmask(ji,jj,jk) == 1.) THEN
zdep = hmld(ji,jj)
@@ -383,5 +384,5 @@
IF( ln_p4z ) THEN
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
IF (tmask(ji,jj,jk) == 1.) THEN
! POC disaggregation by turbulence and bacterial activity.
@@ -400,5 +401,5 @@
END_3D
ELSE
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
! POC disaggregation by turbulence and bacterial activity.
! --------------------------------------------------------
@@ -433,6 +434,6 @@
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
WRITE(charout, FMT="('poc2')")
- CALL prt_ctl_trc_info(charout)
- CALL prt_ctl_trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)
+ CALL prt_ctl_info( charout, cdcomp = 'top' )
+ CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm)
ENDIF
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zprod.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zprod.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zprod.F90 (revision 13540)
@@ -16,5 +16,5 @@
USE sms_pisces ! PISCES Source Minus Sink variables
USE p4zlim ! Co-limitations of differents nutrients
- USE prtctl_trc ! print control for debugging
+ USE prtctl ! print control for debugging
USE iom ! I/O manager
@@ -48,4 +48,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/TOP 4.0 , NEMO Consortium (2018)
@@ -109,5 +110,5 @@
! day length in hours
zstrn(:,:) = 0.
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
zargu = TAN( zcodel ) * TAN( gphit(ji,jj) * rad )
zargu = MAX( -1., MIN( 1., zargu ) )
@@ -116,5 +117,5 @@
! Impact of the day duration and light intermittency on phytoplankton growth
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN
zval = MAX( 1., zstrn(ji,jj) )
@@ -134,5 +135,5 @@
! Computation of the P-I slope for nanos and diatoms
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN
ztn = MAX( 0., ts(ji,jj,jk,jp_tem,Kmm) - 15. )
@@ -149,5 +150,5 @@
END_3D
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN
! Computation of production function for Carbon
@@ -170,5 +171,5 @@
! Computation of a proxy of the N/C ratio
! ---------------------------------------
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 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 )
@@ -180,5 +181,5 @@
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN
@@ -204,5 +205,5 @@
! Sea-ice effect on production
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 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) )
@@ -210,5 +211,5 @@
! Computation of the various production terms
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN
! production terms for nanophyto. (C)
@@ -236,5 +237,5 @@
! Computation of the chlorophyll production terms
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN
! production terms for nanophyto. ( chlorophyll )
@@ -259,5 +260,5 @@
! Update the arrays TRA which contain the biological sources and sinks
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN
zproreg = zprorcan(ji,jj,jk) - zpronewn(ji,jj,jk)
@@ -287,5 +288,5 @@
IF( ln_ligand ) THEN
zpligprod1(:,:,:) = 0._wp ; zpligprod2(:,:,:) = 0._wp
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN
zdocprod = excretd * zprorcad(ji,jj,jk) + excretn * zprorcan(ji,jj,jk)
@@ -330,6 +331,6 @@
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
WRITE(charout, FMT="('prod')")
- CALL prt_ctl_trc_info(charout)
- CALL prt_ctl_trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)
+ CALL prt_ctl_info( charout, cdcomp = 'top' )
+ CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm)
ENDIF
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zrem.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zrem.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zrem.F90 (revision 13540)
@@ -18,5 +18,5 @@
USE p4zprod ! Growth rate of the 2 phyto groups
USE p4zlim
- USE prtctl_trc ! print control for debugging
+ USE prtctl ! print control for debugging
USE iom ! I/O manager
@@ -44,4 +44,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/TOP 4.0 , NEMO Consortium (2018)
@@ -88,5 +89,5 @@
! that was modeling explicitely bacteria
! -------------------------------------------------------
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
zdep = MAX( hmld(ji,jj), heup(ji,jj) )
IF( gdept(ji,jj,jk,Kmm) < zdep ) THEN
@@ -102,5 +103,5 @@
IF( ln_p4z ) THEN
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
! DOC ammonification. Depends on depth, phytoplankton biomass
! and a limitation term which is supposed to be a parameterization of the bacterial activity.
@@ -133,5 +134,5 @@
END_3D
ELSE
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
! DOC ammonification. Depends on depth, phytoplankton biomass
! and a limitation term which is supposed to be a parameterization of the bacterial activity.
@@ -177,5 +178,5 @@
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
! NH4 nitrification to NO3. Ceased for oxygen concentrations
! below 2 umol/L. Inhibited at strong light
@@ -195,9 +196,9 @@
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
WRITE(charout, FMT="('rem1')")
- CALL prt_ctl_trc_info(charout)
- CALL prt_ctl_trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)
+ CALL prt_ctl_info( charout, cdcomp = 'top' )
+ CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm)
ENDIF
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
! Bacterial uptake of iron. No iron is available in DOC. So
@@ -217,6 +218,6 @@
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
WRITE(charout, FMT="('rem2')")
- CALL prt_ctl_trc_info(charout)
- CALL prt_ctl_trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)
+ CALL prt_ctl_info( charout, cdcomp = 'top' )
+ CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm)
ENDIF
@@ -225,5 +226,5 @@
! ---------------------------------------------------------------
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
zdep = MAX( hmld(ji,jj), heup_01(ji,jj) )
zsatur = MAX( rtrn, ( sio3eq(ji,jj,jk) - tr(ji,jj,jk,jpsil,Kbb) ) / ( sio3eq(ji,jj,jk) + rtrn ) )
@@ -248,6 +249,6 @@
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
WRITE(charout, FMT="('rem3')")
- CALL prt_ctl_trc_info(charout)
- CALL prt_ctl_trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)
+ CALL prt_ctl_info( charout, cdcomp = 'top' )
+ CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm)
ENDIF
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zsed.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zsed.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zsed.F90 (revision 13540)
@@ -18,5 +18,5 @@
USE sed ! Sediment module
USE iom ! I/O manager
- USE prtctl_trc ! print control for debugging
+ USE prtctl ! print control for debugging
IMPLICIT NONE
@@ -39,4 +39,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/TOP 4.0 , NEMO Consortium (2018)
@@ -93,5 +94,5 @@
! OA: Warning, the following part is necessary to avoid CFL problems above the sediments
! --------------------------------------------------------------------
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
ikt = mbkt(ji,jj)
zdep = e3t(ji,jj,ikt,Kmm) / xstep
@@ -103,5 +104,5 @@
! Computation of the fraction of organic matter that is permanently buried from Dunne's model
! -------------------------------------------------------
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
IF( tmask(ji,jj,1) == 1 ) THEN
ikt = mbkt(ji,jj)
@@ -129,5 +130,5 @@
IF( .NOT.lk_sed ) zrivsil = 1._wp - sedsilfrac
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
ikt = mbkt(ji,jj)
zdep = xstep / e3t(ji,jj,ikt,Kmm)
@@ -141,5 +142,5 @@
!
IF( .NOT.lk_sed ) THEN
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
ikt = mbkt(ji,jj)
zdep = xstep / e3t(ji,jj,ikt,Kmm)
@@ -159,5 +160,5 @@
ENDIF
!
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
ikt = mbkt(ji,jj)
zdep = xstep / e3t(ji,jj,ikt,Kmm)
@@ -171,5 +172,5 @@
!
IF( ln_p5z ) THEN
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
ikt = mbkt(ji,jj)
zdep = xstep / e3t(ji,jj,ikt,Kmm)
@@ -186,5 +187,5 @@
! 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_11_11
+ DO_2D( 1, 1, 1, 1 )
ikt = mbkt(ji,jj)
zdep = xstep / e3t(ji,jj,ikt,Kmm)
@@ -223,5 +224,5 @@
ENDDO
IF( ln_p4z ) THEN
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
! ! Potential nitrogen fixation dependant on temperature and iron
ztemp = ts(ji,jj,jk,jp_tem,Kmm)
@@ -239,5 +240,5 @@
END_3D
ELSE ! p5z
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
! ! Potential nitrogen fixation dependant on temperature and iron
ztemp = ts(ji,jj,jk,jp_tem,Kmm)
@@ -260,5 +261,5 @@
! ----------------------------------------
IF( ln_p4z ) THEN
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
zfact = nitrpot(ji,jj,jk) * nitrfix
tr(ji,jj,jk,jpnh4,Krhs) = tr(ji,jj,jk,jpnh4,Krhs) + zfact / 3.0
@@ -277,5 +278,5 @@
END_3D
ELSE ! p5z
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
zfact = nitrpot(ji,jj,jk) * nitrfix
tr(ji,jj,jk,jpnh4,Krhs) = tr(ji,jj,jk,jpnh4,Krhs) + zfact / 3.0
@@ -314,6 +315,6 @@
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (USEd for debugging)
WRITE(charout, fmt="('sed ')")
- CALL prt_ctl_trc_info(charout)
- CALL prt_ctl_trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)
+ CALL prt_ctl_info( charout, cdcomp = 'top' )
+ CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm)
ENDIF
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zsink.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zsink.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zsink.F90 (revision 13540)
@@ -17,5 +17,5 @@
USE sms_pisces ! PISCES Source Minus Sink variables
USE trcsink ! General routine to compute sedimentation
- USE prtctl_trc ! print control for debugging
+ USE prtctl ! print control for debugging
USE iom ! I/O manager
USE lib_mpp
@@ -40,4 +40,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/TOP 4.0 , NEMO Consortium (2018)
@@ -80,5 +81,5 @@
! by data and from the coagulation theory
! -----------------------------------------------------------
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
zmax = MAX( heup_01(ji,jj), hmld(ji,jj) )
zfact = MAX( 0., gdepw(ji,jj,jk+1,Kmm) - zmax ) / wsbio2scale
@@ -143,6 +144,6 @@
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
WRITE(charout, FMT="('sink')")
- CALL prt_ctl_trc_info(charout)
- CALL prt_ctl_trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)
+ CALL prt_ctl_info( charout, cdcomp = 'top' )
+ CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm)
ENDIF
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zsms.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zsms.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p4zsms.F90 (revision 13540)
@@ -25,5 +25,5 @@
USE trdtrc ! TOP trends variables
USE sedmodel ! Sediment model
- USE prtctl_trc ! print control for debugging
+ USE prtctl ! print control for debugging
IMPLICIT NONE
@@ -41,4 +41,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/TOP 4.0 , NEMO Consortium (2018)
@@ -68,5 +69,5 @@
REAL(wp), ALLOCATABLE, DIMENSION(:,: ) :: zw2d
REAL(wp), ALLOCATABLE, DIMENSION(:,:,: ) :: zw3d
- REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: ztrdt ! 4D workspace
+ REAL(wp), DIMENSION(jpi,jpj,jpk,jp_pisces) :: ztrbbio
!!---------------------------------------------------------------------
@@ -92,11 +93,4 @@
rfact = rDt_trc
!
- ! trends computation initialisation
- IF( l_trdtrc ) THEN
- ALLOCATE( ztrdt(jpi,jpj,jpk,jp_pisces) ) !* store now fields before applying the Asselin filter
- ztrdt(:,:,:,:) = tr(:,:,:,:,Kmm)
- ENDIF
- !
-
IF( ( ln_top_euler .AND. kt == nittrc000 ) .OR. ( .NOT.ln_top_euler .AND. kt <= nittrc000 + 1 ) ) THEN
rfactr = 1. / rfact
@@ -116,4 +110,9 @@
END DO
ENDIF
+
+ DO jn = jp_pcs0, jp_pcs1 ! Store the tracer concentrations before entering PISCES
+ ztrbbio(:,:,:,jn) = tr(:,:,:,jn,Kbb)
+ END DO
+
!
IF( ll_bc ) CALL p4z_bc( kt, Kbb, Kmm, Krhs ) ! external sources of nutrients
@@ -132,5 +131,5 @@
xnegtr(:,:,:) = 1.e0
DO jn = jp_pcs0, jp_pcs1
- DO_3D_11_11( 1, jpk )
+ DO_3D( 1, 1, 1, 1, 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 )
@@ -197,32 +196,26 @@
END DO
!
- IF( ln_top_euler ) THEN
- DO jn = jp_pcs0, jp_pcs1
- tr(:,:,:,jn,Kmm) = tr(:,:,:,jn,Kbb)
- END DO
- ENDIF
+ END DO
+ !
+#endif
+ !
+ IF( ln_sediment ) THEN
+ !
+ CALL sed_model( kt, Kbb, Kmm, Krhs ) ! Main program of Sediment model
+ !
+ ENDIF
+ !
+ DO jn = jp_pcs0, jp_pcs1
+ tr(:,:,:,jn,Krhs) = ( tr(:,:,:,jn,Kbb) - ztrbbio(:,:,:,jn) ) * rfactr
+ tr(:,:,:,jn,Kbb ) = ztrbbio(:,:,:,jn)
+ ztrbbio(:,:,:,jn) = 0._wp
END DO
!
IF( l_trdtrc ) THEN
DO jn = jp_pcs0, jp_pcs1
- ztrdt(:,:,:,jn) = ( tr(:,:,:,jn,Kbb) - ztrdt(:,:,:,jn) ) * rfact2r
CALL trd_trc( tr(:,:,:,jn,Krhs), jn, jptra_sms, kt, Kmm ) ! save trends
END DO
- DEALLOCATE( ztrdt )
END IF
-#endif
- !
- IF( ln_sediment ) THEN
- !
- CALL sed_model( kt, Kbb, Kmm, Krhs ) ! Main program of Sediment model
- !
- IF( ln_top_euler ) THEN
- DO jn = jp_pcs0, jp_pcs1
- tr(:,:,:,jn,Kmm) = tr(:,:,:,jn,Kbb)
- END DO
- ENDIF
- !
- ENDIF
- !
+ !
IF( lrst_trc ) CALL p4z_rst( kt, Kbb, Kmm, 'WRITE' ) !* Write PISCES informations in restart file
!
@@ -340,12 +333,12 @@
!
IF( iom_varid( numrtr, 'PH', ldstop = .FALSE. ) > 0 ) THEN
- CALL iom_get( numrtr, jpdom_autoglo, 'PH' , hi(:,:,:) )
+ CALL iom_get( numrtr, jpdom_auto, 'PH' , hi(:,:,:) )
ELSE
CALL p4z_che( Kbb, Kmm ) ! initialize the chemical constants
CALL ahini_for_at( hi, Kbb )
ENDIF
- CALL iom_get( numrtr, jpdom_autoglo, 'Silicalim', xksi(:,:) )
+ CALL iom_get( numrtr, jpdom_auto, 'Silicalim', xksi(:,:) )
IF( iom_varid( numrtr, 'Silicamax', ldstop = .FALSE. ) > 0 ) THEN
- CALL iom_get( numrtr, jpdom_autoglo, 'Silicamax' , xksimax(:,:) )
+ CALL iom_get( numrtr, jpdom_auto, 'Silicamax' , xksimax(:,:) )
ELSE
xksimax(:,:) = xksi(:,:)
@@ -360,7 +353,7 @@
IF( ln_p5z ) THEN
IF( iom_varid( numrtr, 'sized', ldstop = .FALSE. ) > 0 ) THEN
- CALL iom_get( numrtr, jpdom_autoglo, 'sizep' , sizep(:,:,:) )
- CALL iom_get( numrtr, jpdom_autoglo, 'sizen' , sizen(:,:,:) )
- CALL iom_get( numrtr, jpdom_autoglo, 'sized' , sized(:,:,:) )
+ CALL iom_get( numrtr, jpdom_auto, 'sizep' , sizep(:,:,:) )
+ CALL iom_get( numrtr, jpdom_auto, 'sizen' , sizen(:,:,:) )
+ CALL iom_get( numrtr, jpdom_auto, 'sized' , sized(:,:,:) )
ELSE
sizep(:,:,:) = 1.
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p5zlim.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p5zlim.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p5zlim.F90 (revision 13540)
@@ -131,5 +131,5 @@
zratchl = 6.0
!
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
!
! Tuning of the iron concentration to a minimum level that is set to the detection limit
@@ -306,5 +306,5 @@
& / (xqndmax(ji,jj,jk) - 2. * xqndmin(ji,jj,jk) ) ) &
& * xqndmax(ji,jj,jk) / (zration + rtrn)
- zlim3 = tr(ji,jj,jk,jpsil,Kbb) / ( tr(ji,jj,jk,jpsil,Kbb) + xksi(ji,jj) )
+ zlim3 = tr(ji,jj,jk,jpsil,Kbb) / ( tr(ji,jj,jk,jpsil,Kbb) + xksi(ji,jj) + rtrn )
zlim4 = MAX( 0., ( zratiof - zqfemd ) / qfdopt )
xlimdfe(ji,jj,jk) = MIN( 1., zlim4 )
@@ -318,5 +318,5 @@
! phytoplankton (see Daines et al., 2013).
! --------------------------------------------------------------------------------------------------
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
! Size estimation of nanophytoplankton
! ------------------------------------
@@ -367,5 +367,5 @@
! Compute the fraction of nanophytoplankton that is made of calcifiers
! --------------------------------------------------------------------
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 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) &
@@ -385,5 +385,5 @@
END_3D
!
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 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) ) &
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p5zmeso.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p5zmeso.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p5zmeso.F90 (revision 13540)
@@ -15,5 +15,5 @@
USE trc ! passive tracers common variables
USE sms_pisces ! PISCES Source Minus Sink variables
- USE prtctl_trc ! print control for debugging
+ USE prtctl ! print control for debugging
USE iom ! I/O manager
@@ -98,5 +98,5 @@
IF ( bmetexc2 ) zmetexcess = 1.0
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
zcompam = MAX( ( tr(ji,jj,jk,jpmes,Kbb) - 1.e-9 ), 0.e0 )
zfact = xstep * tgfunc2(ji,jj,jk) * zcompam
@@ -359,6 +359,6 @@
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
WRITE(charout, FMT="('meso')")
- CALL prt_ctl_trc_info(charout)
- CALL prt_ctl_trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)
+ CALL prt_ctl_info( charout, cdcomp = 'top' )
+ CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm)
ENDIF
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p5zmicro.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p5zmicro.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p5zmicro.F90 (revision 13540)
@@ -18,5 +18,5 @@
USE p5zlim ! Phytoplankton limitation terms
USE iom ! I/O manager
- USE prtctl_trc ! print control for debugging
+ USE prtctl ! print control for debugging
IMPLICIT NONE
@@ -96,5 +96,5 @@
IF ( bmetexc ) zmetexcess = 1.0
!
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
zcompaz = MAX( ( tr(ji,jj,jk,jpzoo,Kbb) - 1.e-9 ), 0.e0 )
zfact = xstep * tgfunc2(ji,jj,jk) * zcompaz
@@ -306,6 +306,6 @@
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
WRITE(charout, FMT="('micro')")
- CALL prt_ctl_trc_info(charout)
- CALL prt_ctl_trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)
+ CALL prt_ctl_info( charout, cdcomp = 'top' )
+ CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm)
ENDIF
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p5zmort.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p5zmort.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p5zmort.F90 (revision 13540)
@@ -16,5 +16,5 @@
USE p4zlim
USE p5zlim ! Phytoplankton limitation terms
- USE prtctl_trc ! print control for debugging
+ USE prtctl ! print control for debugging
IMPLICIT NONE
@@ -82,5 +82,5 @@
!
prodcal(:,:,:) = 0. !: calcite production variable set to zero
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
zcompaph = MAX( ( tr(ji,jj,jk,jpphy,Kbb) - 1e-9 ), 0.e0 )
! Squared mortality of Phyto similar to a sedimentation term during
@@ -121,6 +121,6 @@
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
WRITE(charout, FMT="('nano')")
- CALL prt_ctl_trc_info(charout)
- CALL prt_ctl_trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)
+ CALL prt_ctl_info( charout, cdcomp = 'top' )
+ CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm)
ENDIF
!
@@ -148,5 +148,5 @@
IF( ln_timing ) CALL timing_start('p5z_pico')
!
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
zcompaph = MAX( ( tr(ji,jj,jk,jppic,Kbb) - 1e-9 ), 0.e0 )
! Squared mortality of Phyto similar to a sedimentation term during
@@ -179,6 +179,6 @@
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
WRITE(charout, FMT="('pico')")
- CALL prt_ctl_trc_info(charout)
- CALL prt_ctl_trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)
+ CALL prt_ctl_info( charout, cdcomp = 'top' )
+ CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm)
ENDIF
!
@@ -207,5 +207,5 @@
!
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
zcompadi = MAX( ( tr(ji,jj,jk,jpdia,Kbb) - 1E-9), 0. )
@@ -254,6 +254,6 @@
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
WRITE(charout, FMT="('diat')")
- CALL prt_ctl_trc_info(charout)
- CALL prt_ctl_trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)
+ CALL prt_ctl_info( charout, cdcomp = 'top' )
+ CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm)
ENDIF
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p5zprod.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p5zprod.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/P4Z/p5zprod.F90 (revision 13540)
@@ -18,5 +18,5 @@
USE p4zlim
USE p5zlim ! Co-limitations of differents nutrients
- USE prtctl_trc ! print control for debugging
+ USE prtctl ! print control for debugging
USE iom ! I/O manager
@@ -52,4 +52,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/TOP 4.0 , NEMO Consortium (2018)
@@ -124,5 +125,5 @@
! day length in hours
zstrn(:,:) = 0.
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
zargu = TAN( zcodel ) * TAN( gphit(ji,jj) * rad )
zargu = MAX( -1., MIN( 1., zargu ) )
@@ -131,5 +132,5 @@
! Impact of the day duration on phytoplankton growth
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN
zval = MAX( 1., zstrn(ji,jj) )
@@ -151,5 +152,5 @@
WHERE( zstrn(:,:) < 1.e0 ) zstrn(:,:) = 24.
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN
! Computation of the P-I slope for nanos and diatoms
@@ -185,5 +186,5 @@
END_3D
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN
@@ -207,5 +208,5 @@
! Sea-ice effect on production
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 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) )
@@ -215,5 +216,5 @@
! Computation of the various production terms of nanophytoplankton
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN
! production terms for nanophyto.
@@ -248,5 +249,5 @@
! Computation of the various production terms of picophytoplankton
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN
! production terms for picophyto.
@@ -281,5 +282,5 @@
! Computation of the various production terms of diatoms
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN
! production terms for diatomees
@@ -315,5 +316,5 @@
END_3D
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN
! production terms for nanophyto. ( chlorophyll )
@@ -346,5 +347,5 @@
! Update the arrays TRA which contain the biological sources and sinks
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
zprontot = zpronewn(ji,jj,jk) + zproregn(ji,jj,jk)
zproptot = zpronewp(ji,jj,jk) + zproregp(ji,jj,jk)
@@ -409,5 +410,5 @@
IF( ln_ligand ) THEN
zpligprod1(:,:,:) = 0._wp ; zpligprod2(:,:,:) = 0._wp
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
zdocprod = excretd * zprorcad(ji,jj,jk) + excretn * zprorcan(ji,jj,jk) + excretp * zprorcap(ji,jj,jk)
zfeup = texcretn * zprofen(ji,jj,jk) + texcretd * zprofed(ji,jj,jk) + texcretp * zprofep(ji,jj,jk)
@@ -460,6 +461,6 @@
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
WRITE(charout, FMT="('prod')")
- CALL prt_ctl_trc_info(charout)
- CALL prt_ctl_trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)
+ CALL prt_ctl_info( charout, cdcomp = 'top' )
+ CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm)
ENDIF
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/SED/oce_sed.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/SED/oce_sed.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/SED/oce_sed.F90 (revision 13540)
@@ -13,5 +13,8 @@
USE dom_oce , ONLY : glamt => glamt !: longitude of t-point (degre)
USE dom_oce , ONLY : gphit => gphit !: latitude of t-point (degre)
+!!st
+#if ! defined key_qco
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)
@@ -53,4 +56,2 @@
END MODULE oce_sed
-
-
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/SED/sedchem.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/SED/sedchem.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/SED/sedchem.F90 (revision 13540)
@@ -138,5 +138,5 @@
CALL sed_chem_cst
ELSE
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
ikt = mbkt(ji,jj)
IF ( tmask(ji,jj,ikt) == 1 ) THEN
@@ -577,5 +577,5 @@
saltprac(:) = salt(:) * 35.0 / 35.16504
ELSE
- saltprac(:) = temp(:)
+ saltprac(:) = salt(:)
ENDIF
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/SED/seddta.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/SED/seddta.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/SED/seddta.F90 (revision 13540)
@@ -24,4 +24,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!! $Id$
CONTAINS
@@ -95,5 +96,5 @@
! -----------------------------------------------------------
IF (ln_sediment_offline) THEN
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
ikt = mbkt(ji,jj)
zwsbio4(ji,jj) = wsbio2 / rday
@@ -101,5 +102,5 @@
END_2D
ELSE
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
ikt = mbkt(ji,jj)
zdep = e3t(ji,jj,ikt,Kmm) / rDt_trc
@@ -110,5 +111,5 @@
trc_data(:,:,:) = 0.
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
ikt = mbkt(ji,jj)
IF ( tmask(ji,jj,ikt) == 1 ) THEN
@@ -164,5 +165,5 @@
CALL pack_arr ( jpoce, rainrm_dta(1:jpoce,jscal), trc_data(1:jpi,1:jpj,14), iarroce(1:jpoce) )
rainrm_dta(1:jpoce,jscal) = rainrm_dta(1:jpoce,jscal) * 1e-4
- ! vector temperature [°C] and salinity
+ ! vector temperature [�C] and salinity
CALL pack_arr ( jpoce, temp(1:jpoce), trc_data(1:jpi,1:jpj,15), iarroce(1:jpoce) )
CALL pack_arr ( jpoce, salt(1:jpoce), trc_data(1:jpi,1:jpj,16), iarroce(1:jpoce) )
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/SED/sedini.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/SED/sedini.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/SED/sedini.F90 (revision 13540)
@@ -135,5 +135,5 @@
! Determination of sediments number of points and allocate global variables
epkbot(:,:) = 0.
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
ikt = mbkt(ji,jj)
IF( tmask(ji,jj,ikt) == 1 ) epkbot(ji,jj) = e3t_1d(ikt)
@@ -247,5 +247,5 @@
! Computation of 1D array of sediments points
indoce = 0
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
IF ( epkbot(ji,jj) > 0. ) THEN
indoce = indoce + 1
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/SED/sedinorg.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/SED/sedinorg.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/SED/sedinorg.F90 (revision 13540)
@@ -89,4 +89,5 @@
zsolcpcl = zsolcpcl + solcp(ji,jk,jsclay) * dz(jk)
END DO
+ zsolcpsi = MAX( zsolcpsi, rtrn )
zsieq(ji) = sieqs(ji) * MAX(0.25, 1.0 - (0.045 * zsolcpcl / zsolcpsi )**0.58 )
zsieq(ji) = MAX( rtrn, sieqs(ji) )
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/SED/sedrst.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/SED/sedrst.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/SED/sedrst.F90 (revision 13540)
@@ -80,5 +80,5 @@
IF(lwp) WRITE(numsed,*) &
' open sed restart.output NetCDF file: ',TRIM(clpath)//clname
- CALL iom_open( TRIM(clpath)//TRIM(clname), numrsw, ldwrt = .TRUE., kdlev = jpksed )
+ CALL iom_open( TRIM(clpath)//TRIM(clname), numrsw, ldwrt = .TRUE., kdlev = jpksed, cdcomp = 'SED' )
lrst_sed = .TRUE.
ENDIF
@@ -123,5 +123,5 @@
cltra = TRIM(sedtrcd(jn))
IF( iom_varid( numrsr, TRIM(cltra) , ldstop = .FALSE. ) > 0 ) THEN
- CALL iom_get( numrsr, jpdom_autoglo, TRIM(cltra), zdta(:,:,:,jn) )
+ CALL iom_get( numrsr, jpdom_auto, TRIM(cltra), zdta(:,:,:,jn) )
ELSE
zdta(:,:,:,jn) = 0.0
@@ -142,5 +142,5 @@
cltra = TRIM(seddia3d(jn))
IF( iom_varid( numrsr, TRIM(cltra) , ldstop = .FALSE. ) > 0 ) THEN
- CALL iom_get( numrsr, jpdom_autoglo, TRIM(cltra), zdta1(:,:,:,jn) )
+ CALL iom_get( numrsr, jpdom_auto, TRIM(cltra), zdta1(:,:,:,jn) )
ELSE
zdta1(:,:,:,jn) = 0.0
@@ -169,5 +169,5 @@
cltra = "dbioturb"
IF( iom_varid( numrsr, TRIM(cltra) , ldstop = .FALSE. ) > 0 ) THEN
- CALL iom_get( numrsr, jpdom_autoglo, TRIM(cltra), zdta2(:,:,:) )
+ CALL iom_get( numrsr, jpdom_auto, TRIM(cltra), zdta2(:,:,:) )
ELSE
zdta2(:,:,:) = 0.0
@@ -179,5 +179,5 @@
cltra = "irrig"
IF( iom_varid( numrsr, TRIM(cltra) , ldstop = .FALSE. ) > 0 ) THEN
- CALL iom_get( numrsr, jpdom_autoglo, TRIM(cltra), zdta2(:,:,:) )
+ CALL iom_get( numrsr, jpdom_auto, TRIM(cltra), zdta2(:,:,:) )
ELSE
zdta2(:,:,:) = 0.0
@@ -189,5 +189,5 @@
cltra = "sedligand"
IF( iom_varid( numrsr, TRIM(cltra) , ldstop = .FALSE. ) > 0 ) THEN
- CALL iom_get( numrsr, jpdom_autoglo, TRIM(cltra), zdta2(:,:,:) )
+ CALL iom_get( numrsr, jpdom_auto, TRIM(cltra), zdta2(:,:,:) )
ELSE
zdta2(:,:,:) = 0.0
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/SED/sedsfc.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/SED/sedsfc.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/SED/sedsfc.F90 (revision 13540)
@@ -48,5 +48,5 @@
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
ikt = mbkt(ji,jj)
IF ( tmask(ji,jj,ikt) == 1 ) THEN
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/SED/trcdmp_sed.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/SED/trcdmp_sed.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/SED/trcdmp_sed.F90 (revision 13540)
@@ -21,5 +21,5 @@
USE trc ! ocean passive tracers variables
USE trcdta
- USE prtctl_trc ! Print control for debbuging
+ USE prtctl ! Print control for debbuging
USE iom
@@ -93,5 +93,5 @@
CALL trc_dta( kt, Kmm, sf_trcdta(jl), rf_trfac(jl), ztrcdta ) ! read tracer data at nit000
!
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
ikt = mbkt(ji,jj)
tr(ji,jj,ikt,jn,Kbb) = ztrcdta(ji,jj,ikt) + ( tr(ji,jj,ikt,jn,Kbb) - ztrcdta(ji,jj,ikt) ) &
@@ -107,6 +107,6 @@
IF( sn_cfctl%l_prttrc ) THEN
WRITE(charout, FMT="('dmp ')")
- CALL prt_ctl_trc_info(charout)
- CALL prt_ctl_trc( tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm, clinfo2='trd' )
+ CALL prt_ctl_info( charout, cdcomp = 'top' )
+ CALL prt_ctl( tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm, clinfo3='trd' )
ENDIF
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/trcwri_pisces.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/trcwri_pisces.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/PISCES/trcwri_pisces.F90 (revision 13540)
@@ -21,4 +21,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/TOP 4.0 , NEMO Consortium (2018)
@@ -68,5 +69,5 @@
zo2min (:,:) = tr(:,:,1,jpoxy,Kmm) * tmask(:,:,1)
zdepo2min(:,:) = gdepw(:,:,1,Kmm) * tmask(:,:,1)
- DO_3D_11_11( 2, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 2, jpkm1 )
IF( tmask(ji,jj,jk) == 1 ) then
IF( tr(ji,jj,jk,jpoxy,Kmm) < zo2min(ji,jj) ) then
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/TRP/trcadv.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/TRP/trcadv.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/TRP/trcadv.F90 (revision 13540)
@@ -29,5 +29,5 @@
USE ldfslp ! Lateral diffusion: slopes of neutral surfaces
!
- USE prtctl_trc ! control print
+ USE prtctl ! control print
USE timing ! Timing
@@ -59,4 +59,5 @@
INTEGER, PARAMETER :: np_QCK = 5 ! QUICK scheme
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/TOP 4.0 , NEMO Consortium (2018)
@@ -137,6 +138,6 @@
IF( sn_cfctl%l_prttrc ) THEN !== print mean trends (used for debugging)
WRITE(charout, FMT="('adv ')")
- CALL prt_ctl_trc_info(charout)
- CALL prt_ctl_trc( tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm, clinfo2='trd' )
+ CALL prt_ctl_info( charout, cdcomp = 'top' )
+ CALL prt_ctl( tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm, clinfo3='trd' )
END IF
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/TRP/trcatf.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/TRP/trcatf.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/TRP/trcatf.F90 (revision 13540)
@@ -31,5 +31,9 @@
USE trd_oce
USE trdtra
+# if defined key_qco
+ USE traatfqco
+# else
USE traatf
+# endif
USE bdy_oce , ONLY: ln_bdy
USE trcbdy ! BDY open boundaries
@@ -39,5 +43,5 @@
!
USE lbclnk ! ocean lateral boundary conditions (or mpp link)
- USE prtctl_trc ! Print control for debbuging
+ USE prtctl ! Print control for debbuging
IMPLICIT NONE
@@ -50,4 +54,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/TOP 4.0 , NEMO Consortium (2018)
@@ -112,5 +117,5 @@
! 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 ts(Kmm) terms
+ ! G Nurser 23 Mar 2017. Recalculate trend as Delta(e3ta*Ta)/e3tn; e3tn cancel from ts(Kmm) terms
IF( ln_linssh ) THEN ! linear sea surface height only
DO jn = 1, jptra
@@ -151,6 +156,11 @@
ELSE
IF( .NOT. l_offline ) THEN ! Leap-Frog + Asselin filter time stepping
+# if defined key_qco
+ 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
@@ -174,6 +184,6 @@
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
WRITE(charout, FMT="('nxt')")
- CALL prt_ctl_trc_info(charout)
- CALL prt_ctl_trc(tab4d=ptr(:,:,:,:,Kmm), mask=tmask, clinfo=ctrcnm)
+ CALL prt_ctl_info( charout, cdcomp = 'top' )
+ CALL prt_ctl(tab4d_1=ptr(:,:,:,:,Kmm), mask1=tmask, clinfo=ctrcnm)
ENDIF
!
@@ -182,5 +192,5 @@
END SUBROUTINE trc_atf
-
+# if ! defined key_qco
SUBROUTINE trc_atf_off( kt, Kbb, Kmm, Kaa, ptr )
!!----------------------------------------------------------------------
@@ -198,8 +208,8 @@
!! This can be summurized for tempearture as:
!! ztm = ( e3t_n*tn + rbcp*[ e3t_b*tb - 2 e3t_n*tn + e3t_a*ta ] ) ln_dynhpg_imp = T
- !! /( e3t(:,:,:,Kmm) + rbcp*[ e3t(:,:,:,Kbb) - 2 e3t(:,:,:,Kmm) + e3t(:,:,:,Kaa) ] )
+ !! /( e3t(:,:,jk,Kmm) + rbcp*[ e3t(:,:,jk,Kbb) - 2 e3t(:,:,jk,Kmm) + e3t(:,:,jk,Kaa) ] )
!! ztm = 0 otherwise
!! tb = ( e3t_n*tn + rn_atfp*[ e3t_b*tb - 2 e3t_n*tn + e3t_a*ta ] )
- !! /( e3t(:,:,:,Kmm) + rn_atfp*[ e3t(:,:,:,Kbb) - 2 e3t(:,:,:,Kmm) + e3t(:,:,:,Kaa) ] )
+ !! /( e3t(:,:,jk,Kmm) + rn_atfp*[ e3t(:,:,jk,Kbb) - 2 e3t(:,:,jk,Kmm) + e3t(:,:,jk,Kaa) ] )
!! tn = ta
!! ta = zt (NB: reset to 0 after eos_bn2 call)
@@ -229,5 +239,5 @@
!
DO jn = 1, jptra
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
ze3t_b = e3t(ji,jj,jk,Kbb)
ze3t_n = e3t(ji,jj,jk,Kmm)
@@ -257,4 +267,78 @@
!
END SUBROUTINE trc_atf_off
+# else
+ SUBROUTINE trc_atf_off( kt, Kbb, Kmm, Kaa, ptr )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE tra_atf_off ***
+ !!
+ !! !!!!!!!!!!!!!!!!! REWRITE HEADER COMMENTS !!!!!!!!!!!!!!
+ !!
+ !! ** Purpose : Time varying volume: apply the Asselin time filter
+ !!
+ !! ** Method : - Apply a thickness weighted Asselin time filter on now fields.
+ !! - save in (ta,sa) a thickness weighted average over the three
+ !! time levels which will be used to compute rdn and thus the semi-
+ !! implicit hydrostatic pressure gradient (ln_dynhpg_imp = T)
+ !! - swap tracer fields to prepare the next time_step.
+ !! This can be summurized for tempearture as:
+ !! ztm = ( e3t_n*tn + rbcp*[ e3t_b*tb - 2 e3t_n*tn + e3t_a*ta ] ) ln_dynhpg_imp = T
+ !! /( e3t(:,:,jk,Kmm) + rbcp*[ e3t(:,:,jk,Kbb) - 2 e3t(:,:,jk,Kmm) + e3t(:,:,jk,Kaa) ] )
+ !! ztm = 0 otherwise
+ !! tb = ( e3t_n*tn + rn_atfp*[ e3t_b*tb - 2 e3t_n*tn + e3t_a*ta ] )
+ !! /( e3t(:,:,jk,Kmm) + rn_atfp*[ e3t(:,:,jk,Kbb) - 2 e3t(:,:,jk,Kmm) + e3t(:,:,jk,Kaa) ] )
+ !! tn = ta
+ !! ta = zt (NB: reset to 0 after eos_bn2 call)
+ !!
+ !! ** Action : - (tb,sb) and (tn,sn) ready for the next time step
+ !! - (ta,sa) time averaged (t,s) (ln_dynhpg_imp = T)
+ !!----------------------------------------------------------------------
+ INTEGER , INTENT(in ) :: kt ! ocean time-step index
+ INTEGER , INTENT(in ) :: Kbb, Kmm, Kaa ! time level indices
+ REAL(wp), DIMENSION(jpi,jpj,jpk,jptra,jpt), INTENT(inout) :: ptr ! passive tracers
+ !!
+ INTEGER :: ji, jj, jk, jn ! dummy loop indices
+ REAL(wp) :: ztc_a , ztc_n , ztc_b , ztc_f , ztc_d ! local scalar
+ REAL(wp) :: ze3t_b, ze3t_n, ze3t_a, ze3t_f ! - -
+ !!----------------------------------------------------------------------
+ !
+ IF( kt == nittrc000 ) THEN
+ IF(lwp) WRITE(numout,*)
+ IF(lwp) WRITE(numout,*) 'trc_atf_off : Asselin time filtering'
+ IF(lwp) WRITE(numout,*) '~~~~~~~~~~~'
+ IF( .NOT. ln_linssh ) THEN
+ rfact1 = rn_atfp * rn_Dt
+ rfact2 = rfact1 / rho0
+ ENDIF
+ !
+ ENDIF
+ !
+ DO jn = 1, jptra
+ DO_3D( 1, 1, 1, 1, 1, jpkm1 )
+ ze3t_b = 1._wp + r3t(ji,jj,Kbb) * tmask(ji,jj,jk)
+ ze3t_n = 1._wp + r3t(ji,jj,Kmm) * tmask(ji,jj,jk)
+ ze3t_a = 1._wp + r3t(ji,jj,Kaa) * tmask(ji,jj,jk)
+ ! ! tracer content at Before, now and after
+ ztc_b = ptr(ji,jj,jk,jn,Kbb) * ze3t_b
+ ztc_n = ptr(ji,jj,jk,jn,Kmm) * ze3t_n
+ ztc_a = ptr(ji,jj,jk,jn,Kaa) * ze3t_a
+ !
+ ztc_d = ztc_a - 2. * ztc_n + ztc_b
+ !
+ ze3t_f = 1._wp + r3t_f(ji,jj)*tmask(ji,jj,jk)
+ ztc_f = ztc_n + rn_atfp * ztc_d
+ !
+ IF( .NOT. ln_linssh .AND. jk == mikt(ji,jj) ) THEN ! first level
+ ztc_f = ztc_f - rfact1 * ( sbc_trc(ji,jj,jn) - sbc_trc_b(ji,jj,jn) )
+ ENDIF
+
+ ze3t_f = 1.e0 / ze3t_f
+ ptr(ji,jj,jk,jn,Kmm) = ztc_f * ze3t_f ! time filtered "now" field
+ !
+ END_3D
+ !
+ END DO
+ !
+ END SUBROUTINE trc_atf_off
+# endif
#else
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/TRP/trcbbl.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/TRP/trcbbl.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/TRP/trcbbl.F90 (revision 13540)
@@ -25,5 +25,5 @@
USE trdtra ! tracer trends
USE trabbl ! bottom boundary layer
- USE prtctl_trc ! Print control for debbuging
+ USE prtctl ! Print control for debbuging
PUBLIC trc_bbl ! routine called by trctrp.F90
@@ -70,6 +70,6 @@
CALL tra_bbl_dif( ptr(:,:,:,:,Kbb), ptr(:,:,:,:,Krhs), jptra, Kmm )
IF( sn_cfctl%l_prttrc ) THEN
- WRITE(charout, FMT="(' bbl_dif')") ; CALL prt_ctl_trc_info(charout)
- CALL prt_ctl_trc( tab4d=ptr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm, clinfo2='trd' )
+ WRITE(charout, FMT="(' bbl_dif')") ; CALL prt_ctl_info( charout, cdcomp = 'top' )
+ CALL prt_ctl( tab4d_1=ptr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm, clinfo3='trd' )
ENDIF
!
@@ -81,6 +81,6 @@
CALL tra_bbl_adv( ptr(:,:,:,:,Kbb), ptr(:,:,:,:,Krhs), jptra, Kmm )
IF( sn_cfctl%l_prttrc ) THEN
- WRITE(charout, FMT="(' bbl_adv')") ; CALL prt_ctl_trc_info(charout)
- CALL prt_ctl_trc( tab4d=ptr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm, clinfo2='trd' )
+ WRITE(charout, FMT="(' bbl_adv')") ; CALL prt_ctl_info( charout, cdcomp = 'top' )
+ CALL prt_ctl( tab4d_1=ptr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm, clinfo3='trd' )
ENDIF
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/TRP/trcdmp.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/TRP/trcdmp.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/TRP/trcdmp.F90 (revision 13540)
@@ -24,5 +24,5 @@
!
USE iom
- USE prtctl_trc ! Print control for debbuging
+ USE prtctl ! Print control for debbuging
IMPLICIT NONE
@@ -45,4 +45,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/TOP 4.0 , NEMO Consortium (2018)
@@ -112,10 +113,10 @@
!
CASE( 0 ) !== newtonian damping throughout the water column ==!
- DO_3D_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
ptr(ji,jj,jk,jn,Krhs) = ptr(ji,jj,jk,jn,Krhs) + restotr(ji,jj,jk) * ( ztrcdta(ji,jj,jk) - ptr(ji,jj,jk,jn,Kbb) )
END_3D
!
CASE ( 1 ) !== no damping in the turbocline (avt > 5 cm2/s) ==!
- DO_3D_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
IF( avt(ji,jj,jk) <= avt_c ) THEN
ptr(ji,jj,jk,jn,Krhs) = ptr(ji,jj,jk,jn,Krhs) + restotr(ji,jj,jk) * ( ztrcdta(ji,jj,jk) - ptr(ji,jj,jk,jn,Kbb) )
@@ -124,5 +125,5 @@
!
CASE ( 2 ) !== no damping in the mixed layer ==!
- DO_3D_00_00( 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
IF( gdept(ji,jj,jk,Kmm) >= hmlp (ji,jj) ) THEN
ptr(ji,jj,jk,jn,Krhs) = ptr(ji,jj,jk,jn,Krhs) + restotr(ji,jj,jk) * ( ztrcdta(ji,jj,jk) - ptr(ji,jj,jk,jn,Kbb) )
@@ -148,6 +149,6 @@
IF( sn_cfctl%l_prttrc ) THEN
WRITE(charout, FMT="('dmp ')")
- CALL prt_ctl_trc_info(charout)
- CALL prt_ctl_trc( tab4d=ptr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm, clinfo2='trd' )
+ CALL prt_ctl_info( charout, cdcomp = 'top' )
+ CALL prt_ctl( tab4d_1=ptr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm, clinfo3='trd' )
ENDIF
!
@@ -204,5 +205,5 @@
!Read in mask from file
CALL iom_open ( cn_resto_tr, imask)
- CALL iom_get ( imask, jpdom_autoglo, 'resto', restotr)
+ CALL iom_get ( imask, jpdom_auto, 'resto', restotr)
CALL iom_close( imask )
!
@@ -245,32 +246,33 @@
! ! =======================
CASE ( 1 ) ! eORCA_R1 configuration
- ! ! =======================
- isrow = 332 - jpjglo
- !
- nctsi1(1) = 333 ; nctsj1(1) = 243 - isrow ! Caspian Sea
- nctsi2(1) = 342 ; nctsj2(1) = 274 - isrow
- !
- nctsi1(2) = 198 ; nctsj1(2) = 258 - isrow ! Lake Superior
- nctsi2(2) = 204 ; nctsj2(2) = 262 - isrow
- !
- nctsi1(3) = 201 ; nctsj1(3) = 250 - isrow ! Lake Michigan
- nctsi2(3) = 203 ; nctsj2(3) = 256 - isrow
- !
- nctsi1(4) = 204 ; nctsj1(4) = 252 - isrow ! Lake Huron
- nctsi2(4) = 209 ; nctsj2(4) = 256 - isrow
- !
- nctsi1(5) = 206 ; nctsj1(5) = 249 - isrow ! Lake Erie
- nctsi2(5) = 209 ; nctsj2(5) = 251 - isrow
- !
- nctsi1(6) = 210 ; nctsj1(6) = 252 - isrow ! Lake Ontario
- nctsi2(6) = 212 ; nctsj2(6) = 252 - isrow
- !
- nctsi1(7) = 321 ; nctsj1(7) = 180 - isrow ! Victoria Lake
- nctsi2(7) = 322 ; nctsj2(7) = 189 - isrow
- !
- nctsi1(8) = 297 ; nctsj1(8) = 270 - isrow ! Baltic Sea
- nctsi2(8) = 308 ; nctsj2(8) = 293 - isrow
- !
- ! ! =======================
+ ! ! =======================
+ !
+ isrow = 332 - (Nj0glo + 1) ! was 332 - jpjglo -> jpjglo_old_version = Nj0glo + 1
+ !
+ nctsi1(1) = 333 ; nctsj1(1) = 243 - isrow ! Caspian Sea
+ nctsi2(1) = 342 ; nctsj2(1) = 274 - isrow
+ !
+ nctsi1(2) = 198 ; nctsj1(2) = 258 - isrow ! Lake Superior
+ nctsi2(2) = 204 ; nctsj2(2) = 262 - isrow
+ !
+ nctsi1(3) = 201 ; nctsj1(3) = 250 - isrow ! Lake Michigan
+ nctsi2(3) = 203 ; nctsj2(3) = 256 - isrow
+ !
+ nctsi1(4) = 204 ; nctsj1(4) = 252 - isrow ! Lake Huron
+ nctsi2(4) = 209 ; nctsj2(4) = 256 - isrow
+ !
+ nctsi1(5) = 206 ; nctsj1(5) = 249 - isrow ! Lake Erie
+ nctsi2(5) = 209 ; nctsj2(5) = 251 - isrow
+ !
+ nctsi1(6) = 210 ; nctsj1(6) = 252 - isrow ! Lake Ontario
+ nctsi2(6) = 212 ; nctsj2(6) = 252 - isrow
+ !
+ nctsi1(7) = 321 ; nctsj1(7) = 180 - isrow ! Victoria Lake
+ nctsi2(7) = 322 ; nctsj2(7) = 189 - isrow
+ !
+ nctsi1(8) = 297 ; nctsj1(8) = 270 - isrow ! Baltic Sea
+ nctsi2(8) = 308 ; nctsj2(8) = 293 - isrow
+ !
+ ! ! =======================
CASE ( 2 ) ! ORCA_R2 configuration
! ! =======================
@@ -285,9 +287,10 @@
nctsi2(3) = 181 ; nctsj2(3) = 112
!
- nctsi1(4) = 2 ; nctsj1(4) = 107 ! Black Sea 2 : est part of the Black Sea
+ nctsi1(4) = 2 ; nctsj1(4) = 107 ! Black Sea 2 : est part of the Black Sea
nctsi2(4) = 6 ; nctsj2(4) = 112
!
nctsi1(5) = 145 ; nctsj1(5) = 116 ! Baltic Sea
nctsi2(5) = 150 ; nctsj2(5) = 126
+ !
! ! =======================
CASE ( 4 ) ! ORCA_R4 configuration
@@ -305,4 +308,5 @@
nctsi1(4) = 75 ; nctsj1(4) = 59 ! Baltic Sea
nctsi2(4) = 76 ; nctsj2(4) = 61
+ !
! ! =======================
CASE ( 025 ) ! ORCA_R025 configuration
@@ -318,4 +322,7 @@
!
ENDIF
+ !
+ nctsi1(:) = nctsi1(:) + nn_hls - 1 ; nctsi2(:) = nctsi2(:) + nn_hls - 1 ! -1 as x-perio included in old input files
+ nctsj1(:) = nctsj1(:) + nn_hls ; nctsj2(:) = nctsj2(:) + nn_hls
!
! convert the position in local domain indices
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/TRP/trcldf.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/TRP/trcldf.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/TRP/trcldf.F90 (revision 13540)
@@ -25,5 +25,5 @@
USE trdtra ! trends manager: tracers
!
- USE prtctl_trc ! Print control
+ USE prtctl ! Print control
IMPLICIT NONE
@@ -44,4 +44,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/TOP 4.0 , NEMO Consortium (2018)
@@ -81,5 +82,5 @@
zahv(:,:,:) = rldf * ahtv(:,:,:)
! !* Enhanced zonal diffusivity coefficent in the equatorial domain
- DO_3D_11_11( 1, jpk )
+ DO_3D( 1, 1, 1, 1, 1, jpk )
IF( gdept(ji,jj,jk,Kmm) > 200. .AND. gphit(ji,jj) < 5. .AND. gphit(ji,jj) > -5. ) THEN
zdep = MAX( gdept(ji,jj,jk,Kmm) - 1000., 0. ) / 1000.
@@ -114,6 +115,6 @@
IF( sn_cfctl%l_prttrc ) THEN ! print mean trends (used for debugging)
WRITE(charout, FMT="('ldf ')")
- CALL prt_ctl_trc_info(charout)
- CALL prt_ctl_trc( tab4d=ptr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm, clinfo2='trd' )
+ CALL prt_ctl_info( charout, cdcomp = 'top' )
+ CALL prt_ctl( tab4d_1=ptr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm, clinfo3='trd' )
ENDIF
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/TRP/trcrad.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/TRP/trcrad.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/TRP/trcrad.F90 (revision 13540)
@@ -19,5 +19,5 @@
USE trd_oce
USE trdtra
- USE prtctl_trc ! Print control for debbuging
+ USE prtctl ! Print control for debbuging
USE lib_fortran
@@ -72,6 +72,6 @@
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
WRITE(charout, FMT="('rad')")
- CALL prt_ctl_trc_info( charout )
- CALL prt_ctl_trc( tab4d=ptr(:,:,:,:,Kbb), mask=tmask, clinfo=ctrcnm )
+ CALL prt_ctl_info( charout, cdcomp = 'top' )
+ CALL prt_ctl( tab4d_1=ptr(:,:,:,:,Kbb), mask1=tmask, clinfo=ctrcnm )
ENDIF
!
@@ -168,5 +168,5 @@
IF( l_trdtrc ) ztrtrd(:,:,:) = ptr(:,:,:,jn,itime) ! save input tr(:,:,:,:,Kbb) for trend computation
!
- DO_3D_11_11( 1, jpkm1 )
+ DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
IF( ztrneg(ji,jj,jn) /= 0. ) THEN ! if negative values over the 3x3 box
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/TRP/trcsbc.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/TRP/trcsbc.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/TRP/trcsbc.F90 (revision 13540)
@@ -18,5 +18,5 @@
USE oce_trc ! ocean dynamics and active tracers variables
USE trc ! ocean passive tracers variables
- USE prtctl_trc ! Print control for debbuging
+ USE prtctl ! Print control for debbuging
USE iom
USE trd_oce
@@ -30,4 +30,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/TOP 4.0 , NEMO Consortium (2018)
@@ -49,5 +50,5 @@
!! The surface freshwater flux modify the ocean volume
!! and thus the concentration of a tracer as :
- !! tr(Krhs) = tr(Krhs) + emp * tr(Kmm) / e3t for k=1
+ !! tr(Krhs) = tr(Krhs) + emp * tr(Kmm) / e3t_ for k=1
!! where emp, the surface freshwater budget (evaporation minus
!! precipitation ) given in kg/m2/s is divided
@@ -87,5 +88,5 @@
zfact = 0.5_wp
DO jn = 1, jptra
- CALL iom_get( numrtr, jpdom_autoglo, 'sbc_'//TRIM(ctrcnm(jn))//'_b', sbc_trc_b(:,:,jn) ) ! before tracer content sbc
+ CALL iom_get( numrtr, jpdom_auto, 'sbc_'//TRIM(ctrcnm(jn))//'_b', sbc_trc_b(:,:,jn) ) ! before tracer content sbc
END DO
ELSE ! No restart or restart not found: Euler forward time stepping
@@ -120,5 +121,5 @@
!
DO jn = 1, jptra
- DO_2D_01_00
+ DO_2D( 0, 1, 0, 0 )
sbc_trc(ji,jj,jn) = zsfx(ji,jj) * r1_rho0 * ptr(ji,jj,1,jn,Kmm)
END_2D
@@ -128,5 +129,5 @@
!
DO jn = 1, jptra
- DO_2D_01_00
+ DO_2D( 0, 1, 0, 0 )
sbc_trc(ji,jj,jn) = ( zsfx(ji,jj) + fmmflx(ji,jj) ) * r1_rho0 * ptr(ji,jj,1,jn,Kmm)
END_2D
@@ -136,5 +137,5 @@
!
DO jn = 1, jptra
- DO_2D_01_00
+ DO_2D( 0, 1, 0, 0 )
zse3t = 1. / e3t(ji,jj,1,Kmm)
! tracer flux at the ice/ocean interface (tracer/m2/s)
@@ -154,5 +155,5 @@
END SELECT
!
- CALL lbc_lnk( 'trcsbc', sbc_trc(:,:,:), 'T', 1. )
+ CALL lbc_lnk( 'trcsbc', sbc_trc(:,:,:), 'T', 1.0_wp )
! Concentration dilution effect on tracers due to evaporation & precipitation
DO jn = 1, jptra
@@ -160,5 +161,5 @@
IF( l_trdtrc ) ztrtrd(:,:,:) = ptr(:,:,:,jn,Krhs) ! save trends
!
- DO_2D_01_00
+ DO_2D( 0, 1, 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
@@ -186,6 +187,6 @@
!
IF( sn_cfctl%l_prttrc ) THEN
- WRITE(charout, FMT="('sbc ')") ; CALL prt_ctl_trc_info(charout)
- CALL prt_ctl_trc( tab4d=ptr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm, clinfo2='trd' )
+ WRITE(charout, FMT="('sbc ')") ; CALL prt_ctl_info( charout, cdcomp = 'top' )
+ CALL prt_ctl( tab4d_1=ptr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm, clinfo3='trd' )
ENDIF
IF( l_trdtrc ) DEALLOCATE( ztrtrd )
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/TRP/trcsink.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/TRP/trcsink.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/TRP/trcsink.F90 (revision 13540)
@@ -26,4 +26,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/TOP 4.0 , NEMO Consortium (2018)
@@ -73,5 +74,5 @@
iiter(:,:) = 1
ELSE
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
iiter(ji,jj) = 1
DO jk = 1, jpkm1
@@ -85,5 +86,5 @@
ENDIF
- DO_3D_11_11( 1,jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1,jpkm1 )
IF( tmask(ji,jj,jk) == 1.0 ) THEN
zwsmax = 0.5 * e3t(ji,jj,jk,Kmm) * rday / rsfact
@@ -145,5 +146,5 @@
DO jn = 1, 2
! first guess of the slopes interior values
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
!
zstep = rsfact / REAL( kiter(ji,jj), wp ) / 2.
@@ -157,5 +158,5 @@
! slopes
DO jk = 2, jpkm1
- zign = 0.25 + SIGN( 0.25, ztraz(ji,jj,jk) * ztraz(ji,jj,jk+1) )
+ zign = 0.25 + SIGN( 0.25_wp, ztraz(ji,jj,jk) * ztraz(ji,jj,jk+1) )
zakz(ji,jj,jk) = ( ztraz(ji,jj,jk) + ztraz(ji,jj,jk+1) ) * zign
END DO
@@ -163,5 +164,5 @@
! Slopes limitation
DO jk = 2, jpkm1
- zakz(ji,jj,jk) = SIGN( 1., zakz(ji,jj,jk) ) * &
+ zakz(ji,jj,jk) = SIGN( 1.0_wp, zakz(ji,jj,jk) ) * &
& MIN( ABS( zakz(ji,jj,jk) ), 2. * ABS(ztraz(ji,jj,jk+1)), 2. * ABS(ztraz(ji,jj,jk) ) )
END DO
@@ -185,5 +186,5 @@
END DO
- DO_3D_11_11( 1,jpkm1 )
+ DO_3D( 1, 1, 1, 1, 1,jpkm1 )
zflx = ( psinkflx(ji,jj,jk) - psinkflx(ji,jj,jk+1) ) / e3t(ji,jj,jk,Kmm)
ztrb(ji,jj,jk) = ztrb(ji,jj,jk) + 2. * zflx
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/TRP/trczdf.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/TRP/trczdf.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/TRP/trczdf.F90 (revision 13540)
@@ -22,5 +22,5 @@
!!gm
USE trdtra ! trends manager: tracers
- USE prtctl_trc ! Print control
+ USE prtctl ! Print control
IMPLICIT NONE
@@ -69,6 +69,6 @@
IF( sn_cfctl%l_prttrc ) THEN
WRITE(charout, FMT="('zdf ')")
- CALL prt_ctl_trc_info(charout)
- CALL prt_ctl_trc( tab4d=tr(:,:,:,:,Kaa), mask=tmask, clinfo=ctrcnm, clinfo2='trd' )
+ CALL prt_ctl_info( charout, cdcomp = 'top' )
+ CALL prt_ctl( tab4d_1=tr(:,:,:,:,Kaa), mask1=tmask, clinfo=ctrcnm, clinfo3='trd' )
END IF
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/TRP/trdmxl_trc.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/TRP/trdmxl_trc.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/TRP/trdmxl_trc.F90 (revision 13540)
@@ -51,4 +51,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/TOP 4.0 , NEMO Consortium (2018)
@@ -124,5 +125,5 @@
IF( jpktrd_trc < jpk ) THEN ! description ???
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
IF( nmld_trc(ji,jj) <= jpktrd_trc ) THEN
zvlmsk(ji,jj) = tmask(ji,jj,1)
@@ -147,5 +148,5 @@
! ... Weights for vertical averaging
wkx_trc(:,:,:) = 0.e0
- DO_3D_11_11( 1, jpktrd_trc )
+ DO_3D( 1, 1, 1, 1, 1, jpktrd_trc ) ! initialize wkx_trc with vertical scale factor in mixed-layer
IF( jk - nmld_trc(ji,jj) < 0 ) wkx_trc(ji,jj,jk) = e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk)
END_3D
@@ -258,5 +259,5 @@
!
DO jn = 1, jptra
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 )
ik = nmld_trc(ji,jj)
IF( ln_trdtrc(jn) ) &
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/TRP/trdmxl_trc_rst.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/TRP/trdmxl_trc_rst.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/TRP/trdmxl_trc_rst.F90 (revision 13540)
@@ -144,22 +144,22 @@
DO jn = 1, jptra
- CALL iom_get( inum, jpdom_autoglo, 'tmlbb_trc_' //ctrcnm(jn), tmlbb_trc (:,:,jn) )
- CALL iom_get( inum, jpdom_autoglo, 'tmlbn_trc_' //ctrcnm(jn), tmlbn_trc (:,:,jn) )
- CALL iom_get( inum, jpdom_autoglo, 'tmlatfb_trc_'//ctrcnm(jn), tmlatfb_trc(:,:,jn) )
- CALL iom_get( inum, jpdom_autoglo, 'tmlradb_trc_'//ctrcnm(jn), tmlradb_trc(:,:,jn) )
+ CALL iom_get( inum, jpdom_auto, 'tmlbb_trc_' //ctrcnm(jn), tmlbb_trc (:,:,jn) )
+ CALL iom_get( inum, jpdom_auto, 'tmlbn_trc_' //ctrcnm(jn), tmlbn_trc (:,:,jn) )
+ CALL iom_get( inum, jpdom_auto, 'tmlatfb_trc_'//ctrcnm(jn), tmlatfb_trc(:,:,jn) )
+ CALL iom_get( inum, jpdom_auto, 'tmlradb_trc_'//ctrcnm(jn), tmlradb_trc(:,:,jn) )
END DO
ELSE
- CALL iom_get( inum, jpdom_autoglo, 'rmldbn_trc', rmldbn_trc ) ! needed for rmld_sum
+ CALL iom_get( inum, jpdom_auto, 'rmldbn_trc', rmldbn_trc ) ! needed for rmld_sum
! ! ===========
DO jn = 1, jptra ! tracer loop
! ! ===========
- CALL iom_get( inum, jpdom_autoglo, 'tmlatfb_trc_' //ctrcnm(jn), tmlatfb_trc(:,:,jn) )
- CALL iom_get( inum, jpdom_autoglo, 'tmlbb_trc_' //ctrcnm(jn), tmlbb_trc (:,:,jn) )
- CALL iom_get( inum, jpdom_autoglo, 'tmlradb_trc_' //ctrcnm(jn), tmlradb_trc(:,:,jn) )
-
- CALL iom_get( inum, jpdom_autoglo, 'tmlbn_trc_' //ctrcnm(jn), tmlbn_trc (:,:,jn) ) ! needed for tml_sum
- CALL iom_get( inum, jpdom_autoglo, 'tml_sumb_trc_'//ctrcnm(jn), tml_sumb_trc(:,:,jn) )
+ CALL iom_get( inum, jpdom_auto, 'tmlatfb_trc_' //ctrcnm(jn), tmlatfb_trc(:,:,jn) )
+ CALL iom_get( inum, jpdom_auto, 'tmlbb_trc_' //ctrcnm(jn), tmlbb_trc (:,:,jn) )
+ CALL iom_get( inum, jpdom_auto, 'tmlradb_trc_' //ctrcnm(jn), tmlradb_trc(:,:,jn) )
+
+ CALL iom_get( inum, jpdom_auto, 'tmlbn_trc_' //ctrcnm(jn), tmlbn_trc (:,:,jn) ) ! needed for tml_sum
+ CALL iom_get( inum, jpdom_auto, 'tml_sumb_trc_'//ctrcnm(jn), tml_sumb_trc(:,:,jn) )
DO jk = 1, jpltrd_trc
@@ -169,11 +169,11 @@
WRITE(charout,FMT="('tmltrd_csum_ub_trc_', A3, '_', I2)") ctrcnm(jn), jk
ENDIF
- CALL iom_get( inum, jpdom_autoglo, charout, tmltrd_csum_ub_trc(:,:,jk,jn) )
+ CALL iom_get( inum, jpdom_auto, charout, tmltrd_csum_ub_trc(:,:,jk,jn) )
END DO
- CALL iom_get( inum, jpdom_autoglo, 'tmltrd_atf_sumb_trc_'//ctrcnm(jn) , &
+ CALL iom_get( inum, jpdom_auto, 'tmltrd_atf_sumb_trc_'//ctrcnm(jn) , &
& tmltrd_atf_sumb_trc(:,:,jn) )
- CALL iom_get( inum, jpdom_autoglo, 'tmltrd_rad_sumb_trc_'//ctrcnm(jn) , &
+ CALL iom_get( inum, jpdom_auto, 'tmltrd_rad_sumb_trc_'//ctrcnm(jn) , &
& tmltrd_rad_sumb_trc(:,:,jn) )
! ! ===========
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/TRP/trdtrc.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/TRP/trdtrc.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/TRP/trdtrc.F90 (revision 13540)
@@ -18,4 +18,5 @@
USE trdmxl_trc ! Mixed layer trends diag.
USE iom ! I/O library
+ USE par_kind
IMPLICIT NONE
@@ -107,4 +108,6 @@
!!----------------------------------------------------------------------
+ USE par_kind
+
PUBLIC trd_trc
@@ -116,5 +119,5 @@
INTEGER , INTENT( in ) :: kjn ! tracer index
INTEGER , INTENT( in ) :: ktrd ! tracer trend index
- REAL, DIMENSION(:,:,:), INTENT( inout ) :: ptrtrd ! Temperature or U trend
+ REAL(wp), DIMENSION(:,:,:), INTENT( inout ) :: ptrtrd ! Temperature or U trend
WRITE(*,*) 'trd_trc : You should not have seen this print! error?', ptrtrd(1,1,1)
WRITE(*,*) ' " " : You should not have seen this print! error?', kjn
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/oce_trc.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/oce_trc.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/oce_trc.F90 (revision 13540)
@@ -18,4 +18,27 @@
USE par_oce , ONLY : jp_tem => jp_tem !: indice for temperature
USE par_oce , ONLY : jp_sal => jp_sal !: indice for salinity
+ USE par_oce , ONLY : nn_hls => nn_hls !:
+ USE par_oce , ONLY : Nis0 => Nis0 !:
+ USE par_oce , ONLY : Njs0 => Njs0 !:
+ USE par_oce , ONLY : Nie0 => Nie0 !:
+ USE par_oce , ONLY : Nje0 => Nje0 !:
+ USE par_oce , ONLY : Nis1 => Nis1 !:
+ USE par_oce , ONLY : Njs1 => Njs1 !:
+ USE par_oce , ONLY : Nie1 => Nie1 !:
+ USE par_oce , ONLY : Nje1 => Nje1 !:
+ USE par_oce , ONLY : Nis1nxt2 => Nis1nxt2 !:
+ USE par_oce , ONLY : Njs1nxt2 => Njs1nxt2 !:
+ USE par_oce , ONLY : Nie1nxt2 => Nie1nxt2 !:
+ USE par_oce , ONLY : Nje1nxt2 => Nje1nxt2 !:
+ USE par_oce , ONLY : Nis2 => Nis2 !:
+ USE par_oce , ONLY : Njs2 => Njs2 !:
+ USE par_oce , ONLY : Nie2 => Nie2 !:
+ USE par_oce , ONLY : Nje2 => Nje2 !:
+ USE par_oce , ONLY : Ni_0 => Ni_0 !:
+ USE par_oce , ONLY : Nj_0 => Nj_0 !:
+ USE par_oce , ONLY : Ni_1 => Ni_1 !:
+ USE par_oce , ONLY : Nj_1 => Nj_1 !:
+ USE par_oce , ONLY : Ni_2 => Ni_2 !:
+ USE par_oce , ONLY : Nj_2 => Nj_2 !:
USE in_out_manager !* IO manager *
@@ -62,4 +85,6 @@
USE traqsr , ONLY : rn_abs => rn_abs !: fraction absorbed in the very near surface
USE traqsr , ONLY : rn_si0 => rn_si0 !: very near surface depth of extinction
+ USE traqsr , ONLY : nksr => nksr !: levels below which the light cannot penetrate (depth larger than 391 m)
+ USE traqsr , ONLY : rkrgb => rkrgb !: tabulated attenuation coefficients for RGB absorption
USE traqsr , ONLY : ln_qsr_bio => ln_qsr_bio !: flag to use or not the biological fluxes for light
USE sbcrnf , ONLY : rnfmsk => rnfmsk !: mixed adv scheme in runoffs vicinity (hori.)
Index: MO/branches/2020/r12377_ticket2386/src/TOP/prtctl_trc.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/prtctl_trc.F90 (revision 13539)
+++ (revision )
@@ -1,295 +1,0 @@
-MODULE prtctl_trc
- !!======================================================================
- !! *** MODULE prtctl_trc ***
- !! TOP : print all SUM trends for each processor domain
- !!======================================================================
- !! History : - ! 2005-07 (C. Talandier) original code for OPA
- !! 1.0 ! 2005-10 (C. Ethe ) adapted to passive tracer
- !!----------------------------------------------------------------------
- !! prt_ctl_trc : control print in mpp for passive tracers
- !! prt_ctl_trc_info : ???
- !! prt_ctl_trc_init : ???
- !!----------------------------------------------------------------------
- USE par_trc ! TOP parameters
- USE oce_trc ! ocean space and time domain variables
- USE prtctl ! print control for OPA
-
- IMPLICIT NONE
- PRIVATE
-
- INTEGER , DIMENSION(:), ALLOCATABLE :: numid_trc !: logical unit
- INTEGER , DIMENSION(:), ALLOCATABLE :: nlditl , nldjtl !: first, last indoor index for each i-domain
- INTEGER , DIMENSION(:), ALLOCATABLE :: nleitl , nlejtl !: first, last indoor index for each j-domain
- INTEGER , DIMENSION(:), ALLOCATABLE :: nimpptl, njmpptl !: i-, j-indexes for each processor
- INTEGER , DIMENSION(:), ALLOCATABLE :: nlcitl , nlcjtl !: dimensions of every subdomain
- INTEGER , DIMENSION(:), ALLOCATABLE :: ibonitl, ibonjtl
-
- REAL(wp), DIMENSION(:,:), ALLOCATABLE :: tra_ctl !: previous trend values
-
- PUBLIC prt_ctl_trc ! called by all subroutines
- PUBLIC prt_ctl_trc_info !
- PUBLIC prt_ctl_trc_init ! called by opa.F90
-
-CONTAINS
-
- SUBROUTINE prt_ctl_trc( tab4d, mask, clinfo, ovlap, kdim, clinfo2 )
- !!----------------------------------------------------------------------
- !! *** ROUTINE prt_ctl_trc ***
- !!
- !! ** Purpose : - print sum control 3D arrays over the same area
- !! in mono and mpp case. This way can be usefull when
- !! debugging a new parametrization in mono or mpp.
- !!
- !! ** Method : 2 possibilities exist when setting the sn_cfctl%prttrc parameter to
- !! .true. in the ocean namelist:
- !! - to debug a MPI run .vs. a mono-processor one;
- !! the control print will be done over each sub-domain.
- !! The nictl[se] and njctl[se] parameters in the namelist must
- !! be set to zero and [ij]splt to the corresponding splitted
- !! domain in MPI along respectively i-, j- directions.
- !! - to debug a mono-processor run over the whole domain/a specific area;
- !! in the first case the nictl[se] and njctl[se] parameters must be set
- !! to zero else to the indices of the area to be controled. In both cases
- !! isplt and jsplt must be set to 1.
- !! - All arguments of the above calling sequence are optional so their
- !! name must be explicitly typed if used. For instance if the mask
- !! array tmask(:,:,:) must be passed through the prt_ctl_trc subroutine,
- !! it must look like: CALL prt_ctl_trc( mask=tmask ).
- !!----------------------------------------------------------------------
- REAL(wp) , DIMENSION(:,:,:,:), INTENT(in), OPTIONAL :: tab4d ! 4D array
- REAL(wp) , DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: mask ! 3D mask to apply to the tab4d array
- CHARACTER (len=*), DIMENSION(:) , INTENT(in), OPTIONAL :: clinfo ! information about the tab3d array
- CHARACTER (len=*) , INTENT(in), OPTIONAL :: clinfo2 ! ???
- INTEGER , INTENT(in), OPTIONAL :: ovlap ! overlap value
- INTEGER , INTENT(in), OPTIONAL :: kdim ! k- direction for 4D arrays
- !!
- INTEGER :: overlap, jn, js, sind, eind, kdir, j_id
- REAL(wp) :: zsum, zvctl
- CHARACTER (len=20), ALLOCATABLE, DIMENSION(:) :: cl
- CHARACTER (len=10) :: cl2
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask, ztab3d
- !!----------------------------------------------------------------------
-
- ALLOCATE( cl(jptra) )
- ! ! Arrays, scalars initialization
- overlap = 0
- kdir = jpkm1
- zsum = 0.e0
- zvctl = 0.e0
- cl(:) = ''
- cl2 = ''
- ztab3d(:,:,:) = 0.e0
- zmask (:,:,:) = 1.e0
-
- ! ! Control of optional arguments
- IF( PRESENT(ovlap) ) overlap = ovlap
- IF( PRESENT(kdim) ) kdir = kdim
- IF( PRESENT(clinfo ) ) cl(:) = clinfo(:)
- IF( PRESENT(clinfo2) ) cl2 = clinfo2
- IF( PRESENT(mask) ) zmask (:,:,:) = mask(:,:,:)
-
- IF( lk_mpp ) THEN ! processor number
- sind = narea
- eind = narea
- ELSE ! processors total number
- sind = 1
- eind = ijsplt
- ENDIF
-
- ! Loop over each sub-domain, i.e. the total number of processors ijsplt
- DO js = sind, eind
- !
- ! Set logical unit
- j_id = numid_trc( js - narea + 1 )
- ! Set indices for the SUM control
- IF( .NOT. lsp_area ) THEN
- IF (lk_mpp ) THEN
- nictls = MAX( 1, nlditl(js) - overlap )
- nictle = nleitl(js) + overlap * MIN( 1, nlcitl(js) - nleitl(js))
- njctls = MAX( 1, nldjtl(js) - overlap )
- njctle = nlejtl(js) + overlap * MIN( 1, nlcjtl(js) - nlejtl(js))
- ! Do not take into account the bound of the domain
- IF( ibonitl(js) == -1 .OR. ibonitl(js) == 2 ) nictls = MAX( 2, nictls )
- IF( ibonitl(js) == 1 .OR. ibonitl(js) == 2 ) nictle = MIN( nictle, nleitl(js) - 1 )
- IF( ibonjtl(js) == -1 .OR. ibonjtl(js) == 2 ) njctls = MAX( 2, njctls )
- IF( ibonjtl(js) == 1 .OR. ibonjtl(js) == 2 ) njctle = MIN( njctle, nlejtl(js) - 1 )
- ELSE
- nictls = MAX( 1, nimpptl(js) + nlditl(js) - 1 - overlap )
- nictle = nimpptl(js) + nleitl(js) - 1 + overlap * MIN( 1, nlcitl(js) - nleitl(js) )
- njctls = MAX( 1, njmpptl(js) + nldjtl(js) - 1 - overlap )
- njctle = njmpptl(js) + nlejtl(js) - 1 + overlap * MIN( 1, nlcjtl(js) - nlejtl(js) )
- ! Do not take into account the bound of the domain
- IF( ibonitl(js) == -1 .OR. ibonitl(js) == 2 ) nictls = MAX( 2, nictls )
- IF( ibonjtl(js) == -1 .OR. ibonjtl(js) == 2 ) njctls = MAX( 2, njctls )
- IF( ibonitl(js) == 1 .OR. ibonitl(js) == 2 ) nictle = MIN( nictle, nimpptl(js) + nleitl(js) - 2 )
- IF( ibonjtl(js) == 1 .OR. ibonjtl(js) == 2 ) njctle = MIN( njctle, njmpptl(js) + nlejtl(js) - 2 )
- ENDIF
- ENDIF
- !
- IF( PRESENT(clinfo2) ) THEN
- DO jn = 1, jptra
- zvctl = tra_ctl(jn,js)
- ztab3d(:,:,:) = tab4d(:,:,:,jn)
- zsum = SUM( ztab3d(nictls:nictle,njctls:njctle,1:kdir) &
- & * zmask(nictls:nictle,njctls:njctle,1:kdir) )
- WRITE(j_id,FMT="(3x,a,' : ',D23.16)") cl(jn), zsum-zvctl
- tra_ctl(jn,js) = zsum
- END DO
- ELSE
- DO jn = 1, jptra
- ztab3d(:,:,:) = tab4d(:,:,:,jn)
- zsum = SUM( ztab3d(nictls:nictle,njctls:njctle,1:kdir) &
- & * zmask(nictls:nictle,njctls:njctle,1:kdir) )
- WRITE(j_id,FMT="(3x,a,' : ',D23.16)") cl(jn), zsum
- END DO
- ENDIF
- !
- END DO
- !
- DEALLOCATE( cl )
- !
- END SUBROUTINE prt_ctl_trc
-
-
- SUBROUTINE prt_ctl_trc_info( clinfo )
- !!----------------------------------------------------------------------
- !! *** ROUTINE prt_ctl_trc_info ***
- !!
- !! ** Purpose : - print information without any computation
- !!----------------------------------------------------------------------
- CHARACTER (len=*), INTENT(in) :: clinfo ! information to print
- !!
- INTEGER :: js, sind, eind, j_id
- !!----------------------------------------------------------------------
-
- IF( lk_mpp ) THEN ! processor number
- sind = narea
- eind = narea
- ELSE ! total number of processors
- sind = 1
- eind = ijsplt
- ENDIF
-
- ! Loop over each sub-domain, i.e. number of processors ijsplt
- DO js = sind, eind
- j_id = numid_trc(js - narea + 1)
- WRITE(j_id,*) clinfo
- END DO
- !
- END SUBROUTINE prt_ctl_trc_info
-
-
- SUBROUTINE prt_ctl_trc_init
- !!----------------------------------------------------------------------
- !! *** ROUTINE prt_ctl_trc_init ***
- !!
- !! ** Purpose : open ASCII files & compute indices
- !!----------------------------------------------------------------------
- INTEGER :: js, sind, eind, j_id
- CHARACTER (len=31) :: clfile_out
- CHARACTER (len=27) :: clb_name
- CHARACTER (len=19) :: cl_run
- !!----------------------------------------------------------------------
-
- ! ! Allocate arrays
- ALLOCATE( nlditl (ijsplt) )
- ALLOCATE( nldjtl (ijsplt) )
- ALLOCATE( nleitl (ijsplt) )
- ALLOCATE( nlejtl (ijsplt) )
- ALLOCATE( nimpptl(ijsplt) )
- ALLOCATE( njmpptl(ijsplt) )
- ALLOCATE( nlcitl (ijsplt) )
- ALLOCATE( nlcjtl (ijsplt) )
- ALLOCATE( tra_ctl(jptra,ijsplt) )
- ALLOCATE( ibonitl(ijsplt) )
- ALLOCATE( ibonjtl(ijsplt) )
-
- tra_ctl(:,:) = 0.e0 ! Initialization to zero
-
- IF( lk_mpp ) THEN
- sind = narea
- eind = narea
- clb_name = "('mpp.top.output_',I4.4)"
- cl_run = 'MULTI processor run'
- ! use indices for each area computed by mpp_init subroutine
- nlditl(1:jpnij) = nldit(:)
- nleitl(1:jpnij) = nleit(:)
- nldjtl(1:jpnij) = nldjt(:)
- nlejtl(1:jpnij) = nlejt(:)
- !
- nimpptl(1:jpnij) = nimppt(:)
- njmpptl(1:jpnij) = njmppt(:)
- !
- nlcitl(1:jpnij) = nlcit(:)
- nlcjtl(1:jpnij) = nlcjt(:)
- !
- ibonitl(1:jpnij) = ibonit(:)
- ibonjtl(1:jpnij) = ibonjt(:)
- ELSE
- sind = 1
- eind = ijsplt
- clb_name = "('mono.top.output_',I4.4)"
- cl_run = 'MONO processor run '
- ! compute indices for each area as done in mpp_init subroutine
- CALL sub_dom
- ENDIF
-
- ALLOCATE( numid_trc(eind-sind+1) )
-
- DO js = sind, eind
- WRITE(clfile_out,FMT=clb_name) js-1
- CALL ctl_opn( numid_trc(js -narea + 1), clfile_out, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. )
- j_id = numid_trc(js -narea + 1)
- WRITE(j_id,*)
- WRITE(j_id,*) ' L O D Y C - I P S L'
- WRITE(j_id,*) ' N E M 0 '
- WRITE(j_id,*) ' Ocean General Circulation Model'
- WRITE(j_id,*) ' version TOP 1.0 (2005) '
- WRITE(j_id,*)
- WRITE(j_id,*) ' PROC number: ', js
- WRITE(j_id,*)
- WRITE(j_id,FMT="(19x,a20)") cl_run
-
- ! Print the SUM control indices
- IF( .NOT. lsp_area ) THEN
- IF ( lk_mpp ) THEN
- nictls = nlditl(js)
- nictle = nleitl(js)
- njctls = nldjtl(js)
- njctle = nlejtl(js)
- ELSE
- nictls = nimpptl(js) + nlditl(js) - 1
- nictle = nimpptl(js) + nleitl(js) - 1
- njctls = njmpptl(js) + nldjtl(js) - 1
- njctle = njmpptl(js) + nlejtl(js) - 1
- ENDIF
- ENDIF
- WRITE(j_id,*)
- WRITE(j_id,*) 'prt_tra_ctl : Sum control indices'
- WRITE(j_id,*) '~~~~~~~'
- WRITE(j_id,*)
- WRITE(j_id,9000)' nlej = ', nlejtl(js), ' '
- WRITE(j_id,9000)' ------------- njctle = ', njctle, ' -------------'
- WRITE(j_id,9001)' | |'
- WRITE(j_id,9001)' | |'
- WRITE(j_id,9001)' | |'
- WRITE(j_id,9002)' nictls = ', nictls, ' nictle = ', nictle
- WRITE(j_id,9002)' nldi = ', nlditl(js), ' nlei = ', nleitl(js)
- WRITE(j_id,9001)' | |'
- WRITE(j_id,9001)' | |'
- WRITE(j_id,9001)' | |'
- WRITE(j_id,9004)' njmpp = ',njmpptl(js),' ------------- njctls = ', njctls, ' -------------'
- WRITE(j_id,9003)' nimpp = ', nimpptl(js), ' nldj = ', nldjtl(js), ' '
- WRITE(j_id,*)
- WRITE(j_id,*)
-
-9000 FORMAT(a41,i4.4,a14)
-9001 FORMAT(a59)
-9002 FORMAT(a20,i4.4,a36,i3.3)
-9003 FORMAT(a20,i4.4,a17,i4.4)
-9004 FORMAT(a11,i4.4,a26,i4.4,a14)
- END DO
- !
- END SUBROUTINE prt_ctl_trc_init
-
-END MODULE prtctl_trc
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/trcbc.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/trcbc.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/trcbc.F90 (revision 13540)
@@ -48,4 +48,5 @@
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/TOP 4.0 , NEMO Consortium (2018)
@@ -151,5 +152,5 @@
IF(trcdta_bdy(jn,ib)%cn_obc == 'frs' .AND. nn_trcdmp_bdy(ib) /= 0 ) &
& CALL ctl_stop( 'trc_bc_ini: Use FRS OR relaxation' )
- IF( .NOT.( 0 < nn_trcdmp_bdy(ib) .AND. nn_trcdmp_bdy(ib) <= 2 ) ) &
+ IF( .NOT.( 0 <= nn_trcdmp_bdy(ib) .AND. nn_trcdmp_bdy(ib) <= 2 ) ) &
& CALL ctl_stop( 'trc_bc_ini: Not a valid option for nn_trcdmp_bdy. Allowed: 0,1,2.' )
END DO
@@ -414,5 +415,5 @@
! Remove river dilution for tracers with absent river load
IF( ln_rnf_ctl .AND. .NOT.ln_trc_cbc(jn) ) THEN
- DO_2D_01_00
+ DO_2D( 0, 1, 0, 0 )
DO jk = 1, nk_rnf(ji,jj)
zrnf = (rnf(ji,jj) + rnf_b(ji,jj)) * 0.5_wp * r1_rho0 / h_rnf(ji,jj)
@@ -428,5 +429,5 @@
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_01_00
+ DO_2D( 0, 1, 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
@@ -438,5 +439,5 @@
IF( l_offline ) rn_rfact = 1._wp
jl = n_trc_indcbc(jn)
- DO_2D_01_00
+ DO_2D( 0, 1, 0, 0 )
DO jk = 1, nk_rnf(ji,jj)
zfact = rn_rfact / ( e1e2t(ji,jj) * h_rnf(ji,jj) * rn_cbc_time ) * tmask(ji,jj,1)
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/trcbdy.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/trcbdy.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/trcbdy.F90 (revision 13540)
@@ -49,5 +49,4 @@
INTEGER :: ib_bdy ,ir, jn ,igrd ! Loop indices
REAL(wp), POINTER, DIMENSION(:,:) :: ztrc
- REAL(wp), POINTER :: zfac
LOGICAL :: llrim0 ! indicate if rim 0 is treated
LOGICAL, DIMENSION(4) :: llsend1, llrecv1 ! indicate how communications are to be carried out
@@ -61,30 +60,38 @@
IF( ir == 0 ) THEN ; llrim0 = .TRUE.
ELSE ; llrim0 = .FALSE.
- END IF
+ ENDIF
DO ib_bdy=1, nb_bdy
+ !
DO jn = 1, jptra
!
- ztrc => trcdta_bdy(jn,ib_bdy)%trc
- zfac => trcdta_bdy(jn,ib_bdy)%rn_fac
+ IF( ASSOCIATED(trcdta_bdy(jn,ib_bdy)%trc) .AND. trcdta_bdy(jn,ib_bdy)%cn_obc /= 'neumann' ) THEN
+ IF( .NOT. ASSOCIATED(ztrc) ) ALLOCATE( ztrc(idx_bdy(ib_bdy)%nblen(igrd),jpk) )
+ ztrc(:,:) = trcdta_bdy(jn,ib_bdy)%trc(:,:) * trcdta_bdy(jn,ib_bdy)%rn_fac
+ ENDIF
!
- SELECT CASE( TRIM(trcdta_bdy(jn,ib_bdy)%cn_obc) )
+ SELECT CASE( trcdta_bdy(jn,ib_bdy)%cn_obc )
CASE('none' ) ; CYCLE
CASE('frs' ) ! treat the whole boundary at once
- IF( ir == 0 ) CALL bdy_frs( idx_bdy(ib_bdy), tr(:,:,:,jn,Krhs), ztrc*zfac )
+ IF( ir == 0 ) CALL bdy_frs( idx_bdy(ib_bdy), tr(:,:,:,jn,Krhs), ztrc )
CASE('specified' ) ! treat the whole rim at once
- IF( ir == 0 ) CALL bdy_spe( idx_bdy(ib_bdy), tr(:,:,:,jn,Krhs), ztrc*zfac )
- CASE('neumann' ) ; CALL bdy_nmn( idx_bdy(ib_bdy), igrd , tr(:,:,:,jn,Krhs) ) ! tra masked
- CASE('orlanski' ) ; CALL bdy_orl( idx_bdy(ib_bdy), tr(:,:,:,jn,Kbb), tr(:,:,:,jn,Krhs), ztrc*zfac, ll_npo=.false. )
- CASE('orlanski_npo') ; CALL bdy_orl( idx_bdy(ib_bdy), tr(:,:,:,jn,Kbb), tr(:,:,:,jn,Krhs), ztrc*zfac, ll_npo=.true. )
+ IF( ir == 0 ) CALL bdy_spe( idx_bdy(ib_bdy), tr(:,:,:,jn,Krhs), ztrc )
+ CASE('neumann' ) ; CALL bdy_nmn( idx_bdy(ib_bdy), igrd , tr(:,:,:,jn,Krhs), llrim0 ) ! tra masked
+ CASE('orlanski' ) ; CALL bdy_orl( idx_bdy(ib_bdy), tr(:,:,:,jn,Kbb), tr(:,:,:,jn,Krhs), ztrc, llrim0, &
+ & ll_npo=.FALSE. )
+ CASE('orlanski_npo') ; CALL bdy_orl( idx_bdy(ib_bdy), tr(:,:,:,jn,Kbb), tr(:,:,:,jn,Krhs), ztrc, llrim0, &
+ & ll_npo=.TRUE. )
CASE DEFAULT ; CALL ctl_stop( 'trc_bdy : unrecognised option for open boundaries for passive tracers' )
END SELECT
!
END DO
+ !
+ IF( ASSOCIATED(ztrc) ) DEALLOCATE(ztrc)
+ !
END DO
!
IF( nn_hls > 1 .AND. ir == 1 ) CYCLE ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0
- IF( nn_hls == 1 ) THEN ; llsend1(:) = .false. ; llrecv1(:) = .false. ; END IF
+ IF( nn_hls == 1 ) THEN ; llsend1(:) = .false. ; llrecv1(:) = .false. ; ENDIF
DO ib_bdy=1, nb_bdy
- SELECT CASE( TRIM(cn_tra(ib_bdy)) )
+ SELECT CASE( cn_tra(ib_bdy) )
CASE('neumann')
llsend1(:) = llsend1(:) .OR. lsend_bdyint(ib_bdy,1,:,ir) ! possibly every direction, T points
@@ -96,6 +103,6 @@
END DO
IF( ANY(llsend1) .OR. ANY(llrecv1) ) THEN ! if need to send/recv in at least one direction
- CALL lbc_lnk( 'trcbdy', tr(:,:,:,:,Krhs), 'T', 1., kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 )
- END IF
+ CALL lbc_lnk( 'trcbdy', tr(:,:,:,:,Krhs), 'T', 1.0_wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 )
+ ENDIF
!
END DO ! ir
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/trcdta.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/trcdta.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/trcdta.F90 (revision 13540)
@@ -41,4 +41,5 @@
!! Substitutions
#include "do_loop_substitute.h90"
+#include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/TOP 4.0 , NEMO Consortium (2018)
@@ -198,5 +199,5 @@
WRITE(numout,*) 'trc_dta: interpolates passive tracer data onto the s- or mixed s-z-coordinate mesh'
ENDIF
- DO_2D_11_11
+ DO_2D( 1, 1, 1, 1 ) ! vertical interpolation of T & S
DO jk = 1, jpk ! determines the intepolated T-S profiles at each (i,j) points
zl = gdept(ji,jj,jk,Kmm)
@@ -206,5 +207,5 @@
ztp(jk) = ptrcdta(ji,jj,jpkm1)
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_1d(jkk) < zl < gdept_1d(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))
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/trcini.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/trcini.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/trcini.F90 (revision 13540)
@@ -20,5 +20,5 @@
USE trcnam ! Namelist read
USE daymod ! calendar manager
- USE prtctl_trc ! Print control passive tracers (prt_ctl_trc_init routine)
+ USE prtctl ! Print control passive tracers (prt_ctl_init routine)
USE trcrst
USE lib_mpp ! distribued memory computing library
@@ -31,4 +31,5 @@
PUBLIC trc_init ! called by opa
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/TOP 4.0 , NEMO Consortium (2018)
@@ -93,4 +94,6 @@
INTEGER :: jk, jn ! dummy loop indices
CHARACTER (len=25) :: charout
+ REAL(wp), DIMENSION(jpi,jpj,jpk,jptra) :: zzmsk
+ CHARACTER (len=25), DIMENSION(jptra) :: clseb
!!----------------------------------------------------------------------
!
@@ -124,8 +127,13 @@
IF(lwp) WRITE(numout,*)
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
- CALL prt_ctl_trc_init
+ CALL prt_ctl_init( 'top', jptra )
WRITE(charout, FMT="('ini ')")
- CALL prt_ctl_trc_info( charout )
- CALL prt_ctl_trc( tab4d=tr(:,:,:,:,Kmm), mask=tmask, clinfo=ctrcnm )
+ CALL prt_ctl_info( charout, cdcomp = 'top' )
+ CALL prt_ctl( tab4d_1=tr(:,:,:,:,Kmm), mask1=tmask, clinfo=ctrcnm )
+ DO jn = 1, jptra
+ zzmsk(:,:,:,jn) = tmask(:,:,:)
+ WRITE(clseb(jn),'(a,i2.2)') 'seb ', jn
+ END DO
+ CALL prt_ctl( tab4d_1=zzmsk, mask1=tmask, clinfo=clseb )
ENDIF
9000 FORMAT(' tracer nb : ',i2,' name :',a10,' initial content :',e18.10)
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/trcrst.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/trcrst.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/trcrst.F90 (revision 13540)
@@ -33,4 +33,5 @@
PUBLIC trc_rst_cal
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/TOP 4.0 , NEMO Consortium (2018)
@@ -113,9 +114,9 @@
! READ prognostic variables and computes diagnostic variable
DO jn = 1, jptra
- CALL iom_get( numrtr, jpdom_autoglo, 'TRN'//ctrcnm(jn), tr(:,:,:,jn,Kmm) )
- END DO
-
- DO jn = 1, jptra
- CALL iom_get( numrtr, jpdom_autoglo, 'TRB'//ctrcnm(jn), tr(:,:,:,jn,Kbb) )
+ CALL iom_get( numrtr, jpdom_auto, 'TRN'//ctrcnm(jn), tr(:,:,:,jn,Kmm) )
+ END DO
+
+ DO jn = 1, jptra
+ CALL iom_get( numrtr, jpdom_auto, 'TRB'//ctrcnm(jn), tr(:,:,:,jn,Kbb) )
END DO
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/trcsms.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/trcsms.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/trcsms.F90 (revision 13540)
@@ -20,5 +20,5 @@
USE trcsms_age ! AGE
USE trcsms_my_trc ! MY_TRC tracers
- USE prtctl_trc ! Print control for debbuging
+ USE prtctl ! Print control for debbuging
IMPLICIT NONE
@@ -58,6 +58,6 @@
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
WRITE(charout, FMT="('sms ')")
- CALL prt_ctl_trc_info( charout )
- CALL prt_ctl_trc( tab4d=tr(:,:,:,:,Kmm), mask=tmask, clinfo=ctrcnm )
+ CALL prt_ctl_info( charout, cdcomp = 'top' )
+ CALL prt_ctl( tab4d_1=tr(:,:,:,:,Kmm), mask1=tmask, clinfo=ctrcnm )
ENDIF
!
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/trcstp.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/trcstp.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/trcstp.F90 (revision 13540)
@@ -22,5 +22,5 @@
USE sms_pisces, ONLY : ln_check_mass
!
- USE prtctl_trc ! Print control for debbuging
+ USE prtctl ! Print control for debbuging
USE iom !
USE in_out_manager !
@@ -37,4 +37,5 @@
REAL(wp), DIMENSION(:,:,:), SAVE, ALLOCATABLE :: qsr_arr ! save qsr during TOP time-step
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/TOP 4.0 , NEMO Consortium (2018)
@@ -91,5 +92,5 @@
IF(sn_cfctl%l_prttrc) THEN
WRITE(charout,FMT="('kt =', I4,' d/m/y =',I2,I2,I4)") kt, nday, nmonth, nyear
- CALL prt_ctl_trc_info(charout)
+ CALL prt_ctl_info( charout, cdcomp = 'top' )
ENDIF
!
@@ -142,6 +143,7 @@
!
! Define logical parameter ton control dirunal cycle in TOP
- l_trcdm2dc = ln_dm2dc .OR. ( ln_cpl .AND. ncpl_qsr_freq /= 1 )
- l_trcdm2dc = l_trcdm2dc .AND. .NOT. l_offline
+ 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 ' )
@@ -198,5 +200,5 @@
rsecfst = INT( zkt ) * rn_Dt
IF(lwp) WRITE(numout,*) 'trc_qsr_mean: qsr_mean read in the restart file at time-step rsecfst =', rsecfst, ' s '
- CALL iom_get( numrtr, jpdom_autoglo, 'qsr_mean', qsr_mean ) ! A mean of qsr
+ CALL iom_get( numrtr, jpdom_auto, 'qsr_mean', qsr_mean ) ! A mean of qsr
CALL iom_get( numrtr, 'nrdcy', zrec ) ! Number of record per days
IF( INT( zrec ) == nb_rec_per_day ) THEN
@@ -204,8 +206,8 @@
IF( jn <= 9 ) THEN
WRITE(cl1,'(i1)') jn
- CALL iom_get( numrtr, jpdom_autoglo, 'qsr_arr_'//cl1, qsr_arr(:,:,jn) ) ! A mean of qsr
+ CALL iom_get( numrtr, jpdom_auto, 'qsr_arr_'//cl1, qsr_arr(:,:,jn) ) ! A mean of qsr
ELSE
WRITE(cl2,'(i2.2)') jn
- CALL iom_get( numrtr, jpdom_autoglo, 'qsr_arr_'//cl2, qsr_arr(:,:,jn) ) ! A mean of qsr
+ CALL iom_get( numrtr, jpdom_auto, 'qsr_arr_'//cl2, qsr_arr(:,:,jn) ) ! A mean of qsr
ENDIF
END DO
Index: /NEMO/branches/2020/r12377_ticket2386/src/TOP/trcwri.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/src/TOP/trcwri.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/src/TOP/trcwri.F90 (revision 13540)
@@ -60,7 +60,9 @@
CALL iom_put( "e3v_0", e3v_0(:,:,:) )
!
+#if ! defined key_qco
CALL iom_put( "e3t" , e3t(:,:,:,Kmm) )
CALL iom_put( "e3u" , e3u(:,:,:,Kmm) )
CALL iom_put( "e3v" , e3v(:,:,:,Kmm) )
+#endif
!
ENDIF
Index: /NEMO/branches/2020/r12377_ticket2386/tests/BENCH/EXPREF/namelist_cfg_orca025_like
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/BENCH/EXPREF/namelist_cfg_orca025_like (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/BENCH/EXPREF/namelist_cfg_orca025_like (revision 13540)
@@ -15,6 +15,6 @@
&namusr_def ! User defined : BENCH configuration: Flat bottom, beta-plane
!-----------------------------------------------------------------------
- nn_isize = 1442 ! number of point in i-direction of global(local) domain if >0 (<0)
- nn_jsize = 1207 !! 1050 ! number of point in j-direction of global(local) domain if >0 (<0)
+ nn_isize = 1440 ! number of point in i-direction of global(local) domain if >0 (<0)
+ nn_jsize = 1206 !! 1049 ! number of point in j-direction of global(local) domain if >0 (<0)
nn_ksize = 75 ! total number of point in k-direction
nn_perio = 4 ! periodicity
@@ -30,5 +30,4 @@
&namctl ! Control prints (default: OFF)
!-----------------------------------------------------------------------
- nn_print = 0 ! level of print (0 no extra print)
ln_timing = .false. ! timing by routine write out in timing.output file
/
@@ -50,4 +49,7 @@
!-----------------------------------------------------------------------
ln_usr = .true. ! user defined formulation (T => check usrdef_sbc)
+ nn_ice = 2 ! =0 no ice boundary condition
+ ! ! =1 use observed ice-cover ( => fill namsbc_iif )
+ ! ! =2 or 3 for SI3 and CICE, respectively
ln_traqsr = .true. ! Light penetration in the ocean (T => fill namtra_qsr)
/
@@ -75,6 +77,6 @@
!! !!
!! namdrg top/bottom drag coefficient (default: NO selection)
-!! namdrg_top top friction (ln_OFF =F & ln_isfcav=T)
-!! namdrg_bot bottom friction (ln_OFF =F)
+!! 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)
Index: /NEMO/branches/2020/r12377_ticket2386/tests/BENCH/EXPREF/namelist_cfg_orca12_like
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/BENCH/EXPREF/namelist_cfg_orca12_like (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/BENCH/EXPREF/namelist_cfg_orca12_like (revision 13540)
@@ -15,6 +15,6 @@
&namusr_def ! User defined : BENCH configuration: Flat bottom, beta-plane
!-----------------------------------------------------------------------
- nn_isize = 4322 ! number of point in i-direction of global(local) domain if >0 (<0)
- nn_jsize = 3147 ! number of point in j-direction of global(local) domain if >0 (<0)
+ nn_isize = 4320 ! number of point in i-direction of global(local) domain if >0 (<0)
+ nn_jsize = 3146 ! number of point in j-direction of global(local) domain if >0 (<0)
nn_ksize = 75 ! total number of point in k-direction
nn_perio = 4 ! periodicity
@@ -30,5 +30,4 @@
&namctl ! Control prints (default: OFF)
!-----------------------------------------------------------------------
- nn_print = 0 ! level of print (0 no extra print)
ln_timing = .false. ! timing by routine write out in timing.output file
/
@@ -50,4 +49,7 @@
!-----------------------------------------------------------------------
ln_usr = .true. ! user defined formulation (T => check usrdef_sbc)
+ nn_ice = 2 ! =0 no ice boundary condition
+ ! ! =1 use observed ice-cover ( => fill namsbc_iif )
+ ! ! =2 or 3 for SI3 and CICE, respectively
ln_traqsr = .true. ! Light penetration in the ocean (T => fill namtra_qsr)
/
@@ -75,6 +77,6 @@
!! !!
!! namdrg top/bottom drag coefficient (default: NO selection)
-!! namdrg_top top friction (ln_OFF =F & ln_isfcav=T)
-!! namdrg_bot bottom friction (ln_OFF =F)
+!! 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)
Index: /NEMO/branches/2020/r12377_ticket2386/tests/BENCH/EXPREF/namelist_cfg_orca1_like
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/BENCH/EXPREF/namelist_cfg_orca1_like (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/BENCH/EXPREF/namelist_cfg_orca1_like (revision 13540)
@@ -15,6 +15,6 @@
&namusr_def ! User defined : BENCH configuration: Flat bottom, beta-plane
!-----------------------------------------------------------------------
- nn_isize = 362 ! number of point in i-direction of global(local) domain if >0 (<0)
- nn_jsize = 332 ! number of point in j-direction of global(local) domain if >0 (<0)
+ nn_isize = 360 ! number of point in i-direction of global(local) domain if >0 (<0)
+ nn_jsize = 331 ! number of point in j-direction of global(local) domain if >0 (<0)
nn_ksize = 75 ! total number of point in k-direction
nn_perio = 6 ! periodicity
@@ -30,5 +30,4 @@
&namctl ! Control prints (default: OFF)
!-----------------------------------------------------------------------
- nn_print = 0 ! level of print (0 no extra print)
ln_timing = .false. ! timing by routine write out in timing.output file
/
@@ -50,4 +49,7 @@
!-----------------------------------------------------------------------
ln_usr = .true. ! user defined formulation (T => check usrdef_sbc)
+ nn_ice = 2 ! =0 no ice boundary condition
+ ! ! =1 use observed ice-cover ( => fill namsbc_iif )
+ ! ! =2 or 3 for SI3 and CICE, respectively
ln_traqsr = .true. ! Light penetration in the ocean (T => fill namtra_qsr)
/
@@ -75,6 +77,6 @@
!! !!
!! namdrg top/bottom drag coefficient (default: NO selection)
-!! namdrg_top top friction (ln_OFF =F & ln_isfcav=T)
-!! namdrg_bot bottom friction (ln_OFF =F)
+!! 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)
Index: /NEMO/branches/2020/r12377_ticket2386/tests/BENCH/EXPREF/namelist_pisces_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/BENCH/EXPREF/namelist_pisces_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/BENCH/EXPREF/namelist_pisces_cfg (revision 13540)
@@ -81,10 +81,6 @@
/
!-----------------------------------------------------------------------
-&nampissbc ! parameters for inputs deposition
+&nampisbc ! parameters for inputs deposition
!-----------------------------------------------------------------------
- ln_dust = .false. ! boolean for dust input from the atmosphere
- ln_solub = .false. ! boolean for variable solubility of atm. Iron
- ln_river = .false. ! boolean for river input of nutrients
- ln_ndepo = .false. ! boolean for atmospheric deposition of N
ln_ironsed = .false. ! boolean for Fe input from sediments
ln_ironice = .false. ! boolean for Fe input from sea ice
Index: /NEMO/branches/2020/r12377_ticket2386/tests/BENCH/MY_SRC/usrdef_hgr.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/BENCH/MY_SRC/usrdef_hgr.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/BENCH/MY_SRC/usrdef_hgr.F90 (revision 13540)
@@ -24,4 +24,6 @@
PUBLIC usr_def_hgr ! called by domhgr.F90
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OPA 4.0, NEMO Consortium (2016)
@@ -59,7 +61,7 @@
REAL(wp), DIMENSION(:,:), INTENT(out) :: pe1e2u, pe1e2v ! u- & v-surfaces (if reduction in strait) [m2]
!
- INTEGER :: ji, jj ! dummy loop indices
+ INTEGER :: ji, jj ! dummy loop indices
REAL(wp) :: zres, zf0
- REAL(wp) :: zti, zui, ztj, zvj ! local scalars
+ REAL(wp) :: zti, ztj ! local scalars
!!-------------------------------------------------------------------------------
!
@@ -70,25 +72,22 @@
IF(lwp) WRITE(numout,*) ' given by rn_dx and rn_dy'
!
- !
! Position coordinates (in grid points)
- ! ==========
- DO jj = 1, jpj
- DO ji = 1, jpi
-
- zti = REAL( ji - 1 + nimpp - 1, wp ) ; ztj = REAL( jj - 1 + njmpp - 1, wp )
- zui = REAL( ji - 1 + nimpp - 1, wp ) + 0.5_wp ; zvj = REAL( jj - 1 + njmpp - 1, wp ) + 0.5_wp
+ ! ==========
+ DO_2D( 1, 1, 1, 1 )
+
+ zti = REAL( mig0_oldcmp(ji) - 1, wp ) ! start at i=0 in the global grid without halos
+ ztj = REAL( mjg0_oldcmp(jj) - 1, wp ) ! start at j=0 in the global grid without halos
+
+ plamt(ji,jj) = zti
+ plamu(ji,jj) = zti + 0.5_wp
+ plamv(ji,jj) = zti
+ plamf(ji,jj) = zti + 0.5_wp
+
+ pphit(ji,jj) = ztj
+ pphiu(ji,jj) = ztj
+ pphiv(ji,jj) = ztj + 0.5_wp
+ pphif(ji,jj) = ztj + 0.5_wp
- plamt(ji,jj) = zti
- plamu(ji,jj) = zui
- plamv(ji,jj) = zti
- plamf(ji,jj) = zui
-
- pphit(ji,jj) = ztj
- pphiv(ji,jj) = zvj
- pphiu(ji,jj) = ztj
- pphif(ji,jj) = zvj
-
- END DO
- END DO
+ END_2D
!
! Horizontal scale factors (in meters)
@@ -109,5 +108,5 @@
kff = 1 ! indicate not to compute Coriolis parameter afterward
!
- zf0 = 2._wp * omega * SIN( rad * 45 ) ! constant coriolis factor corresponding to 45°N
+ zf0 = 2._wp * omega * SIN( rad * 45 ) ! constant coriolis factor corresponding to 45°N
pff_f(:,:) = zf0
pff_t(:,:) = zf0
Index: /NEMO/branches/2020/r12377_ticket2386/tests/BENCH/MY_SRC/usrdef_istate.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/BENCH/MY_SRC/usrdef_istate.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/BENCH/MY_SRC/usrdef_istate.F90 (revision 13540)
@@ -28,4 +28,6 @@
PUBLIC usr_def_istate ! called by istate.F90
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OPA 4.0 , NEMO Consortium (2016)
@@ -55,4 +57,5 @@
REAL(wp) :: zfact
INTEGER :: ji, jj, jk
+ INTEGER :: igloi, igloj ! to be removed in the future, see comment bellow
!!----------------------------------------------------------------------
!
@@ -61,15 +64,22 @@
IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~ '
!
- ! define unique value on each point. z2d ranging from 0.05 to -0.05
- DO jj = 1, jpj
- DO ji = 1, jpi
- z2d(ji,jj) = 0.1 * ( 0.5 - REAL( mig(ji) + mjg(jj) * jpiglo, wp ) / REAL( jpiglo * jpjglo, wp ) )
- ENDDO
- ENDDO
+ ! define unique value on each point of the inner global domain. z2d ranging from 0.05 to -0.05
+ !
+ ! WARNING: to keep compatibility with the trunk that was including periodocity into the input data,
+ ! we must define z2d as bellow.
+ ! Once we decide to forget trunk compatibility, we must simply define z2d as:
+!!$ DO_2D( 0, 0, 0, 0 )
+!!$ z2d(ji,jj) = 0.1 * ( 0.5 - REAL( mig0_oldcmp(ji) + (mjg0_oldcmp(jj)-1) * Ni0glo, wp ) / REAL( Ni0glo * Nj0glo, wp ) )
+!!$ END_2D
+ igloi = Ni0glo + 2 * COUNT( (/ jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7 /) )
+ igloj = Nj0glo + 2 * COUNT( (/ jperio == 2 .OR. jperio == 7 /) ) + 1 * COUNT( (/ jperio >= 4 .AND. jperio <= 6 /) )
+ DO_2D( 0, 0, 0, 0 )
+ z2d(ji,jj) = 0.1 * ( 0.5 - REAL( mig0_oldcmp(ji) + (mjg0_oldcmp(jj)-1) * igloi, wp ) / REAL( igloi * igloj, wp ) )
+ END_2D
!
! sea level:
pssh(:,:) = z2d(:,:) ! +/- 0.05 m
!
- DO jk = 1, jpk
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
zfact = REAL(jk-1,wp) / REAL(jpk-1,wp) ! 0 to 1 to add a basic stratification
! temperature choosen to lead to ~50% ice at the beginning if rn_thres_sst = 0.5
@@ -78,7 +88,10 @@
pts(:,:,jk,jp_sal) = 30._wp + 1._wp * zfact + z2d(:,:) ! 30 to 31 +/- 0.05 psu
! velocities:
- pu(:,:,jk) = z2d(:,:) * 0.1_wp ! +/- 0.005 m/s
- pv(:,:,jk) = z2d(:,:) * 0.01_wp ! +/- 0.0005 m/s
- ENDDO
+ pu(:,:,jk) = z2d(:,:) * 0.1_wp * umask(:,:,jk) ! +/- 0.005 m/s
+ pv(:,:,jk) = z2d(:,:) * 0.01_wp * vmask(:,:,jk) ! +/- 0.0005 m/s
+ END_3D
+ pts(:,:,jpk,:) = 0._wp
+ pu( :,:,jpk ) = 0._wp
+ pv( :,:,jpk ) = 0._wp
!
CALL lbc_lnk('usrdef_istate', pssh, 'T', 1. ) ! apply boundary conditions
Index: /NEMO/branches/2020/r12377_ticket2386/tests/BENCH/MY_SRC/usrdef_nam.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/BENCH/MY_SRC/usrdef_nam.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/BENCH/MY_SRC/usrdef_nam.F90 (revision 13540)
@@ -55,8 +55,8 @@
! !!* nammpp namelist *!!
INTEGER :: jpni, jpnj
- LOGICAL :: ln_nnogather
+ LOGICAL :: ln_nnogather, ln_listonly
!!
NAMELIST/namusr_def/ nn_isize, nn_jsize, nn_ksize, nn_perio
- NAMELIST/nammpp/ jpni, jpnj, ln_nnogather
+ NAMELIST/nammpp/ jpni, jpnj, nn_hls, ln_nnogather, ln_listonly
!!----------------------------------------------------------------------
!
@@ -77,6 +77,6 @@
902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nammpp in configuration namelist' )
- kpi = ( -nn_isize - 2*nn_hls ) * jpni + 2*nn_hls
- kpj = ( -nn_jsize - 2*nn_hls ) * jpnj + 2*nn_hls
+ kpi = -nn_isize * jpni
+ kpj = -nn_jsize * jpnj
ELSE
kpi = nn_isize
Index: /NEMO/branches/2020/r12377_ticket2386/tests/BENCH/MY_SRC/usrdef_sbc.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/BENCH/MY_SRC/usrdef_sbc.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/BENCH/MY_SRC/usrdef_sbc.F90 (revision 13540)
@@ -34,4 +34,6 @@
PUBLIC usrdef_sbc_ice_flx ! routine called by sbcice_lim.F90 for ice thermo
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OPA 4.0 , NEMO Consortium (2016)
@@ -97,4 +99,5 @@
REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace
INTEGER :: ji, jj
+ INTEGER :: igloi, igloj ! to be removed in the future, see comment bellow
!!---------------------------------------------------------------------
#if defined key_si3
@@ -102,11 +105,18 @@
!
! define unique value on each point. z2d ranging from 0.05 to -0.05
- DO jj = 1, jpj
- DO ji = 1, jpi
- z2d(ji,jj) = 0.1 * ( 0.5 - REAL( nimpp + ji - 1 + ( njmpp + jj - 2 ) * jpiglo, wp ) / REAL( jpiglo * jpjglo, wp ) )
- ENDDO
- ENDDO
- utau_ice(:,:) = 0.1_wp + z2d(:,:)
- vtau_ice(:,:) = 0.1_wp + z2d(:,:)
+ !
+ ! WARNING: to keep compatibility with the trunk that was including periodocity into the input data,
+ ! we must define z2d as bellow.
+ ! Once we decide to forget trunk compatibility, we must simply define z2d as:
+!!$ DO_2D( 0, 0, 0, 0 )
+!!$ z2d(ji,jj) = 0.1 * ( 0.5 - REAL( mig0_oldcmp(ji) + (mjg0_oldcmp(jj)-1) * Ni0glo, wp ) / REAL( Ni0glo * Nj0glo, wp ) )
+!!$ END_2D
+ igloi = Ni0glo + 2 * COUNT( (/ jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7 /) )
+ igloj = Nj0glo + 2 * COUNT( (/ jperio == 2 .OR. jperio == 7 /) ) + 1 * COUNT( (/ jperio >= 4 .AND. jperio <= 6 /) )
+ DO_2D( 0, 0, 0, 0 )
+ z2d(ji,jj) = 0.1 * ( 0.5 - REAL( mig0_oldcmp(ji) + (mjg0_oldcmp(jj)-1) * igloi, wp ) / REAL( igloi * igloj, wp ) )
+ END_2D
+ utau_ice(:,:) = 0.1_wp + z2d(:,:)
+ vtau_ice(:,:) = 0.1_wp + z2d(:,:)
CALL lbc_lnk_multi( 'usrdef_sbc', utau_ice, 'U', -1., vtau_ice, 'V', -1. )
@@ -127,5 +137,4 @@
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
!!---------------------------------------------------------------------
@@ -162,15 +171,7 @@
qsr_tot (:,:) = at_i_b(:,:) * qsr_oce(:,:) + SUM( a_i_b(:,:,:) * qsr_ice(:,:,:), dim=3 )
- ! --- shortwave radiation transmitted below the surface (W/m2, see Grenfell Maykut 77) --- !
- zfr1 = ( 0.18 * ( 1.0 - cldf_ice ) + 0.35 * cldf_ice ) ! transmission when hi>10cm
- zfr2 = ( 0.82 * ( 1.0 - cldf_ice ) + 0.65 * cldf_ice ) ! 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
- qtr_ice_top(:,:,:) = qsr_ice(:,:,:) * zfr1
- ELSEWHERE ! zero when hs>0
- qtr_ice_top(:,:,:) = 0._wp
- END WHERE
+ ! --- shortwave radiation transmitted thru the surface scattering layer (W/m2) --- !
+ qtr_ice_top(:,:,:) = 0._wp
+
#endif
Index: /NEMO/branches/2020/r12377_ticket2386/tests/BENCH/MY_SRC/usrdef_zgr.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/BENCH/MY_SRC/usrdef_zgr.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/BENCH/MY_SRC/usrdef_zgr.F90 (revision 13540)
@@ -192,8 +192,21 @@
z2d(:,:) = REAL( jpkm1 , wp ) ! flat bottom
!
- IF( jperio == 3 .OR. jperio ==4 ) THEN ! add a small island in the upper corners to avoid model instabilities...
- z2d(mi0( 1):mi1( 3),mj0(jpjglo-2):mj1(jpjglo)) = 0.
- z2d(mi0(jpiglo-2):mi1(jpiglo),mj0(jpjglo-2):mj1(jpjglo)) = 0.
- ENDIF
+ !
+ ! BENCH should work without these 2 small islands on the 2 poles of the folding...
+ ! -> Comment out these lines if instabilities are too large...
+ !
+
+!!$ IF( jperio == 3 .OR. jperio == 4 ) 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.
+!!$ z2d(mi0(jpiglo-nn_hls):mi1(MIN(jpiglo,jpiglo-nn_hls+2)),mj0(jpjglo-nn_hls-1):mj1(jpjglo-nn_hls+1)) = 0.
+!!$ z2d(mi0(jpiglo/2 ):mi1( jpiglo/2 +2 ),mj0(jpjglo-nn_hls-1):mj1(jpjglo-nn_hls+1)) = 0.
+!!$ ENDIF
+!!$ !
+!!$ IF( jperio == 5 .OR. jperio == 6 ) THEN ! add a small island in the upper corners to avoid model instabilities...
+!!$ z2d(mi0( nn_hls):mi1( nn_hls+1),mj0(jpjglo-nn_hls):mj1(jpjglo-nn_hls+1)) = 0.
+!!$ z2d(mi0(jpiglo-nn_hls):mi1(jpiglo-nn_hls+1),mj0(jpjglo-nn_hls):mj1(jpjglo-nn_hls+1)) = 0.
+!!$ z2d(mi0(jpiglo/2 ):mi1(jpiglo/2 +1),mj0(jpjglo-nn_hls):mj1(jpjglo-nn_hls+1)) = 0.
+!!$ ENDIF
+
!
CALL lbc_lnk( 'usrdef_zgr', z2d, 'T', 1. ) ! set surrounding land to zero (here jperio=0 ==>> closed)
Index: MO/branches/2020/r12377_ticket2386/tests/BENCH/MY_SRC/zdfiwm.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/BENCH/MY_SRC/zdfiwm.F90 (revision 13539)
+++ (revision )
@@ -1,466 +1,0 @@
-MODULE zdfiwm
- !!========================================================================
- !! *** MODULE zdfiwm ***
- !! Ocean physics: Internal gravity wave-driven vertical mixing
- !!========================================================================
- !! History : 1.0 ! 2004-04 (L. Bessieres, G. Madec) Original code
- !! - ! 2006-08 (A. Koch-Larrouy) Indonesian strait
- !! 3.3 ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase
- !! 3.6 ! 2016-03 (C. de Lavergne) New param: internal wave-driven mixing
- !! 4.0 ! 2017-04 (G. Madec) renamed module, remove the old param. and the CPP keys
- !!----------------------------------------------------------------------
-
- !!----------------------------------------------------------------------
- !! zdf_iwm : global momentum & tracer Kz with wave induced Kz
- !! zdf_iwm_init : global momentum & tracer Kz with wave induced Kz
- !!----------------------------------------------------------------------
- USE oce ! ocean dynamics and tracers variables
- USE dom_oce ! ocean space and time domain variables
- USE zdf_oce ! ocean vertical physics variables
- USE zdfddm ! ocean vertical physics: double diffusive mixing
- USE lbclnk ! ocean lateral boundary conditions (or mpp link)
- USE eosbn2 ! ocean equation of state
- USE phycst ! physical constants
- !
- USE prtctl ! Print control
- USE in_out_manager ! I/O manager
- USE iom ! 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 zdf_iwm ! called in step module
- PUBLIC zdf_iwm_init ! called in nemogcm module
-
- ! !!* Namelist namzdf_iwm : internal wave-driven mixing *
- INTEGER :: nn_zpyc ! pycnocline-intensified mixing energy proportional to N (=1) or N^2 (=2)
- LOGICAL :: ln_mevar ! variable (=T) or constant (=F) mixing efficiency
- LOGICAL :: ln_tsdiff ! account for differential T/S wave-driven mixing (=T) or not (=F)
-
- REAL(wp):: r1_6 = 1._wp / 6._wp
-
- REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ebot_iwm ! power available from high-mode wave breaking (W/m2)
- REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: epyc_iwm ! power available from low-mode, pycnocline-intensified wave breaking (W/m2)
- REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ecri_iwm ! power available from low-mode, critical slope wave breaking (W/m2)
- REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: hbot_iwm ! WKB decay scale for high-mode energy dissipation (m)
- REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: hcri_iwm ! decay scale for low-mode critical slope dissipation (m)
-
- !! * Substitutions
-# include "do_loop_substitute.h90"
- !!----------------------------------------------------------------------
- !! NEMO/OCE 4.0 , NEMO Consortium (2018)
- !! $Id: zdfiwm.F90 12377 2020-02-12 14:39:06Z acc $
- !! Software governed by the CeCILL license (see ./LICENSE)
- !!----------------------------------------------------------------------
-CONTAINS
-
- INTEGER FUNCTION zdf_iwm_alloc()
- !!----------------------------------------------------------------------
- !! *** FUNCTION zdf_iwm_alloc ***
- !!----------------------------------------------------------------------
- ALLOCATE( ebot_iwm(jpi,jpj), epyc_iwm(jpi,jpj), ecri_iwm(jpi,jpj) , &
- & hbot_iwm(jpi,jpj), hcri_iwm(jpi,jpj) , 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' )
- END FUNCTION zdf_iwm_alloc
-
-
- SUBROUTINE zdf_iwm( kt, Kmm, p_avm, p_avt, p_avs )
- !!----------------------------------------------------------------------
- !! *** ROUTINE zdf_iwm ***
- !!
- !! ** Purpose : add to the vertical mixing coefficients the effect of
- !! breaking internal waves.
- !!
- !! ** Method : - internal wave-driven vertical mixing is given by:
- !! Kz_wave = min( 100 cm2/s, f( Reb = zemx_iwm /( Nu * N^2 ) )
- !! where zemx_iwm is the 3D space distribution of the wave-breaking
- !! energy and Nu the molecular kinematic viscosity.
- !! The function f(Reb) is linear (constant mixing efficiency)
- !! if the namelist parameter ln_mevar = F and nonlinear if ln_mevar = T.
- !!
- !! - Compute zemx_iwm, the 3D power density that allows to compute
- !! Reb and therefrom the wave-induced vertical diffusivity.
- !! This is divided into three components:
- !! 1. Bottom-intensified low-mode dissipation at critical slopes
- !! zemx_iwm(z) = ( ecri_iwm / rho0 ) * EXP( -(H-z)/hcri_iwm )
- !! / ( 1. - EXP( - H/hcri_iwm ) ) * hcri_iwm
- !! where hcri_iwm is the characteristic length scale of the bottom
- !! intensification, ecri_iwm a map of available power, and H the ocean depth.
- !! 2. Pycnocline-intensified low-mode dissipation
- !! zemx_iwm(z) = ( epyc_iwm / rho0 ) * ( sqrt(rn2(z))^nn_zpyc )
- !! / SUM( sqrt(rn2(z))^nn_zpyc * e3w(z) )
- !! where epyc_iwm is a map of available power, and nn_zpyc
- !! is the chosen stratification-dependence of the internal wave
- !! energy dissipation.
- !! 3. WKB-height dependent high mode dissipation
- !! zemx_iwm(z) = ( ebot_iwm / rho0 ) * rn2(z) * EXP(-z_wkb(z)/hbot_iwm)
- !! / SUM( rn2(z) * EXP(-z_wkb(z)/hbot_iwm) * e3w(z) )
- !! where hbot_iwm is the characteristic length scale of the WKB bottom
- !! intensification, ebot_iwm is a map of available power, and z_wkb is the
- !! WKB-stretched height above bottom defined as
- !! z_wkb(z) = H * SUM( sqrt(rn2(z'>=z)) * e3w(z'>=z) )
- !! / SUM( sqrt(rn2(z')) * e3w(z') )
- !!
- !! - update the model vertical eddy viscosity and diffusivity:
- !! avt = avt + av_wave
- !! avm = avm + av_wave
- !!
- !! - if namelist parameter ln_tsdiff = T, account for differential mixing:
- !! avs = avt + av_wave * diffusivity_ratio(Reb)
- !!
- !! ** Action : - avt, avs, avm, increased by tide internal wave-driven mixing
- !!
- !! References : de Lavergne et al. 2015, JPO; 2016, in prep.
- !!----------------------------------------------------------------------
- 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 :: ji, jj, jk ! dummy loop indices
- REAL(wp) :: zztmp, ztmp1, ztmp2 ! scalar workspace
- REAL(wp), DIMENSION(jpi,jpj) :: zfact ! Used for vertical structure
- REAL(wp), DIMENSION(jpi,jpj) :: zhdep ! Ocean depth
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwkb ! WKB-stretched height above bottom
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zweight ! Weight for high mode vertical distribution
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: znu_t ! Molecular kinematic viscosity (T grid)
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: znu_w ! Molecular kinematic viscosity (W grid)
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zReb ! Turbulence intensity parameter
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zemx_iwm ! local energy density available for mixing (W/kg)
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zav_ratio ! S/T diffusivity ratio (only for ln_tsdiff=T)
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zav_wave ! Internal wave-induced diffusivity
- REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: z3d ! 3D workspace used for iom_put
- REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z2d ! 2D - - - -
- !!----------------------------------------------------------------------
- !
- ! !* Set to zero the 1st and last vertical levels of appropriate variables
- zemx_iwm (:,:,1) = 0._wp ; zemx_iwm (:,:,jpk) = 0._wp
- zav_ratio(:,:,1) = 0._wp ; zav_ratio(:,:,jpk) = 0._wp
- zav_wave (:,:,1) = 0._wp ; zav_wave (:,:,jpk) = 0._wp
- !
- ! ! ----------------------------- !
- ! ! Internal wave-driven mixing ! (compute zav_wave)
- ! ! ----------------------------- !
- !
- ! !* Critical slope mixing: distribute energy over the time-varying ocean depth,
- ! using an exponential decay from the seafloor.
- DO_2D_11_11
- zhdep(ji,jj) = gdepw_0(ji,jj,mbkt(ji,jj)+1) ! depth of the ocean
- zfact(ji,jj) = rho0 * ( 1._wp - EXP( -zhdep(ji,jj) / hcri_iwm(ji,jj) ) )
- IF( zfact(ji,jj) /= 0._wp ) zfact(ji,jj) = ecri_iwm(ji,jj) / zfact(ji,jj)
- END_2D
-!!gm gde3w ==>>> check for ssh taken into account.... seem OK gde3w_n=gdept(:,:,:,Kmm) - ssh(:,:,Kmm)
- DO_3D_11_11( 2, jpkm1 )
- IF ( zfact(ji,jj) == 0._wp .OR. wmask(ji,jj,jk) == 0._wp ) THEN ! optimization
- zemx_iwm(ji,jj,jk) = 0._wp
- ELSE
- zemx_iwm(ji,jj,jk) = zfact(ji,jj) * ( EXP( ( gde3w(ji,jj,jk ) - zhdep(ji,jj) ) / hcri_iwm(ji,jj) ) &
- & - EXP( ( gde3w(ji,jj,jk-1) - zhdep(ji,jj) ) / hcri_iwm(ji,jj) ) ) &
- & / ( gde3w(ji,jj,jk) - gde3w(ji,jj,jk-1) )
- ENDIF
- END_3D
-!!gm delta(gde3w) = e3t(:,:,:,Kmm) !! Please verify the grid-point position w versus t-point
-!!gm it seems to me that only 1/hcri_iwm is used ==> compute it one for all
-
-
- ! !* Pycnocline-intensified mixing: distribute energy over the time-varying
- ! !* ocean depth as proportional to sqrt(rn2)^nn_zpyc
- ! ! (NB: N2 is masked, so no use of wmask here)
- SELECT CASE ( nn_zpyc )
- !
- CASE ( 1 ) ! Dissipation scales as N (recommended)
- !
- zfact(:,:) = 0._wp
- DO jk = 2, jpkm1 ! part independent of the level
- zfact(:,:) = zfact(:,:) + e3w(:,:,jk,Kmm) * SQRT( MAX( 0._wp, rn2(:,:,jk) ) ) * wmask(:,:,jk)
- END DO
- !
- DO_2D_11_11
- IF( zfact(ji,jj) /= 0 ) zfact(ji,jj) = epyc_iwm(ji,jj) / ( rho0 * zfact(ji,jj) )
- END_2D
- !
- DO jk = 2, jpkm1 ! complete with the level-dependent part
- zemx_iwm(:,:,jk) = zemx_iwm(:,:,jk) + zfact(:,:) * SQRT( MAX( 0._wp, rn2(:,:,jk) ) ) * wmask(:,:,jk)
- END DO
- !
- CASE ( 2 ) ! Dissipation scales as N^2
- !
- zfact(:,:) = 0._wp
- DO jk = 2, jpkm1 ! part independent of the level
- zfact(:,:) = zfact(:,:) + e3w(:,:,jk,Kmm) * MAX( 0._wp, rn2(:,:,jk) ) * wmask(:,:,jk)
- END DO
- !
- DO_2D_11_11
- IF( zfact(ji,jj) /= 0 ) zfact(ji,jj) = epyc_iwm(ji,jj) / ( rho0 * zfact(ji,jj) )
- END_2D
- !
- DO jk = 2, jpkm1 ! complete with the level-dependent part
- zemx_iwm(:,:,jk) = zemx_iwm(:,:,jk) + zfact(:,:) * MAX( 0._wp, rn2(:,:,jk) ) * wmask(:,:,jk)
- END DO
- !
- END SELECT
-
- ! !* WKB-height dependent mixing: distribute energy over the time-varying
- ! !* ocean depth as proportional to rn2 * exp(-z_wkb/rn_hbot)
- !
- zwkb (:,:,:) = 0._wp
- zfact(:,:) = 0._wp
- DO jk = 2, jpkm1
- zfact(:,:) = zfact(:,:) + e3w(:,:,jk,Kmm) * SQRT( MAX( 0._wp, rn2(:,:,jk) ) ) * wmask(:,:,jk)
- zwkb(:,:,jk) = zfact(:,:)
- END DO
-!!gm even better:
-! DO jk = 2, jpkm1
-! zwkb(:,:) = zwkb(:,:) + e3w(:,:,jk,Kmm) * SQRT( MAX( 0._wp, rn2(:,:,jk) ) )
-! END DO
-! zfact(:,:) = zwkb(:,:,jpkm1)
-!!gm or just use zwkb(k=jpk-1) instead of zfact...
-!!gm
- !
- DO_3D_11_11( 2, jpkm1 )
- IF( zfact(ji,jj) /= 0 ) zwkb(ji,jj,jk) = zhdep(ji,jj) * ( zfact(ji,jj) - zwkb(ji,jj,jk) ) &
- & * wmask(ji,jj,jk) / zfact(ji,jj)
- END_3D
- zwkb(:,:,1) = zhdep(:,:) * wmask(:,:,1)
- !
- DO_3D_11_11( 2, jpkm1 )
- IF ( rn2(ji,jj,jk) <= 0._wp .OR. wmask(ji,jj,jk) == 0._wp ) THEN ! optimization
- zweight(ji,jj,jk) = 0._wp
- ELSE
- zweight(ji,jj,jk) = rn2(ji,jj,jk) * hbot_iwm(ji,jj) &
- & * ( EXP( -zwkb(ji,jj,jk) / hbot_iwm(ji,jj) ) - EXP( -zwkb(ji,jj,jk-1) / hbot_iwm(ji,jj) ) )
- ENDIF
- END_3D
- !
- zfact(:,:) = 0._wp
- DO jk = 2, jpkm1 ! part independent of the level
- zfact(:,:) = zfact(:,:) + zweight(:,:,jk)
- END DO
- !
- DO_2D_11_11
- IF( zfact(ji,jj) /= 0 ) zfact(ji,jj) = ebot_iwm(ji,jj) / ( rho0 * zfact(ji,jj) )
- END_2D
- !
- DO jk = 2, jpkm1 ! complete with the level-dependent part
- zemx_iwm(:,:,jk) = zemx_iwm(:,:,jk) + zweight(:,:,jk) * zfact(:,:) * wmask(:,:,jk) &
- & / ( gde3w(:,:,jk) - gde3w(:,:,jk-1) )
-!!gm use of e3t(:,:,:,Kmm) just above?
- END DO
- !
-!!gm this is to be replaced by just a constant value znu=1.e-6 m2/s
- ! Calculate molecular kinematic viscosity
- znu_t(:,:,:) = 1.e-4_wp * ( 17.91_wp - 0.53810_wp * ts(:,:,:,jp_tem,Kmm) + 0.00694_wp * ts(:,:,:,jp_tem,Kmm) * ts(:,:,:,jp_tem,Kmm) &
- & + 0.02305_wp * ts(:,:,:,jp_sal,Kmm) ) * tmask(:,:,:) * r1_rho0
- DO jk = 2, jpkm1
- znu_w(:,:,jk) = 0.5_wp * ( znu_t(:,:,jk-1) + znu_t(:,:,jk) ) * wmask(:,:,jk)
- END DO
-!!gm end
- !
- ! Calculate turbulence intensity parameter Reb
- DO jk = 2, jpkm1
- zReb(:,:,jk) = zemx_iwm(:,:,jk) / MAX( 1.e-20_wp, znu_w(:,:,jk) * rn2(:,:,jk) )
- END DO
- !
- ! Define internal wave-induced diffusivity
- DO jk = 2, jpkm1
- zav_wave(:,:,jk) = znu_w(:,:,jk) * zReb(:,:,jk) * r1_6 ! This corresponds to a constant mixing efficiency of 1/6
- END DO
- !
- IF( ln_mevar ) THEN ! Variable mixing efficiency case : modify zav_wave in the
- DO_3D_11_11( 2, jpkm1 )
- IF( zReb(ji,jj,jk) > 480.00_wp ) THEN
- zav_wave(ji,jj,jk) = 3.6515_wp * znu_w(ji,jj,jk) * SQRT( zReb(ji,jj,jk) )
- ELSEIF( zReb(ji,jj,jk) < 10.224_wp ) THEN
- zav_wave(ji,jj,jk) = 0.052125_wp * znu_w(ji,jj,jk) * zReb(ji,jj,jk) * SQRT( zReb(ji,jj,jk) )
- ENDIF
- END_3D
- ENDIF
- !
- DO jk = 2, jpkm1 ! Bound diffusivity by molecular value and 100 cm2/s
- zav_wave(:,:,jk) = MIN( MAX( 1.4e-7_wp, zav_wave(:,:,jk) ), 1.e-2_wp ) * wmask(:,:,jk)
- END DO
- !
- IF( kt == nit000 ) THEN !* Control print at first time-step: diagnose the energy consumed by zav_wave
- zztmp = 0._wp
-!!gm used of glosum 3D....
- DO_3D_11_11( 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)
- END_3D
- CALL mpp_sum( 'zdfiwm', zztmp )
- zztmp = rho0 * zztmp ! Global integral of rauo * Kz * N^2 = power contributing to mixing
- !
- IF(lwp) THEN
- WRITE(numout,*)
- WRITE(numout,*) 'zdf_iwm : Internal wave-driven mixing (iwm)'
- WRITE(numout,*) '~~~~~~~ '
- WRITE(numout,*)
- WRITE(numout,*) ' Total power consumption by av_wave = ', zztmp * 1.e-12_wp, 'TW'
- ENDIF
- ENDIF
-
- ! ! ----------------------- !
- ! ! Update mixing coefs !
- ! ! ----------------------- !
- !
- IF( ln_tsdiff ) THEN !* Option for differential mixing of salinity and temperature
- ztmp1 = 0.505_wp + 0.495_wp * TANH( 0.92_wp * ( LOG10( 1.e-20_wp ) - 0.60_wp ) )
- DO_3D_11_11( 2, jpkm1 )
- ztmp2 = zReb(ji,jj,jk) * 5._wp * r1_6
- IF ( ztmp2 > 1.e-20_wp .AND. wmask(ji,jj,jk) == 1._wp ) THEN
- zav_ratio(ji,jj,jk) = 0.505_wp + 0.495_wp * TANH( 0.92_wp * ( LOG10(ztmp2) - 0.60_wp ) )
- ELSE
- zav_ratio(ji,jj,jk) = ztmp1 * wmask(ji,jj,jk)
- ENDIF
- END_3D
- CALL iom_put( "av_ratio", zav_ratio )
- DO jk = 2, jpkm1 !* update momentum & tracer diffusivity with wave-driven mixing
- p_avs(:,:,jk) = p_avs(:,:,jk) + zav_wave(:,:,jk) * zav_ratio(:,:,jk)
- p_avt(:,:,jk) = p_avt(:,:,jk) + zav_wave(:,:,jk)
- p_avm(:,:,jk) = p_avm(:,:,jk) + zav_wave(:,:,jk)
- END DO
- !
- ELSE !* update momentum & tracer diffusivity with wave-driven mixing
- DO jk = 2, jpkm1
- p_avs(:,:,jk) = p_avs(:,:,jk) + zav_wave(:,:,jk)
- p_avt(:,:,jk) = p_avt(:,:,jk) + zav_wave(:,:,jk)
- p_avm(:,:,jk) = p_avm(:,:,jk) + zav_wave(:,:,jk)
- END DO
- ENDIF
-
- ! !* output internal wave-driven mixing coefficient
- CALL iom_put( "av_wave", zav_wave )
- !* output useful diagnostics: Kz*N^2 ,
-!!gm Kz*N2 should take into account the ratio avs/avt if it is used.... (see diaar5)
- ! vertical integral of rho0 * Kz * N^2 , energy density (zemx_iwm)
- IF( iom_use("bflx_iwm") .OR. iom_use("pcmap_iwm") ) THEN
- ALLOCATE( z2d(jpi,jpj) , z3d(jpi,jpj,jpk) )
- z3d(:,:,:) = MAX( 0._wp, rn2(:,:,:) ) * zav_wave(:,:,:)
- z2d(:,:) = 0._wp
- DO jk = 2, jpkm1
- z2d(:,:) = z2d(:,:) + e3w(:,:,jk,Kmm) * z3d(:,:,jk) * wmask(:,:,jk)
- END DO
- z2d(:,:) = rho0 * z2d(:,:)
- CALL iom_put( "bflx_iwm", z3d )
- CALL iom_put( "pcmap_iwm", z2d )
- DEALLOCATE( z2d , z3d )
- ENDIF
- CALL iom_put( "emix_iwm", zemx_iwm )
-
- IF(sn_cfctl%l_prtctl) CALL prt_ctl(tab3d_1=zav_wave , clinfo1=' iwm - av_wave: ', tab3d_2=avt, clinfo2=' avt: ', kdim=jpk)
- !
- END SUBROUTINE zdf_iwm
-
-
- SUBROUTINE zdf_iwm_init
- !!----------------------------------------------------------------------
- !! *** ROUTINE zdf_iwm_init ***
- !!
- !! ** Purpose : Initialization of the wave-driven vertical mixing, reading
- !! of input power maps and decay length scales in netcdf files.
- !!
- !! ** Method : - Read the namzdf_iwm namelist and check the parameters
- !!
- !! - Read the input data in NetCDF files :
- !! power available from high-mode wave breaking (mixing_power_bot.nc)
- !! power available from pycnocline-intensified wave-breaking (mixing_power_pyc.nc)
- !! power available from critical slope wave-breaking (mixing_power_cri.nc)
- !! WKB decay scale for high-mode wave-breaking (decay_scale_bot.nc)
- !! decay scale for critical slope wave-breaking (decay_scale_cri.nc)
- !!
- !! ** input : - Namlist namzdf_iwm
- !! - NetCDF files : mixing_power_bot.nc, mixing_power_pyc.nc, mixing_power_cri.nc,
- !! decay_scale_bot.nc decay_scale_cri.nc
- !!
- !! ** Action : - Increase by 1 the nstop flag is setting problem encounter
- !! - Define ebot_iwm, epyc_iwm, ecri_iwm, hbot_iwm, hcri_iwm
- !!
- !! References : de Lavergne et al. JPO, 2015 ; de Lavergne PhD 2016
- !! de Lavergne et al. in prep., 2017
- !!----------------------------------------------------------------------
- INTEGER :: inum ! local integer
- INTEGER :: ios
- REAL(wp) :: zbot, zpyc, zcri ! local scalars
- !!
- NAMELIST/namzdf_iwm/ nn_zpyc, ln_mevar, ln_tsdiff
- !!----------------------------------------------------------------------
- !
- READ ( numnam_ref, namzdf_iwm, IOSTAT = ios, ERR = 901)
-901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_iwm in reference namelist' )
- !
- READ ( numnam_cfg, namzdf_iwm, IOSTAT = ios, ERR = 902 )
-902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namzdf_iwm in configuration namelist' )
- IF(lwm) WRITE ( numond, namzdf_iwm )
- !
- IF(lwp) THEN ! Control print
- WRITE(numout,*)
- WRITE(numout,*) 'zdf_iwm_init : internal wave-driven mixing'
- WRITE(numout,*) '~~~~~~~~~~~~'
- WRITE(numout,*) ' Namelist namzdf_iwm : set wave-driven mixing parameters'
- WRITE(numout,*) ' Pycnocline-intensified diss. scales as N (=1) or N^2 (=2) = ', nn_zpyc
- WRITE(numout,*) ' Variable (T) or constant (F) mixing efficiency = ', ln_mevar
- WRITE(numout,*) ' Differential internal wave-driven mixing (T) or not (F) = ', ln_tsdiff
- ENDIF
-
- ! The new 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(:) = 1.4e-6_wp ! viscous molecular value
- avtb(:) = 1.e-10_wp ! very small diffusive minimum (background avt is specified in zdf_iwm)
- avtb_2d(:,:) = 1.e0_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.'
- ENDIF
-
- ! ! allocate iwm arrays
- IF( zdf_iwm_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'zdf_iwm_init : unable to allocate iwm arrays' )
- !
- ! ! read necessary fields
-!!$ CALL iom_open('mixing_power_bot',inum) ! energy flux for high-mode wave breaking [W/m2]
-!!$ CALL iom_get (inum, jpdom_data, 'field', ebot_iwm, 1 )
-!!$ CALL iom_close(inum)
- ebot_iwm(:,:) = 1.e-6
- !
-!!$ CALL iom_open('mixing_power_pyc',inum) ! energy flux for pynocline-intensified wave breaking [W/m2]
-!!$ CALL iom_get (inum, jpdom_data, 'field', epyc_iwm, 1 )
-!!$ CALL iom_close(inum)
- epyc_iwm(:,:) = 1.e-6
- !
-!!$ CALL iom_open('mixing_power_cri',inum) ! energy flux for critical slope wave breaking [W/m2]
-!!$ CALL iom_get (inum, jpdom_data, 'field', ecri_iwm, 1 )
-!!$ CALL iom_close(inum)
- ecri_iwm(:,:) = 1.e-10
- !
-!!$ CALL iom_open('decay_scale_bot',inum) ! spatially variable decay scale for high-mode wave breaking [m]
-!!$ CALL iom_get (inum, jpdom_data, 'field', hbot_iwm, 1 )
-!!$ CALL iom_close(inum)
- hbot_iwm(:,:) = 100.
- !
-!!$ CALL iom_open('decay_scale_cri',inum) ! spatially variable decay scale for critical slope wave breaking [m]
-!!$ CALL iom_get (inum, jpdom_data, 'field', hcri_iwm, 1 )
-!!$ CALL iom_close(inum)
- hcri_iwm(:,:) = 100.
-
- ebot_iwm(:,:) = ebot_iwm(:,:) * ssmask(:,:)
- epyc_iwm(:,:) = epyc_iwm(:,:) * ssmask(:,:)
- ecri_iwm(:,:) = ecri_iwm(:,:) * ssmask(:,:)
-
- zbot = glob_sum( 'zdfiwm', e1e2t(:,:) * ebot_iwm(:,:) )
- zpyc = glob_sum( 'zdfiwm', e1e2t(:,:) * epyc_iwm(:,:) )
- zcri = glob_sum( 'zdfiwm', e1e2t(:,:) * ecri_iwm(:,:) )
- IF(lwp) THEN
- WRITE(numout,*) ' High-mode wave-breaking energy: ', zbot * 1.e-12_wp, 'TW'
- WRITE(numout,*) ' Pycnocline-intensifed wave-breaking energy: ', zpyc * 1.e-12_wp, 'TW'
- WRITE(numout,*) ' Critical slope wave-breaking energy: ', zcri * 1.e-12_wp, 'TW'
- ENDIF
- !
- END SUBROUTINE zdf_iwm_init
-
- !!======================================================================
-END MODULE zdfiwm
Index: /NEMO/branches/2020/r12377_ticket2386/tests/CANAL/EXPREF/context_nemo.xml
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/CANAL/EXPREF/context_nemo.xml (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/CANAL/EXPREF/context_nemo.xml (revision 13540)
@@ -11,5 +11,5 @@
01
01
- 1026.0
+ 1026.0
3991.86795711963
0.99530670233846
Index: /NEMO/branches/2020/r12377_ticket2386/tests/CANAL/EXPREF/field_def_nemo-oce.xml
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/CANAL/EXPREF/field_def_nemo-oce.xml (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/CANAL/EXPREF/field_def_nemo-oce.xml (revision 13540)
@@ -1,1132 +1,1 @@
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
- this
- this
- this
- this
- this
- this
- this
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
- toce * e3t
-
- soce * e3t
-
-
-
- toce_e3t_vsum300/e3t_vsum300
-
-
-
-
-
-
-
-
-
-
- sst * sst
-
-
-
-
-
-
-
-
-
-
-
- sss * sss
-
-
-
-
-
-
-
-
-
-
-
-
-
-
- ssh * ssh
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
- topthdep - pycndep
-
-
-
-
-
-
-
-
-
-
-
-
- sshdyn * sshdyn
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
- sqrt( uz1_abl^2 + vz1_abl^2 )
-
-
-
-
- sqrt( uz1_dta^2 + vz1_dta^2 )
-
-
-
-
-
- sqrt( uz1_geo^2 + vz1_geo^2 )
-
-
-
-
-
-
-
-
-
-
-
-
-
- uoce * e3u
-
- this * uoce_e3u_vsum
-
- @uocetr_vsum
-
- uocetr_vsum_cumul * $rau0
-
-
-
-
-
-
-
-
- utau * ssu
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
- ustokes * e3u
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
- voce * e3v
-
-
-
-
-
-
- vtau * ssv
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
- vstokes * e3v
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
- woce * e3w
-
-
-
-
-
-
-
-
-
- avt * e3w
-
-
- avm * e3w
-
-
-
- avs * e3w
-
-
-
-
- avt_evd * e3w
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
- @uoce_e3u
-
- this * e2u
-
- this * maskMFO_u * $rau0
-
- @voce_e3v
-
- this * e1v
-
- this * maskMFO_v * $rau0
-
- u_masstr_strait + v_masstr_strait
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
- sophtvtr - sophtove
- sophtvtr - sopstove
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
- ttrd_atf * e3t
- strd_atf * e3t
-
- ttrd_atf_e3t * 1026.0 * 3991.86795711963
- strd_atf_e3t * 1026.0 * 0.001
-
-
-
-
-
-
-
-
-
-
- sqrt( ttrd_xad^2 + ttrd_yad^2 + ttrd_zad^2 )
- sqrt( strd_xad^2 + strd_yad^2 + strd_zad^2 )
-
-
-
-
-
-
-
-
-
-
-
-
- ttrd_ldf + ttrd_zdf - ttrd_zdfp
- strd_ldf + strd_zdf - strd_zdfp
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
- ttrd_xad * e3t
- strd_xad * e3t
- ttrd_yad * e3t
- strd_yad * e3t
- ttrd_zad * e3t
- strd_zad * e3t
- ttrd_ad * e3t
- strd_ad * e3t
- ttrd_totad * e3t
- strd_totad * e3t
- ttrd_ldf * e3t
- strd_ldf * e3t
- ttrd_zdf * e3t
- strd_zdf * e3t
- ttrd_evd * e3t
- strd_evd * e3t
-
-
- ttrd_iso * e3t
- strd_iso * e3t
- ttrd_zdfp * e3t
- strd_zdfp * e3t
-
-
- ttrd_dmp * e3t
- strd_dmp * e3t
- ttrd_bbl * e3t
- strd_bbl * e3t
- ttrd_npc * e3t
- strd_npc * e3t
- ttrd_qns * e3ts
- strd_cdt * e3ts
- ttrd_qsr * e3t
- ttrd_bbc * e3t
-
-
- ttrd_totad_e3t * 1026.0 * 3991.86795711963
- strd_totad_e3t * 1026.0 * 0.001
- ttrd_evd_e3t * 1026.0 * 3991.86795711963
- strd_evd_e3t * 1026.0 * 0.001
- ttrd_iso_e3t * 1026.0 * 3991.86795711963
- strd_iso_e3t * 1026.0 * 0.001
- ttrd_zdfp_e3t * 1026.0 * 3991.86795711963
- strd_zdfp_e3t * 1026.0 * 0.001
- ttrd_qns_e3t * 1026.0 * 3991.86795711963
- ttrd_qsr_e3t * 1026.0 * 3991.86795711963
- ttrd_bbl_e3t * 1026.0 * 3991.86795711963
- strd_bbl_e3t * 1026.0 * 0.001
- ttrd_evd_e3t * 1026.0 * 3991.86795711963
- strd_evd_e3t * 1026.0 * 0.001
-
-
-
-
-
-
-
-
- ttrd_tot * e3t
- strd_tot * e3t
-
- ttrd_tot_e3t * 1026.0 * 3991.86795711963
- strd_tot_e3t * 1026.0 * 0.001
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+link ../../../cfgs/SHARED/field_def_nemo-oce.xml
Index: /NEMO/branches/2020/r12377_ticket2386/tests/CANAL/EXPREF/file_def_nemo-oce.xml
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/CANAL/EXPREF/file_def_nemo-oce.xml (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/CANAL/EXPREF/file_def_nemo-oce.xml (revision 13540)
@@ -15,6 +15,6 @@
-
-
+
+
Index: /NEMO/branches/2020/r12377_ticket2386/tests/CANAL/EXPREF/namelist_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/CANAL/EXPREF/namelist_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/CANAL/EXPREF/namelist_cfg (revision 13540)
@@ -20,10 +20,10 @@
&namusr_def ! User defined : CANAL configuration: Flat bottom, beta-plane
!-----------------------------------------------------------------------
- rn_domszx = 3600. ! x horizontal size [km]
- rn_domszy = 1800. ! y horizontal size [km]
- rn_domszz = 5000. ! z vertical size [m]
- rn_dx = 30. ! x horizontal resolution [km]
- rn_dy = 30. ! y horizontal resolution [km]
- rn_dz = 500. ! z vertical resolution [m]
+ rn_domszx = 2000. ! x horizontal size [km]
+ rn_domszy = 1000. ! y horizontal size [km]
+ rn_domszz = 1000. ! z vertical size [m]
+ rn_dx = 10. ! x horizontal resolution [km]
+ rn_dy = 10. ! y horizontal resolution [km]
+ rn_dz = 1000. ! z vertical resolution [m]
rn_0xratio = 0.5 ! x-domain ratio of the 0
rn_0yratio = 0.5 ! y-domain ratio of the 0
@@ -31,16 +31,23 @@
rn_ppgphi0 = 38.5 ! Reference latitude [degrees]
rn_u10 = 0. ! 10m wind speed [m/s]
- rn_windszx = 4000. ! longitudinal wind extension [km]
- rn_windszy = 4000. ! latitudinal wind extension [km]
- rn_uofac = 0. ! Uoce multiplicative factor (0.:absolute or 1.:relative winds)
+ rn_windszx = 90. ! longitudinal wind extension [km]
+ rn_windszy = 90. ! latitudinal wind extension [km]
+!!clem rn_uofac = 0. ! Uoce multiplicative factor (0.:absolute or 1.:relative winds)
rn_vtxmax = 1. ! initial vortex max current [m/s]
rn_uzonal = 1. ! initial zonal current [m/s]
- rn_ujetszx = 4000. ! longitudinal jet extension [km]
- rn_ujetszy = 4000. ! latitudinal jet extension [km]
+ rn_ujetszx = 4000. ! longitudinal jet extension [km]
+ rn_ujetszy = 400. ! latitudinal jet extension [km]
nn_botcase = 0 ! bottom definition (0:flat, 1:bump)
- nn_initcase = 1 ! initial condition case (0:rest, 1:zonal current, 2:current shear, 3: gaussian zonal current,
- ! ! 4: geostrophic zonal pulse, 5: vortex)
- ln_sshnoise = .false. ! add random noise on initial ssh
- rn_lambda = 50. ! gaussian lambda
+ nn_initcase = 1 ! initial condition case
+ ! ! -1 : stratif at rest
+ ! ! 0 : rest
+ ! ! 1 : zonal current
+ ! ! 2 : current shear
+ ! ! 3 : gaussian zonal current
+ ! ! 4 : geostrophic zonal pulse
+ ! ! 5 : baroclinic vortex
+ ln_sshnoise = .FALSE. ! add random noise on initial ssh
+ rn_lambda = 50. ! gaussian lambda
+ nn_perio = 1
/
!-----------------------------------------------------------------------
@@ -59,6 +66,12 @@
!-----------------------------------------------------------------------
ln_linssh = .false. ! =T linear free surface ==>> model level are fixed in time
- rn_Dt = 1440. ! time step for the dynamics (and tracer if nn_acc=0)
- rn_atfp = 0.05 ! asselin time filter parameter
+ rn_Dt = 1200. ! time step for the dynamics (and tracer if nn_acc=0)
+ rn_atfp = 0.0 ! asselin time filter parameter
+/
+!-----------------------------------------------------------------------
+&namcfg ! parameters of the configuration (default: use namusr_def in namelist_cfg)
+!-----------------------------------------------------------------------
+ ln_write_cfg = .false. ! (=T) create the domain configuration file
+ cn_domcfg_out = "domain_cfg" ! newly created domain configuration filename
/
!!======================================================================
@@ -108,6 +121,6 @@
!! !!
!! namdrg top/bottom drag coefficient (default: NO selection)
-!! namdrg_top top friction (ln_OFF =F & ln_isfcav=T)
-!! namdrg_bot bottom friction (ln_OFF =F)
+!! 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)
@@ -117,5 +130,5 @@
&namdrg ! top/bottom drag coefficient (default: NO selection)
!-----------------------------------------------------------------------
- ln_OFF = .true. ! free-slip : Cd = 0
+ ln_drg_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot
/
!!======================================================================
@@ -134,5 +147,5 @@
!-----------------------------------------------------------------------
ln_seos = .true. ! = Use simplified equation of state (S-EOS)
- ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
+ ! ! rd(T,S,Z)*rho0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
rn_a0 = 0.28 ! thermal expension coefficient (for simplified equation of state)
rn_b0 = 0. ! saline expension coefficient (for simplified equation of state)
@@ -148,8 +161,8 @@
ln_traadv_OFF = .false. ! No tracer advection
ln_traadv_cen = .false. ! 2nd order centered scheme
- nn_cen_h = 4 ! =2/4, horizontal 2nd order CEN / 4th order CEN
- nn_cen_v = 4 ! =2/4, vertical 2nd order CEN / 4th order COMPACT
+ nn_cen_h = 2 ! =2/4, horizontal 2nd order CEN / 4th order CEN
+ nn_cen_v = 2 ! =2/4, vertical 2nd order CEN / 4th order COMPACT
ln_traadv_fct = .false. ! FCT scheme
- nn_fct_h = 2 ! =2/4, horizontal 2nd / 4th order
+ nn_fct_h = 4 ! =2/4, horizontal 2nd / 4th order
nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order
ln_traadv_mus = .false. ! MUSCL scheme
@@ -162,5 +175,35 @@
&namtra_ldf ! lateral diffusion scheme for tracers (default: NO selection)
!-----------------------------------------------------------------------
- ln_traldf_OFF = .true. ! No explicit diffusion
+ ! ! Operator type:
+ ln_traldf_OFF = .true. ! No explicit diffusion
+ ln_traldf_lap = .false. ! laplacian operator
+ ln_traldf_blp = .false. ! bilaplacian operator
+ !
+ ! ! Direction of action:
+ ln_traldf_lev = .false. ! iso-level
+ ln_traldf_hor = .true. ! horizontal (geopotential)
+ ln_traldf_iso = .false. ! iso-neutral (standard operator)
+ ln_traldf_triad = .false. ! iso-neutral (triad operator)
+ !
+ ! ! iso-neutral options:
+ ln_traldf_msc = .false. ! Method of Stabilizing Correction (both operators)
+ rn_slpmax = 0.01 ! slope limit (both operators)
+ ln_triad_iso = .false. ! pure horizontal mixing in ML (triad only)
+ rn_sw_triad = 1 ! =1 switching triad ; =0 all 4 triads used (triad only)
+ ln_botmix_triad = .false. ! lateral mixing on bottom (triad only)
+ !
+ ! ! Coefficients:
+ nn_aht_ijk_t = 31 ! space/time variation of eddy coefficient:
+ ! ! =-20 (=-30) read in eddy_diffusivity_2D.nc (..._3D.nc) file
+ ! ! = 0 constant
+ ! ! = 10 F(k) =ldf_c1d
+ ! ! = 20 F(i,j) =ldf_c2d
+ ! ! = 21 F(i,j,t) =Treguier et al. JPO 1997 formulation
+ ! ! = 30 F(i,j,k) =ldf_c2d * ldf_c1d
+ ! ! = 31 F(i,j,k,t)=F(local velocity and grid-spacing)
+ ! ! time invariant coefficients: aht0 = 1/2 Ud*Ld (lap case)
+ ! ! or = 1/12 Ud*Ld^3 (blp case)
+ rn_Ud = 0.01 ! lateral diffusive velocity [m/s] (nn_aht_ijk_t= 0, 10, 20, 30)
+ rn_Ld = 200.e+3 ! lateral diffusive length [m] (nn_aht_ijk_t= 0, 10)
/
!!======================================================================
@@ -183,13 +226,15 @@
nn_dynkeg = 0 ! scheme for grad(KE): =0 C2 ; =1 Hollingsworth correction
ln_dynadv_cen2 = .false. ! flux form - 2nd order centered scheme
- ln_dynadv_ubs = .true. ! flux form - 3rd order UBS scheme
+ ln_dynadv_ubs = .true. ! flux form - 3rd order UBS scheme
/
!-----------------------------------------------------------------------
&namdyn_vor ! Vorticity / Coriolis scheme (default: NO selection)
!-----------------------------------------------------------------------
- ln_dynvor_ene = .true. ! energy conserving scheme
- ln_dynvor_ens = .false. ! enstrophy conserving scheme
- ln_dynvor_mix = .false. ! mixed scheme
+ ln_dynvor_ene = .false. ! energy conserving scheme
+ ln_dynvor_ens = .false. ! enstrophy conserving scheme
+ ln_dynvor_mix = .false. ! mixed scheme
ln_dynvor_een = .false. ! energy & enstrophy scheme
+ ln_dynvor_enT = .false. ! energy conserving scheme (T-point)
+ ln_dynvor_eeT = .true. ! energy conserving scheme (een using e3t)
nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1)
/
@@ -210,5 +255,5 @@
! ! = 1 Boxcar over nn_e sub-steps
! ! = 2 Boxcar over 2*nn_e " "
- ln_bt_auto = .false. ! Number of sub-step defined from:
+ ln_bt_auto = .true. ! Number of sub-step defined from:
nn_e = 24 ! =F : the number of sub-step in rn_Dt seconds
/
@@ -222,8 +267,8 @@
! ! Direction of action :
ln_dynldf_lev = .false. ! iso-level
- ln_dynldf_hor = .true. ! horizontal (geopotential)
+ ln_dynldf_hor = .false. ! horizontal (geopotential)
ln_dynldf_iso = .false. ! iso-neutral
! ! Coefficient
- nn_ahm_ijk_t = 20 ! space/time variation of eddy coef
+ nn_ahm_ijk_t = 31 ! space/time variation of eddy coef
! ! =-30 read in eddy_viscosity_3D.nc file
! ! =-20 read in eddy_viscosity_2D.nc file
@@ -275,6 +320,17 @@
!! namdiu Cool skin and warm layer models (default: OFF)
!! namdiu Cool skin and warm layer models (default: OFF)
+<<<<<<< .working
!! namflo float parameters (default: OFF)
!! nam_diadct transports through some sections (default: OFF)
+||||||| .merge-left.r13465
+!! namflo float parameters (default: OFF)
+!! nam_diaharm Harmonic analysis of tidal constituents (default: OFF)
+!! nam_diadct transports through some sections (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)
+>>>>>>> .merge-right.r13470
!! nam_dia25h 25h Mean Output (default: OFF)
!! namnc4 netcdf4 chunking and compression settings ("key_netcdf4")
@@ -285,5 +341,5 @@
!-----------------------------------------------------------------------
ln_glo_trd = .false. ! (T) global domain averaged diag for T, T^2, KE, and PE
- ln_dyn_trd = .true. ! (T) 3D momentum trend output
+ ln_dyn_trd = .true. ! (T) 3D momentum trend output
ln_dyn_mxl = .false. ! (T) 2D momentum trends averaged over the mixed layer (not coded yet)
ln_vor_trd = .false. ! (T) 2D barotropic vorticity trends (not coded yet)
@@ -312,8 +368,12 @@
&nammpp ! Massively Parallel Processing ("key_mpp_mpi")
!-----------------------------------------------------------------------
+!! jpni = 8 ! jpni number of processors following i (set automatically if < 1)
+!! jpnj = 1 ! jpnj number of processors following j (set automatically if < 1)
/
!-----------------------------------------------------------------------
&namctl ! Control prints (default: OFF)
!-----------------------------------------------------------------------
+ ln_timing = .true. ! timing by routine write out in timing.output file
+!! ln_diacfl = .true. ! CFL diagnostics write out in cfl_diagnostics.ascii
/
!-----------------------------------------------------------------------
Index: MO/branches/2020/r12377_ticket2386/tests/CANAL/MY_SRC/diawri.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/CANAL/MY_SRC/diawri.F90 (revision 13539)
+++ (revision )
@@ -1,1031 +1,0 @@
-MODULE diawri
- !!======================================================================
- !! *** MODULE diawri ***
- !! Ocean diagnostics : write ocean output files
- !!=====================================================================
- !! History : OPA ! 1991-03 (M.-A. Foujols) Original code
- !! 4.0 ! 1991-11 (G. Madec)
- !! ! 1992-06 (M. Imbard) correction restart file
- !! ! 1992-07 (M. Imbard) split into diawri and rstwri
- !! ! 1993-03 (M. Imbard) suppress writibm
- !! ! 1998-01 (C. Levy) NETCDF format using ioipsl INTERFACE
- !! ! 1999-02 (E. Guilyardi) name of netCDF files + variables
- !! 8.2 ! 2000-06 (M. Imbard) Original code (diabort.F)
- !! NEMO 1.0 ! 2002-06 (A.Bozec, E. Durand) Original code (diainit.F)
- !! - ! 2002-09 (G. Madec) F90: Free form and module
- !! - ! 2002-12 (G. Madec) merge of diabort and diainit, F90
- !! ! 2005-11 (V. Garnier) Surface pressure gradient organization
- !! 3.2 ! 2008-11 (B. Lemaire) creation from old diawri
- !! 3.7 ! 2014-01 (G. Madec) remove eddy induced velocity from no-IOM output
- !! ! change name of output variables in dia_wri_state
- !!----------------------------------------------------------------------
-
- !!----------------------------------------------------------------------
- !! dia_wri : create the standart output files
- !! dia_wri_state : create an output NetCDF file for a single instantaeous ocean state and forcing fields
- !!----------------------------------------------------------------------
- USE oce ! ocean dynamics and tracers
- USE dom_oce ! ocean space and time domain
- USE phycst ! physical constants
- USE dianam ! build name of file (routine)
- USE diahth ! thermocline diagnostics
- USE dynadv , ONLY: ln_dynadv_vec
- USE icb_oce ! Icebergs
- USE icbdia ! Iceberg budgets
- USE ldftra ! lateral physics: eddy diffusivity coef.
- USE ldfdyn ! lateral physics: eddy viscosity coef.
- USE sbc_oce ! Surface boundary condition: ocean fields
- USE sbc_ice ! Surface boundary condition: ice fields
- USE sbcssr ! restoring term toward SST/SSS climatology
- USE sbcwave ! wave parameters
- USE wet_dry ! wetting and drying
- USE zdf_oce ! ocean vertical physics
- USE zdfdrg ! ocean vertical physics: top/bottom friction
- USE zdfmxl ! mixed layer
- !
- USE lbclnk ! ocean lateral boundary conditions (or mpp link)
- USE in_out_manager ! I/O manager
- USE dia25h ! 25h Mean output
- USE iom !
- USE ioipsl !
-
-#if defined key_si3
- USE ice
- USE icewri
-#endif
- USE lib_mpp ! MPP library
- USE timing ! preformance summary
- USE diu_bulk ! diurnal warm layer
- USE diu_coolskin ! Cool skin
-
- IMPLICIT NONE
- PRIVATE
-
- PUBLIC dia_wri ! routines called by step.F90
- PUBLIC dia_wri_state
- PUBLIC dia_wri_alloc ! Called by nemogcm module
-
- INTEGER :: nid_T, nz_T, nh_T, ndim_T, ndim_hT ! grid_T file
- INTEGER :: nb_T , ndim_bT ! grid_T file
- INTEGER :: nid_U, nz_U, nh_U, ndim_U, ndim_hU ! grid_U file
- INTEGER :: nid_V, nz_V, nh_V, ndim_V, ndim_hV ! grid_V file
- INTEGER :: nid_W, nz_W, nh_W ! grid_W file
- INTEGER :: ndex(1) ! ???
- INTEGER, SAVE, ALLOCATABLE, DIMENSION(:) :: ndex_hT, ndex_hU, ndex_hV
- INTEGER, SAVE, ALLOCATABLE, DIMENSION(:) :: ndex_T, ndex_U, ndex_V
- INTEGER, SAVE, ALLOCATABLE, DIMENSION(:) :: ndex_bT
-
- !!----------------------------------------------------------------------
- !! NEMO/OCE 4.0 , NEMO Consortium (2018)
- !! $Id$
- !! Software governed by the CeCILL license (see ./LICENSE)
- !!----------------------------------------------------------------------
-CONTAINS
-
-#if defined key_iomput
- !!----------------------------------------------------------------------
- !! 'key_iomput' use IOM library
- !!----------------------------------------------------------------------
- INTEGER FUNCTION dia_wri_alloc()
- !
- dia_wri_alloc = 0
- !
- END FUNCTION dia_wri_alloc
-
-
- SUBROUTINE dia_wri( kt, Kmm )
- !!---------------------------------------------------------------------
- !! *** ROUTINE dia_wri ***
- !!
- !! ** Purpose : Standard output of opa: dynamics and tracer fields
- !! NETCDF format is used by default
- !!
- !! ** Method : use iom_put
- !!----------------------------------------------------------------------
- INTEGER, INTENT( in ) :: kt ! ocean time-step index
- INTEGER, INTENT( in ) :: Kmm ! ocean time level index
- !!
- INTEGER :: ji, jj, jk ! dummy loop indices
- INTEGER :: ikbot ! local integer
- REAL(wp):: zztmp , zztmpx ! local scalar
- REAL(wp):: zztmp2, zztmpy ! - -
- REAL(wp):: ze3 ! - -
- REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: z3d ! 3D workspace
- !!----------------------------------------------------------------------
- !
- IF( ln_timing ) CALL timing_start('dia_wri')
- !
- ! Output the initial state and forcings
- IF( ninist == 1 ) THEN
- CALL dia_wri_state( Kmm, 'output.init' )
- ninist = 0
- ENDIF
-
- ! 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( "e3t" , e3t(:,:,:,Kmm) )
- CALL iom_put( "e3u" , e3u(:,:,:,Kmm) )
- CALL iom_put( "e3v" , e3v(:,:,:,Kmm) )
- CALL iom_put( "e3w" , e3w(:,:,:,Kmm) )
- IF( iom_use("e3tdef") ) &
- CALL iom_put( "e3tdef" , ( ( e3t(:,:,:,Kmm) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 )
-
- IF( ll_wd ) THEN
- CALL iom_put( "ssh" , (ssh(:,:,Kmm)+ssh_ref)*tmask(:,:,1) ) ! sea surface height (brought back to the reference used for wetting and drying)
- ELSE
- CALL iom_put( "ssh" , ssh(:,:,Kmm) ) ! sea surface height
- ENDIF
-
- IF( iom_use("wetdep") ) & ! wet depth
- CALL iom_put( "wetdep" , ht_0(:,:) + ssh(:,:,Kmm) )
-
- CALL iom_put( "toce", ts(:,:,:,jp_tem,Kmm) ) ! 3D temperature
- CALL iom_put( "sst", ts(:,:,1,jp_tem,Kmm) ) ! surface temperature
- IF ( iom_use("sbt") ) THEN
- DO jj = 1, jpj
- DO ji = 1, jpi
- ikbot = mbkt(ji,jj)
- z2d(ji,jj) = ts(ji,jj,ikbot,jp_tem,Kmm)
- END DO
- END DO
- CALL iom_put( "sbt", z2d ) ! bottom temperature
- ENDIF
-
- CALL iom_put( "soce", ts(:,:,:,jp_sal,Kmm) ) ! 3D salinity
- CALL iom_put( "sss", ts(:,:,1,jp_sal,Kmm) ) ! surface salinity
- IF ( iom_use("sbs") ) THEN
- DO jj = 1, jpj
- DO ji = 1, jpi
- ikbot = mbkt(ji,jj)
- z2d(ji,jj) = ts(ji,jj,ikbot,jp_sal,Kmm)
- END DO
- END DO
- CALL iom_put( "sbs", z2d ) ! bottom salinity
- ENDIF
-
- IF ( iom_use("taubot") ) THEN ! bottom stress
- zztmp = rho0 * 0.25
- z2d(:,:) = 0._wp
- DO jj = 2, jpjm1
- DO ji = fs_2, fs_jpim1 ! vector opt.
- 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)
- !
- END DO
- END DO
- CALL lbc_lnk( 'diawri', z2d, 'T', 1. )
- CALL iom_put( "taubot", z2d )
- ENDIF
-
- CALL iom_put( "uoce", uu(:,:,:,Kmm) ) ! 3D i-current
- CALL iom_put( "ssu", uu(:,:,1,Kmm) ) ! surface i-current
- IF ( iom_use("sbu") ) THEN
- DO jj = 1, jpj
- DO ji = 1, jpi
- ikbot = mbku(ji,jj)
- z2d(ji,jj) = uu(ji,jj,ikbot,Kmm)
- END DO
- END DO
- CALL iom_put( "sbu", z2d ) ! bottom i-current
- ENDIF
-
- CALL iom_put( "voce", vv(:,:,:,Kmm) ) ! 3D j-current
- CALL iom_put( "ssv", vv(:,:,1,Kmm) ) ! surface j-current
- IF ( iom_use("sbv") ) THEN
- DO jj = 1, jpj
- DO ji = 1, jpi
- ikbot = mbkv(ji,jj)
- z2d(ji,jj) = vv(ji,jj,ikbot,Kmm)
- END DO
- END DO
- CALL iom_put( "sbv", z2d ) ! bottom j-current
- ENDIF
-
- CALL iom_put( "woce", ww ) ! vertical velocity
- IF( iom_use('w_masstr') .OR. iom_use('w_masstr2') ) THEN ! vertical mass transport & its square value
- ! Caution: in the VVL case, it only correponds to the baroclinic mass transport.
- z2d(:,:) = rho0 * e1e2t(:,:)
- DO jk = 1, jpk
- z3d(:,:,jk) = ww(:,:,jk) * z2d(:,:)
- END DO
- CALL iom_put( "w_masstr" , z3d )
- IF( iom_use('w_masstr2') ) CALL iom_put( "w_masstr2", z3d(:,:,:) * z3d(:,:,:) )
- 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.
-
- 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(:,:,:) ) ) )
-
- IF ( iom_use("salgrad") .OR. iom_use("salgrad2") ) THEN
- z3d(:,:,jpk) = 0.
- DO jk = 1, jpkm1
- DO jj = 2, jpjm1 ! sal gradient
- DO ji = fs_2, fs_jpim1 ! vector opt.
- zztmp = ts(ji,jj,jk,jp_sal,Kmm)
- zztmpx = ( ts(ji+1,jj,jk,jp_sal,Kmm) - zztmp ) * r1_e1u(ji,jj) + ( zztmp - ts(ji-1,jj ,jk,jp_sal,Kmm) ) * r1_e1u(ji-1,jj)
- zztmpy = ( ts(ji,jj+1,jk,jp_sal,Kmm) - zztmp ) * r1_e2v(ji,jj) + ( zztmp - ts(ji ,jj-1,jk,jp_sal,Kmm) ) * r1_e2v(ji,jj-1)
- z3d(ji,jj,jk) = 0.25 * ( zztmpx * zztmpx + zztmpy * zztmpy ) &
- & * umask(ji,jj,jk) * umask(ji-1,jj,jk) * vmask(ji,jj,jk) * umask(ji,jj-1,jk)
- END DO
- END DO
- END DO
- CALL lbc_lnk( 'diawri', z3d, 'T', 1. )
- CALL iom_put( "salgrad2", z3d ) ! square of module of sal gradient
- z3d(:,:,:) = SQRT( z3d(:,:,:) )
- CALL iom_put( "salgrad" , z3d ) ! module of sal gradient
- ENDIF
-
- IF ( iom_use("sstgrad") .OR. iom_use("sstgrad2") ) THEN
- DO jj = 2, jpjm1 ! sst gradient
- DO ji = fs_2, fs_jpim1 ! vector opt.
- 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 * ( zztmpx * zztmpx + zztmpy * zztmpy ) &
- & * umask(ji,jj,1) * umask(ji-1,jj,1) * vmask(ji,jj,1) * umask(ji,jj-1,1)
- END DO
- END DO
- CALL lbc_lnk( 'diawri', z2d, 'T', 1. )
- CALL iom_put( "sstgrad2", z2d ) ! square of module of sst gradient
- z2d(:,:) = SQRT( z2d(:,:) )
- CALL iom_put( "sstgrad" , z2d ) ! module of sst gradient
- ENDIF
-
- ! heat and salt contents
- IF( iom_use("heatc") ) THEN
- z2d(:,:) = 0._wp
- DO jk = 1, jpkm1
- DO jj = 1, jpj
- DO ji = 1, jpi
- z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_tem,Kmm) * tmask(ji,jj,jk)
- END DO
- END DO
- END DO
- CALL iom_put( "heatc", rho0_rcp * z2d ) ! vertically integrated heat content (J/m2)
- ENDIF
-
- IF( iom_use("saltc") ) THEN
- z2d(:,:) = 0._wp
- DO jk = 1, jpkm1
- DO jj = 1, jpj
- DO ji = 1, jpi
- z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_sal,Kmm) * tmask(ji,jj,jk)
- END DO
- END DO
- END DO
- CALL iom_put( "saltc", rho0 * z2d ) ! vertically integrated salt content (PSU*kg/m2)
- ENDIF
- !
- IF( iom_use("salt2c") ) THEN
- z2d(:,:) = 0._wp
- DO jk = 1, jpkm1
- DO jj = 1, jpj
- DO ji = 1, jpi
- 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)
- END DO
- END DO
- END DO
- CALL iom_put( "salt2c", rho0 * z2d ) ! vertically integrated salt content (PSU*kg/m2)
- ENDIF
- !
- IF ( iom_use("eken") ) THEN
- z3d(:,:,jpk) = 0._wp
- DO jk = 1, jpkm1
- DO jj = 2, jpjm1
- DO ji = fs_2, fs_jpim1 ! vector opt.
- zztmp = 0.25_wp * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm)
- z3d(ji,jj,jk) = zztmp * ( uu(ji-1,jj,jk,Kmm)**2 * e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm) &
- & + uu(ji ,jj,jk,Kmm)**2 * e2u(ji ,jj) * e3u(ji ,jj,jk,Kmm) &
- & + vv(ji,jj-1,jk,Kmm)**2 * e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) &
- & + vv(ji,jj ,jk,Kmm)**2 * e1v(ji,jj ) * e3v(ji,jj ,jk,Kmm) )
- END DO
- END DO
- END DO
- CALL lbc_lnk( 'diawri', z3d, 'T', 1. )
- CALL iom_put( "eken", z3d ) ! kinetic energy
- ENDIF
-
- IF ( iom_use("ke") .or. iom_use("ke_zint") ) THEN
- !
- z3d(:,:,jpk) = 0._wp
- z3d(1,:, : ) = 0._wp
- z3d(:,1, : ) = 0._wp
- DO jk = 1, jpkm1
- DO jj = 2, jpj
- DO ji = 2, jpi
- z3d(ji,jj,jk) = 0.25_wp * ( uu(ji ,jj,jk,Kmm) * uu(ji ,jj,jk,Kmm) * e1e2u(ji ,jj) * e3u(ji ,jj,jk,Kmm) &
- & + uu(ji-1,jj,jk,Kmm) * uu(ji-1,jj,jk,Kmm) * e1e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm) &
- & + vv(ji,jj ,jk,Kmm) * vv(ji,jj ,jk,Kmm) * e1e2v(ji,jj ) * e3v(ji,jj ,jk,Kmm) &
- & + vv(ji,jj-1,jk,Kmm) * vv(ji,jj-1,jk,Kmm) * e1e2v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) ) &
- & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk)
- END DO
- END DO
- END DO
-
- CALL lbc_lnk( 'diawri', z3d, 'T', 1. )
- CALL iom_put( "ke", z3d ) ! kinetic energy
-
- z2d(:,:) = 0._wp
- DO jk = 1, jpkm1
- DO jj = 1, jpj
- DO ji = 1, jpi
- z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * z3d(ji,jj,jk) * tmask(ji,jj,jk)
- END DO
- END DO
- END DO
- CALL iom_put( "ke_zint", z2d ) ! vertically integrated kinetic energy
-
- ENDIF
- !
- CALL iom_put( "hdiv", hdiv ) ! Horizontal divergence
-
- IF ( iom_use("relvor") .OR. iom_use("absvor") .OR. iom_use("potvor") ) THEN
-
- z3d(:,:,jpk) = 0._wp
- DO jk = 1, jpkm1
- DO jj = 1, jpjm1
- DO ji = 1, fs_jpim1 ! vector opt.
- z3d(ji,jj,jk) = ( e2v(ji+1,jj ) * vv(ji+1,jj ,jk,Kmm) - e2v(ji,jj) * vv(ji,jj,jk,Kmm) &
- & - e1u(ji ,jj+1) * uu(ji ,jj+1,jk,Kmm) + e1u(ji,jj) * uu(ji,jj,jk,Kmm) ) * r1_e1e2f(ji,jj)
- END DO
- END DO
- END DO
- CALL lbc_lnk( 'diawri', z3d, 'F', 1. )
- CALL iom_put( "relvor", z3d ) ! relative vorticity
-
- DO jk = 1, jpkm1
- DO jj = 1, jpj
- DO ji = 1, jpi
- z3d(ji,jj,jk) = ff_f(ji,jj) + z3d(ji,jj,jk)
- END DO
- END DO
- END DO
- CALL iom_put( "absvor", z3d ) ! absolute vorticity
-
- DO jk = 1, jpkm1
- DO jj = 1, jpjm1
- DO ji = 1, fs_jpim1 ! vector opt.
- ze3 = ( 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) )
- IF( ze3 /= 0._wp ) THEN ; ze3 = 4._wp / ze3
- ELSE ; ze3 = 0._wp
- ENDIF
- z3d(ji,jj,jk) = ze3 * z3d(ji,jj,jk)
- END DO
- END DO
- END DO
- CALL lbc_lnk( 'diawri', z3d, 'F', 1. )
- CALL iom_put( "potvor", z3d ) ! potential vorticity
-
- ENDIF
-
- !
- IF( iom_use("u_masstr") .OR. iom_use("u_masstr_vint") .OR. iom_use("u_heattr") .OR. iom_use("u_salttr") ) THEN
- z3d(:,:,jpk) = 0.e0
- z2d(:,:) = 0.e0
- DO jk = 1, jpkm1
- z3d(:,:,jk) = rho0 * uu(:,:,jk,Kmm) * e2u(:,:) * e3u(:,:,jk,Kmm) * umask(:,:,jk)
- z2d(:,:) = z2d(:,:) + z3d(:,:,jk)
- END DO
- CALL iom_put( "u_masstr" , z3d ) ! mass transport in i-direction
- CALL iom_put( "u_masstr_vint", z2d ) ! mass transport in i-direction vertical sum
- ENDIF
-
- IF( iom_use("u_heattr") ) THEN
- z2d(:,:) = 0._wp
- DO jk = 1, jpkm1
- DO jj = 2, jpjm1
- DO ji = fs_2, fs_jpim1 ! vector opt.
- z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( ts(ji,jj,jk,jp_tem,Kmm) + ts(ji+1,jj,jk,jp_tem,Kmm) )
- END DO
- END DO
- END DO
- CALL lbc_lnk( 'diawri', z2d, 'U', -1. )
- CALL iom_put( "u_heattr", 0.5*rcp * z2d ) ! heat transport in i-direction
- ENDIF
-
- IF( iom_use("u_salttr") ) THEN
- z2d(:,:) = 0.e0
- DO jk = 1, jpkm1
- DO jj = 2, jpjm1
- DO ji = fs_2, fs_jpim1 ! vector opt.
- z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( ts(ji,jj,jk,jp_sal,Kmm) + ts(ji+1,jj,jk,jp_sal,Kmm) )
- END DO
- END DO
- END DO
- CALL lbc_lnk( 'diawri', z2d, 'U', -1. )
- CALL iom_put( "u_salttr", 0.5 * z2d ) ! heat transport in i-direction
- ENDIF
-
-
- IF( iom_use("v_masstr") .OR. iom_use("v_heattr") .OR. iom_use("v_salttr") ) THEN
- z3d(:,:,jpk) = 0.e0
- DO jk = 1, jpkm1
- z3d(:,:,jk) = rho0 * vv(:,:,jk,Kmm) * e1v(:,:) * e3v(:,:,jk,Kmm) * vmask(:,:,jk)
- END DO
- CALL iom_put( "v_masstr", z3d ) ! mass transport in j-direction
- ENDIF
-
- IF( iom_use("v_heattr") ) THEN
- z2d(:,:) = 0.e0
- DO jk = 1, jpkm1
- DO jj = 2, jpjm1
- DO ji = fs_2, fs_jpim1 ! vector opt.
- z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( ts(ji,jj,jk,jp_tem,Kmm) + ts(ji,jj+1,jk,jp_tem,Kmm) )
- END DO
- END DO
- END DO
- CALL lbc_lnk( 'diawri', z2d, 'V', -1. )
- CALL iom_put( "v_heattr", 0.5*rcp * z2d ) ! heat transport in j-direction
- ENDIF
-
- IF( iom_use("v_salttr") ) THEN
- z2d(:,:) = 0._wp
- DO jk = 1, jpkm1
- DO jj = 2, jpjm1
- DO ji = fs_2, fs_jpim1 ! vector opt.
- z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( ts(ji,jj,jk,jp_sal,Kmm) + ts(ji,jj+1,jk,jp_sal,Kmm) )
- END DO
- END DO
- END DO
- CALL lbc_lnk( 'diawri', z2d, 'V', -1. )
- CALL iom_put( "v_salttr", 0.5 * z2d ) ! heat transport in j-direction
- ENDIF
-
- IF( iom_use("tosmint") ) THEN
- z2d(:,:) = 0._wp
- DO jk = 1, jpkm1
- DO jj = 2, jpjm1
- DO ji = fs_2, fs_jpim1 ! vector opt.
- z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_tem,Kmm)
- END DO
- END DO
- END DO
- CALL lbc_lnk( 'diawri', z2d, 'T', -1. )
- CALL iom_put( "tosmint", rho0 * z2d ) ! Vertical integral of temperature
- ENDIF
- IF( iom_use("somint") ) THEN
- z2d(:,:)=0._wp
- DO jk = 1, jpkm1
- DO jj = 2, jpjm1
- DO ji = fs_2, fs_jpim1 ! vector opt.
- z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_sal,Kmm)
- END DO
- END DO
- END DO
- CALL lbc_lnk( 'diawri', z2d, 'T', -1. )
- CALL iom_put( "somint", rho0 * z2d ) ! Vertical integral of salinity
- ENDIF
-
- CALL iom_put( "bn2", rn2 ) ! Brunt-Vaisala buoyancy frequency (N^2)
- !
-
- IF (ln_dia25h) CALL dia_25h( kt, Kmm ) ! 25h averaging
-
- IF( ln_timing ) CALL timing_stop('dia_wri')
- !
- END SUBROUTINE dia_wri
-
-#else
- !!----------------------------------------------------------------------
- !! Default option use IOIPSL library
- !!----------------------------------------------------------------------
-
- INTEGER FUNCTION dia_wri_alloc()
- !!----------------------------------------------------------------------
- INTEGER, DIMENSION(2) :: ierr
- !!----------------------------------------------------------------------
- ierr = 0
- ALLOCATE( ndex_hT(jpi*jpj) , ndex_T(jpi*jpj*jpk) , &
- & ndex_hU(jpi*jpj) , ndex_U(jpi*jpj*jpk) , &
- & ndex_hV(jpi*jpj) , ndex_V(jpi*jpj*jpk) , STAT=ierr(1) )
- !
- dia_wri_alloc = MAXVAL(ierr)
- CALL mpp_sum( 'diawri', dia_wri_alloc )
- !
- END FUNCTION dia_wri_alloc
-
-
- SUBROUTINE dia_wri( kt, Kmm )
- !!---------------------------------------------------------------------
- !! *** ROUTINE dia_wri ***
- !!
- !! ** Purpose : Standard output of opa: dynamics and tracer fields
- !! NETCDF format is used by default
- !!
- !! ** Method : At the beginning of the first time step (nit000),
- !! define all the NETCDF files and fields
- !! At each time step call histdef to compute the mean if ncessary
- !! Each nn_write time step, output the instantaneous or mean fields
- !!----------------------------------------------------------------------
- INTEGER, INTENT( in ) :: kt ! ocean time-step index
- INTEGER, INTENT( in ) :: Kmm ! ocean time level index
- !
- LOGICAL :: ll_print = .FALSE. ! =T print and flush numout
- CHARACTER (len=40) :: clhstnam, clop, clmx ! local names
- INTEGER :: inum = 11 ! temporary logical unit
- INTEGER :: ji, jj, jk ! dummy loop indices
- INTEGER :: ierr ! error code return from allocation
- INTEGER :: iimi, iima, ipk, it, itmod, ijmi, ijma ! local integers
- INTEGER :: jn, ierror ! local integers
- REAL(wp) :: zsto, zout, zmax, zjulian ! local scalars
- !
- REAL(wp), DIMENSION(jpi,jpj) :: zw2d ! 2D workspace
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zw3d ! 3D workspace
- !!----------------------------------------------------------------------
- !
- IF( ninist == 1 ) THEN !== Output the initial state and forcings ==!
- CALL dia_wri_state( Kmm, 'output.init' )
- ninist = 0
- ENDIF
- !
- IF( nn_write == -1 ) RETURN ! we will never do any output
- !
- IF( ln_timing ) CALL timing_start('dia_wri')
- !
- ! 0. Initialisation
- ! -----------------
-
- ll_print = .FALSE. ! local variable for debugging
- ll_print = ll_print .AND. lwp
-
- ! Define frequency of output and means
- clop = "x" ! no use of the mask value (require less cpu time and otherwise the model crashes)
-#if defined key_diainstant
- zsto = nn_write * rn_Dt
- clop = "inst("//TRIM(clop)//")"
-#else
- zsto=rn_Dt
- clop = "ave("//TRIM(clop)//")"
-#endif
- zout = nn_write * rn_Dt
- zmax = ( nitend - nit000 + 1 ) * rn_Dt
-
- ! Define indices of the horizontal output zoom and vertical limit storage
- iimi = 1 ; iima = jpi
- ijmi = 1 ; ijma = jpj
- ipk = jpk
-
- ! define time axis
- it = kt
- itmod = kt - nit000 + 1
-
-
- ! 1. Define NETCDF files and fields at beginning of first time step
- ! -----------------------------------------------------------------
-
- IF( kt == nit000 ) THEN
-
- ! Define the NETCDF files (one per grid)
-
- ! Compute julian date from starting date of the run
- CALL ymds2ju( nyear, nmonth, nday, rn_Dt, zjulian )
- zjulian = zjulian - adatrj ! set calendar origin to the beginning of the experiment
- IF(lwp)WRITE(numout,*)
- IF(lwp)WRITE(numout,*) 'Date 0 used :', nit000, ' YEAR ', nyear, &
- & ' MONTH ', nmonth, ' DAY ', nday, 'Julian day : ', zjulian
- IF(lwp)WRITE(numout,*) ' indexes of zoom = ', iimi, iima, ijmi, ijma, &
- ' limit storage in depth = ', ipk
-
- ! WRITE root name in date.file for use by postpro
- IF(lwp) THEN
- CALL dia_nam( clhstnam, nn_write,' ' )
- CALL ctl_opn( inum, 'date.file', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea )
- WRITE(inum,*) clhstnam
- CLOSE(inum)
- ENDIF
-
- ! Define the T grid FILE ( nid_T )
-
- CALL dia_nam( clhstnam, nn_write, 'grid_T' )
- IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam ! filename
- CALL histbeg( clhstnam, jpi, glamt, jpj, gphit, & ! Horizontal grid: glamt and gphit
- & iimi, iima-iimi+1, ijmi, ijma-ijmi+1, &
- & nit000-1, zjulian, rn_Dt, nh_T, nid_T, domain_id=nidom, snc4chunks=snc4set )
- CALL histvert( nid_T, "deptht", "Vertical T levels", & ! Vertical grid: gdept
- & "m", ipk, gdept_1d, nz_T, "down" )
- ! ! Index of ocean points
- CALL wheneq( jpi*jpj*ipk, tmask, 1, 1., ndex_T , ndim_T ) ! volume
- CALL wheneq( jpi*jpj , tmask, 1, 1., ndex_hT, ndim_hT ) ! surface
- !
- IF( ln_icebergs ) THEN
- !
- !! allocation cant go in dia_wri_alloc because ln_icebergs is only set after
- !! that routine is called from nemogcm, so do it here immediately before its needed
- ALLOCATE( ndex_bT(jpi*jpj*nclasses), STAT=ierror )
- CALL mpp_sum( 'diawri', ierror )
- IF( ierror /= 0 ) THEN
- CALL ctl_stop('dia_wri: failed to allocate iceberg diagnostic array')
- RETURN
- ENDIF
- !
- !! iceberg vertical coordinate is class number
- CALL histvert( nid_T, "class", "Iceberg class", & ! Vertical grid: class
- & "number", nclasses, class_num, nb_T )
- !
- !! each class just needs the surface index pattern
- ndim_bT = 3
- DO jn = 1,nclasses
- ndex_bT((jn-1)*jpi*jpj+1:jn*jpi*jpj) = ndex_hT(1:jpi*jpj)
- ENDDO
- !
- ENDIF
-
- ! Define the U grid FILE ( nid_U )
-
- CALL dia_nam( clhstnam, nn_write, 'grid_U' )
- IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam ! filename
- CALL histbeg( clhstnam, jpi, glamu, jpj, gphiu, & ! Horizontal grid: glamu and gphiu
- & iimi, iima-iimi+1, ijmi, ijma-ijmi+1, &
- & nit000-1, zjulian, rn_Dt, nh_U, nid_U, domain_id=nidom, snc4chunks=snc4set )
- CALL histvert( nid_U, "depthu", "Vertical U levels", & ! Vertical grid: gdept
- & "m", ipk, gdept_1d, nz_U, "down" )
- ! ! Index of ocean points
- CALL wheneq( jpi*jpj*ipk, umask, 1, 1., ndex_U , ndim_U ) ! volume
- CALL wheneq( jpi*jpj , umask, 1, 1., ndex_hU, ndim_hU ) ! surface
-
- ! Define the V grid FILE ( nid_V )
-
- CALL dia_nam( clhstnam, nn_write, 'grid_V' ) ! filename
- IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam
- CALL histbeg( clhstnam, jpi, glamv, jpj, gphiv, & ! Horizontal grid: glamv and gphiv
- & iimi, iima-iimi+1, ijmi, ijma-ijmi+1, &
- & nit000-1, zjulian, rn_Dt, nh_V, nid_V, domain_id=nidom, snc4chunks=snc4set )
- CALL histvert( nid_V, "depthv", "Vertical V levels", & ! Vertical grid : gdept
- & "m", ipk, gdept_1d, nz_V, "down" )
- ! ! Index of ocean points
- CALL wheneq( jpi*jpj*ipk, vmask, 1, 1., ndex_V , ndim_V ) ! volume
- CALL wheneq( jpi*jpj , vmask, 1, 1., ndex_hV, ndim_hV ) ! surface
-
- ! Define the W grid FILE ( nid_W )
-
- CALL dia_nam( clhstnam, nn_write, 'grid_W' ) ! filename
- IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam
- CALL histbeg( clhstnam, jpi, glamt, jpj, gphit, & ! Horizontal grid: glamt and gphit
- & iimi, iima-iimi+1, ijmi, ijma-ijmi+1, &
- & nit000-1, zjulian, rn_Dt, nh_W, nid_W, domain_id=nidom, snc4chunks=snc4set )
- CALL histvert( nid_W, "depthw", "Vertical W levels", & ! Vertical grid: gdepw
- & "m", ipk, gdepw_1d, nz_W, "down" )
-
-
- ! Declare all the output fields as NETCDF variables
-
- ! !!! nid_T : 3D
- CALL histdef( nid_T, "votemper", "Temperature" , "C" , & ! tn
- & jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout )
- CALL histdef( nid_T, "vosaline", "Salinity" , "PSU" , & ! sn
- & jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout )
- IF( .NOT.ln_linssh ) THEN
- CALL histdef( nid_T, "vovvle3t", "Level thickness" , "m" ,& ! e3t(:,:,:,Kmm)
- & jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout )
- CALL histdef( nid_T, "vovvldep", "T point depth" , "m" ,& ! e3t(:,:,:,Kmm)
- & jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout )
- CALL histdef( nid_T, "vovvldef", "Squared level deformation" , "%^2" ,& ! e3t(:,:,:,Kmm)
- & jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout )
- ENDIF
- ! !!! nid_T : 2D
- CALL histdef( nid_T, "sosstsst", "Sea Surface temperature" , "C" , & ! sst
- & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
- CALL histdef( nid_T, "sosaline", "Sea Surface Salinity" , "PSU" , & ! sss
- & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
- CALL histdef( nid_T, "sossheig", "Sea Surface Height" , "m" , & ! ssh
- & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
- CALL histdef( nid_T, "sowaflup", "Net Upward Water Flux" , "Kg/m2/s", & ! (emp-rnf)
- & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
- CALL histdef( nid_T, "sorunoff", "River runoffs" , "Kg/m2/s", & ! runoffs
- & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
- CALL histdef( nid_T, "sosfldow", "downward salt flux" , "PSU/m2/s", & ! sfx
- & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
- IF( ln_linssh ) THEN
- CALL histdef( nid_T, "sosst_cd", "Concentration/Dilution term on temperature" & ! emp * ts(:,:,1,jp_tem,Kmm)
- & , "KgC/m2/s", & ! sosst_cd
- & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
- CALL histdef( nid_T, "sosss_cd", "Concentration/Dilution term on salinity" & ! emp * ts(:,:,1,jp_sal,Kmm)
- & , "KgPSU/m2/s",& ! sosss_cd
- & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
- ENDIF
- CALL histdef( nid_T, "sohefldo", "Net Downward Heat Flux" , "W/m2" , & ! qns + qsr
- & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
- CALL histdef( nid_T, "soshfldo", "Shortwave Radiation" , "W/m2" , & ! qsr
- & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
- CALL histdef( nid_T, "somixhgt", "Turbocline Depth" , "m" , & ! hmld
- & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
- CALL histdef( nid_T, "somxl010", "Mixed Layer Depth 0.01" , "m" , & ! hmlp
- & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
- CALL histdef( nid_T, "soicecov", "Ice fraction" , "[0,1]" , & ! fr_i
- & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
- CALL histdef( nid_T, "sowindsp", "wind speed at 10m" , "m/s" , & ! wndm
- & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
-!
- IF( ln_icebergs ) THEN
- CALL histdef( nid_T, "calving" , "calving mass input" , "kg/s" , &
- & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
- CALL histdef( nid_T, "calving_heat" , "calving heat flux" , "XXXX" , &
- & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
- CALL histdef( nid_T, "berg_floating_melt" , "Melt rate of icebergs + bits" , "kg/m2/s", &
- & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
- CALL histdef( nid_T, "berg_stored_ice" , "Accumulated ice mass by class" , "kg" , &
- & jpi, jpj, nh_T, nclasses , 1, nclasses , nb_T , 32, clop, zsto, zout )
- IF( ln_bergdia ) THEN
- CALL histdef( nid_T, "berg_melt" , "Melt rate of icebergs" , "kg/m2/s", &
- & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
- CALL histdef( nid_T, "berg_buoy_melt" , "Buoyancy component of iceberg melt rate" , "kg/m2/s", &
- & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
- CALL histdef( nid_T, "berg_eros_melt" , "Erosion component of iceberg melt rate" , "kg/m2/s", &
- & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
- CALL histdef( nid_T, "berg_conv_melt" , "Convective component of iceberg melt rate", "kg/m2/s", &
- & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
- CALL histdef( nid_T, "berg_virtual_area" , "Virtual coverage by icebergs" , "m2" , &
- & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
- CALL histdef( nid_T, "bits_src" , "Mass source of bergy bits" , "kg/m2/s", &
- & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
- CALL histdef( nid_T, "bits_melt" , "Melt rate of bergy bits" , "kg/m2/s", &
- & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
- CALL histdef( nid_T, "bits_mass" , "Bergy bit density field" , "kg/m2" , &
- & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
- CALL histdef( nid_T, "berg_mass" , "Iceberg density field" , "kg/m2" , &
- & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
- CALL histdef( nid_T, "berg_real_calving" , "Calving into iceberg class" , "kg/s" , &
- & jpi, jpj, nh_T, nclasses , 1, nclasses , nb_T , 32, clop, zsto, zout )
- ENDIF
- ENDIF
-
- IF( ln_ssr ) THEN
- CALL histdef( nid_T, "sohefldp", "Surface Heat Flux: Damping" , "W/m2" , & ! qrp
- & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
- CALL histdef( nid_T, "sowafldp", "Surface Water Flux: Damping" , "Kg/m2/s", & ! erp
- & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
- CALL histdef( nid_T, "sosafldp", "Surface salt flux: damping" , "Kg/m2/s", & ! erp * sn
- & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
- ENDIF
-
- clmx ="l_max(only(x))" ! max index on a period
-! CALL histdef( nid_T, "sobowlin", "Bowl Index" , "W-point", & ! bowl INDEX
-! & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clmx, zsto, zout )
-#if defined key_diahth
- CALL histdef( nid_T, "sothedep", "Thermocline Depth" , "m" , & ! hth
- & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
- CALL histdef( nid_T, "so20chgt", "Depth of 20C isotherm" , "m" , & ! hd20
- & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
- CALL histdef( nid_T, "so28chgt", "Depth of 28C isotherm" , "m" , & ! hd28
- & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
- 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 histend( nid_T, snc4chunks=snc4set )
-
- ! !!! nid_U : 3D
- CALL histdef( nid_U, "vozocrtx", "Zonal Current" , "m/s" , & ! uu(:,:,:,Kmm)
- & jpi, jpj, nh_U, ipk, 1, ipk, nz_U, 32, clop, zsto, zout )
- IF( ln_wave .AND. ln_sdw) THEN
- 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
- CALL histdef( nid_V, "vomecrty", "Meridional Current" , "m/s" , & ! vv(:,:,:,Kmm)
- & jpi, jpj, nh_V, ipk, 1, ipk, nz_V, 32, clop, zsto, zout )
- IF( ln_wave .AND. ln_sdw) THEN
- 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
- CALL histdef( nid_W, "vovecrtz", "Vertical Velocity" , "m/s" , & ! ww
- & jpi, jpj, nh_W, ipk, 1, ipk, nz_W, 32, clop, zsto, zout )
- CALL histdef( nid_W, "votkeavt", "Vertical Eddy Diffusivity" , "m2/s" , & ! avt
- & jpi, jpj, nh_W, ipk, 1, ipk, nz_W, 32, clop, zsto, zout )
- CALL histdef( nid_W, "votkeavm", "Vertical Eddy Viscosity" , "m2/s" , & ! avm
- & jpi, jpj, nh_W, ipk, 1, ipk, nz_W, 32, clop, zsto, zout )
-
- IF( ln_zdfddm ) THEN
- CALL histdef( nid_W,"voddmavs","Salt Vertical Eddy Diffusivity" , "m2/s" , & ! avs
- & jpi, jpj, nh_W, ipk, 1, ipk, nz_W, 32, clop, zsto, zout )
- ENDIF
-
- IF( ln_wave .AND. ln_sdw) THEN
- CALL histdef( nid_W, "sdvecrtz", "Stokes Drift Vertical Current" , "m/s" , & ! wsd
- & jpi, jpj, nh_W, ipk, 1, ipk, nz_W, 32, clop, zsto, zout )
- ENDIF
- ! !!! nid_W : 2D
- CALL histend( nid_W, snc4chunks=snc4set )
-
- IF(lwp) WRITE(numout,*)
- IF(lwp) WRITE(numout,*) 'End of NetCDF Initialization'
- IF(ll_print) CALL FLUSH(numout )
-
- ENDIF
-
- ! 2. Start writing data
- ! ---------------------
-
- ! ndex(1) est utilise ssi l'avant dernier argument est different de
- ! la taille du tableau en sortie. Dans ce cas , l'avant dernier argument
- ! donne le nombre d'elements, et ndex la liste des indices a sortir
-
- IF( lwp .AND. MOD( itmod, nn_write ) == 0 ) THEN
- WRITE(numout,*) 'dia_wri : write model outputs in NetCDF files at ', kt, 'time-step'
- WRITE(numout,*) '~~~~~~ '
- ENDIF
-
- IF( .NOT.ln_linssh ) THEN
- CALL histwrite( nid_T, "votemper", it, ts(:,:,:,jp_tem,Kmm) * e3t(:,:,:,Kmm) , ndim_T , ndex_T ) ! heat content
- CALL histwrite( nid_T, "vosaline", it, ts(:,:,:,jp_sal,Kmm) * e3t(:,:,:,Kmm) , ndim_T , ndex_T ) ! salt content
- CALL histwrite( nid_T, "sosstsst", it, ts(:,:,1,jp_tem,Kmm) * e3t(:,:,1,Kmm) , ndim_hT, ndex_hT ) ! sea surface heat content
- CALL histwrite( nid_T, "sosaline", it, ts(:,:,1,jp_sal,Kmm) * e3t(:,:,1,Kmm) , 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
- CALL histwrite( nid_T, "sosstsst", it, ts(:,:,1,jp_tem,Kmm) , ndim_hT, ndex_hT ) ! sea surface temperature
- CALL histwrite( nid_T, "sosaline", it, ts(:,:,1,jp_sal,Kmm) , ndim_hT, ndex_hT ) ! sea surface salinity
- ENDIF
- IF( .NOT.ln_linssh ) THEN
- zw3d(:,:,:) = ( ( e3t(:,:,:,Kmm) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2
- CALL histwrite( nid_T, "vovvle3t", it, e3t (:,:,:,Kmm) , ndim_T , ndex_T ) ! level thickness
- CALL histwrite( nid_T, "vovvldep", it, gdept(:,:,:,Kmm) , ndim_T , ndex_T ) ! t-point depth
- CALL histwrite( nid_T, "vovvldef", it, zw3d , ndim_T , ndex_T ) ! level thickness deformation
- ENDIF
- CALL histwrite( nid_T, "sossheig", it, ssh(:,:,Kmm) , ndim_hT, ndex_hT ) ! sea surface height
- CALL histwrite( nid_T, "sowaflup", it, ( emp-rnf ) , 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
- zw2d(:,:) = emp (:,:) * ts(:,:,1,jp_tem,Kmm)
- CALL histwrite( nid_T, "sosst_cd", it, zw2d, ndim_hT, ndex_hT ) ! c/d term on sst
- zw2d(:,:) = emp (:,:) * ts(:,:,1,jp_sal,Kmm)
- CALL histwrite( nid_T, "sosss_cd", it, zw2d, ndim_hT, ndex_hT ) ! c/d term on sss
- ENDIF
- CALL histwrite( nid_T, "sohefldo", it, qns + qsr , ndim_hT, ndex_hT ) ! total heat flux
- CALL histwrite( nid_T, "soshfldo", it, qsr , ndim_hT, ndex_hT ) ! solar heat flux
- CALL histwrite( nid_T, "somixhgt", it, hmld , ndim_hT, ndex_hT ) ! turbocline depth
- CALL histwrite( nid_T, "somxl010", it, hmlp , ndim_hT, ndex_hT ) ! mixed layer depth
- 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
-!
- IF( ln_icebergs ) THEN
- !
- CALL histwrite( nid_T, "calving" , it, berg_grid%calving , ndim_hT, ndex_hT )
- CALL histwrite( nid_T, "calving_heat" , it, berg_grid%calving_hflx , ndim_hT, ndex_hT )
- CALL histwrite( nid_T, "berg_floating_melt" , it, berg_grid%floating_melt, ndim_hT, ndex_hT )
- !
- CALL histwrite( nid_T, "berg_stored_ice" , it, berg_grid%stored_ice , ndim_bT, ndex_bT )
- !
- IF( ln_bergdia ) THEN
- CALL histwrite( nid_T, "berg_melt" , it, berg_melt , ndim_hT, ndex_hT )
- CALL histwrite( nid_T, "berg_buoy_melt" , it, buoy_melt , ndim_hT, ndex_hT )
- CALL histwrite( nid_T, "berg_eros_melt" , it, eros_melt , ndim_hT, ndex_hT )
- CALL histwrite( nid_T, "berg_conv_melt" , it, conv_melt , ndim_hT, ndex_hT )
- CALL histwrite( nid_T, "berg_virtual_area" , it, virtual_area , ndim_hT, ndex_hT )
- CALL histwrite( nid_T, "bits_src" , it, bits_src , ndim_hT, ndex_hT )
- CALL histwrite( nid_T, "bits_melt" , it, bits_melt , ndim_hT, ndex_hT )
- CALL histwrite( nid_T, "bits_mass" , it, bits_mass , ndim_hT, ndex_hT )
- CALL histwrite( nid_T, "berg_mass" , it, berg_mass , ndim_hT, ndex_hT )
- !
- CALL histwrite( nid_T, "berg_real_calving" , it, real_calving , ndim_bT, ndex_bT )
- ENDIF
- ENDIF
-
- IF( ln_ssr ) THEN
- 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
- zw2d(:,:) = erp(:,:) * ts(:,:,1,jp_sal,Kmm) * tmask(:,:,1)
- CALL histwrite( nid_T, "sosafldp", it, zw2d , ndim_hT, ndex_hT ) ! salt flux damping
- ENDIF
-! zw2d(:,:) = FLOAT( nmln(:,:) ) * tmask(:,:,1)
-! CALL histwrite( nid_T, "sobowlin", it, zw2d , ndim_hT, ndex_hT ) ! ???
-
-#if defined key_diahth
- CALL histwrite( nid_T, "sothedep", it, hth , ndim_hT, ndex_hT ) ! depth of the thermocline
- CALL histwrite( nid_T, "so20chgt", it, hd20 , ndim_hT, ndex_hT ) ! depth of the 20 isotherm
- 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_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
-
- CALL histwrite( nid_W, "vovecrtz", it, ww , ndim_T, ndex_T ) ! vert. current
- CALL histwrite( nid_W, "votkeavt", it, avt , ndim_T, ndex_T ) ! T vert. eddy diff. coef.
- CALL histwrite( nid_W, "votkeavm", it, avm , ndim_T, ndex_T ) ! T vert. eddy visc. coef.
- IF( ln_zdfddm ) THEN
- CALL histwrite( nid_W, "voddmavs", it, avs , ndim_T, ndex_T ) ! S vert. eddy diff. coef.
- ENDIF
-
- IF( ln_wave .AND. ln_sdw ) THEN
- CALL histwrite( nid_U, "sdzocrtx", it, usd , ndim_U , ndex_U ) ! i-StokesDrift-current
- CALL histwrite( nid_V, "sdmecrty", it, vsd , ndim_V , ndex_V ) ! j-StokesDrift-current
- CALL histwrite( nid_W, "sdvecrtz", it, wsd , ndim_T , ndex_T ) ! StokesDrift vert. current
- ENDIF
-
- ! 3. Close all files
- ! ---------------------------------------
- IF( kt == nitend ) THEN
- CALL histclo( nid_T )
- CALL histclo( nid_U )
- CALL histclo( nid_V )
- CALL histclo( nid_W )
- ENDIF
- !
- IF( ln_timing ) CALL timing_stop('dia_wri')
- !
- END SUBROUTINE dia_wri
-#endif
-
- SUBROUTINE dia_wri_state( Kmm, cdfile_name )
- !!---------------------------------------------------------------------
- !! *** ROUTINE dia_wri_state ***
- !!
- !! ** Purpose : create a NetCDF file named cdfile_name which contains
- !! the instantaneous ocean state and forcing fields.
- !! Used to find errors in the initial state or save the last
- !! ocean state in case of abnormal end of a simulation
- !!
- !! ** Method : NetCDF files using ioipsl
- !! File 'output.init.nc' is created if ninist = 1 (namelist)
- !! File 'output.abort.nc' is created in case of abnormal job end
- !!----------------------------------------------------------------------
- INTEGER , INTENT( in ) :: Kmm ! time level index
- CHARACTER (len=* ), INTENT( in ) :: cdfile_name ! name of the file created
- !!
- INTEGER :: inum
- !!----------------------------------------------------------------------
- !
- IF(lwp) WRITE(numout,*)
- IF(lwp) WRITE(numout,*) 'dia_wri_state : single instantaneous ocean state'
- IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~ and forcing fields file created '
- IF(lwp) WRITE(numout,*) ' and named :', cdfile_name, '...nc'
-
-#if defined key_si3
- CALL iom_open( TRIM(cdfile_name), inum, ldwrt = .TRUE., kdlev = jpl )
-#else
- CALL iom_open( TRIM(cdfile_name), inum, ldwrt = .TRUE. )
-#endif
-
- CALL iom_rstput( 0, 0, inum, 'votemper', ts(:,:,:,jp_tem,Kmm) ) ! now temperature
- CALL iom_rstput( 0, 0, inum, 'vosaline', ts(:,:,:,jp_sal,Kmm) ) ! now salinity
- CALL iom_rstput( 0, 0, inum, 'sossheig', ssh(:,:,Kmm) ) ! sea surface height
- CALL iom_rstput( 0, 0, inum, 'vozocrtx', uu(:,:,:,Kmm) ) ! now i-velocity
- CALL iom_rstput( 0, 0, inum, 'vomecrty', vv(:,:,:,Kmm) ) ! now j-velocity
- CALL iom_rstput( 0, 0, inum, 'vovecrtz', ww ) ! now k-velocity
- IF( ALLOCATED(ahtu) ) THEN
- CALL iom_rstput( 0, 0, inum, 'ahtu', ahtu ) ! aht at u-point
- CALL iom_rstput( 0, 0, inum, 'ahtv', ahtv ) ! aht at v-point
- ENDIF
- IF( ALLOCATED(ahmt) ) THEN
- CALL iom_rstput( 0, 0, inum, 'ahmt', ahmt ) ! ahmt at u-point
- CALL iom_rstput( 0, 0, inum, 'ahmf', ahmf ) ! ahmf at v-point
- ENDIF
- CALL iom_rstput( 0, 0, inum, 'sowaflup', emp - rnf ) ! freshwater budget
- CALL iom_rstput( 0, 0, inum, 'sohefldo', qsr + qns ) ! 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
- CALL iom_rstput( 0, 0, inum, 'vovvldep', gdept(:,:,:,Kmm) ) ! T-cell depth
- CALL iom_rstput( 0, 0, inum, 'vovvle3t', e3t(:,:,:,Kmm) ) ! T-cell thickness
- END IF
- IF( ln_wave .AND. ln_sdw ) THEN
- CALL iom_rstput( 0, 0, inum, 'sdzocrtx', usd ) ! now StokesDrift i-velocity
- CALL iom_rstput( 0, 0, inum, 'sdmecrty', vsd ) ! now StokesDrift j-velocity
- CALL iom_rstput( 0, 0, inum, 'sdvecrtz', wsd ) ! now StokesDrift k-velocity
- ENDIF
-
-#if defined key_si3
- IF( nn_ice == 2 ) THEN ! condition needed in case agrif + ice-model but no-ice in child grid
- CALL ice_wri_state( inum )
- ENDIF
-#endif
- !
- CALL iom_close( inum )
- !
- END SUBROUTINE dia_wri_state
-
- !!======================================================================
-END MODULE diawri
Index: /NEMO/branches/2020/r12377_ticket2386/tests/CANAL/MY_SRC/domvvl.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/CANAL/MY_SRC/domvvl.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/CANAL/MY_SRC/domvvl.F90 (revision 13540)
@@ -9,14 +9,7 @@
!! 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
+ !! 4.x ! 2020-02 (G. Madec, S. Techene) introduce ssh to h0 ratio
!!----------------------------------------------------------------------
- !!----------------------------------------------------------------------
- !! 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
- !!----------------------------------------------------------------------
USE oce ! ocean dynamics and tracers
USE phycst ! physical constant
@@ -36,9 +29,4 @@
PRIVATE
- PUBLIC dom_vvl_init ! called by domain.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
-
! !!* Namelist nam_vvl
LOGICAL , PUBLIC :: ln_vvl_zstar = .FALSE. ! zstar vertical coordinate
@@ -62,4 +50,30 @@
REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:) :: frq_rst_hdv ! retoring period for low freq. divergence
+#if defined key_qco
+ !!----------------------------------------------------------------------
+ !! 'key_qco' EMPTY MODULE Quasi-Eulerian vertical coordonate
+ !!----------------------------------------------------------------------
+#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)
@@ -116,21 +130,49 @@
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
!!----------------------------------------------------------------------
- !
- 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
!
! !== Set of all other vertical scale factors ==! (now and before)
@@ -160,22 +202,18 @@
gdept(:,:,1,Kbb) = 0.5_wp * e3w(:,:,1,Kbb)
gdepw(:,:,1,Kbb) = 0.0_wp
- DO jk = 2, jpk ! vertical sum
- DO jj = 1,jpj
- DO ji = 1,jpi
- ! 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
+ DO_3D( 1, 1, 1, 1, 2, jpk )
+ ! 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 DO
- END DO
- END DO
+ 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)
@@ -212,31 +250,29 @@
ENDIF
IF ( ln_vvl_zstar_at_eqtor ) THEN ! use z-star in vicinity of the Equator
- DO jj = 1, jpj
- DO ji = 1, jpi
+ 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 DO
- END DO
+ 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 ; ii1 = 111
- ij0 = 128 ; ij1 = 135 ;
+ 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
@@ -264,5 +300,5 @@
ENDIF
!
- END SUBROUTINE dom_vvl_init
+ END SUBROUTINE dom_vvl_zgr
@@ -298,5 +334,6 @@
LOGICAL :: ll_do_bclinic ! local logical
REAL(wp), DIMENSION(jpi,jpj) :: zht, z_scale, zwu, zwv, zhdiv
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t
+ REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ze3t
+ LOGICAL , DIMENSION(:,:,:), ALLOCATABLE :: llmsk
!!----------------------------------------------------------------------
!
@@ -329,6 +366,6 @@
END DO
!
- IF( ln_vvl_ztilde .OR. ln_vvl_layer .AND. ll_do_bclinic ) THEN ! z_tilde or layer coordinate !
- ! ! ------baroclinic part------ !
+ IF( (ln_vvl_ztilde .OR. ln_vvl_layer) .AND. ll_do_bclinic ) THEN ! z_tilde or layer coordinate !
+ ! ! ------baroclinic part------ !
! I - initialization
! ==================
@@ -383,31 +420,21 @@
zwu(:,:) = 0._wp
zwv(:,:) = 0._wp
- DO jk = 1, jpkm1 ! a - first derivative: diffusive fluxes
- DO jj = 1, jpjm1
- DO ji = 1, fs_jpim1 ! vector opt.
- 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 DO
- END DO
- END DO
- DO jj = 1, jpj ! b - correction for last oceanic u-v points
- DO ji = 1, jpi
- 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 DO
- END DO
- DO jk = 1, jpkm1 ! c - second derivative: divergence of diffusive fluxes
- DO jj = 2, jpjm1
- DO ji = fs_2, fs_jpim1 ! vector opt.
- 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 DO
- END DO
- END DO
+ DO_3D( 1, 0, 1, 0, 1, jpkm1 )
+ 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( 1, 1, 1, 1 )
+ 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 )
+ 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)
@@ -416,6 +443,4 @@
! 4 - Time stepping of baroclinic scale factors
! ---------------------------------------------
- ! Leapfrog time stepping
- ! ~~~~~~~~~~~~~~~~~~~~~~
CALL lbc_lnk( 'domvvl', tilde_e3t_a(:,:,:), 'T', 1._wp )
tilde_e3t_a(:,:,:) = tilde_e3t_b(:,:,:) + rDt * tmask(:,:,:) * tilde_e3t_a(:,:,:)
@@ -423,25 +448,21 @@
! Maximum deformation control
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~
- ze3t(:,:,jpk) = 0._wp
- DO jk = 1, jpkm1
- ze3t(:,:,jk) = tilde_e3t_a(:,:,jk) / e3t_0(:,:,jk) * tmask(:,:,jk) * tmask_i(:,:)
- END DO
- z_tmax = MAXVAL( ze3t(:,:,:) )
- CALL mpp_max( 'domvvl', z_tmax ) ! max over the global domain
- z_tmin = MINVAL( ze3t(:,:,:) )
- CALL mpp_min( 'domvvl', z_tmin ) ! min over the global domain
+ 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:Nis1,:,:) = .FALSE. ! exclude halos from the checked region
+ llmsk(Nie1: jpi,:,:) = .FALSE.
+ llmsk(:, 1:Njs1,:) = .FALSE.
+ llmsk(:,Nje1: 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
- IF( lk_mpp ) THEN
- CALL mpp_maxloc( 'domvvl', ze3t, tmask, z_tmax, ijk_max )
- CALL mpp_minloc( 'domvvl', ze3t, tmask, z_tmin, ijk_min )
- ELSE
- ijk_max = MAXLOC( ze3t(:,:,:) )
- ijk_max(1) = ijk_max(1) + nimpp - 1
- ijk_max(2) = ijk_max(2) + njmpp - 1
- ijk_min = MINLOC( ze3t(:,:,:) )
- ijk_min(1) = ijk_min(1) + nimpp - 1
- ijk_min(2) = ijk_min(2) + njmpp - 1
- ENDIF
+ 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
@@ -452,4 +473,5 @@
ENDIF
ENDIF
+ DEALLOCATE( ze3t, llmsk )
! - ML - end test
! - ML - Imposing these limits will cause a baroclinicity error which is corrected for below
@@ -613,10 +635,4 @@
tilde_e3t_n(:,:,:) = tilde_e3t_a(:,:,:)
ENDIF
- gdept(:,:,:,Kbb) = gdept(:,:,:,Kmm)
- gdepw(:,:,:,Kbb) = gdepw(:,:,:,Kmm)
-
- e3t(:,:,:,Kmm) = e3t(:,:,:,Kaa)
- e3u(:,:,:,Kmm) = e3u(:,:,:,Kaa)
- e3v(:,:,:,Kmm) = e3v(:,:,:,Kaa)
! Compute all missing vertical scale factor and depths
@@ -641,17 +657,13 @@
gdepw(:,:,1,Kmm) = 0.0_wp
gde3w(:,:,1) = gdept(:,:,1,Kmm) - ssh(:,:,Kmm)
- DO jk = 2, jpk
- DO jj = 1,jpj
- DO ji = 1,jpi
- ! 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 DO
- END DO
- END DO
+ DO_3D( 1, 1, 1, 1, 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
@@ -700,40 +712,28 @@
!
CASE( 'U' ) !* from T- to U-point : hor. surface weighted mean
- DO jk = 1, jpk
- DO jj = 1, jpjm1
- DO ji = 1, fs_jpim1 ! vector opt.
- 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 DO
- END DO
- END DO
+ 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
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
- DO jk = 1, jpk
- DO jj = 1, jpjm1
- DO ji = 1, fs_jpim1 ! vector opt.
- 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 DO
- END DO
- END DO
+ 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
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
- DO jk = 1, jpk
- DO jj = 1, jpjm1
- DO ji = 1, fs_jpim1 ! vector opt.
- 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 DO
- END DO
- END DO
+ DO_3D( 1, 0, 1, 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
CALL lbc_lnk( 'domvvl', pe3_out(:,:,:), 'F', 1._wp )
pe3_out(:,:,:) = pe3_out(:,:,:) + e3f_0(:,:,:)
@@ -803,5 +803,5 @@
IF( ln_rstart ) THEN !* Read the restart file
CALL rst_read_open ! open the restart file if necessary
- CALL iom_get( numror, jpdom_autoglo, 'sshn' , ssh(:,:,Kmm), ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'sshn' , ssh(:,:,Kmm), ldxios = lrxios )
!
id1 = iom_varid( numror, 'e3t_b', ldstop = .FALSE. )
@@ -810,10 +810,12 @@
id4 = iom_varid( numror, 'tilde_e3t_n', ldstop = .FALSE. )
id5 = iom_varid( numror, 'hdiv_lf', ldstop = .FALSE. )
+ !
! ! --------- !
! ! all cases !
! ! --------- !
+ !
IF( MIN( id1, id2 ) > 0 ) THEN ! all required arrays exist
- CALL iom_get( numror, jpdom_autoglo, 'e3t_b', e3t(:,:,:,Kbb), ldxios = lrxios )
- CALL iom_get( numror, jpdom_autoglo, 'e3t_n', e3t(:,:,:,Kmm), ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb), ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm), ldxios = lrxios )
! needed to restart if land processor not computed
IF(lwp) write(numout,*) 'dom_vvl_rst : e3t(:,:,:,Kbb) and e3t(:,:,:,Kmm) found in restart files'
@@ -828,6 +830,6 @@
IF(lwp) write(numout,*) 'dom_vvl_rst WARNING : e3t(:,:,:,Kmm) not found in restart files'
IF(lwp) write(numout,*) 'e3t_n set equal to e3t_b.'
- IF(lwp) write(numout,*) 'l_1st_euler is forced to .true.'
- CALL iom_get( numror, jpdom_autoglo, 'e3t_b', e3t(:,:,:,Kbb), ldxios = lrxios )
+ IF(lwp) write(numout,*) 'l_1st_euler is forced to true'
+ CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb), ldxios = lrxios )
e3t(:,:,:,Kmm) = e3t(:,:,:,Kbb)
l_1st_euler = .true.
@@ -835,6 +837,6 @@
IF(lwp) write(numout,*) 'dom_vvl_rst WARNING : e3t(:,:,:,Kbb) not found in restart files'
IF(lwp) write(numout,*) 'e3t_b set equal to e3t_n.'
- IF(lwp) write(numout,*) 'l_1st_euler is forced to .true.'
- CALL iom_get( numror, jpdom_autoglo, 'e3t_n', e3t(:,:,:,Kmm), ldxios = lrxios )
+ IF(lwp) write(numout,*) 'l_1st_euler is forced to true'
+ CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm), ldxios = lrxios )
e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm)
l_1st_euler = .true.
@@ -842,5 +844,5 @@
IF(lwp) write(numout,*) 'dom_vvl_rst WARNING : e3t(:,:,:,Kmm) not found in restart file'
IF(lwp) write(numout,*) 'Compute scale factor from sshn'
- IF(lwp) write(numout,*) 'l_1st_euler is forced to .true.'
+ IF(lwp) write(numout,*) 'l_1st_euler is forced to true'
DO jk = 1, jpk
e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * ( ht_0(:,:) + ssh(:,:,Kmm) ) &
@@ -861,6 +863,6 @@
! ! ----------------------- !
IF( MIN( id3, id4 ) > 0 ) THEN ! all required arrays exist
- CALL iom_get( numror, jpdom_autoglo, 'tilde_e3t_b', tilde_e3t_b(:,:,:), ldxios = lrxios )
- CALL iom_get( numror, jpdom_autoglo, 'tilde_e3t_n', tilde_e3t_n(:,:,:), ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'tilde_e3t_b', tilde_e3t_b(:,:,:), ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'tilde_e3t_n', tilde_e3t_n(:,:,:), ldxios = lrxios )
ELSE ! one at least array is missing
tilde_e3t_b(:,:,:) = 0.0_wp
@@ -871,5 +873,5 @@
! ! ------------ !
IF( id5 > 0 ) THEN ! required array exists
- CALL iom_get( numror, jpdom_autoglo, 'hdiv_lf', hdiv_lf(:,:,:), ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'hdiv_lf', hdiv_lf(:,:,:), ldxios = lrxios )
ELSE ! array is missing
hdiv_lf(:,:,:) = 0.0_wp
@@ -895,12 +897,10 @@
ssh(:,:,Kbb) = -ssh_ref
- DO jj = 1, jpj
- DO ji = 1, jpi
- IF( ht_0(ji,jj)-ssh_ref < rn_wdmin1 ) THEN ! if total depth is less than min depth
- ssh(ji,jj,Kbb) = rn_wdmin1 - (ht_0(ji,jj) )
- ssh(ji,jj,Kmm) = rn_wdmin1 - (ht_0(ji,jj) )
- ENDIF
- ENDDO
- ENDDO
+ DO_2D( 1, 1, 1, 1 )
+ IF( ht_0(ji,jj)-ssh_ref < rn_wdmin1 ) THEN ! if total depth is less than min depth
+ ssh(ji,jj,Kbb) = rn_wdmin1 - (ht_0(ji,jj) )
+ ssh(ji,jj,Kmm) = rn_wdmin1 - (ht_0(ji,jj) )
+ ENDIF
+ END_2D
ENDIF !If test case else
@@ -913,25 +913,25 @@
e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm)
- DO ji = 1, jpi
- DO jj = 1, jpj
- IF ( ht_0(ji,jj) .LE. 0.0 .AND. NINT( ssmask(ji,jj) ) .EQ. 1) THEN
- CALL ctl_stop( 'dom_vvl_rst: ht_0 must be positive at potentially wet points' )
- ENDIF
- END DO
- END DO
+ DO_2D( 1, 1, 1, 1 )
+ IF ( ht_0(ji,jj) .LE. 0.0 .AND. NINT( ssmask(ji,jj) ) .EQ. 1) THEN
+ CALL ctl_stop( 'dom_vvl_rst: ht_0 must be positive at potentially wet points' )
+ ENDIF
+ END_2D
!
ELSE
!
- ! usr_def_istate called here only to get sshb, that is needed to initialize e3t(Kbb) and e3t(Kmm)
- CALL usr_def_istate( gdept_0, tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb), ssh(:,:,Kbb) )
- ! usr_def_istate will be called again in istate_init to initialize ts(bn), ssh(bn), u(bn) and v(bn)
+ ! usr_def_istate called here only to get ssh(Kbb) needed to initialize e3t(Kbb) and e3t(Kmm)
+ !
+ CALL usr_def_istate( gdept_0, tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb), ssh(:,:,Kbb) )
+ !
+ ! usr_def_istate will be called again in istate_init to initialize ts, ssh, u and v
!
DO jk=1,jpk
- e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * ( ht_0(:,:) + ssh(:,:,Kbb) ) &
- & / ( ht_0(:,:) + 1._wp - ssmask(:,:) ) * tmask(:,:,jk) &
- & + e3t_0(:,:,jk) * ( 1._wp - tmask(:,:,jk) ) ! make sure e3t_b != 0 on land points
+ e3t(:,:,jk,Kbb) = e3t_0(:,:,jk) * ( ht_0(:,:) + ssh(:,:,Kbb) ) &
+ & / ( ht_0(:,:) + 1._wp - ssmask(:,:) ) * tmask(:,:,jk) &
+ & + e3t_0(:,:,jk) * ( 1._wp - tmask(:,:,jk) ) ! make sure e3t(:,:,:,Kbb) != 0 on land points
END DO
e3t(:,:,:,Kmm) = e3t(:,:,:,Kbb)
- ssh(:,: ,Kmm) = ssh(:,: ,Kbb) ! needed later for gde3w
+ ssh(:,:,Kmm) = ssh(:,:,Kbb) ! needed later for gde3w
!
END IF ! end of ll_wd edits
@@ -1025,5 +1025,4 @@
!
IF( ioptio /= 1 ) CALL ctl_stop( 'Choose ONE vertical coordinate in namelist nam_vvl' )
- IF( .NOT. ln_vvl_zstar .AND. ln_isf ) CALL ctl_stop( 'Only vvl_zstar has been tested with ice shelf cavity' )
!
IF(lwp) THEN ! Print the choice
@@ -1041,4 +1040,6 @@
END SUBROUTINE dom_vvl_ctl
+#endif
+
!!======================================================================
END MODULE domvvl
Index: MO/branches/2020/r12377_ticket2386/tests/CANAL/MY_SRC/sbcmod.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/CANAL/MY_SRC/sbcmod.F90 (revision 13539)
+++ (revision )
@@ -1,590 +1,0 @@
-MODULE sbcmod
- !!======================================================================
- !! *** MODULE sbcmod ***
- !! Surface module : provide to the ocean its surface boundary condition
- !!======================================================================
- !! History : 3.0 ! 2006-07 (G. Madec) Original code
- !! 3.1 ! 2008-08 (S. Masson, A. Caubel, E. Maisonnave, G. Madec) coupled interface
- !! 3.3 ! 2010-04 (M. Leclair, G. Madec) Forcing averaged over 2 time steps
- !! 3.3 ! 2010-10 (S. Masson) add diurnal cycle
- !! 3.3 ! 2010-09 (D. Storkey) add ice boundary conditions (BDY)
- !! - ! 2010-11 (G. Madec) ice-ocean stress always computed at each ocean time-step
- !! - ! 2010-10 (J. Chanut, C. Bricaud, G. Madec) add the surface pressure forcing
- !! 3.4 ! 2011-11 (C. Harris) CICE added as an option
- !! 3.5 ! 2012-11 (A. Coward, G. Madec) Rethink of heat, mass and salt surface fluxes
- !! 3.6 ! 2014-11 (P. Mathiot, C. Harris) add ice shelves melting
- !! 4.0 ! 2016-06 (L. Brodeau) new general bulk formulation
- !!----------------------------------------------------------------------
-
- !!----------------------------------------------------------------------
- !! sbc_init : read namsbc namelist
- !! sbc : surface ocean momentum, heat and freshwater boundary conditions
- !! sbc_final : Finalize CICE ice model (if used)
- !!----------------------------------------------------------------------
- USE oce ! ocean dynamics and tracers
- USE dom_oce ! ocean space and time domain
- USE phycst ! physical constants
- USE sbc_oce ! Surface boundary condition: ocean fields
- USE trc_oce ! shared ocean-passive tracers variables
- USE sbc_ice ! Surface boundary condition: ice fields
- USE sbcdcy ! surface boundary condition: diurnal cycle
- USE sbcssm ! surface boundary condition: sea-surface mean variables
- USE sbcflx ! surface boundary condition: flux formulation
- USE sbcblk ! surface boundary condition: bulk formulation
- USE sbcice_if ! surface boundary condition: ice-if sea-ice model
-#if defined key_si3
- USE icestp ! surface boundary condition: SI3 sea-ice model
-#endif
- USE sbcice_cice ! surface boundary condition: CICE sea-ice model
- USE sbcisf ! surface boundary condition: ice-shelf
- USE sbccpl ! surface boundary condition: coupled formulation
- USE cpl_oasis3 ! OASIS routines for coupling
- USE sbcssr ! surface boundary condition: sea surface restoring
- USE sbcrnf ! surface boundary condition: runoffs
- USE sbcapr ! surface boundary condition: atmo pressure
- USE sbcisf ! surface boundary condition: ice shelf
- USE sbcfwb ! surface boundary condition: freshwater budget
- USE icbstp ! Icebergs
- USE icb_oce , ONLY : ln_passive_mode ! iceberg interaction mode
- USE traqsr ! active tracers: light penetration
- USE sbcwave ! Wave module
- USE bdy_oce , ONLY: ln_bdy
- USE usrdef_sbc ! user defined: surface boundary condition
- USE closea ! closed sea
- !
- USE prtctl ! Print control (prt_ctl routine)
- USE iom ! IOM library
- USE in_out_manager ! I/O manager
- USE lib_mpp ! MPP library
- USE timing ! Timing
- USE wet_dry
- USE diu_bulk, ONLY: ln_diurnal_only ! diurnal SST diagnostic
-
- IMPLICIT NONE
- PRIVATE
-
- PUBLIC sbc ! routine called by step.F90
- PUBLIC sbc_init ! routine called by opa.F90
-
- INTEGER :: nsbc ! type of surface boundary condition (deduced from namsbc informations)
-
- !!----------------------------------------------------------------------
- !! NEMO/OCE 4.0 , NEMO Consortium (2018)
- !! $Id: sbcmod.F90 11480 2019-08-29 09:23:25Z davestorkey $
- !! Software governed by the CeCILL license (see ./LICENSE)
- !!----------------------------------------------------------------------
-CONTAINS
-
- SUBROUTINE sbc_init( Kbb, Kmm, Kaa )
- !!---------------------------------------------------------------------
- !! *** ROUTINE sbc_init ***
- !!
- !! ** Purpose : Initialisation of the ocean surface boundary computation
- !!
- !! ** Method : Read the namsbc namelist and set derived parameters
- !! Call init routines for all other SBC modules that have one
- !!
- !! ** Action : - read namsbc parameters
- !! - nsbc: type of sbc
- !!----------------------------------------------------------------------
- INTEGER, INTENT(in) :: Kbb, Kmm, Kaa ! ocean time level indices
- INTEGER :: ios, icpt ! local integer
- LOGICAL :: ll_purecpl, ll_opa, ll_not_nemo ! local logical
- !!
- NAMELIST/namsbc/ nn_fsbc , &
- & ln_usr , ln_flx , ln_blk , &
- & ln_cpl , ln_mixcpl, nn_components, &
- & nn_ice , ln_ice_embd, &
- & ln_traqsr, ln_dm2dc , &
- & ln_rnf , nn_fwb , ln_ssr , ln_isf , ln_apr_dyn , &
- & ln_wave , ln_cdgw , ln_sdw , ln_tauwoc , ln_stcor , &
- & ln_tauw , nn_lsm, nn_sdrift
- !!----------------------------------------------------------------------
- !
- IF(lwp) THEN
- WRITE(numout,*)
- WRITE(numout,*) 'sbc_init : surface boundary condition setting'
- WRITE(numout,*) '~~~~~~~~ '
- ENDIF
- !
- ! !** read Surface Module namelist
- REWIND( numnam_ref ) !* Namelist namsbc in reference namelist : Surface boundary
- READ ( numnam_ref, namsbc, IOSTAT = ios, ERR = 901)
-901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc in reference namelist', lwp )
- REWIND( numnam_cfg ) !* Namelist namsbc in configuration namelist : Parameters of the run
- READ ( numnam_cfg, namsbc, IOSTAT = ios, ERR = 902 )
-902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc in configuration namelist', lwp )
- IF(lwm) WRITE( numond, namsbc )
- !
-#if defined key_mpp_mpi
- ncom_fsbc = nn_fsbc ! make nn_fsbc available for lib_mpp
-#endif
- ! !* overwrite namelist parameter using CPP key information
-#if defined key_agrif
- IF( Agrif_Root() ) THEN ! AGRIF zoom (cf r1242: possibility to run without ice in fine grid)
- IF( lk_si3 ) nn_ice = 2
- IF( lk_cice ) nn_ice = 3
- ENDIF
-#else
- IF( lk_si3 ) nn_ice = 2
- IF( lk_cice ) nn_ice = 3
-#endif
- !
- IF(lwp) THEN !* Control print
- WRITE(numout,*) ' Namelist namsbc (partly overwritten with CPP key setting)'
- WRITE(numout,*) ' frequency update of sbc (and ice) nn_fsbc = ', nn_fsbc
- WRITE(numout,*) ' Type of air-sea fluxes : '
- WRITE(numout,*) ' user defined formulation ln_usr = ', ln_usr
- WRITE(numout,*) ' flux formulation ln_flx = ', ln_flx
- WRITE(numout,*) ' bulk formulation ln_blk = ', ln_blk
- WRITE(numout,*) ' Type of coupling (Ocean/Ice/Atmosphere) : '
- WRITE(numout,*) ' ocean-atmosphere coupled formulation ln_cpl = ', ln_cpl
- WRITE(numout,*) ' mixed forced-coupled formulation ln_mixcpl = ', ln_mixcpl
-!!gm lk_oasis is controlled by key_oasis3 ===>>> It shoud be removed from the namelist
- WRITE(numout,*) ' OASIS coupling (with atm or sas) lk_oasis = ', lk_oasis
- WRITE(numout,*) ' components of your executable nn_components = ', nn_components
- WRITE(numout,*) ' Sea-ice : '
- WRITE(numout,*) ' ice management in the sbc (=0/1/2/3) nn_ice = ', nn_ice
- WRITE(numout,*) ' ice embedded into ocean ln_ice_embd = ', ln_ice_embd
- WRITE(numout,*) ' Misc. options of sbc : '
- WRITE(numout,*) ' Light penetration in temperature Eq. ln_traqsr = ', ln_traqsr
- WRITE(numout,*) ' daily mean to diurnal cycle qsr ln_dm2dc = ', ln_dm2dc
- WRITE(numout,*) ' Sea Surface Restoring on SST and/or SSS ln_ssr = ', ln_ssr
- WRITE(numout,*) ' FreshWater Budget control (=0/1/2) nn_fwb = ', nn_fwb
- WRITE(numout,*) ' Patm gradient added in ocean & ice Eqs. ln_apr_dyn = ', ln_apr_dyn
- WRITE(numout,*) ' runoff / runoff mouths ln_rnf = ', ln_rnf
- WRITE(numout,*) ' iceshelf formulation ln_isf = ', ln_isf
- WRITE(numout,*) ' nb of iterations if land-sea-mask applied nn_lsm = ', nn_lsm
- WRITE(numout,*) ' surface wave ln_wave = ', ln_wave
- WRITE(numout,*) ' Stokes drift corr. to vert. velocity ln_sdw = ', ln_sdw
- WRITE(numout,*) ' vertical parametrization nn_sdrift = ', nn_sdrift
- WRITE(numout,*) ' wave modified ocean stress ln_tauwoc = ', ln_tauwoc
- WRITE(numout,*) ' wave modified ocean stress component ln_tauw = ', ln_tauw
- WRITE(numout,*) ' Stokes coriolis term ln_stcor = ', ln_stcor
- WRITE(numout,*) ' neutral drag coefficient (CORE,NCAR) ln_cdgw = ', ln_cdgw
- ENDIF
- !
- IF( .NOT.ln_wave ) THEN
- ln_sdw = .false. ; ln_cdgw = .false. ; ln_tauwoc = .false. ; ln_tauw = .false. ; ln_stcor = .false.
- ENDIF
- IF( ln_sdw ) THEN
- IF( .NOT.(nn_sdrift==jp_breivik_2014 .OR. nn_sdrift==jp_li_2017 .OR. nn_sdrift==jp_peakfr) ) &
- CALL ctl_stop( 'The chosen nn_sdrift for Stokes drift vertical velocity must be 0, 1, or 2' )
- ENDIF
- ll_st_bv2014 = ( nn_sdrift==jp_breivik_2014 )
- ll_st_li2017 = ( nn_sdrift==jp_li_2017 )
- ll_st_bv_li = ( ll_st_bv2014 .OR. ll_st_li2017 )
- ll_st_peakfr = ( nn_sdrift==jp_peakfr )
- IF( ln_tauwoc .AND. ln_tauw ) &
- CALL ctl_stop( 'More than one method for modifying the ocean stress has been selected ', &
- '(ln_tauwoc=.true. and ln_tauw=.true.)' )
- IF( ln_tauwoc ) &
- CALL ctl_warn( 'You are subtracting the wave stress to the ocean (ln_tauwoc=.true.)' )
- IF( ln_tauw ) &
- CALL ctl_warn( 'The wave modified ocean stress components are used (ln_tauw=.true.) ', &
- 'This will override any other specification of the ocean stress' )
- !
- 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' )
- ENDIF
- ! !** check option consistency
- !
- IF(lwp) WRITE(numout,*) !* Single / Multi - executable (NEMO / OPA+SAS)
- SELECT CASE( nn_components )
- CASE( jp_iam_nemo )
- IF(lwp) WRITE(numout,*) ' ==>>> NEMO configured as a single executable (i.e. including both OPA and Surface module)'
- CASE( jp_iam_opa )
- IF(lwp) WRITE(numout,*) ' ==>>> Multi executable configuration. Here, OPA component'
- IF( .NOT.lk_oasis ) CALL ctl_stop( 'sbc_init : OPA-SAS coupled via OASIS, but key_oasis3 disabled' )
- IF( ln_cpl ) CALL ctl_stop( 'sbc_init : OPA-SAS coupled via OASIS, but ln_cpl = T in OPA' )
- IF( ln_mixcpl ) CALL ctl_stop( 'sbc_init : OPA-SAS coupled via OASIS, but ln_mixcpl = T in OPA' )
- CASE( jp_iam_sas )
- IF(lwp) WRITE(numout,*) ' ==>>> Multi executable configuration. Here, SAS component'
- IF( .NOT.lk_oasis ) CALL ctl_stop( 'sbc_init : OPA-SAS coupled via OASIS, but key_oasis3 disabled' )
- IF( ln_mixcpl ) CALL ctl_stop( 'sbc_init : OPA-SAS coupled via OASIS, but ln_mixcpl = T in OPA' )
- CASE DEFAULT
- CALL ctl_stop( 'sbc_init : unsupported value for nn_components' )
- END SELECT
- ! !* coupled options
- IF( ln_cpl ) THEN
- IF( .NOT. lk_oasis ) CALL ctl_stop( 'sbc_init : coupled mode with an atmosphere model (ln_cpl=T)', &
- & ' required to defined key_oasis3' )
- ENDIF
- IF( ln_mixcpl ) THEN
- IF( .NOT. lk_oasis ) CALL ctl_stop( 'sbc_init : mixed forced-coupled mode (ln_mixcpl=T) ', &
- & ' required to defined key_oasis3' )
- IF( .NOT.ln_cpl ) CALL ctl_stop( 'sbc_init : mixed forced-coupled mode (ln_mixcpl=T) requires ln_cpl = T' )
- IF( nn_components /= jp_iam_nemo ) &
- & CALL ctl_stop( 'sbc_init : the mixed forced-coupled mode (ln_mixcpl=T) ', &
- & ' not yet working with sas-opa coupling via oasis' )
- ENDIF
- ! !* sea-ice
- SELECT CASE( nn_ice )
- CASE( 0 ) !- no ice in the domain
- CASE( 1 ) !- Ice-cover climatology ("Ice-if" model)
- CASE( 2 ) !- SI3 ice model
- CASE( 3 ) !- CICE ice model
- IF( .NOT.( ln_blk .OR. ln_cpl ) ) CALL ctl_stop( 'sbc_init : CICE sea-ice model requires ln_blk or ln_cpl = T' )
- IF( lk_agrif ) CALL ctl_stop( 'sbc_init : CICE sea-ice model not currently available with AGRIF' )
- CASE DEFAULT !- not supported
- END SELECT
- IF( ln_diurnal .AND. .NOT. ln_blk ) CALL ctl_stop( "sbc_init: diurnal flux processing only implemented for bulk forcing" )
- !
- ! !** allocate and set required variables
- !
- ! !* allocate sbc arrays
- IF( sbc_oce_alloc() /= 0 ) CALL ctl_stop( 'sbc_init : unable to allocate sbc_oce arrays' )
-#if ! defined key_si3 && ! defined key_cice
- IF( sbc_ice_alloc() /= 0 ) CALL ctl_stop( 'sbc_init : unable to allocate sbc_ice arrays' )
-#endif
- !
- IF( .NOT.ln_isf ) THEN !* No ice-shelf in the domain : allocate and set to zero
- IF( sbc_isf_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_init : unable to allocate sbc_isf arrays' )
- fwfisf (:,:) = 0._wp ; risf_tsc (:,:,:) = 0._wp
- fwfisf_b(:,:) = 0._wp ; risf_tsc_b(:,:,:) = 0._wp
- END IF
- IF( nn_ice == 0 ) THEN !* No sea-ice in the domain : ice fraction is always zero
- IF( nn_components /= jp_iam_opa ) fr_i(:,:) = 0._wp ! except for OPA in SAS-OPA coupled case
- ENDIF
- !
- sfx (:,:) = 0._wp !* salt flux due to freezing/melting
- fmmflx(:,:) = 0._wp !* freezing minus melting flux
-
- taum(:,:) = 0._wp !* wind stress module (needed in GLS in case of reduced restart)
-
- ! ! Choice of the Surface Boudary Condition (set nsbc)
- IF( ln_dm2dc ) THEN !* daily mean to diurnal cycle
- nday_qsr = -1 ! allow initialization at the 1st call
- IF( .NOT.( ln_flx .OR. ln_blk ) .AND. nn_components /= jp_iam_opa ) &
- & CALL ctl_stop( 'qsr diurnal cycle from daily values requires a flux or bulk formulation' )
- ENDIF
- ! !* Choice of the Surface Boudary Condition
- ! (set nsbc)
- !
- ll_purecpl = ln_cpl .AND. .NOT.ln_mixcpl
- ll_opa = nn_components == jp_iam_opa
- ll_not_nemo = nn_components /= jp_iam_nemo
- icpt = 0
- !
- IF( ln_usr ) THEN ; nsbc = jp_usr ; icpt = icpt + 1 ; ENDIF ! user defined formulation
- IF( ln_flx ) THEN ; nsbc = jp_flx ; icpt = icpt + 1 ; ENDIF ! flux formulation
- IF( ln_blk ) THEN ; nsbc = jp_blk ; icpt = icpt + 1 ; ENDIF ! bulk formulation
- IF( ll_purecpl ) THEN ; nsbc = jp_purecpl ; icpt = icpt + 1 ; ENDIF ! Pure Coupled formulation
- IF( ll_opa ) THEN ; nsbc = jp_none ; icpt = icpt + 1 ; ENDIF ! opa coupling via SAS module
- !
- IF( icpt /= 1 ) CALL ctl_stop( 'sbc_init : choose ONE and only ONE sbc option' )
- !
- IF(lwp) THEN !- print the choice of surface flux formulation
- WRITE(numout,*)
- SELECT CASE( nsbc )
- CASE( jp_usr ) ; WRITE(numout,*) ' ==>>> user defined forcing formulation'
- CASE( jp_flx ) ; WRITE(numout,*) ' ==>>> flux formulation'
- CASE( jp_blk ) ; WRITE(numout,*) ' ==>>> bulk formulation'
- CASE( jp_purecpl ) ; WRITE(numout,*) ' ==>>> pure coupled formulation'
-!!gm abusive use of jp_none ?? ===>>> need to be check and changed by adding a jp_sas parameter
- CASE( jp_none ) ; WRITE(numout,*) ' ==>>> OPA coupled to SAS via oasis'
- IF( ln_mixcpl ) WRITE(numout,*) ' + forced-coupled mixed formulation'
- END SELECT
- IF( ll_not_nemo ) WRITE(numout,*) ' + OASIS coupled SAS'
- ENDIF
- !
- ! !* OASIS initialization
- !
- IF( lk_oasis ) CALL sbc_cpl_init( nn_ice ) ! Must be done before: (1) first time step
- ! ! (2) the use of nn_fsbc
- ! nn_fsbc initialization if OPA-SAS coupling via OASIS
- ! SAS time-step has to be declared in OASIS (mandatory) -> nn_fsbc has to be modified accordingly
- IF( nn_components /= jp_iam_nemo ) THEN
- IF( nn_components == jp_iam_opa ) nn_fsbc = cpl_freq('O_SFLX') / NINT(rn_Dt)
- IF( nn_components == jp_iam_sas ) nn_fsbc = cpl_freq('I_SFLX') / NINT(rn_Dt)
- !
- IF(lwp)THEN
- WRITE(numout,*)
- WRITE(numout,*)" OPA-SAS coupled via OASIS : nn_fsbc re-defined from OASIS namcouple ", nn_fsbc
- WRITE(numout,*)
- ENDIF
- ENDIF
- !
- ! !* check consistency between model timeline and nn_fsbc
- IF( MOD( nitend - nit000 + 1, nn_fsbc) /= 0 .OR. &
- MOD( nstock , nn_fsbc) /= 0 ) THEN
- WRITE(ctmp1,*) 'sbc_init : experiment length (', nitend - nit000 + 1, ') or nstock (', nstock, &
- & ' is NOT a multiple of nn_fsbc (', nn_fsbc, ')'
- CALL ctl_stop( ctmp1, 'Impossible to properly do model restart' )
- ENDIF
- !
- IF( MOD( rday, REAL(nn_fsbc, wp) * rn_Dt ) /= 0 ) &
- & CALL ctl_warn( 'sbc_init : nn_fsbc is NOT a multiple of the number of time steps in a day' )
- !
- IF( ln_dm2dc .AND. NINT(rday) / ( nn_fsbc * NINT(rn_Dt) ) < 8 ) &
- & CALL ctl_warn( 'sbc_init : diurnal cycle for qsr: the sampling of the diurnal cycle is too small...' )
- !
-
- ! !** associated modules : initialization
- !
- CALL sbc_ssm_init ( Kbb, Kmm ) ! Sea-surface mean fields initialization
- !
- IF( ln_blk ) CALL sbc_blk_init ! bulk formulae initialization
-
- IF( ln_ssr ) CALL sbc_ssr_init ! Sea-Surface Restoring initialization
- !
- IF( ln_isf ) CALL sbc_isf_init( Kmm ) ! Compute iceshelves
- !
- CALL sbc_rnf_init( Kmm ) ! Runof initialization
- !
- IF( ln_apr_dyn ) CALL sbc_apr_init ! Atmo Pressure Forcing initialization
- !
-#if defined key_si3
- IF( lk_agrif .AND. nn_ice == 0 ) THEN ! allocate ice arrays in case agrif + ice-model + no-ice in child grid
- IF( sbc_ice_alloc() /= 0 ) CALL ctl_stop('STOP', 'sbc_ice_alloc : unable to allocate arrays' )
- ELSEIF( nn_ice == 2 ) THEN
- CALL ice_init( Kbb, Kmm, Kaa ) ! ICE initialization
- ENDIF
-#endif
- IF( nn_ice == 3 ) CALL cice_sbc_init( nsbc, Kbb, Kmm ) ! CICE initialization
- !
- IF( ln_wave ) CALL sbc_wave_init ! surface wave initialisation
- !
- IF( lwxios ) THEN
- CALL iom_set_rstw_var_active('utau_b')
- CALL iom_set_rstw_var_active('vtau_b')
- CALL iom_set_rstw_var_active('qns_b')
- ! The 3D heat content due to qsr forcing is treated in traqsr
- ! CALL iom_set_rstw_var_active('qsr_b')
- CALL iom_set_rstw_var_active('emp_b')
- CALL iom_set_rstw_var_active('sfx_b')
- ENDIF
-
- END SUBROUTINE sbc_init
-
-
- SUBROUTINE sbc( kt, Kbb, Kmm )
- !!---------------------------------------------------------------------
- !! *** ROUTINE sbc ***
- !!
- !! ** Purpose : provide at each time-step the ocean surface boundary
- !! condition (momentum, heat and freshwater fluxes)
- !!
- !! ** Method : blah blah to be written ?????????
- !! CAUTION : never mask the surface stress field (tke sbc)
- !!
- !! ** 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 , vtau , qns , qsr , emp , sfx , qrp , erp
- !! - updte the ice fraction : fr_i
- !!----------------------------------------------------------------------
- INTEGER, INTENT(in) :: kt ! ocean time step
- INTEGER, INTENT(in) :: Kbb, Kmm ! ocean time level indices
- !
- 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
-
- !!---------------------------------------------------------------------
- !
- IF( ln_timing ) CALL timing_start('sbc')
- !
- ! ! ---------------------------------------- !
- 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 (:,:)
- IF ( ln_rnf ) THEN
- rnf_b (:,: ) = rnf (:,: )
- rnf_tsc_b(:,:,:) = rnf_tsc(:,:,:)
- ENDIF
- IF( ln_isf ) THEN
- fwfisf_b (:,: ) = fwfisf (:,: )
- risf_tsc_b(:,:,:) = risf_tsc(:,:,:)
- ENDIF
- !
- ENDIF
- ! ! ---------------------------------------- !
- ! ! forcing field computation !
- ! ! ---------------------------------------- !
- !
- ll_sas = nn_components == jp_iam_sas ! component flags
- ll_opa = nn_components == jp_iam_opa
- !
- IF( .NOT.ll_sas ) CALL sbc_ssm ( kt, Kbb, Kmm ) ! mean ocean sea surface variables (sst_m, sss_m, ssu_m, ssv_m)
- IF( ln_wave ) CALL sbc_wave( kt, Kmm ) ! surface waves
-
- !
- ! !== sbc formulation ==!
- !
- SELECT CASE( nsbc ) ! Compute ocean surface boundary condition
- ! ! (i.e. utau,vtau, qns, qsr, emp, sfx)
- CASE( jp_usr ) ; CALL usrdef_sbc_oce( kt, Kbb, Kmm ) ! user defined formulation
- CASE( jp_flx ) ; CALL sbc_flx ( kt ) ! flux formulation
- CASE( jp_blk )
- IF( ll_sas ) CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice, Kbb, Kmm ) ! OPA-SAS coupling: SAS receiving fields from OPA
- CALL sbc_blk ( kt ) ! bulk 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 ) ! OPA-SAS coupling: OPA 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_tauwoc .OR. ln_tauw) ) CALL sbc_wstress( ) ! Wind stress provided by waves
- !
- ! !== 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)
-#if defined key_si3
- CASE( 2 ) ; CALL ice_stp ( kt, Kbb, Kmm, nsbc ) ! SI3 ice model
-#endif
- CASE( 3 ) ; CALL sbc_ice_cice ( kt, nsbc ) ! CICE ice model
- END SELECT
-
- IF( ln_icebergs ) THEN
- CALL icb_stp( kt ) ! compute icebergs
- ! icebergs may advect into haloes during the icb step and alter emp.
- ! A lbc_lnk is necessary here to ensure restartability (#2113)
- IF( .NOT. ln_passive_mode ) CALL lbc_lnk( 'sbcmod', emp, 'T', 1. ) ! ensure restartability with icebergs
- ENDIF
-
- IF( ln_isf ) CALL sbc_isf( kt, Kmm ) ! compute iceshelves
-
- 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
-
- IF( nn_fwb /= 0 ) CALL sbc_fwb( kt, nn_fwb, nn_fsbc, Kmm ) ! control the freshwater budget
-
- ! Special treatment of freshwater fluxes over closed seas in the model domain
- ! Should not be run if ln_diurnal_only
- IF( l_sbc_clo .AND. (.NOT. ln_diurnal_only) ) 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. )
- 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
- ENDIF
- !
- IF( kt == nit000 ) THEN ! set the forcing field at nit000 - 1 !
- ! ! ---------------------------------------- !
- IF( ln_rstart .AND. & !* Restart: read in restart file
- & iom_varid( numror, 'utau_b', ldstop = .FALSE. ) > 0 ) THEN
- IF(lwp) WRITE(numout,*) ' nit000-1 surface forcing fields red in the restart file'
- CALL iom_get( numror, jpdom_autoglo, 'utau_b', utau_b, ldxios = lrxios ) ! before i-stress (U-point)
- CALL iom_get( numror, jpdom_autoglo, 'vtau_b', vtau_b, ldxios = lrxios ) ! before j-stress (V-point)
- CALL iom_get( numror, jpdom_autoglo, 'qns_b' , qns_b, ldxios = lrxios ) ! before non solar heat flux (T-point)
- ! The 3D heat content due to qsr forcing is treated in traqsr
- ! CALL iom_get( numror, jpdom_autoglo, 'qsr_b' , qsr_b, ldxios = lrxios ) ! before solar heat flux (T-point)
- CALL iom_get( numror, jpdom_autoglo, 'emp_b', emp_b, ldxios = lrxios ) ! before freshwater flux (T-point)
- ! 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_autoglo, 'sfx_b', sfx_b, ldxios = lrxios ) ! 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(:,:)
- qns_b (:,:) = qns (:,:)
- emp_b (:,:) = emp (:,:)
- sfx_b (:,:) = sfx (:,:)
- ENDIF
- ENDIF
- ! ! ---------------------------------------- !
- IF( lrst_oce ) THEN ! Write in the ocean restart file !
- ! ! ---------------------------------------- !
- IF(lwp) WRITE(numout,*)
- IF(lwp) WRITE(numout,*) 'sbc : ocean surface forcing fields written in ocean restart file ', &
- & 'at it= ', kt,' date= ', ndastp
- IF(lwp) WRITE(numout,*) '~~~~'
- IF( lwxios ) CALL iom_swap( cwxios_context )
- CALL iom_rstput( kt, nitrst, numrow, 'utau_b' , utau, ldxios = lwxios )
- CALL iom_rstput( kt, nitrst, numrow, 'vtau_b' , vtau, ldxios = lwxios )
- CALL iom_rstput( kt, nitrst, numrow, 'qns_b' , qns, ldxios = lwxios )
- ! 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, ldxios = lwxios )
- CALL iom_rstput( kt, nitrst, numrow, 'sfx_b' , sfx, ldxios = lwxios )
- IF( lwxios ) CALL iom_swap( cxios_context )
- ENDIF
- ! ! ---------------------------------------- !
- ! ! Outputs and control print !
- ! ! ---------------------------------------- !
- IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN
- CALL iom_put( "empmr" , emp - rnf ) ! upward water flux
- CALL iom_put( "empbmr" , emp_b - rnf ) ! before upward water flux ( needed to recalculate the time evolution of ssh in offline )
- 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
- 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
- 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
- ENDIF
- !
- CALL iom_put( "utau", utau ) ! i-wind stress (stress can be updated at each time step in sea-ice)
- CALL iom_put( "vtau", vtau ) ! j-wind stress
- !
- IF(ln_ctl) 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 + fwfisf) , clinfo1=' emp-rnf - : ' , mask1=tmask )
- CALL prt_ctl(tab2d_1=(sfx-rnf + fwfisf) , 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 )
- ENDIF
-
- IF( kt == nitend ) CALL sbc_final ! Close down surface module if necessary
- !
- IF( ln_timing ) CALL timing_stop('sbc')
- !
- END SUBROUTINE sbc
-
-
- SUBROUTINE sbc_final
- !!---------------------------------------------------------------------
- !! *** ROUTINE sbc_final ***
- !!
- !! ** Purpose : Finalize CICE (if used)
- !!---------------------------------------------------------------------
- !
- IF( nn_ice == 3 ) CALL cice_sbc_final
- !
- END SUBROUTINE sbc_final
-
- !!======================================================================
-END MODULE sbcmod
Index: /NEMO/branches/2020/r12377_ticket2386/tests/CANAL/MY_SRC/stpctl.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/CANAL/MY_SRC/stpctl.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/CANAL/MY_SRC/stpctl.F90 (revision 13540)
@@ -19,12 +19,12 @@
USE dom_oce ! ocean space and time domain variables
USE c1d ! 1D vertical configuration
+ USE zdf_oce , ONLY : ln_zad_Aimp ! ocean vertical physics variables
+ USE wet_dry, ONLY : ll_wd, ssh_ref ! reference depth for negative bathy
+ !
USE diawri ! Standard run outputs (dia_wri_state routine)
- !
USE in_out_manager ! I/O manager
USE lbclnk ! ocean lateral boundary conditions (or mpp link)
USE lib_mpp ! distributed memory computing
- USE zdf_oce , ONLY : ln_zad_Aimp ! ocean vertical physics variables
- USE wet_dry, ONLY : ll_wd, ssh_ref ! reference depth for negative bathy
-
+ !
USE netcdf ! NetCDF library
IMPLICIT NONE
@@ -33,6 +33,6 @@
PUBLIC stp_ctl ! routine called by step.F90
- INTEGER :: idrun, idtime, idssh, idu, ids1, ids2, idt1, idt2, idc1, idw1, istatus
- LOGICAL :: lsomeoce
+ INTEGER :: nrunid ! netcdf file id
+ INTEGER, DIMENSION(8) :: nvarid ! netcdf variable id
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -42,5 +42,5 @@
CONTAINS
- SUBROUTINE stp_ctl( kt, Kbb, Kmm, kindic )
+ SUBROUTINE stp_ctl( kt, Kmm )
!!----------------------------------------------------------------------
!! *** ROUTINE stp_ctl ***
@@ -49,6 +49,5 @@
!!
!! ** Method : - Save the time step in numstp
- !! - Print it each 50 time steps
- !! - Stop the run IF problem encountered by setting indic=-3
+ !! - Stop the run IF problem encountered by setting nstop > 0
!! Problems checked: |ssh| maximum larger than 10 m
!! |U| maximum larger than 10 m/s
@@ -57,141 +56,256 @@
!! ** Actions : "time.step" file = last ocean time-step
!! "run.stat" file = run statistics
- !! nstop indicator sheared among all local domain (lk_mpp=T)
+ !! nstop indicator sheared among all local domain
!!----------------------------------------------------------------------
INTEGER, INTENT(in ) :: kt ! ocean time-step index
- INTEGER, INTENT(in ) :: Kbb, Kmm ! ocean time level index
- INTEGER, INTENT(inout) :: kindic ! error indicator
- !!
- INTEGER :: ji, jj, jk ! dummy loop indices
- INTEGER, DIMENSION(2) :: ih ! min/max loc indices
- INTEGER, DIMENSION(3) :: iu, is1, is2 ! min/max loc indices
- REAL(wp) :: zzz ! local real
- REAL(wp), DIMENSION(9) :: zmax
- LOGICAL :: ll_wrtstp, ll_colruns, ll_wrtruns
- CHARACTER(len=20) :: clname
- !!----------------------------------------------------------------------
- !
- ll_wrtstp = ( MOD( kt, sn_cfctl%ptimincr ) == 0 ) .OR. ( kt == nitend )
- ll_colruns = ll_wrtstp .AND. ( ln_ctl .OR. sn_cfctl%l_runstat )
- ll_wrtruns = ll_colruns .AND. lwm
- IF( kt == nit000 .AND. lwp ) THEN
- WRITE(numout,*)
- WRITE(numout,*) 'stp_ctl : time-stepping control'
- WRITE(numout,*) '~~~~~~~'
- ! ! open time.step file
- IF( lwm ) CALL ctl_opn( numstp, 'time.step', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea )
- ! ! open run.stat file(s) at start whatever
- ! ! the value of sn_cfctl%ptimincr
- IF( lwm .AND. ( ln_ctl .OR. sn_cfctl%l_runstat ) ) THEN
+ INTEGER, INTENT(in ) :: Kmm ! ocean time level index
+ !!
+ INTEGER :: ji ! dummy loop indices
+ INTEGER :: idtime, istatus
+ INTEGER , DIMENSION(9) :: iareasum, iareamin, iareamax
+ INTEGER , DIMENSION(3,4) :: iloc ! min/max loc indices
+ REAL(wp) :: zzz ! local real
+ REAL(wp), DIMENSION(9) :: zmax, zmaxlocal
+ LOGICAL :: ll_wrtstp, ll_colruns, ll_wrtruns
+ LOGICAL, DIMENSION(jpi,jpj,jpk) :: llmsk
+ CHARACTER(len=20) :: clname
+ !!----------------------------------------------------------------------
+ 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
+ !
+ IF( kt == nit000 ) THEN
+ !
+ IF( lwp ) THEN
+ WRITE(numout,*)
+ WRITE(numout,*) 'stp_ctl : time-stepping control'
+ WRITE(numout,*) '~~~~~~~'
+ ENDIF
+ ! ! open time.step ascii file, done only by 1st subdomain
+ IF( lwm ) CALL ctl_opn( numstp, 'time.step', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea )
+ !
+ IF( ll_wrtruns ) THEN
+ ! ! open run.stat ascii file, done only by 1st subdomain
CALL ctl_opn( numrun, 'run.stat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea )
+ ! ! open run.stat.nc netcdf file, done only by 1st subdomain
clname = 'run.stat.nc'
IF( .NOT. Agrif_Root() ) clname = TRIM(Agrif_CFixed())//"_"//TRIM(clname)
- istatus = NF90_CREATE( TRIM(clname), NF90_CLOBBER, idrun )
- istatus = NF90_DEF_DIM( idrun, 'time', NF90_UNLIMITED, idtime )
- istatus = NF90_DEF_VAR( idrun, 'abs_ssh_max', NF90_DOUBLE, (/ idtime /), idssh )
- istatus = NF90_DEF_VAR( idrun, 'abs_u_max', NF90_DOUBLE, (/ idtime /), idu )
- istatus = NF90_DEF_VAR( idrun, 's_min', NF90_DOUBLE, (/ idtime /), ids1 )
- istatus = NF90_DEF_VAR( idrun, 's_max', NF90_DOUBLE, (/ idtime /), ids2 )
- istatus = NF90_DEF_VAR( idrun, 't_min', NF90_DOUBLE, (/ idtime /), idt1 )
- istatus = NF90_DEF_VAR( idrun, 't_max', NF90_DOUBLE, (/ idtime /), idt2 )
+ istatus = NF90_CREATE( TRIM(clname), NF90_CLOBBER, nrunid )
+ istatus = NF90_DEF_DIM( nrunid, 'time', NF90_UNLIMITED, idtime )
+ istatus = NF90_DEF_VAR( nrunid, 'abs_ssh_max', NF90_DOUBLE, (/ idtime /), nvarid(1) )
+ istatus = NF90_DEF_VAR( nrunid, 'abs_u_max', NF90_DOUBLE, (/ idtime /), nvarid(2) )
+ istatus = NF90_DEF_VAR( nrunid, 's_min', NF90_DOUBLE, (/ idtime /), nvarid(3) )
+ istatus = NF90_DEF_VAR( nrunid, 's_max', NF90_DOUBLE, (/ idtime /), nvarid(4) )
+ istatus = NF90_DEF_VAR( nrunid, 't_min', NF90_DOUBLE, (/ idtime /), nvarid(5) )
+ istatus = NF90_DEF_VAR( nrunid, 't_max', NF90_DOUBLE, (/ idtime /), nvarid(6) )
IF( ln_zad_Aimp ) THEN
- istatus = NF90_DEF_VAR( idrun, 'abs_wi_max', NF90_DOUBLE, (/ idtime /), idw1 )
- istatus = NF90_DEF_VAR( idrun, 'Cu_max', NF90_DOUBLE, (/ idtime /), idc1 )
+ istatus = NF90_DEF_VAR( nrunid, 'Cf_max', NF90_DOUBLE, (/ idtime /), nvarid(7) )
+ istatus = NF90_DEF_VAR( nrunid,'abs_wi_max',NF90_DOUBLE, (/ idtime /), nvarid(8) )
ENDIF
- istatus = NF90_ENDDEF(idrun)
- zmax(8:9) = 0._wp ! initialise to zero in case ln_zad_Aimp option is not in use
- ENDIF
- ENDIF
- IF( kt == nit000 ) lsomeoce = COUNT( ssmask(:,:) == 1._wp ) > 0
- !
- IF(lwm .AND. ll_wrtstp) THEN !== current time step ==! ("time.step" file)
+ istatus = NF90_ENDDEF(nrunid)
+ ENDIF
+ !
+ ENDIF
+ !
+ ! !== write current time step ==!
+ ! !== done only by 1st subdomain at writting timestep ==!
+ IF( lwm .AND. ll_wrtstp ) THEN
WRITE ( numstp, '(1x, i8)' ) kt
REWIND( numstp )
ENDIF
- !
- ! !== test of extrema ==!
+ ! !== test of local extrema ==!
+ ! !== done by all processes at every time step ==!
+ !
+ llmsk( 1:Nis1,:,:) = .FALSE. ! exclude halos from the checked region
+ llmsk(Nie1: jpi,:,:) = .FALSE.
+ llmsk(:, 1:Njs1,:) = .FALSE.
+ llmsk(:,Nje1: jpj,:) = .FALSE.
+ !
+ llmsk(Nis0:Nie0,Njs0:Nje0,1) = ssmask(Nis0:Nie0,Njs0:Nje0) == 1._wp ! define only the inner domain
IF( ll_wd ) THEN
- zmax(1) = MAXVAL( ABS( ssh(:,:,Kmm) + ssh_ref*tmask(:,:,1) ) ) ! ssh max
+ zmax(1) = MAXVAL( ABS( ssh(:,:,Kmm) + ssh_ref ), mask = llmsk(:,:,1) ) ! ssh max
ELSE
- zmax(1) = MAXVAL( ABS( ssh(:,:,Kmm) ) ) ! ssh max
- ENDIF
- zmax(2) = MAXVAL( ABS( uu(:,:,:,Kmm) ) ) ! velocity max (zonal only)
- zmax(3) = MAXVAL( -ts(:,:,:,jp_sal,Kmm) , mask = tmask(:,:,:) == 1._wp ) ! minus salinity max
- zmax(4) = MAXVAL( ts(:,:,:,jp_sal,Kmm) , mask = tmask(:,:,:) == 1._wp ) ! salinity max
- zmax(5) = MAXVAL( -ts(:,:,:,jp_tem,Kmm) , mask = tmask(:,:,:) == 1._wp ) ! minus temperature max
- zmax(6) = MAXVAL( ts(:,:,:,jp_tem,Kmm) , mask = tmask(:,:,:) == 1._wp ) ! temperature max
- zmax(7) = REAL( nstop , wp ) ! stop indicator
- IF( ln_zad_Aimp ) THEN
- zmax(8) = MAXVAL( ABS( wi(:,:,:) ) , mask = wmask(:,:,:) == 1._wp ) ! implicit vertical vel. max
- zmax(9) = MAXVAL( Cu_adv(:,:,:) , mask = tmask(:,:,:) == 1._wp ) ! cell Courant no. max
- ENDIF
- !
+ zmax(1) = MAXVAL( ABS( ssh(:,:,Kmm) ), mask = llmsk(:,:,1) ) ! ssh max
+ ENDIF
+ llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain
+ zmax(2) = MAXVAL( ABS( uu(:,:,:,Kmm) ), mask = llmsk ) ! velocity max (zonal only)
+ llmsk(Nis0:Nie0,Njs0:Nje0,:) = tmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain
+ zmax(3) = MAXVAL( -ts(:,:,:,jp_sal,Kmm), mask = llmsk ) ! minus salinity max
+ zmax(4) = MAXVAL( ts(:,:,:,jp_sal,Kmm), mask = llmsk ) ! salinity max
+ IF( ll_colruns .OR. jpnij == 1 ) THEN ! following variables are used only in the netcdf file
+ zmax(5) = MAXVAL( -ts(:,:,:,jp_tem,Kmm), mask = llmsk ) ! minus temperature max
+ zmax(6) = MAXVAL( ts(:,:,:,jp_tem,Kmm), mask = llmsk ) ! temperature max
+ IF( ln_zad_Aimp ) THEN
+ zmax(7) = MAXVAL( Cu_adv(:,:,:) , mask = llmsk ) ! partitioning coeff. max
+ llmsk(:,:,:) = wmask(:,:,:) == 1._wp
+ zmax(8) = MAXVAL( ABS( wi(:,:,:) ) , mask = llmsk ) ! implicit vertical vel. max
+ ELSE
+ zmax(7:8) = 0._wp
+ ENDIF
+ ELSE
+ zmax(5:8) = 0._wp
+ ENDIF
+ zmax(9) = REAL( nstop, wp ) ! stop indicator
+ ! !== get global extrema ==!
+ ! !== done by all processes if writting run.stat ==!
IF( ll_colruns ) THEN
+ zmaxlocal(:) = zmax(:)
CALL mpp_max( "stpctl", zmax ) ! max over the global domain
- nstop = NINT( zmax(7) ) ! nstop indicator sheared among all local domains
- ENDIF
- ! !== run statistics ==! ("run.stat" files)
+ nstop = NINT( zmax(9) ) ! update nstop indicator (now sheared among all local domains)
+ ENDIF
+ ! !== write "run.stat" files ==!
+ ! !== done only by 1st subdomain at writting timestep ==!
IF( ll_wrtruns ) THEN
WRITE(numrun,9500) kt, zmax(1), zmax(2), -zmax(3), zmax(4)
- istatus = NF90_PUT_VAR( idrun, idssh, (/ zmax(1)/), (/kt/), (/1/) )
- istatus = NF90_PUT_VAR( idrun, idu, (/ zmax(2)/), (/kt/), (/1/) )
- istatus = NF90_PUT_VAR( idrun, ids1, (/-zmax(3)/), (/kt/), (/1/) )
- istatus = NF90_PUT_VAR( idrun, ids2, (/ zmax(4)/), (/kt/), (/1/) )
- istatus = NF90_PUT_VAR( idrun, idt1, (/-zmax(5)/), (/kt/), (/1/) )
- istatus = NF90_PUT_VAR( idrun, idt2, (/ zmax(6)/), (/kt/), (/1/) )
+ istatus = NF90_PUT_VAR( nrunid, nvarid(1), (/ zmax(1)/), (/kt/), (/1/) )
+ istatus = NF90_PUT_VAR( nrunid, nvarid(2), (/ zmax(2)/), (/kt/), (/1/) )
+ istatus = NF90_PUT_VAR( nrunid, nvarid(3), (/-zmax(3)/), (/kt/), (/1/) )
+ istatus = NF90_PUT_VAR( nrunid, nvarid(4), (/ zmax(4)/), (/kt/), (/1/) )
+ istatus = NF90_PUT_VAR( nrunid, nvarid(5), (/-zmax(5)/), (/kt/), (/1/) )
+ istatus = NF90_PUT_VAR( nrunid, nvarid(6), (/ zmax(6)/), (/kt/), (/1/) )
IF( ln_zad_Aimp ) THEN
- istatus = NF90_PUT_VAR( idrun, idw1, (/ zmax(8)/), (/kt/), (/1/) )
- istatus = NF90_PUT_VAR( idrun, idc1, (/ zmax(9)/), (/kt/), (/1/) )
- ENDIF
- IF( MOD( kt , 100 ) == 0 ) istatus = NF90_SYNC(idrun)
- IF( kt == nitend ) istatus = NF90_CLOSE(idrun)
+ istatus = NF90_PUT_VAR( nrunid, nvarid(7), (/ zmax(7)/), (/kt/), (/1/) )
+ istatus = NF90_PUT_VAR( nrunid, nvarid(8), (/ zmax(8)/), (/kt/), (/1/) )
+ ENDIF
+ IF( kt == nitend ) istatus = NF90_CLOSE(nrunid)
END IF
- ! !== error handling ==!
- IF( ( ln_ctl .OR. lsomeoce ) .AND. ( & ! have use mpp_max (because ln_ctl=.T.) or contains some ocean points
- & zmax(1) > 20._wp .OR. & ! too large sea surface height ( > 20 m )
- & zmax(2) > 10._wp .OR. & ! too large velocity ( > 10 m/s)
-!!$ & zmax(3) >= 0._wp .OR. & ! negative or zero sea surface salinity
-!!$ & zmax(4) >= 100._wp .OR. & ! too large sea surface salinity ( > 100 )
-!!$ & zmax(4) < 0._wp .OR. & ! too large sea surface salinity (keep this line for sea-ice)
- & ISNAN( zmax(1) + zmax(2) + zmax(3) ) ) ) THEN ! NaN encounter in the tests
- IF( lk_mpp .AND. ln_ctl ) THEN
- CALL mpp_maxloc( 'stpctl', ABS(ssh(:,:,Kmm)) , ssmask(:,:) , zzz, ih )
- CALL mpp_maxloc( 'stpctl', ABS(uu(:,:,:,Kmm)) , umask (:,:,:), zzz, iu )
- CALL mpp_minloc( 'stpctl', ts(:,:,:,jp_sal,Kmm), tmask (:,:,:), zzz, is1 )
- CALL mpp_maxloc( 'stpctl', ts(:,:,:,jp_sal,Kmm), tmask (:,:,:), zzz, is2 )
+ ! !== error handling ==!
+ ! !== done by all processes at every time step ==!
+ !
+ IF( zmax(1) > 20._wp .OR. & ! too large sea surface height ( > 20 m )
+ & zmax(2) > 10._wp .OR. & ! too large velocity ( > 10 m/s)
+!!$ & zmax(3) >= 0._wp .OR. & ! negative or zero sea surface salinity
+!!$ & zmax(4) >= 100._wp .OR. & ! too large sea surface salinity ( > 100 )
+!!$ & zmax(4) < 0._wp .OR. & ! too large sea surface salinity (keep this line for sea-ice)
+ & ISNAN( zmax(1) + zmax(2) + zmax(3) ) .OR. & ! NaN encounter in the tests
+ & ABS( zmax(1) + zmax(2) + zmax(3) ) > HUGE(1._wp) ) THEN ! Infinity encounter in the tests
+ !
+ iloc(:,:) = 0
+ IF( ll_colruns ) THEN ! zmax is global, so it is the same on all subdomains -> no dead lock with mpp_maxloc
+ ! 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
+ llmsk(Nis0:Nie0,Njs0:Nje0,1) = ssmask(Nis0:Nie0,Njs0:Nje0 ) == 1._wp ! define only the inner domain
+ CALL mpp_maxloc( 'stpctl', ABS(ssh(:,:, Kmm)), llmsk(:,:,1), zzz, iloc(1:2,1) ) ! mpp_maxloc ok if mask = F
+ llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain
+ CALL mpp_maxloc( 'stpctl', ABS( uu(:,:,:, Kmm)), llmsk(:,:,:), zzz, iloc(1:3,2) )
+ llmsk(Nis0:Nie0,Njs0:Nje0,:) = tmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain
+ CALL mpp_minloc( 'stpctl', ts(:,:,:,jp_sal,Kmm) , llmsk(:,:,:), zzz, iloc(1:3,3) )
+ CALL mpp_maxloc( 'stpctl', ts(:,:,:,jp_sal,Kmm) , llmsk(:,:,:), zzz, iloc(1:3,4) )
+ ! find which subdomain has the max.
+ iareamin(:) = jpnij+1 ; iareamax(:) = 0 ; iareasum(:) = 0
+ DO ji = 1, 9
+ IF( zmaxlocal(ji) == zmax(ji) ) THEN
+ iareamin(ji) = narea ; iareamax(ji) = narea ; iareasum(ji) = 1
+ ENDIF
+ END DO
+ CALL mpp_min( "stpctl", iareamin ) ! min over the global domain
+ CALL mpp_max( "stpctl", iareamax ) ! max over the global domain
+ 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
+ llmsk(Nis0:Nie0,Njs0:Nje0,1) = ssmask(Nis0:Nie0,Njs0:Nje0 ) == 1._wp ! define only the inner domain
+ iloc(1:2,1) = MAXLOC( ABS( ssh(:,:, Kmm)), mask = llmsk(:,:,1) )
+ 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(:,:,:) )
+ llmsk(Nis0:Nie0,Njs0:Nje0,:) = tmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain
+ 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, 4 ! local domain indices ==> global domain indices, excluding halos
+ iloc(1:2,ji) = (/ mig0(iloc(1,ji)), mjg0(iloc(2,ji)) /)
+ END DO
+ iareamin(:) = narea ; iareamax(:) = narea ; iareasum(:) = 1 ! this is local information
+ ENDIF
+ !
+ WRITE(ctmp1,*) ' stp_ctl: |ssh| > 20 m or |U| > 10 m/s or S <= 0 or S >= 100 or NaN encounter in the tests'
+ CALL wrt_line( ctmp2, kt, '|ssh| max', zmax(1), iloc(:,1), iareasum(1), iareamin(1), iareamax(1) )
+ CALL wrt_line( ctmp3, kt, '|U| max', zmax(2), iloc(:,2), iareasum(2), iareamin(2), iareamax(2) )
+ CALL wrt_line( ctmp4, kt, 'Sal min', -zmax(3), iloc(:,3), iareasum(3), iareamin(3), iareamax(3) )
+ CALL wrt_line( ctmp5, kt, 'Sal max', zmax(4), iloc(:,4), iareasum(4), iareamin(4), iareamax(4) )
+ IF( Agrif_Root() ) THEN
+ WRITE(ctmp6,*) ' ===> output of last computed fields in output.abort* files'
ELSE
- ih(:) = MAXLOC( ABS( ssh(:,:,Kmm) ) ) + (/ nimpp - 1, njmpp - 1 /)
- iu(:) = MAXLOC( ABS( uu (:,:,:,Kmm) ) ) + (/ nimpp - 1, njmpp - 1, 0 /)
- is1(:) = MINLOC( ts(:,:,:,jp_sal,Kmm), mask = tmask(:,:,:) == 1._wp ) + (/ nimpp - 1, njmpp - 1, 0 /)
- is2(:) = MAXLOC( ts(:,:,:,jp_sal,Kmm), mask = tmask(:,:,:) == 1._wp ) + (/ nimpp - 1, njmpp - 1, 0 /)
- ENDIF
-
- WRITE(ctmp1,*) ' stp_ctl: |ssh| > 20 m or |U| > 10 m/s or S <= 0 or S >= 100 or NaN encounter in the tests'
- WRITE(ctmp2,9100) kt, zmax(1), ih(1) , ih(2)
- WRITE(ctmp3,9200) kt, zmax(2), iu(1) , iu(2) , iu(3)
- WRITE(ctmp4,9300) kt, - zmax(3), is1(1), is1(2), is1(3)
- WRITE(ctmp5,9400) kt, zmax(4), is2(1), is2(2), is2(3)
- WRITE(ctmp6,*) ' ===> output of last computed fields in output.abort.nc file'
-
+ WRITE(ctmp6,*) ' ===> output of last computed fields in '//TRIM(Agrif_CFixed())//'_output.abort* files'
+ ENDIF
+ !
CALL dia_wri_state( Kmm, 'output.abort' ) ! create an output.abort file
-
- IF( .NOT. ln_ctl ) THEN
- WRITE(ctmp8,*) 'E R R O R message from sub-domain: ', narea
- CALL ctl_stop( 'STOP', ctmp1, ' ', ctmp8, ' ', ctmp2, ctmp3, ctmp4, ctmp5, ctmp6 )
- ELSE
- CALL ctl_stop( ctmp1, ' ', ctmp2, ctmp3, ctmp4, ctmp5, ' ', ctmp6, ' ' )
- ENDIF
-
- kindic = -3
- !
- ENDIF
- !
-9100 FORMAT (' kt=',i8,' |ssh| max: ',1pg11.4,', at i j : ',2i5)
-9200 FORMAT (' kt=',i8,' |U| max: ',1pg11.4,', at i j k: ',3i5)
-9300 FORMAT (' kt=',i8,' S min: ',1pg11.4,', at i j k: ',3i5)
-9400 FORMAT (' kt=',i8,' S max: ',1pg11.4,', at i j k: ',3i5)
+ !
+ 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 )
+ 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 )
+ ENDIF
+ !
+ ENDIF
+ !
+ IF( nstop > 0 ) THEN ! an error was detected and we did not abort yet...
+ ngrdstop = Agrif_Fixed() ! store which grid got this error
+ IF( .NOT. ll_colruns .AND. jpnij > 1 ) CALL ctl_stop( 'STOP' ) ! we must abort here to avoid MPI deadlock
+ ENDIF
+ !
9500 FORMAT(' it :', i8, ' |ssh|_max: ', D23.16, ' |U|_max: ', D23.16,' S_min: ', D23.16,' S_max: ', D23.16)
!
END SUBROUTINE stp_ctl
+
+
+ SUBROUTINE wrt_line( cdline, kt, cdprefix, pval, kloc, ksum, kmin, kmax )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE wrt_line ***
+ !!
+ !! ** Purpose : write information line
+ !!
+ !!----------------------------------------------------------------------
+ CHARACTER(len=*), INTENT( out) :: cdline
+ CHARACTER(len=*), INTENT(in ) :: cdprefix
+ REAL(wp), INTENT(in ) :: pval
+ INTEGER, DIMENSION(3), INTENT(in ) :: kloc
+ INTEGER, INTENT(in ) :: kt, ksum, kmin, kmax
+ !
+ CHARACTER(len=80) :: clsuff
+ CHARACTER(len=9 ) :: clkt, clsum, clmin, clmax
+ CHARACTER(len=9 ) :: cli, clj, clk
+ CHARACTER(len=1 ) :: clfmt
+ CHARACTER(len=4 ) :: cl4 ! needed to be able to compile with Agrif, I don't know why
+ INTEGER :: ifmtk
+ !!----------------------------------------------------------------------
+ WRITE(clkt , '(i9)') kt
+
+ WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpnij ,wp))) + 1 ! how many digits to we need to write ? (we decide max = 9)
+ !!! WRITE(clsum, '(i'//clfmt//')') ksum ! this is creating a compilation error with AGRIF
+ cl4 = '(i'//clfmt//')' ; WRITE(clsum, cl4) ksum
+ WRITE(clfmt, '(i1)') INT(LOG10(REAL(MAX(1,jpnij-1),wp))) + 1 ! how many digits to we need to write ? (we decide max = 9)
+ cl4 = '(i'//clfmt//')' ; WRITE(clmin, cl4) kmin-1
+ WRITE(clmax, cl4) kmax-1
+ !
+ WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpiglo,wp))) + 1 ! how many digits to we need to write jpiglo? (we decide max = 9)
+ cl4 = '(i'//clfmt//')' ; WRITE(cli, cl4) kloc(1) ! this is ok with AGRIF
+ WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpjglo,wp))) + 1 ! how many digits to we need to write jpjglo? (we decide max = 9)
+ cl4 = '(i'//clfmt//')' ; WRITE(clj, cl4) kloc(2) ! this is ok with AGRIF
+ !
+ IF( ksum == 1 ) THEN ; WRITE(clsuff,9100) TRIM(clmin)
+ ELSE ; WRITE(clsuff,9200) TRIM(clsum), TRIM(clmin), TRIM(clmax)
+ ENDIF
+ IF(kloc(3) == 0) THEN
+ ifmtk = INT(LOG10(REAL(jpk,wp))) + 1 ! how many digits to we need to write jpk? (we decide max = 9)
+ clk = REPEAT(' ', ifmtk) ! create the equivalent in blank string
+ WRITE(cdline,9300) TRIM(ADJUSTL(clkt)), TRIM(ADJUSTL(cdprefix)), pval, TRIM(cli), TRIM(clj), clk(1:ifmtk), TRIM(clsuff)
+ ELSE
+ WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpk,wp))) + 1 ! how many digits to we need to write jpk? (we decide max = 9)
+ !!! WRITE(clk, '(i'//clfmt//')') kloc(3) ! this is creating a compilation error with AGRIF
+ cl4 = '(i'//clfmt//')' ; WRITE(clk, cl4) kloc(3) ! this is ok with AGRIF
+ WRITE(cdline,9400) TRIM(ADJUSTL(clkt)), TRIM(ADJUSTL(cdprefix)), pval, TRIM(cli), TRIM(clj), TRIM(clk), TRIM(clsuff)
+ ENDIF
+ !
+9100 FORMAT('MPI rank ', a)
+9200 FORMAT('found in ', a, ' MPI tasks, spread out among ranks ', a, ' to ', a)
+9300 FORMAT('kt ', a, ' ', a, ' ', 1pg11.4, ' at i j ', a, ' ', a, ' ', a, ' ', a)
+9400 FORMAT('kt ', a, ' ', a, ' ', 1pg11.4, ' at i j k ', a, ' ', a, ' ', a, ' ', a)
+ !
+ END SUBROUTINE wrt_line
+
!!======================================================================
Index: /NEMO/branches/2020/r12377_ticket2386/tests/CANAL/MY_SRC/trazdf.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/CANAL/MY_SRC/trazdf.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/CANAL/MY_SRC/trazdf.F90 (revision 13540)
@@ -35,4 +35,6 @@
PUBLIC tra_zdf_imp ! called by trczdf.F90
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -77,5 +79,5 @@
! JMM avoid negative salinities near river outlet ! Ugly fix
! JMM : restore negative salinities to small salinities:
-!!$ WHERE( pts(:,:,:,jp_sal,Kaa) < 0._wp ) pts(:,:,:,jp_sal,Kaa) = 0.1_wp
+!!$ WHERE( pts(:,:,:,jp_sal,Kaa) < 0._wp ) pts(:,:,:,jp_sal,Kaa) = 0.1_wp
!!gm
@@ -95,6 +97,6 @@
ENDIF
! ! print mean trends (used for debugging)
- IF(ln_ctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Kaa), clinfo1=' zdf - Ta: ', mask1=tmask, &
- & tab3d_2=pts(:,:,:,jp_sal,Kaa), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' )
+ IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Kaa), clinfo1=' zdf - Ta: ', mask1=tmask, &
+ & tab3d_2=pts(:,:,:,jp_sal,Kaa), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' )
!
IF( ln_timing ) CALL timing_stop('tra_zdf')
@@ -154,19 +156,11 @@
IF( l_ldfslp ) THEN ! isoneutral diffusion: add the contribution
IF( ln_traldf_msc ) THEN ! MSC iso-neutral operator
- DO jk = 2, jpkm1
- DO jj = 2, jpjm1
- DO ji = fs_2, fs_jpim1 ! vector opt.
- zwt(ji,jj,jk) = zwt(ji,jj,jk) + akz(ji,jj,jk)
- END DO
- END DO
- END DO
+ 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 jk = 2, jpkm1
- DO jj = 2, jpjm1
- DO ji = fs_2, fs_jpim1 ! vector opt.
- zwt(ji,jj,jk) = zwt(ji,jj,jk) + ah_wslp2(ji,jj,jk)
- END DO
- END DO
- END DO
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
+ zwt(ji,jj,jk) = zwt(ji,jj,jk) + ah_wslp2(ji,jj,jk)
+ END_3D
ENDIF
ENDIF
@@ -174,26 +168,18 @@
! Diagonal, lower (i), upper (s) (including the bottom boundary condition since avt is masked)
IF( ln_zad_Aimp ) THEN ! Adaptive implicit vertical advection
- DO jk = 1, jpkm1
- DO jj = 2, jpjm1
- DO ji = fs_2, fs_jpim1 ! vector opt. (ensure same order of calculation as below if wi=0.)
- 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 DO
- END DO
- END DO
+ 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 jk = 1, jpkm1
- DO jj = 2, jpjm1
- DO ji = fs_2, fs_jpim1 ! vector opt.
- 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 DO
- END DO
- END DO
+ 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
ENDIF
!
@@ -217,46 +203,28 @@
! used as a work space array: its value is modified.
!
- DO jj = 2, jpjm1 !* 1st recurrence: Tk = Dk - Ik Sk-1 / Tk-1 (increasing k)
- DO ji = fs_2, fs_jpim1 ! done one for all passive tracers (so included in the IF instruction)
- zwt(ji,jj,1) = zwd(ji,jj,1)
- END DO
- END DO
- DO jk = 2, jpkm1
- DO jj = 2, jpjm1
- DO ji = fs_2, fs_jpim1
- zwt(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwt(ji,jj,jk-1)
- END DO
- END DO
- END DO
+ DO_2D( 0, 0, 0, 0 )
+ zwt(ji,jj,1) = zwd(ji,jj,1)
+ 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
!
- DO jj = 2, jpjm1 !* 2nd recurrence: Zk = Yk - Ik / Tk-1 Zk-1
- DO ji = fs_2, fs_jpim1
- 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 DO
- END DO
- DO jk = 2, jpkm1
- DO jj = 2, jpjm1
- DO ji = fs_2, fs_jpim1
- 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 DO
- END DO
- END DO
+ DO_2D( 0, 0, 0, 0 )
+ 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 jj = 2, jpjm1 !* 3d recurrence: Xk = (Zk - Sk Xk+1 ) / Tk (result is the after tracer)
- DO ji = fs_2, fs_jpim1
- pt(ji,jj,jpkm1,jn,Kaa) = pt(ji,jj,jpkm1,jn,Kaa) / zwt(ji,jj,jpkm1) * tmask(ji,jj,jpkm1)
- END DO
- END DO
- DO jk = jpk-2, 1, -1
- DO jj = 2, jpjm1
- DO ji = fs_2, fs_jpim1
- 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 DO
- END DO
- END DO
+ DO_2D( 0, 0, 0, 0 )
+ 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
! ! ================= !
END DO ! end tracer loop !
Index: /NEMO/branches/2020/r12377_ticket2386/tests/CANAL/MY_SRC/usrdef_hgr.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/CANAL/MY_SRC/usrdef_hgr.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/CANAL/MY_SRC/usrdef_hgr.F90 (revision 13540)
@@ -26,4 +26,6 @@
PUBLIC usr_def_hgr ! called by domhgr.F90
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -61,7 +63,7 @@
REAL(wp), DIMENSION(:,:), INTENT(out) :: pe1e2u, pe1e2v ! u- & v-surfaces (if reduction in strait) [m2]
!
- INTEGER :: ji, jj ! dummy loop indices
+ INTEGER :: ji, jj ! dummy loop indices
REAL(wp) :: zphi0, zlam0, zbeta, zf0
- REAL(wp) :: zti, zui, ztj, zvj ! local scalars
+ REAL(wp) :: zti, ztj ! local scalars
!!-------------------------------------------------------------------------------
!
@@ -75,6 +77,6 @@
! Position coordinates (in kilometers)
! ==========
- zlam0 = -REAL(NINT(jpiglo*rn_0xratio)-1, wp) * rn_dx
- zphi0 = -REAL(NINT(jpjglo*rn_0yratio)-1, wp) * rn_dy
+ zlam0 = -REAL(NINT(Ni0glo*rn_0xratio)-1, wp) * rn_dx
+ zphi0 = -REAL(NINT(Nj0glo*rn_0yratio)-1, wp) * rn_dy
#if defined key_agrif
@@ -88,20 +90,18 @@
#endif
- DO jj = 1, jpj
- DO ji = 1, jpi
- zti = FLOAT( ji - 1 + nimpp - 1 ) ; ztj = FLOAT( jj - 1 + njmpp - 1 )
- zui = FLOAT( ji - 1 + nimpp - 1 ) + 0.5_wp ; zvj = FLOAT( jj - 1 + njmpp - 1 ) + 0.5_wp
-
- plamt(ji,jj) = zlam0 + rn_dx * zti
- plamu(ji,jj) = zlam0 + rn_dx * zui
- plamv(ji,jj) = plamt(ji,jj)
- plamf(ji,jj) = plamu(ji,jj)
-
- pphit(ji,jj) = zphi0 + rn_dy * ztj
- pphiv(ji,jj) = zphi0 + rn_dy * zvj
- pphiu(ji,jj) = pphit(ji,jj)
- pphif(ji,jj) = pphiv(ji,jj)
- END DO
- END DO
+ DO_2D( 1, 1, 1, 1 )
+ zti = REAL( mig0_oldcmp(ji) - 1, wp ) ! start at i=0 in the global grid without halos
+ ztj = REAL( mjg0_oldcmp(jj) - 1, wp ) ! start at j=0 in the global grid without halos
+
+ plamt(ji,jj) = zlam0 + rn_dx * zti
+ plamu(ji,jj) = zlam0 + rn_dx * ( zti + 0.5_wp )
+ plamv(ji,jj) = plamt(ji,jj)
+ plamf(ji,jj) = plamu(ji,jj)
+
+ pphit(ji,jj) = zphi0 + rn_dy * ztj
+ pphiv(ji,jj) = zphi0 + rn_dy * ( ztj + 0.5_wp )
+ pphiu(ji,jj) = pphit(ji,jj)
+ pphif(ji,jj) = pphiv(ji,jj)
+ END_2D
!
! Horizontal scale factors (in meters)
Index: /NEMO/branches/2020/r12377_ticket2386/tests/CANAL/MY_SRC/usrdef_istate.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/CANAL/MY_SRC/usrdef_istate.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/CANAL/MY_SRC/usrdef_istate.F90 (revision 13540)
@@ -28,4 +28,6 @@
PUBLIC usr_def_istate ! called by istate.F90
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -64,9 +66,24 @@
IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~ '
!
- IF (ln_sshnoise) CALL RANDOM_NUMBER(zrandom)
zjetx = ABS(rn_ujetszx)/2.
zjety = ABS(rn_ujetszy)/2.
!
+ zf0 = 2._wp * omega * SIN( rad * rn_ppgphi0 )
+ !
SELECT CASE(nn_initcase)
+
+ CASE(-1) ! stratif at rest
+
+ ! sea level:
+ pssh(:,:) = 0.
+ ! temperature:
+ pts(:,:,1,jp_tem) = 25. !!30._wp
+ pts(:,:,2:jpk,jp_tem) = 22. !!24._wp
+ ! salinity:
+ pts(:,:,:,jp_sal) = 35._wp
+ ! velocities:
+ pu(:,:,:) = 0.
+ pv(:,:,:) = 0.
+
CASE(0) ! rest
@@ -96,7 +113,7 @@
zbeta = 2._wp * omega * COS( rad * rn_ppgphi0 ) / ra
WHERE( ABS(gphit) <= zjety )
- pssh(:,:) = - rn_uzonal / grav * ( ff_t(:,:) * gphit(:,:) * 1.e3 + 0.5 * zbeta * gphit(:,:) * gphit(:,:) * 1.e6 )
- ELSEWHERE
- pssh(:,:) = - rn_uzonal / grav * ( ff_t(:,:) * SIGN(zjety, gphit(:,:)) * 1.e3 &
+ pssh(:,:) = - rn_uzonal / grav * ( zf0 * gphit(:,:) * 1.e3 + 0.5 * zbeta * gphit(:,:) * gphit(:,:) * 1.e6 )
+ ELSEWHERE
+ pssh(:,:) = - rn_uzonal / grav * ( zf0 * SIGN(zjety, gphit(:,:)) * 1.e3 &
& + 0.5 * zbeta * zjety * zjety * 1.e6 )
END WHERE
@@ -107,5 +124,10 @@
pts(:,:,jpk,jp_sal) = 0.
DO jk=1, jpkm1
- pts(:,:,jk,jp_sal) = gphit(:,:)
+ WHERE( ABS(gphit) <= zjety )
+!!$ WHERE( ABS(gphit) <= zjety*0.5 .AND. ABS(glamt) <= zjety*0.5 ) ! for a square of salt
+ pts(:,:,jk,jp_sal) = 35.
+ ELSEWHERE
+ pts(:,:,jk,jp_sal) = 30.
+ END WHERE
END DO
! velocities:
@@ -132,8 +154,8 @@
WHERE( ABS(gphit) <= zjety )
pssh(:,:) = - SIGN(rn_uzonal, gphit(:,:)) / grav &
- & * ( ff_t(:,:) * gphit(:,:) * 1.e3 + 0.5 * zbeta * gphit(:,:) * gphit(:,:) * 1.e6 )
+ & * ( zf0 * gphit(:,:) * 1.e3 + 0.5 * zbeta * gphit(:,:) * gphit(:,:) * 1.e6 )
ELSEWHERE
pssh(:,:) = - SIGN(rn_uzonal, gphit(:,:)) / grav &
- & * ( ff_t(:,:) * SIGN(zjety, gphit(:,:)) * 1.e3 + 0.5 * zbeta * zjety * zjety * 1.e6 )
+ & * ( zf0 * SIGN(zjety, gphit(:,:)) * 1.e3 + 0.5 * zbeta * zjety * zjety * 1.e6 )
END WHERE
END SELECT
@@ -141,7 +163,7 @@
pts(:,:,:,jp_tem) = 10._wp
! salinity:
- pts(:,:,:,jp_sal) = 2.
- DO jk=1, jpkm1
- WHERE( ABS(gphiv) <= zjety ) pts(:,:,jk,jp_sal) = 2. + SIGN(1.,gphiv(:,:))
+ pts(:,:,:,jp_sal) = 30.
+ DO jk=1, jpkm1
+ WHERE( ABS(gphiv) <= zjety ) pts(:,:,jk,jp_sal) = 30. + SIGN(1.,gphiv(:,:))
END DO
! velocities:
@@ -164,9 +186,7 @@
pssh(:,1) = - ff_t(:,1) / grav * pu(:,1,1) * e2t(:,1)
DO jl=1, jpnj
- DO jj=nldj, nlej
- DO ji=nldi, nlei
- pssh(ji,jj) = pssh(ji,jj-1) - ff_t(ji,jj) / grav * pu(ji,jj,1) * e2t(ji,jj)
- END DO
- END DO
+ DO_2D( 0, 0, 0, 0 )
+ pssh(ji,jj) = pssh(ji,jj-1) - ff_t(ji,jj) / grav * pu(ji,jj,1) * e2t(ji,jj)
+ END_2D
CALL lbc_lnk( 'usrdef_istate', pssh, 'T', 1. )
END DO
@@ -176,5 +196,5 @@
! salinity:
DO jk=1, jpkm1
- pts(:,:,jk,jp_sal) = gphit(:,:)
+ pts(:,:,jk,jp_sal) = pssh(:,:)
END DO
! velocities:
@@ -183,29 +203,26 @@
CASE(4) ! geostrophic zonal pulse
- DO jj=1, jpj
- DO ji=1, jpi
- IF ( ABS(glamt(ji,jj)) <= zjetx ) THEN
- zdu = rn_uzonal
- ELSEIF ( ABS(glamt(ji,jj)) <= zjetx + 100. ) THEN
- zdu = rn_uzonal * ( ( zjetx-ABS(glamt(ji,jj)) )/100. + 1. )
- ELSE
- zdu = 0.
- END IF
- IF ( ABS(gphit(ji,jj)) <= zjety ) THEN
- pssh(ji,jj) = - ff_t(ji,jj) * zdu * gphit(ji,jj) * 1.e3 / grav
- pu(ji,jj,:) = zdu
- pts(ji,jj,:,jp_sal) = zdu / rn_uzonal + 1.
- ELSE
- pssh(ji,jj) = - ff_t(ji,jj) * zdu * SIGN(zjety,gphit(ji,jj)) * 1.e3 / grav
- pu(ji,jj,:) = 0.
- pts(ji,jj,:,jp_sal) = 1.
- END IF
- END DO
- END DO
+ DO_2D( 1, 1, 1, 1 )
+ IF ( ABS(glamt(ji,jj)) <= zjetx ) THEN
+ zdu = rn_uzonal
+ ELSEIF ( ABS(glamt(ji,jj)) <= zjetx + 100. ) THEN
+ zdu = rn_uzonal * ( ( zjetx-ABS(glamt(ji,jj)) )/100. + 1. )
+ ELSE
+ zdu = 0.
+ END IF
+ IF ( ABS(gphit(ji,jj)) <= zjety ) THEN
+ pssh(ji,jj) = - ff_t(ji,jj) * zdu * gphit(ji,jj) * 1.e3 / grav
+ pu(ji,jj,:) = zdu
+ pts(ji,jj,:,jp_sal) = zdu / rn_uzonal + 1.
+ ELSE
+ pssh(ji,jj) = - ff_t(ji,jj) * zdu * SIGN(zjety,gphit(ji,jj)) * 1.e3 / grav
+ pu(ji,jj,:) = 0.
+ pts(ji,jj,:,jp_sal) = 1.
+ END IF
+ END_2D
! temperature:
pts(:,:,:,jp_tem) = 10._wp * ptmask(:,:,:)
pv(:,:,:) = 0.
-
CASE(5) ! vortex
@@ -213,5 +230,5 @@
zf0 = 2._wp * omega * SIN( rad * rn_ppgphi0 )
zumax = rn_vtxmax * SIGN(1._wp, zf0) ! Here Anticyclonic: set zumax=-1 for cyclonic
- zlambda = SQRT(2._wp)*rn_lambda ! Horizontal scale in meters
+ zlambda = SQRT(2._wp)*rn_lambda*1.e3 ! Horizontal scale in meters
zn2 = 3.e-3**2
zH = 0.5_wp * 5000._wp
@@ -220,31 +237,29 @@
zP0 = rho0 * zf0 * zumax * zlambda * SQRT(EXP(1._wp)/2._wp)
!
- DO jj=1, jpj
- DO ji=1, jpi
- zx = glamt(ji,jj) * 1.e3
- zy = gphit(ji,jj) * 1.e3
- ! Surface pressure: P(x,y,z) = F(z) * Psurf(x,y)
- zpsurf = zP0 * EXP(-(zx**2+zy**2)*zr_lambda2) - rho0 * ff_t(ji,jj) * rn_uzonal * zy
- ! Sea level:
- pssh(ji,jj) = 0.
- DO jl=1,5
- zdt = pssh(ji,jj)
- zdzF = (1._wp - EXP(zdt-zH)) / (zH - 1._wp + EXP(-zH)) ! F'(z)
- zrho1 = rho0 * (1._wp + zn2*zdt/grav) - zdzF * zpsurf / grav ! -1/g Dz(P) = -1/g * F'(z) * Psurf(x,y)
- pssh(ji,jj) = zpsurf / (zrho1*grav) * ptmask(ji,jj,1) ! ssh = Psurf / (Rho*g)
- END DO
- ! temperature:
- DO jk=1,jpk
- zdt = pdept(ji,jj,jk)
- zrho1 = rho0 * (1._wp + zn2*zdt/grav)
- IF (zdt < zH) THEN
- zdzF = (1._wp-EXP(zdt-zH)) / (zH-1._wp + EXP(-zH)) ! F'(z)
- zrho1 = zrho1 - zdzF * zpsurf / grav ! -1/g Dz(P) = -1/g * F'(z) * Psurf(x,y)
- ENDIF
- ! pts(ji,jj,jk,jp_tem) = (20._wp + (rho0-zrho1) / 0.28_wp) * ptmask(ji,jj,jk)
- pts(ji,jj,jk,jp_tem) = (10._wp + (rho0-zrho1) / 0.28_wp) * ptmask(ji,jj,jk)
- END DO
+ DO_2D( 1, 1, 1, 1 )
+ zx = glamt(ji,jj) * 1.e3
+ zy = gphit(ji,jj) * 1.e3
+ ! Surface pressure: P(x,y,z) = F(z) * Psurf(x,y)
+ zpsurf = zP0 * EXP(-(zx**2+zy**2)*zr_lambda2) - rho0 * ff_t(ji,jj) * rn_uzonal * zy
+ ! Sea level:
+ pssh(ji,jj) = 0.
+ DO jl=1,5
+ zdt = pssh(ji,jj)
+ zdzF = (1._wp - EXP(zdt-zH)) / (zH - 1._wp + EXP(-zH)) ! F'(z)
+ zrho1 = rho0 * (1._wp + zn2*zdt/grav) - zdzF * zpsurf / grav ! -1/g Dz(P) = -1/g * F'(z) * Psurf(x,y)
+ pssh(ji,jj) = zpsurf / (zrho1*grav) * ptmask(ji,jj,1) ! ssh = Psurf / (Rho*g)
END DO
- END DO
+ ! temperature:
+ DO jk=1,jpk
+ zdt = pdept(ji,jj,jk)
+ zrho1 = rho0 * (1._wp + zn2*zdt/grav)
+ IF (zdt < zH) THEN
+ zdzF = (1._wp-EXP(zdt-zH)) / (zH-1._wp + EXP(-zH)) ! F'(z)
+ zrho1 = zrho1 - zdzF * zpsurf / grav ! -1/g Dz(P) = -1/g * F'(z) * Psurf(x,y)
+ ENDIF
+ ! pts(ji,jj,jk,jp_tem) = (20._wp + (rho0-zrho1) / 0.28_wp) * ptmask(ji,jj,jk)
+ pts(ji,jj,jk,jp_tem) = (10._wp + (rho0-zrho1) / 0.28_wp) * ptmask(ji,jj,jk)
+ END DO
+ END_2D
!
! salinity:
@@ -253,48 +268,44 @@
! velocities:
za = 2._wp * zP0 / zlambda**2
- DO jj=1, jpj
- DO ji=1, jpim1
- zx = glamu(ji,jj) * 1.e3
- zy = gphiu(ji,jj) * 1.e3
- DO jk=1, jpk
- zdu = 0.5_wp * (pdept(ji,jj,jk) + pdept(ji+1,jj,jk))
- IF (zdu < zH) THEN
- zf = (zH-1._wp-zdu+EXP(zdu-zH)) / (zH-1._wp+EXP(-zH))
- zdyPs = - za * zy * EXP(-(zx**2+zy**2)*zr_lambda2) - rho0 * ff_t(ji,jj) * rn_uzonal
- pu(ji,jj,jk) = - zf / ( rho0 * ff_t(ji,jj) ) * zdyPs * ptmask(ji,jj,jk) * ptmask(ji+1,jj,jk)
- ELSE
- pu(ji,jj,jk) = 0._wp
- ENDIF
- END DO
+ DO_2D( 0, 0, 0, 0 )
+ zx = glamu(ji,jj) * 1.e3
+ zy = gphiu(ji,jj) * 1.e3
+ DO jk=1, jpk
+ zdu = 0.5_wp * (pdept(ji,jj,jk) + pdept(ji+1,jj,jk))
+ IF (zdu < zH) THEN
+ zf = (zH-1._wp-zdu+EXP(zdu-zH)) / (zH-1._wp+EXP(-zH))
+ zdyPs = - za * zy * EXP(-(zx**2+zy**2)*zr_lambda2) - rho0 * ff_t(ji,jj) * rn_uzonal
+ pu(ji,jj,jk) = - zf / ( rho0 * ff_t(ji,jj) ) * zdyPs * ptmask(ji,jj,jk) * ptmask(ji+1,jj,jk)
+ ELSE
+ pu(ji,jj,jk) = 0._wp
+ ENDIF
END DO
- END DO
- !
- DO jj=1, jpjm1
- DO ji=1, jpi
- zx = glamv(ji,jj) * 1.e3
- zy = gphiv(ji,jj) * 1.e3
- DO jk=1, jpk
- zdv = 0.5_wp * (pdept(ji,jj,jk) + pdept(ji,jj+1,jk))
- IF (zdv < zH) THEN
- zf = (zH-1._wp-zdv+EXP(zdv-zH)) / (zH-1._wp+EXP(-zH))
- zdxPs = - za * zx * EXP(-(zx**2+zy**2)*zr_lambda2)
- pv(ji,jj,jk) = zf / ( rho0 * ff_f(ji,jj) ) * zdxPs * ptmask(ji,jj,jk) * ptmask(ji,jj+1,jk)
- ELSE
- pv(ji,jj,jk) = 0._wp
- ENDIF
- END DO
+ END_2D
+ !
+ DO_2D( 0, 0, 0, 0 )
+ zx = glamv(ji,jj) * 1.e3
+ zy = gphiv(ji,jj) * 1.e3
+ DO jk=1, jpk
+ zdv = 0.5_wp * (pdept(ji,jj,jk) + pdept(ji,jj+1,jk))
+ IF (zdv < zH) THEN
+ zf = (zH-1._wp-zdv+EXP(zdv-zH)) / (zH-1._wp+EXP(-zH))
+ zdxPs = - za * zx * EXP(-(zx**2+zy**2)*zr_lambda2)
+ pv(ji,jj,jk) = zf / ( rho0 * ff_f(ji,jj) ) * zdxPs * ptmask(ji,jj,jk) * ptmask(ji,jj+1,jk)
+ ELSE
+ pv(ji,jj,jk) = 0._wp
+ ENDIF
END DO
- END DO
+ END_2D
!
END SELECT
-
+
IF (ln_sshnoise) THEN
+ CALL RANDOM_SEED()
CALL RANDOM_NUMBER(zrandom)
pssh(:,:) = pssh(:,:) + ( 0.1 * zrandom(:,:) - 0.05 )
END IF
CALL lbc_lnk( 'usrdef_istate', pssh, 'T', 1. )
- CALL lbc_lnk( 'usrdef_istate', pts, 'T', 1. )
- CALL lbc_lnk( 'usrdef_istate', pu, 'U', -1. )
- CALL lbc_lnk( 'usrdef_istate', pv, 'V', -1. )
+ CALL lbc_lnk( 'usrdef_istate', pts , 'T', 1. )
+ CALL lbc_lnk_multi( 'usrdef_istate', pu, 'U', -1., pv, 'V', -1. )
END SUBROUTINE usr_def_istate
Index: /NEMO/branches/2020/r12377_ticket2386/tests/CANAL/MY_SRC/usrdef_nam.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/CANAL/MY_SRC/usrdef_nam.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/CANAL/MY_SRC/usrdef_nam.F90 (revision 13540)
@@ -14,5 +14,5 @@
!! usr_def_hgr : initialize the horizontal mesh
!!----------------------------------------------------------------------
- USE dom_oce , ONLY: nimpp , njmpp ! i- & j-indices of the local domain
+ USE dom_oce
USE par_oce ! ocean space and time domain
USE phycst ! physical constants
@@ -50,4 +50,5 @@
LOGICAL , PUBLIC :: ln_sshnoise=.false. ! add random noise on initial ssh
REAL(wp), PUBLIC :: rn_lambda = 50. ! gaussian lambda
+ INTEGER , PUBLIC :: nn_perio = 0 ! periodicity of the channel (0=closed, 1=E-W)
!!----------------------------------------------------------------------
@@ -79,7 +80,7 @@
!!
NAMELIST/namusr_def/ rn_domszx, rn_domszy, rn_domszz, rn_dx, rn_dy, rn_dz, rn_0xratio, rn_0yratio &
- & , nn_fcase, rn_ppgphi0, rn_vtxmax, rn_uzonal, rn_ujetszx, rn_ujetszy &
- & , rn_u10, rn_windszx, rn_windszy, rn_uofac &
- & , nn_botcase, nn_initcase, ln_sshnoise, rn_lambda
+ & , nn_fcase, rn_ppgphi0, rn_u10, rn_windszx, rn_windszy & !!, rn_uofac &
+ & , rn_vtxmax, rn_uzonal, rn_ujetszx, rn_ujetszy &
+ & , nn_botcase, nn_initcase, ln_sshnoise, rn_lambda, nn_perio
!!----------------------------------------------------------------------
!
@@ -106,14 +107,12 @@
kk_cfg = INT( rn_dx )
!
- ! Global Domain size: EW_CANAL global domain is 1800 km x 1800 Km x 5000 m
- kpi = NINT( rn_domszx / rn_dx ) + 1
- kpj = NINT( rn_domszy / rn_dy ) + 3
- kpk = NINT( rn_domszz / rn_dz ) + 1
-#if defined key_agrif
- IF( .NOT. Agrif_Root() ) THEN
- kpi = nbcellsx + 2 + 2*nbghostcells
- kpj = nbcellsy + 2 + 2*nbghostcells
+ IF( Agrif_Root() ) THEN ! Global Domain size: EW_CANAL global domain is 1800 km x 1800 Km x 5000 m
+ kpi = NINT( rn_domszx / rn_dx ) + 1
+ kpj = NINT( rn_domszy / rn_dy ) + 3
+ ELSE ! Global Domain size: add nbghostcells + 1 "land" point on each side
+ kpi = nbcellsx + nbghostcells_x + nbghostcells_x + 2
+ kpj = nbcellsy + nbghostcells_y_s + nbghostcells_y_n + 2
ENDIF
-#endif
+ kpk = MAX( 2, NINT( rn_domszz / rn_dz ) + 1 )
!
zh = (kpk-1)*rn_dz
@@ -150,8 +149,8 @@
WRITE(numout,*) ' add random noise on initial ssh ln_sshnoise= ', ln_sshnoise
WRITE(numout,*) ' Gaussian lambda parameter rn_lambda = ', rn_lambda
- WRITE(numout,*) ' '
- WRITE(numout,*) ' Lateral boundary condition of the global domain'
- WRITE(numout,*) ' EW_CANAL : closed basin jperio = ', kperio
+ WRITE(numout,*) ' Periodicity of the basin nn_perio = ', nn_perio
ENDIF
+ ! ! Set the lateral boundary condition of the global domain
+ kperio = nn_perio ! EW_CANAL configuration : closed basin
!
END SUBROUTINE usr_def_nam
Index: /NEMO/branches/2020/r12377_ticket2386/tests/CANAL/MY_SRC/usrdef_sbc.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/CANAL/MY_SRC/usrdef_sbc.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/CANAL/MY_SRC/usrdef_sbc.F90 (revision 13540)
@@ -17,5 +17,5 @@
USE sbc_oce ! Surface boundary condition: ocean fields
USE phycst ! physical constants
- USE usrdef_nam, ONLY : rn_u10, rn_uofac, rn_windszy
+ USE usrdef_nam, ONLY : rn_u10, rn_uofac, rn_windszy, rn_windszx
!
USE in_out_manager ! I/O manager
@@ -38,5 +38,5 @@
CONTAINS
- SUBROUTINE usrdef_sbc_oce( kt, Kmm, Kbb )
+ SUBROUTINE usrdef_sbc_oce( kt, Kbb )
!!---------------------------------------------------------------------
!! *** ROUTINE usr_def_sbc ***
@@ -53,5 +53,5 @@
!!----------------------------------------------------------------------
INTEGER, INTENT(in) :: kt ! ocean time step
- INTEGER, INTENT(in) :: Kbb, Kmm ! ocean time index
+ INTEGER, INTENT(in) :: Kbb ! ocean time index
INTEGER :: ji, jj ! dummy loop indices
REAL(wp) :: zrhoair = 1.22 ! approximate air density [Kg/m3]
@@ -69,7 +69,4 @@
!
utau(:,:) = 0._wp
- IF( rn_u10 /= 0. .AND. rn_windszy > 0. ) THEN
- WHERE( ABS(gphit) <= rn_windszy/2. ) utau(:,:) = zrhocd * rn_u10 * rn_u10
- ENDIF
vtau(:,:) = 0._wp
taum(:,:) = 0._wp
@@ -83,14 +80,22 @@
ENDIF
+ IF( rn_u10 /= 0. .AND. rn_windszy > 0. ) THEN
+ IF( nyear == 1 .AND. nmonth == 1 .AND. nday <= 10 ) THEN
+ WHERE( ABS(gphit) <= rn_windszy/2. .AND. ABS(glamt) <= rn_windszx/2. ) utau(:,:) = zrhocd * rn_u10 * rn_u10
+ ELSE
+ utau(:,:) = 0.
+ ENDIF
+ ENDIF
+
IF( rn_uofac /= 0. ) THEN
WHERE( ABS(gphit) <= rn_windszy/2. )
- zwndrel(:,:) = rn_u10 - rn_uofac * uu(:,:,1,Kmm)
+ zwndrel(:,:) = rn_u10 - rn_uofac * uu(:,:,1,Kbb)
ELSEWHERE
- zwndrel(:,:) = - rn_uofac * uu(:,:,1,Kmm)
+ zwndrel(:,:) = - rn_uofac * uu(:,:,1,Kbb)
END WHERE
utau(:,:) = zrhocd * zwndrel(:,:) * zwndrel(:,:)
- zwndrel(:,:) = - rn_uofac * vv(:,:,1,Kmm)
+ zwndrel(:,:) = - rn_uofac * vv(:,:,1,Kbb)
vtau(:,:) = zrhocd * zwndrel(:,:) * zwndrel(:,:)
Index: /NEMO/branches/2020/r12377_ticket2386/tests/CANAL/MY_SRC/usrdef_zgr.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/CANAL/MY_SRC/usrdef_zgr.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/CANAL/MY_SRC/usrdef_zgr.F90 (revision 13540)
@@ -197,12 +197,12 @@
zmaxlam = MAXVAL(glamt)
CALL mpp_max( 'usrdef_zgr', zmaxlam ) ! max over the global domain
- zscl = rpi / zmaxlam
- z2d(:,:) = 0.5 * ( 1. - COS( glamt(:,:) * zscl ) )
- z2d(:,:) = REAL(jpkm1 - NINT( 0.75 * REAL(jpkm1,wp) * z2d(:,:) ), wp)
+ zscl = 0.5 * rpi / zmaxlam
+ z2d(:,:) = COS( glamt(:,:) * zscl )
+ z2d(:,:) = REAL(jpkm1 - NINT( 0.5 * REAL(jpkm1,wp) * z2d(:,:) ), wp)
END SELECT
!
CALL lbc_lnk( 'usrdef_zgr', z2d, 'T', 1. ) ! set surrounding land to zero (here jperio=0 ==>> closed)
!
- k_bot(:,:) = INT( z2d(:,:) ) ! =jpkm1 over the ocean point, =0 elsewhere
+ k_bot(:,:) = NINT( z2d(:,:) ) ! =jpkm1 over the ocean point, =0 elsewhere
!
k_top(:,:) = MIN( 1 , k_bot(:,:) ) ! = 1 over the ocean point, =0 elsewhere
Index: /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/axis_def_nemo.xml
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/axis_def_nemo.xml (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/axis_def_nemo.xml (revision 13540)
@@ -0,0 +1,1 @@
+link ../../../cfgs/SHARED/axis_def_nemo.xml
Index: /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/context_nemo.xml
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/context_nemo.xml (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/context_nemo.xml (revision 13540)
@@ -0,0 +1,42 @@
+
+
+
+
+
+ 1900
+ 01
+ 01
+ 1026.0
+ 3991.86795711963
+ 0.99530670233846
+ 917.0
+ 330.0
+ 1.e20
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
Index: /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/domain_def_nemo.xml
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/domain_def_nemo.xml (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/domain_def_nemo.xml (revision 13540)
@@ -0,0 +1,1 @@
+link ../../../cfgs/SHARED/domain_def_nemo.xml
Index: /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/field_def_nemo-ice.xml
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/field_def_nemo-ice.xml (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/field_def_nemo-ice.xml (revision 13540)
@@ -0,0 +1,1 @@
+link ../../../cfgs/SHARED/field_def_nemo-ice.xml
Index: /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/field_def_nemo-oce.xml
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/field_def_nemo-oce.xml (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/field_def_nemo-oce.xml (revision 13540)
@@ -0,0 +1,1 @@
+link ../../../cfgs/SHARED/field_def_nemo-oce.xml
Index: /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/field_def_nemo-pisces.xml
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/field_def_nemo-pisces.xml (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/field_def_nemo-pisces.xml (revision 13540)
@@ -0,0 +1,1 @@
+link ../../../cfgs/SHARED/field_def_nemo-pisces.xml
Index: /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/file_def_nemo-ice.xml
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/file_def_nemo-ice.xml (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/file_def_nemo-ice.xml (revision 13540)
@@ -0,0 +1,156 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
Index: /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/file_def_nemo-oce.xml
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/file_def_nemo-oce.xml (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/file_def_nemo-oce.xml (revision 13540)
@@ -0,0 +1,173 @@
+
+
+
+
+
+
+
+
+
+ @toce_e3t / @e3t
+ @soce_e3t / @e3t
+
+
+
+ sqrt( @sst2 - @sst * @sst )
+ sqrt( @ssh2 - @ssh * @ssh )
+ @sstmax - @sstmin
+
+
+ @mldr10_1max - @mldr10_1min
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ @uoce_e3u / @e3u
+
+
+
+
+
+
+
+
+
+
+
+ @voce_e3v / @e3v
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
Index: /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/file_def_nemo-pisces.xml
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/file_def_nemo-pisces.xml (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/file_def_nemo-pisces.xml (revision 13540)
@@ -0,0 +1,128 @@
+
+
+
+
+
+
+
+
+
+ tdenit * 14. * 86400. * 365. / 1e12
+ tnfix * 14. * 86400. * 365. / 1e12
+ tcflx * -1. * 12. * 86400. * 365. / 1e15
+ tcflxcum * -1. * 12. / 1e15
+ tcexp * 12. * 86400. * 365. / 1e15
+ tintpp * 12. * 86400. * 365. / 1e15
+ pno3tot * 16. / 122. * 1e6
+ ppo4tot * 1. / 122. * 1e6
+ psiltot * 1e6
+ palktot * 1e6
+ pfertot * 1e9
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
Index: /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/gen_report.sh
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/gen_report.sh (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/gen_report.sh (revision 13540)
@@ -0,0 +1,95 @@
+#!/bin/bash
+#set -vx
+# ncmax $var_nm $fl_nm : What is maximum of variable?
+function ncmax { ncap2 -O -C -v -s "foo=${1}.max();print(foo)" ${2} ~/foo.nc | cut -f 3- -d ' ' ; }
+# ncmin $var_nm $fl_nm : What is minimum of variable?
+function ncmin { ncap2 -O -C -v -s "foo=${1}.min();print(foo)" ${2} ~/foo.nc | cut -f 3- -d ' ' ; }
+# ncmdn $var_nm $fl_nm : What is median of variable?
+function ncmdn { ncap2 -O -C -v -s "foo=gsl_stats_median_from_sorted_data(${1}.sort());print(foo)" ${2} ~/foo.nc | cut -f 3- -d ' ' ; }
+
+##
+## simple report generator for the test case
+##
+
+##
+## Variables which may need to be adapted to your experiment:
+##
+# RUNDIR = directory where the test case is executed: contains all outputs
+RUNDIR=/gpfswork/rech/omr/romr001/OUT/CPLTESTCASE/2020-03-31120816
+# NB_NEMO_IT = expected total number of NEMO iterations
+NB_NEMO_IT=160
+# NB_OASIS_OUTFILES = number of debug.root.0* OASIS output files
+NB_OASIS_OUTFILES=2
+##
+## END of variables to be checked - Nothing need to be changed below
+##
+# check if directory is here
+ if [ ! -d $RUNDIR ]; then
+ printf "%-27s %s %s\n" $RUNDIR "directory does not exist. Check RUNDIR variable in script. Stop"
+ return
+ fi
+
+cd $RUNDIR
+
+echo " "
+echo "Check results of test case in directory: " `pwd`
+echo " "
+##
+## Check if OASIS execution has been successful
+##
+echo " OASIS successful (true if OASIS outputs in debug.root.0? includes SUCCESSFUL RUN) : "
+count=0
+for file in debug.root.0*
+do
+ echo $file ; grep "SUCCESSFUL RUN" $file
+ count=`expr $count + 1`
+done
+echo "OASIS success checked on $count files"
+[ $count = $NB_OASIS_OUTFILES ] && echo true || echo false
+##
+## Check if NEMO execution has been sucessful
+##
+echo " "
+echo " NEMO execution is successful if the run.stat file contains one line for each of NB_NEMO_IT iterations, indicating they have indeed been computed"
+ if [ ! -f ./run.stat ]; then
+ echo " the run.stat file does not exist: NEMO did not end its first time step"
+ echo " NEMO UNSUCESSFUL. Stop"
+ return
+ fi
+echo "From run.stat NEMO output file, NEMO has executed the 160 time steps:"
+nemo_iterations=`wc -l ./run.stat | awk {'print $1'} `; [ $nemo_iterations = $NB_NEMO_IT ] && echo true || echo false
+
+##
+## Check mean value of sst field seen by toyatm
+##
+ if [ ! -f ./ATSSTSST_toyatm_01.nc ]; then
+ echo " the ATSSTSST_toyatm_01.nc file does not exist: the test is not successful"
+ echo " Test case UNSUCESSFUL. Stop"
+ return
+ fi
+echo " "
+echo "Examining ATSSTSST variable sea surface temperature as seen by toyatm, unit is degree Kelvin (min. should be around 271., max. around 302., median around 280.)"
+ASSTmin=`ncmin ATSSTSST ATSSTSST_toyatm_01.nc`
+ASSTmax=`ncmax ATSSTSST ATSSTSST_toyatm_01.nc`
+ASSTmed=`ncmdn ATSSTSST ATSSTSST_toyatm_01.nc`
+echo "Minimum value of ATSSTSST variable in ATSSTSST_toyatm_01.nc file = " $ASSTmin
+echo "Maximum value of ATSSTSST variable in ATSSTSST_toyatm_01.nc file = " $ASSTmax
+echo "Median value of ATSSTSST variable in ATSSTSST_toyatm_01.nc file = " $ASSTmed
+MINMAX=0
+if [ ${ASSTmin%%.*} -lt 270 -o ${ASSTmax%%.*} -gt 310 ]; then
+echo " Min. or max. values of ATSSTSST do not look reasonable. Check the test again "
+MINMAX=1
+fi
+##
+## Summary
+##
+echo " "
+if [ $count = $NB_OASIS_OUTFILES ] && [ $nemo_iterations = $NB_NEMO_IT ] && [ $MINMAX = 0 ]
+then
+ echo " The run looks very succesful!"
+ echo " Have a look to the ASTSSTSST.nc file (using ncview for example): sea surface temperatures as seen by the toyatm and compare it to the reference file (CPL/ref_ATSSTSST_last_time_step.jpg) "
+ echo " Units are in degrees Kelvin and it will confirm the test is successful"
+ echo " "
+else
+ echo "The test case is unsuccessful. Check all inputs and outputs"
+fi
Index: /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/grid_def_nemo.xml
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/grid_def_nemo.xml (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/grid_def_nemo.xml (revision 13540)
@@ -0,0 +1,1 @@
+link ../../../cfgs/SHARED/grid_def_nemo.xml
Index: /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/iodef.xml
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/iodef.xml (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/iodef.xml (revision 13540)
@@ -0,0 +1,26 @@
+
+
+
+
+
+
+
+
+
+
+
+ 10
+ false
+ true
+ oceanx
+
+
+
+
+
+
+
+
+
+
+
Index: /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/namelist_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/namelist_cfg (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/namelist_cfg (revision 13540)
@@ -0,0 +1,486 @@
+!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+!! NEMO/OCE Configuration namelist : overwrite default values defined in SHARED/namelist_ref
+!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+!! ORCA2 - ICE - PISCES 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 ("key_c1d")
+!! namc1d_dyndmp 1D newtonian damping applied on currents ("key_c1d")
+!! namc1d_uvd 1D data (currents) ("key_c1d")
+!!======================================================================
+!
+!-----------------------------------------------------------------------
+&namrun ! parameters of the run
+!-----------------------------------------------------------------------
+ cn_exp = "ORCA2" ! experience name
+ nn_it000 = 1 ! first time step
+ nn_itend = 160 ! last time step (std 5475)
+ nn_istate = 0 ! output the initial state (1) or not (0)
+/
+!-----------------------------------------------------------------------
+&namdom ! time and space domain
+!-----------------------------------------------------------------------
+ rn_Dt = 5400. ! time step for the dynamics and tracer
+/
+!-----------------------------------------------------------------------
+&namcfg ! parameters of the configuration (default: use namusr_def in namelist_cfg)
+!-----------------------------------------------------------------------
+ ln_read_cfg = .true. ! (=T) read the domain configuration file
+ cn_domcfg = "ORCA_R2_zps_domcfg" ! domain configuration filename
+ !
+ ln_closea = .false. ! F => suppress closed seas (defined by closea_mask field)
+ ! ! from the bathymetry at runtime.
+/
+!-----------------------------------------------------------------------
+&namtsd ! Temperature & Salinity Data (init/dmp) (default: OFF)
+!-----------------------------------------------------------------------
+ ! ! =T read T-S fields for:
+ ln_tsd_init = .true. ! ocean initialisation
+ ln_tsd_dmp = .true. ! T-S restoring (see namtra_dmp)
+
+ cn_dir = './' ! root directory for the T-S data location
+ !___________!_________________________!___________________!___________!_____________!________!___________!__________________!__________!_______________!
+ ! ! file name ! frequency (hours) ! variable ! time interp.! clim ! 'yearly'/ ! weights filename ! rotation ! land/sea mask !
+ ! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! ! pairing ! filename !
+ sn_tem = 'data_1m_potential_temperature_nomask', -1. ,'votemper', .true. , .true. , 'yearly' , '' , '' , ''
+ sn_sal = 'data_1m_salinity_nomask' , -1. ,'vosaline', .true. , .true. , 'yearly' , '' , '' , ''
+/
+!!======================================================================
+!! *** 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_isf ice shelf melting/freezing (ln_isfcav =T : read (ln_read_cfg=T) or set or usr_def_zgr )
+!! namsbc_iscpl coupling option between land ice model and ocean (ln_isfcav =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
+ ! (also = the frequency of sea-ice & iceberg model call)
+ ! Type of air-sea fluxes
+ ln_cpl = .true. ! atmosphere coupled formulation ( requires key_oasis3 )
+ ! Sea-ice :
+ nn_ice = 2 ! =2 or 3 automatically for SI3 or CICE ("key_si3" or "key_cice")
+ ! except in AGRIF zoom where it has to be specified
+ ! Misc. options of sbc :
+ ln_traqsr = .true. ! Light penetration in the ocean (T => fill namtra_qsr)
+ ln_ssr = .true. ! Sea Surface Restoring on T and/or S (T => fill namsbc_ssr)
+ ln_rnf = .true. ! runoffs (T => fill namsbc_rnf)
+ nn_fwb = 2 ! FreshWater Budget:
+ ! ! =2 annual global mean of e-p-r set to zero
+ ln_wave = .false. ! Activate coupling with wave (T => fill namsbc_wave)
+ ln_cdgw = .false. ! Neutral drag coefficient read from wave model (T => ln_wave=.true. & fill namsbc_wave)
+ ln_sdw = .false. ! Read 2D Surf Stokes Drift & Computation of 3D stokes drift (T => ln_wave=.true. & fill namsbc_wave)
+ nn_sdrift = 0 ! Parameterization for the calculation of 3D-Stokes drift from the surface Stokes drift
+ ! ! = 0 Breivik 2015 parameterization: v_z=v_0*[exp(2*k*z)/(1-8*k*z)]
+ ! ! = 1 Phillips: v_z=v_o*[exp(2*k*z)-beta*sqrt(-2*k*pi*z)*erfc(sqrt(-2*k*z))]
+ ! ! = 2 Phillips as (1) but using the wave frequency from a wave model
+ ln_tauwoc = .false. ! Activate ocean stress modified by external wave induced stress (T => ln_wave=.true. & fill namsbc_wave)
+ ln_tauw = .false. ! Activate ocean stress components from wave model
+ ln_stcor = .false. ! Activate Stokes Coriolis term (T => ln_wave=.true. & ln_sdw=.true. & fill namsbc_wave)
+/
+!-----------------------------------------------------------------------
+&namsbc_blk ! namsbc_blk generic Bulk formula (ln_blk =T)
+!-----------------------------------------------------------------------
+ ! ! bulk algorithm :
+ ln_NCAR = .true. ! "NCAR" algorithm (Large and Yeager 2008)
+
+ cn_dir = './' ! root directory for the bulk data location
+ !___________!_________________________!___________________!___________!_____________!________!___________!______________________________________!__________!_______________!
+ ! ! file name ! frequency (hours) ! variable ! time interp.! clim ! 'yearly'/ ! weights filename ! rotation ! land/sea mask !
+ ! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! ! pairing ! filename !
+ sn_wndi = 'u_10.15JUNE2009_fill' , 6. , 'U_10_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bicubic_noc.nc' , 'Uwnd' , ''
+ sn_wndj = 'v_10.15JUNE2009_fill' , 6. , 'V_10_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bicubic_noc.nc' , 'Vwnd' , ''
+ sn_qsr = 'ncar_rad.15JUNE2009_fill' , 24. , 'SWDN_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
+ sn_qlw = 'ncar_rad.15JUNE2009_fill' , 24. , 'LWDN_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
+ sn_tair = 't_10.15JUNE2009_fill' , 6. , 'T_10_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
+ sn_humi = 'q_10.15JUNE2009_fill' , 6. , 'Q_10_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
+ sn_prec = 'ncar_precip.15JUNE2009_fill', -1. , 'PRC_MOD1', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
+ sn_snow = 'ncar_precip.15JUNE2009_fill', -1. , 'SNOW' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
+ sn_slp = 'slp.15JUNE2009_fill' , 6. , 'SLP' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , ''
+/
+&namsbc_cpl ! coupled ocean/atmosphere model ("key_oasis3")
+!-----------------------------------------------------------------------
+ nn_cplmodel = 1 ! Maximum number of models to/from which NEMO is potentially sending/receiving data
+ ln_usecplmask = .false. ! 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)
+ nn_cats_cpl = 5 ! Number of sea ice categories over which coupling is to be carried out (if not 1)
+
+ !_____________!__________________________!____________!_____________!______________________!________!
+ ! ! description ! multiple ! vector ! vector ! vector !
+ ! ! ! categories ! reference ! orientation ! grids !
+!*** send ***
+!! sn_snd_temp = 'weighted oce and ice' , 'no' , '' , '' , ''
+ sn_snd_temp = 'mixed oce-ice' , 'no' , '' , '' , ''
+ sn_snd_ttilyr = 'none' , 'no' , '' , '' , ''
+ sn_snd_alb = 'none' , 'no' , '' , '' , ''
+ sn_snd_thick = 'none' , 'no' , '' , '' , ''
+ sn_snd_ifrac = 'none' , 'no' , '' , '' , ''
+ sn_snd_crt = 'none' , 'no' , 'spherical' , 'eastward-northward' , 'T'
+ sn_snd_co2 = 'none' , 'no' , '' , '' , ''
+ sn_snd_cond = 'none' , 'no' , '' , '' , ''
+ sn_snd_mpnd = 'none' , 'no' , '' , '' , ''
+ sn_snd_sstfrz = 'none' , 'no' , '' , '' , ''
+ sn_snd_crtw = 'none' , 'no' , '' , '' , 'U,V'
+ sn_snd_wlev = 'none' , 'no' , '' , '' , ''
+ sn_snd_thick1 = 'none' , 'no' , '' , '' , ''
+!*** receive ***
+ sn_rcv_w10m = 'none' , 'no' , '' , '' , ''
+ sn_rcv_taumod = 'none' , 'no' , '' , '' , ''
+ sn_rcv_tau = 'oce only' , 'no' , 'spherical' , 'eastward-northward' , 'T'
+ sn_rcv_dqnsdt = 'coupled' , 'no' , '' , '' , ''
+ sn_rcv_qsr = 'conservative' , 'no' , '' , '' , ''
+ sn_rcv_qns = 'conservative' , 'no' , '' , '' , ''
+ sn_rcv_emp = 'conservative' , 'no' , '' , '' , ''
+ sn_rcv_rnf = 'none' , 'no' , '' , '' , ''
+ sn_rcv_cal = 'none' , 'no' , '' , '' , ''
+ sn_rcv_icb = 'none' , 'no' , '' , '' , ''
+ sn_rcv_isf = 'none' , 'no' , '' , '' , ''
+ sn_rcv_iceflx = 'none' , 'no' , '' , '' , ''
+ sn_rcv_co2 = 'none' , 'no' , '' , '' , ''
+ 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_wfreq = 'none' , 'no' , '' , '' , ''
+ sn_rcv_tauwoc = 'none' , 'no' , '' , '' , ''
+ sn_rcv_tauw = 'none' , 'no' , '' , '' , ''
+ sn_rcv_wdrag = 'none' , 'no' , '' , '' , ''
+ sn_rcv_ts_ice = 'none' , 'no' , '' , '' , ''
+ sn_rcv_mslp = 'none' , 'no' , '' , '' , ''
+/
+!-----------------------------------------------------------------------
+&namtra_qsr ! penetrative solar radiation (ln_traqsr =T)
+!-----------------------------------------------------------------------
+ ! ! type of penetration (default: NO selection)
+ ln_qsr_rgb = .true. ! RGB light penetration (Red-Green-Blue)
+ !
+ nn_chldta = 1 ! RGB : Chl data (=1) or cst value (=0)
+
+ cn_dir = './' ! root directory for the chlorophyl data location
+ !___________!_________________________!___________________!___________!_____________!________!___________!__________________!__________!_______________!
+ ! ! file name ! frequency (hours) ! variable ! time interp.! clim ! 'yearly'/ ! weights filename ! rotation ! land/sea mask !
+ ! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! ! pairing ! filename !
+ sn_chl ='chlorophyll' , -1. , 'CHLA' , .true. , .true. , 'yearly' , '' , '' , ''
+/
+!-----------------------------------------------------------------------
+&namsbc_ssr ! surface boundary condition : sea surface restoring (ln_ssr =T)
+!-----------------------------------------------------------------------
+ nn_sssr = 2 ! add a damping term to the surface freshwater flux
+ rn_deds = -166.67 ! magnitude of the damping on salinity [mm/day]
+ ln_sssr_bnd = .true. ! flag to bound erp term (associated with nn_sssr=2)
+ rn_sssr_bnd = 4.e0 ! ABS(Max/Min) value of the damping erp term [mm/day]
+/
+!-----------------------------------------------------------------------
+&namsbc_rnf ! runoffs (ln_rnf =T)
+!-----------------------------------------------------------------------
+ ln_rnf_mouth = .true. ! specific treatment at rivers mouths
+ rn_hrnf = 15.e0 ! depth over which enhanced vertical mixing is used (ln_rnf_mouth=T)
+ rn_avt_rnf = 1.e-3 ! value of the additional vertical mixing coef. [m2/s] (ln_rnf_mouth=T)
+ rn_rfact = 1.e0 ! multiplicative factor for runoff
+
+ cn_dir = './' ! root directory for the location of the runoff files
+ !___________!_____________!___________________!___________!_____________!_________!___________!__________!__________!_______________!
+ ! ! file name ! frequency (hours) ! variable ! time interp. ! clim ! 'yearly'/ ! weights ! rotation ! land/sea mask !
+ ! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! filename ! pairing ! filename !
+ sn_rnf = 'runoff_core_monthly', -1. , 'sorunoff', .true. , .true. , 'yearly' , '' , '' , ''
+ sn_cnf = 'runoff_core_monthly', 0. , 'socoefr0', .false. , .true. , 'yearly' , '' , '' , ''
+ sn_s_rnf = 'runoffs' , 24. , 'rosaline', .true. , .true. , 'yearly' , '' , '' , ''
+ sn_t_rnf = 'runoffs' , 24. , 'rotemper', .true. , .true. , 'yearly' , '' , '' , ''
+ sn_dep_rnf = 'runoffs' , 0. , 'rodepth' , .false. , .true. , 'yearly' , '' , '' , ''
+/
+!-----------------------------------------------------------------------
+&namsbc_wave ! External fields from wave model (ln_wave=T)
+!-----------------------------------------------------------------------
+/
+!-----------------------------------------------------------------------
+&namberg ! iceberg parameters (default: OFF)
+!-----------------------------------------------------------------------
+ ln_icebergs = .true. ! activate iceberg floats (force =F with "key_agrif")
+
+ cn_dir = './' ! root directory for the location of drag coefficient files
+ !______!___________!___________________!______________!______________!_________!___________!__________!__________!_______________!
+ ! ! file name ! frequency (hours) ! variable ! time interp. ! clim ! 'yearly'/ ! weights ! rotation ! land/sea mask !
+ ! ! ! (if <0 months) ! name ! (logical) ! (T/F ) ! 'monthly' ! filename ! pairing ! filename !
+ sn_icb = 'calving', -1. , 'calving' , .true. , .true. , 'yearly' , '' , '' , ''
+/
+!!======================================================================
+!! *** 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 = 2. ! no slip
+/
+!-----------------------------------------------------------------------
+&namagrif ! AGRIF zoom ("key_agrif")
+!-----------------------------------------------------------------------
+ ln_spc_dyn = .true. ! use 0 as special value for dynamics
+ rn_sponge_tra = 2880. ! coefficient for tracer sponge layer [m2/s]
+ rn_sponge_dyn = 2880. ! coefficient for dynamics sponge layer [m2/s]
+ ln_chk_bathy = .false. ! =T check the parent bathymetry
+/
+!!======================================================================
+!! *** 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_lin = .true. ! linear drag: Cd = Cd0 Uc0
+/
+!-----------------------------------------------------------------------
+&nambbc ! bottom temperature boundary condition (default: OFF)
+!-----------------------------------------------------------------------
+ ln_trabbc = .true. ! Apply a geothermal heating at the ocean bottom
+ nn_geoflx = 2 ! geothermal heat flux: = 2 read variable flux [mW/m2]
+
+ cn_dir = './' ! root directory for the geothermal data location
+ !___________!_________________________!___________________!___________!_____________!________!___________!__________________!__________!_______________!
+ ! ! file name ! frequency (hours) ! variable ! time interp.! clim ! 'yearly'/ ! weights filename ! rotation ! land/sea mask !
+ ! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! ! pairing ! filename !
+ sn_qgh ='geothermal_heating.nc' , -12. , 'heatflow', .false. , .true. , 'yearly' , '' , '' , ''
+/
+!-----------------------------------------------------------------------
+&nambbl ! bottom boundary layer scheme (default: OFF)
+!-----------------------------------------------------------------------
+ ln_trabbl = .true. ! Bottom Boundary Layer parameterisation flag
+ nn_bbl_ldf = 1 ! diffusive bbl (=1) or not (=0)
+ nn_bbl_adv = 0 ! advective bbl (=1/2) or not (=0)
+ rn_ahtbbl = 1000. ! lateral mixing coefficient in the bbl [m2/s]
+ rn_gambbl = 10. ! advective bbl coefficient [s]
+/
+!!======================================================================
+!! 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
+/
+!-----------------------------------------------------------------------
+&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_iso = .true. ! iso-neutral (Standard operator)
+ ln_traldf_msc = .true. ! Method of Stabilizing Correction (both operators)
+ ! ! Coefficients:
+ nn_aht_ijk_t = 20 ! space/time variation of eddy coef
+ ! ! = 20 aht = 1/2 Ud. max(e1,e2)
+ rn_Ud = 0.018 ! lateral diffusive velocity [m/s] (nn_aht_ijk_t= 0, 10, 20, 30)
+ rn_Ld = 200.e+3 ! lateral diffusive length [m] (nn_aht_ijk_t= 0, 10)
+/
+!-----------------------------------------------------------------------
+&namtra_mle ! mixed layer eddy parametrisation (Fox-Kemper) (default: OFF)
+!-----------------------------------------------------------------------
+ ln_mle = .true. ! (T) use the Mixed Layer Eddy (MLE) parameterisation
+/
+!-----------------------------------------------------------------------
+&namtra_eiv ! eddy induced velocity param. (default: OFF)
+!-----------------------------------------------------------------------
+ ln_ldfeiv = .true. ! use eddy induced velocity parameterization
+ ! ! Coefficients:
+ nn_aei_ijk_t = 21 ! space/time variation of the eiv coeficient
+ ! ! = 21 F(i,j,t) =Treguier et al. JPO 1997 formulation
+ ! ! time invariant coefficients: aei0 = 1/2 Ue*Le
+ rn_Ue = 0.03 ! lateral diffusive velocity [m/s] (nn_aht_ijk_t= 0, 10, 20, 30)
+ rn_Le = 200.e+3 ! lateral diffusive length [m] (nn_aht_ijk_t= 0, 10)
+ !
+ ln_ldfeiv_dia =.true. ! diagnose eiv stream function and velocities
+/
+!-----------------------------------------------------------------------
+&namtra_dmp ! tracer: T & S newtonian damping (default: OFF)
+!-----------------------------------------------------------------------
+ ln_tradmp = .true. ! add a damping term (using resto.nc coef.)
+ nn_zdmp = 0 ! vertical shape =0 damping throughout the water column
+/
+!!======================================================================
+!! *** 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)
+!!======================================================================
+!
+!-----------------------------------------------------------------------
+&namdyn_adv ! formulation of the momentum advection (default: NO selection)
+!-----------------------------------------------------------------------
+ ln_dynadv_vec = .true. ! vector form - 2nd centered scheme
+ nn_dynkeg = 0 ! grad(KE) scheme: =0 C2 ; =1 Hollingsworth correction
+/
+!-----------------------------------------------------------------------
+&namdyn_vor ! Vorticity / Coriolis scheme (default: NO selection)
+!-----------------------------------------------------------------------
+ ln_dynvor_een = .true. ! energy & enstrophy scheme
+ nn_een_e3f = 0 ! =0 e3f = mean masked e3t divided by 4
+/
+!-----------------------------------------------------------------------
+&namdyn_hpg ! Hydrostatic pressure gradient option (default: NO selection)
+!-----------------------------------------------------------------------
+ ln_hpg_sco = .true. ! s-coordinate (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 = -30 ! =-30 3D coeff. read in eddy_diffusivity_3D.nc
+/
+!!======================================================================
+!! 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)
+!-----------------------------------------------------------------------
+ ln_zdftke = .true. ! Turbulent Kinetic Energy closure (T => fill namzdf_tke)
+ ln_zdfevd = .true. ! Enhanced Vertical Diffusion scheme
+ nn_evdm = 0 ! evd apply on tracer (=0) or on tracer and momentum (=1)
+ rn_evd = 100. ! evd mixing coefficient [m2/s]
+ ln_zdfddm = .true. ! double diffusive mixing
+ rn_avts = 1.e-4 ! maximum avs (vertical mixing on salinity)
+ rn_hsbfr = 1.6 ! heat/salt buoyancy flux ratio
+ ln_zdfiwm = .true. ! internal wave-induced mixing (T => fill namzdf_iwm)
+ ! ! Coefficients
+ rn_avm0 = 1.2e-4 ! vertical eddy viscosity [m2/s] (background Kz if ln_zdfcst=F)
+ rn_avt0 = 1.2e-5 ! vertical eddy diffusivity [m2/s] (background Kz if ln_zdfcst=F)
+ nn_avb = 0 ! profile for background avt & avm (=1) or not (=0)
+ nn_havtb = 1 ! horizontal shape for avtb (=1) or not (=0)
+/
+!-----------------------------------------------------------------------
+&namzdf_tke ! turbulent eddy kinetic dependent vertical diffusion (ln_zdftke =T)
+!-----------------------------------------------------------------------
+ nn_mxl = 3 ! mixing length: = 0 bounded by the distance to surface and bottom
+ ! ! = 1 bounded by the local vertical scale factor
+ ! ! = 2 first vertical derivative of mixing length bounded by 1
+ ! ! = 3 as =2 with distinct dissipative an mixing length scale
+ nn_etau = 1 ! penetration of tke below the mixed layer (ML) due to NIWs
+ ! = 0 none ; = 1 add a tke source below the ML
+ ! = 2 add a tke source just at the base of the ML
+ ! = 3 as = 1 applied on HF part of the stress (ln_cpl=T)
+ rn_eice = 0 ! below sea ice: =0 ON ; =4 OFF when ice fraction > 1/4
+/
+!-----------------------------------------------------------------------
+&namzdf_iwm ! internal wave-driven mixing parameterization (ln_zdfiwm =T)
+!-----------------------------------------------------------------------
+ nn_zpyc = 2 ! pycnocline-intensified dissipation scales as N (=1) or N^2 (=2)
+ ln_mevar = .true. ! variable (T) or constant (F) mixing efficiency
+ ln_tsdiff = .true. ! account for differential T/S mixing (T) or not (F)
+
+ cn_dir = './' ! root directory for the iwm data location
+ !___________!_________________________!___________________!___________!_____________!________!___________!__________________!__________!_______________!
+ ! ! file name ! frequency (hours) ! variable ! time interp.! clim ! 'yearly'/ ! weights filename ! rotation ! land/sea mask !
+ ! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! ! pairing ! filename !
+ sn_mpb = 'mixing_power_bot' , -12 , 'field' , .false. , .true. , 'yearly' , '' , '' , ''
+ sn_mpp = 'mixing_power_pyc' , -12 , 'field' , .false. , .true. , 'yearly' , '' , '' , ''
+ sn_mpc = 'mixing_power_cri' , -12 , 'field' , .false. , .true. , 'yearly' , '' , '' , ''
+ sn_dsb = 'decay_scale_bot' , -12 , 'field' , .false. , .true. , 'yearly' , '' , '' , ''
+ sn_dsc = 'decay_scale_cri' , -12 , 'field' , .false. , .true. , 'yearly' , '' , '' , ''
+/
+!!======================================================================
+!! *** Diagnostics namelists *** !!
+!! !!
+!! namtrd dynamics and/or tracer trends (default: OFF)
+!! namptr Poleward Transport Diagnostics (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")
+!!======================================================================
+!
+!!======================================================================
+!! *** Observation & Assimilation *** !!
+!! !!
+!! namobs observation and model comparison (default: OFF)
+!! nam_asminc assimilation increments ('key_asminc')
+!!======================================================================
+!
+!!======================================================================
+!! *** Miscellaneous namelists *** !!
+!! !!
+!! nammpp Massively Parallel Processing ("key_mpp_mpi")
+!! namctl Control prints (default: OFF)
+!! namsto Stochastic parametrization of EOS (default: OFF)
+!!======================================================================
+!
+!-----------------------------------------------------------------------
+&nammpp ! Massively Parallel Processing ("key_mpp_mpi")
+!-----------------------------------------------------------------------
+/
+!-----------------------------------------------------------------------
+&namctl ! Control prints (default: OFF)
+!-----------------------------------------------------------------------
+/
+!-----------------------------------------------------------------------
+&namsto ! Stochastic parametrization of EOS (default: OFF)
+!-----------------------------------------------------------------------
+/
Index: /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/namelist_ice_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/namelist_ice_cfg (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/namelist_ice_cfg (revision 13540)
@@ -0,0 +1,84 @@
+!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+!! SI3 configuration namelist: Overwrites SHARED/namelist_ice_ref
+!! 1 - Generic parameters (nampar)
+!! 2 - Ice thickness discretization (namitd)
+!! 3 - Ice dynamics (namdyn)
+!! 4 - Ice ridging/rafting (namdyn_rdgrft)
+!! 5 - Ice rheology (namdyn_rhg)
+!! 6 - Ice advection (namdyn_adv)
+!! 7 - Ice surface boundary conditions (namsbc)
+!! 8 - Ice thermodynamics (namthd)
+!! 9 - Ice heat diffusion (namthd_zdf)
+!! 10 - Ice lateral melting (namthd_da)
+!! 11 - Ice growth in open water (namthd_do)
+!! 12 - Ice salinity (namthd_sal)
+!! 13 - Ice melt ponds (namthd_pnd)
+!! 14 - Ice initialization (namini)
+!! 15 - Ice/snow albedos (namalb)
+!! 16 - Ice diagnostics (namdia)
+!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+!
+!------------------------------------------------------------------------------
+&nampar ! Generic parameters
+!------------------------------------------------------------------------------
+/
+!------------------------------------------------------------------------------
+&namitd ! Ice discretization
+!------------------------------------------------------------------------------
+/
+!------------------------------------------------------------------------------
+&namdyn ! Ice dynamics
+!------------------------------------------------------------------------------
+/
+!------------------------------------------------------------------------------
+&namdyn_rdgrft ! Ice ridging/rafting
+!------------------------------------------------------------------------------
+/
+!------------------------------------------------------------------------------
+&namdyn_rhg ! Ice rheology
+!------------------------------------------------------------------------------
+/
+!------------------------------------------------------------------------------
+&namdyn_adv ! Ice advection
+!------------------------------------------------------------------------------
+/
+!------------------------------------------------------------------------------
+&namsbc ! Ice surface boundary conditions
+!------------------------------------------------------------------------------
+/
+!------------------------------------------------------------------------------
+&namthd ! Ice thermodynamics
+!------------------------------------------------------------------------------
+/
+!------------------------------------------------------------------------------
+&namthd_zdf ! Ice heat diffusion
+!------------------------------------------------------------------------------
+/
+!------------------------------------------------------------------------------
+&namthd_da ! Ice lateral melting
+!------------------------------------------------------------------------------
+/
+!------------------------------------------------------------------------------
+&namthd_do ! Ice growth in open water
+!------------------------------------------------------------------------------
+/
+!------------------------------------------------------------------------------
+&namthd_sal ! Ice salinity
+!------------------------------------------------------------------------------
+/
+!------------------------------------------------------------------------------
+&namthd_pnd ! Melt ponds
+!------------------------------------------------------------------------------
+/
+!------------------------------------------------------------------------------
+&namini ! Ice initialization
+!------------------------------------------------------------------------------
+/
+!------------------------------------------------------------------------------
+&namalb ! albedo parameters
+!------------------------------------------------------------------------------
+/
+!------------------------------------------------------------------------------
+&namdia ! Diagnostics
+!------------------------------------------------------------------------------
+/
Index: /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/namelist_ice_ref
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/namelist_ice_ref (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/namelist_ice_ref (revision 13540)
@@ -0,0 +1,1 @@
+link ../../../cfgs/SHARED/namelist_ice_ref
Index: /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/namelist_pisces_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/namelist_pisces_cfg (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/namelist_pisces_cfg (revision 13540)
@@ -0,0 +1,141 @@
+!-----------------------------------------------------------------------
+&nampismod ! Model used
+!-----------------------------------------------------------------------
+/
+!-----------------------------------------------------------------------
+&nampisext ! air-sea exchange
+!-----------------------------------------------------------------------
+/
+!-----------------------------------------------------------------------
+&nampisatm ! Atmospheric prrssure
+!-----------------------------------------------------------------------
+/
+!-----------------------------------------------------------------------
+&nampisbio ! biological parameters
+!-----------------------------------------------------------------------
+/
+!-----------------------------------------------------------------------
+&namp4zlim ! parameters for nutrient limitations for PISCES std - ln_p4z
+!-----------------------------------------------------------------------
+/
+!-----------------------------------------------------------------------
+&namp5zlim ! parameters for nutrient limitations PISCES QUOTA - ln_p5z
+!-----------------------------------------------------------------------
+/
+!-----------------------------------------------------------------------
+&namp5zquota ! parameters for nutrient limitations PISCES quota - ln_p5z
+!-----------------------------------------------------------------------
+/
+!-----------------------------------------------------------------------
+&nampisopt ! parameters for optics
+!-----------------------------------------------------------------------
+/
+!-----------------------------------------------------------------------
+&namp4zprod ! parameters for phytoplankton growth for PISCES std - ln_p4z
+!-----------------------------------------------------------------------
+/
+!-----------------------------------------------------------------------
+&namp5zprod ! parameters for phytoplankton growth for PISCES quota- ln_p5z
+!-----------------------------------------------------------------------
+/
+!-----------------------------------------------------------------------
+&namp4zmort ! parameters for phytoplankton sinks for PISCES std - ln_p4z
+!-----------------------------------------------------------------------
+/
+!-----------------------------------------------------------------------
+&namp5zmort ! parameters for phytoplankton sinks for PISCES quota - ln_p5z
+!-----------------------------------------------------------------------
+/
+!-----------------------------------------------------------------------
+&namp4zmes ! parameters for mesozooplankton for PISCES std - ln_p4z
+!-----------------------------------------------------------------------
+/
+!-----------------------------------------------------------------------
+&namp5zmes ! parameters for mesozooplankton
+!-----------------------------------------------------------------------
+/
+!-----------------------------------------------------------------------
+&namp4zzoo ! parameters for microzooplankton for PISCES std - ln_p4z
+!-----------------------------------------------------------------------
+/
+!-----------------------------------------------------------------------
+&namp5zzoo ! parameters for microzooplankton
+!-----------------------------------------------------------------------
+/
+!-----------------------------------------------------------------------
+&nampisfer ! parameters for iron chemistry
+!-----------------------------------------------------------------------
+/
+!-----------------------------------------------------------------------
+&nampisrem ! parameters for remineralization
+!-----------------------------------------------------------------------
+/
+!-----------------------------------------------------------------------
+&nampispoc ! parameters for organic particles
+!-----------------------------------------------------------------------
+/
+!-----------------------------------------------------------------------
+&nampiscal ! parameters for Calcite chemistry
+!-----------------------------------------------------------------------
+/
+!-----------------------------------------------------------------------
+&nampisbc ! parameters for inputs deposition
+!-----------------------------------------------------------------------
+ sn_dust = 'dust.orca.new' , -1 , 'dust' , .true. , .true. , 'yearly' , '' , '' , ''
+ ln_ironsed = .true. ! boolean for Fe input from sediments
+ ln_ironice = .true. ! boolean for Fe input from sea ice
+ ln_hydrofe = .true. ! boolean for from hydrothermal vents
+/
+!-----------------------------------------------------------------------
+&nampissed ! parameters for sediments mobilization
+!-----------------------------------------------------------------------
+/
+!-----------------------------------------------------------------------
+&nampislig ! Namelist parameters for ligands, nampislig
+!-----------------------------------------------------------------------
+/
+!-----------------------------------------------------------------------
+&nampisice ! Prescribed sea ice tracers
+!-----------------------------------------------------------------------
+/
+!-----------------------------------------------------------------------
+&nampisdmp ! Damping
+!-----------------------------------------------------------------------
+ nn_pisdmp = 5840 ! Frequency of Relaxation
+/
+!-----------------------------------------------------------------------
+&nampismass ! Mass conservation
+!-----------------------------------------------------------------------
+/
+!-----------------------------------------------------------------------
+&namlobphy ! biological parameters for phytoplankton
+!-----------------------------------------------------------------------
+/
+!-----------------------------------------------------------------------
+&namlobnut ! biological parameters for nutrients
+!-----------------------------------------------------------------------
+/
+!-----------------------------------------------------------------------
+&namlobzoo ! biological parameters for zooplankton
+!-----------------------------------------------------------------------
+/
+!-----------------------------------------------------------------------
+&namlobdet ! biological parameters for detritus
+!-----------------------------------------------------------------------
+/
+!-----------------------------------------------------------------------
+&namlobdom ! biological parameters for DOM
+!-----------------------------------------------------------------------
+/
+!-----------------------------------------------------------------------
+&namlobsed ! parameters from aphotic layers to sediment
+!-----------------------------------------------------------------------
+/
+!-----------------------------------------------------------------------
+&namlobrat ! general coefficients
+!-----------------------------------------------------------------------
+/
+!-----------------------------------------------------------------------
+&namlobopt ! optical parameters
+!-----------------------------------------------------------------------
+/
Index: /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/namelist_pisces_ref
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/namelist_pisces_ref (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/namelist_pisces_ref (revision 13540)
@@ -0,0 +1,1 @@
+link ../../../cfgs/SHARED/namelist_pisces_ref
Index: /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/namelist_ref
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/namelist_ref (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/namelist_ref (revision 13540)
@@ -0,0 +1,1 @@
+link ../../../cfgs/SHARED/namelist_ref
Index: /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/namelist_top_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/namelist_top_cfg (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/namelist_top_cfg (revision 13540)
@@ -0,0 +1,141 @@
+!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+!! NEMO/TOP1 : Configuration namelist : used to overwrite defaults values defined in SHARED/namelist_top_ref
+!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+!-----------------------------------------------------------------------
+&namtrc_run ! run information
+!-----------------------------------------------------------------------
+ ln_top_euler = .true.
+/
+!-----------------------------------------------------------------------
+&namtrc ! tracers definition
+!-----------------------------------------------------------------------
+ jp_bgc = 24
+!
+ ln_pisces = .true.
+ ln_my_trc = .false.
+ ln_age = .false.
+ ln_cfc11 = .false.
+ ln_cfc12 = .false.
+ ln_c14 = .false.
+!
+ ln_trcdta = .true. ! Initialisation from data input file (T) or not (F)
+ ln_trcbc = .false. ! Enables Boundary conditions
+! ! ! ! ! !
+! ! name ! title of the field ! units ! init ! sbc ! cbc ! obc !
+ sn_tracer(1) = 'DIC ' , 'Dissolved inorganic Concentration ', 'mol-C/L' , .true. , .false., .true. , .false.
+ sn_tracer(2) = 'Alkalini' , 'Total Alkalinity Concentration ', 'eq/L ' , .true. , .false., .true. , .false.
+ sn_tracer(3) = 'O2 ' , 'Dissolved Oxygen Concentration ', 'mol-C/L' , .true. , .false., .false., .false.
+ sn_tracer(4) = 'CaCO3 ' , 'Calcite Concentration ', 'mol-C/L' , .false. , .false., .false., .false.
+ sn_tracer(5) = 'PO4 ' , 'Phosphate Concentration ', 'mol-C/L' , .true. , .true. , .true. , .false.
+ sn_tracer(6) = 'POC ' , 'Small organic carbon Concentration ', 'mol-C/L' , .false. , .false., .false., .false.
+ sn_tracer(7) = 'Si ' , 'Silicate Concentration ', 'mol-C/L' , .true. , .true. , .true. , .false.
+ sn_tracer(8) = 'PHY ' , 'Nanophytoplankton Concentration ', 'mol-C/L' , .false. , .false., .false., .false.
+ sn_tracer(9) = 'ZOO ' , 'Microzooplankton Concentration ', 'mol-C/L' , .false. , .false., .false., .false.
+ sn_tracer(10) = 'DOC ' , 'Dissolved organic Concentration ', 'mol-C/L' , .true. , .false., .true. , .false.
+ sn_tracer(11) = 'PHY2 ' , 'Diatoms Concentration ', 'mol-C/L' , .false. , .false., .false., .false.
+ sn_tracer(12) = 'ZOO2 ' , 'Mesozooplankton Concentration ', 'mol-C/L' , .false. , .false., .false., .false.
+ sn_tracer(13) = 'DSi ' , 'Diatoms Silicate Concentration ', 'mol-C/L' , .false. , .false., .false., .false.
+ sn_tracer(14) = 'Fer ' , 'Dissolved Iron Concentration ', 'mol-C/L' , .true. , .true. , .true. , .false.
+ sn_tracer(15) = 'BFe ' , 'Big iron particles Concentration ', 'mol-C/L' , .false. , .false., .false., .false.
+ sn_tracer(16) = 'GOC ' , 'Big organic carbon Concentration ', 'mol-C/L' , .false. , .false., .false., .false.
+ sn_tracer(17) = 'SFe ' , 'Small iron particles Concentration ', 'mol-C/L' , .false. , .false., .false., .false.
+ sn_tracer(18) = 'DFe ' , 'Diatoms iron Concentration ', 'mol-C/L' , .false. , .false., .false., .false.
+ sn_tracer(19) = 'GSi ' , 'Sinking biogenic Silicate Concentration', 'mol-C/L' , .false. , .false., .false., .false.
+ sn_tracer(20) = 'NFe ' , 'Nano iron Concentration ', 'mol-C/L' , .false. , .false., .false., .false.
+ sn_tracer(21) = 'NCHL ' , 'Nano chlorophyl Concentration ', 'mol-C/L' , .false. , .false., .false., .false.
+ sn_tracer(22) = 'DCHL ' , 'Diatoms chlorophyl Concentration ', 'mol-C/L' , .false. , .false., .false., .false.
+ sn_tracer(23) = 'NO3 ' , 'Nitrates Concentration ', 'mol-C/L' , .true. , .true. , .true. , .false.
+ sn_tracer(24) = 'NH4 ' , 'Ammonium Concentration ', 'mol-C/L' , .false. , .false., .false., .false.
+/
+!-----------------------------------------------------------------------
+&namage ! AGE
+!-----------------------------------------------------------------------
+/
+!-----------------------------------------------------------------------
+&namtrc_dta ! Initialisation from data input file
+!-----------------------------------------------------------------------
+! ! file name ! frequency (hours) ! variable ! time interp. ! clim ! 'yearly'/ ! weights ! rotation ! land/sea mask !
+! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! filename ! pairing ! filename !
+ sn_trcdta(1) = 'data_DIC_nomask' , -12. , 'DIC' , .false. , .true. , 'yearly' , '' , '' , ''
+ sn_trcdta(2) = 'data_Alkalini_nomask' , -12. , 'Alkalini', .false. , .true. , 'yearly' , '' , '' , ''
+ sn_trcdta(3) = 'data_O2_nomask' , -1. , 'O2' , .true. , .true. , 'yearly' , '' , '' , ''
+ sn_trcdta(5) = 'data_PO4_nomask' , -1. , 'PO4' , .true. , .true. , 'yearly' , '' , '' , ''
+ sn_trcdta(7) = 'data_Si_nomask' , -1. , 'Si' , .true. , .true. , 'yearly' , '' , '' , ''
+ sn_trcdta(10) = 'data_DOC_nomask' , -12. , 'DOC' , .false. , .true. , 'yearly' , '' , '' , ''
+ sn_trcdta(14) = 'data_Fer_nomask' , -12. , 'Fer' , .false. , .true. , 'yearly' , '' , '' , ''
+ sn_trcdta(23) = 'data_NO3_nomask' , -1. , 'NO3' , .true. , .true. , 'yearly' , '' , '' , ''
+ rn_trfac(1) = 1.0e-06 ! multiplicative factor
+ rn_trfac(2) = 1.0e-06 ! - - - -
+ rn_trfac(3) = 44.6e-06 ! - - - -
+ rn_trfac(5) = 122.0e-06 ! - - - -
+ rn_trfac(7) = 1.0e-06 ! - - - -
+ rn_trfac(10) = 1.0 ! - - - -
+ rn_trfac(14) = 1.0 ! - - - -
+ rn_trfac(23) = 7.6e-06 ! - - - -
+/
+!-----------------------------------------------------------------------
+&namtrc_adv ! advection scheme for passive tracer (default: NO selection)
+!-----------------------------------------------------------------------
+ ln_trcadv_mus = .true. ! MUSCL scheme
+ ln_mus_ups = .false. ! use upstream scheme near river mouths
+/
+!-----------------------------------------------------------------------
+&namtrc_ldf ! lateral diffusion scheme for passive tracer (default: NO selection)
+!-----------------------------------------------------------------------
+ ln_trcldf_tra = .true. ! use active tracer setting
+/
+!-----------------------------------------------------------------------
+&namtrc_rad ! treatment of negative concentrations
+!-----------------------------------------------------------------------
+/
+!-----------------------------------------------------------------------
+&namtrc_snk ! sedimentation of particles
+!-----------------------------------------------------------------------
+/
+!-----------------------------------------------------------------------
+&namtrc_dmp ! passive tracer newtonian damping
+!-----------------------------------------------------------------------
+/
+!-----------------------------------------------------------------------
+&namtrc_ice ! Representation of sea ice growth & melt effects
+!-----------------------------------------------------------------------
+/
+!-----------------------------------------------------------------------
+&namtrc_trd ! diagnostics on tracer trends ('key_trdtrc')
+!----------------------------------------------------------------------
+/
+!----------------------------------------------------------------------
+&namtrc_bc ! data for boundary conditions
+!-----------------------------------------------------------------------
+! ! file name ! frequency (hours) ! variable ! time interp. ! clim ! 'yearly'/ ! weights ! rotation ! land/sea mask !
+! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! filename ! pairing ! filename !
+ sn_trcsbc(5) = 'dust.orca.new' , -1 , 'dustpo4' , .true. , .true. , 'yearly' , '' , '' , ''
+ sn_trcsbc(7) = 'dust.orca.new' , -1 , 'dustsi' , .true. , .true. , 'yearly' , '' , '' , ''
+ sn_trcsbc(14) = 'dust.orca.new' , -1 , 'dustfer' , .true. , .true. , 'yearly' , '' , '' , ''
+ sn_trcsbc(23) = 'ndeposition.orca', -12 , 'ndep' , .false. , .true. , 'yearly' , '' , '' , ''
+ rn_trsfac(5) = 8.264e-02 ! ( 0.021 / 31. * 122 )
+ rn_trsfac(7) = 3.313e-01 ! ( 8.8 / 28.1 )
+ rn_trsfac(14) = 6.266e-04 ! ( 0.035 / 55.85 )
+ rn_trsfac(23) = 5.4464e-01 ! ( From kgN m-2 s-1 to molC l-1 ====> zfact = 7.625/14 )
+ rn_sbc_time = 1. ! Time scaling factor for SBC and CBC data (seconds in a day)
+ !
+ sn_trccbc(1) = 'river.orca' , 120 , 'riverdic' , .true. , .true. , 'yearly' , '' , '' , ''
+ sn_trccbc(2) = 'river.orca' , 120 , 'riverdic' , .true. , .true. , 'yearly' , '' , '' , ''
+ sn_trccbc(5) = 'river.orca' , 120 , 'riverdip' , .true. , .true. , 'yearly' , '' , '' , ''
+ sn_trccbc(7) = 'river.orca' , 120 , 'riverdsi' , .true. , .true. , 'yearly' , '' , '' , ''
+ sn_trccbc(10) = 'river.orca' , 120 , 'riverdoc' , .true. , .true. , 'yearly' , '' , '' , ''
+ sn_trccbc(14) = 'river.orca' , 120 , 'riverdic' , .true. , .true. , 'yearly' , '' , '' , ''
+ sn_trccbc(23) = 'river.orca' , 120 , 'riverdin' , .true. , .true. , 'yearly' , '' , '' , ''
+ rn_trcfac(1) = 8.333e+01 ! ( data in Mg/m2/yr : 1e3/12/ryyss)
+ rn_trcfac(2) = 8.333e+01 ! ( 1e3 /12 )
+ rn_trcfac(5) = 3.935e+04 ! ( 1e3 / 31. * 122 )
+ rn_trcfac(7) = 3.588e+01 ! ( 1e3 / 28.1 )
+ rn_trcfac(10) = 8.333e+01 ! ( 1e3 / 12
+ rn_trcfac(14) = 4.166e-03 ! ( 1e3 / 12 * 5e-5 )
+ rn_trcfac(23) = 5.446e+02 ! ( 1e3 / 14 * 7.625 )
+ rn_cbc_time = 3.1536e+7 ! Time scaling factor for CBC data (seconds in a year)
+/
+!----------------------------------------------------------------------
+&namtrc_bdy ! Setup of tracer boundary conditions
+!-----------------------------------------------------------------------
+/
Index: /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/namelist_top_ref
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/namelist_top_ref (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/EXPREF/namelist_top_ref (revision 13540)
@@ -0,0 +1,1 @@
+link ../../../cfgs/SHARED/namelist_top_ref
Index: /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/README.md
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/README.md (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/README.md (revision 13540)
@@ -0,0 +1,65 @@
+# Coupling with OASIS test case
+The CPL_OASIS test case allows to set up and check a basic coupling of NEMOto a simple TOYATM fake tmposhere through the OASIS coupler. A very limited number of fields are exchanged between NEMO and the TOYATM. The tests checks that the fields are indeed exchanged through OASIS and that the ATSSTSST field of sea surface temparture received by the TOYATM makes sense. If the test is sucessful, it states that the set up of NEMO-OASIS interface in the NEMO SBC module is working fine.
+
+We here provide a description of details of this experiment so as as how to run it and check test is sucessful. This experiment is **created and tested** for NEMO ** revision 12573 (to be replace by NEMO release 4.2 by end 2020)**.
+
+## Objectives
+This test case enables the OASIS interface in NEMO (in the OCE/SBC module). A few fields are sent and received by NEMO and by TOYATM (the simplified "atmosphere"). The success of this test (see below ** Verification**) indicates that
+* the OASIS interface in NEMO is functionnal (some fields are sent and received)
+* The sea surface temperature received by the TOYATM makes sense
+
+This test case can be seen as a template to set up a coupling between NEMO and an atmospheric model through OASIS.
+
+## Detailed description
+
+This test case is a set up of NEMO (dynamics, sea-ice and biogeochemistry) on a global 2° grid (as in ithe ORCA2_ICE_PISCES reference configuration), except NEMO is here coupled to a "toyatm" through OASIS.
+
+NEMO is running 160 time-steps (10 days). The coupling is done at each timestep (nn_fsbc=1 in namelist_cfg). The fields exchanged with the toyatm are defined in the &namsbc_cpl namelist in namelist_cfg file.
+
+
+This test case requires:
+* NEMO (no mofication of source code, from rev 12573 or higher (e.g. compatible with NEMO reease 4.2
+* OASIS (need to be downloaded and compiled, with correct paths set in your arch file for NEMO
+* TOYATM (the simple toy in place of an atmospheric model) (located in NEMO/tools directory, need to created executable using tools/maketools command)
+
+This tests/CPL_OASIS directory contains all the need files:
+* cpp_CPL_OASIS.fcm defining the active cpp keys for NEMO
+* EXPREF directory containing all the input files: namelists, xml files, a template job tu run the test case, and a script to check the results and produce the report
+ * More specifically, the fields exchanged by NEMO through OASIS ae defined in the namelist_cfg input file (see &namsbc_cpl variables)
+
+
+## Building the CPL_OASIS test case
+* Download and compile OASIS
+* Build the NEMO executable for this CPL_OASIS test case. First you need to add the correct OASIS library path in your arch file in the %OASIS_HOME variable. Then, in your local NEMO root directory:
+```
+./makenemo -a CPL_OASIS -n MYCPL_OASIS -m "your arch file"
+```
+This makenemo command will create the test case in cfgs/MYCPL_OASIS
+* Build the TOYATM executable
+```
+cd tools
+./maketools -n TOYATM -m "your arch file"
+```
+
+## Running the test case
+```
+cd tests/MYCPL_OASIS/EXP00
+cp ../../CPL_OASIS/job_run_CPL_TESTCASE .
+Adapt the job_run_CPL_TESTCASE to your target computer and run it
+```
+In this directory the job_run_cpl_testcase contains all the steps to run the testcase. These steps are commented in the file.
+** After adapting the headers for your batch system and the paths for the files **, run this script through the batch system of your target computer.
+
+## Verification and validation of the test case
+The script gen_report.sh located in the CPL_OASIS directory allows to check if the run came to a sucessful ending:
+```
+cd MYCPL_OASIS/EXP00
+cp ../../CPL_OASIS/gen_report.sh .
+./gen_report.sh
+```
+If the report is successful, a final check sould be done by visualising the ATSSTSST_toyatm_01.nc (using ncview or any other visualiser for NETCDF files) and comparing it to the reference ref_ATSSTSST_last_time_step.jpg image in the CPL_OASIS directory: the two visualisations must look alike.
+
+reference ref_ATSSTSST_last_time_step.jpg
+.. image:: ref_ATSSTSST_last_time_step.jpg
+
+
Index: /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/cpp_CPL_OASIS.fcm
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/cpp_CPL_OASIS.fcm (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/cpp_CPL_OASIS.fcm (revision 13540)
@@ -0,0 +1,1 @@
+bld::tool::fppkeys key_si3 key_top key_iomput key_mpp_mpi key_oasis3
Index: /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/gen_report.sh
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/gen_report.sh (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/gen_report.sh (revision 13540)
@@ -0,0 +1,95 @@
+#!/bin/bash
+#set -vx
+# ncmax $var_nm $fl_nm : What is maximum of variable?
+function ncmax { ncap2 -O -C -v -s "foo=${1}.max();print(foo)" ${2} ~/foo.nc | cut -f 3- -d ' ' ; }
+# ncmin $var_nm $fl_nm : What is minimum of variable?
+function ncmin { ncap2 -O -C -v -s "foo=${1}.min();print(foo)" ${2} ~/foo.nc | cut -f 3- -d ' ' ; }
+# ncmdn $var_nm $fl_nm : What is median of variable?
+function ncmdn { ncap2 -O -C -v -s "foo=gsl_stats_median_from_sorted_data(${1}.sort());print(foo)" ${2} ~/foo.nc | cut -f 3- -d ' ' ; }
+
+##
+## simple report generator for the test case
+##
+
+##
+## Variables which may need to be adapted to your experiment:
+##
+# RUNDIR = directory where the test case is executed: contains all outputs
+RUNDIR=`pwd`
+# NB_NEMO_IT = expected total number of NEMO iterations
+NB_NEMO_IT=160
+# NB_OASIS_OUTFILES = number of debug.root.0* OASIS output files
+NB_OASIS_OUTFILES=2
+##
+## END of variables to be checked - Nothing need to be changed below
+##
+# check if directory is here
+ if [ ! -d $RUNDIR ]; then
+ printf "%-27s %s %s\n" $RUNDIR "directory does not exist. Check RUNDIR variable in script. Stop"
+ return
+ fi
+
+cd $RUNDIR
+
+echo " "
+echo "Check results of test case in directory: " `pwd`
+echo " "
+##
+## Check if OASIS execution has been successful
+##
+echo " OASIS successful (true if OASIS outputs in debug.root.0? includes SUCCESSFUL RUN) : "
+count=0
+for file in debug.root.0*
+do
+ echo $file ; grep "SUCCESSFUL RUN" $file
+ count=`expr $count + 1`
+done
+echo "OASIS success checked on $count files"
+[ $count = $NB_OASIS_OUTFILES ] && echo true || echo false
+##
+## Check if NEMO execution has been sucessful
+##
+echo " "
+echo " NEMO execution is successful if the run.stat file contains one line for each of NB_NEMO_IT iterations, indicating they have indeed been computed"
+ if [ ! -f ./run.stat ]; then
+ echo " the run.stat file does not exist: NEMO did not end its first time step"
+ echo " NEMO UNSUCESSFUL. Stop"
+ return
+ fi
+echo "From run.stat NEMO output file, NEMO has executed the 160 time steps:"
+nemo_iterations=`wc -l ./run.stat | awk {'print $1'} `; [ $nemo_iterations = $NB_NEMO_IT ] && echo true || echo false
+
+##
+## Check mean value of sst field seen by toyatm
+##
+ if [ ! -f ./ATSSTSST_toyatm_01.nc ]; then
+ echo " the ATSSTSST_toyatm_01.nc file does not exist: the test is not successful"
+ echo " Test case UNSUCESSFUL. Stop"
+ return
+ fi
+echo " "
+echo "Examining ATSSTSST variable sea surface temperature as seen by toyatm, unit is degree Kelvin (min. should be around 271., max. around 302., median around 280.)"
+ASSTmin=`ncmin ATSSTSST ATSSTSST_toyatm_01.nc`
+ASSTmax=`ncmax ATSSTSST ATSSTSST_toyatm_01.nc`
+ASSTmed=`ncmdn ATSSTSST ATSSTSST_toyatm_01.nc`
+echo "Minimum value of ATSSTSST variable in ATSSTSST_toyatm_01.nc file = " $ASSTmin
+echo "Maximum value of ATSSTSST variable in ATSSTSST_toyatm_01.nc file = " $ASSTmax
+echo "Median value of ATSSTSST variable in ATSSTSST_toyatm_01.nc file = " $ASSTmed
+MINMAX=0
+if [ ${ASSTmin%%.*} -lt 270 -o ${ASSTmax%%.*} -gt 310 ]; then
+echo " Min. or max. values of ATSSTSST do not look reasonable. Check the test again "
+MINMAX=1
+fi
+##
+## Summary
+##
+echo " "
+if [ $count = $NB_OASIS_OUTFILES ] && [ $nemo_iterations = $NB_NEMO_IT ] && [ $MINMAX = 0 ]
+then
+ echo " The run looks very succesful!"
+ echo " Have a look to the ASTSSTSST.nc file (using ncview for example): sea surface temperatures as seen by the toyatm and compare it to the reference file (CPL/ref_ATSSTSST_last_time_step.jpg) "
+ echo " Units are in degrees Kelvin and it will confirm the test is successful"
+ echo " "
+else
+ echo "The test case is unsuccessful. Check all inputs and outputs"
+fi
Index: /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/job_run_CPL_TESTCASE
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/job_run_CPL_TESTCASE (revision 13540)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/CPL_OASIS/job_run_CPL_TESTCASE (revision 13540)
@@ -0,0 +1,91 @@
+#!/bin/bash
+###################################
+## Definitions for batch system
+#SBATCH -A omr@cpu # Accounting information
+#SBATCH --job-name=CPL_TESTCASE # Job name
+##SBATCH --partition=cpu_p1 # Partition Name
+#SBATCH --ntasks=29 # Total number of MPI processes
+#SBATCH --ntasks-per-node=40 # Number of MPI processes per node
+#SBATCH --hint=nomultithread # 1 MPI process per node (no hyperthreading)
+#SBATCH --time=00:10:00 # Maximum execution time (HH:MM:SS)
+#SBATCH --output=cpltestcase_%j # Name of output listing file
+#SBATCH --error=cpltestcase_%j # Name of error listing file (the same)
+###################################
+##
+## CONFIG_DIR is submission directory
+##
+CONFIG_DIR=${SLURM_SUBMIT_DIR}
+#
+cd ${CONFIG_DIR}
+pwd
+##
+## Define and create execution directory and move there
+##
+XXD=`date +%F%H%M%S`
+echo " XXD " $XXD
+mkdir -p $WORK/OUT/CPLTESTCASE/$XXD
+cd $WORK/OUT/CPLTESTCASE/$XXD
+echo "RUN directory " `pwd`
+##
+## Get input files for NEMO
+##
+DATA1DIR=$WORK/FORCING/ORCA2_ICE_PISCES_v4.0
+for file in $DATA1DIR/*
+do
+ln -s $file . || exit 2
+done
+# Get input namelist and xml files
+for file in $CONFIG_DIR/*namelist*_ref $CONFIG_DIR/*namelist*_cfg $CONFIG_DIR/*.xml
+do
+ cp $file . || exit 3
+done
+##
+## Get input files for TOYATM, including the namcouple file
+##
+TOYATM_DIR=$CONFIG_DIR/../../../tools/TOYATM/EXP
+for file in $TOYATM_DIR/*
+do
+ cp $file . || exit 4
+done
+##
+## Get Executables
+##
+cp $CONFIG_DIR/nemo nemo.exe || exit 5
+cp $TOYATM_DIR/toyatm.exe . || exit 5
+##
+## Get script generating summary report
+cp $CONFIG_DIR/gen_report.sh .
+
+echo "DIR BEFORE EXEC"
+ls -l
+echo '(3) Prepare launch of the run'
+echo '----------------'
+export MPIRUN="srun --mpi=pmi2 --cpu-bind=cores -K1"
+NB_PROCS_NEMO=28
+NB_PROCS_OASIS=1
+NB_PROCS_TOYATM=1
+date
+touch ./run_file
+echo 0-27 ./nemo.exe >>./run_file
+echo 28 ./toyatm.exe >>./run_file
+echo run_file
+cat ./run_file
+##
+## Run the CPL test case using 27 processes for nemo and 1 for toyatm
+##
+echo '(4) Run the code'
+echo '----------------'
+time srun --multi-prog ./run_file
+echo "DIR AFTER EXEC"
+ls -l
+date
+pwd
+##
+## simple report generator for the test case
+##
+./gen_report.sh | tee CPL_OASIS_results
+
+
+cat CPL_OASIS_results
+## Copy Summary of results back into submission directory
+cp CPL_OASIS_results ${CONFIG_DIR}
Index: /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV1D/EXPREF/context_nemo.xml
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV1D/EXPREF/context_nemo.xml (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV1D/EXPREF/context_nemo.xml (revision 13540)
@@ -11,5 +11,5 @@
01
01
- 1026.0
+ 1026.0
3991.86795711963
0.99530670233846
Index: /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV1D/EXPREF/namelist_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV1D/EXPREF/namelist_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV1D/EXPREF/namelist_cfg (revision 13540)
@@ -106,6 +106,6 @@
!! !!
!! namdrg top/bottom drag coefficient (default: NO selection)
-!! namdrg_top top friction (ln_OFF=F & ln_isfcav=T)
-!! namdrg_bot bottom friction (ln_OFF=F)
+!! 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)
@@ -115,5 +115,5 @@
&namdrg ! top/bottom drag coefficient (default: NO selection)
!-----------------------------------------------------------------------
- ln_OFF = .true. ! free-slip : Cd = 0
+ ln_drg_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot
/
!!======================================================================
Index: /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV1D/EXPREF/namelist_cfg_120pts
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV1D/EXPREF/namelist_cfg_120pts (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV1D/EXPREF/namelist_cfg_120pts (revision 13540)
@@ -106,6 +106,6 @@
!! !!
!! namdrg top/bottom drag coefficient (default: NO selection)
-!! namdrg_top top friction (ln_OFF=F & ln_isfcav=T)
-!! namdrg_bot bottom friction (ln_OFF=F)
+!! 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)
@@ -115,5 +115,5 @@
&namdrg ! top/bottom drag coefficient (default: NO selection)
!-----------------------------------------------------------------------
- ln_OFF = .true. ! free-slip : Cd = 0
+ ln_drg_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot
/
!!======================================================================
Index: /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV1D/EXPREF/namelist_cfg_240pts
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV1D/EXPREF/namelist_cfg_240pts (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV1D/EXPREF/namelist_cfg_240pts (revision 13540)
@@ -106,6 +106,6 @@
!! !!
!! namdrg top/bottom drag coefficient (default: NO selection)
-!! namdrg_top top friction (ln_OFF=F & ln_isfcav=T)
-!! namdrg_bot bottom friction (ln_OFF=F)
+!! 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)
@@ -115,5 +115,5 @@
&namdrg ! top/bottom drag coefficient (default: NO selection)
!-----------------------------------------------------------------------
- ln_OFF = .true. ! free-slip : Cd = 0
+ ln_drg_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot
/
!!======================================================================
Index: /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV1D/EXPREF/namelist_cfg_60pts
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV1D/EXPREF/namelist_cfg_60pts (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV1D/EXPREF/namelist_cfg_60pts (revision 13540)
@@ -106,6 +106,6 @@
!! !!
!! namdrg top/bottom drag coefficient (default: NO selection)
-!! namdrg_top top friction (ln_OFF=F & ln_isfcav=T)
-!! namdrg_bot bottom friction (ln_OFF=F)
+!! 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)
@@ -115,5 +115,5 @@
&namdrg ! top/bottom drag coefficient (default: NO selection)
!-----------------------------------------------------------------------
- ln_OFF = .true. ! free-slip : Cd = 0
+ ln_drg_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot
/
!!======================================================================
Index: /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV1D/EXPREF/namelist_ice_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV1D/EXPREF/namelist_ice_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV1D/EXPREF/namelist_ice_cfg (revision 13540)
@@ -88,5 +88,5 @@
!------------------------------------------------------------------------------
ln_iceini = .true. ! activate ice initialization (T) or not (F)
- ln_iceini_file = .true. ! netcdf file provided for initialization (T) or not (F)
+ nn_iceini_file = 1 ! netcdf file provided for initialization
sn_hti = 'initice_60pts' , -12 ,'hti' , .false. , .true., 'yearly' , '' , '', ''
Index: /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV1D/EXPREF/namelist_ice_cfg_120pts
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV1D/EXPREF/namelist_ice_cfg_120pts (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV1D/EXPREF/namelist_ice_cfg_120pts (revision 13540)
@@ -88,5 +88,5 @@
!------------------------------------------------------------------------------
ln_iceini = .true. ! activate ice initialization (T) or not (F)
- ln_iceini_file = .true. ! netcdf file provided for initialization (T) or not (F)
+ nn_iceini_file = 1 ! netcdf file provided for initialization
sn_hti = 'initice_120pts' , -12 ,'hti' , .false. , .true., 'yearly' , '' , '', ''
Index: /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV1D/EXPREF/namelist_ice_cfg_240pts
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV1D/EXPREF/namelist_ice_cfg_240pts (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV1D/EXPREF/namelist_ice_cfg_240pts (revision 13540)
@@ -88,5 +88,5 @@
!------------------------------------------------------------------------------
ln_iceini = .true. ! activate ice initialization (T) or not (F)
- ln_iceini_file = .true. ! netcdf file provided for initialization (T) or not (F)
+ nn_iceini_file = 1 ! netcdf file provided for initialization
sn_hti = 'initice_240pts' , -12 ,'hti' , .false. , .true., 'yearly' , '' , '', ''
Index: /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV1D/EXPREF/namelist_ice_cfg_60pts
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV1D/EXPREF/namelist_ice_cfg_60pts (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV1D/EXPREF/namelist_ice_cfg_60pts (revision 13540)
@@ -88,5 +88,5 @@
!------------------------------------------------------------------------------
ln_iceini = .true. ! activate ice initialization (T) or not (F)
- ln_iceini_file = .true. ! netcdf file provided for initialization (T) or not (F)
+ nn_iceini_file = 1 ! netcdf file provided for initialization
sn_hti = 'initice_60pts' , -12 ,'hti' , .false. , .true., 'yearly' , '' , '', ''
Index: /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV1D/MY_SRC/usrdef_hgr.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV1D/MY_SRC/usrdef_hgr.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV1D/MY_SRC/usrdef_hgr.F90 (revision 13540)
@@ -26,4 +26,6 @@
PUBLIC usr_def_hgr ! called by domhgr.F90
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -62,7 +64,7 @@
REAL(wp), DIMENSION(:,:), INTENT(out) :: pe1e2u, pe1e2v ! u- & v-surfaces (if reduction in strait) [m2]
!
- INTEGER :: ji, jj ! dummy loop indices
+ INTEGER :: ji, jj ! dummy loop indices
REAL(wp) :: zphi0, zlam0, zbeta, zf0
- REAL(wp) :: zti, zui, ztj, zvj ! local scalars
+ REAL(wp) :: zti, ztj ! local scalars
!!-------------------------------------------------------------------------------
!
@@ -73,23 +75,21 @@
! ==========
- zlam0 = -(jpiglo-1)/2 * 1.e-3 * rn_dx
- zphi0 = -(jpjglo-1)/2 * 1.e-3 * rn_dy
+ zlam0 = -REAL( (Ni0glo-2)/2, wp) * 1.e-3 * rn_dx
+ zphi0 = -REAL( (Nj0glo-2)/2, wp) * 1.e-3 * rn_dy
- DO jj = 1, jpj
- DO ji = 1, jpi
- zti = FLOAT( ji - 1 + nimpp - 1 ) ; ztj = FLOAT( jj - 1 + njmpp - 1 )
- zui = FLOAT( ji - 1 + nimpp - 1 ) + 0.5_wp ; zvj = FLOAT( jj - 1 + njmpp - 1 ) + 0.5_wp
-
- plamt(ji,jj) = zlam0 + rn_dx * 1.e-3 * zti
- plamu(ji,jj) = zlam0 + rn_dx * 1.e-3 * zui
- plamv(ji,jj) = plamt(ji,jj)
- plamf(ji,jj) = plamu(ji,jj)
-
- pphit(ji,jj) = zphi0 + rn_dy * 1.e-3 * ztj
- pphiv(ji,jj) = zphi0 + rn_dy * 1.e-3 * zvj
- pphiu(ji,jj) = pphit(ji,jj)
- pphif(ji,jj) = pphiv(ji,jj)
- END DO
- END DO
+ DO_2D( 1, 1, 1, 1 )
+ zti = REAL( mig0_oldcmp(ji) - 1, wp ) ! start at i=0 in the global grid without halos
+ ztj = REAL( mjg0_oldcmp(jj) - 1, wp ) ! start at j=0 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 )
+ plamv(ji,jj) = plamt(ji,jj)
+ plamf(ji,jj) = plamu(ji,jj)
+
+ pphit(ji,jj) = zphi0 + rn_dy * 1.e-3 * ztj
+ pphiv(ji,jj) = zphi0 + rn_dy * 1.e-3 * ( ztj + 0.5_wp )
+ pphiu(ji,jj) = pphit(ji,jj)
+ pphif(ji,jj) = pphiv(ji,jj)
+ END_2D
! constant scale factors
Index: /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV1D/MY_SRC/usrdef_nam.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV1D/MY_SRC/usrdef_nam.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV1D/MY_SRC/usrdef_nam.F90 (revision 13540)
@@ -14,5 +14,4 @@
!! usr_def_hgr : initialize the horizontal mesh
!!----------------------------------------------------------------------
- USE dom_oce , ONLY: nimpp , njmpp ! i- & j-indices of the local domain
USE par_oce ! ocean space and time domain
USE phycst ! physical constants
@@ -91,6 +90,6 @@
WRITE(numout,*) ' LX [km]: ', zlx
WRITE(numout,*) ' LY [km]: ', zly
- WRITE(numout,*) ' resulting global domain size : jpiglo = ', kpi
- WRITE(numout,*) ' jpjglo = ', kpj
+ WRITE(numout,*) ' resulting global domain size : Ni0glo = ', kpi
+ WRITE(numout,*) ' Nj0glo = ', kpj
WRITE(numout,*) ' jpkglo = ', kpk
WRITE(numout,*) ' Coriolis:', ln_corio
Index: /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV1D/MY_SRC/usrdef_sbc.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV1D/MY_SRC/usrdef_sbc.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV1D/MY_SRC/usrdef_sbc.F90 (revision 13540)
@@ -107,6 +107,8 @@
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
!!---------------------------------------------------------------------
!
@@ -141,15 +143,18 @@
! --- shortwave radiation transmitted below the surface (W/m2, see Grenfell Maykut 77) --- !
- zfr1 = ( 0.18 * ( 1.0 - cldf_ice ) + 0.35 * cldf_ice ) ! transmission when hi>10cm
- zfr2 = ( 0.82 * ( 1.0 - cldf_ice ) + 0.65 * cldf_ice ) ! zfr2 such that zfr1 + zfr2 to equal 1
+ cloud_fra(:,:) = pp_cldf
+ ztri(:,:) = 0.18 * ( 1.0 - cloud_fra(:,:) ) + 0.35 * cloud_fra(:,:) ! surface transmission when hi>10cm
!
- 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
- qtr_ice_top(:,:,:) = qsr_ice(:,:,:) * zfr1
- ELSEWHERE ! zero when hs>0
- qtr_ice_top(:,:,:) = 0._wp
- END WHERE
-
+ 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
+ qtr_ice_top(:,:,jl) = qsr_ice(:,:,jl) * ztri(:,:)
+ ELSEWHERE ! zero when hs>0
+ qtr_ice_top(:,:,jl) = 0._wp
+ END WHERE
+ ENDDO
+
+
END SUBROUTINE usrdef_sbc_ice_flx
Index: /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV2D/EXPREF/context_nemo.xml
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV2D/EXPREF/context_nemo.xml (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV2D/EXPREF/context_nemo.xml (revision 13540)
@@ -11,5 +11,5 @@
01
01
- 1026.0
+ 1026.0
3991.86795711963
0.99530670233846
Index: /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV2D/EXPREF/namelist_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV2D/EXPREF/namelist_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV2D/EXPREF/namelist_cfg (revision 13540)
@@ -106,6 +106,6 @@
!! !!
!! namdrg top/bottom drag coefficient (default: NO selection)
-!! namdrg_top top friction (ln_OFF=F & ln_isfcav=T)
-!! namdrg_bot bottom friction (ln_OFF=F)
+!! 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)
@@ -115,5 +115,5 @@
&namdrg ! top/bottom drag coefficient (default: NO selection)
!-----------------------------------------------------------------------
- ln_OFF = .true. ! free-slip : Cd = 0
+ ln_drg_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot
/
!!======================================================================
Index: /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV2D/EXPREF/namelist_ice_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV2D/EXPREF/namelist_ice_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV2D/EXPREF/namelist_ice_cfg (revision 13540)
@@ -86,5 +86,5 @@
!------------------------------------------------------------------------------
ln_iceini = .true. ! activate ice initialization (T) or not (F)
- ln_iceini_file = .true. ! netcdf file provided for initialization (T) or not (F)
+ nn_iceini_file = 1 ! netcdf file provided for initialization
sn_hti = 'initice' , -12 ,'hti' , .false. , .true., 'yearly' , '' , '', ''
Index: /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV2D/MY_SRC/usrdef_hgr.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV2D/MY_SRC/usrdef_hgr.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV2D/MY_SRC/usrdef_hgr.F90 (revision 13540)
@@ -26,4 +26,6 @@
PUBLIC usr_def_hgr ! called by domhgr.F90
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -62,7 +64,7 @@
REAL(wp), DIMENSION(:,:), INTENT(out) :: pe1e2u, pe1e2v ! u- & v-surfaces (if reduction in strait) [m2]
!
- INTEGER :: ji, jj ! dummy loop indices
+ INTEGER :: ji, jj ! dummy loop indices
REAL(wp) :: zphi0, zlam0, zbeta, zf0
- REAL(wp) :: zti, zui, ztj, zvj ! local scalars
+ REAL(wp) :: zti, ztj ! local scalars
!!-------------------------------------------------------------------------------
!
@@ -74,6 +76,6 @@
! ==========
- zlam0 = -(jpiglo-1)/2 * 1.e-3 * rn_dx
- zphi0 = -(jpjglo-1)/2 * 1.e-3 * rn_dy
+ zlam0 = -REAL( (Ni0glo-2)/2, wp) * 1.e-3 * rn_dx
+ zphi0 = -REAL( (Nj0glo-2)/2, wp) * 1.e-3 * rn_dy
#if defined key_agrif
@@ -81,27 +83,25 @@
!clem zlam0 = Agrif_Parent(zlam0) + (Agrif_ix())*Agrif_Parent(rn_dx) * 1.e-5
!clem zphi0 = Agrif_Parent(zphi0) + (Agrif_iy())*Agrif_Parent(rn_dy) * 1.e-5
- zlam0 = ( 0.5_wp - ( Agrif_parent(jpiglo) - 1 ) / 2 ) * 1.e-3 * Agrif_irhox() * rn_dx &
+ zlam0 = ( 0.5_wp - REAL( (Agrif_parent(Ni0glo) - 2 ) / 2, wp ) ) * 1.e-3 * Agrif_irhox() * rn_dx &
& + ( Agrif_Ix() + nbghostcells - 1 ) * Agrif_irhox() * rn_dx * 1.e-3 - ( 0.5_wp + nbghostcells ) * rn_dx * 1.e-3
- zphi0 = ( 0.5_wp - ( Agrif_parent(jpjglo) - 1 ) / 2 ) * 1.e-3 * Agrif_irhoy() * rn_dy &
+ zphi0 = ( 0.5_wp - REAL( (Agrif_parent(Nj0glo) - 2 ) / 2, wp ) ) * 1.e-3 * Agrif_irhoy() * rn_dy &
& + ( Agrif_Iy() + nbghostcells - 1 ) * Agrif_irhoy() * rn_dy * 1.e-3 - ( 0.5_wp + nbghostcells ) * rn_dy * 1.e-3
ENDIF
#endif
- DO jj = 1, jpj
- DO ji = 1, jpi
- zti = FLOAT( ji - 1 + nimpp - 1 ) ; ztj = FLOAT( jj - 1 + njmpp - 1 )
- zui = FLOAT( ji - 1 + nimpp - 1 ) + 0.5_wp ; zvj = FLOAT( jj - 1 + njmpp - 1 ) + 0.5_wp
-
- plamt(ji,jj) = zlam0 + rn_dx * 1.e-3 * zti
- plamu(ji,jj) = zlam0 + rn_dx * 1.e-3 * zui
- plamv(ji,jj) = plamt(ji,jj)
- plamf(ji,jj) = plamu(ji,jj)
-
- pphit(ji,jj) = zphi0 + rn_dy * 1.e-3 * ztj
- pphiv(ji,jj) = zphi0 + rn_dy * 1.e-3 * zvj
- pphiu(ji,jj) = pphit(ji,jj)
- pphif(ji,jj) = pphiv(ji,jj)
- END DO
- END DO
+ DO_2D( 1, 1, 1, 1 )
+ zti = REAL( mig0_oldcmp(ji) - 1, wp ) ! start at i=0 in the global grid without halos
+ ztj = REAL( mjg0_oldcmp(jj) - 1, wp ) ! start at j=0 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 )
+ plamv(ji,jj) = plamt(ji,jj)
+ plamf(ji,jj) = plamu(ji,jj)
+
+ pphit(ji,jj) = zphi0 + rn_dy * 1.e-3 * ztj
+ pphiv(ji,jj) = zphi0 + rn_dy * 1.e-3 * ( ztj + 0.5_wp )
+ pphiu(ji,jj) = pphit(ji,jj)
+ pphif(ji,jj) = pphiv(ji,jj)
+ END_2D
! Horizontal scale factors (in meters)
Index: /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV2D/MY_SRC/usrdef_nam.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV2D/MY_SRC/usrdef_nam.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV2D/MY_SRC/usrdef_nam.F90 (revision 13540)
@@ -14,5 +14,5 @@
!! usr_def_hgr : initialize the horizontal mesh
!!----------------------------------------------------------------------
- USE dom_oce , ONLY: nimpp , njmpp ! i- & j-indices of the local domain
+ USE dom_oce
USE par_oce ! ocean space and time domain
USE phycst ! physical constants
@@ -82,12 +82,12 @@
kk_cfg = NINT( rn_dx )
!
- IF( Agrif_Root() ) THEN ! Global Domain size: ICE_AGRIF domain is 300 km x 300 Km x 10 m
+ IF( Agrif_Root() ) THEN ! Global Domain size: ICE_AGRIF domain is 300 km x 300 Km x 10 m
kpi = NINT( 300.e3 / rn_dx ) - 1
kpj = NINT( 300.e3 / rn_dy ) - 1
- ELSE
- kpi = nbcellsx + 2 + 2*nbghostcells
- kpj = nbcellsy + 2 + 2*nbghostcells
+ ELSE ! Global Domain size: add nbghostcells + 1 "land" point on each side
+ kpi = nbcellsx + nbghostcells_x + nbghostcells_x + 2
+ kpj = nbcellsy + nbghostcells_y_s + nbghostcells_y_n + 2
ENDIF
- kpk = 1
+ kpk = 2
!
!! zlx = (kpi-2)*rn_dx*1.e-3
@@ -110,6 +110,6 @@
WRITE(numout,*) ' LX [km]: ', zlx
WRITE(numout,*) ' LY [km]: ', zly
- WRITE(numout,*) ' resulting global domain size : jpiglo = ', kpi
- WRITE(numout,*) ' jpjglo = ', kpj
+ WRITE(numout,*) ' resulting global domain size : Ni0glo = ', kpi
+ WRITE(numout,*) ' Nj0glo = ', kpj
WRITE(numout,*) ' jpkglo = ', kpk
WRITE(numout,*) ' Coriolis:', ln_corio
Index: /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV2D/MY_SRC/usrdef_sbc.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV2D/MY_SRC/usrdef_sbc.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/ICE_ADV2D/MY_SRC/usrdef_sbc.F90 (revision 13540)
@@ -107,6 +107,8 @@
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
!!---------------------------------------------------------------------
!
@@ -141,15 +143,18 @@
! --- shortwave radiation transmitted below the surface (W/m2, see Grenfell Maykut 77) --- !
- zfr1 = ( 0.18 * ( 1.0 - cldf_ice ) + 0.35 * cldf_ice ) ! transmission when hi>10cm
- zfr2 = ( 0.82 * ( 1.0 - cldf_ice ) + 0.65 * cldf_ice ) ! zfr2 such that zfr1 + zfr2 to equal 1
+ cloud_fra(:,:) = pp_cldf
+ ztri(:,:) = 0.18 * ( 1.0 - cloud_fra(:,:) ) + 0.35 * cloud_fra(:,:) ! surface transmission when hi>10cm
!
- 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
- qtr_ice_top(:,:,:) = qsr_ice(:,:,:) * zfr1
- ELSEWHERE ! zero when hs>0
- qtr_ice_top(:,:,:) = 0._wp
- END WHERE
-
+ 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
+ qtr_ice_top(:,:,jl) = qsr_ice(:,:,jl) * ztri(:,:)
+ ELSEWHERE ! zero when hs>0
+ qtr_ice_top(:,:,jl) = 0._wp
+ END WHERE
+ ENDDO
+
+
END SUBROUTINE usrdef_sbc_ice_flx
Index: /NEMO/branches/2020/r12377_ticket2386/tests/ICE_AGRIF/EXPREF/1_namelist_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/ICE_AGRIF/EXPREF/1_namelist_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/ICE_AGRIF/EXPREF/1_namelist_cfg (revision 13540)
@@ -106,6 +106,6 @@
!! !!
!! namdrg top/bottom drag coefficient (default: NO selection)
-!! namdrg_top top friction (ln_OFF=F & ln_isfcav=T)
-!! namdrg_bot bottom friction (ln_OFF=F)
+!! 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)
@@ -115,5 +115,5 @@
&namdrg ! top/bottom drag coefficient (default: NO selection)
!-----------------------------------------------------------------------
- ln_OFF = .true. ! free-slip : Cd = 0
+ ln_drg_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot
/
!!======================================================================
Index: /NEMO/branches/2020/r12377_ticket2386/tests/ICE_AGRIF/EXPREF/AGRIF_FixedGrids.in
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/ICE_AGRIF/EXPREF/AGRIF_FixedGrids.in (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/ICE_AGRIF/EXPREF/AGRIF_FixedGrids.in (revision 13540)
@@ -1,3 +1,3 @@
1
-34 63 34 63 3 3 3
+33 62 33 62 3 3 3
0
Index: /NEMO/branches/2020/r12377_ticket2386/tests/ICE_AGRIF/EXPREF/context_nemo.xml
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/ICE_AGRIF/EXPREF/context_nemo.xml (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/ICE_AGRIF/EXPREF/context_nemo.xml (revision 13540)
@@ -11,5 +11,5 @@
01
01
- 1026.0
+ 1026.0
3991.86795711963
0.99530670233846
Index: /NEMO/branches/2020/r12377_ticket2386/tests/ICE_AGRIF/EXPREF/namelist_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/ICE_AGRIF/EXPREF/namelist_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/ICE_AGRIF/EXPREF/namelist_cfg (revision 13540)
@@ -106,6 +106,6 @@
!! !!
!! namdrg top/bottom drag coefficient (default: NO selection)
-!! namdrg_top top friction (ln_OFF=F & ln_isfcav=T)
-!! namdrg_bot bottom friction (ln_OFF=F)
+!! 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)
@@ -115,5 +115,5 @@
&namdrg ! top/bottom drag coefficient (default: NO selection)
!-----------------------------------------------------------------------
- ln_OFF = .true. ! free-slip : Cd = 0
+ ln_drg_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot
/
!!======================================================================
Index: /NEMO/branches/2020/r12377_ticket2386/tests/ICE_AGRIF/EXPREF/namelist_ice_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/ICE_AGRIF/EXPREF/namelist_ice_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/ICE_AGRIF/EXPREF/namelist_ice_cfg (revision 13540)
@@ -86,5 +86,5 @@
!------------------------------------------------------------------------------
ln_iceini = .true. ! activate ice initialization (T) or not (F)
- ln_iceini_file = .true. ! netcdf file provided for initialization (T) or not (F)
+ nn_iceini_file = 1 ! netcdf file provided for initialization
sn_hti = 'initice' , -12 ,'hti' , .false. , .true., 'yearly' , '' , '', ''
Index: /NEMO/branches/2020/r12377_ticket2386/tests/ICE_AGRIF/MY_SRC/usrdef_hgr.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/ICE_AGRIF/MY_SRC/usrdef_hgr.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/ICE_AGRIF/MY_SRC/usrdef_hgr.F90 (revision 13540)
@@ -26,4 +26,6 @@
PUBLIC usr_def_hgr ! called by domhgr.F90
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -62,7 +64,7 @@
REAL(wp), DIMENSION(:,:), INTENT(out) :: pe1e2u, pe1e2v ! u- & v-surfaces (if reduction in strait) [m2]
!
- INTEGER :: ji, jj ! dummy loop indices
+ INTEGER :: ji, jj ! dummy loop indices
REAL(wp) :: zphi0, zlam0, zbeta, zf0
- REAL(wp) :: zti, zui, ztj, zvj ! local scalars
+ REAL(wp) :: zti, ztj ! local scalars
!!-------------------------------------------------------------------------------
!
@@ -74,34 +76,41 @@
! ==========
- zlam0 = -(jpiglo-1)/2 * 1.e-3 * rn_dx
- zphi0 = -(jpjglo-1)/2 * 1.e-3 * rn_dy
-
#if defined key_agrif
- IF( .NOT. Agrif_Root() ) THEN
+ IF( Agrif_Root() ) THEN
+#endif
+ ! Compatibility WITH old version:
+ ! jperio = 7 => Ni0glo = jpigo_old_version - 2
+ ! => jpiglo-1 replaced by Ni0glo+1
+ zlam0 = -REAL( (Ni0glo+1)/2, wp) * 1.e-3 * rn_dx
+ zphi0 = -REAL( (Nj0glo+1)/2, wp) * 1.e-3 * rn_dy ! +1 for compatibility with old version --> to be replaced by -1 as before
+#if defined key_agrif
+ ELSE
+ ! ! let lower left longitude and latitude from parent
!clem zlam0 = Agrif_Parent(zlam0) + (Agrif_ix())*Agrif_Parent(rn_dx) * 1.e-5
!clem zphi0 = Agrif_Parent(zphi0) + (Agrif_iy())*Agrif_Parent(rn_dy) * 1.e-5
- zlam0 = ( 0.5_wp - ( Agrif_parent(jpiglo) - 1 ) / 2 ) * 1.e-3 * Agrif_irhox() * rn_dx &
+ ! Compatibility WITH old version:
+ ! jperio = 0 => Ni0glo = jpigo_old_version
+ ! => Agrif_parent(jpiglo)-1 replaced by Agrif_parent(Ni0glo)-1
+ zlam0 = ( 0.5_wp - REAL( ( Agrif_parent(Ni0glo)-1 ) / 2, wp) ) * 1.e-3 * Agrif_irhox() * rn_dx &
& + ( Agrif_Ix() + nbghostcells - 1 ) * Agrif_irhox() * rn_dx * 1.e-3 - ( 0.5_wp + nbghostcells ) * rn_dx * 1.e-3
- zphi0 = ( 0.5_wp - ( Agrif_parent(jpjglo) - 1 ) / 2 ) * 1.e-3 * Agrif_irhoy() * rn_dy &
+ zphi0 = ( 0.5_wp - REAL( ( Agrif_parent(Nj0glo)-1 ) / 2, wp) ) * 1.e-3 * Agrif_irhoy() * rn_dy &
& + ( Agrif_Iy() + nbghostcells - 1 ) * Agrif_irhoy() * rn_dy * 1.e-3 - ( 0.5_wp + nbghostcells ) * rn_dy * 1.e-3
ENDIF
#endif
- DO jj = 1, jpj
- DO ji = 1, jpi
- zti = FLOAT( ji - 1 + nimpp - 1 ) ; ztj = FLOAT( jj - 1 + njmpp - 1 )
- zui = FLOAT( ji - 1 + nimpp - 1 ) + 0.5_wp ; zvj = FLOAT( jj - 1 + njmpp - 1 ) + 0.5_wp
-
- plamt(ji,jj) = zlam0 + rn_dx * 1.e-3 * zti
- plamu(ji,jj) = zlam0 + rn_dx * 1.e-3 * zui
- plamv(ji,jj) = plamt(ji,jj)
- plamf(ji,jj) = plamu(ji,jj)
-
- pphit(ji,jj) = zphi0 + rn_dy * 1.e-3 * ztj
- pphiv(ji,jj) = zphi0 + rn_dy * 1.e-3 * zvj
- pphiu(ji,jj) = pphit(ji,jj)
- pphif(ji,jj) = pphiv(ji,jj)
- END DO
- END DO
+ DO_2D( 1, 1, 1, 1 )
+ zti = REAL( mig0_oldcmp(ji) - 1, wp ) ! start at i=0 in the global grid without halos
+ ztj = REAL( mjg0_oldcmp(jj) - 1, wp ) ! start at j=0 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 )
+ plamv(ji,jj) = plamt(ji,jj)
+ plamf(ji,jj) = plamu(ji,jj)
+
+ pphit(ji,jj) = zphi0 + rn_dy * 1.e-3 * ztj
+ pphiv(ji,jj) = zphi0 + rn_dy * 1.e-3 * ( ztj + 0.5_wp )
+ pphiu(ji,jj) = pphit(ji,jj)
+ pphif(ji,jj) = pphiv(ji,jj)
+ END_2D
! Horizontal scale factors (in meters)
Index: /NEMO/branches/2020/r12377_ticket2386/tests/ICE_AGRIF/MY_SRC/usrdef_nam.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/ICE_AGRIF/MY_SRC/usrdef_nam.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/ICE_AGRIF/MY_SRC/usrdef_nam.F90 (revision 13540)
@@ -14,5 +14,5 @@
!! usr_def_hgr : initialize the horizontal mesh
!!----------------------------------------------------------------------
- USE dom_oce , ONLY: nimpp , njmpp ! i- & j-indices of the local domain
+ USE dom_oce
USE par_oce ! ocean space and time domain
USE phycst ! physical constants
@@ -85,9 +85,13 @@
kpi = NINT( 300.e3 / rn_dx ) - 1
kpj = NINT( 300.e3 / rn_dy ) - 1
- ELSE
- kpi = nbcellsx + 2 + 2*nbghostcells
- kpj = nbcellsy + 2 + 2*nbghostcells
+ kpi = kpi - 2 ! for compatibility with old version (because kerio=7) --> to be removed
+ kpj = kpj - 2 ! for compatibility with old version (because kerio=7) --> to be removed
+ ELSE ! Global Domain size: add nbghostcells + 1 "land" point on each side
+ kpi = nbcellsx + 2 * ( nbghostcells + 1 )
+ kpj = nbcellsy + 2 * ( nbghostcells + 1 )
+!!$ kpi = nbcellsx + nbghostcells_x + nbghostcells_x + 2
+!!$ kpj = nbcellsy + nbghostcells_y_s + nbghostcells_y_n + 2
ENDIF
- kpk = 1
+ kpk = 2
!
!! zlx = (kpi-2)*rn_dx*1.e-3
@@ -110,6 +114,6 @@
WRITE(numout,*) ' LX [km]: ', zlx
WRITE(numout,*) ' LY [km]: ', zly
- WRITE(numout,*) ' resulting global domain size : jpiglo = ', kpi
- WRITE(numout,*) ' jpjglo = ', kpj
+ WRITE(numout,*) ' resulting global domain size : Ni0glo = ', kpi
+ WRITE(numout,*) ' Nj0glo = ', kpj
WRITE(numout,*) ' jpkglo = ', kpk
WRITE(numout,*) ' Coriolis:', ln_corio
Index: /NEMO/branches/2020/r12377_ticket2386/tests/ICE_AGRIF/MY_SRC/usrdef_sbc.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/ICE_AGRIF/MY_SRC/usrdef_sbc.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/ICE_AGRIF/MY_SRC/usrdef_sbc.F90 (revision 13540)
@@ -107,6 +107,8 @@
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
!!---------------------------------------------------------------------
!
@@ -141,14 +143,16 @@
! --- shortwave radiation transmitted below the surface (W/m2, see Grenfell Maykut 77) --- !
- zfr1 = ( 0.18 * ( 1.0 - cldf_ice ) + 0.35 * cldf_ice ) ! transmission when hi>10cm
- zfr2 = ( 0.82 * ( 1.0 - cldf_ice ) + 0.65 * cldf_ice ) ! zfr2 such that zfr1 + zfr2 to equal 1
+ cloud_fra(:,:) = pp_cldf
+ ztri(:,:) = 0.18 * ( 1.0 - cloud_fra(:,:) ) + 0.35 * cloud_fra(:,:) ! surface transmission when hi>10cm
!
- 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
- qtr_ice_top(:,:,:) = qsr_ice(:,:,:) * zfr1
- ELSEWHERE ! zero when hs>0
- qtr_ice_top(:,:,:) = 0._wp
- END WHERE
+ 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
+ qtr_ice_top(:,:,jl) = qsr_ice(:,:,jl) * ztri(:,:)
+ ELSEWHERE ! zero when hs>0
+ qtr_ice_top(:,:,jl) = 0._wp
+ END WHERE
+ ENDDO
END SUBROUTINE usrdef_sbc_ice_flx
Index: /NEMO/branches/2020/r12377_ticket2386/tests/ICE_AGRIF/MY_SRC/usrdef_zgr.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/ICE_AGRIF/MY_SRC/usrdef_zgr.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/ICE_AGRIF/MY_SRC/usrdef_zgr.F90 (revision 13540)
@@ -89,5 +89,5 @@
! !== z-coordinate ==! (step-like topography)
! !* bottom ocean compute from the depth of grid-points
- jpkm1 = jpk
+ jpkm1 = jpk-1
k_bot(:,:) = 1 ! here use k_top as a land mask
! !* horizontally uniform coordinate (reference z-co everywhere)
Index: /NEMO/branches/2020/r12377_ticket2386/tests/ISOMIP+/EXPREF/file_def_nemo-oce.xml
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/ISOMIP+/EXPREF/file_def_nemo-oce.xml (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/ISOMIP+/EXPREF/file_def_nemo-oce.xml (revision 13540)
@@ -21,25 +21,26 @@
-
-
-
-
-
+
+ @toce_e3t / @e3t
+ @soce_e3t / @e3t
+
-
-
-
+
+
+
-
-
-
+
+
+
-
-
+
+ @uoce_e3u / @e3u />
-
-
+
+ @voce_e3v / @e3v />
+
+
Index: /NEMO/branches/2020/r12377_ticket2386/tests/ISOMIP+/EXPREF/namelist_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/ISOMIP+/EXPREF/namelist_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/ISOMIP+/EXPREF/namelist_cfg (revision 13540)
@@ -114,5 +114,5 @@
ln_usr = .true. ! user defined formulation (T => check usrdef_sbc)
- nn_fwb = 1
+ nn_fwb = 4
/
!-----------------------------------------------------------------------
@@ -261,6 +261,6 @@
!! !!
!! namdrg top/bottom drag coefficient (default: NO selection)
-!! namdrg_top top friction (ln_OFF=F & ln_isfcav=T)
-!! namdrg_bot bottom friction (ln_OFF=F)
+!! 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)
@@ -273,5 +273,5 @@
/
!-----------------------------------------------------------------------
-&namdrg_top ! TOP friction (ln_OFF =F & ln_isfcav=T)
+&namdrg_top ! TOP friction (ln_drg_OFF =F & ln_isfcav=T)
!-----------------------------------------------------------------------
rn_Cd0 = 2.5e-3 ! drag coefficient [-]
@@ -279,5 +279,5 @@
/
!-----------------------------------------------------------------------
-&namdrg_bot ! BOTTOM friction (ln_OFF =F)
+&namdrg_bot ! BOTTOM friction (ln_drg_OFF =F)
!-----------------------------------------------------------------------
rn_Cd0 = 2.5e-3 ! drag coefficient [-]
@@ -308,12 +308,10 @@
&nameos ! ocean Equation Of Seawater (default: NO selection)
!-----------------------------------------------------------------------
- ln_teos10 = .false. ! = Use TEOS-10
- ln_eos80 = .false. ! = Use EOS80
- ln_leos = .true. ! = Use S-EOS (simplified Eq.)
+ ln_leos = .true. ! = Use L-EOS (linear Eq.)
!
! ! S-EOS coefficients (ln_seos=T):
- ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
+ ! ! 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)*rau0 = rau0*(-a0*dT+b0*dS)
+ ! ! rd(T,S,Z)*rho0 = rho0*(-a0*dT+b0*dS)
rn_a0 = 3.7330e-5 ! thermal expension coefficient
rn_b0 = 7.8430e-4 ! saline expension coefficient
Index: /NEMO/branches/2020/r12377_ticket2386/tests/ISOMIP+/MY_SRC/dtatsd.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/ISOMIP+/MY_SRC/dtatsd.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/ISOMIP+/MY_SRC/dtatsd.F90 (revision 13540)
@@ -36,4 +36,6 @@
TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_tsddmp ! structure of input SST (file informations, fields read)
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -67,8 +69,6 @@
ierr0 = 0 ; ierr1 = 0 ; ierr2 = 0 ; ierr3 = 0
!
- REWIND( numnam_ref ) ! Namelist namtsd in reference namelist :
READ ( numnam_ref, namtsd, IOSTAT = ios, ERR = 901)
901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtsd in reference namelist' )
- REWIND( numnam_cfg ) ! Namelist namtsd in configuration namelist : Parameters of the run
READ ( numnam_cfg, namtsd, IOSTAT = ios, ERR = 902 )
902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtsd in configuration namelist' )
@@ -191,32 +191,30 @@
ENDIF
!
- DO jj = 1, jpj ! vertical interpolation of T & S
- DO ji = 1, jpi
- DO jk = 1, jpk ! determines the intepolated T-S profiles at each (i,j) points
- zl = gdept_0(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)
- ELSEIF( zl > gdept_1d(jpk) ) THEN ! below the last level of data
- 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)
- 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
- zsp(jk) = ptsd(ji,jj,jkk,jp_sal) + ( ptsd(ji,jj,jkk+1,jp_sal) - ptsd(ji,jj,jkk,jp_sal) ) * zi
- ENDIF
- END DO
- ENDIF
- END DO
- DO jk = 1, jpkm1
- ptsd(ji,jj,jk,jp_tem) = ztp(jk) * tmask(ji,jj,jk) ! mask required for mixed zps-s-coord
- ptsd(ji,jj,jk,jp_sal) = zsp(jk) * tmask(ji,jj,jk)
- END DO
- ptsd(ji,jj,jpk,jp_tem) = 0._wp
- ptsd(ji,jj,jpk,jp_sal) = 0._wp
+ DO_2D( 1, 1, 1, 1 )
+ DO jk = 1, jpk ! determines the intepolated T-S profiles at each (i,j) points
+ zl = gdept_0(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)
+ ELSEIF( zl > gdept_1d(jpk) ) THEN ! below the last level of data
+ 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)
+ 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
+ zsp(jk) = ptsd(ji,jj,jkk,jp_sal) + ( ptsd(ji,jj,jkk+1,jp_sal) - ptsd(ji,jj,jkk,jp_sal) ) * zi
+ ENDIF
+ END DO
+ ENDIF
END DO
- END DO
+ DO jk = 1, jpkm1
+ ptsd(ji,jj,jk,jp_tem) = ztp(jk) * tmask(ji,jj,jk) ! mask required for mixed zps-s-coord
+ ptsd(ji,jj,jk,jp_sal) = zsp(jk) * tmask(ji,jj,jk)
+ END DO
+ ptsd(ji,jj,jpk,jp_tem) = 0._wp
+ ptsd(ji,jj,jpk,jp_sal) = 0._wp
+ END_2D
!
ELSE !== z- or zps- coordinate ==!
@@ -226,20 +224,18 @@
!
IF( ln_zps ) THEN ! zps-coordinate (partial steps) interpolation at the last ocean level
- DO jj = 1, jpj
- DO ji = 1, jpi
- 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 DO
- END DO
+ 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) )
+ 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
!
Index: /NEMO/branches/2020/r12377_ticket2386/tests/ISOMIP+/MY_SRC/eosbn2.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/ISOMIP+/MY_SRC/eosbn2.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/ISOMIP+/MY_SRC/eosbn2.F90 (revision 13540)
@@ -180,4 +180,6 @@
REAL(wp) :: BPE002
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -241,12 +243,129 @@
CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==!
!
- DO jk = 1, jpkm1
- DO jj = 1, jpj
- DO ji = 1, jpi
- !
- 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
+ DO_3D( 1, 1, 1, 1, 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( 1, 1, 1, 1, 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( 1, 1, 1, 1, 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
+
+
+ SUBROUTINE eos_insitu_pot( pts, prd, prhop, pdep )
+ !!----------------------------------------------------------------------
+ !! *** 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)
+ !!
+ !!----------------------------------------------------------------------
+ REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! 1 : potential temperature [Celsius]
+ ! ! 2 : salinity [psu]
+ REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT( out) :: prd ! in situ density [-]
+ REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT( out) :: prhop ! potential density (surface referenced)
+ REAL(wp), DIMENSION(jpi,jpj,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( 1, 1, 1, 1, 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 &
@@ -263,5 +382,5 @@
& + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001
!
- zn0 = (((((EOS060*zt &
+ zn0_sto(jsmp) = (((((EOS060*zt &
& + EOS150*zs+EOS050)*zt &
& + (EOS240*zs+EOS140)*zs+EOS040)*zt &
@@ -271,278 +390,26 @@
& + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000
!
- zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0
+ 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) = ( zn * r1_rho0 - 1._wp ) * ztm ! density anomaly (masked)
- !
+ prd(ji,jj,jk) = prd(ji,jj,jk) + ( zn_sto(jsmp) * r1_rho0 - 1._wp ) ! density anomaly (masked)
END DO
- END DO
- END DO
- !
- CASE( np_seos ) !== simplified EOS ==!
- !
- DO jk = 1, jpkm1
- DO jj = 1, jpj
- DO ji = 1, jpi
- 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 DO
- END DO
- END DO
- !
- CASE( np_leos ) !== linear ISOMIP EOS ==!
- !
- DO jk = 1, jpkm1
- DO jj = 1, jpj
- DO ji = 1, jpi
- 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 DO
- END DO
- END DO
- !
- END SELECT
- !
- IF(ln_ctl) CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-insitu : ', kdim=jpk )
- !
- IF( ln_timing ) CALL timing_stop('eos-insitu')
- !
- END SUBROUTINE eos_insitu
-
-
- SUBROUTINE eos_insitu_pot( pts, prd, prhop, pdep )
- !!----------------------------------------------------------------------
- !! *** 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)
- !!
- !!----------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! 1 : potential temperature [Celsius]
- ! ! 2 : salinity [psu]
- REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT( out) :: prd ! in situ density [-]
- REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT( out) :: prhop ! potential density (surface referenced)
- REAL(wp), DIMENSION(jpi,jpj,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 jk = 1, jpkm1
- DO jj = 1, jpj
- DO ji = 1, jpi
- !
- ! 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 DO
- END DO
- 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 jk = 1, jpkm1
- DO jj = 1, jpj
- DO ji = 1, jpi
- !
- 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 DO
- END DO
- END DO
- ENDIF
-
- CASE( np_seos ) !== simplified EOS ==!
- !
- DO jk = 1, jpkm1
- DO jj = 1, jpj
- DO ji = 1, jpi
- 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 DO
- END DO
- END DO
- !
- CASE( np_leos ) !== linear ISOMIP EOS ==!
- !
- DO jk = 1, jpkm1
- DO jj = 1, jpj
- DO ji = 1, jpi
- 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 DO
- END DO
- END DO
- !
- END SELECT
- !
- IF(ln_ctl) 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
-
-
- SUBROUTINE eos_insitu_2d( pts, pdep, prd )
- !!----------------------------------------------------------------------
- !! *** 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)
- !!
- !!----------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT(in ) :: pts ! 1 : potential temperature [Celsius]
- ! ! 2 : salinity [psu]
- REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: pdep ! depth [m]
- REAL(wp), DIMENSION(jpi,jpj) , 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 jj = 1, jpjm1
- DO ji = 1, fs_jpim1 ! vector opt.
- !
- 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
+ DO_3D( 1, 1, 1, 1, 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 &
@@ -569,52 +436,148 @@
zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0
!
- prd(ji,jj) = zn * r1_rho0 - 1._wp ! unmasked in situ density anomaly
- !
- END DO
- END DO
- !
- CALL lbc_lnk( 'eosbn2', prd, 'T', 1. ) ! Lateral boundary conditions
- !
+ 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 jj = 1, jpjm1
- DO ji = 1, fs_jpim1 ! vector opt.
- !
- 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 DO
- END DO
- !
- CALL lbc_lnk( 'eosbn2', prd, 'T', 1. ) ! Lateral boundary conditions
+ DO_3D( 1, 1, 1, 1, 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( 1, 1, 1, 1, 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
+
+
+ SUBROUTINE eos_insitu_2d( pts, pdep, prd )
+ !!----------------------------------------------------------------------
+ !! *** 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)
+ !!
+ !!----------------------------------------------------------------------
+ REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT(in ) :: pts ! 1 : potential temperature [Celsius]
+ ! ! 2 : salinity [psu]
+ REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: pdep ! depth [m]
+ REAL(wp), DIMENSION(jpi,jpj) , 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( 1, 1, 1, 1 )
+ !
+ 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( 1, 1, 1, 1 )
+ !
+ 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 jj = 1, jpjm1
- DO ji = 1, fs_jpim1 ! vector opt.
- !
- 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 DO
- END DO
- !
- CALL lbc_lnk( 'eosbn2', prd, 'T', 1. ) ! Lateral boundary conditions
+ DO_2D( 1, 1, 1, 1 )
+ !
+ 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(ln_ctl) CALL prt_ctl( tab2d_1=prd, clinfo1=' eos2d: ' )
+ IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=prd, clinfo1=' eos2d: ' )
!
IF( ln_timing ) CALL timing_stop('eos2d')
@@ -648,98 +611,86 @@
CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==!
!
- DO jk = 1, jpkm1
- DO jj = 1, jpj
- DO ji = 1, jpi
- !
- 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 DO
- END DO
- END DO
+ DO_3D( 1, 1, 1, 1, 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 jk = 1, jpkm1
- DO jj = 1, jpj
- DO ji = 1, jpi
- 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 DO
- END DO
- END DO
+ DO_3D( 1, 1, 1, 1, 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 jk = 1, jpkm1
- DO jj = 1, jpj
- DO ji = 1, jpi
- 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 DO
- END DO
- END DO
+ DO_3D( 1, 1, 1, 1, 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
@@ -749,6 +700,6 @@
END SELECT
!
- IF(ln_ctl) CALL prt_ctl( tab3d_1=pab(:,:,:,jp_tem), clinfo1=' rab_3d_t: ', &
- & tab3d_2=pab(:,:,:,jp_sal), clinfo2=' rab_3d_s : ', kdim=jpk )
+ 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')
@@ -783,98 +734,86 @@
CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==!
!
- DO jj = 1, jpjm1
- DO ji = 1, fs_jpim1 ! vector opt.
- !
- 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 DO
- END DO
- ! ! Lateral boundary conditions
- CALL lbc_lnk_multi( 'eosbn2', pab(:,:,jp_tem), 'T', 1. , pab(:,:,jp_sal), 'T', 1. )
+ DO_2D( 1, 1, 1, 1 )
+ !
+ 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 jj = 1, jpjm1
- DO ji = 1, fs_jpim1 ! vector opt.
- !
- 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 DO
- END DO
- ! ! Lateral boundary conditions
- CALL lbc_lnk_multi( 'eosbn2', pab(:,:,jp_tem), 'T', 1. , pab(:,:,jp_sal), 'T', 1. )
+ DO_2D( 1, 1, 1, 1 )
+ !
+ 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 jj = 1, jpjm1
- DO ji = 1, fs_jpim1 ! vector opt.
- !
- 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 DO
- END DO
- !
- CALL lbc_lnk_multi( 'eosbn2', pab(:,:,jp_tem), 'T', 1. , pab(:,:,jp_sal), 'T', 1. ) ! Lateral boundary conditions
+ DO_2D( 1, 1, 1, 1 )
+ !
+ 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
@@ -884,6 +823,6 @@
END SELECT
!
- IF(ln_ctl) CALL prt_ctl( tab2d_1=pab(:,:,jp_tem), clinfo1=' rab_2d_t: ', &
- & tab2d_2=pab(:,:,jp_sal), clinfo2=' rab_2d_s : ' )
+ 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')
@@ -1026,21 +965,17 @@
IF( ln_timing ) CALL timing_start('bn2')
!
- DO jk = 2, jpkm1 ! interior points only (2=< jk =< jpkm1 )
- DO jj = 1, jpj ! surface and bottom value set to zero one for all in istate.F90
- DO ji = 1, jpi
- 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 DO
- END DO
- END DO
- !
- IF(ln_ctl) CALL prt_ctl( tab3d_1=pn2, clinfo1=' bn2 : ', kdim=jpk )
+ DO_3D( 1, 1, 1, 1, 2, jpkm1 )
+ 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')
@@ -1078,28 +1013,26 @@
z1_T0 = 1._wp/40._wp
!
- DO jj = 1, jpj
- DO ji = 1, jpi
- !
- zt = ctmp (ji,jj) * z1_T0
- zs = SQRT( ABS( psal(ji,jj) + zdeltaS ) * r1_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 DO
- END DO
+ DO_2D( 1, 1, 1, 1 )
+ !
+ zt = ctmp (ji,jj) * z1_T0
+ zs = SQRT( ABS( psal(ji,jj) + zdeltaS ) * r1_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')
@@ -1133,16 +1066,14 @@
!
z1_S0 = 1._wp / 35.16504_wp
- DO jj = 1, jpj
- DO ji = 1, jpi
- 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 DO
- END DO
+ DO_2D( 1, 1, 1, 1 )
+ 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, np_leos ) !== PT,SP (UNESCO formulation) ==!
+ CASE ( np_eos80 ) !== PT,SP (UNESCO formulation) ==!
!
ptf(:,:) = ( - 0.0575_wp + 1.710523e-3_wp * SQRT( psal(:,:) ) &
@@ -1190,5 +1121,5 @@
IF( PRESENT( pdep ) ) ptf = ptf - 7.53e-4 * pdep
!
- CASE ( np_eos80, np_leos ) !== PT,SP (UNESCO formulation) ==!
+ CASE ( np_eos80 ) !== PT,SP (UNESCO formulation) ==!
!
ptf = ( - 0.0575_wp + 1.710523e-3_wp * SQRT( psal ) &
@@ -1242,104 +1173,92 @@
CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==!
!
- DO jk = 1, jpkm1
- DO jj = 1, jpj
- DO ji = 1, jpi
- !
- 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 DO
- END DO
- END DO
+ DO_3D( 1, 1, 1, 1, 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 jk = 1, jpkm1
- DO jj = 1, jpj
- DO ji = 1, jpi
- 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 DO
- END DO
- END DO
+ DO_3D( 1, 1, 1, 1, 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 jk = 1, jpkm1
- DO jj = 1, jpj
- DO ji = 1, jpi
- 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 DO
- END DO
- END DO
+ DO_3D( 1, 1, 1, 1, 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
@@ -1365,14 +1284,11 @@
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
- !!----------------------------------------------------------------------
- !
- REWIND( numnam_ref ) ! Namelist nameos in reference namelist : equation of state
+ 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' )
!
- REWIND( numnam_cfg ) ! Namelist nameos in configuration namelist : equation of state
READ ( numnam_cfg, nameos, IOSTAT = ios, ERR = 902 )
902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nameos in configuration namelist' )
Index: /NEMO/branches/2020/r12377_ticket2386/tests/ISOMIP+/MY_SRC/isfcavgam.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/ISOMIP+/MY_SRC/isfcavgam.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/ISOMIP+/MY_SRC/isfcavgam.F90 (revision 13540)
@@ -91,7 +91,7 @@
pgs(:,:) = rn_gammas0
CASE ( 'vel' ) ! gamma is proportional to u*
- CALL gammats_vel ( zutbl, zvtbl, rCd0_top, r_ke0_top, pgt, pgs )
+ CALL gammats_vel ( zutbl, zvtbl, rCd0_top, rn_vtide**2, 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, pgt, pgs )
+ CALL gammats_vel_stab (Kmm, pttbl, pstbl, zutbl, zvtbl, rCd0_top, rn_vtide**2, pqoce, pqfwf, pgt, pgs )
CASE DEFAULT
CALL ctl_stop('STOP','method to compute gamma (cn_gammablk) is unknown (should not see this)')
Index: /NEMO/branches/2020/r12377_ticket2386/tests/ISOMIP+/MY_SRC/isfstp.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/ISOMIP+/MY_SRC/isfstp.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/ISOMIP+/MY_SRC/isfstp.F90 (revision 13540)
@@ -250,5 +250,5 @@
IF ( l_isfoasis .AND. ln_isf ) THEN
!
- CALL ctl_stop( ' ln_ctl and ice shelf not tested' )
+ 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
@@ -291,9 +291,7 @@
!!----------------------------------------------------------------------
!
- REWIND( numnam_ref ) ! Namelist namsbc_rnf in reference namelist : Runoffs
READ ( numnam_ref, namisf, IOSTAT = ios, ERR = 901)
901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namisf in reference namelist' )
!
- REWIND( numnam_cfg ) ! Namelist namsbc_rnf in configuration namelist : Runoffs
READ ( numnam_cfg, namisf, IOSTAT = ios, ERR = 902 )
902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namisf in configuration namelist' )
Index: /NEMO/branches/2020/r12377_ticket2386/tests/ISOMIP+/MY_SRC/istate.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/ISOMIP+/MY_SRC/istate.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/ISOMIP+/MY_SRC/istate.F90 (revision 13540)
@@ -41,4 +41,6 @@
PUBLIC istate_init ! routine called by step.F90
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -75,5 +77,5 @@
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
+ 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
#if defined key_agrif
@@ -90,5 +92,5 @@
! ! ---------------
numror = 0 ! define numror = 0 -> no restart file to read
- neuler = 0 ! Set time-step indicator at nit000 (euler forward)
+ l_1st_euler = .true. ! Set time-step indicator at nit000 (euler forward)
CALL day_init ! model calendar (using both namelist and restart infos)
! ! Initialization of ocean to zero
@@ -103,11 +105,9 @@
! Apply minimum wetdepth criterion
!
- DO jj = 1,jpj
- DO ji = 1,jpi
- IF( ht_0(ji,jj) + ssh(ji,jj,Kbb) < rn_wdmin1 ) THEN
- ssh(ji,jj,Kbb) = tmask(ji,jj,1)*( rn_wdmin1 - (ht_0(ji,jj)) )
- ENDIF
- END DO
- END DO
+ DO_2D( 1, 1, 1, 1 )
+ IF( ht_0(ji,jj) + ssh(ji,jj,Kbb) < rn_wdmin1 ) THEN
+ ssh(ji,jj,Kbb) = tmask(ji,jj,1)*( rn_wdmin1 - (ht_0(ji,jj)) )
+ ENDIF
+ END_2D
ENDIF
uu (:,:,:,Kbb) = 0._wp
@@ -159,15 +159,11 @@
!
!!gm the use of umsak & vmask is not necessary below as uu(:,:,:,Kmm), vv(:,:,:,Kmm), uu(:,:,:,Kbb), vv(:,:,:,Kbb) are always masked
- DO jk = 1, jpkm1
- DO jj = 1, jpj
- DO ji = 1, jpi
- 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)
- !
- uu_b(ji,jj,Kbb) = uu_b(ji,jj,Kbb) + e3u(ji,jj,jk,Kbb) * uu(ji,jj,jk,Kbb) * umask(ji,jj,jk)
- vv_b(ji,jj,Kbb) = vv_b(ji,jj,Kbb) + e3v(ji,jj,jk,Kbb) * vv(ji,jj,jk,Kbb) * vmask(ji,jj,jk)
- END DO
- END DO
- END DO
+ DO_3D( 1, 1, 1, 1, 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)
+ !
+ uu_b(ji,jj,Kbb) = uu_b(ji,jj,Kbb) + e3u(ji,jj,jk,Kbb) * uu(ji,jj,jk,Kbb) * umask(ji,jj,jk)
+ vv_b(ji,jj,Kbb) = vv_b(ji,jj,Kbb) + e3v(ji,jj,jk,Kbb) * vv(ji,jj,jk,Kbb) * vmask(ji,jj,jk)
+ END_3D
!
uu_b(:,:,Kmm) = uu_b(:,:,Kmm) * r1_hu(:,:,Kmm)
Index: /NEMO/branches/2020/r12377_ticket2386/tests/ISOMIP+/MY_SRC/sbcfwb.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/ISOMIP+/MY_SRC/sbcfwb.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/ISOMIP+/MY_SRC/sbcfwb.F90 (revision 13540)
@@ -95,4 +95,5 @@
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
!
@@ -151,5 +152,5 @@
ENDIF
! ! Update fwfold if new year start
- ikty = 365 * 86400 / rn_Dt !!bug use of 365 days leap year or 360d year !!!!!!!
+ ikty = 365 * 86400 / rn_Dt !!bug use of 365 days leap year or 360d year !!!!!!!
IF( MOD( kt, ikty ) == 0 ) THEN
a_fwb_b = a_fwb ! mean sea level taking into account the ice+snow
@@ -211,5 +212,5 @@
erp(:,:) = erp(:,:) + zerp_cor(:,:)
!
- IF( nprint == 1 .AND. lwp ) THEN ! control print
+ IF( lwp ) THEN ! control print
IF( z_fwf < 0._wp ) THEN
WRITE(numout,*)' z_fwf < 0'
Index: /NEMO/branches/2020/r12377_ticket2386/tests/ISOMIP+/MY_SRC/tradmp.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/ISOMIP+/MY_SRC/tradmp.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/ISOMIP+/MY_SRC/tradmp.F90 (revision 13540)
@@ -51,4 +51,6 @@
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: resto !: restoring coeff. on T and S (s-1)
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -110,41 +112,29 @@
CASE( 0 ) !* newtonian damping throughout the water column *!
DO jn = 1, jpts
- DO jk = 1, jpkm1
- DO jj = 2, jpjm1
- DO ji = fs_2, fs_jpim1 ! vector opt.
- 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 DO
- END DO
- END DO
+ 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 jk = 1, jpkm1
- DO jj = 2, jpjm1
- DO ji = fs_2, fs_jpim1 ! vector opt.
- 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 DO
- END DO
- END DO
+ 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 jk = 1, jpkm1
- DO jj = 2, jpjm1
- DO ji = fs_2, fs_jpim1 ! vector opt.
- 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 DO
- END DO
- END DO
+ 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
@@ -157,6 +147,6 @@
ENDIF
! ! Control print
- IF(ln_ctl) 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(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')
@@ -178,9 +168,7 @@
!!----------------------------------------------------------------------
!
- REWIND( numnam_ref ) ! Namelist namtra_dmp in reference namelist : T & S relaxation
READ ( numnam_ref, namtra_dmp, IOSTAT = ios, ERR = 901)
901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_dmp in reference namelist' )
!
- REWIND( numnam_cfg ) ! Namelist namtra_dmp in configuration namelist : T & S relaxation
READ ( numnam_cfg, namtra_dmp, IOSTAT = ios, ERR = 902 )
902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_dmp in configuration namelist' )
@@ -220,5 +208,5 @@
! ! Read in mask from file
CALL iom_open ( cn_resto, imask)
- CALL iom_get ( imask, jpdom_autoglo, 'resto', resto )
+ CALL iom_get ( imask, jpdom_auto, 'resto', resto )
CALL iom_close( imask )
ENDIF
Index: /NEMO/branches/2020/r12377_ticket2386/tests/ISOMIP/EXPREF/context_nemo.xml
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/ISOMIP/EXPREF/context_nemo.xml (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/ISOMIP/EXPREF/context_nemo.xml (revision 13540)
@@ -11,5 +11,5 @@
01
01
- 1026.0
+ 1026.0
3991.86795711963
0.99530670233846
Index: /NEMO/branches/2020/r12377_ticket2386/tests/ISOMIP/EXPREF/namelist_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/ISOMIP/EXPREF/namelist_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/ISOMIP/EXPREF/namelist_cfg (revision 13540)
@@ -227,6 +227,6 @@
!! !!
!! namdrg top/bottom drag coefficient (default: NO selection)
-!! namdrg_top top friction (ln_OFF=F & ln_isfcav=T)
-!! namdrg_bot bottom friction (ln_OFF=F)
+!! 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)
@@ -236,5 +236,5 @@
&namdrg ! top/bottom drag coefficient (default: NO selection)
!-----------------------------------------------------------------------
- ln_OFF = .false. ! free-slip : Cd = 0 (F => fill namdrg_bot
+ 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|
@@ -244,5 +244,5 @@
/
!-----------------------------------------------------------------------
-&namdrg_top ! TOP friction (ln_OFF =F & ln_isfcav=T)
+&namdrg_top ! TOP friction (ln_drg_OFF =F & ln_isfcav=T)
!-----------------------------------------------------------------------
rn_Cd0 = 2.5e-3 ! drag coefficient [-]
@@ -255,5 +255,5 @@
/
!-----------------------------------------------------------------------
-&namdrg_bot ! BOTTOM friction (ln_OFF =F)
+&namdrg_bot ! BOTTOM friction (ln_drg_OFF =F)
!-----------------------------------------------------------------------
rn_Cd0 = 1.e-3 ! drag coefficient [-]
Index: /NEMO/branches/2020/r12377_ticket2386/tests/ISOMIP/MY_SRC/usrdef_hgr.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/ISOMIP/MY_SRC/usrdef_hgr.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/ISOMIP/MY_SRC/usrdef_hgr.F90 (revision 13540)
@@ -14,5 +14,5 @@
!! usr_def_hgr : initialize the horizontal mesh for ISOMIP configuration
!!----------------------------------------------------------------------
- USE dom_oce , ONLY: nimpp, njmpp ! ocean space and time domain
+ USE dom_oce
USE par_oce ! ocean space and time domain
USE phycst ! physical constants
@@ -27,4 +27,6 @@
PUBLIC usr_def_hgr ! called by domhgr.F90
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -75,33 +77,30 @@
!
! !== grid point position ==! (in degrees)
- DO jj = 1, jpj
- DO ji = 1, jpi ! longitude (west coast at lon=0°)
- plamt(ji,jj) = rn_e1deg * ( - 0.5 + REAL( ji-1 + nimpp-1 , wp ) )
- plamu(ji,jj) = rn_e1deg * ( REAL( ji-1 + nimpp-1 , wp ) )
- plamv(ji,jj) = plamt(ji,jj)
- plamf(ji,jj) = plamu(ji,jj)
- ! ! latitude (south coast at lat= 81°)
- pphit(ji,jj) = rn_e2deg * ( - 0.5 + REAL( jj-1 + njmpp-1 , wp ) ) - 80._wp
- pphiu(ji,jj) = pphit(ji,jj)
- pphiv(ji,jj) = rn_e2deg * ( REAL( jj-1 + njmpp-1 , wp ) ) - 80_wp
- pphif(ji,jj) = pphiv(ji,jj)
- END DO
- END DO
+ DO_2D( 1, 1, 1, 1 )
+ ! ! longitude (west coast at lon=0°)
+ plamt(ji,jj) = rn_e1deg * ( - 0.5 + REAL( mig0_oldcmp(ji)-1 , wp ) )
+ plamu(ji,jj) = rn_e1deg * ( REAL( mig0_oldcmp(ji)-1 , wp ) )
+ plamv(ji,jj) = plamt(ji,jj)
+ plamf(ji,jj) = plamu(ji,jj)
+ ! ! latitude (south coast at lat= 81°)
+ pphit(ji,jj) = rn_e2deg * ( - 0.5 + REAL( mjg0_oldcmp(jj)-1 , wp ) ) - 80._wp
+ pphiu(ji,jj) = pphit(ji,jj)
+ pphiv(ji,jj) = rn_e2deg * ( REAL( mjg0_oldcmp(jj)-1 , wp ) ) - 80_wp
+ pphif(ji,jj) = pphiv(ji,jj)
+ END_2D
!
! !== Horizontal scale factors ==! (in meters)
- DO jj = 1, jpj
- DO ji = 1, jpi
- ! ! 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 DO
- END DO
+ DO_2D( 1, 1, 1, 1 )
+ ! ! 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
Index: /NEMO/branches/2020/r12377_ticket2386/tests/ISOMIP/MY_SRC/usrdef_nam.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/ISOMIP/MY_SRC/usrdef_nam.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/ISOMIP/MY_SRC/usrdef_nam.F90 (revision 13540)
@@ -15,5 +15,4 @@
!! 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
@@ -95,6 +94,6 @@
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 : jpiglo = ', kpi
- WRITE(numout,*) ' jpjglo = ', kpj
+ WRITE(numout,*) ' resulting global domain size : Ni0glo = ', kpi
+ WRITE(numout,*) ' Nj0glo = ', kpj
WRITE(numout,*) ' jpkglo = ', kpk
WRITE(numout,*) ' '
Index: /NEMO/branches/2020/r12377_ticket2386/tests/ISOMIP/MY_SRC/usrdef_zgr.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/ISOMIP/MY_SRC/usrdef_zgr.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/ISOMIP/MY_SRC/usrdef_zgr.F90 (revision 13540)
@@ -16,6 +16,6 @@
!!---------------------------------------------------------------------
USE oce ! ocean variables
- USE dom_oce , ONLY: mj0 , mj1 , nimpp , njmpp ! ocean space and time domain
- USE dom_oce , ONLY: glamt , gphit ! ocean space and time domain
+ 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
!
@@ -30,4 +30,6 @@
PUBLIC usr_def_zgr ! called by domzgr.F90
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -65,6 +67,4 @@
REAL(wp), DIMENSION(jpi,jpj) :: zht , zhu ! bottom depth
REAL(wp), DIMENSION(jpi,jpj) :: zhisf, zhisfu ! top depth
- REAL(wp), DIMENSION(jpi,jpj) :: zmsk
- REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2d workspace
!!----------------------------------------------------------------------
!
@@ -85,17 +85,10 @@
! !== isfdraft ==!
!
- ! the ocean basin surrounded by land (1 grid-point) set through lbc_lnk call as jperio=0
- z2d(:,:) = 1._wp ! surface ocean is the 1st level
- CALL lbc_lnk( 'usrdef_zgr', z2d, 'T', 1. ) ! closed basin since jperio = 0 (see userdef_nam.F90)
- zmsk(:,:) = NINT( z2d(:,:) )
- !
- !
zht (:,:) = rbathy
zhisf(:,:) = 200._wp
- ij0 = 1 ; ij1 = 40
+ 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
- zhisf(:,:) = zhisf(:,:) * zmsk(:,:)
!
CALL zgr_z1d( pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d ) ! Reference z-coordinate system
@@ -132,48 +125,43 @@
pe3vw(:,:,jk) = pe3w_1d (jk)
END DO
- DO jj = 1, jpj ! top scale factors and depth at T- and W-points
- DO ji = 1, jpi
- 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 DO
- END DO
- DO jj = 1, jpj ! bottom scale factors and depth at T- and W-points
- DO ji = 1, jpi
- ik = k_bot(ji,jj)
- pdepw(ji,jj,ik+1) = MIN( zht(ji,jj) , pdepw_1d(ik+1) )
+ ! 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)
- pe3t (ji,jj,ik+1) = pe3t (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+1) + pe3t (ji,jj,ik+1) * 0.5_wp
- pe3w (ji,jj,ik+1) = pdept(ji,jj,ik+1) - pdept(ji,jj,ik)
- END DO
- END DO
+ 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 jk = 1, jpk ! Computed as the minimum of neighbooring scale factors
- DO jj = 1, jpjm1
- DO ji = 1, jpi
- 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 DO
- END DO
- END DO
+ 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 )
Index: /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/EXPREF/context_nemo.xml
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/EXPREF/context_nemo.xml (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/EXPREF/context_nemo.xml (revision 13540)
@@ -11,5 +11,5 @@
01
01
- 1026.0
+ 1026.0
3991.86795711963
0.99530670233846
Index: /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT2_flux_cen2_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT2_flux_cen2_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT2_flux_cen2_cfg (revision 13540)
@@ -65,5 +65,5 @@
&namdrg ! top/bottom drag coefficient (default: NO selection)
!-----------------------------------------------------------------------
- ln_OFF = .true. ! free-slip : Cd = 0
+ ln_drg_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot
/
!-----------------------------------------------------------------------
@@ -72,5 +72,5 @@
ln_seos = .true. ! = Use simplified equation of state (S-EOS)
! ! S-EOS coefficients (nn_eos=1):
- ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
+ ! ! rd(T,S,Z)*rho0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
rn_a0 = 0.2 ! thermal expension coefficient (nn_eos= 1)
rn_b0 = 0. ! saline expension coefficient (nn_eos= 1)
Index: /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT2_flux_ubs_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT2_flux_ubs_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT2_flux_ubs_cfg (revision 13540)
@@ -110,6 +110,6 @@
!! !!
!! namdrg top/bottom drag coefficient (default: NO selection)
-!! namdrg_top top friction (ln_OFF=F & ln_isfcav=T)
-!! namdrg_bot bottom friction (ln_OFF=F)
+!! 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)
@@ -119,5 +119,5 @@
&namdrg ! top/bottom drag coefficient (default: NO selection)
!-----------------------------------------------------------------------
- ln_OFF = .true. ! free-slip : Cd = 0
+ ln_drg_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot
/
!!======================================================================
@@ -137,5 +137,5 @@
ln_seos = .true. ! = Use simplified equation of state (S-EOS)
! ! S-EOS coefficients (nn_eos=1):
- ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
+ ! ! rd(T,S,Z)*rho0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
rn_a0 = 0.2 ! thermal expension coefficient (nn_eos= 1)
rn_b0 = 0. ! saline expension coefficient (nn_eos= 1)
Index: /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT2_vect_eenH_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT2_vect_eenH_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT2_vect_eenH_cfg (revision 13540)
@@ -65,5 +65,5 @@
&namdrg ! top/bottom drag coefficient (default: NO selection)
!-----------------------------------------------------------------------
- ln_OFF = .true. ! free-slip : Cd = 0
+ ln_drg_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot
/
!-----------------------------------------------------------------------
@@ -72,5 +72,5 @@
ln_seos = .true. ! = Use simplified equation of state (S-EOS)
! ! S-EOS coefficients (nn_eos=1):
- ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
+ ! ! rd(T,S,Z)*rho0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
rn_a0 = 0.2 ! thermal expension coefficient (nn_eos= 1)
rn_b0 = 0. ! saline expension coefficient (nn_eos= 1)
Index: /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT2_vect_een_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT2_vect_een_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT2_vect_een_cfg (revision 13540)
@@ -65,5 +65,5 @@
&namdrg ! top/bottom drag coefficient (default: NO selection)
!-----------------------------------------------------------------------
- ln_OFF = .true. ! free-slip : Cd = 0
+ ln_drg_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot
/
!-----------------------------------------------------------------------
@@ -72,5 +72,5 @@
ln_seos = .true. ! = Use simplified equation of state (S-EOS)
! ! S-EOS coefficients (nn_eos=1):
- ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
+ ! ! rd(T,S,Z)*rho0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
rn_a0 = 0.2 ! thermal expension coefficient (nn_eos= 1)
rn_b0 = 0. ! saline expension coefficient (nn_eos= 1)
Index: /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT2_vect_ene_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT2_vect_ene_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT2_vect_ene_cfg (revision 13540)
@@ -65,5 +65,5 @@
&namdrg ! top/bottom drag coefficient (default: NO selection)
!-----------------------------------------------------------------------
- ln_OFF = .true. ! free-slip : Cd = 0
+ ln_drg_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot
/
!-----------------------------------------------------------------------
@@ -72,5 +72,5 @@
ln_seos = .true. ! = Use simplified equation of state (S-EOS)
! ! S-EOS coefficients (nn_eos=1):
- ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
+ ! ! rd(T,S,Z)*rho0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
rn_a0 = 0.2 ! thermal expension coefficient (nn_eos= 1)
rn_b0 = 0. ! saline expension coefficient (nn_eos= 1)
Index: /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT2_vect_ens_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT2_vect_ens_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT2_vect_ens_cfg (revision 13540)
@@ -65,5 +65,5 @@
&namdrg ! top/bottom drag coefficient (default: NO selection)
!-----------------------------------------------------------------------
- ln_OFF = .true. ! free-slip : Cd = 0
+ ln_drg_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot
/
!-----------------------------------------------------------------------
@@ -72,5 +72,5 @@
ln_seos = .true. ! = Use simplified equation of state (S-EOS)
! ! S-EOS coefficients (nn_eos=1):
- ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
+ ! ! rd(T,S,Z)*rho0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
rn_a0 = 0.2 ! thermal expension coefficient (nn_eos= 1)
rn_b0 = 0. ! saline expension coefficient (nn_eos= 1)
Index: /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT4_flux_cen2_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT4_flux_cen2_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT4_flux_cen2_cfg (revision 13540)
@@ -65,5 +65,5 @@
&namdrg ! top/bottom drag coefficient (default: NO selection)
!-----------------------------------------------------------------------
- ln_OFF = .true. ! free-slip : Cd = 0
+ ln_drg_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot
/
!-----------------------------------------------------------------------
@@ -72,5 +72,5 @@
ln_seos = .true. ! = Use simplified equation of state (S-EOS)
! ! S-EOS coefficients (nn_eos=1):
- ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
+ ! ! rd(T,S,Z)*rho0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
rn_a0 = 0.2 ! thermal expension coefficient (nn_eos= 1)
rn_b0 = 0. ! saline expension coefficient (nn_eos= 1)
Index: /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT4_flux_ubs_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT4_flux_ubs_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT4_flux_ubs_cfg (revision 13540)
@@ -65,5 +65,5 @@
&namdrg ! top/bottom drag coefficient (default: NO selection)
!-----------------------------------------------------------------------
- ln_OFF = .true. ! free-slip : Cd = 0
+ ln_drg_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot
/
!-----------------------------------------------------------------------
@@ -72,5 +72,5 @@
ln_seos = .true. ! = Use simplified equation of state (S-EOS)
! ! S-EOS coefficients (nn_eos=1):
- ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
+ ! ! rd(T,S,Z)*rho0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
rn_a0 = 0.2 ! thermal expension coefficient (nn_eos= 1)
rn_b0 = 0. ! saline expension coefficient (nn_eos= 1)
Index: /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT4_vect_eenH_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT4_vect_eenH_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT4_vect_eenH_cfg (revision 13540)
@@ -65,5 +65,5 @@
&namdrg ! top/bottom drag coefficient (default: NO selection)
!-----------------------------------------------------------------------
- ln_OFF = .true. ! free-slip : Cd = 0
+ ln_drg_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot
/
!-----------------------------------------------------------------------
@@ -72,5 +72,5 @@
ln_seos = .true. ! = Use simplified equation of state (S-EOS)
! ! S-EOS coefficients (nn_eos=1):
- ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
+ ! ! rd(T,S,Z)*rho0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
rn_a0 = 0.2 ! thermal expension coefficient (nn_eos= 1)
rn_b0 = 0. ! saline expension coefficient (nn_eos= 1)
Index: /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT4_vect_een_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT4_vect_een_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT4_vect_een_cfg (revision 13540)
@@ -65,5 +65,5 @@
&namdrg ! top/bottom drag coefficient (default: NO selection)
!-----------------------------------------------------------------------
- ln_OFF = .true. ! free-slip : Cd = 0
+ ln_drg_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot
/
!-----------------------------------------------------------------------
@@ -72,5 +72,5 @@
ln_seos = .true. ! = Use simplified equation of state (S-EOS)
! ! S-EOS coefficients (nn_eos=1):
- ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
+ ! ! rd(T,S,Z)*rho0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
rn_a0 = 0.2 ! thermal expension coefficient (nn_eos= 1)
rn_b0 = 0. ! saline expension coefficient (nn_eos= 1)
Index: /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT4_vect_ene_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT4_vect_ene_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT4_vect_ene_cfg (revision 13540)
@@ -65,5 +65,5 @@
&namdrg ! top/bottom drag coefficient (default: NO selection)
!-----------------------------------------------------------------------
- ln_OFF = .true. ! free-slip : Cd = 0
+ ln_drg_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot
/
!-----------------------------------------------------------------------
@@ -72,5 +72,5 @@
ln_seos = .true. ! = Use simplified equation of state (S-EOS)
! ! S-EOS coefficients (nn_eos=1):
- ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
+ ! ! rd(T,S,Z)*rho0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
rn_a0 = 0.2 ! thermal expension coefficient (nn_eos= 1)
rn_b0 = 0. ! saline expension coefficient (nn_eos= 1)
Index: /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT4_vect_ens_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT4_vect_ens_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT4_vect_ens_cfg (revision 13540)
@@ -65,5 +65,5 @@
&namdrg ! top/bottom drag coefficient (default: NO selection)
!-----------------------------------------------------------------------
- ln_OFF = .true. ! free-slip : Cd = 0
+ ln_drg_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot
/
!-----------------------------------------------------------------------
@@ -72,5 +72,5 @@
ln_seos = .true. ! = Use simplified equation of state (S-EOS)
! ! S-EOS coefficients (nn_eos=1):
- ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
+ ! ! rd(T,S,Z)*rho0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
rn_a0 = 0.2 ! thermal expension coefficient (nn_eos= 1)
rn_b0 = 0. ! saline expension coefficient (nn_eos= 1)
Index: /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/MY_SRC/usrdef_hgr.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/MY_SRC/usrdef_hgr.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/MY_SRC/usrdef_hgr.F90 (revision 13540)
@@ -13,5 +13,5 @@
!! usr_def_hgr : initialize the horizontal mesh for LOCK_EXCHANGE configuration
!!----------------------------------------------------------------------
- USE dom_oce , ONLY: nimpp, njmpp ! ocean space and time domain
+ USE dom_oce
USE par_oce ! ocean space and time domain
USE phycst ! physical constants
@@ -26,4 +26,6 @@
PUBLIC usr_def_hgr ! called by domhgr.F90
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -72,17 +74,16 @@
! !== grid point position ==! (in kilometers)
zfact = rn_dx * 1.e-3 ! conversion in km
- DO jj = 1, jpj
- DO ji = 1, jpi ! longitude
- plamt(ji,jj) = zfact * ( - 0.5 + REAL( ji-1 + nimpp-1 , wp ) )
- plamu(ji,jj) = zfact * ( REAL( ji-1 + nimpp-1 , wp ) )
- plamv(ji,jj) = plamt(ji,jj)
- plamf(ji,jj) = plamu(ji,jj)
- ! ! latitude
- pphit(ji,jj) = zfact * ( - 0.5 + REAL( jj-1 + njmpp-1 , wp ) )
- pphiu(ji,jj) = pphit(ji,jj)
- pphiv(ji,jj) = zfact * ( REAL( jj-1 + njmpp-1 , wp ) )
- pphif(ji,jj) = pphiv(ji,jj)
- END DO
- END DO
+ DO_2D( 1, 1, 1, 1 )
+ ! ! longitude
+ plamt(ji,jj) = zfact * ( - 0.5 + REAL( mig0_oldcmp(ji)-1 , wp ) )
+ plamu(ji,jj) = zfact * ( REAL( mig0_oldcmp(ji)-1 , wp ) )
+ plamv(ji,jj) = plamt(ji,jj)
+ plamf(ji,jj) = plamu(ji,jj)
+ ! ! latitude
+ pphit(ji,jj) = zfact * ( - 0.5 + REAL( mjg0_oldcmp(jj)-1 , wp ) )
+ pphiu(ji,jj) = pphit(ji,jj)
+ pphiv(ji,jj) = zfact * ( REAL( mjg0_oldcmp(jj)-1 , wp ) )
+ pphif(ji,jj) = pphiv(ji,jj)
+ END_2D
!
! !== Horizontal scale factors ==! (in meters)
Index: /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/MY_SRC/usrdef_nam.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/MY_SRC/usrdef_nam.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/LOCK_EXCHANGE/MY_SRC/usrdef_nam.F90 (revision 13540)
@@ -14,5 +14,4 @@
!! usr_def_hgr : initialize the horizontal mesh
!!----------------------------------------------------------------------
- USE dom_oce , ONLY: nimpp , njmpp ! i- & j-indices of the local domain
USE par_oce ! ocean space and time domain
USE phycst ! physical constants
@@ -85,6 +84,6 @@
WRITE(numout,*) ' vertical resolution rn_dz = ', rn_dz, ' meters'
WRITE(numout,*) ' LOCK_EXCHANGE domain = 64 km x 3 grid-points x 20 m'
- WRITE(numout,*) ' resulting global domain size : jpiglo = ', kpi
- WRITE(numout,*) ' jpjglo = ', kpj
+ WRITE(numout,*) ' resulting global domain size : Ni0glo = ', kpi
+ WRITE(numout,*) ' Nj0glo = ', kpj
WRITE(numout,*) ' jpkglo = ', kpk
WRITE(numout,*) ' '
Index: /NEMO/branches/2020/r12377_ticket2386/tests/OVERFLOW/EXPREF/context_nemo.xml
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/OVERFLOW/EXPREF/context_nemo.xml (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/OVERFLOW/EXPREF/context_nemo.xml (revision 13540)
@@ -11,5 +11,5 @@
01
01
- 1026.0
+ 1026.0
3991.86795711963
0.99530670233846
Index: /NEMO/branches/2020/r12377_ticket2386/tests/OVERFLOW/EXPREF/namelist_sco_FCT2_flux_cen-ahm1000_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/OVERFLOW/EXPREF/namelist_sco_FCT2_flux_cen-ahm1000_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/OVERFLOW/EXPREF/namelist_sco_FCT2_flux_cen-ahm1000_cfg (revision 13540)
@@ -71,5 +71,5 @@
&namdrg ! top/bottom drag coefficient (default: NO selection)
!-----------------------------------------------------------------------
- ln_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot
+ ln_drg_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot
ln_lin = .false. ! linear drag: Cd = Cd0 Uc0 & namdrg_top)
ln_non_lin = .false. ! non-linear drag: Cd = Cd0 |U|
@@ -82,5 +82,5 @@
!-----------------------------------------------------------------------
ln_seos = .true. ! = Use simplified equation of state (S-EOS)
- ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
+ ! ! rd(T,S,Z)*rho0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
rn_a0 = 0.2 ! thermal expension coefficient (for simplified equation of state)
rn_b0 = 0. ! saline expension coefficient (for simplified equation of state)
Index: /NEMO/branches/2020/r12377_ticket2386/tests/OVERFLOW/EXPREF/namelist_sco_FCT2_flux_ubs_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/OVERFLOW/EXPREF/namelist_sco_FCT2_flux_ubs_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/OVERFLOW/EXPREF/namelist_sco_FCT2_flux_ubs_cfg (revision 13540)
@@ -71,5 +71,5 @@
&namdrg ! top/bottom drag coefficient (default: NO selection)
!-----------------------------------------------------------------------
- ln_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot
+ ln_drg_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot
ln_lin = .false. ! linear drag: Cd = Cd0 Uc0 & namdrg_top)
ln_non_lin = .false. ! non-linear drag: Cd = Cd0 |U|
@@ -82,5 +82,5 @@
!-----------------------------------------------------------------------
ln_seos = .true. ! = Use simplified equation of state (S-EOS)
- ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
+ ! ! rd(T,S,Z)*rho0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
rn_a0 = 0.2 ! thermal expension coefficient (for simplified equation of state)
rn_b0 = 0. ! saline expension coefficient (for simplified equation of state)
Index: /NEMO/branches/2020/r12377_ticket2386/tests/OVERFLOW/EXPREF/namelist_sco_FCT4_flux_cen-ahm1000_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/OVERFLOW/EXPREF/namelist_sco_FCT4_flux_cen-ahm1000_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/OVERFLOW/EXPREF/namelist_sco_FCT4_flux_cen-ahm1000_cfg (revision 13540)
@@ -71,5 +71,5 @@
&namdrg ! top/bottom drag coefficient (default: NO selection)
!-----------------------------------------------------------------------
- ln_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot
+ ln_drg_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot
ln_lin = .false. ! linear drag: Cd = Cd0 Uc0 & namdrg_top)
ln_non_lin = .false. ! non-linear drag: Cd = Cd0 |U|
@@ -82,5 +82,5 @@
!-----------------------------------------------------------------------
ln_seos = .true. ! = Use simplified equation of state (S-EOS)
- ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
+ ! ! rd(T,S,Z)*rho0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
rn_a0 = 0.2 ! thermal expension coefficient (for simplified equation of state)
rn_b0 = 0. ! saline expension coefficient (for simplified equation of state)
Index: /NEMO/branches/2020/r12377_ticket2386/tests/OVERFLOW/EXPREF/namelist_sco_FCT4_flux_ubs_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/OVERFLOW/EXPREF/namelist_sco_FCT4_flux_ubs_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/OVERFLOW/EXPREF/namelist_sco_FCT4_flux_ubs_cfg (revision 13540)
@@ -71,5 +71,5 @@
&namdrg ! top/bottom drag coefficient (default: NO selection)
!-----------------------------------------------------------------------
- ln_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot
+ ln_drg_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot
ln_lin = .false. ! linear drag: Cd = Cd0 Uc0 & namdrg_top)
ln_non_lin = .false. ! non-linear drag: Cd = Cd0 |U|
@@ -82,5 +82,5 @@
!-----------------------------------------------------------------------
ln_seos = .true. ! = Use simplified equation of state (S-EOS)
- ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
+ ! ! rd(T,S,Z)*rho0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
rn_a0 = 0.2 ! thermal expension coefficient (for simplified equation of state)
rn_b0 = 0. ! saline expension coefficient (for simplified equation of state)
Index: /NEMO/branches/2020/r12377_ticket2386/tests/OVERFLOW/EXPREF/namelist_zps_FCT2_flux_ubs_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/OVERFLOW/EXPREF/namelist_zps_FCT2_flux_ubs_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/OVERFLOW/EXPREF/namelist_zps_FCT2_flux_ubs_cfg (revision 13540)
@@ -71,5 +71,5 @@
&namdrg ! top/bottom drag coefficient (default: NO selection)
!-----------------------------------------------------------------------
- ln_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot
+ ln_drg_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot
ln_lin = .false. ! linear drag: Cd = Cd0 Uc0 & namdrg_top)
ln_non_lin = .false. ! non-linear drag: Cd = Cd0 |U|
@@ -82,5 +82,5 @@
!-----------------------------------------------------------------------
ln_seos = .true. ! = Use simplified equation of state (S-EOS)
- ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
+ ! ! rd(T,S,Z)*rho0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
rn_a0 = 0.2 ! thermal expension coefficient (for simplified equation of state)
rn_b0 = 0. ! saline expension coefficient (for simplified equation of state)
Index: /NEMO/branches/2020/r12377_ticket2386/tests/OVERFLOW/EXPREF/namelist_zps_FCT4_flux_ubs_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/OVERFLOW/EXPREF/namelist_zps_FCT4_flux_ubs_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/OVERFLOW/EXPREF/namelist_zps_FCT4_flux_ubs_cfg (revision 13540)
@@ -105,6 +105,6 @@
!! !!
!! namdrg top/bottom drag coefficient (default: NO selection)
-!! namdrg_top top friction (ln_OFF=F & ln_isfcav=T)
-!! namdrg_bot bottom friction (ln_OFF=F)
+!! 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)
@@ -114,5 +114,5 @@
&namdrg ! top/bottom drag coefficient (default: NO selection)
!-----------------------------------------------------------------------
- ln_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot
+ ln_drg_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot
ln_lin = .false. ! linear drag: Cd = Cd0 Uc0 & namdrg_top)
ln_non_lin = .false. ! non-linear drag: Cd = Cd0 |U|
@@ -136,5 +136,5 @@
!-----------------------------------------------------------------------
ln_seos = .true. ! = Use simplified equation of state (S-EOS)
- ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
+ ! ! rd(T,S,Z)*rho0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
rn_a0 = 0.2 ! thermal expension coefficient (for simplified equation of state)
rn_b0 = 0. ! saline expension coefficient (for simplified equation of state)
Index: /NEMO/branches/2020/r12377_ticket2386/tests/OVERFLOW/EXPREF/namelist_zps_FCT4_vect_een_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/OVERFLOW/EXPREF/namelist_zps_FCT4_vect_een_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/OVERFLOW/EXPREF/namelist_zps_FCT4_vect_een_cfg (revision 13540)
@@ -71,5 +71,5 @@
&namdrg ! top/bottom drag coefficient (default: NO selection)
!-----------------------------------------------------------------------
- ln_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot
+ ln_drg_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot
ln_lin = .false. ! linear drag: Cd = Cd0 Uc0 & namdrg_top)
ln_non_lin = .false. ! non-linear drag: Cd = Cd0 |U|
@@ -82,5 +82,5 @@
!-----------------------------------------------------------------------
ln_seos = .true. ! = Use simplified equation of state (S-EOS)
- ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
+ ! ! rd(T,S,Z)*rho0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
rn_a0 = 0.2 ! thermal expension coefficient (for simplified equation of state)
rn_b0 = 0. ! saline expension coefficient (for simplified equation of state)
Index: /NEMO/branches/2020/r12377_ticket2386/tests/OVERFLOW/MY_SRC/usrdef_hgr.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/OVERFLOW/MY_SRC/usrdef_hgr.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/OVERFLOW/MY_SRC/usrdef_hgr.F90 (revision 13540)
@@ -13,5 +13,5 @@
!! usr_def_hgr : initialize the horizontal mesh for OVERFLOW configuration
!!----------------------------------------------------------------------
- USE dom_oce , ONLY: nimpp, njmpp ! ocean space and time domain
+ USE dom_oce
USE par_oce ! ocean space and time domain
USE phycst ! physical constants
@@ -26,4 +26,6 @@
PUBLIC usr_def_hgr ! called by domhgr.F90
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -72,17 +74,16 @@
! !== grid point position ==! (in kilometers)
zfact = rn_dx * 1.e-3 ! conversion in km
- DO jj = 1, jpj
- DO ji = 1, jpi ! longitude
- plamt(ji,jj) = zfact * ( - 0.5 + REAL( ji-1 + nimpp-1 , wp ) )
- plamu(ji,jj) = zfact * ( REAL( ji-1 + nimpp-1 , wp ) )
- plamv(ji,jj) = plamt(ji,jj)
- plamf(ji,jj) = plamu(ji,jj)
- ! ! latitude
- pphit(ji,jj) = zfact * ( - 0.5 + REAL( jj-1 + njmpp-1 , wp ) )
- pphiu(ji,jj) = pphit(ji,jj)
- pphiv(ji,jj) = zfact * ( REAL( jj-1 + njmpp-1 , wp ) )
- pphif(ji,jj) = pphiv(ji,jj)
- END DO
- END DO
+ DO_2D( 1, 1, 1, 1 )
+ ! ! longitude
+ plamt(ji,jj) = zfact * ( - 0.5 + REAL( mig0_oldcmp(ji)-1 , wp ) )
+ plamu(ji,jj) = zfact * ( REAL( mig0_oldcmp(ji)-1 , wp ) )
+ plamv(ji,jj) = plamt(ji,jj)
+ plamf(ji,jj) = plamu(ji,jj)
+ ! ! latitude
+ pphit(ji,jj) = zfact * ( - 0.5 + REAL( mjg0_oldcmp(jj)-1 , wp ) )
+ pphiu(ji,jj) = pphit(ji,jj)
+ pphiv(ji,jj) = zfact * ( REAL( mjg0_oldcmp(jj)-1 , wp ) )
+ pphif(ji,jj) = pphiv(ji,jj)
+ END_2D
!
! !== Horizontal scale factors ==! (in meters)
Index: /NEMO/branches/2020/r12377_ticket2386/tests/OVERFLOW/MY_SRC/usrdef_nam.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/OVERFLOW/MY_SRC/usrdef_nam.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/OVERFLOW/MY_SRC/usrdef_nam.F90 (revision 13540)
@@ -14,5 +14,4 @@
!! 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
@@ -86,6 +85,6 @@
WRITE(numout,*) ' vertical resolution rn_dz = ', rn_dz, ' meters'
WRITE(numout,*) ' OVERFLOW domain = 200 km x 3 grid-points x 2000 m'
- WRITE(numout,*) ' resulting global domain size : jpiglo = ', kpi
- WRITE(numout,*) ' jpjglo = ', kpj
+ WRITE(numout,*) ' resulting global domain size : Ni0glo = ', kpi
+ WRITE(numout,*) ' Nj0glo = ', kpj
WRITE(numout,*) ' jpkglo = ', kpk
!
Index: /NEMO/branches/2020/r12377_ticket2386/tests/OVERFLOW/MY_SRC/usrdef_zgr.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/OVERFLOW/MY_SRC/usrdef_zgr.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/OVERFLOW/MY_SRC/usrdef_zgr.F90 (revision 13540)
@@ -15,6 +15,6 @@
!!---------------------------------------------------------------------
USE oce ! ocean variables
- USE dom_oce , ONLY: mi0, mi1, nimpp, njmpp ! ocean space and time domain
- USE dom_oce , ONLY: glamt ! ocean space and time domain
+ USE dom_oce , ONLY: mi0, mi1 ! ocean space and time domain
+ USE dom_oce , ONLY: glamt ! ocean space and time domain
USE usrdef_nam ! User defined : namelist variables
!
@@ -29,4 +29,6 @@
PUBLIC usr_def_zgr ! called by domzgr.F90
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -182,16 +184,14 @@
pe3vw(:,:,jk) = pe3w_1d (jk)
END DO
- DO jj = 1, jpj ! bottom scale factors and depth at T- and W-points
- DO ji = 1, jpi
- 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 )
- END DO
- END DO
+ 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) ! = 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
Index: /NEMO/branches/2020/r12377_ticket2386/tests/README.rst
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/README.rst (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/README.rst (revision 13540)
@@ -205,2 +205,7 @@
:style: unsrt
:labelprefix: T
+
+CPL_OASIS
+---------
+| This test case checks the OASIS interface in OCE/SBC, allowing to set up
+a coupled configuration through OASIS. See CPL_OASIS/README.md for more information.
Index: /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/EXPREF/file_def_nemo-oce.xml
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/EXPREF/file_def_nemo-oce.xml (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/EXPREF/file_def_nemo-oce.xml (revision 13540)
@@ -28,6 +28,16 @@
-
-
+
+
+
+
+
+
+
+
+
+
+
+
Index: /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/EXPREF/launch_sasf.sh
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/EXPREF/launch_sasf.sh (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/EXPREF/launch_sasf.sh (revision 13540)
@@ -1,44 +1,72 @@
#!/bin/bash
-# NEMO directory where to fetch compiled STATION_ASF nemo.exe + setup:
-NEMO_DIR="${HOME}/NEMO/NEMOvdev_r11085_ASINTER-05_Brodeau_Advanced_Bulk"
+################################################################
+#
+# Script to launch a set of STATION_ASF simulations
+#
+# L. Brodeau, 2020
+#
+################################################################
+
+# What directory inside "tests" actually contains the compiled "nemo.exe" for STATION_ASF ?
+TC_DIR="STATION_ASF2"
+
+expdir=`basename ${PWD}`; # we expect "EXPREF" or "EXP00" normally...
+
+# NEMOGCM root directory:
+NEMO_ROOT_DIR=`pwd | sed -e "s|/tests/STATION_ASF/${expdir}||g"`
+
+# NEMOGCM root directory where to fetch compiled STATION_ASF nemo.exe:
+SASF_WRK_DIR="${NEMO_ROOT_DIR}/tests/${TC_DIR}"
# Directory where to run the simulation:
-WORK_DIR="${HOME}/tmp/STATION_ASF"
+PROD_DIR="${HOME}/tmp/STATION_ASF"
-# FORC_DIR => Directory containing sea-surface + atmospheric forcings
-# (get it there https://drive.google.com/file/d/1MxNvjhRHmMrL54y6RX7WIaM9-LGl--ZP/):
-if [ `hostname` = "merlat" ]; then
- FORC_DIR="/MEDIA/data/STATION_ASF/input_data_STATION_ASF_2016-2018"
-elif [ `hostname` = "luitel" ]; then
- FORC_DIR="/data/gcm_setup/STATION_ASF/input_data_STATION_ASF_2016-2018"
-elif [ `hostname` = "ige-meom-cal1" ]; then
- FORC_DIR="/mnt/meom/workdir/brodeau/STATION_ASF/input_data_STATION_ASF_2016-2018"
-elif [ `hostname` = "salvelinus" ]; then
- FORC_DIR="/opt/data/STATION_ASF/input_data_STATION_ASF_2016-2018"
-else
- echo "Boo!"; exit
-fi
-#======================
-mkdir -p ${WORK_DIR}
+####### End of normal user configurable section #######
-NEMO_EXE="${NEMO_DIR}/tests/STATION_ASF/BLD/bin/nemo.exe"
-if [ ! -f ${NEMO_EXE} ]; then echo " Mhhh, no compiled nemo.exe found into ${NEMO_DIR}/tests/STATION_ASF/BLD/bin !"; exit; fi
+#================================================================================
-NEMO_EXPREF="${NEMO_DIR}/tests/STATION_ASF/EXPREF"
-if [ ! -d ${NEMO_EXPREF} ]; then echo " Mhhh, no EXPREF directory ${NEMO_EXPREF} !"; exit; fi
+SASF_REF_DIR="${NEMO_ROOT_DIR}/tests/STATION_ASF"
+if [ ! -d ${SASF_REF_DIR} ]; then echo " Mhhh, no EXPREF directory ${SASF_REF_DIR} !"; exit; fi
-rsync -avP ${NEMO_EXE} ${WORK_DIR}/
+# NEMO executable to use is:
+NEMO_EXE="${SASF_WRK_DIR}/BLD/bin/nemo.exe"
+if [ ! -f ${NEMO_EXE} ]; then echo " Mhhh, no compiled 'nemo.exe' found into `dirname ${NEMO_EXE}` !"; exit; fi
+
+DATA_IN_DIR="${SASF_REF_DIR}/input_data" ; # Directory containing sea-surface + atmospheric input data
+if [ ! -d ${DATA_IN_DIR} ]; then echo "PROBLEM!!! => did not find directory 'input_data' with input forcing..."; exit; fi
+
+SASF_EXPREF=${SASF_REF_DIR}/${expdir} ; # STATION_ASF EXPREF directory from which to use namelists and XIOS xml files...
+if [ ! -d ${SASF_EXPREF} ]; then echo " Mhhh, no ${expdir} directory ${SASF_EXPREF} !"; exit; fi
+
+
+echo "###########################################################"
+echo "# S T A T I O N A i r - S e a F l u x #"
+echo "###########################################################"
+echo
+echo " * NEMO reference root directory is: ${NEMO_ROOT_DIR}"
+echo " * STATION_ASF work directory is: ${SASF_WRK_DIR}"
+echo " ==> NEMO EXE to use: ${NEMO_EXE}"
+echo
+echo " * Input forcing data into: ${DATA_IN_DIR}"
+echo " * Production will be done into: ${PROD_DIR}"
+echo " * Directory in which namelists and xml files are fetched:"
+echo " ==> ${SASF_EXPREF}"
+echo
+
+mkdir -p ${PROD_DIR}
+
+rsync -avP ${NEMO_EXE} ${PROD_DIR}/
for ff in "context_nemo.xml" "domain_def_nemo.xml" "field_def_nemo-oce.xml" "file_def_nemo-oce.xml" "grid_def_nemo.xml" "iodef.xml" "namelist_ref"; do
- if [ ! -f ${NEMO_EXPREF}/${ff} ]; then echo " Mhhh, ${ff} not found into ${NEMO_EXPREF} !"; exit; fi
- rsync -avPL ${NEMO_EXPREF}/${ff} ${WORK_DIR}/
+ if [ ! -f ${SASF_EXPREF}/${ff} ]; then echo " Mhhh, ${ff} not found into ${SASF_EXPREF} !"; exit; fi
+ rsync -avPL ${SASF_EXPREF}/${ff} ${PROD_DIR}/
done
# Copy forcing to work directory:
-rsync -avP ${FORC_DIR}/Station_PAPA_50N-145W*.nc ${WORK_DIR}/
+rsync -avP ${DATA_IN_DIR}/Station_PAPA_50N-145W*.nc ${PROD_DIR}/
-for CASE in "ECMWF-noskin" "COARE3p6-noskin" "ECMWF" "COARE3p6" "NCAR"; do
+for CASE in "ECMWF" "COARE3p6" "NCAR" "ECMWF-noskin" "COARE3p6-noskin"; do
echo ; echo
@@ -50,11 +78,11 @@
scase=`echo "${CASE}" | tr '[:upper:]' '[:lower:]'`
- rm -f ${WORK_DIR}/namelist_cfg
- rsync -avPL ${NEMO_EXPREF}/namelist_${scase}_cfg ${WORK_DIR}/namelist_cfg
+ rm -f ${PROD_DIR}/namelist_cfg
+ rsync -avPL ${SASF_EXPREF}/namelist_${scase}_cfg ${PROD_DIR}/namelist_cfg
- cd ${WORK_DIR}/
+ cd ${PROD_DIR}/
echo
echo "Launching NEMO !"
- ./nemo.exe 1> out_nemo.out 2>err_nemo.err
+ ./nemo.exe 1>out_nemo.out 2>err_nemo.err
echo "Done!"
echo
Index: /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/EXPREF/namelist_coare3p6-noskin_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/EXPREF/namelist_coare3p6-noskin_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/EXPREF/namelist_coare3p6-noskin_cfg (revision 13540)
@@ -29,10 +29,12 @@
cn_exp = 'STATION_ASF-COARE3p6-noskin' ! experience name
nn_it000 = 1 ! first time step
- nn_itend = 26280 ! last time step (std 5840)
- nn_date0 = 20160101 ! date at nit_0000 (format yyyymmdd) used if ln_rstart=F or (ln_rstart=T and nn_rstctl=0 or 1)
+!!! nn_itend = 26304 ! last time step => 3 years (including 1 leap!) at dt=3600s
+!!! nn_date0 = 20160101 ! date at nit_0000 (format yyyymmdd) used if ln_rstart=F or (ln_rstart=T and nn_rstctl=0 or 1)
+ nn_itend = 8760 ! last time step => 3 years (including 1 leap!) at dt=3600s
+ nn_date0 = 20180101 ! date at nit_0000 (format yyyymmdd) used if ln_rstart=F or (ln_rstart=T and nn_rstctl=0 or 1)
nn_time0 = 0 ! initial time of day in hhmm
- nn_leapy = 0 ! Leap year calendar (1) or not (0)
- ln_rstart = .false. ! start from rest (F) or from a restart file (T)
- nn_euler = 1 ! = 0 : start with forward time step if ln_rstart=T
+ nn_leapy = 1 ! Leap year calendar (1) or not (0)
+ ln_rstart = .false. ! start from rest (F) or from a restart file (T)
+ ln_1st_euler = .false. ! =T force a start with forward time step (ln_rstart=T)
nn_rstctl = 2 ! restart control ==> activated only if ln_rstart=T
! ! = 0 nn_date0 read in namelist ; nn_it000 : read in namelist
@@ -45,6 +47,10 @@
nn_istate = 0 ! output the initial state (1) or not (0)
ln_rst_list = .false. ! output restarts at list of times using nn_stocklist (T) or at set frequency with nn_stock (F)
- nn_stock = 26280 ! 1year @ dt=3600 s / frequency of creation of a restart file (modulo referenced to 1)
- nn_write = 26280 ! 1year @ dt=3600 s / frequency of write in the output file (modulo referenced to nn_it000)
+ !!
+!!! nn_stock = 26304 ! 3 years (including 1 leap!) at dt=3600s / frequency of creation of a restart file (modulo referenced to 1)
+!!! nn_write = 26304 ! 3 years (including 1 leap!) at dt=3600s / frequency of write in the output file (modulo referenced to nn_it000)
+ nn_stock = 8760 ! 1 year at dt=3600s / frequency of creation of a restart file (modulo referenced to 1)
+ nn_write = 8760 ! 1 year at dt=3600s / frequency of write in the output file (modulo referenced to nn_it000)
+ !!
ln_mskland = .false. ! mask land points in NetCDF outputs (costly: + ~15%)
ln_cfmeta = .false. ! output additional data to netCDF files required for compliance with the CF metadata standard
@@ -195,6 +201,6 @@
!! !!
!! namdrg top/bottom drag coefficient (default: NO selection)
-!! namdrg_top top friction (ln_OFF=F & ln_isfcav=T)
-!! namdrg_bot bottom friction (ln_OFF=F)
+!! 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)
Index: /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/EXPREF/namelist_coare3p6_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/EXPREF/namelist_coare3p6_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/EXPREF/namelist_coare3p6_cfg (revision 13540)
@@ -29,10 +29,12 @@
cn_exp = 'STATION_ASF-COARE3p6' ! experience name
nn_it000 = 1 ! first time step
- nn_itend = 26280 ! last time step (std 5840)
- nn_date0 = 20160101 ! date at nit_0000 (format yyyymmdd) used if ln_rstart=F or (ln_rstart=T and nn_rstctl=0 or 1)
+!!! nn_itend = 26304 ! last time step => 3 years (including 1 leap!) at dt=3600s
+!!! nn_date0 = 20160101 ! date at nit_0000 (format yyyymmdd) used if ln_rstart=F or (ln_rstart=T and nn_rstctl=0 or 1)
+ nn_itend = 8760 ! last time step => 3 years (including 1 leap!) at dt=3600s
+ nn_date0 = 20180101 ! date at nit_0000 (format yyyymmdd) used if ln_rstart=F or (ln_rstart=T and nn_rstctl=0 or 1)
nn_time0 = 0 ! initial time of day in hhmm
- nn_leapy = 0 ! Leap year calendar (1) or not (0)
- ln_rstart = .false. ! start from rest (F) or from a restart file (T)
- nn_euler = 1 ! = 0 : start with forward time step if ln_rstart=T
+ nn_leapy = 1 ! Leap year calendar (1) or not (0)
+ ln_rstart = .false. ! start from rest (F) or from a restart file (T)
+ ln_1st_euler = .false. ! =T force a start with forward time step (ln_rstart=T)
nn_rstctl = 2 ! restart control ==> activated only if ln_rstart=T
! ! = 0 nn_date0 read in namelist ; nn_it000 : read in namelist
@@ -45,6 +47,10 @@
nn_istate = 0 ! output the initial state (1) or not (0)
ln_rst_list = .false. ! output restarts at list of times using nn_stocklist (T) or at set frequency with nn_stock (F)
- nn_stock = 26280 ! 1year @ dt=3600 s / frequency of creation of a restart file (modulo referenced to 1)
- nn_write = 26280 ! 1year @ dt=3600 s / frequency of write in the output file (modulo referenced to nn_it000)
+ !!
+!!! nn_stock = 26304 ! 3 years (including 1 leap!) at dt=3600s / frequency of creation of a restart file (modulo referenced to 1)
+!!! nn_write = 26304 ! 3 years (including 1 leap!) at dt=3600s / frequency of write in the output file (modulo referenced to nn_it000)
+ nn_stock = 8760 ! 1 year at dt=3600s / frequency of creation of a restart file (modulo referenced to 1)
+ nn_write = 8760 ! 1 year at dt=3600s / frequency of write in the output file (modulo referenced to nn_it000)
+ !!
ln_mskland = .false. ! mask land points in NetCDF outputs (costly: + ~15%)
ln_cfmeta = .false. ! output additional data to netCDF files required for compliance with the CF metadata standard
@@ -134,5 +140,5 @@
ln_humi_rlh = .true. ! humidity specified below in "sn_humi" is relative humidity [%] if .true.
!
- cn_dir = './' ! root directory for the bulk data location
+ cn_dir = './' ! root directory for the bulk data location
!___________!_________________________!___________________!___________!_____________!________!___________!______________________________________!__________!_______________!
! ! file name ! frequency (hours) ! variable ! time interp.! clim ! 'yearly'/ ! weights filename ! rotation ! land/sea mask !
@@ -163,5 +169,5 @@
ln_read_frq = .false. ! specify whether we must read frq or not
- cn_dir = './' ! root directory for the ocean data location
+ cn_dir = './' ! root directory for the ocean data location
!___________!_________________________!___________________!___________!_____________!________!___________!__________________!__________!_______________!
! ! file name ! frequency (hours) ! variable ! time interp.! clim ! 'yearly'/ ! weights filename ! rotation ! land/sea mask !
@@ -195,6 +201,6 @@
!! !!
!! namdrg top/bottom drag coefficient (default: NO selection)
-!! namdrg_top top friction (ln_OFF=F & ln_isfcav=T)
-!! namdrg_bot bottom friction (ln_OFF=F)
+!! 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)
@@ -215,5 +221,5 @@
&nameos ! ocean Equation Of Seawater (default: NO selection)
!-----------------------------------------------------------------------
- ln_eos80 = .true. ! = Use EOS80
+ ln_eos80 = .true. ! = Use EOS80
/
!!======================================================================
Index: /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/EXPREF/namelist_ecmwf-noskin_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/EXPREF/namelist_ecmwf-noskin_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/EXPREF/namelist_ecmwf-noskin_cfg (revision 13540)
@@ -29,10 +29,12 @@
cn_exp = 'STATION_ASF-ECMWF-noskin' ! experience name
nn_it000 = 1 ! first time step
- nn_itend = 26280 ! last time step (std 5840)
- nn_date0 = 20160101 ! date at nit_0000 (format yyyymmdd) used if ln_rstart=F or (ln_rstart=T and nn_rstctl=0 or 1)
+!!! nn_itend = 26304 ! last time step => 3 years (including 1 leap!) at dt=3600s
+!!! nn_date0 = 20160101 ! date at nit_0000 (format yyyymmdd) used if ln_rstart=F or (ln_rstart=T and nn_rstctl=0 or 1)
+ nn_itend = 8760 ! last time step => 3 years (including 1 leap!) at dt=3600s
+ nn_date0 = 20180101 ! date at nit_0000 (format yyyymmdd) used if ln_rstart=F or (ln_rstart=T and nn_rstctl=0 or 1)
nn_time0 = 0 ! initial time of day in hhmm
- nn_leapy = 0 ! Leap year calendar (1) or not (0)
- ln_rstart = .false. ! start from rest (F) or from a restart file (T)
- nn_euler = 1 ! = 0 : start with forward time step if ln_rstart=T
+ nn_leapy = 1 ! Leap year calendar (1) or not (0)
+ ln_rstart = .false. ! start from rest (F) or from a restart file (T)
+ ln_1st_euler = .false. ! =T force a start with forward time step (ln_rstart=T)
nn_rstctl = 2 ! restart control ==> activated only if ln_rstart=T
! ! = 0 nn_date0 read in namelist ; nn_it000 : read in namelist
@@ -45,6 +47,10 @@
nn_istate = 0 ! output the initial state (1) or not (0)
ln_rst_list = .false. ! output restarts at list of times using nn_stocklist (T) or at set frequency with nn_stock (F)
- nn_stock = 26280 ! 1year @ dt=3600 s / frequency of creation of a restart file (modulo referenced to 1)
- nn_write = 26280 ! 1year @ dt=3600 s / frequency of write in the output file (modulo referenced to nn_it000)
+ !!
+!!! nn_stock = 26304 ! 3 years (including 1 leap!) at dt=3600s / frequency of creation of a restart file (modulo referenced to 1)
+!!! nn_write = 26304 ! 3 years (including 1 leap!) at dt=3600s / frequency of write in the output file (modulo referenced to nn_it000)
+ nn_stock = 8760 ! 1 year at dt=3600s / frequency of creation of a restart file (modulo referenced to 1)
+ nn_write = 8760 ! 1 year at dt=3600s / frequency of write in the output file (modulo referenced to nn_it000)
+ !!
ln_mskland = .false. ! mask land points in NetCDF outputs (costly: + ~15%)
ln_cfmeta = .false. ! output additional data to netCDF files required for compliance with the CF metadata standard
@@ -195,6 +201,6 @@
!! !!
!! namdrg top/bottom drag coefficient (default: NO selection)
-!! namdrg_top top friction (ln_OFF=F & ln_isfcav=T)
-!! namdrg_bot bottom friction (ln_OFF=F)
+!! 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)
Index: /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/EXPREF/namelist_ecmwf_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/EXPREF/namelist_ecmwf_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/EXPREF/namelist_ecmwf_cfg (revision 13540)
@@ -29,10 +29,12 @@
cn_exp = 'STATION_ASF-ECMWF' ! experience name
nn_it000 = 1 ! first time step
- nn_itend = 26280 ! last time step (std 5840)
- nn_date0 = 20160101 ! date at nit_0000 (format yyyymmdd) used if ln_rstart=F or (ln_rstart=T and nn_rstctl=0 or 1)
+!!! nn_itend = 26304 ! last time step => 3 years (including 1 leap!) at dt=3600s
+!!! nn_date0 = 20160101 ! date at nit_0000 (format yyyymmdd) used if ln_rstart=F or (ln_rstart=T and nn_rstctl=0 or 1)
+ nn_itend = 8760 ! last time step => 3 years (including 1 leap!) at dt=3600s
+ nn_date0 = 20180101 ! date at nit_0000 (format yyyymmdd) used if ln_rstart=F or (ln_rstart=T and nn_rstctl=0 or 1)
nn_time0 = 0 ! initial time of day in hhmm
- nn_leapy = 0 ! Leap year calendar (1) or not (0)
- ln_rstart = .false. ! start from rest (F) or from a restart file (T)
- nn_euler = 1 ! = 0 : start with forward time step if ln_rstart=T
+ nn_leapy = 1 ! Leap year calendar (1) or not (0)
+ ln_rstart = .false. ! start from rest (F) or from a restart file (T)
+ ln_1st_euler = .false. ! =T force a start with forward time step (ln_rstart=T)
nn_rstctl = 2 ! restart control ==> activated only if ln_rstart=T
! ! = 0 nn_date0 read in namelist ; nn_it000 : read in namelist
@@ -45,6 +47,10 @@
nn_istate = 0 ! output the initial state (1) or not (0)
ln_rst_list = .false. ! output restarts at list of times using nn_stocklist (T) or at set frequency with nn_stock (F)
- nn_stock = 26280 ! 1year @ dt=3600 s / frequency of creation of a restart file (modulo referenced to 1)
- nn_write = 26280 ! 1year @ dt=3600 s / frequency of write in the output file (modulo referenced to nn_it000)
+ !!
+!!! nn_stock = 26304 ! 3 years (including 1 leap!) at dt=3600s / frequency of creation of a restart file (modulo referenced to 1)
+!!! nn_write = 26304 ! 3 years (including 1 leap!) at dt=3600s / frequency of write in the output file (modulo referenced to nn_it000)
+ nn_stock = 8760 ! 1 year at dt=3600s / frequency of creation of a restart file (modulo referenced to 1)
+ nn_write = 8760 ! 1 year at dt=3600s / frequency of write in the output file (modulo referenced to nn_it000)
+ !!
ln_mskland = .false. ! mask land points in NetCDF outputs (costly: + ~15%)
ln_cfmeta = .false. ! output additional data to netCDF files required for compliance with the CF metadata standard
@@ -134,5 +140,5 @@
ln_humi_rlh = .true. ! humidity specified below in "sn_humi" is relative humidity [%] if .true.
!
- cn_dir = './' ! root directory for the bulk data location
+ cn_dir = './' ! root directory for the bulk data location
!___________!_________________________!___________________!___________!_____________!________!___________!______________________________________!__________!_______________!
! ! file name ! frequency (hours) ! variable ! time interp.! clim ! 'yearly'/ ! weights filename ! rotation ! land/sea mask !
@@ -163,5 +169,5 @@
ln_read_frq = .false. ! specify whether we must read frq or not
- cn_dir = './' ! root directory for the ocean data location
+ cn_dir = './' ! root directory for the ocean data location
!___________!_________________________!___________________!___________!_____________!________!___________!__________________!__________!_______________!
! ! file name ! frequency (hours) ! variable ! time interp.! clim ! 'yearly'/ ! weights filename ! rotation ! land/sea mask !
@@ -195,6 +201,6 @@
!! !!
!! namdrg top/bottom drag coefficient (default: NO selection)
-!! namdrg_top top friction (ln_OFF=F & ln_isfcav=T)
-!! namdrg_bot bottom friction (ln_OFF=F)
+!! 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)
@@ -215,5 +221,5 @@
&nameos ! ocean Equation Of Seawater (default: NO selection)
!-----------------------------------------------------------------------
- ln_eos80 = .true. ! = Use EOS80
+ ln_eos80 = .true. ! = Use EOS80
/
!!======================================================================
Index: /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/EXPREF/namelist_ncar_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/EXPREF/namelist_ncar_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/EXPREF/namelist_ncar_cfg (revision 13540)
@@ -29,10 +29,12 @@
cn_exp = 'STATION_ASF-NCAR' ! experience name
nn_it000 = 1 ! first time step
- nn_itend = 26280 ! last time step (std 5840)
- nn_date0 = 20160101 ! date at nit_0000 (format yyyymmdd) used if ln_rstart=F or (ln_rstart=T and nn_rstctl=0 or 1)
+!!! nn_itend = 26304 ! last time step => 3 years (including 1 leap!) at dt=3600s
+!!! nn_date0 = 20160101 ! date at nit_0000 (format yyyymmdd) used if ln_rstart=F or (ln_rstart=T and nn_rstctl=0 or 1)
+ nn_itend = 8760 ! last time step => 3 years (including 1 leap!) at dt=3600s
+ nn_date0 = 20180101 ! date at nit_0000 (format yyyymmdd) used if ln_rstart=F or (ln_rstart=T and nn_rstctl=0 or 1)
nn_time0 = 0 ! initial time of day in hhmm
- nn_leapy = 0 ! Leap year calendar (1) or not (0)
- ln_rstart = .false. ! start from rest (F) or from a restart file (T)
- nn_euler = 1 ! = 0 : start with forward time step if ln_rstart=T
+ nn_leapy = 1 ! Leap year calendar (1) or not (0)
+ ln_rstart = .false. ! start from rest (F) or from a restart file (T)
+ ln_1st_euler = .false. ! =T force a start with forward time step (ln_rstart=T)
nn_rstctl = 2 ! restart control ==> activated only if ln_rstart=T
! ! = 0 nn_date0 read in namelist ; nn_it000 : read in namelist
@@ -45,6 +47,10 @@
nn_istate = 0 ! output the initial state (1) or not (0)
ln_rst_list = .false. ! output restarts at list of times using nn_stocklist (T) or at set frequency with nn_stock (F)
- nn_stock = 26280 ! 1year @ dt=3600 s / frequency of creation of a restart file (modulo referenced to 1)
- nn_write = 26280 ! 1year @ dt=3600 s / frequency of write in the output file (modulo referenced to nn_it000)
+ !!
+!!! nn_stock = 26304 ! 3 years (including 1 leap!) at dt=3600s / frequency of creation of a restart file (modulo referenced to 1)
+!!! nn_write = 26304 ! 3 years (including 1 leap!) at dt=3600s / frequency of write in the output file (modulo referenced to nn_it000)
+ nn_stock = 8760 ! 1 year at dt=3600s / frequency of creation of a restart file (modulo referenced to 1)
+ nn_write = 8760 ! 1 year at dt=3600s / frequency of write in the output file (modulo referenced to nn_it000)
+ !!
ln_mskland = .false. ! mask land points in NetCDF outputs (costly: + ~15%)
ln_cfmeta = .false. ! output additional data to netCDF files required for compliance with the CF metadata standard
@@ -134,5 +140,5 @@
ln_humi_rlh = .true. ! humidity specified below in "sn_humi" is relative humidity [%] if .true.
!
- cn_dir = './' ! root directory for the bulk data location
+ cn_dir = './' ! root directory for the bulk data location
!___________!_________________________!___________________!___________!_____________!________!___________!______________________________________!__________!_______________!
! ! file name ! frequency (hours) ! variable ! time interp.! clim ! 'yearly'/ ! weights filename ! rotation ! land/sea mask !
@@ -163,5 +169,5 @@
ln_read_frq = .false. ! specify whether we must read frq or not
- cn_dir = './' ! root directory for the ocean data location
+ cn_dir = './' ! root directory for the ocean data location
!___________!_________________________!___________________!___________!_____________!________!___________!__________________!__________!_______________!
! ! file name ! frequency (hours) ! variable ! time interp.! clim ! 'yearly'/ ! weights filename ! rotation ! land/sea mask !
@@ -195,6 +201,6 @@
!! !!
!! namdrg top/bottom drag coefficient (default: NO selection)
-!! namdrg_top top friction (ln_OFF=F & ln_isfcav=T)
-!! namdrg_bot bottom friction (ln_OFF=F)
+!! 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)
@@ -215,5 +221,5 @@
&nameos ! ocean Equation Of Seawater (default: NO selection)
!-----------------------------------------------------------------------
- ln_eos80 = .true. ! = Use EOS80
+ ln_eos80 = .true. ! = Use EOS80
/
!!======================================================================
Index: /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/EXPREF/plot_station_asf.py
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/EXPREF/plot_station_asf.py (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/EXPREF/plot_station_asf.py (revision 13540)
@@ -1,13 +1,11 @@
-#!/usr/bin/env python
+#!/usr/bin/env python3
# -*- Mode: Python; coding: utf-8; indent-tabs-mode: nil; tab-width: 4 -*-
-# Post-diagnostic of STATION_ASF / L. Brodeau, 2019
+# Post-diagnostic of STATION_ASF / L. Brodeau, 2020
import sys
from os import path as path
-#from string import replace
import math
import numpy as nmp
-#import scipy.signal as signal
from netCDF4 import Dataset
import matplotlib as mpl
@@ -15,21 +13,7 @@
import matplotlib.pyplot as plt
import matplotlib.dates as mdates
-#from string import find
-#import warnings
-#warnings.filterwarnings("ignore")
-#import time
-
-#import barakuda_plot as bp
-#import barakuda_tool as bt
-
-reload(sys)
-sys.setdefaultencoding('utf8')
-
-cy1 = '2016' ; # First year
+
+cy1 = '2018' ; # First year
cy2 = '2018' ; # Last year
-
-jt0 = 0
-jt0 = 17519
-
dir_figs='.'
@@ -53,6 +37,6 @@
L_VARL = [ r'$Q_{lat}$', r'$Q_{sens}$' , r'$Q_{net}$' , r'$Q_{lw}$' , r'$|\tau|$' , r'$\Delta T_{skin}$' ] ; # name of variable in latex mode
L_VUNT = [ r'$W/m^2$' , r'$W/m^2$' , r'$W/m^2$' , r'$W/m^2$' , r'$N/m^2$' , 'K' ]
-L_VMAX = [ 75. , 75. , 800. , 25. , 1.2 , -0.7 ]
-L_VMIN = [ -250. , -125. , -400. , -150. , 0. , 0.7 ]
+L_VMAX = [ 75. , 75. , 800. , 25. , 1.2 , 0.7 ]
+L_VMIN = [ -250. , -125. , -400. , -150. , 0. , -0.7 ]
L_ANOM = [ True , True , True , True , True , False ]
@@ -72,5 +56,5 @@
narg = len(sys.argv)
if narg != 2:
- print 'Usage: '+sys.argv[0]+' '; sys.exit(0)
+ print('Usage: '+sys.argv[0]+' '); sys.exit(0)
cdir_data = sys.argv[1]
@@ -82,5 +66,5 @@
def chck4f(cf):
cmesg = 'ERROR: File '+cf+' does not exist !!!'
- if not path.exists(cf): print cmesg ; sys.exit(0)
+ if not path.exists(cf): print(cmesg); sys.exit(0)
###cf_in = nmp.empty((), dtype="S10")
@@ -104,5 +88,5 @@
# Getting time array from the first file:
id_in = Dataset(cf_in[0])
-vt = id_in.variables['time_counter'][jt0:]
+vt = id_in.variables['time_counter'][:]
cunit_t = id_in.variables['time_counter'].units ; print(' "time_counter" is in "'+cunit_t+'"')
id_in.close()
@@ -138,5 +122,5 @@
if ctest == 'skin': id_in = Dataset(cf_in[ja])
if ctest == 'noskin': id_in = Dataset(cf_in_ns[ja])
- xF[:,ja] = id_in.variables[L_VNEM[jv]][jt0:,1,1] # only the center point of the 3x3 spatial domain!
+ xF[:,ja] = id_in.variables[L_VNEM[jv]][:,1,1] # only the center point of the 3x3 spatial domain!
if ja == 0: cvar_lnm = id_in.variables[L_VNEM[jv]].long_name
id_in.close()
@@ -180,5 +164,4 @@
rmlt = 10.**(int(romagn)) / 2.
yrng = math.copysign( math.ceil(abs(rmax)/rmlt)*rmlt , rmax)
- #print 'yrng = ', yrng ; #sys.exit(0)
fig = plt.figure(num = 10+jv, figsize=size_fig, facecolor='w', edgecolor='k')
@@ -211,10 +194,10 @@
for ja in range(nb_algos-1):
id_in = Dataset(cf_in[ja])
- xF[:,ja] = id_in.variables[L_VNEM[jv]][jt0:,1,1] # only the center point of the 3x3 spatial domain!
+ xF[:,ja] = id_in.variables[L_VNEM[jv]][:,1,1] # only the center point of the 3x3 spatial domain!
if ja == 0: cvar_lnm = id_in.variables[L_VNEM[jv]].long_name
id_in.close()
#
id_in = Dataset(cf_in_ns[ja])
- xFns[:,ja] = id_in.variables[L_VNEM[jv]][jt0:,1,1] # only the center point of the 3x3 spatial domain!
+ xFns[:,ja] = id_in.variables[L_VNEM[jv]][:,1,1] # only the center point of the 3x3 spatial domain!
if ja == 0: cvar_lnm = id_in.variables[L_VNEM[jv]].long_name
id_in.close()
@@ -229,9 +212,6 @@
rmlt = 10.**(int(romagn)) / 2.
yrng = math.copysign( math.ceil(abs(rmax)/rmlt)*rmlt , rmax)
- print 'yrng = ', yrng ; #sys.exit(0)
-
-
-
-
+
+
for ja in range(nb_algos-1):
Index: /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/MY_SRC/diawri.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/MY_SRC/diawri.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/MY_SRC/diawri.F90 (revision 13540)
@@ -35,4 +35,5 @@
USE iom !
USE ioipsl !
+
#if defined key_si3
USE ice
@@ -56,6 +57,6 @@
!!----------------------------------------------------------------------
- !! NEMO/SAS 4.0 , NEMO Consortium (2018)
- !! $Id: diawri.F90 10425 2018-12-19 21:54:16Z smasson $
+ !! NEMO/OCE 4.0 , NEMO Consortium (2018)
+ !! $Id: diawri.F90 12493 2020-03-02 07:56:31Z smasson $
!! Software governed by the CeCILL license (see ./LICENSE)
!!----------------------------------------------------------------------
@@ -114,11 +115,16 @@
INTEGER, DIMENSION(2) :: ierr
!!----------------------------------------------------------------------
- ierr = 0
- ALLOCATE( ndex_hT(jpi*jpj) , ndex_T(jpi*jpj*jpk) , &
- & ndex_hU(jpi*jpj) , ndex_U(jpi*jpj*jpk) , &
- & ndex_hV(jpi*jpj) , ndex_V(jpi*jpj*jpk) , STAT=ierr(1) )
- !
- dia_wri_alloc = MAXVAL(ierr)
- CALL mpp_sum( 'diawri', dia_wri_alloc )
+ IF( nn_write == -1 ) THEN
+ dia_wri_alloc = 0
+ ELSE
+ ierr = 0
+ ALLOCATE( ndex_hT(jpi*jpj) , ndex_T(jpi*jpj*jpk) , &
+ & ndex_hU(jpi*jpj) , ndex_U(jpi*jpj*jpk) , &
+ & ndex_hV(jpi*jpj) , ndex_V(jpi*jpj*jpk) , STAT=ierr(1) )
+ !
+ dia_wri_alloc = MAXVAL(ierr)
+ CALL mpp_sum( 'diawri', dia_wri_alloc )
+ !
+ ENDIF
!
END FUNCTION dia_wri_alloc
@@ -374,5 +380,5 @@
CALL iom_rstput( 0, 0, inum, 'vozocrtx', uu(:,:,:,Kmm) ) ! now i-velocity
CALL iom_rstput( 0, 0, inum, 'vomecrty', vv(:,:,:,Kmm) ) ! now j-velocity
- CALL iom_rstput( 0, 0, inum, 'vovecrtz', ww ) ! now k-velocity
+ CALL iom_rstput( 0, 0, inum, 'vovecrtz', ww ) ! now k-velocity
CALL iom_rstput( 0, 0, inum, 'sowaflup', emp - rnf ) ! freshwater budget
CALL iom_rstput( 0, 0, inum, 'sohefldo', qsr + qns ) ! total heat flux
Index: /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/MY_SRC/nemogcm.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/MY_SRC/nemogcm.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/MY_SRC/nemogcm.F90 (revision 13540)
@@ -2,5 +2,5 @@
!!======================================================================
!! *** MODULE nemogcm ***
- !! StandAlone Surface module : surface fluxes
+ !! STATION_ASF (SAS meets C1D)
!!======================================================================
!! History : 3.6 ! 2011-11 (S. Alderson, G. Madec) original code
@@ -19,17 +19,17 @@
!!----------------------------------------------------------------------
USE step_oce ! module used in the ocean time stepping module (step.F90)
- USE sbc_oce ! surface boundary condition: ocean #LB: rm?
USE phycst ! physical constant (par_cst routine)
USE domain ! domain initialization (dom_init & dom_cfg routines)
USE closea ! treatment of closed seas (for ln_closea)
USE usrdef_nam ! user defined configuration
+ USE istate ! initial state setting (istate_init routine)
USE step, ONLY : Nbb, Nnn, Naa, Nrhs ! time level indices
USE daymod ! calendar
USE restart ! open restart file
- !LB:USE step ! NEMO time-stepping (stp routine)
USE c1d ! 1D configuration
USE step_c1d ! Time stepping loop for the 1D configuration
- USE sbcssm !
!
+ USE prtctl ! Print control
+ USE in_out_manager ! I/O manager
USE lib_mpp ! distributed memory computing
USE mppini ! shared/distributed memory setting (mpp_init routine)
@@ -49,5 +49,5 @@
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
- !! $Id: nemogcm.F90 11536 2019-09-11 13:54:18Z smasson $
+ !! $Id: nemogcm.F90 12489 2020-02-28 15:55:11Z davestorkey $
!! Software governed by the CeCILL license (see ./LICENSE)
!!----------------------------------------------------------------------
@@ -84,4 +84,7 @@
! !== time stepping ==!
! !-----------------------!
+ !
+ ! !== set the model time-step ==!
+ !
istp = nit000
!
@@ -98,5 +101,6 @@
IF( nstop /= 0 .AND. lwp ) THEN ! error print
WRITE(ctmp1,*) ' ==>>> nemo_gcm: a total of ', nstop, ' errors have been found'
- CALL ctl_stop( ctmp1 )
+ WRITE(ctmp2,*) ' Look for "E R R O R" messages in all existing ocean_output* files'
+ CALL ctl_stop( ' ', ctmp1, ' ', ctmp2 )
ENDIF
!
@@ -106,8 +110,7 @@
!
#if defined key_iomput
- CALL xios_finalize ! end mpp communications with xios
+ CALL xios_finalize ! end mpp communications with xios
#else
- IF( lk_mpp ) THEN ; CALL mppstop ! end mpp communications
- ENDIF
+ IF( lk_mpp ) CALL mppstop ! end mpp communications
#endif
!
@@ -129,7 +132,6 @@
INTEGER :: ios, ilocal_comm ! local integers
!!
- NAMELIST/namctl/ sn_cfctl, nn_print, nn_ictls, nn_ictle, &
- & nn_isplt , nn_jsplt, nn_jctls, nn_jctle, &
- & ln_timing, ln_diacfl
+ NAMELIST/namctl/ sn_cfctl, ln_timing, ln_diacfl, &
+ & nn_isplt, nn_jsplt, nn_ictls, nn_ictle, nn_jctls, nn_jctle
NAMELIST/namcfg/ ln_read_cfg, cn_domcfg, ln_closea, ln_write_cfg, cn_domcfg_out, ln_use_jattr
!!----------------------------------------------------------------------
@@ -161,9 +163,15 @@
IF( lwm ) CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. )
! open reference and configuration namelist files
- CALL load_nml( numnam_ref, 'namelist_ref', -1, lwm )
- CALL load_nml( numnam_cfg, 'namelist_cfg', -1, lwm )
+ CALL load_nml( numnam_ref, 'namelist_ref', -1, lwm )
+ CALL load_nml( numnam_cfg, 'namelist_cfg', -1, lwm )
IF( lwm ) CALL ctl_opn( numond, 'output.namelist.dyn', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. )
! open /dev/null file to be able to supress output write easily
- CALL ctl_opn( numnul, '/dev/null', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. )
+ IF( Agrif_Root() ) THEN
+ CALL ctl_opn( numnul, '/dev/null', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. )
+#ifdef key_agrif
+ ELSE
+ numnul = Agrif_Parent(numnul)
+#endif
+ ENDIF
!
! !--------------------!
@@ -177,20 +185,6 @@
!
! finalize the definition of namctl variables
- IF( sn_cfctl%l_allon ) THEN
- ! Turn on all options.
- CALL nemo_set_cfctl( sn_cfctl, .TRUE., .TRUE. )
- ! Ensure all processors are active
- sn_cfctl%procmin = 0 ; sn_cfctl%procmax = 1000000 ; sn_cfctl%procincr = 1
- ELSEIF( sn_cfctl%l_config ) THEN
- ! Activate finer control of report outputs
- ! optionally switch off output from selected areas (note this only
- ! applies to output which does not involve global communications)
- IF( ( narea < sn_cfctl%procmin .OR. narea > sn_cfctl%procmax ) .OR. &
- & ( MOD( narea - sn_cfctl%procmin, sn_cfctl%procincr ) /= 0 ) ) &
- & CALL nemo_set_cfctl( sn_cfctl, .FALSE., .FALSE. )
- ELSE
- ! turn off all options.
- CALL nemo_set_cfctl( sn_cfctl, .FALSE., .TRUE. )
- ENDIF
+ IF( narea < sn_cfctl%procmin .OR. narea > sn_cfctl%procmax .OR. MOD( narea - sn_cfctl%procmin, sn_cfctl%procincr ) /= 0 ) &
+ & CALL nemo_set_cfctl( sn_cfctl, .FALSE. )
!
lwp = (narea == 1) .OR. sn_cfctl%l_oceout ! control of all listing output print
@@ -235,10 +229,10 @@
903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcfg in reference namelist' )
READ ( numnam_cfg, namcfg, IOSTAT = ios, ERR = 904 )
-904 IF( ios > 0 ) CALL ctl_nam ( ios , 'namcfg in configuration namelist' )
+904 IF( ios > 0 ) CALL ctl_nam ( ios , 'namcfg in configuration namelist' )
!
IF( ln_read_cfg ) THEN ! Read sizes in domain configuration file
- CALL domain_cfg ( cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio )
+ CALL domain_cfg ( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, jperio )
ELSE ! user-defined namelist
- CALL usr_def_nam( cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio )
+ CALL usr_def_nam( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, jperio )
ENDIF
!
@@ -266,26 +260,16 @@
IF( ln_timing ) CALL timing_start( 'nemo_init')
!
- CALL phy_cst ! Physical constants
- CALL eos_init ! Equation of state
+ CALL phy_cst ! Physical constants
+ CALL eos_init ! Equation of state
IF( lk_c1d ) CALL c1d_init ! 1D column configuration
- CALL dom_init( Nbb, Nnn, Naa, "OPA") ! Domain
+ CALL dom_init( Nbb, Nnn, Naa, "OPA") ! Domain
IF( sn_cfctl%l_prtctl ) &
& CALL prt_ctl_init ! Print control
-
- IF( ln_rstart ) THEN ! Restart from a file
- ! ! -------------------
- CALL rst_read( Nbb, Nnn ) ! Read the restart file
- CALL day_init ! model calendar (using both namelist and restart infos)
- !
- ELSE ! Start from rest
- ! ! ---------------
- numror = 0 ! define numror = 0 -> no restart file to read
- neuler = 0 ! Set time-step indicator at nit000 (euler forward)
- CALL day_init ! model calendar (using both namelist and restart infos)
- ENDIF
- !
-
- ! ! external forcing
- CALL sbc_init( Nbb, Nnn, Naa ) ! surface boundary conditions (including sea-ice)
+ !
+
+ CALL istate_init( Nbb, Nnn, Naa ) ! ocean initial state (Dynamics and tracers)
+
+ ! ! external forcing
+ CALL sbc_init( Nbb, Nnn, Naa ) ! surface boundary conditions (including sea-ice)
!
@@ -311,7 +295,4 @@
WRITE(numout,*) '~~~~~~~~'
WRITE(numout,*) ' Namelist namctl'
- WRITE(numout,*) ' sn_cfctl%l_glochk = ', sn_cfctl%l_glochk
- WRITE(numout,*) ' sn_cfctl%l_allon = ', sn_cfctl%l_allon
- WRITE(numout,*) ' finer control over o/p sn_cfctl%l_config = ', sn_cfctl%l_config
WRITE(numout,*) ' sn_cfctl%l_runstat = ', sn_cfctl%l_runstat
WRITE(numout,*) ' sn_cfctl%l_trcstat = ', sn_cfctl%l_trcstat
@@ -321,27 +302,13 @@
WRITE(numout,*) ' sn_cfctl%l_prttrc = ', sn_cfctl%l_prttrc
WRITE(numout,*) ' sn_cfctl%l_oasout = ', sn_cfctl%l_oasout
- WRITE(numout,*) ' sn_cfctl%procmin = ', sn_cfctl%procmin
- WRITE(numout,*) ' sn_cfctl%procmax = ', sn_cfctl%procmax
- WRITE(numout,*) ' sn_cfctl%procincr = ', sn_cfctl%procincr
- WRITE(numout,*) ' sn_cfctl%ptimincr = ', sn_cfctl%ptimincr
- WRITE(numout,*) ' level of print nn_print = ', nn_print
- WRITE(numout,*) ' Start i indice for SUM control nn_ictls = ', nn_ictls
- WRITE(numout,*) ' End i indice for SUM control nn_ictle = ', nn_ictle
- WRITE(numout,*) ' Start j indice for SUM control nn_jctls = ', nn_jctls
- WRITE(numout,*) ' End j indice for SUM control nn_jctle = ', nn_jctle
- WRITE(numout,*) ' number of proc. following i nn_isplt = ', nn_isplt
- WRITE(numout,*) ' number of proc. following j nn_jsplt = ', nn_jsplt
+ WRITE(numout,*) ' sn_cfctl%procmin = ', sn_cfctl%procmin
+ WRITE(numout,*) ' sn_cfctl%procmax = ', sn_cfctl%procmax
+ WRITE(numout,*) ' sn_cfctl%procincr = ', sn_cfctl%procincr
+ WRITE(numout,*) ' sn_cfctl%ptimincr = ', sn_cfctl%ptimincr
WRITE(numout,*) ' timing by routine ln_timing = ', ln_timing
WRITE(numout,*) ' CFL diagnostics ln_diacfl = ', ln_diacfl
ENDIF
!
- nprint = nn_print ! convert DOCTOR namelist names into OLD names
- nictls = nn_ictls
- nictle = nn_ictle
- njctls = nn_jctls
- njctle = nn_jctle
- isplt = nn_isplt
- jsplt = nn_jsplt
-
+ IF( .NOT.ln_read_cfg ) ln_closea = .false. ! dealing possible only with a domcfg file
IF(lwp) THEN ! control print
WRITE(numout,*)
@@ -354,44 +321,4 @@
WRITE(numout,*) ' use file attribute if exists as i/p j-start ln_use_jattr = ', ln_use_jattr
ENDIF
- IF( .NOT.ln_read_cfg ) ln_closea = .false. ! dealing possible only with a domcfg file
- !
- ! ! Parameter control
- !
- IF( sn_cfctl%l_prtctl .OR. sn_cfctl%l_prttrc ) THEN ! sub-domain area indices for the control prints
- IF( lk_mpp .AND. jpnij > 1 ) THEN
- isplt = jpni ; jsplt = jpnj ; ijsplt = jpni*jpnj ! the domain is forced to the real split domain
- ELSE
- IF( isplt == 1 .AND. jsplt == 1 ) THEN
- CALL ctl_warn( ' - isplt & jsplt are equal to 1', &
- & ' - the print control will be done over the whole domain' )
- ENDIF
- ijsplt = isplt * jsplt ! total number of processors ijsplt
- ENDIF
- IF(lwp) WRITE(numout,*)' - The total number of processors over which the'
- IF(lwp) WRITE(numout,*)' print control will be done is ijsplt : ', ijsplt
- !
- ! ! indices used for the SUM control
- IF( nictls+nictle+njctls+njctle == 0 ) THEN ! print control done over the default area
- lsp_area = .FALSE.
- ELSE ! print control done over a specific area
- lsp_area = .TRUE.
- IF( nictls < 1 .OR. nictls > jpiglo ) THEN
- CALL ctl_warn( ' - nictls must be 1<=nictls>=jpiglo, it is forced to 1' )
- nictls = 1
- ENDIF
- IF( nictle < 1 .OR. nictle > jpiglo ) THEN
- CALL ctl_warn( ' - nictle must be 1<=nictle>=jpiglo, it is forced to jpiglo' )
- nictle = jpiglo
- ENDIF
- IF( njctls < 1 .OR. njctls > jpjglo ) THEN
- CALL ctl_warn( ' - njctls must be 1<=njctls>=jpjglo, it is forced to 1' )
- njctls = 1
- ENDIF
- IF( njctle < 1 .OR. njctle > jpjglo ) THEN
- CALL ctl_warn( ' - njctle must be 1<=njctle>=jpjglo, it is forced to jpjglo' )
- njctle = jpjglo
- ENDIF
- ENDIF
- ENDIF
!
IF( 1._wp /= SIGN(1._wp,-0._wp) ) CALL ctl_stop( 'nemo_ctl: The intrinsec SIGN function follows f2003 standard.', &
@@ -439,5 +366,5 @@
!!----------------------------------------------------------------------
!
- ierr = oce_alloc () ! ocean
+ ierr = oce_alloc () ! ocean
ierr = ierr + dia_wri_alloc()
ierr = ierr + dom_oce_alloc() ! ocean domain
@@ -448,26 +375,19 @@
END SUBROUTINE nemo_alloc
-
- SUBROUTINE nemo_set_cfctl(sn_cfctl, setto, for_all )
+
+ SUBROUTINE nemo_set_cfctl(sn_cfctl, setto )
!!----------------------------------------------------------------------
!! *** ROUTINE nemo_set_cfctl ***
!!
!! ** Purpose : Set elements of the output control structure to setto.
- !! for_all should be .false. unless all areas are to be
- !! treated identically.
!!
!! ** Method : Note this routine can be used to switch on/off some
- !! types of output for selected areas but any output types
- !! that involve global communications (e.g. mpp_max, glob_sum)
- !! should be protected from selective switching by the
- !! for_all argument
- !!----------------------------------------------------------------------
- LOGICAL :: setto, for_all
- TYPE(sn_ctl) :: sn_cfctl
- !!----------------------------------------------------------------------
- IF( for_all ) THEN
- sn_cfctl%l_runstat = setto
- sn_cfctl%l_trcstat = setto
- ENDIF
+ !! types of output for selected areas.
+ !!----------------------------------------------------------------------
+ TYPE(sn_ctl), INTENT(inout) :: sn_cfctl
+ LOGICAL , INTENT(in ) :: setto
+ !!----------------------------------------------------------------------
+ sn_cfctl%l_runstat = setto
+ sn_cfctl%l_trcstat = setto
sn_cfctl%l_oceout = setto
sn_cfctl%l_layout = setto
@@ -479,2 +399,3 @@
!!======================================================================
END MODULE nemogcm
+
Index: /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/MY_SRC/sbcssm.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/MY_SRC/sbcssm.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/MY_SRC/sbcssm.F90 (revision 13540)
@@ -54,5 +54,5 @@
!!----------------------------------------------------------------------
!! NEMO/SAS 4.0 , NEMO Consortium (2018)
- !! $Id: sbcssm.F90 10068 2018-08-28 14:09:04Z nicolasmartin $
+ !! $Id: sbcssm.F90 12615 2020-03-26 15:18:49Z laurent $
!! Software governed by the CeCILL license (see ./LICENSE)
!!----------------------------------------------------------------------
Index: /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/MY_SRC/step_c1d.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/MY_SRC/step_c1d.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/MY_SRC/step_c1d.F90 (revision 13540)
@@ -26,5 +26,5 @@
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
- !! $Id: step_c1d.F90 10068 2018-08-28 14:09:04Z nicolasmartin $
+ !! $Id: step_c1d.F90 12377 2020-02-12 14:39:06Z acc $
!! Software governed by the CeCILL license (see ./LICENSE)
!!----------------------------------------------------------------------
@@ -64,4 +64,7 @@
CALL sbc ( kstp, Nbb, Nnn ) ! Sea Boundary Condition (including sea-ice)
+ !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ ! diagnostics and outputs
+ !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
CALL dia_wri( kstp, Nnn ) ! ocean model: outputs
@@ -75,10 +78,11 @@
! Control and restarts
!<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
- CALL stp_ctl( kstp, Nbb, Nnn, indic )
+ CALL stp_ctl( kstp, Nnn )
+
IF( kstp == nit000 ) CALL iom_close( numror ) ! close input ocean restart file
IF( lrst_oce ) CALL rst_write( kstp, Nbb, Nnn ) ! write output ocean restart file
!
#if defined key_iomput
- IF( kstp == nitend .OR. indic < 0 ) CALL xios_context_finalize() ! needed for XIOS
+ IF( kstp == nitend .OR. nstop > 0 ) CALL xios_context_finalize() ! needed for XIOS
!
#endif
Index: /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/MY_SRC/stpctl.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/MY_SRC/stpctl.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/MY_SRC/stpctl.F90 (revision 13540)
@@ -19,10 +19,10 @@
USE dom_oce ! ocean space and time domain variables
USE sbc_oce ! surface fluxes and stuff
+ !
USE diawri ! Standard run outputs (dia_wri_state routine)
- !
USE in_out_manager ! I/O manager
USE lbclnk ! ocean lateral boundary conditions (or mpp link)
USE lib_mpp ! distributed memory computing
-
+ !
USE netcdf ! NetCDF library
IMPLICIT NONE
@@ -31,6 +31,6 @@
PUBLIC stp_ctl ! routine called by step.F90
- INTEGER :: idrun, idtime, idtau, idqns, idemp, istatus
- LOGICAL :: lsomeoce
+ INTEGER :: nrunid ! netcdf file id
+ INTEGER, DIMENSION(3) :: nvarid ! netcdf variable id
!!----------------------------------------------------------------------
!! NEMO/SAS 4.0 , NEMO Consortium (2018)
@@ -40,99 +40,171 @@
CONTAINS
- SUBROUTINE stp_ctl( kt, Kbb, Kmm, kindic )
+ SUBROUTINE stp_ctl( kt, Kmm )
!!----------------------------------------------------------------------
!! *** ROUTINE stp_ctl ***
- !!
+ !!
!! ** Purpose : Control the run
!!
!! ** Method : - Save the time step in numstp
- !! - Print it each 50 time steps
- !! - Stop the run IF problem encountered by setting indic=-3
+ !! - Stop the run IF problem encountered by setting nstop > 0
+ !! Problems checked: wind stress module max larger than 5 N/m^2
+ !! non-solar heat flux max larger than 2000 W/m^2
+ !! Evaporation-Precip max larger than 1.E-3 kg/m^2/s
!!
!! ** Actions : "time.step" file = last ocean time-step
!! "run.stat" file = run statistics
- !! nstop indicator sheared among all local domain (lk_mpp=T)
+ !! nstop indicator sheared among all local domain
!!----------------------------------------------------------------------
INTEGER, INTENT(in ) :: kt ! ocean time-step index
- INTEGER, INTENT(in ) :: Kbb, Kmm ! ocean time level index
- INTEGER, INTENT(inout) :: kindic ! error indicator
- !!
- REAL(wp), DIMENSION(3) :: zmax
- LOGICAL :: ll_wrtstp, ll_colruns, ll_wrtruns
- CHARACTER(len=20) :: clname
- !!----------------------------------------------------------------------
- !
- ll_wrtstp = ( MOD( kt, sn_cfctl%ptimincr ) == 0 ) .OR. ( kt == nitend )
- ll_colruns = ll_wrtstp .AND. ( sn_cfctl%l_runstat )
- ll_wrtruns = ll_colruns .AND. lwm
- IF( kt == nit000 .AND. lwp ) THEN
- WRITE(numout,*)
- WRITE(numout,*) 'stp_ctl : time-stepping control'
- WRITE(numout,*) '~~~~~~~'
- ! ! open time.step file
- IF( lwm ) CALL ctl_opn( numstp, 'time.step', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea )
- ! ! open run.stat file(s) at start whatever
- ! ! the value of sn_cfctl%ptimincr
- IF( lwm .AND. ( sn_cfctl%l_runstat ) ) THEN
+ INTEGER, INTENT(in ) :: Kmm ! ocean time level index
+ !!
+ INTEGER :: ji ! dummy loop indices
+ INTEGER :: idtime, istatus
+ INTEGER , DIMENSION(4) :: iareasum, iareamin, iareamax
+ INTEGER , DIMENSION(3,3) :: iloc ! min/max loc indices
+ REAL(wp) :: zzz ! local real
+ REAL(wp), DIMENSION(4) :: zmax, zmaxlocal
+ LOGICAL :: ll_wrtstp, ll_colruns, ll_wrtruns
+ LOGICAL, DIMENSION(jpi,jpj) :: llmsk
+ CHARACTER(len=20) :: clname
+ !!----------------------------------------------------------------------
+ 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
+ !
+ IF( kt == nit000 ) THEN
+ !
+ IF( lwp ) THEN
+ WRITE(numout,*)
+ WRITE(numout,*) 'stp_ctl : time-stepping control'
+ WRITE(numout,*) '~~~~~~~'
+ ENDIF
+ ! ! open time.step ascii file, done only by 1st subdomain
+ IF( lwm ) CALL ctl_opn( numstp, 'time.step', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea )
+ !
+ IF( ll_wrtruns ) THEN
+ ! ! open run.stat ascii file, done only by 1st subdomain
CALL ctl_opn( numrun, 'run.stat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea )
+ ! ! open run.stat.nc netcdf file, done only by 1st subdomain
clname = 'run.stat.nc'
IF( .NOT. Agrif_Root() ) clname = TRIM(Agrif_CFixed())//"_"//TRIM(clname)
- istatus = NF90_CREATE( TRIM(clname), NF90_CLOBBER, idrun )
- istatus = NF90_DEF_DIM( idrun, 'time', NF90_UNLIMITED, idtime )
- istatus = NF90_DEF_VAR( idrun, 'tau_max', NF90_DOUBLE, (/ idtime /), idtau )
- istatus = NF90_DEF_VAR( idrun, 'qns_max', NF90_DOUBLE, (/ idtime /), idqns )
- istatus = NF90_DEF_VAR( idrun, 'emp_max', NF90_DOUBLE, (/ idtime /), idemp )
- istatus = NF90_ENDDEF(idrun)
- ENDIF
- ENDIF
- IF( kt == nit000 ) lsomeoce = COUNT( ssmask(:,:) == 1._wp ) > 0
- !
- IF(lwm .AND. ll_wrtstp) THEN !== current time step ==! ("time.step" file)
+ istatus = NF90_CREATE( TRIM(clname), NF90_CLOBBER, nrunid )
+ istatus = NF90_DEF_DIM( nrunid, 'time', NF90_UNLIMITED, idtime )
+ istatus = NF90_DEF_VAR( nrunid, 'tau_max', NF90_DOUBLE, (/ idtime /), nvarid(1) )
+ istatus = NF90_DEF_VAR( nrunid, 'qns_max', NF90_DOUBLE, (/ idtime /), nvarid(2) )
+ istatus = NF90_DEF_VAR( nrunid, 'emp_max', NF90_DOUBLE, (/ idtime /), nvarid(3) )
+ istatus = NF90_ENDDEF(nrunid)
+ ENDIF
+ !
+ ENDIF
+ !
+ ! !== write current time step ==!
+ ! !== done only by 1st subdomain at writting timestep ==!
+ IF( lwm .AND. ll_wrtstp ) THEN
WRITE ( numstp, '(1x, i8)' ) kt
REWIND( numstp )
ENDIF
- !
- ! !== test of extrema ==!
- zmax(1) = MAXVAL( taum(:,:) , mask = tmask(:,:,1) == 1._wp ) ! max wind stress module
- zmax(2) = MAXVAL( ABS( qns(:,:) ) , mask = tmask(:,:,1) == 1._wp ) ! max non-solar heat flux
- zmax(3) = MAXVAL( ABS( emp(:,:) ) , mask = tmask(:,:,1) == 1._wp ) ! max E-P
- !
+ ! !== test of local extrema ==!
+ ! !== done by all processes at every time step ==!
+ !
+ llmsk( 1:Nis1,:) = .FALSE. ! exclude halos from the checked region
+ llmsk(Nie1: jpi,:) = .FALSE.
+ llmsk(:, 1:Njs1) = .FALSE.
+ llmsk(:,Nje1: jpj) = .FALSE.
+ !
+ llmsk(Nis0:Nie0,Njs0:Nje0) = tmask(Nis0:Nie0,Njs0:Nje0,1) == 1._wp ! test only the inner domain
+ IF( COUNT( llmsk(:,:) ) > 0 ) THEN ! avoid huge values sent back for land processors...
+ zmax(1) = MAXVAL( taum(:,:) , mask = llmsk ) ! max wind stress module
+ zmax(2) = MAXVAL( ABS( qns(:,:) ) , mask = llmsk ) ! max non-solar heat flux
+ zmax(3) = MAXVAL( ABS( emp(:,:) ) , mask = llmsk ) ! max E-P
+ ELSE
+ IF( ll_colruns ) THEN ! default value: must not be kept when calling mpp_max -> must be as small as possible
+ zmax(1:3) = -HUGE(1._wp)
+ ELSE ! default value: must not give true for any of the tests bellow (-> avoid manipulating HUGE...)
+ zmax(1:3) = 0._wp
+ ENDIF
+ ENDIF
+ zmax(4) = REAL( nstop, wp ) ! stop indicator
+ ! !== get global extrema ==!
+ ! !== done by all processes if writting run.stat ==!
IF( ll_colruns ) THEN
+ zmaxlocal(:) = zmax(:)
CALL mpp_max( "stpctl", zmax ) ! max over the global domain
- nstop = NINT( zmax(3) ) ! nstop indicator sheared among all local domains
- ENDIF
- ! !== run statistics ==! ("run.stat" files)
+ nstop = NINT( zmax(4) ) ! update nstop indicator (now sheared among all local domains)
+ ENDIF
+ ! !== write "run.stat" files ==!
+ ! !== done only by 1st subdomain at writting timestep ==!
IF( ll_wrtruns ) THEN
WRITE(numrun,9500) kt, zmax(1), zmax(2), zmax(3)
- istatus = NF90_PUT_VAR( idrun, idtau, (/ zmax(1)/), (/kt/), (/1/) )
- istatus = NF90_PUT_VAR( idrun, idqns, (/ zmax(2)/), (/kt/), (/1/) )
- istatus = NF90_PUT_VAR( idrun, idemp, (/ zmax(3)/), (/kt/), (/1/) )
- IF( MOD( kt , 100 ) == 0 ) istatus = NF90_SYNC(idrun)
- IF( kt == nitend ) istatus = NF90_CLOSE(idrun)
+ istatus = NF90_PUT_VAR( nrunid, nvarid(1), (/ zmax(1)/), (/kt/), (/1/) )
+ istatus = NF90_PUT_VAR( nrunid, nvarid(2), (/ zmax(2)/), (/kt/), (/1/) )
+ istatus = NF90_PUT_VAR( nrunid, nvarid(3), (/ zmax(3)/), (/kt/), (/1/) )
+ IF( kt == nitend ) istatus = NF90_CLOSE(nrunid)
END IF
- ! !== error handling ==!
- IF( ( sn_cfctl%l_glochk .OR. lsomeoce ) .AND. ( & ! domain contains some ocean points, check for sensible ranges
- & zmax(1) > 5._wp .OR. & ! too large wind stress ( > 5 N/m^2 )
- & zmax(2) > 2000._wp .OR. & ! too large non-solar heat flux ( > 2000 W/m^2)
- & zmax(3) > 1.E-3_wp .OR. & ! too large net freshwater flux ( kg/m^2/s)
- & ISNAN( zmax(1) + zmax(2) + zmax(3) ) ) ) THEN ! NaN encounter in the tests
-
- !! We are 1D so no need to find a spatial location of the rogue point.
-
+ ! !== error handling ==!
+ ! !== done by all processes at every time step ==!
+ !
+ IF( zmax(1) > 5._wp .OR. & ! too large wind stress ( > 5 N/m^2 )
+ & zmax(2) > 2000._wp .OR. & ! too large non-solar heat flux ( > 2000 W/m^2 )
+ & zmax(3) > 1.E-3_wp .OR. & ! too large net freshwater flux ( > 1.E-3 kg/m^2/s )
+ & ISNAN( zmax(1) + zmax(2) + zmax(3) ) .OR. & ! NaN encounter in the tests
+ & ABS( zmax(1) + zmax(2) + zmax(3) ) > HUGE(1._wp) ) THEN ! Infinity encounter in the tests
+ !
+ iloc(:,:) = 0
+ IF( ll_colruns ) THEN ! zmax is global, so it is the same on all subdomains -> no dead lock with mpp_maxloc
+ ! 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) )
+ ! find which subdomain has the max.
+ iareamin(:) = jpnij+1 ; iareamax(:) = 0 ; iareasum(:) = 0
+ DO ji = 1, 4
+ IF( zmaxlocal(ji) == zmax(ji) ) THEN
+ iareamin(ji) = narea ; iareamax(ji) = narea ; iareasum(ji) = 1
+ ENDIF
+ END DO
+ CALL mpp_min( "stpctl", iareamin ) ! min over the global domain
+ CALL mpp_max( "stpctl", iareamax ) ! max over the global domain
+ 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 )
+ DO ji = 1, 3 ! local domain indices ==> global domain indices, excluding halos
+ iloc(1:2,ji) = (/ mig0(iloc(1,ji)), mjg0(iloc(2,ji)) /)
+ END DO
+ iareamin(:) = narea ; iareamax(:) = narea ; iareasum(:) = 1 ! this is local information
+ ENDIF
+ !
WRITE(ctmp1,*) ' stp_ctl: |tau_mod| > 5 N/m2 or |qns| > 2000 W/m2 or |emp| > 1.E-3 or NaN encounter in the tests'
- WRITE(ctmp2,9500) kt, zmax(1), zmax(2), zmax(3)
- WRITE(ctmp6,*) ' ===> output of last computed fields in output.abort.nc file'
-
+ CALL wrt_line( ctmp2, kt, '|tau| max', zmax(1), iloc(:,1), iareasum(1), iareamin(1), iareamax(1) )
+ CALL wrt_line( ctmp3, kt, '|qns| max', zmax(2), iloc(:,2), iareasum(2), iareamin(2), iareamax(2) )
+ CALL wrt_line( ctmp4, kt, 'emp max', zmax(3), iloc(:,3), iareasum(3), iareamin(3), iareamax(3) )
+ IF( Agrif_Root() ) THEN
+ WRITE(ctmp6,*) ' ===> output of last computed fields in output.abort* files'
+ ELSE
+ WRITE(ctmp6,*) ' ===> output of last computed fields in '//TRIM(Agrif_CFixed())//'_output.abort* files'
+ ENDIF
+ !
CALL dia_wri_state( Kmm, 'output.abort' ) ! create an output.abort file
-
- IF( .NOT. sn_cfctl%l_glochk ) THEN
- WRITE(ctmp8,*) 'E R R O R message from sub-domain: ', narea
- CALL ctl_stop( 'STOP', ctmp1, ' ', ctmp2, ' ', ctmp6, ' ' )
- ELSE
- CALL ctl_stop( ctmp1, ' ', ctmp2, ' ', ctmp6, ' ' )
- ENDIF
-
- kindic = -3
- !
+ !
+ 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 )
+ 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 )
+ ENDIF
+ !
+ ENDIF
+ !
+ IF( nstop > 0 ) THEN ! an error was detected and we did not abort yet...
+ ngrdstop = Agrif_Fixed() ! store which grid got this error
+ IF( .NOT. ll_colruns .AND. jpnij > 1 ) CALL ctl_stop( 'STOP' ) ! we must abort here to avoid MPI deadlock
ENDIF
!
@@ -140,4 +212,61 @@
!
END SUBROUTINE stp_ctl
+
+
+ SUBROUTINE wrt_line( cdline, kt, cdprefix, pval, kloc, ksum, kmin, kmax )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE wrt_line ***
+ !!
+ !! ** Purpose : write information line
+ !!
+ !!----------------------------------------------------------------------
+ CHARACTER(len=*), INTENT( out) :: cdline
+ CHARACTER(len=*), INTENT(in ) :: cdprefix
+ REAL(wp), INTENT(in ) :: pval
+ INTEGER, DIMENSION(3), INTENT(in ) :: kloc
+ INTEGER, INTENT(in ) :: kt, ksum, kmin, kmax
+ !
+ CHARACTER(len=80) :: clsuff
+ CHARACTER(len=9 ) :: clkt, clsum, clmin, clmax
+ CHARACTER(len=9 ) :: cli, clj, clk
+ CHARACTER(len=1 ) :: clfmt
+ CHARACTER(len=4 ) :: cl4 ! needed to be able to compile with Agrif, I don't know why
+ INTEGER :: ifmtk
+ !!----------------------------------------------------------------------
+ WRITE(clkt , '(i9)') kt
+
+ WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpnij ,wp))) + 1 ! how many digits to we need to write ? (we decide max = 9)
+ !!! WRITE(clsum, '(i'//clfmt//')') ksum ! this is creating a compilation error with AGRIF
+ cl4 = '(i'//clfmt//')' ; WRITE(clsum, cl4) ksum
+ WRITE(clfmt, '(i1)') INT(LOG10(REAL(MAX(1,jpnij-1),wp))) + 1 ! how many digits to we need to write ? (we decide max = 9)
+ cl4 = '(i'//clfmt//')' ; WRITE(clmin, cl4) kmin-1
+ WRITE(clmax, cl4) kmax-1
+ !
+ WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpiglo,wp))) + 1 ! how many digits to we need to write jpiglo? (we decide max = 9)
+ cl4 = '(i'//clfmt//')' ; WRITE(cli, cl4) kloc(1) ! this is ok with AGRIF
+ WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpjglo,wp))) + 1 ! how many digits to we need to write jpjglo? (we decide max = 9)
+ cl4 = '(i'//clfmt//')' ; WRITE(clj, cl4) kloc(2) ! this is ok with AGRIF
+ !
+ IF( ksum == 1 ) THEN ; WRITE(clsuff,9100) TRIM(clmin)
+ ELSE ; WRITE(clsuff,9200) TRIM(clsum), TRIM(clmin), TRIM(clmax)
+ ENDIF
+ IF(kloc(3) == 0) THEN
+ ifmtk = INT(LOG10(REAL(jpk,wp))) + 1 ! how many digits to we need to write jpk? (we decide max = 9)
+ clk = REPEAT(' ', ifmtk) ! create the equivalent in blank string
+ WRITE(cdline,9300) TRIM(ADJUSTL(clkt)), TRIM(ADJUSTL(cdprefix)), pval, TRIM(cli), TRIM(clj), clk(1:ifmtk), TRIM(clsuff)
+ ELSE
+ WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpk,wp))) + 1 ! how many digits to we need to write jpk? (we decide max = 9)
+ !!! WRITE(clk, '(i'//clfmt//')') kloc(3) ! this is creating a compilation error with AGRIF
+ cl4 = '(i'//clfmt//')' ; WRITE(clk, cl4) kloc(3) ! this is ok with AGRIF
+ WRITE(cdline,9400) TRIM(ADJUSTL(clkt)), TRIM(ADJUSTL(cdprefix)), pval, TRIM(cli), TRIM(clj), TRIM(clk), TRIM(clsuff)
+ ENDIF
+ !
+9100 FORMAT('MPI rank ', a)
+9200 FORMAT('found in ', a, ' MPI tasks, spread out among ranks ', a, ' to ', a)
+9300 FORMAT('kt ', a, ' ', a, ' ', 1pg11.4, ' at i j ', a, ' ', a, ' ', a, ' ', a)
+9400 FORMAT('kt ', a, ' ', a, ' ', 1pg11.4, ' at i j k ', a, ' ', a, ' ', a, ' ', a)
+ !
+ END SUBROUTINE wrt_line
+
!!======================================================================
Index: /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/MY_SRC/usrdef_hgr.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/MY_SRC/usrdef_hgr.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/MY_SRC/usrdef_hgr.F90 (revision 13540)
@@ -14,5 +14,4 @@
!! 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
@@ -30,5 +29,5 @@
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
- !! $Id: usrdef_hgr.F90 10072 2018-08-28 15:21:50Z nicolasmartin $
+ !! $Id: usrdef_hgr.F90 12489 2020-02-28 15:55:11Z davestorkey $
!! Software governed by the CeCILL license (see ./LICENSE)
!!----------------------------------------------------------------------
@@ -54,5 +53,5 @@
!!
!! ** Action : - define longitude & latitude of t-, u-, v- and f-points (in degrees)
- !! - define coriolis parameter at f-point if the domain in not on the sphere
+ !! - define coriolis parameter at f-point if the domain in not on the sphere (on beta-plane)
!! - define i- & j-scale factors at t-, u-, v- and f-points (in meters)
!! - define u- & v-surfaces (if gridsize reduction is used in some straits) (in m2)
Index: /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/MY_SRC/usrdef_nam.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/MY_SRC/usrdef_nam.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/MY_SRC/usrdef_nam.F90 (revision 13540)
@@ -8,5 +8,5 @@
!!======================================================================
!! History : 4.0 ! 2016-03 (S. Flavoni, G. Madec) Original code
- !! History : 4.x ! 2019-10 (L. Brodeau) for STATION_ASF (C1D meets SAS)
+ !! 4.x ! 2019-10 (L. Brodeau) for STATION_ASF (C1D meets SAS)
!!----------------------------------------------------------------------
@@ -15,6 +15,4 @@
!! 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
@@ -33,5 +31,5 @@
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
- !! $Id: usrdef_nam.F90 11536 2019-09-11 13:54:18Z smasson $
+ !! $Id: usrdef_nam.F90 12377 2020-02-12 14:39:06Z acc $
!! Software governed by the CeCILL license (see ./LICENSE)
!!----------------------------------------------------------------------
@@ -68,8 +66,8 @@
kk_cfg = 0
- ! Global Domain size: STATION_ASF domain is 3 x 3 grid-points x 75 or vertical levels
+ ! Global Domain size: STATION_ASF domain is 3 x 3 grid-points x 2 or vertical levels
kpi = 3
kpj = 3
- kpk = 1
+ kpk = 2 ! 2, rather than 1, because 1 would cause some issues... like overflow in array boundary indexes, etc...
!
! ! Set the lateral boundary condition of the global domain
Index: /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/MY_SRC/usrdef_zgr.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/MY_SRC/usrdef_zgr.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/MY_SRC/usrdef_zgr.F90 (revision 13540)
@@ -1,19 +1,21 @@
MODULE usrdef_zgr
!!======================================================================
- !! *** MODULE usrdef_zgr ***
+ !! *** MODULE usrdef_zgr ***
!!
!! === STATION_ASF case ===
!!
- !! user defined : vertical coordinate system of a user configuration
+ !! User defined : vertical coordinate system of a user configuration
!!======================================================================
- !! History : 4.0 ! 2019-10 (L. Brodeau) Original code
+ !! History : 4.0 ! 2016-06 (G. Madec) Original code
+ !! 4.x ! 2019-10 (L. Brodeau) Station ASF
!!----------------------------------------------------------------------
!!----------------------------------------------------------------------
- !! usr_def_zgr : user defined vertical coordinate system (required)
+ !! usr_def_zgr : user defined vertical coordinate system
+ !! zgr_z : reference 1D z-coordinate
+ !! zgr_top_bot: ocean top and bottom level indices
+ !! zgr_zco : 3D verticl coordinate in pure z-coordinate case
!!---------------------------------------------------------------------
USE oce ! ocean variables
- !USE dom_oce ! ocean domain
- !USE depth_e3 ! depth <=> e3
USE usrdef_nam ! User defined : namelist variables
!
@@ -21,14 +23,13 @@
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
+ PUBLIC usr_def_zgr ! called by domzgr.F90
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
- !! $Id: usrdef_zgr.F90 10072 2018-08-28 15:21:50Z nicolasmartin $
+ !! $Id: usrdef_zgr.F90 12377 2020-02-12 14:39:06Z acc $
!! Software governed by the CeCILL license (see ./LICENSE)
!!----------------------------------------------------------------------
@@ -47,12 +48,12 @@
!!
!!----------------------------------------------------------------------
- LOGICAL , INTENT( out) :: 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
+ 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
!!----------------------------------------------------------------------
!
@@ -61,10 +62,13 @@
IF(lwp) WRITE(numout,*) '~~~~~~~~~~~'
!
-
+ !
+ ! type of vertical coordinate
+ ! ---------------------------
ld_zco = .TRUE. ! z-coordinate without ocean cavities
ld_zps = .FALSE.
ld_sco = .FALSE.
ld_isfcav = .FALSE.
-
+
+ !! 1st level (the only one that matters)
pdept_1d(1) = rn_dept1 ! depth (m) at which the SST is taken/measured == depth of first T point!
pdepw_1d(1) = 0._wp
@@ -72,16 +76,33 @@
pe3w_1d(1) = rn_dept1 ! LB???
- pdept(:,:,:) = rn_dept1
- pdepw(:,:,:) = 0._wp
- pe3t(:,:,:) = 2._wp*rn_dept1
- pe3u(:,:,:) = 2._wp*rn_dept1
- pe3v(:,:,:) = 2._wp*rn_dept1
- pe3f(:,:,:) = 2._wp*rn_dept1
- pe3w(:,:,:) = rn_dept1 ! LB???
- pe3uw(:,:,:) = rn_dept1 ! LB???
- pe3vw(:,:,:) = rn_dept1 ! LB???
+ pdept(:,:,1) = rn_dept1
+ pdepw(:,:,1) = 0._wp
+ pe3t(:,:,1) = 2._wp*rn_dept1
+ pe3u(:,:,1) = 2._wp*rn_dept1
+ pe3v(:,:,1) = 2._wp*rn_dept1
+ pe3f(:,:,1) = 2._wp*rn_dept1
+ pe3w(:,:,1) = rn_dept1 ! LB???
+ pe3uw(:,:,1) = rn_dept1 ! LB???
+ pe3vw(:,:,1) = rn_dept1 ! LB???
+
+ !! 2nd level, technically useless (only for the sake of code stability)
+ pdept_1d(2) = 3._wp*rn_dept1
+ pdepw_1d(2) = 2._wp*rn_dept1
+ pe3t_1d(2) = 2._wp*rn_dept1
+ pe3w_1d(2) = 2._wp*rn_dept1
+
+ pdept(:,:,2) = 3._wp*rn_dept1
+ pdepw(:,:,2) = 2._wp*rn_dept1
+ pe3t(:,:,2) = 2._wp*rn_dept1
+ pe3u(:,:,2) = 2._wp*rn_dept1
+ pe3v(:,:,2) = 2._wp*rn_dept1
+ pe3f(:,:,2) = 2._wp*rn_dept1
+ pe3w(:,:,2) = 2._wp*rn_dept1
+ pe3uw(:,:,2) = 2._wp*rn_dept1
+ pe3vw(:,:,2) = 2._wp*rn_dept1
+
k_top = 1
k_bot = 1
- !
+
END SUBROUTINE usr_def_zgr
!!======================================================================
Index: /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/README.md
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/README.md (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/STATION_ASF/README.md (revision 13540)
@@ -1,18 +1,22 @@
+# *Station Air-Sea Fluxes* demonstration case
-## WARNING: TOTALLY-ALPHA-STUFF / DOCUMENT IN THE PROCESS OF BEING WRITEN!
+Last successful test done with NEMOGCM trunk: `r13263`
-# *Station Air-Sea Fluxes* demonstration case
+Author: Laurent Brodeau, 2020
+
+NOTE: if working with the trunk of NEMO, you are strongly advised to use the same test-case but on the `NEMO-examples` GitHub depo:
+https://github.com/NEMO-ocean/NEMO-examples/tree/master/STATION_ASF
## Objectives
-```STATION_ASF``` is a demonstration case that mimics an in-situ station (buoy, platform) dedicated to the estimation of surface air-sea fluxes by means of the measurement of traditional meteorological surface parameters.
+```STATION_ASF``` is a demonstration test-case that mimics a (static) in-situ station (buoy, platform) dedicated to the estimation of surface air-sea fluxes by means of *widely-measured* (bulk) meteorological surface parameters.
-```STATION_ASF``` is based on the merging of the "single column" and the "standalone surface module" configurations of NEMO. In short, it coulb defined as "SAS meets C1D". As such, the spatial domain of ```STATION_ASF``` is punctual (1D, well actually 3 x 3 as in C1D).
+```STATION_ASF``` has been constructed by merging the *single column* and the *standalone surface module* configurations of NEMO. In short, it can be defined as "SAS meets C1D". As such, the spatial domain of ```STATION_ASF``` is punctual (1D, well actually 3 x 3 as in C1D).
-```STATION_ASF``` is therefore a versatile tool, and extremely light in terms of computing requirements, to test the different bulk algorithms and cool-skin/warm-layer parameterization options included in NEMO.
+```STATION_ASF``` is therefore a versatile tool, and extremely lightweight in terms of computing requirements, to test the different bulk algorithms and cool-skin/warm-layer parameterization options included in NEMO.
As input ```STATION_ASF``` will require the traditional *bulk* sea surface parameters:
-- sea surface temperature (SST) at $z_{SST}$ meters below the surface
+- Bulk sea surface temperature (SST) at _zSST_ meters below the surface
- Surface current vector
- Sea surface salinity
@@ -20,18 +24,29 @@
as well as the usual surface atmospheric state:
-- air temperature at $z_t$ meters above the surface
-- air humidity at $z_t$ meters above the surface (specific humidity or relative humidity or dew-point temperature)
-- wind speed vector at $z_u$ meters above the surface
+- air temperature at _zt_ meters above the surface
+- air humidity at _zt_ meters above the surface (specific humidity or relative humidity or dew-point temperature)
+- wind speed vector at _zu_ meters above the surface
- Sea level atmospheric pressure (SLP)
- Downwelling solar radiation
- Downwelling longwave radiation
+### Example of diagnostics from `STATION_ASF`
+
+(Generated with script `./EXPREF/plot_station_asf_simple.py`)
+
+![plot](https://github.com/NEMO-ocean/NEMO-examples/blob/master/STATION_ASF/figs/01_temperatures_ECMWF.svg)
+
+![plot](https://github.com/NEMO-ocean/NEMO-examples/blob/master/STATION_ASF/figs/Cd.svg)
+
+![plot](https://github.com/NEMO-ocean/NEMO-examples/blob/master/STATION_ASF/figs/dT_skin.svg)
+
+![plot](https://github.com/NEMO-ocean/NEMO-examples/blob/master/STATION_ASF/figs/Qlat.svg)
## Physical description
-### Important namelist parameters speficic to STATION_ASF
+### Important namelist parameters specific to STATION_ASF
-* ```rn_dept1@namusr_def:``` depth (m) at which the prescribed SST is taken (i.e. depth of first T-point); important due to impact on warm-layer estimate, the deeper, the more pronounced!
+* ```rn_dept1@namusr_def:``` depth (m) at which the prescribed SST is taken (*i.e.* depth of first T-point); important due to impact on warm-layer estimate, the deeper, the more pronounced!
* ```rn_lat1d,rn_lon1d@namc1d:``` fixed coordinates of the location of the station (buoy, platform, etc).
@@ -45,20 +60,21 @@
## Input files to test STATION ASF
-Three full years of processed hourly data from the PAPA station (buoy) can be downloaded here:
-https://drive.google.com/file/d/1MxNvjhRHmMrL54y6RX7WIaM9-LGl--ZP/
+One full year (2018) of processed hourly data from the PAPA station (buoy) is found into the `input_data` directory.
+These three files are everything you need to play with the set of *namelists* provided for this test-case.
-These three files are everything you need to play with the set of namelists provided for this test-case.
-
-- ```Station_PAPA_50N-145W_atm_hourly.nc``` → contains hourly surface atmospheric state
-- ```Station_PAPA_50N-145W_precip_daily.nc``` → contains daily precipitation
-- ```Station_PAPA_50N-145W_oce_hourly.nc``` → contains hourly sea surface state
+- ```Station_PAPA_50N-145W_atm_hourly_y2018.nc``` → contains hourly surface atmospheric state
+- ```Station_PAPA_50N-145W_precip_daily_y2018.nc``` → contains daily precipitation
+- ```Station_PAPA_50N-145W_oce_hourly_y2018.nc``` → contains hourly sea surface state
For station PAPA (50.1 N, 144.9 W), air temperature and humidity are measured at 2.5 m, the wind speed at 4 m, and the SST at 1 m below the surface, hence the following namelist parameters are given:
-- ```rn_dept1 = 1. ``` (&namusr_def)
-- ```rn_lat1d = 50.1 ``` (&namc1d)
-- ```rn_lon1d = 215.1``` (&namc1d)
-- ```rn_zqt = 2.5``` (&namsbc_blk)
-- ```rn_zu = 4.``` (&namsbc_blk)
+- `&namusr_def`
+ - ```rn_dept1 = 1. ```
+- `&namc1d`
+ - ```rn_lat1d = 50.1 ```
+ - ```rn_lon1d = 215.1```
+- `&namsbc_blk`
+ - ```rn_zqt = 2.5```
+ - ```rn_zu = 4.```
@@ -68,12 +84,28 @@
First compile the test-case as follows (compile with xios-2.5 support → check your ARCH file):
-```./makenemo -m -n STATION_ASF -j 4 -a STATION_ASF```
+```./makenemo -a STATION_ASF -m -n STATION_ASF2 -j 4```
Then you can use the script ``launch_sasf.sh`` found in ```EXPREF/``` to launch 3 simulations (one for each bulk parameterization available). You need to adapt the following variable to your environment in the script:
-- ```NEMO_DIR``` : NEMO root directory where to fetch compiled STATION_ASF ```nemo.exe``` + setup (such as ```${NEMO_DIR}/tests/STATION_ASF```)
+- ```NEMO_ROOT_DIR``` : NEMO root directory where to fetch compiled STATION_ASF ```nemo.exe``` + setup (such as ```${NEMO_ROOT_DIR}/tests/STATION_ASF```)
-- ```WORK_DIR``` : Directory where to run the simulation
+- ```PROD_DIR``` : Directory where to run the simulation
-- ```FORC_DIR``` Directory containing sea-surface + atmospheric forcings (get it there https://drive.google.com/file/d/1MxNvjhRHmMrL54y6RX7WIaM9-LGl--ZP/)
+- ```DATA_IN_DIR``` : Directory containing sea-surface + atmospheric forcings (found here in ```input_data/```)
+If everything goes according to plan, ``launch_sasf.sh`` should have generated the 3 following sets of output files into `${PROD_DIR}/output`:
+
+ STATION_ASF-COARE3p6_1h_20180101_20181231_gridT.nc
+ STATION_ASF-COARE3p6_1h_20180101_20181231_gridU.nc
+ STATION_ASF-COARE3p6_1h_20180101_20181231_gridV.nc
+ STATION_ASF-ECMWF_1h_20180101_20181231_gridT.nc
+ STATION_ASF-ECMWF_1h_20180101_20181231_gridU.nc
+ STATION_ASF-ECMWF_1h_20180101_20181231_gridV.nc
+ STATION_ASF-NCAR_1h_20180101_20181231_gridT.nc
+ STATION_ASF-NCAR_1h_20180101_20181231_gridU.nc
+ STATION_ASF-NCAR_1h_20180101_20181231_gridV.nc
+
+---
+
+*/Laurent, July 2020.*
+
Index: /NEMO/branches/2020/r12377_ticket2386/tests/VORTEX/EXPREF/1_context_nemo.xml
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/VORTEX/EXPREF/1_context_nemo.xml (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/VORTEX/EXPREF/1_context_nemo.xml (revision 13540)
@@ -11,5 +11,5 @@
01
01
- 1026.0
+ 1026.0
3991.86795711963
0.99530670233846
Index: /NEMO/branches/2020/r12377_ticket2386/tests/VORTEX/EXPREF/1_namelist_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/VORTEX/EXPREF/1_namelist_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/VORTEX/EXPREF/1_namelist_cfg (revision 13540)
@@ -98,8 +98,6 @@
&namagrif ! AGRIF zoom ("key_agrif")
!-----------------------------------------------------------------------
- ln_spc_dyn = .true. ! use 0 as special value for dynamics
- rn_sponge_tra = 800. ! coefficient for tracer sponge layer [m2/s]
- rn_sponge_dyn = 800. ! coefficient for dynamics sponge layer [m2/s]
- ln_chk_bathy = .FALSE. !
+ rn_sponge_tra = 0.00768 ! coefficient for tracer sponge layer []
+ rn_sponge_dyn = 0.00768 ! coefficient for dynamics sponge layer []
/
!!======================================================================
@@ -107,6 +105,6 @@
!! !!
!! namdrg top/bottom drag coefficient (default: NO selection)
-!! namdrg_top top friction (ln_OFF=F & ln_isfcav=T)
-!! namdrg_bot bottom friction (ln_OFF=F)
+!! 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)
@@ -116,5 +114,5 @@
&namdrg ! top/bottom drag coefficient (default: NO selection)
!-----------------------------------------------------------------------
- ln_OFF = .true. ! free-slip : Cd = 0
+ ln_drg_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot
/
!!======================================================================
@@ -133,5 +131,5 @@
!-----------------------------------------------------------------------
ln_seos = .true. ! = Use simplified equation of state (S-EOS)
- ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
+ ! ! rd(T,S,Z)*rho0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
rn_a0 = 0.28 ! thermal expension coefficient (for simplified equation of state)
rn_b0 = 0. ! saline expension coefficient (for simplified equation of state)
Index: /NEMO/branches/2020/r12377_ticket2386/tests/VORTEX/EXPREF/context_nemo.xml
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/VORTEX/EXPREF/context_nemo.xml (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/VORTEX/EXPREF/context_nemo.xml (revision 13540)
@@ -11,5 +11,5 @@
01
01
- 1026.0
+ 1026.0
3991.86795711963
0.99530670233846
Index: /NEMO/branches/2020/r12377_ticket2386/tests/VORTEX/EXPREF/namelist_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/VORTEX/EXPREF/namelist_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/VORTEX/EXPREF/namelist_cfg (revision 13540)
@@ -99,6 +99,6 @@
!! !!
!! namdrg top/bottom drag coefficient (default: NO selection)
-!! namdrg_top top friction (ln_OFF=F & ln_isfcav=T)
-!! namdrg_bot bottom friction (ln_OFF=F)
+!! 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)
@@ -108,5 +108,5 @@
&namdrg ! top/bottom drag coefficient (default: NO selection)
!-----------------------------------------------------------------------
- ln_OFF = .true. ! free-slip : Cd = 0
+ ln_drg_OFF = .true. ! free-slip : Cd = 0 (F => fill namdrg_bot
/
!!======================================================================
@@ -125,5 +125,5 @@
!-----------------------------------------------------------------------
ln_seos = .true. ! = Use simplified equation of state (S-EOS)
- ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
+ ! ! rd(T,S,Z)*rho0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
rn_a0 = 0.28 ! thermal expension coefficient (for simplified equation of state)
rn_b0 = 0. ! saline expension coefficient (for simplified equation of state)
Index: /NEMO/branches/2020/r12377_ticket2386/tests/VORTEX/MY_SRC/domvvl.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/VORTEX/MY_SRC/domvvl.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/VORTEX/MY_SRC/domvvl.F90 (revision 13540)
@@ -9,14 +9,7 @@
!! 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
+ !! 4.x ! 2020-02 (G. Madec, S. Techene) introduce ssh to h0 ratio
!!----------------------------------------------------------------------
- !!----------------------------------------------------------------------
- !! 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
- !!----------------------------------------------------------------------
USE oce ! ocean dynamics and tracers
USE phycst ! physical constant
@@ -36,10 +29,4 @@
PRIVATE
- 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
-
! !!* Namelist nam_vvl
LOGICAL , PUBLIC :: ln_vvl_zstar = .FALSE. ! zstar vertical coordinate
@@ -63,4 +50,30 @@
REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:) :: frq_rst_hdv ! retoring period for low freq. divergence
+#if defined key_qco
+ !!----------------------------------------------------------------------
+ !! 'key_qco' EMPTY MODULE Quasi-Eulerian vertical coordonate
+ !!----------------------------------------------------------------------
+#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)
@@ -133,5 +146,6 @@
!
END SUBROUTINE dom_vvl_init
- !
+
+
SUBROUTINE dom_vvl_zgr(Kbb, Kmm, Kaa)
!!----------------------------------------------------------------------
@@ -188,22 +202,18 @@
gdept(:,:,1,Kbb) = 0.5_wp * e3w(:,:,1,Kbb)
gdepw(:,:,1,Kbb) = 0.0_wp
- DO jk = 2, jpk ! vertical sum
- DO jj = 1,jpj
- DO ji = 1,jpi
- ! 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
+ DO_3D( 1, 1, 1, 1, 2, jpk )
+ ! 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 DO
- END DO
- END DO
+ 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)
@@ -240,31 +250,29 @@
ENDIF
IF ( ln_vvl_zstar_at_eqtor ) THEN ! use z-star in vicinity of the Equator
- DO jj = 1, jpj
- DO ji = 1, jpi
+ 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 DO
- END DO
+ 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 ; ii1 = 111
- ij0 = 128 ; ij1 = 135 ;
+ 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
@@ -326,5 +334,6 @@
LOGICAL :: ll_do_bclinic ! local logical
REAL(wp), DIMENSION(jpi,jpj) :: zht, z_scale, zwu, zwv, zhdiv
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t
+ REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ze3t
+ LOGICAL , DIMENSION(:,:,:), ALLOCATABLE :: llmsk
!!----------------------------------------------------------------------
!
@@ -357,6 +366,6 @@
END DO
!
- IF( ln_vvl_ztilde .OR. ln_vvl_layer .AND. ll_do_bclinic ) THEN ! z_tilde or layer coordinate !
- ! ! ------baroclinic part------ !
+ IF( (ln_vvl_ztilde .OR. ln_vvl_layer) .AND. ll_do_bclinic ) THEN ! z_tilde or layer coordinate !
+ ! ! ------baroclinic part------ !
! I - initialization
! ==================
@@ -411,31 +420,21 @@
zwu(:,:) = 0._wp
zwv(:,:) = 0._wp
- DO jk = 1, jpkm1 ! a - first derivative: diffusive fluxes
- DO jj = 1, jpjm1
- DO ji = 1, jpim1 ! vector opt.
- 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 DO
- END DO
- END DO
- DO jj = 1, jpj ! b - correction for last oceanic u-v points
- DO ji = 1, jpi
- 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 DO
- END DO
- DO jk = 1, jpkm1 ! c - second derivative: divergence of diffusive fluxes
- DO jj = 2, jpjm1
- DO ji = 2, jpim1 ! vector opt.
- 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 DO
- END DO
- END DO
+ DO_3D( 1, 0, 1, 0, 1, jpkm1 )
+ 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( 1, 1, 1, 1 )
+ 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 )
+ 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)
@@ -444,6 +443,4 @@
! 4 - Time stepping of baroclinic scale factors
! ---------------------------------------------
- ! Leapfrog time stepping
- ! ~~~~~~~~~~~~~~~~~~~~~~
CALL lbc_lnk( 'domvvl', tilde_e3t_a(:,:,:), 'T', 1._wp )
tilde_e3t_a(:,:,:) = tilde_e3t_b(:,:,:) + rDt * tmask(:,:,:) * tilde_e3t_a(:,:,:)
@@ -451,25 +448,21 @@
! Maximum deformation control
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~
- ze3t(:,:,jpk) = 0._wp
- DO jk = 1, jpkm1
- ze3t(:,:,jk) = tilde_e3t_a(:,:,jk) / e3t_0(:,:,jk) * tmask(:,:,jk) * tmask_i(:,:)
- END DO
- z_tmax = MAXVAL( ze3t(:,:,:) )
- CALL mpp_max( 'domvvl', z_tmax ) ! max over the global domain
- z_tmin = MINVAL( ze3t(:,:,:) )
- CALL mpp_min( 'domvvl', z_tmin ) ! min over the global domain
+ 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:Nis1,:,:) = .FALSE. ! exclude halos from the checked region
+ llmsk(Nie1: jpi,:,:) = .FALSE.
+ llmsk(:, 1:Njs1,:) = .FALSE.
+ llmsk(:,Nje1: 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
- IF( lk_mpp ) THEN
- CALL mpp_maxloc( 'domvvl', ze3t, tmask, z_tmax, ijk_max )
- CALL mpp_minloc( 'domvvl', ze3t, tmask, z_tmin, ijk_min )
- ELSE
- ijk_max = MAXLOC( ze3t(:,:,:) )
- ijk_max(1) = ijk_max(1) + nimpp - 1
- ijk_max(2) = ijk_max(2) + njmpp - 1
- ijk_min = MINLOC( ze3t(:,:,:) )
- ijk_min(1) = ijk_min(1) + nimpp - 1
- ijk_min(2) = ijk_min(2) + njmpp - 1
- ENDIF
+ 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
@@ -480,4 +473,5 @@
ENDIF
ENDIF
+ DEALLOCATE( ze3t, llmsk )
! - ML - end test
! - ML - Imposing these limits will cause a baroclinicity error which is corrected for below
@@ -646,5 +640,5 @@
! Horizontal scale factor interpolations
! --------------------------------------
- ! - ML - e3u(:,:,:,Kbb) and e3v(:,:,:,Kbb) are allready computed in dynnxt
+ ! - ML - e3u(:,:,:,Kbb) and e3v(:,:,:,Kbb) are already computed in dynnxt
! - JC - hu(:,:,:,Kbb), hv(:,:,:,:,Kbb), hur_b, hvr_b also
@@ -663,17 +657,13 @@
gdepw(:,:,1,Kmm) = 0.0_wp
gde3w(:,:,1) = gdept(:,:,1,Kmm) - ssh(:,:,Kmm)
- DO jk = 2, jpk
- DO jj = 1,jpj
- DO ji = 1,jpi
- ! 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 DO
- END DO
- END DO
+ DO_3D( 1, 1, 1, 1, 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
@@ -722,40 +712,28 @@
!
CASE( 'U' ) !* from T- to U-point : hor. surface weighted mean
- DO jk = 1, jpk
- DO jj = 1, jpjm1
- DO ji = 1, jpim1 ! vector opt.
- 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 DO
- END DO
- END DO
+ 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
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
- DO jk = 1, jpk
- DO jj = 1, jpjm1
- DO ji = 1, jpim1 ! vector opt.
- 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 DO
- END DO
- END DO
+ 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
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
- DO jk = 1, jpk
- DO jj = 1, jpjm1
- DO ji = 1, jpim1 ! vector opt.
- 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 DO
- END DO
- END DO
+ DO_3D( 1, 0, 1, 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
CALL lbc_lnk( 'domvvl', pe3_out(:,:,:), 'F', 1._wp )
pe3_out(:,:,:) = pe3_out(:,:,:) + e3f_0(:,:,:)
@@ -825,5 +803,5 @@
IF( ln_rstart ) THEN !* Read the restart file
CALL rst_read_open ! open the restart file if necessary
- CALL iom_get( numror, jpdom_autoglo, 'sshn' , ssh(:,:,Kmm), ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'sshn' , ssh(:,:,Kmm), ldxios = lrxios )
!
id1 = iom_varid( numror, 'e3t_b', ldstop = .FALSE. )
@@ -832,10 +810,12 @@
id4 = iom_varid( numror, 'tilde_e3t_n', ldstop = .FALSE. )
id5 = iom_varid( numror, 'hdiv_lf', ldstop = .FALSE. )
+ !
! ! --------- !
! ! all cases !
! ! --------- !
+ !
IF( MIN( id1, id2 ) > 0 ) THEN ! all required arrays exist
- CALL iom_get( numror, jpdom_autoglo, 'e3t_b', e3t(:,:,:,Kbb), ldxios = lrxios )
- CALL iom_get( numror, jpdom_autoglo, 'e3t_n', e3t(:,:,:,Kmm), ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb), ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm), ldxios = lrxios )
! needed to restart if land processor not computed
IF(lwp) write(numout,*) 'dom_vvl_rst : e3t(:,:,:,Kbb) and e3t(:,:,:,Kmm) found in restart files'
@@ -850,6 +830,6 @@
IF(lwp) write(numout,*) 'dom_vvl_rst WARNING : e3t(:,:,:,Kmm) not found in restart files'
IF(lwp) write(numout,*) 'e3t_n set equal to e3t_b.'
- IF(lwp) write(numout,*) 'l_1st_euler is forced to .true.'
- CALL iom_get( numror, jpdom_autoglo, 'e3t_b', e3t(:,:,:,Kbb), ldxios = lrxios )
+ IF(lwp) write(numout,*) 'l_1st_euler is forced to true'
+ CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb), ldxios = lrxios )
e3t(:,:,:,Kmm) = e3t(:,:,:,Kbb)
l_1st_euler = .true.
@@ -857,6 +837,6 @@
IF(lwp) write(numout,*) 'dom_vvl_rst WARNING : e3t(:,:,:,Kbb) not found in restart files'
IF(lwp) write(numout,*) 'e3t_b set equal to e3t_n.'
- IF(lwp) write(numout,*) 'l_1st_euler is forced to .true.'
- CALL iom_get( numror, jpdom_autoglo, 'e3t_n', e3t(:,:,:,Kmm), ldxios = lrxios )
+ IF(lwp) write(numout,*) 'l_1st_euler is forced to true'
+ CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm), ldxios = lrxios )
e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm)
l_1st_euler = .true.
@@ -864,5 +844,5 @@
IF(lwp) write(numout,*) 'dom_vvl_rst WARNING : e3t(:,:,:,Kmm) not found in restart file'
IF(lwp) write(numout,*) 'Compute scale factor from sshn'
- IF(lwp) write(numout,*) 'l_1st_euler is forced to .true.'
+ IF(lwp) write(numout,*) 'l_1st_euler is forced to true'
DO jk = 1, jpk
e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * ( ht_0(:,:) + ssh(:,:,Kmm) ) &
@@ -883,6 +863,6 @@
! ! ----------------------- !
IF( MIN( id3, id4 ) > 0 ) THEN ! all required arrays exist
- CALL iom_get( numror, jpdom_autoglo, 'tilde_e3t_b', tilde_e3t_b(:,:,:), ldxios = lrxios )
- CALL iom_get( numror, jpdom_autoglo, 'tilde_e3t_n', tilde_e3t_n(:,:,:), ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'tilde_e3t_b', tilde_e3t_b(:,:,:), ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'tilde_e3t_n', tilde_e3t_n(:,:,:), ldxios = lrxios )
ELSE ! one at least array is missing
tilde_e3t_b(:,:,:) = 0.0_wp
@@ -893,5 +873,5 @@
! ! ------------ !
IF( id5 > 0 ) THEN ! required array exists
- CALL iom_get( numror, jpdom_autoglo, 'hdiv_lf', hdiv_lf(:,:,:), ldxios = lrxios )
+ CALL iom_get( numror, jpdom_auto, 'hdiv_lf', hdiv_lf(:,:,:), ldxios = lrxios )
ELSE ! array is missing
hdiv_lf(:,:,:) = 0.0_wp
@@ -917,12 +897,10 @@
ssh(:,:,Kbb) = -ssh_ref
- DO jj = 1, jpj
- DO ji = 1, jpi
- IF( ht_0(ji,jj)-ssh_ref < rn_wdmin1 ) THEN ! if total depth is less than min depth
- ssh(ji,jj,Kbb) = rn_wdmin1 - (ht_0(ji,jj) )
- ssh(ji,jj,Kmm) = rn_wdmin1 - (ht_0(ji,jj) )
- ENDIF
- ENDDO
- ENDDO
+ DO_2D( 1, 1, 1, 1 )
+ IF( ht_0(ji,jj)-ssh_ref < rn_wdmin1 ) THEN ! if total depth is less than min depth
+ ssh(ji,jj,Kbb) = rn_wdmin1 - (ht_0(ji,jj) )
+ ssh(ji,jj,Kmm) = rn_wdmin1 - (ht_0(ji,jj) )
+ ENDIF
+ END_2D
ENDIF !If test case else
@@ -935,11 +913,9 @@
e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm)
- DO ji = 1, jpi
- DO jj = 1, jpj
- IF ( ht_0(ji,jj) .LE. 0.0 .AND. NINT( ssmask(ji,jj) ) .EQ. 1) THEN
- CALL ctl_stop( 'dom_vvl_rst: ht_0 must be positive at potentially wet points' )
- ENDIF
- END DO
- END DO
+ DO_2D( 1, 1, 1, 1 )
+ IF ( ht_0(ji,jj) .LE. 0.0 .AND. NINT( ssmask(ji,jj) ) .EQ. 1) THEN
+ CALL ctl_stop( 'dom_vvl_rst: ht_0 must be positive at potentially wet points' )
+ ENDIF
+ END_2D
!
ELSE
@@ -1064,4 +1040,6 @@
END SUBROUTINE dom_vvl_ctl
+#endif
+
!!======================================================================
END MODULE domvvl
Index: /NEMO/branches/2020/r12377_ticket2386/tests/VORTEX/MY_SRC/usrdef_hgr.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/VORTEX/MY_SRC/usrdef_hgr.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/VORTEX/MY_SRC/usrdef_hgr.F90 (revision 13540)
@@ -26,4 +26,6 @@
PUBLIC usr_def_hgr ! called by domhgr.F90
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -61,7 +63,7 @@
REAL(wp), DIMENSION(:,:), INTENT(out) :: pe1e2u, pe1e2v ! u- & v-surfaces (if reduction in strait) [m2]
!
- INTEGER :: ji, jj ! dummy loop indices
+ INTEGER :: ji, jj ! dummy loop indices
REAL(wp) :: zphi0, zlam0, zbeta, zf0
- REAL(wp) :: zti, zui, ztj, zvj ! local scalars
+ REAL(wp) :: zti, ztj ! local scalars
!!-------------------------------------------------------------------------------
!
@@ -75,33 +77,39 @@
! Position coordinates (in kilometers)
! ==========
- zlam0 = -(jpiglo-1)/2 * 1.e-3 * rn_dx
- zphi0 = -(jpjglo-1)/2 * 1.e-3 * rn_dy
-
+#if defined key_agrif
+ IF( Agrif_Root() ) THEN
+#endif
+ ! Compatibility WITH old version:
+ ! jperio = 0 => Ni0glo = jpigo_old_version
+ ! => jpiglo-1 replaced by Ni0glo-1
+ zlam0 = -REAL( (Ni0glo-1)/2, wp) * 1.e-3 * rn_dx
+ zphi0 = -REAL( (Nj0glo-1)/2, wp) * 1.e-3 * rn_dy
#if defined key_agrif
- ! ! let lower left longitude and latitude from parent
- IF (.NOT.Agrif_root()) THEN
- zlam0 = (0.5_wp-(Agrif_parent(jpiglo)-1)/2)*1.e-3*Agrif_irhox()*rn_dx &
- &+(Agrif_Ix()+nbghostcells-1)*Agrif_irhox()*rn_dx*1.e-3-(0.5_wp+nbghostcells)*rn_dx*1.e-3
- zphi0 = (0.5_wp-(Agrif_parent(jpjglo)-1)/2)*1.e-3*Agrif_irhoy()*rn_dy &
- &+(Agrif_Iy()+nbghostcells-1)*Agrif_irhoy()*rn_dy*1.e-3-(0.5_wp+nbghostcells)*rn_dy*1.e-3
+ ELSE
+ ! ! let lower left longitude and latitude from parent
+ ! Compatibility WITH old version:
+ ! jperio = 0 => Ni0glo = jpigo_old_version
+ ! => Agrif_parent(jpiglo)-1 replaced by Agrif_parent(Ni0glo)-1
+ zlam0 = ( 0.5_wp - REAL( ( Agrif_parent(Ni0glo)-1 ) / 2, wp) ) * 1.e-3 * Agrif_irhox() * rn_dx &
+ & + ( Agrif_Ix() + nbghostcells - 1 ) * Agrif_irhox() * rn_dx * 1.e-3 - ( 0.5_wp + nbghostcells ) * rn_dx * 1.e-3
+ zphi0 = ( 0.5_wp - REAL( ( Agrif_parent(Nj0glo)-1 ) / 2, wp) ) * 1.e-3 * Agrif_irhoy() * rn_dy &
+ & + ( Agrif_Iy() + nbghostcells - 1 ) * Agrif_irhoy() * rn_dy * 1.e-3 - ( 0.5_wp + nbghostcells ) * rn_dy * 1.e-3
ENDIF
#endif
- DO jj = 1, jpj
- DO ji = 1, jpi
- zti = FLOAT( ji - 1 + nimpp - 1 ) ; ztj = FLOAT( jj - 1 + njmpp - 1 )
- zui = FLOAT( ji - 1 + nimpp - 1 ) + 0.5_wp ; zvj = FLOAT( jj - 1 + njmpp - 1 ) + 0.5_wp
-
- plamt(ji,jj) = zlam0 + rn_dx * 1.e-3 * zti
- plamu(ji,jj) = zlam0 + rn_dx * 1.e-3 * zui
- plamv(ji,jj) = plamt(ji,jj)
- plamf(ji,jj) = plamu(ji,jj)
-
- pphit(ji,jj) = zphi0 + rn_dy * 1.e-3 * ztj
- pphiv(ji,jj) = zphi0 + rn_dy * 1.e-3 * zvj
- pphiu(ji,jj) = pphit(ji,jj)
- pphif(ji,jj) = pphiv(ji,jj)
- END DO
- END DO
+ DO_2D( 1, 1, 1, 1 )
+ zti = REAL( mig0_oldcmp(ji) - 1, wp ) ! start at i=0 in the global grid without halos
+ ztj = REAL( mjg0_oldcmp(jj) - 1, wp ) ! start at j=0 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 )
+ plamv(ji,jj) = plamt(ji,jj)
+ plamf(ji,jj) = plamu(ji,jj)
+
+ pphit(ji,jj) = zphi0 + rn_dy * 1.e-3 * ztj
+ pphiv(ji,jj) = zphi0 + rn_dy * 1.e-3 * ( ztj + 0.5_wp )
+ pphiu(ji,jj) = pphit(ji,jj)
+ pphif(ji,jj) = pphiv(ji,jj)
+ END_2D
!
! Horizontal scale factors (in meters)
Index: /NEMO/branches/2020/r12377_ticket2386/tests/VORTEX/MY_SRC/usrdef_istate.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/VORTEX/MY_SRC/usrdef_istate.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/VORTEX/MY_SRC/usrdef_istate.F90 (revision 13540)
@@ -28,4 +28,6 @@
PUBLIC usr_def_istate ! called by istate.F90
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -73,29 +75,25 @@
! Sea level:
za = -zP0 * (1._wp-EXP(-zH)) / (grav*(zH-1._wp + EXP(-zH)))
- DO ji=1, jpi
- DO jj=1, jpj
- zx = glamt(ji,jj) * 1.e3
- zy = gphit(ji,jj) * 1.e3
- zrho1 = rho0 + za * EXP(-(zx**2+zy**2)/zlambda**2)
- pssh(ji,jj) = zP0 * EXP(-(zx**2+zy**2)/zlambda**2)/(zrho1*grav) * ptmask(ji,jj,1)
- END DO
- END DO
+ DO_2D( 1, 1, 1, 1 )
+ zx = glamt(ji,jj) * 1.e3
+ zy = gphit(ji,jj) * 1.e3
+ zrho1 = rho0 + za * EXP(-(zx**2+zy**2)/zlambda**2)
+ pssh(ji,jj) = zP0 * EXP(-(zx**2+zy**2)/zlambda**2)/(zrho1*grav) * ptmask(ji,jj,1)
+ END_2D
!
! temperature:
- DO ji=1, jpi
- DO jj=1, jpj
- zx = glamt(ji,jj) * 1.e3
- zy = gphit(ji,jj) * 1.e3
- DO jk=1,jpk
- zdt = pdept(ji,jj,jk)
- zrho1 = rho0 * (1._wp + zn2*zdt/grav)
- IF (zdt < zH) THEN
- zrho1 = zrho1 - zP0 * (1._wp-EXP(zdt-zH)) &
- & * EXP(-(zx**2+zy**2)/zlambda**2) / (grav*(zH -1._wp + exp(-zH)));
- ENDIF
- pts(ji,jj,jk,jp_tem) = (20._wp + (rho0-zrho1) / 0.28_wp) * ptmask(ji,jj,jk)
- END DO
+ DO_2D( 1, 1, 1, 1 )
+ zx = glamt(ji,jj) * 1.e3
+ zy = gphit(ji,jj) * 1.e3
+ DO jk=1,jpk
+ zdt = pdept(ji,jj,jk)
+ zrho1 = rho0 * (1._wp + zn2*zdt/grav)
+ IF (zdt < zH) THEN
+ zrho1 = zrho1 - zP0 * (1._wp-EXP(zdt-zH)) &
+ & * EXP(-(zx**2+zy**2)/zlambda**2) / (grav*(zH -1._wp + EXP(-zH)));
+ ENDIF
+ pts(ji,jj,jk,jp_tem) = (20._wp + (rho0-zrho1) / 0.28_wp) * ptmask(ji,jj,jk)
END DO
- END DO
+ END_2D
!
! salinity:
@@ -104,38 +102,33 @@
! velocities:
za = 2._wp * zP0 / (zf0 * rho0 * zlambda**2)
- DO ji=1, jpim1
- DO jj=1, jpj
- zx = glamu(ji,jj) * 1.e3
- zy = gphiu(ji,jj) * 1.e3
- DO jk=1, jpk
- zdu = 0.5_wp * (pdept(ji ,jj,jk) + pdept(ji+1,jj,jk))
- IF (zdu < zH) THEN
- zf = (zH-1._wp-zdu+EXP(zdu-zH)) / (zH-1._wp+EXP(-zH))
- pu(ji,jj,jk) = (za * zf * zy * EXP(-(zx**2+zy**2)/zlambda**2)) * ptmask(ji,jj,jk) * ptmask(ji+1,jj,jk)
- ELSE
- pu(ji,jj,jk) = 0._wp
- ENDIF
- END DO
+ DO_2D( 0, 0, 0, 0 )
+ zx = glamu(ji,jj) * 1.e3
+ zy = gphiu(ji,jj) * 1.e3
+ DO jk=1, jpk
+ zdu = 0.5_wp * (pdept(ji ,jj,jk) + pdept(ji+1,jj,jk))
+ IF (zdu < zH) THEN
+ zf = (zH-1._wp-zdu+EXP(zdu-zH)) / (zH-1._wp+EXP(-zH))
+ pu(ji,jj,jk) = (za * zf * zy * EXP(-(zx**2+zy**2)/zlambda**2)) * ptmask(ji,jj,jk) * ptmask(ji+1,jj,jk)
+ ELSE
+ pu(ji,jj,jk) = 0._wp
+ ENDIF
END DO
- END DO
+ END_2D
!
- DO ji=1, jpi
- DO jj=1, jpjm1
- zx = glamv(ji,jj) * 1.e3
- zy = gphiv(ji,jj) * 1.e3
- DO jk=1, jpk
- zdv = 0.5_wp * (pdept(ji ,jj,jk) + pdept(ji,jj+1,jk))
- IF (zdv < zH) THEN
- zf = (zH-1._wp-zdv+EXP(zdv-zH)) / (zH-1._wp+EXP(-zH))
- pv(ji,jj,jk) = -(za * zf * zx * EXP(-(zx**2+zy**2)/zlambda**2)) * ptmask(ji,jj,jk) * ptmask(ji,jj+1,jk)
- ELSE
- pv(ji,jj,jk) = 0._wp
- ENDIF
- END DO
+ DO_2D( 0, 0, 0, 0 )
+ zx = glamv(ji,jj) * 1.e3
+ zy = gphiv(ji,jj) * 1.e3
+ DO jk=1, jpk
+ zdv = 0.5_wp * (pdept(ji ,jj,jk) + pdept(ji,jj+1,jk))
+ IF (zdv < zH) THEN
+ zf = (zH-1._wp-zdv+EXP(zdv-zH)) / (zH-1._wp+EXP(-zH))
+ pv(ji,jj,jk) = -(za * zf * zx * EXP(-(zx**2+zy**2)/zlambda**2)) * ptmask(ji,jj,jk) * ptmask(ji,jj+1,jk)
+ ELSE
+ pv(ji,jj,jk) = 0._wp
+ ENDIF
END DO
- END DO
-
- CALL lbc_lnk( 'usrdef_istate', pu, 'U', -1. )
- CALL lbc_lnk( 'usrdef_istate', pv, 'V', -1. )
+ END_2D
+ !
+ CALL lbc_lnk_multi( 'usrdef_istate', pu, 'U', -1., pv, 'V', -1. )
!
END SUBROUTINE usr_def_istate
Index: /NEMO/branches/2020/r12377_ticket2386/tests/VORTEX/MY_SRC/usrdef_nam.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/VORTEX/MY_SRC/usrdef_nam.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/VORTEX/MY_SRC/usrdef_nam.F90 (revision 13540)
@@ -14,5 +14,5 @@
!! usr_def_hgr : initialize the horizontal mesh
!!----------------------------------------------------------------------
- USE dom_oce , ONLY: nimpp , njmpp ! i- & j-indices of the local domain
+ USE dom_oce
USE par_oce ! ocean space and time domain
USE phycst ! physical constants
@@ -84,7 +84,9 @@
kpi = NINT( 1800.e3 / rn_dx ) + 3
kpj = NINT( 1800.e3 / rn_dy ) + 3
- ELSE
- kpi = nbcellsx + 2 + 2*nbghostcells
- kpj = nbcellsy + 2 + 2*nbghostcells
+ ELSE ! Global Domain size: add nbghostcells + 1 "land" point on each side
+ kpi = nbcellsx + 2 * ( nbghostcells + 1 )
+ kpj = nbcellsy + 2 * ( nbghostcells + 1 )
+!!$ kpi = nbcellsx + nbghostcells_x + nbghostcells_x + 2
+!!$ kpj = nbcellsy + nbghostcells_y_s + nbghostcells_y_n + 2
ENDIF
kpk = NINT( 5000._wp / rn_dz ) + 1
@@ -104,4 +106,7 @@
WRITE(numout,*) ' horizontal resolution rn_dy = ', rn_dy, ' m'
WRITE(numout,*) ' vertical resolution rn_dz = ', rn_dz, ' m'
+ WRITE(numout,*) ' resulting global domain size : Ni0glo = ', kpi
+ WRITE(numout,*) ' Nj0glo = ', kpj
+ WRITE(numout,*) ' jpkglo = ', kpk
WRITE(numout,*) ' VORTEX domain: '
WRITE(numout,*) ' LX [km]: ', zlx
Index: /NEMO/branches/2020/r12377_ticket2386/tests/VORTEX/MY_SRC/usrdef_zgr.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/VORTEX/MY_SRC/usrdef_zgr.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/VORTEX/MY_SRC/usrdef_zgr.F90 (revision 13540)
@@ -192,5 +192,5 @@
CALL lbc_lnk( 'usrdef_zgr', z2d, 'T', 1. ) ! set surrounding land to zero (here jperio=0 ==>> closed)
!
- k_bot(:,:) = INT( z2d(:,:) ) ! =jpkm1 over the ocean point, =0 elsewhere
+ k_bot(:,:) = NINT( z2d(:,:) ) ! =jpkm1 over the ocean point, =0 elsewhere
!
k_top(:,:) = MIN( 1 , k_bot(:,:) ) ! = 1 over the ocean point, =0 elsewhere
Index: /NEMO/branches/2020/r12377_ticket2386/tests/WAD/EXPREF/context_nemo.xml
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/WAD/EXPREF/context_nemo.xml (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/WAD/EXPREF/context_nemo.xml (revision 13540)
@@ -11,5 +11,5 @@
01
01
- 1026.0
+ 1026.0
3991.86795711963
0.99530670233846
Index: /NEMO/branches/2020/r12377_ticket2386/tests/WAD/EXPREF/namelist_cfg
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/WAD/EXPREF/namelist_cfg (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/WAD/EXPREF/namelist_cfg (revision 13540)
@@ -200,6 +200,6 @@
!! !!
!! namdrg top/bottom drag coefficient (default: NO selection)
-!! namdrg_top top friction (ln_OFF=F & ln_isfcav=T)
-!! namdrg_bot bottom friction (ln_OFF=F)
+!! 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)
@@ -253,5 +253,5 @@
!
! ! S-EOS coefficients (ln_seos=T):
- ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
+ ! ! rd(T,S,Z)*rho0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
rn_a0 = 1.6550e-1 ! thermal expension coefficient (nn_eos= 1)
rn_b0 = 7.6554e-1 ! saline expension coefficient (nn_eos= 1)
@@ -263,5 +263,5 @@
!!org GYRE rn_alpha = 2.0e-4 ! thermal expension coefficient (nn_eos= 1 or 2)
!!org GYRE rn_beta = 7.7e-4 ! saline expension coefficient (nn_eos= 2)
-!!org caution now a0 = alpha / rau0 with rau0 = 1026
+!!org caution now a0 = alpha / rho0 with rho0 = 1026
/
!-----------------------------------------------------------------------
Index: /NEMO/branches/2020/r12377_ticket2386/tests/WAD/MY_SRC/usrdef_hgr.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/WAD/MY_SRC/usrdef_hgr.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/WAD/MY_SRC/usrdef_hgr.F90 (revision 13540)
@@ -13,5 +13,5 @@
!! usr_def_hgr : initialize the horizontal mesh for WAD_TEST_CASES configuration
!!----------------------------------------------------------------------
- USE dom_oce , ONLY: nimpp, njmpp ! ocean space and time domain
+ USE dom_oce
USE par_oce ! ocean space and time domain
USE phycst ! physical constants
@@ -26,4 +26,6 @@
PUBLIC usr_def_hgr ! called by domhgr.F90
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -72,17 +74,16 @@
! !== grid point position ==! (in kilometers)
zfact = rn_dx * 1.e-3 ! conversion in km
- DO jj = 1, jpj
- DO ji = 1, jpi ! longitude
- plamt(ji,jj) = zfact * ( - 0.5 + REAL( ji-1 + nimpp-1 , wp ) )
- plamu(ji,jj) = zfact * ( REAL( ji-1 + nimpp-1 , wp ) )
- plamv(ji,jj) = plamt(ji,jj)
- plamf(ji,jj) = plamu(ji,jj)
- ! ! latitude
- pphit(ji,jj) = zfact * ( - 0.5 + REAL( jj-1 + njmpp-1 , wp ) )
- pphiu(ji,jj) = pphit(ji,jj)
- pphiv(ji,jj) = zfact * ( REAL( jj-1 + njmpp-1 , wp ) )
- pphif(ji,jj) = pphiv(ji,jj)
- END DO
- END DO
+ DO_2D( 1, 1, 1, 1 )
+ ! ! longitude
+ plamt(ji,jj) = zfact * ( - 0.5 + REAL( mig0_oldcmp(ji)-1 , wp ) )
+ plamu(ji,jj) = zfact * ( REAL( mig0_oldcmp(ji)-1 , wp ) )
+ plamv(ji,jj) = plamt(ji,jj)
+ plamf(ji,jj) = plamu(ji,jj)
+ ! ! latitude
+ pphit(ji,jj) = zfact * ( - 0.5 + REAL( mjg0_oldcmp(jj)-1 , wp ) )
+ pphiu(ji,jj) = pphit(ji,jj)
+ pphiv(ji,jj) = zfact * ( REAL( mjg0_oldcmp(jj)-1 , wp ) )
+ pphif(ji,jj) = pphiv(ji,jj)
+ END_2D
!
! !== Horizontal scale factors ==! (in meters)
Index: /NEMO/branches/2020/r12377_ticket2386/tests/WAD/MY_SRC/usrdef_istate.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/WAD/MY_SRC/usrdef_istate.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/WAD/MY_SRC/usrdef_istate.F90 (revision 13540)
@@ -26,4 +26,6 @@
PUBLIC usr_def_istate ! called in istate.F90
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -174,11 +176,9 @@
! Apply minimum wetdepth criterion
!
- do jj = 1,jpj
- do ji = 1,jpi
- IF( ht_0(ji,jj) + pssh(ji,jj) < rn_wdmin1 ) THEN
- pssh(ji,jj) = ptmask(ji,jj,1)*( rn_wdmin1 - ht_0(ji,jj) )
- ENDIF
- end do
- end do
+ DO_2D( 1, 1, 1, 1 )
+ IF( ht_0(ji,jj) + pssh(ji,jj) < rn_wdmin1 ) THEN
+ pssh(ji,jj) = ptmask(ji,jj,1)*( rn_wdmin1 - ht_0(ji,jj) )
+ ENDIF
+ END_2D
!
END SUBROUTINE usr_def_istate
Index: /NEMO/branches/2020/r12377_ticket2386/tests/WAD/MY_SRC/usrdef_nam.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/WAD/MY_SRC/usrdef_nam.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/WAD/MY_SRC/usrdef_nam.F90 (revision 13540)
@@ -14,5 +14,4 @@
!! usr_def_hgr : initialize the horizontal mesh
!!----------------------------------------------------------------------
- USE dom_oce , ONLY: nimpp , njmpp ! i- & j-indices of the local domain
USE par_oce ! ocean space and time domain
USE phycst ! physical constants
@@ -77,5 +76,9 @@
! ! Set the lateral boundary condition of the global domain
kperio = 0 ! WAD_TEST_CASES configuration : closed domain
- IF( nn_wad_test == 8 ) kperio = 7 ! North-South cyclic test
+ IF( nn_wad_test == 8 ) THEN
+ kperio = 7 ! North-South cyclic test
+ kpi = kpi - 2 ! no closed boundary
+ kpj = kpj - 2 ! no closed boundary
+ ENDIF
!
! ! control print
Index: /NEMO/branches/2020/r12377_ticket2386/tests/WAD/MY_SRC/usrdef_zgr.F90
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/WAD/MY_SRC/usrdef_zgr.F90 (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/WAD/MY_SRC/usrdef_zgr.F90 (revision 13540)
@@ -15,6 +15,5 @@
!!---------------------------------------------------------------------
USE oce ! ocean variables
- USE dom_oce , ONLY: ht_0, mi0, mi1, nimpp, njmpp, &
- & mj0, mj1, glamt, gphit ! ocean space and time domain
+ USE dom_oce , ONLY: ht_0, mi0, mi1, mj0, mj1, glamt, gphit ! 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
@@ -29,4 +28,6 @@
PUBLIC usr_def_zgr ! called by domzgr.F90
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -242,7 +243,7 @@
! at v-point: averaging zht
zhv = 0._wp
- DO jj = 1, jpjm1
- zhv(:,jj) = 0.5_wp * ( zht(:,jj) + zht(:,jj+1) )
- END DO
+ DO_2D( 0, 0, 0, 0 )
+ 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
@@ -279,34 +280,30 @@
ht_0 = zht
k_bot(:,:) = jpkm1 * k_top(:,:) !* bottom ocean = jpk-1 (here use k_top as a land mask)
- DO jj = 1, jpj
- DO ji = 1, jpi
- IF( zht(ji,jj) <= -(rn_wdld - rn_wdmin2)) THEN
- k_bot(ji,jj) = 0
- k_top(ji,jj) = 0
- ENDIF
- END DO
- END DO
+ DO_2D( 1, 1, 1, 1 )
+ IF( zht(ji,jj) <= -(rn_wdld - rn_wdmin2)) THEN
+ k_bot(ji,jj) = 0
+ k_top(ji,jj) = 0
+ ENDIF
+ END_2D
!
! !* terrain-following coordinate with e3.(k)=cst)
! ! OVERFLOW case : identical with j-index (T=V, U=F)
- DO jj = 1, jpjm1
- DO ji = 1, jpim1
- z1_jpkm1 = 1._wp / REAL( k_bot(ji,jj) - k_top(ji,jj) + 1 , wp)
- DO jk = 1, jpk
- zwet = MAX( zht(ji,jj), rn_wdmin1 )
- pdept(ji,jj,jk) = zwet * z1_jpkm1 * ( REAL( jk , wp ) - 0.5_wp )
- pdepw(ji,jj,jk) = zwet * z1_jpkm1 * ( REAL( jk-1 , wp ) )
- pe3t (ji,jj,jk) = zwet * z1_jpkm1
- pe3w (ji,jj,jk) = zwet * z1_jpkm1
- zwet = MAX( zhu(ji,jj), rn_wdmin1 )
- pe3u (ji,jj,jk) = zwet * z1_jpkm1
- pe3uw(ji,jj,jk) = zwet * z1_jpkm1
- pe3f (ji,jj,jk) = zwet * z1_jpkm1
- zwet = MAX( zhv(ji,jj), rn_wdmin1 )
- pe3v (ji,jj,jk) = zwet * z1_jpkm1
- pe3vw(ji,jj,jk) = zwet * z1_jpkm1
- END DO
- END DO
- END DO
+ DO_2D( 0, 0, 0, 0 )
+ z1_jpkm1 = 1._wp / REAL( k_bot(ji,jj) - k_top(ji,jj) + 1 , wp)
+ DO jk = 1, jpk
+ zwet = MAX( zht(ji,jj), rn_wdmin1 )
+ pdept(ji,jj,jk) = zwet * z1_jpkm1 * ( REAL( jk , wp ) - 0.5_wp )
+ pdepw(ji,jj,jk) = zwet * z1_jpkm1 * ( REAL( jk-1 , wp ) )
+ pe3t (ji,jj,jk) = zwet * z1_jpkm1
+ pe3w (ji,jj,jk) = zwet * z1_jpkm1
+ zwet = MAX( zhu(ji,jj), rn_wdmin1 )
+ pe3u (ji,jj,jk) = zwet * z1_jpkm1
+ pe3uw(ji,jj,jk) = zwet * z1_jpkm1
+ pe3f (ji,jj,jk) = zwet * z1_jpkm1
+ zwet = MAX( zhv(ji,jj), rn_wdmin1 )
+ pe3v (ji,jj,jk) = zwet * z1_jpkm1
+ pe3vw(ji,jj,jk) = zwet * z1_jpkm1
+ END DO
+ END_2D
CALL lbc_lnk( 'usrdef_zgr', pdept, 'T', 1. )
CALL lbc_lnk( 'usrdef_zgr', pdepw, 'T', 1. )
Index: /NEMO/branches/2020/r12377_ticket2386/tests/demo_cfgs.txt
===================================================================
--- /NEMO/branches/2020/r12377_ticket2386/tests/demo_cfgs.txt (revision 13539)
+++ /NEMO/branches/2020/r12377_ticket2386/tests/demo_cfgs.txt (revision 13540)
@@ -11,2 +11,3 @@
BENCH OCE ICE TOP
STATION_ASF OCE
+CPL_OASIS OCE TOP ICE NST