Changeset 13286
- Timestamp:
- 2020-07-09T17:48:29+02:00 (4 years ago)
- Location:
- NEMO/trunk
- Files:
-
- 2 deleted
- 199 edited
- 2 copied
Legend:
- Unmodified
- Added
- Removed
-
NEMO/trunk
- Property svn:externals
-
old new 2 2 ^/utils/build/makenemo@HEAD makenemo 3 3 ^/utils/build/mk@HEAD mk 4 ^/utils/tools /@HEADtools4 ^/utils/tools@HEAD tools 5 5 ^/vendors/AGRIF/dev_r12970_AGRIF_CMEMS ext/AGRIF 6 6 ^/vendors/FCM@HEAD ext/FCM … … 8 8 9 9 # SETTE 10 ^/utils/CI/ sette@12931sette10 ^/utils/CI/r12931_sette_ticket2366@HEAD sette
-
- Property svn:externals
-
NEMO/trunk/cfgs/AGRIF_DEMO/EXPREF/AGRIF_FixedGrids.in
r9770 r13286 1 1 2 2 4 2 8249 91 1 1 13 12 2 153110 143 4 4 42 41 81 49 91 1 1 1 3 121 152 110 143 4 4 4 4 4 0 5 5 1 -
NEMO/trunk/cfgs/AGRIF_DEMO/EXPREF/namelist_cfg
r13208 r13286 33 33 / 34 34 !----------------------------------------------------------------------- 35 &namcfg ! parameters of the configuration (default: use r defined GYRE)35 &namcfg ! parameters of the configuration (default: use namusr_def in namelist_cfg) 36 36 !----------------------------------------------------------------------- 37 37 ln_read_cfg = .true. ! (=T) read the domain configuration file … … 42 42 / 43 43 !----------------------------------------------------------------------- 44 &namtsd ! Temperature & Salinity Data 44 &namtsd ! Temperature & Salinity Data (init/dmp) (default: OFF) 45 45 !----------------------------------------------------------------------- 46 46 ! ! =T read T-S fields for: … … 63 63 !! namsbc_cpl CouPLed formulation ("key_oasis3" ) 64 64 !! namsbc_sas Stand-Alone Surface module (SAS_SRC only) 65 !! namsbc_iif Ice-IF: use observed ice cover (nn_ice = 1 ) 65 66 !! namtra_qsr penetrative solar radiation (ln_traqsr =T) 67 !! namsbc_ssr sea surface restoring term (for T and/or S) (ln_ssr =T) 66 68 !! namsbc_rnf river runoffs (ln_rnf =T) 69 !! namsbc_apr Atmospheric Pressure (ln_apr_dyn =T) 67 70 !! namsbc_isf ice shelf melting/freezing (ln_isfcav =T : read (ln_read_cfg=T) or set or usr_def_zgr ) 68 71 !! namsbc_iscpl coupling option between land ice model and ocean (ln_isfcav =T) 69 !! namsbc_apr Atmospheric Pressure (ln_apr_dyn =T)70 !! namsbc_ssr sea surface restoring term (for T and/or S) (ln_ssr =T)71 72 !! namsbc_wave external fields from wave model (ln_wave =T) 72 73 !! namberg iceberg floats (ln_icebergs=T) … … 74 75 ! 75 76 !----------------------------------------------------------------------- 76 &namsbc ! Surface Boundary Condition (surface module)77 &namsbc ! Surface Boundary Condition manager (default: NO selection) 77 78 !----------------------------------------------------------------------- 78 79 nn_fsbc = 1 ! frequency of SBC module call … … 86 87 ! Misc. options of sbc : 87 88 ln_traqsr = .true. ! Light penetration in the ocean (T => fill namtra_qsr) 89 ln_ssr = .true. ! Sea Surface Restoring on T and/or S (T => fill namsbc_ssr) 88 90 ln_rnf = .true. ! runoffs (T => fill namsbc_rnf) 89 ln_ssr = .true. ! Sea Surface Restoring on T and/or S (T => fill namsbc_ssr)90 91 nn_fwb = 0 ! FreshWater Budget: =0 unchecked 91 92 / 92 93 !----------------------------------------------------------------------- 93 &namsbc_blk ! namsbc_blk generic Bulk formula(ln_blk =T)94 &namsbc_blk ! namsbc_blk generic Bulk formula (ln_blk =T) 94 95 !----------------------------------------------------------------------- 95 96 ! ! bulk algorithm : 96 ln_NCAR = .true. ! "NCAR" algorithm (Large and Yeager 2008) 97 ! 97 ln_NCAR = .true. ! "NCAR" algorithm (Large and Yeager 2008) 98 98 cn_dir = './' ! root directory for the bulk data location 99 99 !___________!_________________________!___________________!___________!_____________!________!___________!______________________________________!__________!_______________! 100 100 ! ! file name ! frequency (hours) ! variable ! time interp.! clim ! 'yearly'/ ! weights filename ! rotation ! land/sea mask ! 101 101 ! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! ! pairing ! filename ! 102 sn_wndi = 'u_10.15JUNE2009_fill' , 6. , 'U_10_MOD', .false. , .true. , 'yearly' , 'weights_core _orca2_bicubic_noc.nc' , 'Uwnd' , ''103 sn_wndj = 'v_10.15JUNE2009_fill' , 6. , 'V_10_MOD', .false. , .true. , 'yearly' , 'weights_core _orca2_bicubic_noc.nc' , 'Vwnd' , ''104 sn_qsr = 'ncar_rad.15JUNE2009_fill' , 24. , 'SWDN_MOD', .false. , .true. , 'yearly' , 'weights_core _orca2_bilinear_noc.nc' , '' , ''105 sn_qlw = 'ncar_rad.15JUNE2009_fill' , 24. , 'LWDN_MOD', .false. , .true. , 'yearly' , 'weights_core _orca2_bilinear_noc.nc' , '' , ''106 sn_tair = 't_10.15JUNE2009_fill' , 6. , 'T_10_MOD', .false. , .true. , 'yearly' , 'weights_core _orca2_bilinear_noc.nc' , '' , ''107 sn_humi = 'q_10.15JUNE2009_fill' , 6. , 'Q_10_MOD', .false. , .true. , 'yearly' , 'weights_core _orca2_bilinear_noc.nc' , '' , ''108 sn_prec = 'ncar_precip.15JUNE2009_fill', -1. , 'PRC_MOD1', .false. , .true. , 'yearly' , 'weights_core _orca2_bilinear_noc.nc' , '' , ''109 sn_snow = 'ncar_precip.15JUNE2009_fill', -1. , 'SNOW' , .false. , .true. , 'yearly' , 'weights_core _orca2_bilinear_noc.nc' , '' , ''110 sn_slp = 'slp.15JUNE2009_fill' , 6. , 'SLP' , .false. , .true. , 'yearly' , 'weights_core _orca2_bilinear_noc.nc' , '' , ''102 sn_wndi = 'u_10.15JUNE2009_fill' , 6. , 'U_10_MOD', .false. , .true. , 'yearly' , 'weights_core2_orca2_bicub' , 'Uwnd' , '' 103 sn_wndj = 'v_10.15JUNE2009_fill' , 6. , 'V_10_MOD', .false. , .true. , 'yearly' , 'weights_core2_orca2_bicub' , 'Vwnd' , '' 104 sn_qsr = 'ncar_rad.15JUNE2009_fill' , 24. , 'SWDN_MOD', .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , '' 105 sn_qlw = 'ncar_rad.15JUNE2009_fill' , 24. , 'LWDN_MOD', .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , '' 106 sn_tair = 't_10.15JUNE2009_fill' , 6. , 'T_10_MOD', .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , '' 107 sn_humi = 'q_10.15JUNE2009_fill' , 6. , 'Q_10_MOD', .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , '' 108 sn_prec = 'ncar_precip.15JUNE2009_fill', -1. , 'PRC_MOD1', .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , '' 109 sn_snow = 'ncar_precip.15JUNE2009_fill', -1. , 'SNOW' , .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , '' 110 sn_slp = 'slp.15JUNE2009_fill' , 6. , 'SLP' , .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , '' 111 111 / 112 112 !----------------------------------------------------------------------- … … 125 125 / 126 126 !----------------------------------------------------------------------- 127 &namsbc_ssr ! surface boundary condition : sea surface restoring (ln_ssr =T) 128 !----------------------------------------------------------------------- 129 nn_sssr = 2 ! add a damping term to the surface freshwater flux 130 rn_deds = -166.67 ! magnitude of the damping on salinity [mm/day] 131 ln_sssr_bnd = .true. ! flag to bound erp term (associated with nn_sssr=2) 132 rn_sssr_bnd = 4.e0 ! ABS(Max/Min) value of the damping erp term [mm/day] 133 / 134 !----------------------------------------------------------------------- 127 135 &namsbc_rnf ! runoffs (ln_rnf =T) 128 136 !----------------------------------------------------------------------- … … 130 138 rn_hrnf = 15.e0 ! depth over which enhanced vertical mixing is used (ln_rnf_mouth=T) 131 139 rn_avt_rnf = 1.e-3 ! value of the additional vertical mixing coef. [m2/s] (ln_rnf_mouth=T) 140 rn_rfact = 1.e0 ! multiplicative factor for runoff 132 141 133 142 cn_dir = './' ! root directory for the location of the runoff files … … 142 151 / 143 152 !----------------------------------------------------------------------- 144 &namsbc_ssr ! surface boundary condition : sea surface restoring (ln_ssr =T) 145 !----------------------------------------------------------------------- 146 nn_sssr = 2 ! add a damping term to the surface freshwater flux 147 rn_deds = -166.67 ! magnitude of the damping on salinity [mm/day] 148 ln_sssr_bnd = .true. ! flag to bound erp term (associated with nn_sssr=2) 149 rn_sssr_bnd = 4.e0 ! ABS(Max/Min) value of the damping erp term [mm/day] 150 / 151 !----------------------------------------------------------------------- 152 &namberg ! iceberg parameters (default: No iceberg) 153 &namsbc_wave ! External fields from wave model (ln_wave=T) 154 !----------------------------------------------------------------------- 155 / 156 !----------------------------------------------------------------------- 157 &namberg ! iceberg parameters (default: OFF) 153 158 !----------------------------------------------------------------------- 154 159 ! iceberg floats are not currently available with AGRIF … … 159 164 !! !! 160 165 !! namlbc lateral momentum boundary condition (default: NO selection) 161 !! namagrif agrif nested grid ( read by child model only) ("key_agrif")166 !! namagrif agrif nested grid (read by child model only) ("key_agrif") 162 167 !! nam_tide Tidal forcing (default: OFF) 163 168 !! nambdy Unstructured open boundaries (default: OFF) … … 212 217 / 213 218 !!====================================================================== 214 !! Tracer (T & S) namelists!!219 !! Tracer (T-S) namelists !! 215 220 !! !! 216 221 !! nameos equation of state (default: NO selection) … … 233 238 nn_fct_h = 2 ! =2/4, horizontal 2nd / 4th order 234 239 nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order 235 /236 !-----------------------------------------------------------------------237 &namtra_mle ! mixed layer eddy parametrisation (Fox-Kemper) (default: OFF)238 !-----------------------------------------------------------------------239 ln_mle = .true. ! (T) use the Mixed Layer Eddy (MLE) parameterisation240 240 / 241 241 !----------------------------------------------------------------------- … … 255 255 / 256 256 !----------------------------------------------------------------------- 257 &namtra_eiv ! eddy induced velocity param. (default: OFF) 258 !----------------------------------------------------------------------- 259 ln_ldfeiv =.true. ! use eddy induced velocity parameterization 257 &namtra_mle ! mixed layer eddy parametrisation (Fox-Kemper) (default: OFF) 258 !----------------------------------------------------------------------- 259 ln_mle = .true. ! (T) use the Mixed Layer Eddy (MLE) parameterisation 260 / 261 !----------------------------------------------------------------------- 262 &namtra_eiv ! eddy induced velocity param. (default: OFF) 263 !----------------------------------------------------------------------- 264 ln_ldfeiv = .true. ! use eddy induced velocity parameterization 260 265 ! ! Coefficients: 261 266 nn_aei_ijk_t = 21 ! space/time variation of the eiv coeficient … … 286 291 ! 287 292 !----------------------------------------------------------------------- 288 &nam_vvl ! vertical coordinate options (default: z-star)289 !-----------------------------------------------------------------------290 /291 !-----------------------------------------------------------------------292 293 &namdyn_adv ! formulation of the momentum advection (default: NO selection) 293 294 !----------------------------------------------------------------------- … … 334 335 ! 335 336 !----------------------------------------------------------------------- 336 &namzdf ! vertical physics 337 &namzdf ! vertical physics manager (default: NO selection) 337 338 !----------------------------------------------------------------------- 338 339 ! ! type of vertical closure … … 384 385 !!====================================================================== 385 386 ! 386 !387 387 !----------------------------------------------------------------------- 388 388 &nammpp ! Massively Parallel Processing ("key_mpp_mpi") -
NEMO/trunk/cfgs/ORCA2_ICE_PISCES/EXPREF/namelist_cfg
r13214 r13286 110 110 ! ! file name ! frequency (hours) ! variable ! time interp.! clim ! 'yearly'/ ! weights filename ! rotation ! land/sea mask ! 111 111 ! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! ! pairing ! filename ! 112 sn_wndi = 'u_10.15JUNE2009_fill' , 6. , 'U_10_MOD', .false. , .true. , 'yearly' , 'weights_core _orca2_bicubic_noc.nc' , 'Uwnd' , ''113 sn_wndj = 'v_10.15JUNE2009_fill' , 6. , 'V_10_MOD', .false. , .true. , 'yearly' , 'weights_core _orca2_bicubic_noc.nc' , 'Vwnd' , ''114 sn_qsr = 'ncar_rad.15JUNE2009_fill' , 24. , 'SWDN_MOD', .false. , .true. , 'yearly' , 'weights_core _orca2_bilinear_noc.nc' , '' , ''115 sn_qlw = 'ncar_rad.15JUNE2009_fill' , 24. , 'LWDN_MOD', .false. , .true. , 'yearly' , 'weights_core _orca2_bilinear_noc.nc' , '' , ''116 sn_tair = 't_10.15JUNE2009_fill' , 6. , 'T_10_MOD', .false. , .true. , 'yearly' , 'weights_core _orca2_bilinear_noc.nc' , '' , ''117 sn_humi = 'q_10.15JUNE2009_fill' , 6. , 'Q_10_MOD', .false. , .true. , 'yearly' , 'weights_core _orca2_bilinear_noc.nc' , '' , ''118 sn_prec = 'ncar_precip.15JUNE2009_fill', -1. , 'PRC_MOD1', .false. , .true. , 'yearly' , 'weights_core _orca2_bilinear_noc.nc' , '' , ''119 sn_snow = 'ncar_precip.15JUNE2009_fill', -1. , 'SNOW' , .false. , .true. , 'yearly' , 'weights_core _orca2_bilinear_noc.nc' , '' , ''120 sn_slp = 'slp.15JUNE2009_fill' , 6. , 'SLP' , .false. , .true. , 'yearly' , 'weights_core _orca2_bilinear_noc.nc' , '' , ''112 sn_wndi = 'u_10.15JUNE2009_fill' , 6. , 'U_10_MOD', .false. , .true. , 'yearly' , 'weights_core2_orca2_bicub' , 'Uwnd' , '' 113 sn_wndj = 'v_10.15JUNE2009_fill' , 6. , 'V_10_MOD', .false. , .true. , 'yearly' , 'weights_core2_orca2_bicub' , 'Vwnd' , '' 114 sn_qsr = 'ncar_rad.15JUNE2009_fill' , 24. , 'SWDN_MOD', .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , '' 115 sn_qlw = 'ncar_rad.15JUNE2009_fill' , 24. , 'LWDN_MOD', .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , '' 116 sn_tair = 't_10.15JUNE2009_fill' , 6. , 'T_10_MOD', .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , '' 117 sn_humi = 'q_10.15JUNE2009_fill' , 6. , 'Q_10_MOD', .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , '' 118 sn_prec = 'ncar_precip.15JUNE2009_fill', -1. , 'PRC_MOD1', .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , '' 119 sn_snow = 'ncar_precip.15JUNE2009_fill', -1. , 'SNOW' , .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , '' 120 sn_slp = 'slp.15JUNE2009_fill' , 6. , 'SLP' , .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , '' 121 121 / 122 122 !----------------------------------------------------------------------- … … 391 391 ! ! file name ! frequency (hours) ! variable ! time interp.! clim ! 'yearly'/ ! weights filename ! rotation ! land/sea mask ! 392 392 ! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! ! pairing ! filename ! 393 sn_mpb = ' mixing_power_bot' , -12 , 'field' , .false. , .true. , 'yearly' , '' , '' , ''394 sn_mpp = ' mixing_power_pyc' , -12 , 'field' , .false. , .true. , 'yearly' , '' , '' , ''395 sn_mpc = ' mixing_power_cri' , -12 , 'field' , .false. , .true. , 'yearly' , '' , '' , ''396 sn_dsb = ' decay_scale_bot' , -12 , 'field', .false. , .true. , 'yearly' , '' , '' , ''397 sn_dsc = ' decay_scale_cri' , -12 , 'field', .false. , .true. , 'yearly' , '' , '' , ''393 sn_mpb = 'int_wave_mix' , -12. , 'mixing_power_bot' , .false. , .true. , 'yearly' , '' , '' , '' 394 sn_mpp = 'int_wave_mix' , -12. , 'mixing_power_pyc' , .false. , .true. , 'yearly' , '' , '' , '' 395 sn_mpc = 'int_wave_mix' , -12. , 'mixing_power_cri' , .false. , .true. , 'yearly' , '' , '' , '' 396 sn_dsb = 'int_wave_mix' , -12. , 'decay_scale_bot' , .false. , .true. , 'yearly' , '' , '' , '' 397 sn_dsc = 'int_wave_mix' , -12. , 'decay_scale_cri' , .false. , .true. , 'yearly' , '' , '' , '' 398 398 / 399 399 !!====================================================================== -
NEMO/trunk/cfgs/ORCA2_SAS_ICE/EXPREF/namelist_cfg
r13208 r13286 73 73 ! ! file name ! frequency (hours) ! variable ! time interp.! clim ! 'yearly'/ ! weights filename ! rotation ! land/sea mask ! 74 74 ! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! ! pairing ! filename ! 75 sn_wndi = 'u_10.15JUNE2009_fill' , 6. , 'U_10_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bicubic_noc.nc' , 'Uwnd' , '' 76 sn_wndj = 'v_10.15JUNE2009_fill' , 6. , 'V_10_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bicubic_noc.nc' , 'Vwnd' , '' 77 sn_qsr = 'ncar_rad.15JUNE2009_fill' , 24. , 'SWDN_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' 78 sn_qlw = 'ncar_rad.15JUNE2009_fill' , 24. , 'LWDN_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' 79 sn_tair = 't_10.15JUNE2009_fill' , 6. , 'T_10_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' 80 sn_humi = 'q_10.15JUNE2009_fill' , 6. , 'Q_10_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' 81 sn_prec = 'ncar_precip.15JUNE2009_fill', -1. , 'PRC_MOD1', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' 82 sn_snow = 'ncar_precip.15JUNE2009_fill', -1. , 'SNOW' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' 83 sn_slp = 'slp.15JUNE2009_fill' , 6. , 'SLP' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' 84 / 85 !----------------------------------------------------------------------- 86 &namsbc_cpl ! coupled ocean/atmosphere model ("key_oasis3") 87 !----------------------------------------------------------------------- 75 sn_wndi = 'u_10.15JUNE2009_fill' , 6. , 'U_10_MOD', .false. , .true. , 'yearly' , 'weights_core2_orca2_bicub' , 'Uwnd' , '' 76 sn_wndj = 'v_10.15JUNE2009_fill' , 6. , 'V_10_MOD', .false. , .true. , 'yearly' , 'weights_core2_orca2_bicub' , 'Vwnd' , '' 77 sn_qsr = 'ncar_rad.15JUNE2009_fill' , 24. , 'SWDN_MOD', .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , '' 78 sn_qlw = 'ncar_rad.15JUNE2009_fill' , 24. , 'LWDN_MOD', .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , '' 79 sn_tair = 't_10.15JUNE2009_fill' , 6. , 'T_10_MOD', .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , '' 80 sn_humi = 'q_10.15JUNE2009_fill' , 6. , 'Q_10_MOD', .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , '' 81 sn_prec = 'ncar_precip.15JUNE2009_fill', -1. , 'PRC_MOD1', .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , '' 82 sn_snow = 'ncar_precip.15JUNE2009_fill', -1. , 'SNOW' , .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , '' 83 sn_slp = 'slp.15JUNE2009_fill' , 6. , 'SLP' , .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , '' 88 84 / 89 85 !----------------------------------------------------------------------- -
NEMO/trunk/cfgs/SHARED/namelist_ref
r13216 r13286 1209 1209 ! ! file name ! frequency (hours) ! variable ! time interp.! clim ! 'yearly'/ ! weights filename ! rotation ! land/sea mask ! 1210 1210 ! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! ! pairing ! filename ! 1211 sn_mpb = 'NOT USED' , -12 1212 sn_mpp = 'NOT USED' , -12 1213 sn_mpc = 'NOT USED' , -12 1214 sn_dsb = 'NOT USED' , -12 1215 sn_dsc = 'NOT USED' , -12 1211 sn_mpb = 'NOT USED' , -12. , 'mixing_power_bot' , .false. , .true. , 'yearly' , '' , '' , '' 1212 sn_mpp = 'NOT USED' , -12. , 'mixing_power_pyc' , .false. , .true. , 'yearly' , '' , '' , '' 1213 sn_mpc = 'NOT USED' , -12. , 'mixing_power_cri' , .false. , .true. , 'yearly' , '' , '' , '' 1214 sn_dsb = 'NOT USED' , -12. , 'decay_scale_bot' , .false. , .true. , 'yearly' , '' , '' , '' 1215 sn_dsc = 'NOT USED' , -12. , 'decay_scale_cri' , .false. , .true. , 'yearly' , '' , '' , '' 1216 1216 / 1217 1217 !!====================================================================== … … 1402 1402 jpni = 0 ! number of processors following i (set automatically if < 1), see also ln_listonly = T 1403 1403 jpnj = 0 ! number of processors following j (set automatically if < 1), see also ln_listonly = T 1404 nn_hls = 1 ! halo width (applies to both rows and columns) 1404 1405 / 1405 1406 !----------------------------------------------------------------------- … … 1417 1418 sn_cfctl%procincr = 1 ! Increment for optional subsetting of areas [default:1] 1418 1419 sn_cfctl%ptimincr = 1 ! Timestep increment for writing time step progress info 1419 nn_print = 0 ! level of print (0 no extra print)1420 1420 nn_ictls = 0 ! start i indice of control sum (use to compare mono versus 1421 1421 nn_ictle = 0 ! end i indice of control sum multi processor runs -
NEMO/trunk/cfgs/ref_cfgs.txt
r13227 r13286 11 11 SPITZ12 OCE ICE 12 12 WED025 OCE ICE 13 -
NEMO/trunk/src/ABL/ablrst.F90
r13214 r13286 165 165 166 166 ! --- mandatory fields --- ! 167 CALL iom_get( numrar, jpdom_auto glo, 'u_abl', u_abl(:,:,:,nt_n ))168 CALL iom_get( numrar, jpdom_auto glo, 'v_abl', v_abl(:,:,:,nt_n ))169 CALL iom_get( numrar, jpdom_auto glo, 't_abl', tq_abl(:,:,:,nt_n,jp_ta) )170 CALL iom_get( numrar, jpdom_auto glo, 'q_abl', tq_abl(:,:,:,nt_n,jp_qa) )171 CALL iom_get( numrar, jpdom_auto glo, 'tke_abl', tke_abl(:,:,:,nt_n ) )172 CALL iom_get( numrar, jpdom_auto glo, 'avm_abl', avm_abl(:,:,: ) )173 CALL iom_get( numrar, jpdom_auto glo, 'avt_abl', avt_abl(:,:,: ) )174 CALL iom_get( numrar, jpdom_auto glo,'mxld_abl',mxld_abl(:,:,: ) )175 CALL iom_get( numrar, jpdom_auto glo, 'pblh', pblh(:,: ) )167 CALL iom_get( numrar, jpdom_auto, 'u_abl', u_abl(:,:,:,nt_n ), cd_type = 'U', psgn = -1._wp ) 168 CALL iom_get( numrar, jpdom_auto, 'v_abl', v_abl(:,:,:,nt_n ), cd_type = 'V', psgn = -1._wp ) 169 CALL iom_get( numrar, jpdom_auto, 't_abl', tq_abl(:,:,:,nt_n,jp_ta) ) 170 CALL iom_get( numrar, jpdom_auto, 'q_abl', tq_abl(:,:,:,nt_n,jp_qa) ) 171 CALL iom_get( numrar, jpdom_auto, 'tke_abl', tke_abl(:,:,:,nt_n ) ) 172 CALL iom_get( numrar, jpdom_auto, 'avm_abl', avm_abl(:,:,: ) ) 173 CALL iom_get( numrar, jpdom_auto, 'avt_abl', avt_abl(:,:,: ) ) 174 CALL iom_get( numrar, jpdom_auto,'mxld_abl',mxld_abl(:,:,: ) ) 175 CALL iom_get( numrar, jpdom_auto, 'pblh', pblh(:,: ) ) 176 176 CALL iom_delay_rst( 'READ', 'ABL', numrar ) ! read only abl delayed global communication variables 177 177 -
NEMO/trunk/src/ICE/icectl.F90
r12649 r13286 702 702 DO jl = 1, jpl 703 703 CALL prt_ctl_info(' ') 704 CALL prt_ctl_info(' - Category : ', ivar 1=jl)704 CALL prt_ctl_info(' - Category : ', ivar=jl) 705 705 CALL prt_ctl_info(' ~~~~~~~~~~') 706 706 CALL prt_ctl(tab2d_1=h_i (:,:,jl) , clinfo1= ' h_i : ') … … 719 719 720 720 DO jk = 1, nlay_i 721 CALL prt_ctl_info(' - Layer : ', ivar 1=jk)721 CALL prt_ctl_info(' - Layer : ', ivar=jk) 722 722 CALL prt_ctl(tab2d_1=t_i(:,:,jk,jl) , clinfo1= ' t_i : ') 723 723 END DO -
NEMO/trunk/src/ICE/icedia.F90
r12489 r13286 230 230 CALL iom_get( numrir, 'frc_tembot' , frc_tembot ) 231 231 CALL iom_get( numrir, 'frc_sal' , frc_sal ) 232 CALL iom_get( numrir, jpdom_auto glo, 'vol_loc_ini', vol_loc_ini )233 CALL iom_get( numrir, jpdom_auto glo, 'tem_loc_ini', tem_loc_ini )234 CALL iom_get( numrir, jpdom_auto glo, 'sal_loc_ini', sal_loc_ini )232 CALL iom_get( numrir, jpdom_auto, 'vol_loc_ini', vol_loc_ini ) 233 CALL iom_get( numrir, jpdom_auto, 'tem_loc_ini', tem_loc_ini ) 234 CALL iom_get( numrir, jpdom_auto, 'sal_loc_ini', sal_loc_ini ) 235 235 ELSE 236 236 IF(lwp) WRITE(numout,*) -
NEMO/trunk/src/ICE/icedyn_adv_pra.F90
r13226 r13286 772 772 ! 773 773 ! ! ice thickness 774 CALL iom_get( numrir, jpdom_auto glo, 'sxice' , sxice )775 CALL iom_get( numrir, jpdom_auto glo, 'syice' , syice )776 CALL iom_get( numrir, jpdom_auto glo, 'sxxice', sxxice )777 CALL iom_get( numrir, jpdom_auto glo, 'syyice', syyice )778 CALL iom_get( numrir, jpdom_auto glo, 'sxyice', sxyice )774 CALL iom_get( numrir, jpdom_auto, 'sxice' , sxice ) 775 CALL iom_get( numrir, jpdom_auto, 'syice' , syice ) 776 CALL iom_get( numrir, jpdom_auto, 'sxxice', sxxice ) 777 CALL iom_get( numrir, jpdom_auto, 'syyice', syyice ) 778 CALL iom_get( numrir, jpdom_auto, 'sxyice', sxyice ) 779 779 ! ! snow thickness 780 CALL iom_get( numrir, jpdom_auto glo, 'sxsn' , sxsn )781 CALL iom_get( numrir, jpdom_auto glo, 'sysn' , sysn )782 CALL iom_get( numrir, jpdom_auto glo, 'sxxsn' , sxxsn )783 CALL iom_get( numrir, jpdom_auto glo, 'syysn' , syysn )784 CALL iom_get( numrir, jpdom_auto glo, 'sxysn' , sxysn )780 CALL iom_get( numrir, jpdom_auto, 'sxsn' , sxsn ) 781 CALL iom_get( numrir, jpdom_auto, 'sysn' , sysn ) 782 CALL iom_get( numrir, jpdom_auto, 'sxxsn' , sxxsn ) 783 CALL iom_get( numrir, jpdom_auto, 'syysn' , syysn ) 784 CALL iom_get( numrir, jpdom_auto, 'sxysn' , sxysn ) 785 785 ! ! ice concentration 786 CALL iom_get( numrir, jpdom_auto glo, 'sxa' , sxa )787 CALL iom_get( numrir, jpdom_auto glo, 'sya' , sya )788 CALL iom_get( numrir, jpdom_auto glo, 'sxxa' , sxxa )789 CALL iom_get( numrir, jpdom_auto glo, 'syya' , syya )790 CALL iom_get( numrir, jpdom_auto glo, 'sxya' , sxya )786 CALL iom_get( numrir, jpdom_auto, 'sxa' , sxa ) 787 CALL iom_get( numrir, jpdom_auto, 'sya' , sya ) 788 CALL iom_get( numrir, jpdom_auto, 'sxxa' , sxxa ) 789 CALL iom_get( numrir, jpdom_auto, 'syya' , syya ) 790 CALL iom_get( numrir, jpdom_auto, 'sxya' , sxya ) 791 791 ! ! ice salinity 792 CALL iom_get( numrir, jpdom_auto glo, 'sxsal' , sxsal )793 CALL iom_get( numrir, jpdom_auto glo, 'sysal' , sysal )794 CALL iom_get( numrir, jpdom_auto glo, 'sxxsal', sxxsal )795 CALL iom_get( numrir, jpdom_auto glo, 'syysal', syysal )796 CALL iom_get( numrir, jpdom_auto glo, 'sxysal', sxysal )792 CALL iom_get( numrir, jpdom_auto, 'sxsal' , sxsal ) 793 CALL iom_get( numrir, jpdom_auto, 'sysal' , sysal ) 794 CALL iom_get( numrir, jpdom_auto, 'sxxsal', sxxsal ) 795 CALL iom_get( numrir, jpdom_auto, 'syysal', syysal ) 796 CALL iom_get( numrir, jpdom_auto, 'sxysal', sxysal ) 797 797 ! ! ice age 798 CALL iom_get( numrir, jpdom_auto glo, 'sxage' , sxage )799 CALL iom_get( numrir, jpdom_auto glo, 'syage' , syage )800 CALL iom_get( numrir, jpdom_auto glo, 'sxxage', sxxage )801 CALL iom_get( numrir, jpdom_auto glo, 'syyage', syyage )802 CALL iom_get( numrir, jpdom_auto glo, 'sxyage', sxyage )798 CALL iom_get( numrir, jpdom_auto, 'sxage' , sxage ) 799 CALL iom_get( numrir, jpdom_auto, 'syage' , syage ) 800 CALL iom_get( numrir, jpdom_auto, 'sxxage', sxxage ) 801 CALL iom_get( numrir, jpdom_auto, 'syyage', syyage ) 802 CALL iom_get( numrir, jpdom_auto, 'sxyage', sxyage ) 803 803 ! ! snow layers heat content 804 804 DO jk = 1, nlay_s 805 805 WRITE(zchar1,'(I2.2)') jk 806 znam = 'sxc0'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto glo, znam , z3d ) ; sxc0 (:,:,jk,:) = z3d(:,:,:)807 znam = 'syc0'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto glo, znam , z3d ) ; syc0 (:,:,jk,:) = z3d(:,:,:)808 znam = 'sxxc0'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto glo, znam , z3d ) ; sxxc0(:,:,jk,:) = z3d(:,:,:)809 znam = 'syyc0'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto glo, znam , z3d ) ; syyc0(:,:,jk,:) = z3d(:,:,:)810 znam = 'sxyc0'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto glo, znam , z3d ) ; sxyc0(:,:,jk,:) = z3d(:,:,:)806 znam = 'sxc0'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; sxc0 (:,:,jk,:) = z3d(:,:,:) 807 znam = 'syc0'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; syc0 (:,:,jk,:) = z3d(:,:,:) 808 znam = 'sxxc0'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; sxxc0(:,:,jk,:) = z3d(:,:,:) 809 znam = 'syyc0'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; syyc0(:,:,jk,:) = z3d(:,:,:) 810 znam = 'sxyc0'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; sxyc0(:,:,jk,:) = z3d(:,:,:) 811 811 END DO 812 812 ! ! ice layers heat content 813 813 DO jk = 1, nlay_i 814 814 WRITE(zchar1,'(I2.2)') jk 815 znam = 'sxe'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto glo, znam , z3d ) ; sxe (:,:,jk,:) = z3d(:,:,:)816 znam = 'sye'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto glo, znam , z3d ) ; sye (:,:,jk,:) = z3d(:,:,:)817 znam = 'sxxe'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto glo, znam , z3d ) ; sxxe(:,:,jk,:) = z3d(:,:,:)818 znam = 'syye'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto glo, znam , z3d ) ; syye(:,:,jk,:) = z3d(:,:,:)819 znam = 'sxye'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto glo, znam , z3d ) ; sxye(:,:,jk,:) = z3d(:,:,:)815 znam = 'sxe'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; sxe (:,:,jk,:) = z3d(:,:,:) 816 znam = 'sye'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; sye (:,:,jk,:) = z3d(:,:,:) 817 znam = 'sxxe'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; sxxe(:,:,jk,:) = z3d(:,:,:) 818 znam = 'syye'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; syye(:,:,jk,:) = z3d(:,:,:) 819 znam = 'sxye'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; sxye(:,:,jk,:) = z3d(:,:,:) 820 820 END DO 821 821 ! 822 822 IF( ln_pnd_H12 ) THEN ! melt pond fraction 823 CALL iom_get( numrir, jpdom_auto glo, 'sxap' , sxap )824 CALL iom_get( numrir, jpdom_auto glo, 'syap' , syap )825 CALL iom_get( numrir, jpdom_auto glo, 'sxxap', sxxap )826 CALL iom_get( numrir, jpdom_auto glo, 'syyap', syyap )827 CALL iom_get( numrir, jpdom_auto glo, 'sxyap', sxyap )823 CALL iom_get( numrir, jpdom_auto, 'sxap' , sxap ) 824 CALL iom_get( numrir, jpdom_auto, 'syap' , syap ) 825 CALL iom_get( numrir, jpdom_auto, 'sxxap', sxxap ) 826 CALL iom_get( numrir, jpdom_auto, 'syyap', syyap ) 827 CALL iom_get( numrir, jpdom_auto, 'sxyap', sxyap ) 828 828 ! ! melt pond volume 829 CALL iom_get( numrir, jpdom_auto glo, 'sxvp' , sxvp )830 CALL iom_get( numrir, jpdom_auto glo, 'syvp' , syvp )831 CALL iom_get( numrir, jpdom_auto glo, 'sxxvp', sxxvp )832 CALL iom_get( numrir, jpdom_auto glo, 'syyvp', syyvp )833 CALL iom_get( numrir, jpdom_auto glo, 'sxyvp', sxyvp )829 CALL iom_get( numrir, jpdom_auto, 'sxvp' , sxvp ) 830 CALL iom_get( numrir, jpdom_auto, 'syvp' , syvp ) 831 CALL iom_get( numrir, jpdom_auto, 'sxxvp', sxxvp ) 832 CALL iom_get( numrir, jpdom_auto, 'syyvp', syyvp ) 833 CALL iom_get( numrir, jpdom_auto, 'sxyvp', sxyvp ) 834 834 ENDIF 835 835 ! -
NEMO/trunk/src/ICE/icedyn_rhg_evp.F90
r13237 r13286 845 845 ! 846 846 IF( MIN( id1, id2, id3 ) > 0 ) THEN ! fields exist 847 CALL iom_get( numrir, jpdom_auto glo, 'stress1_i' , stress1_i)848 CALL iom_get( numrir, jpdom_auto glo, 'stress2_i' , stress2_i)849 CALL iom_get( numrir, jpdom_auto glo, 'stress12_i', stress12_i)847 CALL iom_get( numrir, jpdom_auto, 'stress1_i' , stress1_i , cd_type = 'T' ) 848 CALL iom_get( numrir, jpdom_auto, 'stress2_i' , stress2_i , cd_type = 'T' ) 849 CALL iom_get( numrir, jpdom_auto, 'stress12_i', stress12_i, cd_type = 'F' ) 850 850 ELSE ! start rheology from rest 851 851 IF(lwp) WRITE(numout,*) -
NEMO/trunk/src/ICE/icerst.F90
r12649 r13286 211 211 212 212 ! --- mandatory fields --- ! 213 CALL iom_get( numrir, jpdom_auto glo, 'v_i' , v_i )214 CALL iom_get( numrir, jpdom_auto glo, 'v_s' , v_s )215 CALL iom_get( numrir, jpdom_auto glo, 'sv_i' , sv_i )216 CALL iom_get( numrir, jpdom_auto glo, 'a_i' , a_i )217 CALL iom_get( numrir, jpdom_auto glo, 't_su' , t_su )218 CALL iom_get( numrir, jpdom_auto glo, 'u_ice', u_ice)219 CALL iom_get( numrir, jpdom_auto glo, 'v_ice', v_ice)213 CALL iom_get( numrir, jpdom_auto, 'v_i' , v_i ) 214 CALL iom_get( numrir, jpdom_auto, 'v_s' , v_s ) 215 CALL iom_get( numrir, jpdom_auto, 'sv_i' , sv_i ) 216 CALL iom_get( numrir, jpdom_auto, 'a_i' , a_i ) 217 CALL iom_get( numrir, jpdom_auto, 't_su' , t_su ) 218 CALL iom_get( numrir, jpdom_auto, 'u_ice', u_ice, cd_type = 'U', psgn = -1._wp ) 219 CALL iom_get( numrir, jpdom_auto, 'v_ice', v_ice, cd_type = 'V', psgn = -1._wp ) 220 220 ! Snow enthalpy 221 221 DO jk = 1, nlay_s 222 222 WRITE(zchar1,'(I2.2)') jk 223 223 znam = 'e_s'//'_l'//zchar1 224 CALL iom_get( numrir, jpdom_auto glo, znam , z3d )224 CALL iom_get( numrir, jpdom_auto, znam , z3d ) 225 225 e_s(:,:,jk,:) = z3d(:,:,:) 226 226 END DO … … 229 229 WRITE(zchar1,'(I2.2)') jk 230 230 znam = 'e_i'//'_l'//zchar1 231 CALL iom_get( numrir, jpdom_auto glo, znam , z3d )231 CALL iom_get( numrir, jpdom_auto, znam , z3d ) 232 232 e_i(:,:,jk,:) = z3d(:,:,:) 233 233 END DO … … 236 236 id1 = iom_varid( numrir, 'oa_i' , ldstop = .FALSE. ) 237 237 IF( id1 > 0 ) THEN ! fields exist 238 CALL iom_get( numrir, jpdom_auto glo, 'oa_i', oa_i )238 CALL iom_get( numrir, jpdom_auto, 'oa_i', oa_i ) 239 239 ELSE ! start from rest 240 240 IF(lwp) WRITE(numout,*) ' ==>> previous run without ice age output then set it to zero' … … 244 244 id2 = iom_varid( numrir, 'a_ip' , ldstop = .FALSE. ) 245 245 IF( id2 > 0 ) THEN ! fields exist 246 CALL iom_get( numrir, jpdom_auto glo, 'a_ip' , a_ip )247 CALL iom_get( numrir, jpdom_auto glo, 'v_ip' , v_ip )246 CALL iom_get( numrir, jpdom_auto, 'a_ip' , a_ip ) 247 CALL iom_get( numrir, jpdom_auto, 'v_ip' , v_ip ) 248 248 ELSE ! start from rest 249 249 IF(lwp) WRITE(numout,*) ' ==>> previous run without melt ponds output then set it to zero' … … 256 256 id4 = iom_varid( numrir, 't1_ice' , ldstop = .FALSE. ) 257 257 IF( id3 > 0 .AND. id4 > 0 ) THEN ! fields exist 258 CALL iom_get( numrir, jpdom_auto glo, 'cnd_ice', cnd_ice )259 CALL iom_get( numrir, jpdom_auto glo, 't1_ice' , t1_ice )258 CALL iom_get( numrir, jpdom_auto, 'cnd_ice', cnd_ice ) 259 CALL iom_get( numrir, jpdom_auto, 't1_ice' , t1_ice ) 260 260 ELSE ! start from rest 261 261 IF(lwp) WRITE(numout,*) ' ==>> previous run without conductivity output then set it to zero' -
NEMO/trunk/src/ICE/iceupdate.F90
r13226 r13286 417 417 ! 418 418 IF( id1 > 0 ) THEN ! fields exist 419 CALL iom_get( numrir, jpdom_auto glo, 'snwice_mass' , snwice_mass )420 CALL iom_get( numrir, jpdom_auto glo, 'snwice_mass_b', snwice_mass_b )419 CALL iom_get( numrir, jpdom_auto, 'snwice_mass' , snwice_mass ) 420 CALL iom_get( numrir, jpdom_auto, 'snwice_mass_b', snwice_mass_b ) 421 421 ELSE ! start from rest 422 422 IF(lwp) WRITE(numout,*) ' ==>> previous run without snow-ice mass output then set it' -
NEMO/trunk/src/NST/agrif_ice_interp.F90
r13216 r13286 269 269 ! imin = i1 ; imax = i2 ; jmin = j1 ; jmax = j2 270 270 ! IF( (nbondj == -1) .OR. (nbondj == 2) ) jmin = 3 271 ! IF( (nbondj == +1) .OR. (nbondj == 2) ) jmax = nlcj-2271 ! IF( (nbondj == +1) .OR. (nbondj == 2) ) jmax = jpj-2 272 272 ! IF( (nbondi == -1) .OR. (nbondi == 2) ) imin = 3 273 ! IF( (nbondi == +1) .OR. (nbondi == 2) ) imax = nlci-2273 ! IF( (nbondi == +1) .OR. (nbondi == 2) ) imax = jpi-2 274 274 ! 275 275 ! ! smoothed fields 276 276 ! IF( eastern_side ) THEN 277 ! ztab( nlci,j1:j2,:) = z1 * ptab(nlci,j1:j2,:) + z2 * ptab(nlci-1,j1:j2,:)277 ! ztab(jpi,j1:j2,:) = z1 * ptab(jpi,j1:j2,:) + z2 * ptab(jpi-1,j1:j2,:) 278 278 ! DO jj = jmin, jmax 279 279 ! rswitch = 0. 280 ! IF( u_ice( nlci-2,jj) > 0._wp ) rswitch = 1.281 ! ztab( nlci-1,jj,:) = ( 1. - umask(nlci-2,jj,1) ) * ztab(nlci,jj,:) &282 ! & + umask(nlci-2,jj,1) * &283 ! & ( ( 1. - rswitch ) * ( z4 * ztab(nlci,jj,:) + z3 * ztab(nlci-2,jj,:) ) &284 ! & + rswitch * ( z6 * ztab(nlci-2,jj,:) + z5 * ztab(nlci,jj,:) + z7 * ztab(nlci-3,jj,:) ) )285 ! ztab( nlci-1,jj,:) = ztab(nlci-1,jj,:) * tmask(nlci-1,jj,1)280 ! IF( u_ice(jpi-2,jj) > 0._wp ) rswitch = 1. 281 ! ztab(jpi-1,jj,:) = ( 1. - umask(jpi-2,jj,1) ) * ztab(jpi,jj,:) & 282 ! & + umask(jpi-2,jj,1) * & 283 ! & ( (1. - rswitch) * ( z4 * ztab(jpi ,jj,:) + z3 * ztab(jpi-2,jj,:) ) & 284 ! & + rswitch * ( z6 * ztab(jpi-2,jj,:) + z5 * ztab(jpi ,jj,:) + z7 * ztab(jpi-3,jj,:) ) ) 285 ! ztab(jpi-1,jj,:) = ztab(jpi-1,jj,:) * tmask(jpi-1,jj,1) 286 286 ! END DO 287 287 ! ENDIF 288 288 ! ! 289 289 ! IF( northern_side ) THEN 290 ! ztab(i1:i2, nlcj,:) = z1 * ptab(i1:i2,nlcj,:) + z2 * ptab(i1:i2,nlcj-1,:)290 ! ztab(i1:i2,jpj,:) = z1 * ptab(i1:i2,jpj,:) + z2 * ptab(i1:i2,jpj-1,:) 291 291 ! DO ji = imin, imax 292 292 ! rswitch = 0. 293 ! IF( v_ice(ji, nlcj-2) > 0._wp ) rswitch = 1.294 ! ztab(ji, nlcj-1,:) = ( 1. - vmask(ji,nlcj-2,1) ) * ztab(ji,nlcj,:) &295 ! & + vmask(ji,nlcj-2,1) * &296 ! & ( ( 1. - rswitch ) * ( z4 * ztab(ji,nlcj,:) + z3 * ztab(ji,nlcj-2,:) ) &297 ! & + rswitch * ( z6 * ztab(ji,nlcj-2,:) + z5 * ztab(ji,nlcj,:) + z7 * ztab(ji,nlcj-3,:) ) )298 ! ztab(ji, nlcj-1,:) = ztab(ji,nlcj-1,:) * tmask(ji,nlcj-1,1)293 ! IF( v_ice(ji,jpj-2) > 0._wp ) rswitch = 1. 294 ! ztab(ji,jpj-1,:) = ( 1. - vmask(ji,jpj-2,1) ) * ztab(ji,jpj,:) & 295 ! & + vmask(ji,jpj-2,1) * & 296 ! & ( (1. - rswitch) * ( z4 * ztab(ji,jpj ,:) + z3 * ztab(ji,jpj-2,:) ) & 297 ! & + rswitch * ( z6 * ztab(ji,jpj-2,:) + z5 * ztab(ji,jpj ,:) + z7 * ztab(ji,jpj-3,:) ) ) 298 ! ztab(ji,jpj-1,:) = ztab(ji,jpj-1,:) * tmask(ji,jpj-1,1) 299 299 ! END DO 300 300 ! END IF … … 327 327 ! ! 328 328 ! ! Treatment of corners 329 ! IF( (eastern_side) .AND. ((nbondj == -1).OR.(nbondj == 2)) ) ztab( nlci-1,2,:) = ptab(nlci-1,2,:)! East south330 ! IF( (eastern_side) .AND. ((nbondj == 1).OR.(nbondj == 2)) ) ztab( nlci-1,nlcj-1,:) = ptab(nlci-1,nlcj-1,:)! East north331 ! IF( (western_side) .AND. ((nbondj == -1).OR.(nbondj == 2)) ) ztab( 2,2,:) = ptab(2,2,:)! West south332 ! IF( (western_side) .AND. ((nbondj == 1).OR.(nbondj == 2)) ) ztab( 2,nlcj-1,:) = ptab(2,nlcj-1,:)! West north329 ! IF( (eastern_side) .AND. ((nbondj == -1).OR.(nbondj == 2)) ) ztab(jpi-1,2 ,:) = ptab(jpi-1, 2,:) ! East south 330 ! IF( (eastern_side) .AND. ((nbondj == 1).OR.(nbondj == 2)) ) ztab(jpi-1,jpj-1,:) = ptab(jpi-1,jpj-1,:) ! East north 331 ! IF( (western_side) .AND. ((nbondj == -1).OR.(nbondj == 2)) ) ztab( 2, 2,:) = ptab( 2, 2,:) ! West south 332 ! IF( (western_side) .AND. ((nbondj == 1).OR.(nbondj == 2)) ) ztab( 2,jpj-1,:) = ptab( 2,jpj-1,:) ! West north 333 333 ! 334 334 ! ! retrieve ice tracers -
NEMO/trunk/src/NST/agrif_oce.F90
r13216 r13286 68 68 INTEGER, PUBLIC :: avt_id, avm_id, en_id ! TKE related identificators 69 69 INTEGER, PUBLIC :: mbkt_id, ht0_id 70 INTEGER, PUBLIC :: glamt_id, gphit_id 70 71 INTEGER, PUBLIC :: kindic_agr 71 72 -
NEMO/trunk/src/NST/agrif_oce_interp.F90
r13216 r13286 44 44 PUBLIC interptsn, interpsshn, interpavm 45 45 PUBLIC interpunb, interpvnb , interpub2b, interpvb2b 46 PUBLIC interpe3t 46 PUBLIC interpe3t, interpglamt, interpgphit 47 47 PUBLIC interpht0, interpmbkt 48 48 PUBLIC agrif_initts, agrif_initssh … … 87 87 IF( Agrif_Root() ) RETURN 88 88 ! 89 Agrif_SpecialValue = 0. _wp89 Agrif_SpecialValue = 0.0_wp 90 90 Agrif_UseSpecialValue = ln_spc_dyn 91 91 ! 92 92 use_sign_north = .TRUE. 93 sign_north = -1. 93 sign_north = -1.0_wp 94 94 CALL Agrif_Bc_variable( un_interp_id, procname=interpun ) 95 95 CALL Agrif_Bc_variable( vn_interp_id, procname=interpvn ) … … 100 100 ! --- West --- ! 101 101 IF( lk_west ) THEN 102 ibdy1 = 2103 ibdy2 = 1+nbghostcells102 ibdy1 = nn_hls + 2 ! halo + land + 1 103 ibdy2 = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 104 104 ! 105 105 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 106 106 DO ji = mi0(ibdy1), mi1(ibdy2) 107 107 uu_b(ji,:,Krhs_a) = 0._wp 108 109 108 DO jk = 1, jpkm1 110 109 DO jj = 1, jpj … … 112 111 END DO 113 112 END DO 114 115 113 DO jj = 1, jpj 116 114 uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) * r1_hu(ji,jj,Krhs_a) … … 123 121 DO jk = 1, jpkm1 124 122 DO jj = 1, jpj 125 zub(ji,jj) = zub(ji,jj) & 126 & + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a)*umask(ji,jj,jk) 123 zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 127 124 END DO 128 125 END DO 129 126 DO jj=1,jpj 130 127 zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a) 131 END DO 132 128 END DO 133 129 DO jk = 1, jpkm1 134 130 DO jj = 1, jpj 135 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)136 END DO 137 END DO 138 END DO 139 131 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) 132 END DO 133 END DO 134 END DO 135 ! 140 136 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 141 137 DO ji = mi0(ibdy1), mi1(ibdy2) … … 151 147 DO jk = 1, jpkm1 152 148 DO jj = 1, jpj 153 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)149 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) 154 150 END DO 155 151 END DO 156 152 END DO 157 153 ENDIF 154 ! 158 155 ENDIF 159 156 160 157 ! --- East --- ! 161 158 IF( lk_east) THEN 162 ibdy1 = jpiglo -1-nbghostcells163 ibdy2 = jpiglo -2159 ibdy1 = jpiglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells 160 ibdy2 = jpiglo - ( nn_hls + 2 ) ! halo + land + 1 164 161 ! 165 162 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport … … 168 165 DO jk = 1, jpkm1 169 166 DO jj = 1, jpj 170 uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) & 171 & + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 167 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) 172 168 END DO 173 169 END DO … … 182 178 DO jk = 1, jpkm1 183 179 DO jj = 1, jpj 184 zub(ji,jj) = zub(ji,jj) & 185 & + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 180 zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 186 181 END DO 187 182 END DO … … 189 184 zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a) 190 185 END DO 191 192 186 DO jk = 1, jpkm1 193 187 DO jj = 1, jpj 194 uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) & 195 & + uu_b(ji,jj,Krhs_a)-zub(ji,jj))*umask(ji,jj,jk) 196 END DO 197 END DO 198 END DO 199 188 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) 189 END DO 190 END DO 191 END DO 192 ! 200 193 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 201 ibdy1 = jpiglo -nbghostcells202 ibdy2 = jpiglo -1194 ibdy1 = jpiglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 195 ibdy2 = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 203 196 DO ji = mi0(ibdy1), mi1(ibdy2) 204 197 zvb(ji,:) = 0._wp 205 198 DO jk = 1, jpkm1 206 199 DO jj = 1, jpj 207 zvb(ji,jj) = zvb(ji,jj) & 208 & + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 200 zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 209 201 END DO 210 202 END DO … … 214 206 DO jk = 1, jpkm1 215 207 DO jj = 1, jpj 216 vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) & 217 & + vv_b(ji,jj,Krhs_a)-zvb(ji,jj)) * vmask(ji,jj,jk) 208 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) 218 209 END DO 219 210 END DO 220 211 END DO 221 212 ENDIF 213 ! 222 214 ENDIF 223 215 224 216 ! --- South --- ! 225 217 IF( lk_south ) THEN 226 jbdy1 = 2227 jbdy2 = 1+nbghostcells218 jbdy1 = nn_hls + 2 ! halo + land + 1 219 jbdy2 = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 228 220 ! 229 221 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport … … 232 224 DO jk = 1, jpkm1 233 225 DO ji = 1, jpi 234 vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) & 235 & + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 226 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) 236 227 END DO 237 228 END DO … … 246 237 DO jk=1,jpkm1 247 238 DO ji=1,jpi 248 zvb(ji,jj) = zvb(ji,jj) & 249 & + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 239 zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 250 240 END DO 251 241 END DO … … 253 243 zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a) 254 244 END DO 255 256 245 DO jk = 1, jpkm1 257 246 DO ji = 1, jpi 258 vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) & 259 & + vv_b(ji,jj,Krhs_a) - zvb(ji,jj) ) * vmask(ji,jj,jk) 260 END DO 261 END DO 262 END DO 263 247 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) 248 END DO 249 END DO 250 END DO 251 ! 264 252 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 265 253 DO jj = mj0(jbdy1), mj1(jbdy2) … … 267 255 DO jk = 1, jpkm1 268 256 DO ji = 1, jpi 269 zub(ji,jj) = zub(ji,jj) & 270 & + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 257 zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 271 258 END DO 272 259 END DO … … 274 261 zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a) 275 262 END DO 276 277 263 DO jk = 1, jpkm1 278 264 DO ji = 1, jpi 279 uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) & 280 & + uu_b(ji,jj,Krhs_a) - zub(ji,jj) ) * umask(ji,jj,jk) 265 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) 281 266 END DO 282 267 END DO 283 268 END DO 284 269 ENDIF 270 ! 285 271 ENDIF 286 272 287 273 ! --- North --- ! 288 274 IF( lk_north ) THEN 289 jbdy1 = jpjglo -1-nbghostcells290 jbdy2 = jpjglo -2275 jbdy1 = jpjglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells 276 jbdy2 = jpjglo - ( nn_hls + 2 ) ! halo + land + 1 291 277 ! 292 278 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport … … 295 281 DO jk = 1, jpkm1 296 282 DO ji = 1, jpi 297 vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) & 298 & + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 283 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) 299 284 END DO 300 285 END DO … … 309 294 DO jk=1,jpkm1 310 295 DO ji=1,jpi 311 zvb(ji,jj) = zvb(ji,jj) & 312 & + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 296 zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 313 297 END DO 314 298 END DO … … 316 300 zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a) 317 301 END DO 318 319 302 DO jk = 1, jpkm1 320 303 DO ji = 1, jpi 321 vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) & 322 & + vv_b(ji,jj,Krhs_a) - zvb(ji,jj) ) * vmask(ji,jj,jk) 323 END DO 324 END DO 325 END DO 326 304 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) 305 END DO 306 END DO 307 END DO 308 ! 327 309 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 328 jbdy1 = jpjglo -nbghostcells329 jbdy2 = jpjglo -1310 jbdy1 = jpjglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 311 jbdy2 = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 330 312 DO jj = mj0(jbdy1), mj1(jbdy2) 331 313 zub(:,jj) = 0._wp 332 314 DO jk = 1, jpkm1 333 315 DO ji = 1, jpi 334 zub(ji,jj) = zub(ji,jj) & 335 & + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 316 zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 336 317 END DO 337 318 END DO … … 339 320 zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a) 340 321 END DO 341 342 322 DO jk = 1, jpkm1 343 323 DO ji = 1, jpi 344 uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) & 345 & + uu_b(ji,jj,Krhs_a) - zub(ji,jj) ) * umask(ji,jj,jk) 324 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) 346 325 END DO 347 326 END DO 348 327 END DO 349 328 ENDIF 329 ! 350 330 ENDIF 351 331 ! … … 367 347 !--- West ---! 368 348 IF( lk_west ) THEN 369 istart = 2370 iend = n bghostcells+1349 istart = nn_hls + 2 ! halo + land + 1 350 iend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 371 351 DO ji = mi0(istart), mi1(iend) 372 352 DO jj=1,jpj … … 379 359 !--- East ---! 380 360 IF( lk_east ) THEN 381 istart = jpiglo -nbghostcells382 iend = jpiglo -1361 istart = jpiglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 362 iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 383 363 DO ji = mi0(istart), mi1(iend) 384 364 … … 387 367 END DO 388 368 END DO 389 istart = jpiglo -nbghostcells-1390 iend = jpiglo -2369 istart = jpiglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells 370 iend = jpiglo - ( nn_hls + 2 ) ! halo + land + 1 391 371 DO ji = mi0(istart), mi1(iend) 392 372 DO jj=1,jpj … … 398 378 !--- South ---! 399 379 IF( lk_south ) THEN 400 jstart = 2401 jend = n bghostcells+1380 jstart = nn_hls + 2 ! halo + land + 1 381 jend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 402 382 DO jj = mj0(jstart), mj1(jend) 403 383 … … 411 391 !--- North ---! 412 392 IF( lk_north ) THEN 413 jstart = jpjglo -nbghostcells414 jend = jpjglo -1393 jstart = jpjglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 394 jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 415 395 DO jj = mj0(jstart), mj1(jend) 416 396 DO ji=1,jpi … … 418 398 END DO 419 399 END DO 420 jstart = jpjglo -nbghostcells-1421 jend = jpjglo -2400 jstart = jpjglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells 401 jend = jpjglo - ( nn_hls + 2 ) ! halo + land + 1 422 402 DO jj = mj0(jstart), mj1(jend) 423 403 DO ji=1,jpi … … 429 409 END SUBROUTINE Agrif_dyn_ts 430 410 411 431 412 SUBROUTINE Agrif_dyn_ts_flux( jn, zu, zv ) 432 413 !!---------------------------------------------------------------------- … … 444 425 !--- West ---! 445 426 IF( lk_west ) THEN 446 istart = 2447 iend = n bghostcells+1427 istart = nn_hls + 2 ! halo + land + 1 428 iend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 448 429 DO ji = mi0(istart), mi1(iend) 449 430 DO jj=1,jpj … … 456 437 !--- East ---! 457 438 IF( lk_east ) THEN 458 istart = jpiglo -nbghostcells459 iend = jpiglo -1439 istart = jpiglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 440 iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 460 441 DO ji = mi0(istart), mi1(iend) 461 442 DO jj=1,jpj … … 463 444 END DO 464 445 END DO 465 istart = jpiglo -nbghostcells-1466 iend = jpiglo -2446 istart = jpiglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells 447 iend = jpiglo - ( nn_hls + 2 ) ! halo + land + 1 467 448 DO ji = mi0(istart), mi1(iend) 468 449 DO jj=1,jpj … … 474 455 !--- South ---! 475 456 IF( lk_south ) THEN 476 jstart = 2477 jend = n bghostcells+1457 jstart = nn_hls + 2 ! halo + land + 1 458 jend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 478 459 DO jj = mj0(jstart), mj1(jend) 479 460 DO ji=1,jpi … … 486 467 !--- North ---! 487 468 IF( lk_north ) THEN 488 jstart = jpjglo -nbghostcells489 jend = jpjglo -1469 jstart = jpjglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 470 jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 490 471 DO jj = mj0(jstart), mj1(jend) 491 472 DO ji=1,jpi … … 493 474 END DO 494 475 END DO 495 jstart = jpjglo -nbghostcells-1496 jend = jpjglo -2476 jstart = jpjglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells 477 jend = jpjglo - ( nn_hls + 2 ) ! halo + land + 1 497 478 DO jj = mj0(jstart), mj1(jend) 498 479 DO ji=1,jpi … … 504 485 END SUBROUTINE Agrif_dyn_ts_flux 505 486 487 506 488 SUBROUTINE Agrif_dta_ts( kt ) 507 489 !!---------------------------------------------------------------------- … … 578 560 ! --- West --- ! 579 561 IF(lk_west) THEN 580 istart = 2581 iend = 1+ nbghostcells562 istart = nn_hls + 2 ! halo + land + 1 563 iend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 582 564 DO ji = mi0(istart), mi1(iend) 583 565 DO jj = 1, jpj 584 566 ssh(ji,jj,Krhs_a) = hbdy(ji,jj) 585 END DO586 END DO567 END DO 568 END DO 587 569 ENDIF 588 570 ! 589 571 ! --- East --- ! 590 572 IF(lk_east) THEN 591 istart = jpiglo - nbghostcells592 iend = jpiglo - 1573 istart = jpiglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 574 iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 593 575 DO ji = mi0(istart), mi1(iend) 594 576 DO jj = 1, jpj 595 577 ssh(ji,jj,Krhs_a) = hbdy(ji,jj) 596 END DO597 END DO578 END DO 579 END DO 598 580 ENDIF 599 581 ! 600 582 ! --- South --- ! 601 583 IF(lk_south) THEN 602 jstart = 2603 jend = 1+ nbghostcells584 jstart = nn_hls + 2 ! halo + land + 1 585 jend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 604 586 DO jj = mj0(jstart), mj1(jend) 605 587 DO ji = 1, jpi 606 588 ssh(ji,jj,Krhs_a) = hbdy(ji,jj) 607 END DO608 END DO589 END DO 590 END DO 609 591 ENDIF 610 592 ! 611 593 ! --- North --- ! 612 594 IF(lk_north) THEN 613 jstart = jpjglo - nbghostcells614 jend = jpjglo - 1595 jstart = jpjglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 596 jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 615 597 DO jj = mj0(jstart), mj1(jend) 616 598 DO ji = 1, jpi 617 599 ssh(ji,jj,Krhs_a) = hbdy(ji,jj) 618 END DO619 END DO600 END DO 601 END DO 620 602 ENDIF 621 603 ! … … 637 619 ! --- West --- ! 638 620 IF(lk_west) THEN 639 istart = 2640 iend = 1+nbghostcells621 istart = nn_hls + 2 ! halo + land + 1 622 iend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 641 623 DO ji = mi0(istart), mi1(iend) 642 624 DO jj = 1, jpj 643 625 ssha_e(ji,jj) = hbdy(ji,jj) 644 END DO645 END DO626 END DO 627 END DO 646 628 ENDIF 647 629 ! 648 630 ! --- East --- ! 649 631 IF(lk_east) THEN 650 istart = jpiglo - nbghostcells651 iend = jpiglo - 1632 istart = jpiglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 633 iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 652 634 DO ji = mi0(istart), mi1(iend) 653 635 DO jj = 1, jpj 654 636 ssha_e(ji,jj) = hbdy(ji,jj) 655 END DO656 END DO637 END DO 638 END DO 657 639 ENDIF 658 640 ! 659 641 ! --- South --- ! 660 642 IF(lk_south) THEN 661 jstart = 2662 jend = 1+nbghostcells643 jstart = nn_hls + 2 ! halo + land + 1 644 jend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 663 645 DO jj = mj0(jstart), mj1(jend) 664 646 DO ji = 1, jpi 665 647 ssha_e(ji,jj) = hbdy(ji,jj) 666 END DO667 END DO648 END DO 649 END DO 668 650 ENDIF 669 651 ! 670 652 ! --- North --- ! 671 653 IF(lk_north) THEN 672 jstart = jpjglo - nbghostcells673 jend = jpjglo - 1654 jstart = jpjglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 655 jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 674 656 DO jj = mj0(jstart), mj1(jend) 675 657 DO ji = 1, jpi 676 658 ssha_e(ji,jj) = hbdy(ji,jj) 677 END DO678 END DO659 END DO 660 END DO 679 661 ENDIF 680 662 ! 681 663 END SUBROUTINE Agrif_ssh_ts 682 664 665 683 666 SUBROUTINE Agrif_avm 684 667 !!---------------------------------------------------------------------- … … 701 684 ! 702 685 END SUBROUTINE Agrif_avm 703 686 704 687 705 688 SUBROUTINE interptsn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before ) … … 793 776 DO jk=2,N_in 794 777 z_in(jk) = z_in(jk-1) + 0.5_wp * h_in(jk) 795 END DO778 END DO 796 779 797 780 N_out = 0 … … 800 783 N_out = N_out + 1 801 784 h_out(jk) = e3t(ji,jj,jk,Krhs_a) 802 END DO785 END DO 803 786 804 787 z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + ht_0(ji,jj) 805 788 DO jk=2,N_out 806 789 z_out(jk) = z_out(jk-1) + 0.5_wp * h_out(jk) 807 END DO790 END DO 808 791 809 792 IF (N_in*N_out > 0) THEN … … 816 799 ENDIF 817 800 ENDIF 818 END DO819 END DO801 END DO 802 END DO 820 803 Krhs_a = item 821 804 … … 831 814 END SUBROUTINE interptsn 832 815 816 833 817 SUBROUTINE interpsshn( ptab, i1, i2, j1, j2, before ) 834 818 !!---------------------------------------------------------------------- … … 849 833 END SUBROUTINE interpsshn 850 834 835 851 836 SUBROUTINE interpun( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before ) 852 837 !!---------------------------------------------------------------------- … … 934 919 tabin(jk) = 0. 935 920 ENDIF 936 END DO921 END DO 937 922 z_in(1) = 0.5_wp * h_in(1) - zhtot + hu0_parent(ji,jj) 938 923 DO jk=2,N_in 939 924 z_in(jk) = z_in(jk-1) + 0.5_wp * h_in(jk) 940 END DO925 END DO 941 926 942 927 N_out = 0 … … 945 930 N_out = N_out + 1 946 931 h_out(N_out) = e3u(ji,jj,jk,Krhs_a) 947 END DO932 END DO 948 933 949 934 z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + hu_0(ji,jj) 950 935 DO jk=2,N_out 951 936 z_out(jk) = z_out(jk-1) + 0.5_wp * h_out(jk) 952 END DO937 END DO 953 938 954 939 IF (N_in*N_out > 0) THEN … … 959 944 ENDIF 960 945 ENDIF 961 END DO962 END DO946 END DO 947 END DO 963 948 ELSE 964 949 DO jk = 1, jpkm1 … … 973 958 END SUBROUTINE interpun 974 959 960 975 961 SUBROUTINE interpvn( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before ) 976 962 !!---------------------------------------------------------------------- … … 1055 1041 tabin(jk) = 0. 1056 1042 ENDIF 1057 END DO1043 END DO 1058 1044 1059 1045 z_in(1) = 0.5_wp * h_in(1) - zhtot + hv0_parent(ji,jj) 1060 1046 DO jk=2,N_in 1061 1047 z_in(jk) = z_in(jk-1) + 0.5_wp * h_in(jk) 1062 END DO1048 END DO 1063 1049 1064 1050 N_out = 0 … … 1067 1053 N_out = N_out + 1 1068 1054 h_out(N_out) = e3v(ji,jj,jk,Krhs_a) 1069 END DO1055 END DO 1070 1056 1071 1057 z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + hv_0(ji,jj) 1072 1058 DO jk=2,N_out 1073 1059 z_out(jk) = z_out(jk-1) + 0.5_wp * h_out(jk) 1074 END DO1060 END DO 1075 1061 1076 1062 IF (N_in*N_out > 0) THEN … … 1286 1272 WRITE(numout,*) ' Agrif error for e3t_0: parent , child, i, j, k ', & 1287 1273 & ptab(ji,jj,jk), tmask(ji,jj,jk) * e3t_0(ji,jj,jk), & 1288 & ji+nimpp-1, jj+njmpp-1, jk1289 kindic_agr = kindic_agr + 11274 & mig0(ji), mig0(jj), jk 1275 ! kindic_agr = kindic_agr + 1 1290 1276 ENDIF 1291 1277 END DO … … 1296 1282 ! 1297 1283 END SUBROUTINE interpe3t 1284 1285 SUBROUTINE interpglamt( ptab, i1, i2, j1, j2, before ) 1286 !!---------------------------------------------------------------------- 1287 !! *** ROUTINE interpglamt *** 1288 !!---------------------------------------------------------------------- 1289 INTEGER , INTENT(in ) :: i1, i2, j1, j2 1290 REAL(wp),DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 1291 LOGICAL , INTENT(in ) :: before 1292 ! 1293 INTEGER :: ji, jj, jk 1294 REAL(wp):: ztst 1295 !!---------------------------------------------------------------------- 1296 ! 1297 IF( before ) THEN 1298 ptab(i1:i2,j1:j2) = glamt(i1:i2,j1:j2) 1299 ELSE 1300 ztst = MAXVAL(ABS(glamt(i1:i2,j1:j2)))*1.e-4 1301 DO jj = j1, j2 1302 DO ji = i1, i2 1303 IF( ABS( ptab(ji,jj) - glamt(ji,jj) ) > ztst ) THEN 1304 WRITE(numout,*) ' Agrif error for glamt: parent, child, i, j ', ptab(ji,jj), glamt(ji,jj), mig0(ji), mig0(jj) 1305 ! kindic_agr = kindic_agr + 1 1306 ENDIF 1307 END DO 1308 END DO 1309 ENDIF 1310 ! 1311 END SUBROUTINE interpglamt 1312 1313 1314 SUBROUTINE interpgphit( ptab, i1, i2, j1, j2, before ) 1315 !!---------------------------------------------------------------------- 1316 !! *** ROUTINE interpgphit *** 1317 !!---------------------------------------------------------------------- 1318 INTEGER , INTENT(in ) :: i1, i2, j1, j2 1319 REAL(wp),DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 1320 LOGICAL , INTENT(in ) :: before 1321 ! 1322 INTEGER :: ji, jj, jk 1323 REAL(wp):: ztst 1324 !!---------------------------------------------------------------------- 1325 ! 1326 IF( before ) THEN 1327 ptab(i1:i2,j1:j2) = gphit(i1:i2,j1:j2) 1328 ELSE 1329 ztst = MAXVAL(ABS(gphit(i1:i2,j1:j2)))*1.e-4 1330 DO jj = j1, j2 1331 DO ji = i1, i2 1332 IF( ABS( ptab(ji,jj) - gphit(ji,jj) ) > ztst ) THEN 1333 WRITE(numout,*) ' Agrif error for gphit: parent, child, i, j ', ptab(ji,jj), gphit(ji,jj), mig0(ji), mig0(jj) 1334 ! kindic_agr = kindic_agr + 1 1335 ENDIF 1336 END DO 1337 END DO 1338 ENDIF 1339 ! 1340 END SUBROUTINE interpgphit 1341 1298 1342 1299 1343 SUBROUTINE interpavm( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before ) … … 1368 1412 DO jk = 1, N_out ! Child vertical grid 1369 1413 z_out(jk) = gdepw(ji,jj,jk,Kmm_a) 1370 END DO1414 END DO 1371 1415 IF (N_in*N_out > 0) THEN 1372 1416 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) 1373 1417 ENDIF 1374 END DO1375 END DO1418 END DO 1419 END DO 1376 1420 ELSE 1377 1421 avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2,1) … … 1381 1425 END SUBROUTINE interpavm 1382 1426 1427 1383 1428 SUBROUTINE interpmbkt( ptab, i1, i2, j1, j2, before ) 1384 1429 !!---------------------------------------------------------------------- … … 1399 1444 END SUBROUTINE interpmbkt 1400 1445 1446 1401 1447 SUBROUTINE interpht0( ptab, i1, i2, j1, j2, before ) 1402 1448 !!---------------------------------------------------------------------- … … 1417 1463 END SUBROUTINE interpht0 1418 1464 1465 1419 1466 SUBROUTINE agrif_initts(tabres,i1,i2,j1,j2,k1,k2,m1,m2,before) 1420 1467 INTEGER :: i1, i2, j1, j2, k1, k2, m1, m2 … … 1435 1482 END SUBROUTINE agrif_initts 1436 1483 1484 1437 1485 SUBROUTINE agrif_initssh( ptab, i1, i2, j1, j2, before ) 1438 1486 !!---------------------------------------------------------------------- -
NEMO/trunk/src/NST/agrif_oce_sponge.F90
r13226 r13286 78 78 zcoef = REAL(Agrif_rhot()-1,wp)/REAL(Agrif_rhot()) 79 79 80 Agrif_SpecialValue =0.80 Agrif_SpecialValue = 0._wp 81 81 Agrif_UseSpecialValue = ln_spc_dyn 82 use_sign_north = .TRUE.83 sign_north = -1.82 use_sign_north = .TRUE. 83 sign_north = -1._wp 84 84 ! 85 85 tabspongedone_u = .FALSE. … … 92 92 ! 93 93 Agrif_UseSpecialValue = .FALSE. 94 use_sign_north = .FALSE.94 use_sign_north = .FALSE. 95 95 #endif 96 96 ! … … 109 109 REAL(wp) :: z1_ispongearea, z1_jspongearea 110 110 REAL(wp), DIMENSION(jpi,jpj) :: ztabramp 111 #if defined key_vertical 112 REAL(wp), DIMENSION(jpi,jpj) :: ztabrampu 113 REAL(wp), DIMENSION(jpi,jpj) :: ztabrampv 114 #endif 111 115 REAL(wp), DIMENSION(jpjmax) :: zmskwest, zmskeast 112 116 REAL(wp), DIMENSION(jpimax) :: zmsknorth, zmsksouth … … 129 133 ! Retrieve masks at open boundaries: 130 134 131 ! --- West --- ! 132 IF( lk_west) THEN 135 IF( lk_west ) THEN ! --- West --- ! 133 136 ztabramp(:,:) = 0._wp 134 ind1 = 1+nbghostcells137 ind1 = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 135 138 DO ji = mi0(ind1), mi1(ind1) 136 139 ztabramp(ji,:) = ssumask(ji,:) 137 140 END DO 138 ! 139 zmskwest(:) = 0._wp 140 zmskwest(1:jpj) = MAXVAL(ztabramp(:,:), dim=1) 141 zmskwest( 1:jpj ) = MAXVAL(ztabramp(:,:), dim=1) 142 zmskwest(jpj+1:jpjmax) = 0._wp 141 143 ENDIF 142 143 ! --- East --- ! 144 IF( lk_east ) THEN 144 IF( lk_east ) THEN ! --- East --- ! 145 145 ztabramp(:,:) = 0._wp 146 ind1 = jpiglo - nbghostcells - 1146 ind1 = jpiglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells 147 147 DO ji = mi0(ind1), mi1(ind1) 148 148 ztabramp(ji,:) = ssumask(ji,:) 149 149 END DO 150 ! 151 zmskeast(:) = 0._wp 152 zmskeast(1:jpj) = MAXVAL(ztabramp(:,:), dim=1) 150 zmskeast( 1:jpj ) = MAXVAL(ztabramp(:,:), dim=1) 151 zmskeast(jpj+1:jpjmax) = 0._wp 153 152 ENDIF 154 155 ! --- South --- ! 156 IF( lk_south ) THEN 153 IF( lk_south ) THEN ! --- South --- ! 157 154 ztabramp(:,:) = 0._wp 158 ind1 = 1+nbghostcells155 ind1 = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 159 156 DO jj = mj0(ind1), mj1(ind1) 160 157 ztabramp(:,jj) = ssvmask(:,jj) 161 158 END DO 162 ! 163 zmsksouth(:) = 0._wp 164 zmsksouth(1:jpi) = MAXVAL(ztabramp(:,:), dim=2) 159 zmsksouth( 1:jpi ) = MAXVAL(ztabramp(:,:), dim=2) 160 zmsksouth(jpi+1:jpimax) = 0._wp 165 161 ENDIF 166 167 ! --- North --- ! 168 IF( lk_north) THEN 162 IF( lk_north ) THEN ! --- North --- ! 169 163 ztabramp(:,:) = 0._wp 170 ind1 = jpjglo - nbghostcells - 1164 ind1 = jpjglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells 171 165 DO jj = mj0(ind1), mj1(ind1) 172 166 ztabramp(:,jj) = ssvmask(:,jj) 173 167 END DO 174 ! 175 zmsknorth(:) = 0._wp 176 zmsknorth(1:jpi) = MAXVAL(ztabramp(:,:), dim=2) 168 zmsknorth( 1:jpi ) = MAXVAL(ztabramp(:,:), dim=2) 169 zmsknorth(jpi+1:jpimax) = 0._wp 177 170 ENDIF 178 171 … … 180 173 zmskwest(:) = 1._wp 181 174 zmskeast(:) = 1._wp 175 zmsksouth(:) = 1._wp 182 176 zmsknorth(:) = 1._wp 183 zmsksouth(:) = 1._wp184 177 #if defined key_mpp_mpi 185 178 ! CALL mpp_max( 'AGRIF_sponge', zmskwest(:) , jpjmax ) … … 192 185 ! Store it in ztabramp 193 186 194 ispongearea = nn_sponge_len * Agrif_irhox()195 z1_ispongearea = 1._wp / REAL( ispongearea )196 jspongearea = nn_sponge_len * Agrif_irhoy()197 z1_jspongearea = 1._wp / REAL( jspongearea )187 ispongearea = nn_sponge_len * Agrif_irhox() 188 z1_ispongearea = 1._wp / REAL( ispongearea, wp ) 189 jspongearea = nn_sponge_len * Agrif_irhoy() 190 z1_jspongearea = 1._wp / REAL( jspongearea, wp ) 198 191 199 192 ztabramp(:,:) = 0._wp … … 203 196 IF ( nbcellsy <= 3 ) jspongearea = -1 204 197 205 ! --- West --- ! 206 IF(lk_west) THEN 207 ind1 = 1+nbghostcells 208 ind2 = 1+nbghostcells + ispongearea 198 IF( lk_west ) THEN ! --- West --- ! 199 ind1 = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 200 ind2 = nn_hls + 1 + nbghostcells + ispongearea 209 201 DO ji = mi0(ind1), mi1(ind2) 210 202 DO jj = 1, jpj 211 ztabramp(ji,jj) = REAL( ind2 - mig(ji) ) * z1_ispongearea * zmskwest(jj) 212 END DO 213 END DO 214 203 ztabramp(ji,jj) = REAL(ind2 - mig(ji), wp) * z1_ispongearea * zmskwest(jj) 204 END DO 205 END DO 215 206 ! ghost cells: 216 207 ind1 = 1 217 ind2 = n bghostcells + 1208 ind2 = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 218 209 DO ji = mi0(ind1), mi1(ind2) 219 210 DO jj = 1, jpj … … 222 213 END DO 223 214 ENDIF 224 225 ! --- East --- ! 226 IF(lk_east) THEN 227 ind1 = jpiglo - nbghostcells - ispongearea 228 ind2 = jpiglo - nbghostcells 215 IF( lk_east ) THEN ! --- East --- ! 216 ind1 = jpiglo - ( nn_hls + nbghostcells ) - ispongearea 217 ind2 = jpiglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 229 218 DO ji = mi0(ind1), mi1(ind2) 230 231 219 DO jj = 1, jpj 232 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( mig(ji) - ind1 ) * z1_ispongearea) * zmskeast(jj) 233 ENDDO 234 END DO 235 220 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL(mig(ji) - ind1, wp) * z1_ispongearea ) * zmskeast(jj) 221 END DO 222 END DO 236 223 ! ghost cells: 237 ind1 = jpiglo - nbghostcells224 ind1 = jpiglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 238 225 ind2 = jpiglo 239 226 DO ji = mi0(ind1), mi1(ind2) 240 241 227 DO jj = 1, jpj 242 228 ztabramp(ji,jj) = zmskeast(jj) 243 ENDDO 244 END DO 245 ENDIF 246 247 ! --- South --- ! 248 IF( lk_south ) THEN 249 ind1 = 1+nbghostcells 250 ind2 = 1+nbghostcells + jspongearea 229 END DO 230 END DO 231 ENDIF 232 IF( lk_south ) THEN ! --- South --- ! 233 ind1 = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 234 ind2 = nn_hls + 1 + nbghostcells + jspongearea 251 235 DO jj = mj0(ind1), mj1(ind2) 252 236 DO ji = 1, jpi 253 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( ind2 - mjg(jj) ) * z1_jspongearea) * zmsksouth(ji) 254 END DO 255 END DO 256 237 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL(ind2 - mjg(jj), wp) * z1_jspongearea ) * zmsksouth(ji) 238 END DO 239 END DO 257 240 ! ghost cells: 258 241 ind1 = 1 259 ind2 = n bghostcells + 1242 ind2 = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 260 243 DO jj = mj0(ind1), mj1(ind2) 261 244 DO ji = 1, jpi … … 264 247 END DO 265 248 ENDIF 266 267 ! --- North --- ! 268 IF( lk_north ) THEN 269 ind1 = jpjglo - nbghostcells - jspongearea 270 ind2 = jpjglo - nbghostcells 249 IF( lk_north ) THEN ! --- North --- ! 250 ind1 = jpjglo - ( nn_hls + nbghostcells ) - jspongearea 251 ind2 = jpjglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 271 252 DO jj = mj0(ind1), mj1(ind2) 272 253 DO ji = 1, jpi 273 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( mjg(jj) - ind1 ) * z1_jspongearea) * zmsknorth(ji) 274 END DO 275 END DO 276 254 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL(mjg(jj) - ind1, wp) * z1_jspongearea ) * zmsknorth(ji) 255 END DO 256 END DO 277 257 ! ghost cells: 278 ind1 = jpjglo - nbghostcells258 ind1 = jpjglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 279 259 ind2 = jpjglo 280 260 DO jj = mj0(ind1), mj1(ind2) … … 284 264 END DO 285 265 ENDIF 286 266 ! 287 267 ENDIF 288 268 … … 295 275 fspv(ji,jj) = 0.5_wp * ( ztabramp(ji,jj) + ztabramp(ji ,jj+1) ) * ssvmask(ji,jj) 296 276 END_2D 297 CALL lbc_lnk( 'agrif_Sponge', fspu, 'U', 1.0_wp ) ! Lateral boundary conditions298 CALL lbc_lnk( 'agrif_Sponge', fspv, 'V', 1.0_wp )299 300 spongedoneT = .TRUE.301 277 ENDIF 302 278 … … 311 287 & * ssvmask(ji,jj) * ssvmask(ji,jj+1) 312 288 END_2D 313 CALL lbc_lnk( 'agrif_Sponge', fspt, 'T', 1.0_wp ) ! Lateral boundary conditions 314 CALL lbc_lnk( 'agrif_Sponge', fspf, 'F', 1.0_wp ) 315 289 ENDIF 290 291 IF( .NOT. spongedoneT .AND. .NOT. spongedoneU ) THEN 292 CALL lbc_lnk_multi( 'agrif_Sponge', fspu, 'U', 1._wp, fspv, 'V', 1._wp, fspt, 'T', 1._wp, fspf, 'F', 1._wp ) 293 spongedoneT = .TRUE. 294 spongedoneU = .TRUE. 295 ENDIF 296 IF( .NOT. spongedoneT ) THEN 297 CALL lbc_lnk_multi( 'agrif_Sponge', fspu, 'U', 1._wp, fspv, 'V', 1._wp ) 298 spongedoneT = .TRUE. 299 ENDIF 300 IF( .NOT. spongedoneT .AND. .NOT. spongedoneU ) THEN 301 CALL lbc_lnk_multi( 'agrif_Sponge', fspt, 'T', 1._wp, fspf, 'F', 1._wp ) 316 302 spongedoneU = .TRUE. 317 303 ENDIF … … 334 320 END_2D 335 321 ! 336 ztabramp(:,:) = REAL( mbkt_parent(:,:), wp ) ; CALL lbc_lnk( 'Agrif_Sponge', ztabramp, 'T', 1.0_wp ) 337 mbkt_parent(:,:) = NINT( ztabramp(:,:) ) 338 ztabramp(:,:) = REAL( mbku_parent(:,:), wp ) ; CALL lbc_lnk( 'Agrif_Sponge', ztabramp, 'U', 1.0_wp ) 339 mbku_parent(:,:) = NINT( ztabramp(:,:) ) 340 ztabramp(:,:) = REAL( mbkv_parent(:,:), wp ) ; CALL lbc_lnk( 'Agrif_Sponge', ztabramp, 'V', 1.0_wp ) 341 mbkv_parent(:,:) = NINT( ztabramp(:,:) ) 322 ztabramp (:,:) = REAL( mbkt_parent (:,:), wp ) 323 ztabrampu(:,:) = REAL( mbku_parentu(:,:), wp ) 324 ztabrampv(:,:) = REAL( mbkv_parentv(:,:), wp ) 325 CALL lbc_lnk_multi( 'Agrif_Sponge', ztabramp, 'T', 1._wp, ztabrampu, 'U', 1._wp, ztabrampv, 'V', 1._wp ) 326 mbkt_parent(:,:) = NINT( ztabramp (:,:) ) 327 mbku_parent(:,:) = NINT( ztabrampu(:,:) ) 328 mbkv_parent(:,:) = NINT( ztabrampv(:,:) ) 342 329 #endif 343 330 ! … … 346 333 END SUBROUTINE Agrif_Sponge 347 334 335 348 336 SUBROUTINE interptsn_sponge( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) 349 337 !!---------------------------------------------------------------------- … … 433 421 N_out = N_out + 1 434 422 h_out(jk) = e3t(ji,jj,jk,Kbb_a) !Child grid scale factors. Could multiply by e1e2t here instead of division above 435 END DO423 END DO 436 424 437 425 ! Account for small differences in free-surface … … 444 432 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) 445 433 ENDIF 446 END DO447 END DO434 END DO 435 END DO 448 436 # endif 449 437 … … 456 444 tsbdiff(ji,jj,jk,1:jpts) = (ts(ji,jj,jk,1:jpts,Kbb_a) - tabres(ji,jj,jk,1:jpts))*tmask(ji,jj,jk) 457 445 # endif 458 END DO459 END DO460 END DO446 END DO 447 END DO 448 END DO 461 449 462 450 DO jn = 1, jpts … … 513 501 END SUBROUTINE interptsn_sponge 514 502 503 515 504 SUBROUTINE interpun_sponge(tabres,i1,i2,j1,j2,k1,k2,m1,m2, before) 516 505 !!--------------------------------------------- … … 521 510 LOGICAL, INTENT(in) :: before 522 511 523 INTEGER :: ji,jj,jk,jmax524 512 INTEGER :: ji,jj,jk,jmax 513 INTEGER :: ind1 525 514 ! sponge parameters 526 515 REAL(wp) :: ze2u, ze1v, zua, zva, zbtr, zhtot … … 586 575 zhtot = zhtot + h_in(jk) 587 576 tabin(jk) = tabres(ji,jj,jk,m1) 588 END DO577 END DO 589 578 ! 590 579 N_out = 0 … … 593 582 N_out = N_out + 1 594 583 h_out(N_out) = e3u(ji,jj,jk,Kbb_a) 595 END DO584 END DO 596 585 597 586 ! Account for small differences in free-surface … … 605 594 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) 606 595 ENDIF 607 END DO608 END DO596 END DO 597 END DO 609 598 610 599 ubdiff(i1:i2,j1:j2,:) = (uu(i1:i2,j1:j2,:,Kbb_a) - tabres_child(i1:i2,j1:j2,:))*umask(i1:i2,j1:j2,:) … … 659 648 660 649 jmax = j2-1 661 ! IF (lk_north) jmax = MIN(jmax,nlcj-nbghostcells-2) ! North 662 IF ((nbondj == 1).OR.(nbondj == 2)) jmax = MIN(jmax,nlcj-nbghostcells-2) ! North 650 ind1 = jpjglo - ( nn_hls + nbghostcells + 2 ) ! North 651 DO jj = mj0(ind1), mj1(ind1) 652 jmax = MIN(jmax,jj) 653 END DO 663 654 664 655 DO jj = j1+1, jmax … … 688 679 END SUBROUTINE interpun_sponge 689 680 690 SUBROUTINE interpvn_sponge(tabres,i1,i2,j1,j2,k1,k2,m1,m2, before,nb,ndir) 681 682 SUBROUTINE interpvn_sponge(tabres,i1,i2,j1,j2,k1,k2,m1,m2, before) 691 683 !!--------------------------------------------- 692 684 !! *** ROUTINE interpvn_sponge *** … … 695 687 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: tabres 696 688 LOGICAL, INTENT(in) :: before 697 INTEGER, INTENT(in) :: nb , ndir698 689 ! 699 690 INTEGER :: ji, jj, jk, imax 691 INTEGER :: ind1 700 692 REAL(wp) :: ze2u, ze1v, zua, zva, zbtr, zhtot 701 693 REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: vbdiff … … 759 751 zhtot = zhtot + h_in(jk) 760 752 tabin(jk) = tabres(ji,jj,jk,m1) 761 END DO753 END DO 762 754 ! 763 755 N_out = 0 … … 766 758 N_out = N_out + 1 767 759 h_out(N_out) = e3v(ji,jj,jk,Kbb_a) 768 END DO760 END DO 769 761 770 762 ! Account for small differences in free-surface … … 778 770 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) 779 771 ENDIF 780 END DO781 END DO772 END DO 773 END DO 782 774 783 775 vbdiff(i1:i2,j1:j2,:) = (vv(i1:i2,j1:j2,:,Kbb_a) - tabres_child(i1:i2,j1:j2,:))*vmask(i1:i2,j1:j2,:) … … 812 804 813 805 imax = i2 - 1 814 ! IF(lk_east) imax = MIN(imax,nlci-nbghostcells-2) ! East 815 IF ((nbondi == 1).OR.(nbondi == 2)) imax = MIN(imax,nlci-nbghostcells-2) ! East 816 806 ind1 = jpiglo - ( nn_hls + nbghostcells + 2 ) ! East 807 DO ji = mi0(ind1), mi1(ind1) 808 imax = MIN(imax,ji) 809 END DO 810 817 811 DO jj = j1+1, j2 818 812 DO ji = i1+1, imax ! vector opt. -
NEMO/trunk/src/NST/agrif_oce_update.F90
r13216 r13286 85 85 86 86 Agrif_UseSpecialValueInUpdate = .FALSE. 87 Agrif_SpecialValueFineGrid = 0.87 Agrif_SpecialValueFineGrid = 0._wp 88 88 89 89 use_sign_north = .TRUE. 90 sign_north = -1.90 sign_north = -1._wp 91 91 92 92 ! … … 144 144 ! 145 145 Agrif_UseSpecialValueInUpdate = .TRUE. 146 Agrif_SpecialValueFineGrid = 0. 146 Agrif_SpecialValueFineGrid = 0._wp 147 147 # if ! defined DECAL_FEEDBACK_2D 148 148 CALL Agrif_Update_Variable(sshn_id,procname = updateSSH) … … 156 156 IF ( ln_dynspg_ts.AND.ln_bt_fw ) THEN 157 157 use_sign_north = .TRUE. 158 sign_north = -1. 158 sign_north = -1._wp 159 159 ! Refluxing on ssh: 160 160 # if defined DECAL_FEEDBACK_2D -
NEMO/trunk/src/NST/agrif_user.F90
r13226 r13286 11 11 END SUBROUTINE agrif_user 12 12 13 13 14 SUBROUTINE agrif_before_regridding 14 15 END SUBROUTINE agrif_before_regridding 15 16 17 16 18 SUBROUTINE Agrif_InitWorkspace 17 19 END SUBROUTINE Agrif_InitWorkspace 18 20 21 19 22 SUBROUTINE Agrif_InitValues 20 23 !!---------------------------------------------------------------------- … … 38 41 END SUBROUTINE Agrif_initvalues 39 42 40 SUBROUTINE agrif_istate( Kbb, Kmm, Kaa ) 41 42 USE domvvl 43 USE domain 44 USE par_oce 45 USE agrif_oce 46 USE agrif_oce_interp 47 USE oce 48 USE lib_mpp 49 USe lbclnk 50 43 44 SUBROUTINE Agrif_Istate( Kbb, Kmm, Kaa ) 45 !!---------------------------------------------------------------------- 46 !! *** ROUTINE agrif_istate *** 47 !!---------------------------------------------------------------------- 48 USE domvvl 49 USE domain 50 USE par_oce 51 USE agrif_oce 52 USE agrif_oce_interp 53 USE oce 54 USE lib_mpp 55 USE lbclnk 56 ! 57 IMPLICIT NONE 58 ! 51 59 INTEGER, INTENT(in) :: Kbb, Kmm, Kaa 52 60 INTEGER :: jn 53 61 !!---------------------------------------------------------------------- 54 62 IF(lwp) WRITE(numout,*) ' ' 55 63 IF(lwp) WRITE(numout,*) 'AGRIF: interp child initial state from parent' 56 64 IF(lwp) WRITE(numout,*) ' ' 57 65 58 l_ini_child = .TRUE.59 Agrif_SpecialValue = 0. _wp66 l_ini_child = .TRUE. 67 Agrif_SpecialValue = 0.0_wp 60 68 Agrif_UseSpecialValue = .TRUE. 61 uu(:,:,:,:) = 0. ; vv(:,:,:,:) = 0. ; ts(:,:,:,:,:) = 0.69 uu(:,:,:,:) = 0.0_wp ; vv(:,:,:,:) = 0.0_wp ; ts(:,:,:,:,:) = 0.0_wp 62 70 63 Krhs_a = Kbb ;Kmm_a = Kbb71 Krhs_a = Kbb ; Kmm_a = Kbb 64 72 65 73 ! Brutal fix to pas 1x1 refinment. … … 79 87 use_sign_north = .FALSE. 80 88 81 Agrif_UseSpecialValue = .FALSE. !82 l_ini_child = .FALSE.83 84 Krhs_a = Kaa ;Kmm_a = Kmm89 Agrif_UseSpecialValue = .FALSE. 90 l_ini_child = .FALSE. 91 92 Krhs_a = Kaa ; Kmm_a = Kmm 85 93 86 94 DO jn = 1, jpts 87 95 ts(:,:,:,jn,Kbb) = ts(:,:,:,jn,Kbb)*tmask(:,:,:) 88 96 END DO 89 uu(:,:,:,Kbb) = uu(:,:,:,Kbb) * umask(:,:,:) 90 vv(:,:,:,Kbb) = vv(:,:,:,Kbb) * vmask(:,:,:) 91 92 93 CALL lbc_lnk_multi( 'agrif_istate', uu(:,:,:,Kbb), 'U', -1. , vv(:,:,:,Kbb), 'V', -1. ) 94 CALL lbc_lnk( 'agrif_istate', ts(:,:,:,:,Kbb), 'T', 1. ) 95 96 END SUBROUTINE agrif_istate 97 97 uu(:,:,:,Kbb) = uu(:,:,:,Kbb) * umask(:,:,:) 98 vv(:,:,:,Kbb) = vv(:,:,:,Kbb) * vmask(:,:,:) 99 100 101 CALL lbc_lnk_multi( 'agrif_istate', uu(:,:,: ,Kbb), 'U', -1.0_wp , vv(:,:,:,Kbb), 'V', -1.0_wp ) 102 CALL lbc_lnk( 'agrif_istate', ts(:,:,:,:,Kbb), 'T', 1.0_wp ) 103 104 END SUBROUTINE Agrif_Istate 105 106 98 107 SUBROUTINE agrif_declare_var_ini 99 108 !!---------------------------------------------------------------------- 100 !! *** ROUTINE agrif_declare_var ***109 !! *** ROUTINE agrif_declare_var_ini *** 101 110 !!---------------------------------------------------------------------- 102 111 USE agrif_util … … 110 119 ! 111 120 INTEGER :: ind1, ind2, ind3 121 INTEGER :: its 112 122 External :: nemo_mapping 113 123 !!---------------------------------------------------------------------- … … 126 136 ! 1. Declaration of the type of variable which have to be interpolated 127 137 !--------------------------------------------------------------------- 128 ind1 = nbghostcells 129 ind2 = 2 + nbghostcells_x 130 ind3 = 2 + nbghostcells_y_s 131 132 CALL agrif_declare_variable((/2,2,0/),(/ind2,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),e3t_id) 133 CALL agrif_declare_variable((/2,2/) ,(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),mbkt_id) 134 CALL agrif_declare_variable((/2,2/) ,(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ht0_id) 135 136 CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),e1u_id) 137 CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),e2v_id) 138 138 ind1 = nbghostcells 139 ind2 = nn_hls + 2 + nbghostcells_x 140 ind3 = nn_hls + 2 + nbghostcells_y_s 141 142 CALL agrif_declare_variable((/2,2,0 /),(/ind2 ,ind3,0 /),(/'x','y','N' /),(/1,1,1 /),(/jpi,jpj,jpk /), e3t_id) 143 CALL agrif_declare_variable((/2,2 /),(/ind2 ,ind3 /),(/'x','y' /),(/1,1 /),(/jpi,jpj /), mbkt_id) 144 CALL agrif_declare_variable((/2,2 /),(/ind2 ,ind3 /),(/'x','y' /),(/1,1 /),(/jpi,jpj /), ht0_id) 145 146 CALL agrif_declare_variable((/1,2 /),(/ind2-1,ind3 /),(/'x','y' /),(/1,1 /),(/jpi,jpj /), e1u_id) 147 CALL agrif_declare_variable((/2,1 /),(/ind2 ,ind3-1 /),(/'x','y' /),(/1,1 /),(/jpi,jpj /), e2v_id) 139 148 140 149 ! Initial or restart velues 141 142 CALL agrif_declare_variable((/2,2,0,0/),(/ind2 ,ind3 ,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/ nlci,nlcj,jpk,jpts+1/),tsini_id)143 CALL agrif_declare_variable((/1,2,0,0/),(/ind2-1,ind3 ,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/ nlci,nlcj,jpk,2/) ,uini_id)144 CALL agrif_declare_variable((/2,1,0,0/),(/ind2 ,ind3-1,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/ nlci,nlcj,jpk,2/) ,vini_id)145 CALL agrif_declare_variable((/2,2 /) ,(/ind2,ind3/) ,(/'x','y'/),(/1,1/),(/nlci,nlcj/),sshini_id)150 its = jpts+1 151 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) 152 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) 153 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) 154 CALL agrif_declare_variable((/2,2 /),(/ind2 ,ind3 /),(/'x','y' /),(/1,1 /),(/jpi,jpj /),sshini_id) 146 155 ! 147 156 148 157 ! 2. Type of interpolation 149 158 !------------------------- 150 CALL Agrif_Set_bcinterp( e3t_id,interp=AGRIF_constant)151 152 CALL Agrif_Set_bcinterp( mbkt_id,interp=AGRIF_constant)153 CALL Agrif_Set_interp ( mbkt_id,interp=AGRIF_constant)154 CALL Agrif_Set_bcinterp( ht0_id ,interp=AGRIF_constant)155 CALL Agrif_Set_interp ( ht0_id ,interp=AGRIF_constant)156 157 CALL Agrif_Set_bcinterp( e1u_id,interp1=Agrif_linear, interp2=AGRIF_ppm )158 CALL Agrif_Set_bcinterp( e2v_id,interp1=AGRIF_ppm , interp2=Agrif_linear )159 CALL Agrif_Set_bcinterp( e3t_id,interp =AGRIF_constant) 160 161 CALL Agrif_Set_bcinterp( mbkt_id,interp =AGRIF_constant) 162 CALL Agrif_Set_interp ( mbkt_id,interp =AGRIF_constant) 163 CALL Agrif_Set_bcinterp( ht0_id,interp =AGRIF_constant) 164 CALL Agrif_Set_interp ( ht0_id,interp =AGRIF_constant) 165 166 CALL Agrif_Set_bcinterp( e1u_id,interp1=Agrif_linear, interp2=AGRIF_ppm ) 167 CALL Agrif_Set_bcinterp( e2v_id,interp1=AGRIF_ppm , interp2=Agrif_linear ) 159 168 160 169 ! Initial fields 161 CALL Agrif_Set_bcinterp( tsini_id ,interp=AGRIF_linear)162 CALL Agrif_Set_interp ( tsini_id ,interp=AGRIF_linear)163 CALL Agrif_Set_bcinterp( uini_id ,interp=AGRIF_linear)164 CALL Agrif_Set_interp ( uini_id ,interp=AGRIF_linear)165 CALL Agrif_Set_bcinterp( vini_id ,interp=AGRIF_linear)166 CALL Agrif_Set_interp ( vini_id ,interp=AGRIF_linear)167 CALL Agrif_Set_bcinterp(sshini_id,interp =AGRIF_linear)168 CALL Agrif_Set_interp (sshini_id,interp =AGRIF_linear)170 CALL Agrif_Set_bcinterp( tsini_id,interp =AGRIF_linear ) 171 CALL Agrif_Set_interp ( tsini_id,interp =AGRIF_linear ) 172 CALL Agrif_Set_bcinterp( uini_id,interp =AGRIF_linear ) 173 CALL Agrif_Set_interp ( uini_id,interp =AGRIF_linear ) 174 CALL Agrif_Set_bcinterp( vini_id,interp =AGRIF_linear ) 175 CALL Agrif_Set_interp ( vini_id,interp =AGRIF_linear ) 176 CALL Agrif_Set_bcinterp(sshini_id,interp =AGRIF_linear ) 177 CALL Agrif_Set_interp (sshini_id,interp =AGRIF_linear ) 169 178 170 179 ! 3. Location of interpolation … … 172 181 ! CALL Agrif_Set_bc( e3t_id, (/-nn_sponge_len*Agrif_irhox(),ind1-1/) ) 173 182 ! JC: check near the boundary only until matching in sponge has been sorted out: 174 CALL Agrif_Set_bc( e3t_id, (/0,ind1-1/) )183 CALL Agrif_Set_bc( e3t_id, (/0,ind1-1/) ) 175 184 176 185 ! extend the interpolation zone by 1 more point than necessary: 177 186 ! RB check here 178 CALL Agrif_Set_bc( mbkt_id, (/-nn_sponge_len*Agrif_irhox()-2,ind1/) )179 CALL Agrif_Set_bc( ht0_id,(/-nn_sponge_len*Agrif_irhox()-2,ind1/) )187 CALL Agrif_Set_bc( mbkt_id, (/-nn_sponge_len*Agrif_irhox()-2,ind1/) ) 188 CALL Agrif_Set_bc( ht0_id, (/-nn_sponge_len*Agrif_irhox()-2,ind1/) ) 180 189 181 CALL Agrif_Set_bc( e1u_id,(/0,ind1-1/))182 CALL Agrif_Set_bc( e2v_id,(/0,ind1-1/))183 184 CALL Agrif_Set_bc( tsini_id, (/0,ind1-1/) ) ! if west, rhox=3 and nbghost=3: columns 2 to 4185 CALL Agrif_Set_bc( uini_id, (/0,ind1-1/) )186 CALL Agrif_Set_bc( vini_id, (/0,ind1-1/) )190 CALL Agrif_Set_bc( e1u_id, (/0,ind1-1/) ) 191 CALL Agrif_Set_bc( e2v_id, (/0,ind1-1/) ) 192 193 CALL Agrif_Set_bc( tsini_id, (/0,ind1-1/) ) ! if west, rhox=3 and nbghost=3: columns 2 to 4 194 CALL Agrif_Set_bc( uini_id, (/0,ind1-1/) ) 195 CALL Agrif_Set_bc( vini_id, (/0,ind1-1/) ) 187 196 CALL Agrif_Set_bc( sshini_id, (/0,ind1-1/) ) 188 197 … … 190 199 !--------------- 191 200 # if defined UPD_HIGH 192 CALL Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Average , update2=Agrif_Update_Full_Weighting)193 CALL Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Full_Weighting, update2=Agrif_Update_Average )201 CALL Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Average , update2=Agrif_Update_Full_Weighting) 202 CALL Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Full_Weighting, update2=Agrif_Update_Average ) 194 203 #else 195 CALL Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Copy , update2=Agrif_Update_Average)196 CALL Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Average , update2=Agrif_Update_Copy)204 CALL Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Copy , update2=Agrif_Update_Average ) 205 CALL Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Average , update2=Agrif_Update_Copy ) 197 206 #endif 198 207 … … 204 213 SUBROUTINE Agrif_Init_Domain( Kbb, Kmm, Kaa ) 205 214 !!---------------------------------------------------------------------- 206 !! *** ROUTINE Agrif_InitValues_cont_dom *** 207 !!---------------------------------------------------------------------- 208 209 !!---------------------------------------------------------------------- 210 !! *** ROUTINE Agrif_InitValues_cont *** 211 !! 212 !! ** Purpose :: Declaration of variables to be interpolated 213 !!---------------------------------------------------------------------- 215 !! *** ROUTINE Agrif_Init_Domain *** 216 !!---------------------------------------------------------------------- 214 217 USE agrif_oce_update 215 218 USE agrif_oce_interp … … 243 246 ! on the child grid 244 247 Agrif_UseSpecialValue = .FALSE. 245 ht0_parent( :,:) = 0._wp248 ht0_parent( :,:) = 0._wp 246 249 mbkt_parent(:,:) = 0 247 250 ! … … 255 258 ! and no refinement 256 259 DO_2D_10_10 257 mbku_parent(ji,jj) = MIN( mbkt_parent(ji+1,jj ) , mbkt_parent(ji,jj))258 mbkv_parent(ji,jj) = MIN( mbkt_parent(ji ,jj+1) , mbkt_parent(ji,jj))260 mbku_parent(ji,jj) = MIN( mbkt_parent(ji+1,jj ), mbkt_parent(ji,jj) ) 261 mbkv_parent(ji,jj) = MIN( mbkt_parent(ji ,jj+1), mbkt_parent(ji,jj) ) 259 262 END_2D 260 263 IF ( ln_sco.AND.Agrif_Parent(ln_sco) ) THEN … … 265 268 ELSE 266 269 DO_2D_10_10 267 hu0_parent(ji,jj) = MIN( ht0_parent(ji,jj), ht0_parent(ji+1,jj) )268 hv0_parent(ji,jj) = MIN( ht0_parent(ji,jj), ht0_parent(ji,jj+1) )270 hu0_parent(ji,jj) = MIN( ht0_parent(ji,jj), ht0_parent(ji+1,jj) ) 271 hv0_parent(ji,jj) = MIN( ht0_parent(ji,jj), ht0_parent(ji,jj+1) ) 269 272 END_2D 270 271 ENDIF 272 ! 273 CALL lbc_lnk( 'Agrif_Init_Domain', hu0_parent, 'U', 1.0_wp ) 274 CALL lbc_lnk( 'Agrif_Init_Domain', hv0_parent, 'V', 1.0_wp ) 275 zk(:,:) = REAL( mbku_parent(:,:), wp ) ; CALL lbc_lnk('Agrif_InitValues_cont', zk, 'U', 1.0_wp ) 276 mbku_parent(:,:) = MAX( NINT( zk(:,:) ), 1 ) ; 277 zk(:,:) = REAL( mbkv_parent(:,:), wp ) ; CALL lbc_lnk( 'Agrif_InitValues_cont', zk, 'V', 1.0_wp ) 273 ENDIF 274 ! 275 CALL lbc_lnk_multi( 'Agrif_Init_Domain', hu0_parent, 'U', 1.0_wp, hv0_parent, 'V', 1.0_wp ) 276 DO_2D_00_00 277 zk(ji,jj) = REAL( mbku_parent(ji,jj), wp ) 278 END_2D 279 CALL lbc_lnk( 'Agrif_InitValues_cont', zk, 'U', 1.0_wp ) 280 mbku_parent(:,:) = MAX( NINT( zk(:,:) ), 1 ) 281 DO_2D_00_00 282 zk(ji,jj) = REAL( mbkv_parent(ji,jj), wp ) 283 END_2D 284 CALL lbc_lnk( 'Agrif_InitValues_cont', zk, 'V', 1.0_wp ) 278 285 mbkv_parent(:,:) = MAX( NINT( zk(:,:) ), 1 ) 279 286 … … 333 340 334 341 SUBROUTINE Agrif_InitValues_cont 335 336 337 338 339 342 !!---------------------------------------------------------------------- 343 !! *** ROUTINE Agrif_InitValues_cont *** 344 !! 345 !! ** Purpose :: Declaration of variables to be interpolated 346 !!---------------------------------------------------------------------- 340 347 USE agrif_oce_update 341 348 USE agrif_oce_interp … … 367 374 Agrif_SpecialValue = 0._wp 368 375 Agrif_UseSpecialValue = .TRUE. 369 CALL Agrif_Bc_variable( tsn_id,calledweight=1.,procname=interptsn)376 CALL Agrif_Bc_variable( tsn_id,calledweight=1.,procname=interptsn) 370 377 CALL Agrif_Sponge 371 378 tabspongedone_tsn = .FALSE. … … 398 405 use_sign_north = .TRUE. 399 406 sign_north = -1. 400 CALL Agrif_Bc_variable( unb_id,calledweight=1.,procname=interpunb)401 CALL Agrif_Bc_variable( vnb_id,calledweight=1.,procname=interpvnb)407 CALL Agrif_Bc_variable( unb_id,calledweight=1.,procname=interpunb ) 408 CALL Agrif_Bc_variable( vnb_id,calledweight=1.,procname=interpvnb ) 402 409 CALL Agrif_Bc_variable(ub2b_interp_id,calledweight=1.,procname=interpub2b) 403 410 CALL Agrif_Bc_variable(vb2b_interp_id,calledweight=1.,procname=interpvb2b) … … 460 467 ! 1. Declaration of the type of variable which have to be interpolated 461 468 !--------------------------------------------------------------------- 462 463 ind1 = nbghostcells 464 ind2 = 2 + nbghostcells_x 465 ind3 = 2 + nbghostcells_y_s 466 469 ind1 = nbghostcells 470 ind2 = nn_hls + 2 + nbghostcells_x 471 ind3 = nn_hls + 2 + nbghostcells_y_s 467 472 # if defined key_vertical 468 CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/ nlci,nlcj,jpk,jpts+1/),tsn_id)469 CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/ nlci,nlcj,jpk,jpts+1/),tsn_sponge_id)470 CALL agrif_declare_variable((/1,2,0,0/),(/ind2-1,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/ nlci,nlcj,jpk,2/),un_interp_id)471 CALL agrif_declare_variable((/2,1,0,0/),(/ind2,ind3-1,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/ nlci,nlcj,jpk,2/),vn_interp_id)472 CALL agrif_declare_variable((/1,2,0,0/),(/ind2-1,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/ nlci,nlcj,jpk,2/),un_update_id)473 CALL agrif_declare_variable((/2,1,0,0/),(/ind2,ind3-1,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/ nlci,nlcj,jpk,2/),vn_update_id)474 CALL agrif_declare_variable((/1,2,0,0/),(/ind2-1,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/ nlci,nlcj,jpk,2/),un_sponge_id)475 CALL agrif_declare_variable((/2,1,0,0/),(/ind2,ind3-1,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/ nlci,nlcj,jpk,2/),vn_sponge_id)473 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) 474 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) 475 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) 476 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) 477 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) 478 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) 479 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) 480 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) 476 481 # else 477 CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/ nlci,nlcj,jpk,jpts/),tsn_id)478 CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/ nlci,nlcj,jpk,jpts/),tsn_sponge_id)479 CALL agrif_declare_variable((/1,2,0,0/),(/ind2-1,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/ nlci,nlcj,jpk,1/),un_interp_id)480 CALL agrif_declare_variable((/2,1,0,0/),(/ind2,ind3-1,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/ nlci,nlcj,jpk,1/),vn_interp_id)481 CALL agrif_declare_variable((/1,2,0,0/),(/ind2-1,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/ nlci,nlcj,jpk,1/),un_update_id)482 CALL agrif_declare_variable((/2,1,0,0/),(/ind2,ind3-1,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/ nlci,nlcj,jpk,1/),vn_update_id)483 CALL agrif_declare_variable((/1,2,0,0/),(/ind2-1,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/ nlci,nlcj,jpk,1/),un_sponge_id)484 CALL agrif_declare_variable((/2,1,0,0/),(/ind2,ind3-1,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/ nlci,nlcj,jpk,1/),vn_sponge_id)482 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) 483 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) 484 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) 485 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) 486 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) 487 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) 488 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) 489 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) 485 490 # endif 486 CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),unb_id) 487 CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vnb_id) 488 CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ub2b_interp_id) 489 CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vb2b_interp_id) 490 CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ub2b_update_id) 491 CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vb2b_update_id) 492 493 CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),sshn_id) 491 CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),unb_id) 492 CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/jpi,jpj/),vnb_id) 493 CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),ub2b_interp_id) 494 CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/jpi,jpj/),vb2b_interp_id) 495 CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),ub2b_update_id) 496 CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/jpi,jpj/),vb2b_update_id) 497 498 ! CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),glamt_id) 499 ! CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),gphit_id) 500 CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),sshn_id) 494 501 495 502 496 503 IF( ln_zdftke.OR.ln_zdfgls ) THEN ! logical not known at this point 497 ! CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/ nlci,nlcj,jpk/), en_id)498 ! CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/ nlci,nlcj,jpk/),avt_id)504 ! CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/), en_id) 505 ! CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avt_id) 499 506 # if defined key_vertical 500 CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/ nlci,nlcj,jpk,2/),avm_id)507 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) 501 508 # else 502 CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/ nlci,nlcj,jpk,1/),avm_id)509 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) 503 510 # endif 504 511 ENDIF … … 506 513 ! 2. Type of interpolation 507 514 !------------------------- 508 CALL Agrif_Set_bcinterp( tsn_id,interp=AGRIF_linear)509 CALL Agrif_Set_bcinterp( un_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm)510 CALL Agrif_Set_bcinterp( vn_interp_id,interp1=AGRIF_ppm,interp2=Agrif_linear)511 512 CALL Agrif_Set_bcinterp( tsn_sponge_id,interp=AGRIF_linear)513 CALL Agrif_Set_bcinterp( un_sponge_id,interp1=Agrif_linear,interp2=AGRIF_ppm)514 CALL Agrif_Set_bcinterp( vn_sponge_id,interp1=AGRIF_ppm,interp2=Agrif_linear)515 516 CALL Agrif_Set_bcinterp( sshn_id,interp=AGRIF_linear)517 CALL Agrif_Set_bcinterp( unb_id,interp1=Agrif_linear,interp2=AGRIF_ppm)518 CALL Agrif_Set_bcinterp( vnb_id,interp1=AGRIF_ppm,interp2=Agrif_linear)519 CALL Agrif_Set_bcinterp(ub2b_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm )520 CALL Agrif_Set_bcinterp(vb2b_interp_id,interp1=AGRIF_ppm ,interp2=Agrif_linear)515 CALL Agrif_Set_bcinterp( tsn_id,interp =AGRIF_linear) 516 CALL Agrif_Set_bcinterp( un_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm ) 517 CALL Agrif_Set_bcinterp( vn_interp_id,interp1=AGRIF_ppm ,interp2=Agrif_linear) 518 519 CALL Agrif_Set_bcinterp( tsn_sponge_id,interp =AGRIF_linear) 520 CALL Agrif_Set_bcinterp( un_sponge_id,interp1=Agrif_linear,interp2=AGRIF_ppm ) 521 CALL Agrif_Set_bcinterp( vn_sponge_id,interp1=AGRIF_ppm ,interp2=Agrif_linear) 522 523 CALL Agrif_Set_bcinterp( sshn_id,interp =AGRIF_linear) 524 CALL Agrif_Set_bcinterp( unb_id,interp1=Agrif_linear,interp2=AGRIF_ppm ) 525 CALL Agrif_Set_bcinterp( vnb_id,interp1=AGRIF_ppm ,interp2=Agrif_linear) 526 CALL Agrif_Set_bcinterp(ub2b_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm ) 527 CALL Agrif_Set_bcinterp(vb2b_interp_id,interp1=AGRIF_ppm ,interp2=Agrif_linear) 521 528 ! 522 529 ! > Divergence conserving alternative: … … 531 538 532 539 533 ! 3. Location of interpolation 540 ! CALL Agrif_Set_bcinterp(gphit_id,interp=AGRIF_constant) 541 ! CALL Agrif_Set_bcinterp(glamt_id,interp=AGRIF_constant) 542 543 ! 3. Location of interpolation 534 544 !----------------------------- 535 545 CALL Agrif_Set_bc( tsn_id, (/0,ind1-1/) ) ! if west, rhox=3 and nbghost=3: columns 2 to 4 … … 548 558 549 559 IF( ln_zdftke.OR.ln_zdfgls ) CALL Agrif_Set_bc( avm_id, (/0,ind1/) ) 560 !!$ CALL Agrif_Set_bc(glamt_id, (/0,ind1-1/) ) 561 !!$ CALL Agrif_Set_bc(gphit_id, (/0,ind1-1/) ) 550 562 551 563 ! 4. Update type … … 553 565 554 566 # if defined UPD_HIGH 555 CALL Agrif_Set_Updatetype( tsn_id, update= Agrif_Update_Full_Weighting)556 CALL Agrif_Set_Updatetype(un_update_id,update1 = Agrif_Update_Average , update2 = Agrif_Update_Full_Weighting)557 CALL Agrif_Set_Updatetype(vn_update_id,update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average )558 559 CALL Agrif_Set_Updatetype(ub2b_update_id,update1 = Agrif_Update_Average , update2 = Agrif_Update_Full_Weighting)560 CALL Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average )561 CALL Agrif_Set_Updatetype( sshn_id,update= Agrif_Update_Full_Weighting)562 CALL Agrif_Set_Updatetype( e3t_id, update= Agrif_Update_Full_Weighting)567 CALL Agrif_Set_Updatetype( tsn_id,update = Agrif_Update_Full_Weighting) 568 CALL Agrif_Set_Updatetype(un_update_id,update1 = Agrif_Update_Average , update2 = Agrif_Update_Full_Weighting) 569 CALL Agrif_Set_Updatetype(vn_update_id,update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average ) 570 571 CALL Agrif_Set_Updatetype(ub2b_update_id,update1 = Agrif_Update_Average , update2 = Agrif_Update_Full_Weighting) 572 CALL Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average ) 573 CALL Agrif_Set_Updatetype( sshn_id,update = Agrif_Update_Full_Weighting) 574 CALL Agrif_Set_Updatetype( e3t_id,update = Agrif_Update_Full_Weighting) 563 575 564 576 ! IF( ln_zdftke.OR.ln_zdfgls ) THEN … … 569 581 570 582 #else 571 CALL Agrif_Set_Updatetype( tsn_id, update= AGRIF_Update_Average)572 CALL Agrif_Set_Updatetype(un_update_id,update1 = Agrif_Update_Copy , update2 = Agrif_Update_Average)573 CALL Agrif_Set_Updatetype(vn_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy )574 575 CALL Agrif_Set_Updatetype(ub2b_update_id,update1 = Agrif_Update_Copy , update2 = Agrif_Update_Average)576 CALL Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy )577 CALL Agrif_Set_Updatetype( sshn_id,update= AGRIF_Update_Average)578 CALL Agrif_Set_Updatetype( e3t_id, update= AGRIF_Update_Average)583 CALL Agrif_Set_Updatetype( tsn_id, update = AGRIF_Update_Average) 584 CALL Agrif_Set_Updatetype(un_update_id,update1 = Agrif_Update_Copy , update2 = Agrif_Update_Average) 585 CALL Agrif_Set_Updatetype(vn_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy ) 586 587 CALL Agrif_Set_Updatetype(ub2b_update_id,update1 = Agrif_Update_Copy , update2 = Agrif_Update_Average) 588 CALL Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy ) 589 CALL Agrif_Set_Updatetype( sshn_id,update = AGRIF_Update_Average) 590 CALL Agrif_Set_Updatetype( e3t_id,update = AGRIF_Update_Average) 579 591 580 592 ! IF( ln_zdftke.OR.ln_zdfgls ) THEN … … 589 601 590 602 #if defined key_si3 591 SUBROUTINE Agrif_InitValues_cont_ice 603 SUBROUTINE Agrif_InitValues_cont_ice 604 !!---------------------------------------------------------------------- 605 !! *** ROUTINE Agrif_InitValues_cont_ice *** 606 !!---------------------------------------------------------------------- 592 607 USE Agrif_Util 593 608 USE sbc_oce, ONLY : nn_fsbc ! clem: necessary otherwise Agrif_Parent(nn_fsbc) = nn_fsbc … … 597 612 USE agrif_ice_interp 598 613 USE lib_mpp 599 ! !----------------------------------------------------------------------600 !! *** ROUTINE Agrif_InitValues_cont_ice ***601 ! !----------------------------------------------------------------------602 614 ! 615 IMPLICIT NONE 616 ! 617 !!---------------------------------------------------------------------- 603 618 ! Controls 604 619 … … 623 638 END SUBROUTINE Agrif_InitValues_cont_ice 624 639 640 625 641 SUBROUTINE agrif_declare_var_ice 626 642 !!---------------------------------------------------------------------- 627 643 !! *** ROUTINE agrif_declare_var_ice *** 628 644 !!---------------------------------------------------------------------- 629 630 645 USE Agrif_Util 631 646 USE ice … … 635 650 ! 636 651 INTEGER :: ind1, ind2, ind3 637 !!---------------------------------------------------------------------- 652 INTEGER :: ipl 653 !!---------------------------------------------------------------------- 638 654 ! 639 655 ! 1. Declaration of the type of variable which have to be interpolated (parent=>child) … … 644 660 ! 2,2 = two ghost lines 645 661 !------------------------------------------------------------------------------------- 646 647 ind 1 = nbghostcells648 ind 2 = 2 + nbghostcells_x649 i nd3 = 2 + nbghostcells_y_s650 CALL agrif_declare_variable((/2,2,0/),(/ind2,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/ nlci,nlcj,jpl*(8+nlay_s+nlay_i)/),tra_ice_id)651 CALL agrif_declare_variable((/1,2/) ,(/ind2-1,ind3/) ,(/'x','y'/) ,(/1,1/) ,(/nlci,nlcj/) ,u_ice_id)652 CALL agrif_declare_variable((/2,1/) ,(/ind2,ind3-1/) ,(/'x','y'/) ,(/1,1/) ,(/nlci,nlcj/) ,v_ice_id)653 654 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_iceini_id)655 CALL agrif_declare_variable((/1,2/) ,(/ind2-1,ind3/) ,(/'x','y'/) ,(/1,1/) ,(/nlci,nlcj/) ,u_iceini_id)656 CALL agrif_declare_variable((/2,1/) ,(/ind2,ind3-1/) ,(/'x','y'/) ,(/1,1/) ,(/nlci,nlcj/) ,v_iceini_id)662 ind1 = nbghostcells 663 ind2 = nn_hls + 2 + nbghostcells_x 664 ind3 = nn_hls + 2 + nbghostcells_y_s 665 ipl = jpl*(8+nlay_s+nlay_i) 666 CALL agrif_declare_variable((/2,2,0/),(/ind2,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,ipl/),tra_ice_id) 667 CALL agrif_declare_variable((/1,2/) ,(/ind2-1,ind3/),(/'x','y' /),(/1,1 /),(/jpi,jpj /), u_ice_id) 668 CALL agrif_declare_variable((/2,1/) ,(/ind2,ind3-1/),(/'x','y' /),(/1,1 /),(/jpi,jpj /), v_ice_id) 669 670 CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,ipl/),tra_iceini_id) 671 CALL agrif_declare_variable((/1,2/) ,(/ind2-1,ind3/),(/'x','y' /),(/1,1 /),(/jpi,jpj /), u_iceini_id) 672 CALL agrif_declare_variable((/2,1/) ,(/ind2,ind3-1/),(/'x','y' /),(/1,1 /),(/jpi,jpj /), v_iceini_id) 657 673 658 674 ! 2. Set interpolations (normal & tangent to the grid cell for velocities) … … 712 728 USE agrif_top_interp 713 729 USE agrif_top_sponge 714 !! 715 716 !! 717 IMPLICIT NONE 718 ! 719 CHARACTER(len=10) :: cl_check1, cl_check2, cl_check3 720 LOGICAL :: check_namelist 721 !!---------------------------------------------------------------------- 722 723 724 ! 1. Declaration of the type of variable which have to be interpolated 725 !--------------------------------------------------------------------- 726 CALL agrif_declare_var_top 727 728 ! 2. First interpolations of potentially non zero fields 729 !------------------------------------------------------- 730 Agrif_SpecialValue=0. 731 Agrif_UseSpecialValue = .TRUE. 732 CALL Agrif_Bc_variable(trn_id,calledweight=1.,procname=interptrn) 733 Agrif_UseSpecialValue = .FALSE. 734 CALL Agrif_Sponge 735 tabspongedone_trn = .FALSE. 736 CALL Agrif_Bc_variable(trn_sponge_id,calledweight=1.,procname=interptrn_sponge) 737 ! reset tsa to zero 738 tra(:,:,:,:) = 0. 739 740 ! 3. Some controls 741 !----------------- 742 check_namelist = .TRUE. 743 744 IF( check_namelist ) THEN 745 ! Check time steps 746 IF( NINT(Agrif_Rhot()) * NINT(rdt) .NE. Agrif_Parent(rdt) ) THEN 747 WRITE(cl_check1,*) Agrif_Parent(rdt) 748 WRITE(cl_check2,*) rdt 749 WRITE(cl_check3,*) rdt*Agrif_Rhot() 750 CALL ctl_stop( 'incompatible time step between grids', & 730 ! 731 IMPLICIT NONE 732 ! 733 CHARACTER(len=10) :: cl_check1, cl_check2, cl_check3 734 LOGICAL :: check_namelist 735 !!---------------------------------------------------------------------- 736 737 ! 1. Declaration of the type of variable which have to be interpolated 738 !--------------------------------------------------------------------- 739 CALL agrif_declare_var_top 740 741 ! 2. First interpolations of potentially non zero fields 742 !------------------------------------------------------- 743 Agrif_SpecialValue=0._wp 744 Agrif_UseSpecialValue = .TRUE. 745 CALL Agrif_Bc_variable(trn_id,calledweight=1.,procname=interptrn) 746 Agrif_UseSpecialValue = .FALSE. 747 CALL Agrif_Sponge 748 tabspongedone_trn = .FALSE. 749 CALL Agrif_Bc_variable(trn_sponge_id,calledweight=1.,procname=interptrn_sponge) 750 ! reset tsa to zero 751 tra(:,:,:,:) = 0._wp 752 753 ! 3. Some controls 754 !----------------- 755 check_namelist = .TRUE. 756 757 IF( check_namelist ) THEN 758 ! Check time steps 759 IF( NINT(Agrif_Rhot()) * NINT(rdt) .NE. Agrif_Parent(rdt) ) THEN 760 WRITE(cl_check1,*) Agrif_Parent(rdt) 761 WRITE(cl_check2,*) rdt 762 WRITE(cl_check3,*) rdt*Agrif_Rhot() 763 CALL ctl_stop( 'incompatible time step between grids', & 751 764 & 'parent grid value : '//cl_check1 , & 752 765 & 'child grid value : '//cl_check2 , & 753 766 & 'value on child grid should be changed to & 754 767 & :'//cl_check3 ) 755 ENDIF756 757 ! Check run length758 IF( Agrif_IRhot() * (Agrif_Parent(nitend)- &768 ENDIF 769 770 ! Check run length 771 IF( Agrif_IRhot() * (Agrif_Parent(nitend)- & 759 772 Agrif_Parent(nit000)+1) .NE. (nitend-nit000+1) ) THEN 760 WRITE(cl_check1,*) (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1761 WRITE(cl_check2,*) Agrif_Parent(nitend) *Agrif_IRhot()762 CALL ctl_warn( 'incompatible run length between grids' , &773 WRITE(cl_check1,*) (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 774 WRITE(cl_check2,*) Agrif_Parent(nitend) *Agrif_IRhot() 775 CALL ctl_warn( 'incompatible run length between grids' , & 763 776 & ' nit000 on fine grid will be change to : '//cl_check1, & 764 777 & ' nitend on fine grid will be change to : '//cl_check2 ) 765 nit000 = (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1766 nitend = Agrif_Parent(nitend) *Agrif_IRhot()767 ENDIF768 ENDIF769 !778 nit000 = (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 779 nitend = Agrif_Parent(nitend) *Agrif_IRhot() 780 ENDIF 781 ENDIF 782 ! 770 783 END SUBROUTINE Agrif_InitValues_cont_top 771 784 … … 784 797 INTEGER :: ind1, ind2, ind3 785 798 !!---------------------------------------------------------------------- 786 787 788 789 799 !RB_CMEMS : declare here init for top 790 800 ! 1. Declaration of the type of variable which have to be interpolated 791 801 !--------------------------------------------------------------------- 792 ind1 = nbghostcells793 ind2 = 2 + nbghostcells_x794 ind3 = 2 + nbghostcells_y_s802 ind1 = nbghostcells 803 ind2 = nn_hls + 2 + nbghostcells_x 804 ind3 = nn_hls + 2 + nbghostcells_y_s 795 805 # if defined key_vertical 796 CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/ nlci,nlcj,jpk,jptra+1/),trn_id)797 CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/ nlci,nlcj,jpk,jptra+1/),trn_sponge_id)806 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) 807 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) 798 808 # else 799 809 ! LAURENT: STRANGE why (3,3) here ? 800 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/ nlci,nlcj,jpk,jptra/),trn_id)801 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/ nlci,nlcj,jpk,jptra/),trn_sponge_id)810 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) 811 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) 802 812 # endif 803 813 … … 822 832 END SUBROUTINE agrif_declare_var_top 823 833 # endif 834 824 835 825 836 SUBROUTINE Agrif_detect( kg, ksizex ) … … 835 846 END SUBROUTINE Agrif_detect 836 847 848 837 849 SUBROUTINE agrif_nemo_init 838 850 !!---------------------------------------------------------------------- 839 851 !! *** ROUTINE agrif_init *** 840 852 !!---------------------------------------------------------------------- 841 USE agrif_oce842 USE agrif_ice843 USE dom_oce844 USE in_out_manager845 USE lib_mpp846 ! !853 USE agrif_oce 854 USE agrif_ice 855 USE dom_oce 856 USE in_out_manager 857 USE lib_mpp 858 ! 847 859 IMPLICIT NONE 848 860 ! … … 880 892 ! 881 893 ! Set the number of ghost cells according to periodicity 882 nbghostcells_x = nbghostcells894 nbghostcells_x = nbghostcells 883 895 nbghostcells_y_s = nbghostcells 884 896 nbghostcells_y_n = nbghostcells 885 897 ! 886 IF ( jperio == 1 ) nbghostcells_x = 0 887 IF ( .NOT. lk_south ) nbghostcells_y_s = 0 888 898 IF( jperio == 1 ) nbghostcells_x = 0 899 IF( .NOT. lk_south ) nbghostcells_y_s = 0 889 900 ! Some checks 890 IF( jpiglo /= nbcellsx + 2 + 2*n bghostcells_x )&891 CALL ctl_stop( 'STOP', 'agrif_nemo_init: Agrif children requires jpiglo == nbcellsx + 2+ 2*nbghostcells_x' )892 IF( jpjglo /= nbcellsy + 2 + nbghostcells_y_s + nbghostcells_y_n )&893 CALL ctl_stop( 'STOP', 'agrif_nemo_init: Agrif children requires jpjglo == nbcellsy + 2+ nbghostcells_y_s + nbghostcells_y_n' )901 IF( jpiglo /= nbcellsx + 2 + 2*nn_hls + nbghostcells_x + nbghostcells_x ) CALL ctl_stop( 'STOP', & 902 & 'agrif_nemo_init: Agrif children requires jpiglo == nbcellsx + 2 + 2*nn_hls + 2*nbghostcells_x' ) 903 IF( jpjglo /= nbcellsy + 2 + 2*nn_hls + nbghostcells_y_s + nbghostcells_y_n ) CALL ctl_stop( 'STOP', & 904 & 'agrif_nemo_init: Agrif children requires jpjglo == nbcellsy + 2 + 2*nn_hls + nbghostcells_y_s + nbghostcells_y_n' ) 894 905 IF( ln_use_jattr ) CALL ctl_stop( 'STOP', 'agrif_nemo_init:Agrif children requires ln_use_jattr = .false. ' ) 895 906 ! 896 907 END SUBROUTINE agrif_nemo_init 897 908 909 898 910 # if defined key_mpp_mpi 899 911 SUBROUTINE Agrif_InvLoc( indloc, nprocloc, i, indglob ) … … 909 921 ! 910 922 SELECT CASE( i ) 911 CASE(1) ; indglob = indloc + nimppt(nprocloc+1) - 1 912 CASE(2) ; indglob = indloc + njmppt(nprocloc+1) - 1 913 CASE DEFAULT 914 indglob = indloc 923 CASE(1) ; indglob = mig(indloc) 924 CASE(2) ; indglob = mjg(indloc) 925 CASE DEFAULT ; indglob = indloc 915 926 END SELECT 916 927 ! 917 928 END SUBROUTINE Agrif_InvLoc 918 929 930 919 931 SUBROUTINE Agrif_get_proc_info( imin, imax, jmin, jmax ) 920 932 !!---------------------------------------------------------------------- … … 929 941 !!---------------------------------------------------------------------- 930 942 ! 931 imin = nimppt(Agrif_Procrank+1) ! ?????932 jmin = njmppt(Agrif_Procrank+1) ! ?????933 imax = imin + jpi - 1934 jmax = jmin + jpj - 1943 imin = mig( 1 ) 944 jmin = mjg( 1 ) 945 imax = mig(jpi) 946 jmax = mjg(jpj) 935 947 ! 936 948 END SUBROUTINE Agrif_get_proc_info 937 949 950 938 951 SUBROUTINE Agrif_estimate_parallel_cost(imin, imax,jmin, jmax, nbprocs, grid_cost) 939 952 !!---------------------------------------------------------------------- … … 1130 1143 FUNCTION agrif_external_switch_index(ptx,pty,i1,isens) 1131 1144 1132 USE dom_oce 1133 1134 INTEGER :: ptx, pty, i1, isens 1135 INTEGER :: agrif_external_switch_index 1136 1137 IF( isens == 1 ) THEN 1138 IF( ptx == 2 ) THEN ! T, V points 1139 agrif_external_switch_index = jpiglo-i1+2 1140 ELSE ! U, F points 1141 agrif_external_switch_index = jpiglo-i1+1 1142 ENDIF 1143 ELSE IF( isens ==2 ) THEN 1144 IF ( pty == 2 ) THEN ! T, U points 1145 agrif_external_switch_index = jpjglo-2-(i1 -jpjglo) 1146 ELSE ! V, F points 1147 agrif_external_switch_index = jpjglo-3-(i1 -jpjglo) 1148 ENDIF 1149 ENDIF 1145 USE dom_oce 1146 ! 1147 IMPLICIT NONE 1148 1149 INTEGER :: ptx, pty, i1, isens 1150 INTEGER :: agrif_external_switch_index 1151 !!---------------------------------------------------------------------- 1152 1153 IF( isens == 1 ) THEN 1154 IF( ptx == 2 ) THEN ! T, V points 1155 agrif_external_switch_index = jpiglo-i1+2 1156 ELSE ! U, F points 1157 agrif_external_switch_index = jpiglo-i1+1 1158 ENDIF 1159 ELSE IF( isens ==2 ) THEN 1160 IF ( pty == 2 ) THEN ! T, U points 1161 agrif_external_switch_index = jpjglo-2-(i1 -jpjglo) 1162 ELSE ! V, F points 1163 agrif_external_switch_index = jpjglo-3-(i1 -jpjglo) 1164 ENDIF 1165 ENDIF 1150 1166 1151 1167 END FUNCTION agrif_external_switch_index … … 1155 1171 !! *** ROUTINE Correct_field *** 1156 1172 !!---------------------------------------------------------------------- 1157 1158 USE dom_oce 1159 USE agrif_oce 1160 1161 INTEGER :: i1,i2,j1,j2 1162 REAL(wp), DIMENSION(i1:i2,j1:j2) :: tab2d 1163 1164 INTEGER :: i,j 1165 REAL(wp), DIMENSION(i1:i2,j1:j2) :: tab2dtemp 1166 1167 tab2dtemp = tab2d 1168 1169 IF( .NOT. use_sign_north ) THEN 1170 DO j=j1,j2 1171 DO i=i1,i2 1172 tab2d(i,j)=tab2dtemp(i2-(i-i1),j2-(j-j1)) 1173 USE dom_oce 1174 USE agrif_oce 1175 ! 1176 IMPLICIT NONE 1177 ! 1178 INTEGER :: i1,i2,j1,j2 1179 REAL(wp), DIMENSION(i1:i2,j1:j2) :: tab2d 1180 ! 1181 INTEGER :: i,j 1182 REAL(wp), DIMENSION(i1:i2,j1:j2) :: tab2dtemp 1183 !!---------------------------------------------------------------------- 1184 1185 tab2dtemp = tab2d 1186 1187 IF( .NOT. use_sign_north ) THEN 1188 DO j=j1,j2 1189 DO i=i1,i2 1190 tab2d(i,j)=tab2dtemp(i2-(i-i1),j2-(j-j1)) 1191 END DO 1173 1192 END DO 1174 E ND DO1175 ELSE1176 DO j=j1,j21177 DO i=i1,i21178 tab2d(i,j)=sign_north * tab2dtemp(i2-(i-i1),j2-(j-j1))1193 ELSE 1194 DO j=j1,j2 1195 DO i=i1,i2 1196 tab2d(i,j)=sign_north * tab2dtemp(i2-(i-i1),j2-(j-j1)) 1197 END DO 1179 1198 END DO 1180 END DO 1181 ENDIF 1199 ENDIF 1182 1200 1183 1201 END SUBROUTINE Correct_field -
NEMO/trunk/src/OCE/ASM/asminc.F90
r13237 r13286 360 360 361 361 IF ( ln_trainc ) THEN 362 CALL iom_get( inum, jpdom_auto glo, 'bckint', t_bkginc, 1 )363 CALL iom_get( inum, jpdom_auto glo, 'bckins', s_bkginc, 1 )362 CALL iom_get( inum, jpdom_auto, 'bckint', t_bkginc, 1 ) 363 CALL iom_get( inum, jpdom_auto, 'bckins', s_bkginc, 1 ) 364 364 ! Apply the masks 365 365 t_bkginc(:,:,:) = t_bkginc(:,:,:) * tmask(:,:,:) … … 372 372 373 373 IF ( ln_dyninc ) THEN 374 CALL iom_get( inum, jpdom_auto glo, 'bckinu', u_bkginc, 1 )375 CALL iom_get( inum, jpdom_auto glo, 'bckinv', v_bkginc, 1 )374 CALL iom_get( inum, jpdom_auto, 'bckinu', u_bkginc, 1 ) 375 CALL iom_get( inum, jpdom_auto, 'bckinv', v_bkginc, 1 ) 376 376 ! Apply the masks 377 377 u_bkginc(:,:,:) = u_bkginc(:,:,:) * umask(:,:,:) … … 384 384 385 385 IF ( ln_sshinc ) THEN 386 CALL iom_get( inum, jpdom_auto glo, 'bckineta', ssh_bkginc, 1 )386 CALL iom_get( inum, jpdom_auto, 'bckineta', ssh_bkginc, 1 ) 387 387 ! Apply the masks 388 388 ssh_bkginc(:,:) = ssh_bkginc(:,:) * tmask(:,:,1) … … 393 393 394 394 IF ( ln_seaiceinc ) THEN 395 CALL iom_get( inum, jpdom_auto glo, 'bckinseaice', seaice_bkginc, 1 )395 CALL iom_get( inum, jpdom_auto, 'bckinseaice', seaice_bkginc, 1 ) 396 396 ! Apply the masks 397 397 seaice_bkginc(:,:) = seaice_bkginc(:,:) * tmask(:,:,1) … … 467 467 ! 468 468 IF ( ln_trainc ) THEN 469 CALL iom_get( inum, jpdom_auto glo, 'tn', t_bkg )470 CALL iom_get( inum, jpdom_auto glo, 'sn', s_bkg )469 CALL iom_get( inum, jpdom_auto, 'tn', t_bkg ) 470 CALL iom_get( inum, jpdom_auto, 'sn', s_bkg ) 471 471 t_bkg(:,:,:) = t_bkg(:,:,:) * tmask(:,:,:) 472 472 s_bkg(:,:,:) = s_bkg(:,:,:) * tmask(:,:,:) … … 474 474 ! 475 475 IF ( ln_dyninc ) THEN 476 CALL iom_get( inum, jpdom_auto glo, 'un', u_bkg)477 CALL iom_get( inum, jpdom_auto glo, 'vn', v_bkg)476 CALL iom_get( inum, jpdom_auto, 'un', u_bkg, cd_type = 'U', psgn = 1._wp ) 477 CALL iom_get( inum, jpdom_auto, 'vn', v_bkg, cd_type = 'V', psgn = 1._wp ) 478 478 u_bkg(:,:,:) = u_bkg(:,:,:) * umask(:,:,:) 479 479 v_bkg(:,:,:) = v_bkg(:,:,:) * vmask(:,:,:) … … 481 481 ! 482 482 IF ( ln_sshinc ) THEN 483 CALL iom_get( inum, jpdom_auto glo, 'sshn', ssh_bkg )483 CALL iom_get( inum, jpdom_auto, 'sshn', ssh_bkg ) 484 484 ssh_bkg(:,:) = ssh_bkg(:,:) * tmask(:,:,1) 485 485 ENDIF -
NEMO/trunk/src/OCE/BDY/bdyini.F90
r13226 r13286 416 416 CALL iom_get( inum, jpdom_unknown, 'nbi'//cgrid(igrd), zz_read(1:nblendta(igrd,ib_bdy),:) ) 417 417 DO ii = 1,nblendta(igrd,ib_bdy) 418 nbidta(ii,igrd,ib_bdy) = NINT( zz_read(ii,1) ) 418 nbidta(ii,igrd,ib_bdy) = NINT( zz_read(ii,1) ) + nn_hls 419 419 END DO 420 420 CALL iom_get( inum, jpdom_unknown, 'nbj'//cgrid(igrd), zz_read(1:nblendta(igrd,ib_bdy),:) ) 421 421 DO ii = 1,nblendta(igrd,ib_bdy) 422 nbjdta(ii,igrd,ib_bdy) = NINT( zz_read(ii,1) ) 422 nbjdta(ii,igrd,ib_bdy) = NINT( zz_read(ii,1) ) + nn_hls 423 423 END DO 424 424 CALL iom_get( inum, jpdom_unknown, 'nbr'//cgrid(igrd), zz_read(1:nblendta(igrd,ib_bdy),:) ) … … 1378 1378 DO ji = 1, jpi 1379 1379 DO jj = 1, jpj 1380 IF (((ji + nimpp - 1) == jpiwob(ib)).AND. & 1381 & ((jj + njmpp - 1) == jpjwdt(ib))) ztestmask(1)=tmask(ji,jj,1) 1382 IF (((ji + nimpp - 1) == jpiwob(ib)).AND. & 1383 & ((jj + njmpp - 1) == jpjwft(ib))) ztestmask(2)=tmask(ji,jj,1) 1380 IF( mig(ji) == jpiwob(ib) .AND. mjg(jj) == jpjwdt(ib) ) ztestmask(1) = tmask(ji,jj,1) 1381 IF( mig(ji) == jpiwob(ib) .AND. mjg(jj) == jpjwft(ib) ) ztestmask(2) = tmask(ji,jj,1) 1384 1382 END DO 1385 1383 END DO … … 1416 1414 DO ji = 1, jpi 1417 1415 DO jj = 1, jpj 1418 IF (((ji + nimpp - 1) == jpieob(ib)+1).AND. & 1419 & ((jj + njmpp - 1) == jpjedt(ib))) ztestmask(1)=tmask(ji,jj,1) 1420 IF (((ji + nimpp - 1) == jpieob(ib)+1).AND. & 1421 & ((jj + njmpp - 1) == jpjeft(ib))) ztestmask(2)=tmask(ji,jj,1) 1416 IF( mig(ji) == jpieob(ib)+1 .AND. mjg(jj) == jpjedt(ib) ) ztestmask(1) = tmask(ji,jj,1) 1417 IF( mig(ji) == jpieob(ib)+1 .AND. mjg(jj) == jpjeft(ib) ) ztestmask(2) = tmask(ji,jj,1) 1422 1418 END DO 1423 1419 END DO … … 1454 1450 DO ji = 1, jpi 1455 1451 DO jj = 1, jpj 1456 IF (((jj + njmpp - 1) == jpjsob(ib)).AND. & 1457 & ((ji + nimpp - 1) == jpisdt(ib))) ztestmask(1)=tmask(ji,jj,1) 1458 IF (((jj + njmpp - 1) == jpjsob(ib)).AND. & 1459 & ((ji + nimpp - 1) == jpisft(ib))) ztestmask(2)=tmask(ji,jj,1) 1452 IF( mjg(jj) == jpjsob(ib) .AND. mig(ji) == jpisdt(ib) ) ztestmask(1) = tmask(ji,jj,1) 1453 IF( mjg(jj) == jpjsob(ib) .AND. mig(ji) == jpisft(ib) ) ztestmask(2) = tmask(ji,jj,1) 1460 1454 END DO 1461 1455 END DO … … 1478 1472 DO ji = 1, jpi 1479 1473 DO jj = 1, jpj 1480 IF (((jj + njmpp - 1) == jpjnob(ib)+1).AND. & 1481 & ((ji + nimpp - 1) == jpindt(ib))) ztestmask(1)=tmask(ji,jj,1) 1482 IF (((jj + njmpp - 1) == jpjnob(ib)+1).AND. & 1483 & ((ji + nimpp - 1) == jpinft(ib))) ztestmask(2)=tmask(ji,jj,1) 1474 IF( mjg(jj) == jpjnob(ib)+1 .AND. mig(ji) == jpindt(ib) ) ztestmask(1) = tmask(ji,jj,1) 1475 IF( mjg(jj) == jpjnob(ib)+1 .AND. mig(ji) == jpinft(ib) ) ztestmask(2) = tmask(ji,jj,1) 1484 1476 END DO 1485 1477 END DO -
NEMO/trunk/src/OCE/BDY/bdytides.F90
r12921 r13286 167 167 igrd = 1 ! Everything is at T-points here 168 168 DO itide = 1, nb_harmo 169 CALL iom_get( inum, jpdom_auto glo, TRIM(tide_harmonics(itide)%cname_tide)//'_z1', ztr(:,:) )170 CALL iom_get( inum, jpdom_auto glo, TRIM(tide_harmonics(itide)%cname_tide)//'_z2', zti(:,:) )169 CALL iom_get( inum, jpdom_auto, TRIM(tide_harmonics(itide)%cname_tide)//'_z1', ztr(:,:) ) 170 CALL iom_get( inum, jpdom_auto, TRIM(tide_harmonics(itide)%cname_tide)//'_z2', zti(:,:) ) 171 171 DO ib = 1, SIZE(dta%ssh) 172 172 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) … … 185 185 igrd = 2 ! Everything is at U-points here 186 186 DO itide = 1, nb_harmo 187 CALL iom_get ( inum, jpdom_autoglo, TRIM(tide_harmonics(itide)%cname_tide)//'_u1', ztr(:,:))188 CALL iom_get ( inum, jpdom_autoglo, TRIM(tide_harmonics(itide)%cname_tide)//'_u2', zti(:,:))187 CALL iom_get(inum, jpdom_auto, TRIM(tide_harmonics(itide)%cname_tide)//'_u1', ztr(:,:),cd_type='U',psgn=-1._wp) 188 CALL iom_get(inum, jpdom_auto, TRIM(tide_harmonics(itide)%cname_tide)//'_u2', zti(:,:),cd_type='U',psgn=-1._wp) 189 189 DO ib = 1, SIZE(dta%u2d) 190 190 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) … … 203 203 igrd = 3 ! Everything is at V-points here 204 204 DO itide = 1, nb_harmo 205 CALL iom_get ( inum, jpdom_autoglo, TRIM(tide_harmonics(itide)%cname_tide)//'_v1', ztr(:,:))206 CALL iom_get ( inum, jpdom_autoglo, TRIM(tide_harmonics(itide)%cname_tide)//'_v2', zti(:,:))205 CALL iom_get(inum, jpdom_auto, TRIM(tide_harmonics(itide)%cname_tide)//'_v1', ztr(:,:),cd_type='V',psgn=-1._wp) 206 CALL iom_get(inum, jpdom_auto, TRIM(tide_harmonics(itide)%cname_tide)//'_v2', zti(:,:),cd_type='V',psgn=-1._wp) 207 207 DO ib = 1, SIZE(dta%v2d) 208 208 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) -
NEMO/trunk/src/OCE/C1D/dyndmp.F90
r12377 r13286 121 121 !Read in mask from file 122 122 CALL iom_open ( cn_resto, imask) 123 CALL iom_get ( imask, jpdom_auto glo, 'resto', resto)123 CALL iom_get ( imask, jpdom_auto, 'resto', resto) 124 124 CALL iom_close( imask ) 125 125 ENDIF -
NEMO/trunk/src/OCE/CRS/crs.F90
r10068 r13286 36 36 INTEGER :: jpiglo_full, jpjglo_full !: jpiglo / jpjglo 37 37 INTEGER :: npiglo, npjglo !: jpjglo 38 INTEGER :: nlci_full, nlcj_full !: i-, j-dimension of local or sub domain on parent grid 39 INTEGER :: nldi_full, nldj_full !: starting indices of internal sub-domain on parent grid 40 INTEGER :: nlei_full, nlej_full !: ending indices of internal sub-domain on parent grid 41 INTEGER :: nlci_crs, nlcj_crs !: i-, j-dimension of local or sub domain on coarse grid 42 INTEGER :: nldi_crs, nldj_crs !: starting indices of internal sub-domain on coarse grid 43 INTEGER :: nlei_crs, nlej_crs !: ending indices of internal sub-domain on coarse grid 38 INTEGER :: Nis0_full, Njs0_full !: starting indices of internal sub-domain on parent grid 39 INTEGER :: Nie0_full, Nje0_full !: ending indices of internal sub-domain on parent grid 40 INTEGER :: Nis0_crs , Njs0_crs !: starting indices of internal sub-domain on coarse grid 41 INTEGER :: Nie0_crs , Nje0_crs !: ending indices of internal sub-domain on coarse grid 44 42 45 43 INTEGER :: narea_full, narea_crs !: node … … 48 46 INTEGER :: nimpp_full, njmpp_full !: global position of point (1,1) of subdomain on parent grid 49 47 INTEGER :: nimpp_crs, njmpp_crs !: set to 1,1 for now . Valid only for monoproc 50 INTEGER :: nreci_full, nrecj_full51 INTEGER :: nreci_crs, nrecj_crs52 48 !cc 53 49 INTEGER :: noea_full, nowe_full !: index of the local neighboring processors in … … 76 72 INTEGER, DIMENSION(:), ALLOCATABLE :: mi0_crs, mi1_crs, mj0_crs, mj1_crs 77 73 INTEGER :: mxbinctr, mybinctr ! central point in grid box 78 INTEGER, DIMENSION(:), ALLOCATABLE :: nlcit_crs, nlcit_full!: dimensions of every subdomain79 INTEGER, DIMENSION(:), ALLOCATABLE :: n ldit_crs, nldit_full!: first, last indoor index for each i-domain80 INTEGER, DIMENSION(:), ALLOCATABLE :: n leit_crs, nleit_full!: first, last indoor index for each j-domain81 INTEGER, DIMENSION(:), ALLOCATABLE :: nimppt_crs, nimppt_full!: first, last indoor index for each j-domain82 INTEGER, DIMENSION(:), ALLOCATABLE :: nlcjt_crs, nlcjt_full!: dimensions of every subdomain83 INTEGER, DIMENSION(:), ALLOCATABLE :: n ldjt_crs, nldjt_full!: first, last indoor index for each i-domain84 INTEGER, DIMENSION(:), ALLOCATABLE :: n lejt_crs, nlejt_full!: first, last indoor index for each j-domain85 INTEGER, DIMENSION(:), ALLOCATABLE :: njmppt_crs, njmppt_full!: first, last indoor index for each j-domain74 INTEGER, DIMENSION(:), ALLOCATABLE :: jpiall_crs, jpiall_full !: dimensions of every subdomain 75 INTEGER, DIMENSION(:), ALLOCATABLE :: nis0all_crs, nis0all_full !: first, last indoor index for each i-domain 76 INTEGER, DIMENSION(:), ALLOCATABLE :: nie0all_crs, nie0all_full !: first, last indoor index for each j-domain 77 INTEGER, DIMENSION(:), ALLOCATABLE :: nimppt_crs, nimppt_full !: first, last indoor index for each j-domain 78 INTEGER, DIMENSION(:), ALLOCATABLE :: jpjall_crs, jpjall_full !: dimensions of every subdomain 79 INTEGER, DIMENSION(:), ALLOCATABLE :: njs0all_crs, njs0all_full !: first, last indoor index for each i-domain 80 INTEGER, DIMENSION(:), ALLOCATABLE :: nje0all_crs, nje0all_full !: first, last indoor index for each j-domain 81 INTEGER, DIMENSION(:), ALLOCATABLE :: njmppt_crs, njmppt_full !: first, last indoor index for each j-domain 86 82 87 83 88 84 ! Masks 89 85 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: tmask_crs, umask_crs, vmask_crs, fmask_crs 90 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: tmask_i_crs, rnfmsk_crs, tpol_crs, fpol_crs 91 92 ! REAL(wp), DIMENSION(:,:), ALLOCATABLE :: tmask_i_crs, tpol, fpol 93 86 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: rnfmsk_crs 87 94 88 ! Scale factors 95 89 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: e1t_crs, e2t_crs, e1e2t_crs ! horizontal scale factors grid type T … … 182 176 & umask_crs(jpi_crs,jpj_crs,jpk) , vmask_crs(jpi_crs,jpj_crs,jpk) , STAT=ierr(2)) 183 177 184 ALLOCATE( tmask_i_crs(jpi_crs,jpj_crs) , rnfmsk_crs(jpi_crs,jpj_crs), & 185 & tpol_crs(jpiglo_crs,jpjglo_crs), fpol_crs(jpiglo_crs,jpjglo_crs), STAT=ierr(3) ) 178 ALLOCATE( rnfmsk_crs(jpi_crs,jpj_crs), STAT=ierr(3) ) 186 179 187 180 ALLOCATE( gphit_crs(jpi_crs,jpj_crs) , glamt_crs(jpi_crs,jpj_crs) , & … … 238 231 & hmlp_crs(jpi_crs,jpj_crs) , hmlpt_crs(jpi_crs,jpj_crs) , STAT=ierr(14) ) 239 232 240 ALLOCATE( nimppt_crs (jpnij) , nlcit_crs (jpnij) , nldit_crs (jpnij) , nleit_crs (jpnij), &241 & nimppt_full(jpnij) , nlcit_full(jpnij) , nldit_full(jpnij) , nleit_full(jpnij), &242 njmppt_crs (jpnij) , nlcjt_crs (jpnij) , nldjt_crs (jpnij) , nlejt_crs (jpnij), &243 & njmppt_full(jpnij) , nlcjt_full(jpnij) , nldjt_full(jpnij) , nlejt_full(jpnij) , STAT=ierr(15) )233 ALLOCATE( nimppt_crs (jpnij) , jpiall_crs (jpnij) , nis0all_crs (jpnij) , nie0all_crs (jpnij), & 234 & nimppt_full(jpnij) , jpiall_full(jpnij) , nis0all_full(jpnij) , nie0all_full(jpnij), & 235 njmppt_crs (jpnij) , jpjall_crs (jpnij) , njs0all_crs (jpnij) , nje0all_crs (jpnij), & 236 & njmppt_full(jpnij) , jpjall_full(jpnij) , njs0all_full(jpnij) , nje0all_full(jpnij) , STAT=ierr(15) ) 244 237 245 238 crs_dom_alloc = MAXVAL(ierr) … … 258 251 ierr(:) = 0 259 252 260 ALLOCATE( mjs_crs( nlej_crs) , mje_crs(nlej_crs), mis_crs(nlei_crs) , mie_crs(nlei_crs), STAT=ierr(1) )253 ALLOCATE( mjs_crs(Nje0_crs) , mje_crs(Nje0_crs), mis_crs(Nie0_crs) , mie_crs(Nie0_crs), STAT=ierr(1) ) 261 254 crs_dom_alloc2 = MAXVAL(ierr) 262 255 … … 282 275 jpjglo = jpjglo_full 283 276 284 nlci = nlci_full285 nlcj = nlcj_full286 nldi = nldi_full287 nldj = nldj_full288 nlei = nlei_full289 nlej = nlej_full290 nimpp 291 njmpp 292 293 nlcit(:) = nlcit_full(:)294 n ldit(:) = nldit_full(:)295 n leit(:) = nleit_full(:)296 nimppt (:) = nimppt_full(:)297 nlcjt(:) = nlcjt_full(:)298 n ldjt(:) = nldjt_full(:)299 n lejt(:) = nlejt_full(:)300 njmppt (:) = njmppt_full(:)277 jpi = jpi_full 278 jpj = jpj_full 279 Nis0 = Nis0_full 280 Njs0 = Njs0_full 281 Nie0 = Nie0_full 282 Nje0 = Nje0_full 283 nimpp = nimpp_full 284 njmpp = njmpp_full 285 286 jpiall (:) = jpiall_full (:) 287 nis0all(:) = nis0all_full(:) 288 nie0all(:) = nie0all_full(:) 289 nimppt (:) = nimppt_full (:) 290 jpjall (:) = jpjall_full (:) 291 njs0all(:) = njs0all_full(:) 292 nje0all(:) = nje0all_full(:) 293 njmppt (:) = njmppt_full (:) 301 294 302 295 END SUBROUTINE dom_grid_glo … … 322 315 323 316 324 nlci = nlci_crs325 nlcj = nlcj_crs326 nldi = nldi_crs327 nlei = nlei_crs328 nlej = nlej_crs329 nldj = nldj_crs330 nimpp 331 njmpp 332 333 nlcit(:) = nlcit_crs(:)334 n ldit(:) = nldit_crs(:)335 n leit(:) = nleit_crs(:)336 nimppt (:) = nimppt_crs(:)337 nlcjt(:) = nlcjt_crs(:)338 n ldjt(:) = nldjt_crs(:)339 n lejt(:) = nlejt_crs(:)340 njmppt (:) = njmppt_crs(:)317 jpi = jpi_crs 318 jpj = jpj_crs 319 Nis0 = Nis0_crs 320 Nie0 = Nie0_crs 321 Nje0 = Nje0_crs 322 Njs0 = Njs0_crs 323 nimpp = nimpp_crs 324 njmpp = njmpp_crs 325 326 jpiall (:) = jpiall_crs (:) 327 nis0all(:) = nis0all_crs(:) 328 nie0all(:) = nie0all_crs(:) 329 nimppt (:) = nimppt_crs (:) 330 jpjall (:) = jpjall_crs (:) 331 njs0all(:) = njs0all_crs(:) 332 nje0all(:) = nje0all_crs(:) 333 njmppt (:) = njmppt_crs (:) 341 334 ! 342 335 END SUBROUTINE dom_grid_crs -
NEMO/trunk/src/OCE/CRS/crsdom.F90
r13226 r13286 73 73 74 74 75 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA275 IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 76 76 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 77 77 je_2 = mje_crs(2) ; ij = je_2 … … 81 81 ENDIF 82 82 DO jk = 1, jpkm1 83 DO ji = 2, nlei_crs83 DO ji = 2, Nie0_crs 84 84 ijis = mis_crs(ji) ; ijie = mie_crs(ji) 85 85 ! … … 101 101 ! 102 102 DO jk = 1, jpkm1 103 DO ji = 2, nlei_crs103 DO ji = 2, Nie0_crs 104 104 ijis = mis_crs(ji) ; ijie = mie_crs(ji) 105 DO jj = 3, nlej_crs105 DO jj = 3, Nje0_crs 106 106 ijjs = mjs_crs(jj) ; ijje = mje_crs(jj) 107 107 … … 168 168 SELECT CASE ( cd_type ) 169 169 CASE ( 'T' ) 170 DO jj = nldj_crs, nlej_crs170 DO jj = Njs0_crs, Nje0_crs 171 171 ijjs = mjs_crs(jj) + mybinctr 172 DO ji = 2, nlei_crs172 DO ji = 2, Nie0_crs 173 173 ijis = mis_crs(ji) + mxbinctr 174 174 p_gphi_crs(ji,jj) = p_gphi(ijis,ijjs) … … 177 177 ENDDO 178 178 CASE ( 'U' ) 179 DO jj = nldj_crs, nlej_crs179 DO jj = Njs0_crs, Nje0_crs 180 180 ijjs = mjs_crs(jj) + mybinctr 181 DO ji = 2, nlei_crs181 DO ji = 2, Nie0_crs 182 182 ijis = mis_crs(ji) 183 183 p_gphi_crs(ji,jj) = p_gphi(ijis,ijjs) … … 186 186 ENDDO 187 187 CASE ( 'V' ) 188 DO jj = nldj_crs, nlej_crs188 DO jj = Njs0_crs, Nje0_crs 189 189 ijjs = mjs_crs(jj) 190 DO ji = 2, nlei_crs190 DO ji = 2, Nie0_crs 191 191 ijis = mis_crs(ji) + mxbinctr 192 192 p_gphi_crs(ji,jj) = p_gphi(ijis,ijjs) … … 195 195 ENDDO 196 196 CASE ( 'F' ) 197 DO jj = nldj_crs, nlej_crs197 DO jj = Njs0_crs, Nje0_crs 198 198 ijjs = mjs_crs(jj) 199 DO ji = 2, nlei_crs199 DO ji = 2, Nie0_crs 200 200 ijis = mis_crs(ji) 201 201 p_gphi_crs(ji,jj) = p_gphi(ijis,ijjs) … … 212 212 SELECT CASE ( cd_type ) 213 213 CASE ( 'T', 'V' ) 214 DO ji = 2, nlei_crs214 DO ji = 2, Nie0_crs 215 215 ijis = mis_crs(ji) + mxbinctr 216 216 p_gphi_crs(ji,1) = p_gphi(ijis,1) … … 218 218 ENDDO 219 219 CASE ( 'U', 'F' ) 220 DO ji = 2, nlei_crs220 DO ji = 2, Nie0_crs 221 221 ijis = mis_crs(ji) 222 222 p_gphi_crs(ji,1) = p_gphi(ijis,1) … … 261 261 262 262 DO jk = 1, jpk 263 DO ji = 2, nlei_crs263 DO ji = 2, Nie0_crs 264 264 ijie = mie_crs(ji) 265 DO jj = nldj_crs, nlej_crs265 DO jj = Njs0_crs, Nje0_crs 266 266 ijje = mje_crs(jj) ; ijrs = mje_crs(jj) - mjs_crs(jj) 267 267 ! Only for a factro 3 coarsening … … 374 374 ENDIF 375 375 376 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2376 IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 377 377 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 378 378 je_2 = mje_crs(2) … … 512 512 ENDIF 513 513 514 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2514 IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 515 515 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 516 516 je_2 = mje_crs(2) … … 617 617 CASE( 'T', 'W' ) 618 618 619 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2619 IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 620 620 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 621 621 je_2 = mje_crs(2) … … 674 674 CASE( 'V' ) 675 675 676 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2676 IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 677 677 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 678 678 ijje = mje_crs(2) … … 711 711 CASE( 'U' ) 712 712 713 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2713 IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 714 714 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 715 715 je_2 = mje_crs(2) … … 782 782 CASE( 'T', 'W' ) 783 783 784 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2784 IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 785 785 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 786 786 je_2 = mje_crs(2) … … 842 842 CASE( 'V' ) 843 843 844 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2844 IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 845 845 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 846 846 ijje = mje_crs(2) … … 883 883 CASE( 'U' ) 884 884 885 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2885 IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 886 886 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 887 887 je_2 = mje_crs(2) … … 953 953 CASE( 'T', 'W' ) 954 954 955 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2955 IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 956 956 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 957 957 je_2 = mje_crs(2) … … 1013 1013 CASE( 'V' ) 1014 1014 1015 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA21015 IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 1016 1016 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 1017 1017 ijje = mje_crs(2) … … 1053 1053 CASE( 'U' ) 1054 1054 1055 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA21055 IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 1056 1056 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 1057 1057 je_2 = mje_crs(2) … … 1158 1158 zsurfmsk(:,:) = p_e12(:,:) * p_e3(:,:,1) * p_mask(:,:,1) 1159 1159 1160 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA21160 IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 1161 1161 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 1162 1162 je_2 = mje_crs(2) … … 1234 1234 CASE( 'T', 'W' ) 1235 1235 1236 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA21236 IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 1237 1237 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 1238 1238 je_2 = mje_crs(2) … … 1285 1285 CASE( 'V' ) 1286 1286 1287 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA21287 IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 1288 1288 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 1289 1289 ijje = mje_crs(2) … … 1318 1318 CASE( 'U' ) 1319 1319 1320 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA21320 IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 1321 1321 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 1322 1322 je_2 = mje_crs(2) … … 1369 1369 CASE( 'T', 'W' ) 1370 1370 1371 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA21371 IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 1372 1372 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 1373 1373 je_2 = mje_crs(2) … … 1420 1420 CASE( 'V' ) 1421 1421 1422 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA21422 IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 1423 1423 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 1424 1424 ijje = mje_crs(2) … … 1453 1453 CASE( 'U' ) 1454 1454 1455 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA21455 IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 1456 1456 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 1457 1457 je_2 = mje_crs(2) … … 1497 1497 CASE( 'T', 'W' ) 1498 1498 1499 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA21499 IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 1500 1500 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 1501 1501 je_2 = mje_crs(2) … … 1548 1548 CASE( 'V' ) 1549 1549 1550 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA21550 IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 1551 1551 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 1552 1552 ijje = mje_crs(2) … … 1581 1581 CASE( 'U' ) 1582 1582 1583 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA21583 IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 1584 1584 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 1585 1585 je_2 = mje_crs(2) … … 1665 1665 ENDDO 1666 1666 1667 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA21667 IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 1668 1668 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 1669 1669 je_2 = mje_crs(2) … … 1808 1808 END SELECT 1809 1809 1810 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA21810 IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 1811 1811 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 1812 1812 je_2 = mje_crs(2) … … 1899 1899 ! 2.a Define processor domain 1900 1900 IF( .NOT. lk_mpp ) THEN 1901 nimpp_crs = 1 1902 njmpp_crs = 1 1903 nlci_crs = jpi_crs 1904 nlcj_crs = jpj_crs 1905 nldi_crs = 1 1906 nldj_crs = 1 1907 nlei_crs = jpi_crs 1908 nlej_crs = jpj_crs 1901 nimpp_crs = 1 1902 njmpp_crs = 1 1903 Nis0_crs = 1 1904 Njs0_crs = 1 1905 Nie0_crs = jpi_crs 1906 Nje0_crs = jpj_crs 1909 1907 ELSE 1910 1908 ! Initialisation of most local variables - 1911 nimpp_crs = 1 1912 njmpp_crs = 1 1913 nlci_crs = jpi_crs 1914 nlcj_crs = jpj_crs 1915 nldi_crs = 1 1916 nldj_crs = 1 1917 nlei_crs = jpi_crs 1918 nlej_crs = jpj_crs 1909 nimpp_crs = 1 1910 njmpp_crs = 1 1911 Nis0_crs = 1 1912 Njs0_crs = 1 1913 Nie0_crs = jpi_crs 1914 Nje0_crs = jpj_crs 1919 1915 1920 1916 ! Calculs suivant une découpage en j 1921 1917 DO jn = 1, jpnij, jpni 1922 1918 IF( jn < ( jpnij - jpni + 1 ) ) THEN 1923 n lejt_crs(jn) = AINT( REAL( ( jpjglo - (njmppt(jn ) - 1) ) / nn_facty, wp ) ) &1919 nje0all_crs(jn) = AINT( REAL( ( jpjglo - (njmppt(jn ) - 1) ) / nn_facty, wp ) ) & 1924 1920 & - AINT( REAL( ( jpjglo - (njmppt(jn+jpni) - 1) ) / nn_facty, wp ) ) 1925 1921 ELSE 1926 n lejt_crs(jn) = AINT( REAL( nlejt(jn) / nn_facty, wp ) ) + 11922 nje0all_crs(jn) = AINT( REAL( nje0all(jn) / nn_facty, wp ) ) + 1 1927 1923 ENDIF 1928 IF( noso < 0 ) n lejt_crs(jn) = nlejt_crs(jn) + 11924 IF( noso < 0 ) nje0all_crs(jn) = nje0all_crs(jn) + 1 1929 1925 SELECT CASE( ibonjt(jn) ) 1930 1926 CASE ( -1 ) 1931 IF( MOD( jpjglo - njmppt(jn), nn_facty) > 0 ) n lejt_crs(jn) = nlejt_crs(jn) + 11932 nlcjt_crs(jn) = nlejt_crs(jn) + nn_hls1933 n ldjt_crs(jn) = nldjt(jn)1927 IF( MOD( jpjglo - njmppt(jn), nn_facty) > 0 ) nje0all_crs(jn) = nje0all_crs(jn) + 1 1928 jpjall_crs (jn) = nje0all_crs(jn) + nn_hls 1929 njs0all_crs(jn) = njs0all(jn) 1934 1930 1935 1931 CASE ( 0 ) 1936 1932 1937 n ldjt_crs(jn) = nldjt(jn)1938 IF( n ldjt(jn) == 1 ) nlejt_crs(jn) = nlejt_crs(jn) + 11939 n lejt_crs(jn) = nlejt_crs(jn) + nn_hls1940 nlcjt_crs(jn) = nlejt_crs(jn) + nn_hls1933 njs0all_crs(jn) = njs0all(jn) 1934 IF( njs0all(jn) == 1 ) nje0all_crs(jn) = nje0all_crs(jn) + 1 1935 nje0all_crs(jn) = nje0all_crs(jn) + nn_hls 1936 jpjall_crs (jn) = nje0all_crs(jn) + nn_hls 1941 1937 1942 1938 CASE ( 1, 2 ) 1943 1939 1944 n lejt_crs(jn) = nlejt_crs(jn) + nn_hls1945 nlcjt_crs(jn) = nlejt_crs(jn)1946 n ldjt_crs(jn) = nldjt(jn)1940 nje0all_crs(jn) = nje0all_crs(jn) + nn_hls 1941 jpjall_crs (jn) = nje0all_crs(jn) 1942 njs0all_crs(jn) = njs0all(jn) 1947 1943 1948 1944 CASE DEFAULT 1949 1945 CALL ctl_stop( 'STOP', 'error from crs_dom_def, you should not be there (1) ...' ) 1950 1946 END SELECT 1951 IF( nlcjt_crs(jn) > jpj_crs ) jpj_crs = jpj_crs + 11952 1953 IF(n ldjt_crs(jn) == 1 ) THEN1947 IF( jpjall_crs(jn) > jpj_crs ) jpj_crs = jpj_crs + 1 1948 1949 IF(njs0all_crs(jn) == 1 ) THEN 1954 1950 njmppt_crs(jn) = 1 1955 1951 ELSE … … 1958 1954 1959 1955 DO jj = jn + 1, jn + jpni - 1 1960 n lejt_crs(jj) = nlejt_crs(jn)1961 nlcjt_crs(jj) = nlcjt_crs(jn)1962 n ldjt_crs(jj) = nldjt_crs(jn)1963 njmppt_crs (jj)= njmppt_crs(jn)1956 nje0all_crs(jj) = nje0all_crs(jn) 1957 jpjall_crs (jj) = jpjall_crs(jn) 1958 njs0all_crs(jj) = njs0all_crs(jn) 1959 njmppt_crs (jj) = njmppt_crs(jn) 1964 1960 ENDDO 1965 1961 ENDDO 1966 nlej_crs = nlejt_crs(nproc + 1)1967 nlcj_crs = nlcjt_crs(nproc + 1)1968 nldj_crs = nldjt_crs(nproc + 1)1969 njmpp_crs = njmppt_crs (nproc + 1)1962 Nje0_crs = nje0all_crs(nproc + 1) 1963 jpj_crs = jpjall_crs (nproc + 1) 1964 Njs0_crs = njs0all_crs(nproc + 1) 1965 njmpp_crs = njmppt_crs (nproc + 1) 1970 1966 1971 1967 ! Calcul suivant un decoupage en i 1972 1968 DO jn = 1, jpni 1973 1969 IF( jn == 1 ) THEN 1974 n leit_crs(jn) = AINT( REAL( ( nimppt(jn ) - 1 + nlcit(jn ) ) / nn_factx, wp) )1970 nie0all_crs(jn) = AINT( REAL( ( nimppt(jn ) - 1 + jpiall(jn ) ) / nn_factx, wp) ) 1975 1971 ELSE 1976 n leit_crs(jn) = AINT( REAL( ( nimppt(jn ) - 1 + nlcit(jn ) ) / nn_factx, wp) ) &1977 & - AINT( REAL( ( nimppt(jn-1) - 1 + nlcit(jn-1) ) / nn_factx, wp) )1972 nie0all_crs(jn) = AINT( REAL( ( nimppt(jn ) - 1 + jpiall(jn ) ) / nn_factx, wp) ) & 1973 & - AINT( REAL( ( nimppt(jn-1) - 1 + jpiall(jn-1) ) / nn_factx, wp) ) 1978 1974 ENDIF 1979 1975 1980 1976 SELECT CASE( ibonit(jn) ) 1981 1977 CASE ( -1 ) 1982 n leit_crs(jn) = nleit_crs(jn) + nn_hls1983 nlcit_crs(jn) = nleit_crs(jn) + nn_hls1984 n ldit_crs(jn) = nldit(jn)1978 nie0all_crs(jn) = nie0all_crs(jn) + nn_hls 1979 jpiall_crs (jn) = nie0all_crs(jn) + nn_hls 1980 nis0all_crs(jn) = nis0all(jn) 1985 1981 1986 1982 CASE ( 0 ) 1987 n leit_crs(jn) = nleit_crs(jn) + nn_hls1988 nlcit_crs(jn) = nleit_crs(jn) + nn_hls1989 n ldit_crs(jn) = nldit(jn)1983 nie0all_crs(jn) = nie0all_crs(jn) + nn_hls 1984 jpiall_crs (jn) = nie0all_crs(jn) + nn_hls 1985 nis0all_crs(jn) = nis0all(jn) 1990 1986 1991 1987 CASE ( 1, 2 ) 1992 IF( MOD( jpiglo - nimppt(jn), nn_factx) > 0 ) n leit_crs(jn) = nleit_crs(jn) + 11993 n leit_crs(jn) = nleit_crs(jn) + nn_hls1994 nlcit_crs(jn) = nleit_crs(jn)1995 n ldit_crs(jn) = nldit(jn)1988 IF( MOD( jpiglo - nimppt(jn), nn_factx) > 0 ) nie0all_crs(jn) = nie0all_crs(jn) + 1 1989 nie0all_crs(jn) = nie0all_crs(jn) + nn_hls 1990 jpiall_crs (jn) = nie0all_crs(jn) 1991 nis0all_crs(jn) = nis0all(jn) 1996 1992 1997 1993 CASE DEFAULT … … 2001 1997 nimppt_crs(jn) = ANINT( REAL( (nimppt(jn) + 1 ) / nn_factx, wp ) ) + 1 2002 1998 DO jj = jn + jpni , jpnij, jpni 2003 n leit_crs(jj) = nleit_crs(jn)2004 nlcit_crs(jj) = nlcit_crs(jn)2005 n ldit_crs(jj) = nldit_crs(jn)2006 nimppt_crs (jj)= nimppt_crs(jn)1999 nie0all_crs(jj) = nie0all_crs(jn) 2000 jpiall_crs (jj) = jpiall_crs (jn) 2001 nis0all_crs(jj) = nis0all_crs(jn) 2002 nimppt_crs (jj) = nimppt_crs (jn) 2007 2003 ENDDO 2008 2004 ENDDO 2009 2005 2010 nlei_crs = nleit_crs(nproc + 1)2011 nlci_crs = nlcit_crs(nproc + 1)2012 nldi_crs = nldit_crs(nproc + 1)2013 nimpp_crs = nimppt_crs (nproc + 1)2006 Nie0_crs = nie0all_crs(nproc + 1) 2007 jpi_crs = jpiall_crs (nproc + 1) 2008 Nis0_crs = nis0all_crs(nproc + 1) 2009 nimpp_crs = nimppt_crs (nproc + 1) 2014 2010 2015 2011 DO ji = 1, jpi_crs … … 2043 2039 jpjglo_full = jpjglo 2044 2040 2045 nlcj_full = nlcj2046 nlci_full = nlci2047 nldi_full = nldi2048 nldj_full = nldj2049 nlei_full = nlei2050 nlej_full = nlej2051 nimpp_full 2052 njmpp_full 2041 jpj_full = jpj 2042 jpi_full = jpi 2043 Nis0_full = Nis0 2044 Njs0_full = Njs0 2045 Nie0_full = Nie0 2046 Nje0_full = Nje0 2047 nimpp_full = nimpp 2048 njmpp_full = njmpp 2053 2049 2054 nlcit_full(:) = nlcit(:)2055 n ldit_full(:) = nldit(:)2056 n leit_full(:) = nleit(:)2057 nimppt_full (:) = nimppt(:)2058 nlcjt_full(:) = nlcjt(:)2059 n ldjt_full(:) = nldjt(:)2060 n lejt_full(:) = nlejt(:)2061 njmppt_full (:) = njmppt(:)2050 jpiall_full (:) = jpiall (:) 2051 nis0all_full(:) = nis0all(:) 2052 nie0all_full(:) = nie0all(:) 2053 nimppt_full (:) = nimppt (:) 2054 jpjall_full (:) = jpjall (:) 2055 njs0all_full(:) = njs0all(:) 2056 nje0all_full(:) = nje0all(:) 2057 njmppt_full (:) = njmppt (:) 2062 2058 2063 2059 CALL dom_grid_crs !swich de grille … … 2073 2069 WRITE(numout,*) 2074 2070 WRITE(numout,*) ' nproc = ' , nproc 2075 WRITE(numout,*) ' nlci = ' , nlci2076 WRITE(numout,*) ' nlcj = ' , nlcj2077 WRITE(numout,*) ' nldi = ' , nldi2078 WRITE(numout,*) ' nldj = ' , nldj2079 WRITE(numout,*) ' nlei = ' , nlei2080 WRITE(numout,*) ' nlej = ' , nlej2081 WRITE(numout,*) ' nlei_full=' , nlei_full2082 WRITE(numout,*) ' nldi_full=' , nldi_full2071 WRITE(numout,*) ' jpi = ' , jpi 2072 WRITE(numout,*) ' jpj = ' , jpj 2073 WRITE(numout,*) ' Nis0 = ' , Nis0 2074 WRITE(numout,*) ' Njs0 = ' , Njs0 2075 WRITE(numout,*) ' Nie0 = ' , Nie0 2076 WRITE(numout,*) ' Nje0 = ' , Nje0 2077 WRITE(numout,*) ' Nie0_full=' , Nie0_full 2078 WRITE(numout,*) ' Nis0_full=' , Nis0_full 2083 2079 WRITE(numout,*) ' nimpp = ' , nimpp 2084 2080 WRITE(numout,*) ' njmpp = ' , njmpp … … 2203 2199 mje_crs(:) = mje2_crs(:) 2204 2200 ELSE 2205 DO jj = 1, nlej_crs2201 DO jj = 1, Nje0_crs 2206 2202 mjs_crs(jj) = mjs2_crs(mjg_crs(jj)) - njmpp + 1 2207 2203 mje_crs(jj) = mje2_crs(mjg_crs(jj)) - njmpp + 1 2208 2204 ENDDO 2209 DO ji = 1, nlei_crs2205 DO ji = 1, Nie0_crs 2210 2206 mis_crs(ji) = mis2_crs(mig_crs(ji)) - nimpp + 1 2211 2207 mie_crs(ji) = mie2_crs(mig_crs(ji)) - nimpp + 1 … … 2213 2209 ENDIF 2214 2210 ! 2215 nistr = mis_crs(2) ; niend = mis_crs( nlci_crs - 1)2216 njstr = mjs_crs(3) ; njend = mjs_crs( nlcj_crs - 1)2211 nistr = mis_crs(2) ; niend = mis_crs(jpi_crs - 1) 2212 njstr = mjs_crs(3) ; njend = mjs_crs(jpj_crs - 1) 2217 2213 ! 2218 2214 END SUBROUTINE crs_dom_def -
NEMO/trunk/src/OCE/CRS/crsdomwri.F90
r13226 r13286 50 50 INTEGER :: ji, jj, jk ! dummy loop indices 51 51 INTEGER :: inum ! local units for 'mesh_mask.nc' file 52 INTEGER :: iif, iil, ijf, ijl53 52 CHARACTER(len=21) :: clnam ! filename (mesh and mask informations) 54 53 ! ! workspace … … 76 75 CALL iom_rstput( 0, 0, inum, 'fmask', fmask_crs, ktype = jp_i1 ) 77 76 78 79 tmask_i_crs(:,:) = tmask_crs(:,:,1) 80 iif = nn_hls 81 iil = nlci_crs - nn_hls + 1 82 ijf = nn_hls 83 ijl = nlcj_crs - nn_hls + 1 84 85 tmask_i_crs( 1:iif , : ) = 0._wp 86 tmask_i_crs(iil:jpi_crs, : ) = 0._wp 87 tmask_i_crs( : , 1:ijf ) = 0._wp 88 tmask_i_crs( : ,ijl:jpj_crs) = 0._wp 89 90 91 tpol_crs(1:jpiglo_crs,:) = 1._wp 92 fpol_crs(1:jpiglo_crs,:) = 1._wp 93 IF( jperio == 3 .OR. jperio == 4 ) THEN 94 tpol_crs(jpiglo_crs/2+1:jpiglo_crs,:) = 0._wp 95 fpol_crs( 1 :jpiglo_crs,:) = 0._wp 96 IF( mjg_crs(nlej_crs) == jpiglo_crs ) THEN 97 DO ji = iif+1, iil-1 98 tmask_i_crs(ji,nlej_crs-1) = tmask_i_crs(ji,nlej_crs-1) & 99 & * tpol_crs(mig_crs(ji),1) 100 ENDDO 101 ENDIF 102 ENDIF 103 IF( jperio == 5 .OR. jperio == 6 ) THEN 104 tpol_crs( 1 :jpiglo_crs,:)=0._wp 105 fpol_crs(jpiglo_crs/2+1:jpiglo_crs,:)=0._wp 106 ENDIF 107 108 CALL iom_rstput( 0, 0, inum, 'tmaskutil', tmask_i_crs, ktype = jp_i1 ) 109 ! ! unique point mask 77 CALL dom_uniq_crs( zprw, 'T' ) 78 zprt = tmask_crs(:,:,1) * zprw 79 CALL iom_rstput( 0, 0, inum, 'tmaskutil', zprt, ktype = jp_i1 ) 110 80 CALL dom_uniq_crs( zprw, 'U' ) 111 81 zprt = umask_crs(:,:,1) * zprw … … 211 181 REAL(wp) :: zshift ! shift value link to the process number 212 182 INTEGER :: ji ! dummy loop indices 213 LOGICAL , DIMENSION(SIZE(puniq,1),SIZE(puniq,2),1) :: lldbl! store whether each point is unique or not214 REAL(wp), DIMENSION(jpi_crs,jpj_crs ) ::ztstref183 LOGICAL , DIMENSION(jpi_crs,jpj_crs,1) :: lluniq ! store whether each point is unique or not 184 REAL(wp), DIMENSION(jpi_crs,jpj_crs ) :: ztstref 215 185 !!---------------------------------------------------------------------- 216 186 ! … … 218 188 ! in mpp: make sure that these values are different even between process 219 189 ! -> apply a shift value according to the process number 220 zshift = jpi_crs * jpj_crs * ( narea - 1 )190 zshift = (jpi_crs+1.) * (jpj_crs+1.) * ( narea - 1 ) ! we should use jpimax_crs but not existing 221 191 ztstref(:,:) = RESHAPE( (/ (zshift + REAL(ji,wp), ji = 1, jpi_crs*jpj_crs) /), (/ jpi_crs, jpj_crs /) ) 222 192 ! 223 193 puniq(:,:) = ztstref(:,:) ! default definition 224 194 CALL crs_lbc_lnk( puniq,cdgrd, 1.0_wp ) ! apply boundary conditions 225 lldbl(:,:,1) = puniq(:,:) == ztstref(:,:) ! check which values have been changed 226 ! 227 puniq(:,:) = 1. ! default definition 228 ! fill only the inner part of the cpu with llbl converted into real 229 puniq(nldi_crs:nlei_crs,nldj_crs:nlej_crs) = REAL( COUNT( lldbl(nldi_crs:nlei_crs,nldj_crs:nlej_crs,:), dim = 3 ) , wp ) 195 lluniq(:,:,1) = puniq(:,:) == ztstref(:,:) ! check which values have been changed 196 ! 197 puniq(:,:) = REAL( COUNT( lluniq(:,:,:), dim = 3 ), wp ) 230 198 ! 231 199 END SUBROUTINE dom_uniq_crs -
NEMO/trunk/src/OCE/DIA/diaar5.F90
r13237 r13286 396 396 ALLOCATE( zsaldta(jpi,jpj,jpk,jpts) ) 397 397 CALL iom_open ( 'sali_ref_clim_monthly', inum ) 398 CALL iom_get ( inum, jpdom_ data, 'vosaline' , zsaldta(:,:,:,1), 1 )399 CALL iom_get ( inum, jpdom_ data, 'vosaline' , zsaldta(:,:,:,2), 12 )398 CALL iom_get ( inum, jpdom_global, 'vosaline' , zsaldta(:,:,:,1), 1 ) 399 CALL iom_get ( inum, jpdom_global, 'vosaline' , zsaldta(:,:,:,2), 12 ) 400 400 CALL iom_close( inum ) 401 401 -
NEMO/trunk/src/OCE/DIA/diadct.F90
r13237 r13286 412 412 ijloc=ijglo-njmpp+1 ! " 413 413 414 !verify if the point is on the local domain:(1, nlei)*(1,nlej)415 IF( iiloc >= 1 .AND. iiloc <= nlei.AND. &416 ijloc >= 1 .AND. ijloc <= nlej)THEN414 !verify if the point is on the local domain:(1,Nie0)*(1,Nje0) 415 IF( iiloc >= 1 .AND. iiloc <= Nie0 .AND. & 416 ijloc >= 1 .AND. ijloc <= Nje0 )THEN 417 417 iptloc = iptloc + 1 ! count local points 418 418 secs(jsec)%listPoint(iptloc) = POINT_SECTION(mi0(iiglo),mj0(ijglo)) ! store local coordinates … … 519 519 520 520 !which coordinate shall we verify ? 521 IF ( cdind=='I' )THEN ; itest= nlei; iind=1522 ELSE IF ( cdind=='J' )THEN ; itest= nlej; iind=2521 IF ( cdind=='I' )THEN ; itest=Nie0 ; iind=1 522 ELSE IF ( cdind=='J' )THEN ; itest=Nje0 ; iind=2 523 523 ELSE ; CALL ctl_stop("removepoints :Wrong value for cdind") 524 524 ENDIF -
NEMO/trunk/src/OCE/DIA/diahsb.F90
r13237 r13286 274 274 CALL iom_get( numror, 'frc_wn_s', frc_wn_s, ldxios = lrxios ) 275 275 ENDIF 276 CALL iom_get( numror, jpdom_auto glo, 'surf_ini' , surf_ini , ldxios = lrxios ) ! ice sheet coupling277 CALL iom_get( numror, jpdom_auto glo, 'ssh_ini' , ssh_ini , ldxios = lrxios )278 CALL iom_get( numror, jpdom_auto glo, 'e3t_ini' , e3t_ini , ldxios = lrxios )279 CALL iom_get( numror, jpdom_auto glo, 'tmask_ini' , tmask_ini , ldxios = lrxios )280 CALL iom_get( numror, jpdom_auto glo, 'hc_loc_ini', hc_loc_ini, ldxios = lrxios )281 CALL iom_get( numror, jpdom_auto glo, 'sc_loc_ini', sc_loc_ini, ldxios = lrxios )276 CALL iom_get( numror, jpdom_auto, 'surf_ini' , surf_ini , ldxios = lrxios ) ! ice sheet coupling 277 CALL iom_get( numror, jpdom_auto, 'ssh_ini' , ssh_ini , ldxios = lrxios ) 278 CALL iom_get( numror, jpdom_auto, 'e3t_ini' , e3t_ini , ldxios = lrxios ) 279 CALL iom_get( numror, jpdom_auto, 'tmask_ini' , tmask_ini , ldxios = lrxios ) 280 CALL iom_get( numror, jpdom_auto, 'hc_loc_ini', hc_loc_ini, ldxios = lrxios ) 281 CALL iom_get( numror, jpdom_auto, 'sc_loc_ini', sc_loc_ini, ldxios = lrxios ) 282 282 IF( ln_linssh ) THEN 283 CALL iom_get( numror, jpdom_auto glo, 'ssh_hc_loc_ini', ssh_hc_loc_ini, ldxios = lrxios )284 CALL iom_get( numror, jpdom_auto glo, 'ssh_sc_loc_ini', ssh_sc_loc_ini, ldxios = lrxios )283 CALL iom_get( numror, jpdom_auto, 'ssh_hc_loc_ini', ssh_hc_loc_ini, ldxios = lrxios ) 284 CALL iom_get( numror, jpdom_auto, 'ssh_sc_loc_ini', ssh_sc_loc_ini, ldxios = lrxios ) 285 285 ENDIF 286 286 ELSE -
NEMO/trunk/src/OCE/DIA/diaptr.F90
r13237 r13286 355 355 btmsk(:,:,1) = tmask_i(:,:) 356 356 CALL iom_open( 'subbasins', inum, ldstop = .FALSE. ) 357 CALL iom_get( inum, jpdom_ data, 'atlmsk', btmsk(:,:,2) ) ! Atlantic basin358 CALL iom_get( inum, jpdom_ data, 'pacmsk', btmsk(:,:,3) ) ! Pacific basin359 CALL iom_get( inum, jpdom_ data, 'indmsk', btmsk(:,:,4) ) ! Indian basin357 CALL iom_get( inum, jpdom_global, 'atlmsk', btmsk(:,:,2) ) ! Atlantic basin 358 CALL iom_get( inum, jpdom_global, 'pacmsk', btmsk(:,:,3) ) ! Pacific basin 359 CALL iom_get( inum, jpdom_global, 'indmsk', btmsk(:,:,4) ) ! Indian basin 360 360 CALL iom_close( inum ) 361 361 btmsk(:,:,5) = MAX ( btmsk(:,:,3), btmsk(:,:,4) ) ! Indo-Pacific basin -
NEMO/trunk/src/OCE/DIA/diawri.F90
r13237 r13286 471 471 472 472 ! Define indices of the horizontal output zoom and vertical limit storage 473 iimi = 1 ; iima = jpi474 ijmi = 1 ; ijma = jpj473 iimi = Nis0 ; iima = Nie0 474 ijmi = Njs0 ; ijma = Nje0 475 475 ipk = jpk 476 476 IF(ln_abl) ipka = jpkam1 -
NEMO/trunk/src/OCE/DOM/closea.F90
r12377 r13286 22 22 ! 23 23 USE diu_bulk , ONLY: ln_diurnal_only ! used for sanity check 24 USE iom , ONLY: iom_open, iom_get, iom_close, jpdom_ data! I/O routines24 USE iom , ONLY: iom_open, iom_get, iom_close, jpdom_global ! I/O routines 25 25 USE lib_fortran , ONLY: glob_sum ! fortran library 26 26 USE lib_mpp , ONLY: mpp_max, ctl_nam, ctl_stop ! MPP library … … 236 236 ! 237 237 CALL iom_open ( cd_file, ics ) 238 CALL iom_get ( ics, jpdom_ data, TRIM(cd_var), zdta )238 CALL iom_get ( ics, jpdom_global, TRIM(cd_var), zdta ) 239 239 CALL iom_close( ics ) 240 240 k_mskout(:,:) = NINT(zdta(:,:)) -
NEMO/trunk/src/OCE/DOM/daymod.F90
r13226 r13286 279 279 IF(sn_cfctl%l_prtctl) THEN 280 280 WRITE(charout,FMT="('kt =', I4,' d/m/y =',I2,I2,I4)") kt, nday, nmonth, nyear 281 CALL prt_ctl_info( charout)281 CALL prt_ctl_info( charout ) 282 282 ENDIF 283 283 -
NEMO/trunk/src/OCE/DOM/dom_oce.F90
r13237 r13286 76 76 ! !: domain MPP decomposition parameters 77 77 INTEGER , PUBLIC :: nimpp, njmpp !: i- & j-indexes for mpp-subdomain left bottom 78 INTEGER , PUBLIC :: nreci, nrecj !: overlap region in i and j79 78 INTEGER , PUBLIC :: nproc !: number for local processor 80 79 INTEGER , PUBLIC :: narea !: number for local area … … 86 85 87 86 INTEGER, PUBLIC :: npolj !: north fold mark (0, 3 or 4) 88 INTEGER, PUBLIC :: nlci, nldi, nlei !: i-dimensions of the local subdomain and its first and last indoor indices89 INTEGER, PUBLIC :: nlcj, nldj, nlej !: i-dimensions of the local subdomain and its first and last indoor indices90 87 INTEGER, PUBLIC :: noea, nowe !: index of the local neighboring processors in 91 88 INTEGER, PUBLIC :: noso, nono !: east, west, south and north directions 92 89 INTEGER, PUBLIC :: nidom !: ??? 93 90 94 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mig !: local ==> global domain i-index 95 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mjg !: local ==> global domain j-index 96 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mi0, mi1 !: global ==> local domain i-index (mi0=1 and mi1=0 if the global index 97 ! ! is not in the local domain) 98 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mj0, mj1 !: global ==> local domain j-index (mj0=1 and mj1=0 if the global index 99 ! ! is not in the local domain) 100 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nimppt, njmppt !: i-, j-indexes for each processor 101 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ibonit, ibonjt !: i-, j- processor neighbour existence 102 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nlcit , nlcjt !: dimensions of every subdomain 103 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nldit , nldjt !: first, last indoor index for each i-domain 104 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nleit , nlejt !: first, last indoor index for each j-domain 105 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: nfiimpp, nfipproc, nfilcit 91 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mig !: local ==> global domain, including halos (jpiglo), i-index 92 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mjg !: local ==> global domain, including halos (jpjglo), j-index 93 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mig0 !: local ==> global domain, excluding halos (Ni0glo), i-index 94 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mjg0 !: local ==> global domain, excluding halos (Nj0glo), j-index 95 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mig0_oldcmp !: local ==> global domain, excluding halos (Ni0glo), i-index 96 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mjg0_oldcmp !: local ==> global domain, excluding halos (Nj0glo), j-index 97 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mi0, mi1 !: global, including halos (jpiglo) ==> local domain i-index 98 ! !: (mi0=1 and mi1=0 if global index not in local domain) 99 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mj0, mj1 !: global, including halos (jpjglo) ==> local domain j-index 100 ! !: (mj0=1 and mj1=0 if global index not in local domain) 101 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nimppt, njmppt !: i-, j-indexes for each processor 102 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ibonit, ibonjt !: i-, j- processor neighbour existence 103 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: jpiall, jpjall !: dimensions of all subdomain 104 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nis0all, njs0all !: first, last indoor index for all i-subdomain 105 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nie0all, nje0all !: first, last indoor index for all j-subdomain 106 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nfimpp, nfproc, nfjpi 106 107 107 108 !!---------------------------------------------------------------------- … … 116 117 ! 117 118 REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2t , r1_e1e2t !: associated metrics at t-point 118 REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2u , r1_e1e2u , e2_e1u!: associated metrics at u-point119 REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2v , r1_e1e2v , e1_e2v!: associated metrics at v-point119 REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2u , e2_e1u, r1_e1e2u !: associated metrics at u-point 120 REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2v , e1_e2v, r1_e1e2v !: associated metrics at v-point 120 121 REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2f , r1_e1e2f !: associated metrics at f-point 121 122 ! … … 187 188 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tmask_h !: internal domain T-point mask (Figure 8.5 NEMO book) 188 189 189 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mikt, miku, mikv, mikf !: top first wet T-, U-, V-, F-level (ISF)190 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mikt, miku, mikv, mikf !: top first wet T-, U-, V-, F-level (ISF) 190 191 191 192 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ssmask, ssumask, ssvmask, ssfmask !: surface mask at T-,U-, V- and F-pts 192 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: tmask, umask, vmask, fmask !: land/ocean mask at T-, U-, V- and F-pts 193 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: wmask, wumask, wvmask !: land/ocean mask at WT-, WU- and WV-pts 194 195 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: tpol, fpol !: north fold mask (jperio= 3 or 4) 193 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: tmask, umask, vmask, wmask, fmask !: land/ocean mask at T-, U-, V-, W- and F-pts 194 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: wumask, wvmask !: land/ocean mask at WT-, WU- and WV-pts 196 195 197 196 !!---------------------------------------------------------------------- … … 262 261 ! 263 262 ii = ii+1 264 ALLOCATE( mig(jpi), mjg(jpj), STAT=ierr(ii) ) 265 ! 266 ii = ii+1 267 ALLOCATE( mi0(jpiglo) , mi1 (jpiglo), mj0(jpjglo) , mj1 (jpjglo) , & 268 & tpol(jpiglo) , fpol(jpiglo) , STAT=ierr(ii) ) 263 ALLOCATE( mig(jpi), mjg(jpj), mig0(jpi), mjg0(jpj), mig0_oldcmp(jpi), mjg0_oldcmp(jpj), STAT=ierr(ii) ) 264 ! 265 ii = ii+1 266 ALLOCATE( mi0(jpiglo), mi1(jpiglo), mj0(jpjglo), mj1(jpjglo), STAT=ierr(ii) ) 269 267 ! 270 268 ii = ii+1 -
NEMO/trunk/src/OCE/DOM/domain.F90
r13237 r13286 240 240 !! ** Method : 241 241 !! 242 !! ** Action : - mig , mjg : local domain indices ==> global domain indices 242 !! ** Action : - mig , mjg : local domain indices ==> global domain, including halos, indices 243 !! - mig0, mjg0: local domain indices ==> global domain, excluding halos, indices 243 244 !! - mi0 , mi1 : global domain indices ==> local domain indices 244 !! - mj0 ,, mj1 (global point not in the local domain ==> mi0>mi1 and/or mj0>mj1)245 !! - mj0 , mj1 (if global point not in the local domain ==> mi0>mi1 and/or mj0>mj1) 245 246 !!---------------------------------------------------------------------- 246 247 INTEGER :: ji, jj ! dummy loop argument 247 248 !!---------------------------------------------------------------------- 248 249 ! 249 DO ji = 1, jpi ! local domain indices ==> global domain indices250 DO ji = 1, jpi ! local domain indices ==> global domain, including halos, indices 250 251 mig(ji) = ji + nimpp - 1 251 252 END DO … … 253 254 mjg(jj) = jj + njmpp - 1 254 255 END DO 255 ! ! global domain indices ==> local domain indices 256 ! ! local domain indices ==> global domain, excluding halos, indices 257 ! 258 mig0(:) = mig(:) - nn_hls 259 mjg0(:) = mjg(:) - nn_hls 260 ! WARNING: to keep compatibility with the trunk that was including periodocity into the input data, 261 ! we must define mig0 and mjg0 as bellow. 262 ! Once we decide to forget trunk compatibility, we must simply define mig0 and mjg0 as: 263 mig0_oldcmp(:) = mig0(:) + COUNT( (/ jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7 /) ) 264 mjg0_oldcmp(:) = mjg0(:) + COUNT( (/ jperio == 2 .OR. jperio == 7 /) ) 265 ! 266 ! ! global domain, including halos, indices ==> local domain indices 256 267 ! ! (return (m.0,m.1)=(1,0) if data domain gridpoint is to the west/south of the 257 268 ! ! local domain, or (m.0,m.1)=(jp.+1,jp.) to the east/north of local domain. … … 271 282 WRITE(numout,*) ' local domain: jpi = ', jpi , ' jpj = ', jpj , ' jpk = ', jpk 272 283 WRITE(numout,*) 273 WRITE(numout,*) ' conversion from local to global domain indices (and vise versa) done' 274 IF( nn_print >= 1 ) THEN 275 WRITE(numout,*) 276 WRITE(numout,*) ' conversion local ==> global i-index domain (mig)' 277 WRITE(numout,25) (mig(ji),ji = 1,jpi) 278 WRITE(numout,*) 279 WRITE(numout,*) ' conversion global ==> local i-index domain' 280 WRITE(numout,*) ' starting index (mi0)' 281 WRITE(numout,25) (mi0(ji),ji = 1,jpiglo) 282 WRITE(numout,*) ' ending index (mi1)' 283 WRITE(numout,25) (mi1(ji),ji = 1,jpiglo) 284 WRITE(numout,*) 285 WRITE(numout,*) ' conversion local ==> global j-index domain (mjg)' 286 WRITE(numout,25) (mjg(jj),jj = 1,jpj) 287 WRITE(numout,*) 288 WRITE(numout,*) ' conversion global ==> local j-index domain' 289 WRITE(numout,*) ' starting index (mj0)' 290 WRITE(numout,25) (mj0(jj),jj = 1,jpjglo) 291 WRITE(numout,*) ' ending index (mj1)' 292 WRITE(numout,25) (mj1(jj),jj = 1,jpjglo) 293 ENDIF 294 ENDIF 295 25 FORMAT( 100(10x,19i4,/) ) 284 ENDIF 296 285 ! 297 286 END SUBROUTINE dom_glo … … 413 402 #endif 414 403 415 #if defined key_agrif416 404 IF( Agrif_Root() ) THEN 417 #endif 418 IF(lwp) WRITE(numout,*) 419 SELECT CASE ( nleapy ) ! Choose calendar for IOIPSL 420 CASE ( 1 ) 421 CALL ioconf_calendar('gregorian') 422 IF(lwp) WRITE(numout,*) ' ==>>> The IOIPSL calendar is "gregorian", i.e. leap year' 423 CASE ( 0 ) 424 CALL ioconf_calendar('noleap') 425 IF(lwp) WRITE(numout,*) ' ==>>> The IOIPSL calendar is "noleap", i.e. no leap year' 426 CASE ( 30 ) 427 CALL ioconf_calendar('360d') 428 IF(lwp) WRITE(numout,*) ' ==>>> The IOIPSL calendar is "360d", i.e. 360 days in a year' 429 END SELECT 430 #if defined key_agrif 431 ENDIF 432 #endif 405 IF(lwp) WRITE(numout,*) 406 SELECT CASE ( nleapy ) ! Choose calendar for IOIPSL 407 CASE ( 1 ) 408 CALL ioconf_calendar('gregorian') 409 IF(lwp) WRITE(numout,*) ' ==>>> The IOIPSL calendar is "gregorian", i.e. leap year' 410 CASE ( 0 ) 411 CALL ioconf_calendar('noleap') 412 IF(lwp) WRITE(numout,*) ' ==>>> The IOIPSL calendar is "noleap", i.e. no leap year' 413 CASE ( 30 ) 414 CALL ioconf_calendar('360d') 415 IF(lwp) WRITE(numout,*) ' ==>>> The IOIPSL calendar is "360d", i.e. 360 days in a year' 416 END SELECT 417 ENDIF 433 418 434 419 READ ( numnam_ref, namdom, IOSTAT = ios, ERR = 903) … … 503 488 !! ** Method : compute and print extrema of masked scale factors 504 489 !!---------------------------------------------------------------------- 505 INTEGER, DIMENSION(2) :: imi1, imi2, ima1, ima2506 INTEGER, DIMENSION(2) :: iloc !507 REAL(wp) ::ze1min, ze1max, ze2min, ze2max490 LOGICAL, DIMENSION(jpi,jpj) :: llmsk 491 INTEGER, DIMENSION(2) :: imil, imip, imi1, imi2, imal, imap, ima1, ima2 492 REAL(wp) :: zglmin, zglmax, zgpmin, zgpmax, ze1min, ze1max, ze2min, ze2max 508 493 !!---------------------------------------------------------------------- 509 494 ! 510 495 IF(lk_mpp) THEN 511 CALL mpp_minloc( 'domain', e1t(:,:), tmask_i(:,:), ze1min, imi1 ) 512 CALL mpp_minloc( 'domain', e2t(:,:), tmask_i(:,:), ze2min, imi2 ) 513 CALL mpp_maxloc( 'domain', e1t(:,:), tmask_i(:,:), ze1max, ima1 ) 514 CALL mpp_maxloc( 'domain', e2t(:,:), tmask_i(:,:), ze2max, ima2 ) 496 CALL mpp_minloc( 'domain', glamt(:,:), tmask_i(:,:), zglmin, imil ) 497 CALL mpp_minloc( 'domain', gphit(:,:), tmask_i(:,:), zgpmin, imip ) 498 CALL mpp_minloc( 'domain', e1t(:,:), tmask_i(:,:), ze1min, imi1 ) 499 CALL mpp_minloc( 'domain', e2t(:,:), tmask_i(:,:), ze2min, imi2 ) 500 CALL mpp_maxloc( 'domain', glamt(:,:), tmask_i(:,:), zglmax, imal ) 501 CALL mpp_maxloc( 'domain', gphit(:,:), tmask_i(:,:), zgpmax, imap ) 502 CALL mpp_maxloc( 'domain', e1t(:,:), tmask_i(:,:), ze1max, ima1 ) 503 CALL mpp_maxloc( 'domain', e2t(:,:), tmask_i(:,:), ze2max, ima2 ) 515 504 ELSE 516 ze1min = MINVAL( e1t(:,:), mask = tmask_i(:,:) == 1._wp ) 517 ze2min = MINVAL( e2t(:,:), mask = tmask_i(:,:) == 1._wp ) 518 ze1max = MAXVAL( e1t(:,:), mask = tmask_i(:,:) == 1._wp ) 519 ze2max = MAXVAL( e2t(:,:), mask = tmask_i(:,:) == 1._wp ) 520 ! 521 iloc = MINLOC( e1t(:,:), mask = tmask_i(:,:) == 1._wp ) 522 imi1(1) = iloc(1) + nimpp - 1 523 imi1(2) = iloc(2) + njmpp - 1 524 iloc = MINLOC( e2t(:,:), mask = tmask_i(:,:) == 1._wp ) 525 imi2(1) = iloc(1) + nimpp - 1 526 imi2(2) = iloc(2) + njmpp - 1 527 iloc = MAXLOC( e1t(:,:), mask = tmask_i(:,:) == 1._wp ) 528 ima1(1) = iloc(1) + nimpp - 1 529 ima1(2) = iloc(2) + njmpp - 1 530 iloc = MAXLOC( e2t(:,:), mask = tmask_i(:,:) == 1._wp ) 531 ima2(1) = iloc(1) + nimpp - 1 532 ima2(2) = iloc(2) + njmpp - 1 533 ENDIF 505 llmsk = tmask_i(:,:) == 1._wp 506 zglmin = MINVAL( glamt(:,:), mask = llmsk ) 507 zgpmin = MINVAL( gphit(:,:), mask = llmsk ) 508 ze1min = MINVAL( e1t(:,:), mask = llmsk ) 509 ze2min = MINVAL( e2t(:,:), mask = llmsk ) 510 zglmin = MAXVAL( glamt(:,:), mask = llmsk ) 511 zgpmin = MAXVAL( gphit(:,:), mask = llmsk ) 512 ze1max = MAXVAL( e1t(:,:), mask = llmsk ) 513 ze2max = MAXVAL( e2t(:,:), mask = llmsk ) 514 ! 515 imil = MINLOC( glamt(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 516 imip = MINLOC( gphit(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 517 imi1 = MINLOC( e1t(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 518 imi2 = MINLOC( e2t(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 519 imal = MAXLOC( glamt(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 520 imap = MAXLOC( gphit(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 521 ima1 = MAXLOC( e1t(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 522 ima2 = MAXLOC( e2t(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 523 ENDIF 524 ! 534 525 IF(lwp) THEN 535 526 WRITE(numout,*) 536 527 WRITE(numout,*) 'dom_ctl : extrema of the masked scale factors' 537 528 WRITE(numout,*) '~~~~~~~' 538 WRITE(numout,"(14x,'e1t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1max, ima1(1), ima1(2) 539 WRITE(numout,"(14x,'e1t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1min, imi1(1), imi1(2) 540 WRITE(numout,"(14x,'e2t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2max, ima2(1), ima2(2) 541 WRITE(numout,"(14x,'e2t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2min, imi2(1), imi2(2) 529 WRITE(numout,"(14x,'glamt mini: ',1f10.2,' at i = ',i5,' j= ',i5)") zglmin, imil(1), imil(2) 530 WRITE(numout,"(14x,'glamt maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") zglmax, imal(1), imal(2) 531 WRITE(numout,"(14x,'gphit mini: ',1f10.2,' at i = ',i5,' j= ',i5)") zgpmin, imip(1), imip(2) 532 WRITE(numout,"(14x,'gphit maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") zgpmax, imap(1), imap(2) 533 WRITE(numout,"(14x,' e1t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1min, imi1(1), imi1(2) 534 WRITE(numout,"(14x,' e1t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1max, ima1(1), ima1(2) 535 WRITE(numout,"(14x,' e2t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2min, imi2(1), imi2(2) 536 WRITE(numout,"(14x,' e2t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2max, ima2(1), ima2(2) 542 537 ENDIF 543 538 ! … … 606 601 IF(lwp) THEN 607 602 WRITE(numout,*) ' cn_cfg = ', TRIM(cd_cfg), ' nn_cfg = ', kk_cfg 608 WRITE(numout,*) ' jpiglo = ', kpi609 WRITE(numout,*) ' jpjglo = ', kpj603 WRITE(numout,*) ' Ni0glo = ', kpi 604 WRITE(numout,*) ' Nj0glo = ', kpj 610 605 WRITE(numout,*) ' jpkglo = ', kpk 611 606 WRITE(numout,*) ' type of global domain lateral boundary jperio = ', kperio … … 631 626 !!---------------------------------------------------------------------- 632 627 INTEGER :: ji, jj, jk ! dummy loop indices 633 INTEGER :: izco, izps, isco, icav634 628 INTEGER :: inum ! local units 635 629 CHARACTER(len=21) :: clnam ! filename (mesh and mask informations) … … 646 640 ! 647 641 clnam = cn_domcfg_out ! filename (configuration information) 648 CALL iom_open( TRIM(clnam), inum, ldwrt = .TRUE. ) 649 642 CALL iom_open( TRIM(clnam), inum, ldwrt = .TRUE. ) 650 643 ! 651 644 ! !== ORCA family specificities ==! … … 655 648 ENDIF 656 649 ! 657 ! !== global domain size ==!658 !659 CALL iom_rstput( 0, 0, inum, 'jpiglo', REAL( jpiglo, wp), ktype = jp_i4 )660 CALL iom_rstput( 0, 0, inum, 'jpjglo', REAL( jpjglo, wp), ktype = jp_i4 )661 CALL iom_rstput( 0, 0, inum, 'jpkglo', REAL( jpk , wp), ktype = jp_i4 )662 !663 650 ! !== domain characteristics ==! 664 651 ! … … 667 654 ! 668 655 ! ! type of vertical coordinate 669 IF( ln_zco ) THEN ; izco = 1 ; ELSE ; izco = 0 ; ENDIF 670 IF( ln_zps ) THEN ; izps = 1 ; ELSE ; izps = 0 ; ENDIF 671 IF( ln_sco ) THEN ; isco = 1 ; ELSE ; isco = 0 ; ENDIF 672 CALL iom_rstput( 0, 0, inum, 'ln_zco' , REAL( izco, wp), ktype = jp_i4 ) 673 CALL iom_rstput( 0, 0, inum, 'ln_zps' , REAL( izps, wp), ktype = jp_i4 ) 674 CALL iom_rstput( 0, 0, inum, 'ln_sco' , REAL( isco, wp), ktype = jp_i4 ) 656 CALL iom_rstput( 0, 0, inum, 'ln_zco', REAL(COUNT((/ln_zco/)), wp), ktype = jp_i4 ) 657 CALL iom_rstput( 0, 0, inum, 'ln_zps', REAL(COUNT((/ln_zps/)), wp), ktype = jp_i4 ) 658 CALL iom_rstput( 0, 0, inum, 'ln_sco', REAL(COUNT((/ln_sco/)), wp), ktype = jp_i4 ) 675 659 ! 676 660 ! ! ocean cavities under iceshelves 677 IF( ln_isfcav ) THEN ; icav = 1 ; ELSE ; icav = 0 ; ENDIF 678 CALL iom_rstput( 0, 0, inum, 'ln_isfcav', REAL( icav, wp), ktype = jp_i4 ) 661 CALL iom_rstput( 0, 0, inum, 'ln_isfcav', REAL(COUNT((/ln_isfcav/)), wp), ktype = jp_i4 ) 679 662 ! 680 663 ! !== horizontal mesh ! -
NEMO/trunk/src/OCE/DOM/domhgr.F90
r10068 r13286 31 31 USE iom ! I/O library 32 32 USE lib_mpp ! MPP library 33 USE lbclnk ! lateal boundary condition / mpp exchanges 33 34 USE timing ! Timing 34 35 … … 88 89 ENDIF 89 90 ! 90 !91 91 IF( ln_read_cfg ) THEN !== read in mesh_mask.nc file ==! 92 ! 92 93 IF(lwp) WRITE(numout,*) 93 94 IF(lwp) WRITE(numout,*) ' ==>>> read horizontal mesh in ', TRIM( cn_domcfg ), ' file' … … 112 113 ! 113 114 ENDIF 114 !115 115 ! !== Coriolis parameter ==! (if necessary) 116 116 ! … … 126 126 ENDIF 127 127 ENDIF 128 129 128 ! 130 129 ! !== associated horizontal metrics ==! … … 150 149 e2_e1u(:,:) = e2u(:,:) / e1u(:,:) 151 150 e1_e2v(:,:) = e1v(:,:) / e2v(:,:) 152 !153 151 ! 154 152 IF( ln_timing ) CALL timing_stop('dom_hgr') … … 189 187 CALL iom_open( cn_domcfg, inum ) 190 188 ! 191 CALL iom_get( inum, jpdom_ data, 'glamt', plamt, lrowattr=ln_use_jattr)192 CALL iom_get( inum, jpdom_ data, 'glamu', plamu, lrowattr=ln_use_jattr)193 CALL iom_get( inum, jpdom_ data, 'glamv', plamv, lrowattr=ln_use_jattr)194 CALL iom_get( inum, jpdom_ data, 'glamf', plamf, lrowattr=ln_use_jattr)195 ! 196 CALL iom_get( inum, jpdom_ data, 'gphit', pphit, lrowattr=ln_use_jattr)197 CALL iom_get( inum, jpdom_ data, 'gphiu', pphiu, lrowattr=ln_use_jattr)198 CALL iom_get( inum, jpdom_ data, 'gphiv', pphiv, lrowattr=ln_use_jattr)199 CALL iom_get( inum, jpdom_ data, 'gphif', pphif, lrowattr=ln_use_jattr)200 ! 201 CALL iom_get( inum, jpdom_ data, 'e1t' , pe1t , lrowattr=ln_use_jattr)202 CALL iom_get( inum, jpdom_ data, 'e1u' , pe1u , lrowattr=ln_use_jattr)203 CALL iom_get( inum, jpdom_ data, 'e1v' , pe1v , lrowattr=ln_use_jattr)204 CALL iom_get( inum, jpdom_ data, 'e1f' , pe1f , lrowattr=ln_use_jattr)205 ! 206 CALL iom_get( inum, jpdom_ data, 'e2t' , pe2t , lrowattr=ln_use_jattr)207 CALL iom_get( inum, jpdom_ data, 'e2u' , pe2u , lrowattr=ln_use_jattr)208 CALL iom_get( inum, jpdom_ data, 'e2v' , pe2v , lrowattr=ln_use_jattr)209 CALL iom_get( inum, jpdom_ data, 'e2f' , pe2f , lrowattr=ln_use_jattr)189 CALL iom_get( inum, jpdom_global, 'glamt', plamt, cd_type = 'T', psgn = 1._wp ) 190 CALL iom_get( inum, jpdom_global, 'glamu', plamu, cd_type = 'U', psgn = 1._wp ) 191 CALL iom_get( inum, jpdom_global, 'glamv', plamv, cd_type = 'V', psgn = 1._wp ) 192 CALL iom_get( inum, jpdom_global, 'glamf', plamf, cd_type = 'F', psgn = 1._wp ) 193 ! 194 CALL iom_get( inum, jpdom_global, 'gphit', pphit, cd_type = 'T', psgn = 1._wp ) 195 CALL iom_get( inum, jpdom_global, 'gphiu', pphiu, cd_type = 'U', psgn = 1._wp ) 196 CALL iom_get( inum, jpdom_global, 'gphiv', pphiv, cd_type = 'V', psgn = 1._wp ) 197 CALL iom_get( inum, jpdom_global, 'gphif', pphif, cd_type = 'F', psgn = 1._wp ) 198 ! 199 CALL iom_get( inum, jpdom_global, 'e1t' , pe1t , cd_type = 'T', psgn = 1._wp, kfill = jpfillcopy ) 200 CALL iom_get( inum, jpdom_global, 'e1u' , pe1u , cd_type = 'U', psgn = 1._wp, kfill = jpfillcopy ) 201 CALL iom_get( inum, jpdom_global, 'e1v' , pe1v , cd_type = 'V', psgn = 1._wp, kfill = jpfillcopy ) 202 CALL iom_get( inum, jpdom_global, 'e1f' , pe1f , cd_type = 'F', psgn = 1._wp, kfill = jpfillcopy ) 203 ! 204 CALL iom_get( inum, jpdom_global, 'e2t' , pe2t , cd_type = 'T', psgn = 1._wp, kfill = jpfillcopy ) 205 CALL iom_get( inum, jpdom_global, 'e2u' , pe2u , cd_type = 'U', psgn = 1._wp, kfill = jpfillcopy ) 206 CALL iom_get( inum, jpdom_global, 'e2v' , pe2v , cd_type = 'V', psgn = 1._wp, kfill = jpfillcopy ) 207 CALL iom_get( inum, jpdom_global, 'e2f' , pe2f , cd_type = 'F', psgn = 1._wp, kfill = jpfillcopy ) 210 208 ! 211 209 IF( iom_varid( inum, 'ff_f', ldstop = .FALSE. ) > 0 .AND. & 212 210 & iom_varid( inum, 'ff_t', ldstop = .FALSE. ) > 0 ) THEN 213 211 IF(lwp) WRITE(numout,*) ' Coriolis factor at f- and t-points read in ', TRIM( cn_domcfg ), ' file' 214 CALL iom_get( inum, jpdom_ data, 'ff_f' , pff_f , lrowattr=ln_use_jattr)215 CALL iom_get( inum, jpdom_ data, 'ff_t' , pff_t , lrowattr=ln_use_jattr)212 CALL iom_get( inum, jpdom_global, 'ff_f', pff_f, cd_type = 'F', psgn = 1._wp ) 213 CALL iom_get( inum, jpdom_global, 'ff_t', pff_t, cd_type = 'T', psgn = 1._wp ) 216 214 kff = 1 217 215 ELSE … … 221 219 IF( iom_varid( inum, 'e1e2u', ldstop = .FALSE. ) > 0 ) THEN 222 220 IF(lwp) WRITE(numout,*) ' e1e2u & e1e2v read in ', TRIM( cn_domcfg ), ' file' 223 CALL iom_get( inum, jpdom_ data, 'e1e2u' , pe1e2u , lrowattr=ln_use_jattr)224 CALL iom_get( inum, jpdom_ data, 'e1e2v' , pe1e2v , lrowattr=ln_use_jattr)221 CALL iom_get( inum, jpdom_global, 'e1e2u', pe1e2u, cd_type = 'U', psgn = 1._wp, kfill = jpfillcopy ) 222 CALL iom_get( inum, jpdom_global, 'e1e2v', pe1e2v, cd_type = 'V', psgn = 1._wp, kfill = jpfillcopy ) 225 223 ke1e2u_v = 1 226 224 ELSE -
NEMO/trunk/src/OCE/DOM/dommsk.F90
r13237 r13286 26 26 USE oce ! ocean dynamics and tracers 27 27 USE dom_oce ! ocean space and time domain 28 USE domutl ! 28 29 USE usrdef_fmask ! user defined fmask 29 30 USE bdy_oce ! open boundary … … 89 90 ! 90 91 INTEGER :: ji, jj, jk ! dummy loop indices 91 INTEGER :: iif, iil ! local integers92 INTEGER :: ijf, ijl ! - -93 92 INTEGER :: iktop, ikbot ! - - 94 93 INTEGER :: ios, inum … … 136 135 ikbot = k_bot(ji,jj) 137 136 IF( iktop /= 0 ) THEN ! water in the column 138 tmask(ji,jj,iktop:ikbot 137 tmask(ji,jj,iktop:ikbot) = 1._wp 139 138 ENDIF 140 139 END_2D 141 140 ! 142 ! the following call is mandatory 143 ! it masks boundaries (bathy=0) where needed depending on the configuration (closed, periodic...) 144 CALL lbc_lnk( 'dommsk', tmask , 'T', 1._wp ) ! Lateral boundary conditions 145 146 ! Mask corrections for bdy (read in mppini2) 141 ! Mask corrections for bdy (read in mppini2) 147 142 READ ( numnam_ref, nambdy, IOSTAT = ios, ERR = 903) 148 143 903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy in reference namelist' ) … … 152 147 IF ( ln_bdy .AND. ln_mask_file ) THEN 153 148 CALL iom_open( cn_mask_file, inum ) 154 CALL iom_get ( inum, jpdom_ data, 'bdy_msk', bdytmask(:,:) )149 CALL iom_get ( inum, jpdom_global, 'bdy_msk', bdytmask(:,:) ) 155 150 CALL iom_close( inum ) 156 151 DO_3D_11_11( 1, jpkm1 ) … … 162 157 ! ---------------------------------------- 163 158 ! NB: at this point, fmask is designed for free slip lateral boundary condition 164 DO jk = 1, jpk 165 DO jj = 1, jpjm1 166 DO ji = 1, jpim1 ! vector loop 167 umask(ji,jj,jk) = tmask(ji,jj ,jk) * tmask(ji+1,jj ,jk) 168 vmask(ji,jj,jk) = tmask(ji,jj ,jk) * tmask(ji ,jj+1,jk) 169 END DO 170 DO ji = 1, jpim1 ! NO vector opt. 171 fmask(ji,jj,jk) = tmask(ji,jj ,jk) * tmask(ji+1,jj ,jk) & 172 & * tmask(ji,jj+1,jk) * tmask(ji+1,jj+1,jk) 173 END DO 174 END DO 175 END DO 159 DO_3D_00_00( 1, jpk ) 160 umask(ji,jj,jk) = tmask(ji,jj ,jk) * tmask(ji+1,jj ,jk) 161 vmask(ji,jj,jk) = tmask(ji,jj ,jk) * tmask(ji ,jj+1,jk) 162 fmask(ji,jj,jk) = tmask(ji,jj ,jk) * tmask(ji+1,jj ,jk) & 163 & * tmask(ji,jj+1,jk) * tmask(ji+1,jj+1,jk) 164 END_3D 176 165 CALL lbc_lnk_multi( 'dommsk', umask, 'U', 1.0_wp, vmask, 'V', 1.0_wp, fmask, 'F', 1.0_wp ) ! Lateral boundary conditions 177 166 … … 187 176 END DO 188 177 189 190 178 ! Ocean/land column mask at t-, u-, and v-points (i.e. at least 1 wet cell in the vertical) 191 179 ! ---------------------------------------------- … … 195 183 ssfmask(:,:) = MAXVAL( fmask(:,:,:), DIM=3 ) 196 184 197 198 185 ! Interior domain mask (used for global sum) 199 186 ! -------------------- 200 187 ! 201 iif = nn_hls ; iil = nlci - nn_hls + 1 202 ijf = nn_hls ; ijl = nlcj - nn_hls + 1 203 ! 204 ! ! halo mask : 0 on the halo and 1 elsewhere 205 tmask_h(:,:) = 1._wp 206 tmask_h( 1 :iif, : ) = 0._wp ! first columns 207 tmask_h(iil:jpi, : ) = 0._wp ! last columns (including mpp extra columns) 208 tmask_h( : , 1 :ijf) = 0._wp ! first rows 209 tmask_h( : ,ijl:jpj) = 0._wp ! last rows (including mpp extra rows) 210 ! 211 ! ! north fold mask 212 tpol(1:jpiglo) = 1._wp 213 fpol(1:jpiglo) = 1._wp 214 IF( jperio == 3 .OR. jperio == 4 ) THEN ! T-point pivot 215 tpol(jpiglo/2+1:jpiglo) = 0._wp 216 fpol( 1 :jpiglo) = 0._wp 217 IF( mjg(nlej) == jpjglo ) THEN ! only half of the nlcj-1 row for tmask_h 218 DO ji = iif+1, iil-1 219 tmask_h(ji,nlej-1) = tmask_h(ji,nlej-1) * tpol(mig(ji)) 220 END DO 221 ENDIF 222 ENDIF 223 ! 224 IF( jperio == 5 .OR. jperio == 6 ) THEN ! F-point pivot 225 tpol( 1 :jpiglo) = 0._wp 226 fpol(jpiglo/2+1:jpiglo) = 0._wp 227 ENDIF 188 CALL dom_uniq( tmask_h, 'T' ) 228 189 ! 229 190 ! ! interior mask : 2D ocean mask x halo mask 230 191 tmask_i(:,:) = ssmask(:,:) * tmask_h(:,:) 231 232 192 233 193 ! Lateral boundary conditions on velocity (modify fmask) -
NEMO/trunk/src/OCE/DOM/domqco.F90
r13237 r13286 217 217 ! 218 218 IF( MIN( id1, id2 ) > 0 ) THEN ! all required arrays exist 219 CALL iom_get( numror, jpdom_auto glo, 'sshb' , ssh(:,:,Kbb), ldxios = lrxios )220 CALL iom_get( numror, jpdom_auto glo, 'sshn' , ssh(:,:,Kmm), ldxios = lrxios )219 CALL iom_get( numror, jpdom_auto, 'sshb' , ssh(:,:,Kbb), ldxios = lrxios ) 220 CALL iom_get( numror, jpdom_auto, 'sshn' , ssh(:,:,Kmm), ldxios = lrxios ) 221 221 ! needed to restart if land processor not computed 222 222 IF(lwp) write(numout,*) 'qe_rst_read : ssh(:,:,Kbb) and ssh(:,:,Kmm) found in restart files' … … 232 232 IF(lwp) write(numout,*) 'sshn set equal to sshb.' 233 233 IF(lwp) write(numout,*) 'neuler is forced to 0' 234 CALL iom_get( numror, jpdom_auto glo, 'sshb', ssh(:,:,Kbb), ldxios = lrxios )234 CALL iom_get( numror, jpdom_auto, 'sshb', ssh(:,:,Kbb), ldxios = lrxios ) 235 235 ssh(:,:,Kmm) = ssh(:,:,Kbb) 236 236 l_1st_euler = .TRUE. … … 239 239 IF(lwp) write(numout,*) 'sshb set equal to sshn.' 240 240 IF(lwp) write(numout,*) 'neuler is forced to 0' 241 CALL iom_get( numror, jpdom_auto glo, 'sshn', ssh(:,:,Kmm), ldxios = lrxios )241 CALL iom_get( numror, jpdom_auto, 'sshn', ssh(:,:,Kmm), ldxios = lrxios ) 242 242 ssh(:,:,Kbb) = ssh(:,:,Kmm) 243 243 l_1st_euler = .TRUE. -
NEMO/trunk/src/OCE/DOM/domvvl.F90
r13237 r13286 273 273 IF( cn_cfg == "orca" .OR. cn_cfg == "ORCA" ) THEN 274 274 IF( nn_cfg == 3 ) THEN ! ORCA2: Suppress ztilde in the Foxe Basin for ORCA2 275 ii0 = 103 ; ii1 = 111276 ij0 = 128 ; ij1 = 135 ;275 ii0 = 103 + nn_hls - 1 ; ii1 = 111 + nn_hls - 1 276 ij0 = 128 + nn_hls ; ij1 = 135 + nn_hls 277 277 frq_rst_e3t( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0.0_wp 278 278 frq_rst_hdv( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1.e0_wp / rn_Dt … … 805 805 IF( ln_rstart ) THEN !* Read the restart file 806 806 CALL rst_read_open ! open the restart file if necessary 807 CALL iom_get( numror, jpdom_auto glo, 'sshn' , ssh(:,:,Kmm), ldxios = lrxios )807 CALL iom_get( numror, jpdom_auto, 'sshn' , ssh(:,:,Kmm), ldxios = lrxios ) 808 808 ! 809 809 id1 = iom_varid( numror, 'e3t_b', ldstop = .FALSE. ) … … 818 818 ! 819 819 IF( MIN( id1, id2 ) > 0 ) THEN ! all required arrays exist 820 CALL iom_get( numror, jpdom_auto glo, 'e3t_b', e3t(:,:,:,Kbb), ldxios = lrxios )821 CALL iom_get( numror, jpdom_auto glo, 'e3t_n', e3t(:,:,:,Kmm), ldxios = lrxios )820 CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb), ldxios = lrxios ) 821 CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm), ldxios = lrxios ) 822 822 ! needed to restart if land processor not computed 823 823 IF(lwp) write(numout,*) 'dom_vvl_rst : e3t(:,:,:,Kbb) and e3t(:,:,:,Kmm) found in restart files' … … 833 833 IF(lwp) write(numout,*) 'e3t_n set equal to e3t_b.' 834 834 IF(lwp) write(numout,*) 'l_1st_euler is forced to true' 835 CALL iom_get( numror, jpdom_auto glo, 'e3t_b', e3t(:,:,:,Kbb), ldxios = lrxios )835 CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb), ldxios = lrxios ) 836 836 e3t(:,:,:,Kmm) = e3t(:,:,:,Kbb) 837 837 l_1st_euler = .true. … … 840 840 IF(lwp) write(numout,*) 'e3t_b set equal to e3t_n.' 841 841 IF(lwp) write(numout,*) 'l_1st_euler is forced to true' 842 CALL iom_get( numror, jpdom_auto glo, 'e3t_n', e3t(:,:,:,Kmm), ldxios = lrxios )842 CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm), ldxios = lrxios ) 843 843 e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 844 844 l_1st_euler = .true. … … 865 865 ! ! ----------------------- ! 866 866 IF( MIN( id3, id4 ) > 0 ) THEN ! all required arrays exist 867 CALL iom_get( numror, jpdom_auto glo, 'tilde_e3t_b', tilde_e3t_b(:,:,:), ldxios = lrxios )868 CALL iom_get( numror, jpdom_auto glo, 'tilde_e3t_n', tilde_e3t_n(:,:,:), ldxios = lrxios )867 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_b', tilde_e3t_b(:,:,:), ldxios = lrxios ) 868 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_n', tilde_e3t_n(:,:,:), ldxios = lrxios ) 869 869 ELSE ! one at least array is missing 870 870 tilde_e3t_b(:,:,:) = 0.0_wp … … 875 875 ! ! ------------ ! 876 876 IF( id5 > 0 ) THEN ! required array exists 877 CALL iom_get( numror, jpdom_auto glo, 'hdiv_lf', hdiv_lf(:,:,:), ldxios = lrxios )877 CALL iom_get( numror, jpdom_auto, 'hdiv_lf', hdiv_lf(:,:,:), ldxios = lrxios ) 878 878 ELSE ! array is missing 879 879 hdiv_lf(:,:,:) = 0.0_wp -
NEMO/trunk/src/OCE/DOM/domwri.F90
r13226 r13286 13 13 !!---------------------------------------------------------------------- 14 14 !! dom_wri : create and write mesh and mask file(s) 15 !! dom_uniq : identify unique point of a grid (TUVF)16 15 !! dom_stiff : diagnose maximum grid stiffness/hydrostatic consistency (s-coordinate) 17 16 !!---------------------------------------------------------------------- 18 17 ! 19 18 USE dom_oce ! ocean space and time domain 19 USE domutl ! 20 20 USE phycst , ONLY : rsmall 21 21 USE wet_dry, ONLY : ll_wd ! Wetting and drying … … 74 74 ! ! ============================ 75 75 CALL iom_open( TRIM(clnam), inum, ldwrt = .TRUE. ) 76 !77 ! ! global domain size78 CALL iom_rstput( 0, 0, inum, 'jpiglo', REAL( jpiglo, wp), ktype = jp_i4 )79 CALL iom_rstput( 0, 0, inum, 'jpjglo', REAL( jpjglo, wp), ktype = jp_i4 )80 CALL iom_rstput( 0, 0, inum, 'jpkglo', REAL( jpkglo, wp), ktype = jp_i4 )81 82 76 ! ! domain characteristics 83 77 CALL iom_rstput( 0, 0, inum, 'jperio', REAL( jperio, wp), ktype = jp_i4 ) … … 182 176 ! ! ============================ 183 177 END SUBROUTINE dom_wri 184 185 186 SUBROUTINE dom_uniq( puniq, cdgrd )187 !!----------------------------------------------------------------------188 !! *** ROUTINE dom_uniq ***189 !!190 !! ** Purpose : identify unique point of a grid (TUVF)191 !!192 !! ** Method : 1) aplly lbc_lnk on an array with different values for each element193 !! 2) check which elements have been changed194 !!----------------------------------------------------------------------195 CHARACTER(len=1) , INTENT(in ) :: cdgrd !196 REAL(wp), DIMENSION(:,:), INTENT(inout) :: puniq !197 !198 REAL(wp) :: zshift ! shift value link to the process number199 INTEGER :: ji ! dummy loop indices200 LOGICAL, DIMENSION(SIZE(puniq,1),SIZE(puniq,2),1) :: lldbl ! store whether each point is unique or not201 REAL(wp), DIMENSION(jpi,jpj) :: ztstref202 !!----------------------------------------------------------------------203 !204 ! build an array with different values for each element205 ! in mpp: make sure that these values are different even between process206 ! -> apply a shift value according to the process number207 zshift = jpi * jpj * ( narea - 1 )208 ztstref(:,:) = RESHAPE( (/ (zshift + REAL(ji,wp), ji = 1, jpi*jpj) /), (/ jpi, jpj /) )209 !210 puniq(:,:) = ztstref(:,:) ! default definition211 CALL lbc_lnk( 'domwri', puniq, cdgrd, 1.0_wp ) ! apply boundary conditions212 lldbl(:,:,1) = puniq(:,:) == ztstref(:,:) ! check which values have been changed213 !214 puniq(:,:) = 1. ! default definition215 ! fill only the inner part of the cpu with llbl converted into real216 puniq(nldi:nlei,nldj:nlej) = REAL( COUNT( lldbl(nldi:nlei,nldj:nlej,:), dim = 3 ) , wp )217 !218 END SUBROUTINE dom_uniq219 178 220 179 -
NEMO/trunk/src/OCE/DOM/domzgr.F90
r13226 r13286 75 75 INTEGER :: ioptio, ibat, ios ! local integer 76 76 REAL(wp) :: zrefdep ! depth of the reference level (~10m) 77 REAL(wp), DIMENSION(jpi,jpj) :: zmsk 77 78 !!---------------------------------------------------------------------- 78 79 ! … … 109 110 ! 110 111 ENDIF 112 ! 113 ! the following is mandatory 114 ! make sure that closed boundaries are correctly defined in k_top that will be used to compute all mask arrays 115 ! 116 zmsk(:,:) = 1._wp ! default: no closed boundaries 117 IF( jperio == 0 .OR. jperio == 2 .OR. jperio == 3 .OR. jperio == 5 ) THEN ! E-W closed 118 zmsk( mi0( 1+nn_hls):mi1( 1+nn_hls),:) = 0._wp ! first column of inner global domain at 0 119 zmsk( mi0(jpiglo-nn_hls):mi1(jpiglo-nn_hls),:) = 0._wp ! last column of inner global domain at 0 120 ENDIF 121 IF( .NOT. ( jperio == 2 .OR. jperio == 7 ) ) THEN ! S closed 122 zmsk(:,mj0( 1+nn_hls):mj1( 1+nn_hls) ) = 0._wp ! first line of inner global domain at 0 123 ENDIF 124 IF( jperio == 0 .OR. jperio == 1 ) THEN ! N closed 125 zmsk(:,mj0(jpjglo-nn_hls):mj1(jpjglo-nn_hls) ) = 0._wp ! last line of inner global domain at 0 126 ENDIF 127 CALL lbc_lnk( 'usrdef_zgr', zmsk, 'T', 1. ) ! set halos 128 k_top(:,:) = k_top(:,:) * NINT( zmsk(:,:) ) 111 129 ! 112 130 !!gm to be remove when removing the OLD definition of e3 scale factors so that gde3w disappears … … 164 182 !!gm end bug 165 183 ! 166 IF( nprint == 1 .AND.lwp ) THEN184 IF( lwp ) THEN 167 185 WRITE(numout,*) ' MIN val k_top ', MINVAL( k_top(:,:) ), ' MAX ', MAXVAL( k_top(:,:) ) 168 186 WRITE(numout,*) ' MIN val k_bot ', MINVAL( k_bot(:,:) ), ' MAX ', MAXVAL( k_bot(:,:) ) … … 236 254 CALL iom_get( inum, jpdom_unknown, 'e3w_1d' , pe3w_1d ) 237 255 ! 238 CALL iom_get( inum, jpdom_ data, 'e3t_0' , pe3t , lrowattr=ln_use_jattr) ! 3D coordinate239 CALL iom_get( inum, jpdom_ data, 'e3u_0' , pe3u , lrowattr=ln_use_jattr)240 CALL iom_get( inum, jpdom_ data, 'e3v_0' , pe3v , lrowattr=ln_use_jattr)241 CALL iom_get( inum, jpdom_ data, 'e3f_0' , pe3f , lrowattr=ln_use_jattr)242 CALL iom_get( inum, jpdom_ data, 'e3w_0' , pe3w , lrowattr=ln_use_jattr)243 CALL iom_get( inum, jpdom_ data, 'e3uw_0' , pe3uw , lrowattr=ln_use_jattr)244 CALL iom_get( inum, jpdom_ data, 'e3vw_0' , pe3vw , lrowattr=ln_use_jattr)256 CALL iom_get( inum, jpdom_global, 'e3t_0' , pe3t , cd_type = 'T', psgn = 1._wp, kfill = jpfillcopy ) ! 3D coordinate 257 CALL iom_get( inum, jpdom_global, 'e3u_0' , pe3u , cd_type = 'U', psgn = 1._wp, kfill = jpfillcopy ) 258 CALL iom_get( inum, jpdom_global, 'e3v_0' , pe3v , cd_type = 'V', psgn = 1._wp, kfill = jpfillcopy ) 259 CALL iom_get( inum, jpdom_global, 'e3f_0' , pe3f , cd_type = 'F', psgn = 1._wp, kfill = jpfillcopy ) 260 CALL iom_get( inum, jpdom_global, 'e3w_0' , pe3w , cd_type = 'W', psgn = 1._wp, kfill = jpfillcopy ) 261 CALL iom_get( inum, jpdom_global, 'e3uw_0' , pe3uw, cd_type = 'U', psgn = 1._wp, kfill = jpfillcopy ) 262 CALL iom_get( inum, jpdom_global, 'e3vw_0' , pe3vw, cd_type = 'V', psgn = 1._wp, kfill = jpfillcopy ) 245 263 ! 246 264 ! !* depths … … 254 272 CALL iom_get( inum, jpdom_unknown, 'gdept_1d', pdept_1d ) 255 273 CALL iom_get( inum, jpdom_unknown, 'gdepw_1d', pdepw_1d ) 256 CALL iom_get( inum, jpdom_ data , 'gdept_0' , pdept , lrowattr=ln_use_jattr)257 CALL iom_get( inum, jpdom_ data , 'gdepw_0' , pdepw , lrowattr=ln_use_jattr)274 CALL iom_get( inum, jpdom_global , 'gdept_0' , pdept, kfill = jpfillcopy ) 275 CALL iom_get( inum, jpdom_global , 'gdepw_0' , pdepw, kfill = jpfillcopy ) 258 276 ! 259 277 ELSE !- depths computed from e3. scale factors … … 269 287 ! 270 288 ! !* ocean top and bottom level 271 CALL iom_get( inum, jpdom_ data, 'top_level' , z2d , lrowattr=ln_use_jattr) ! 1st wet T-points (ISF)289 CALL iom_get( inum, jpdom_global, 'top_level' , z2d ) ! 1st wet T-points (ISF) 272 290 k_top(:,:) = NINT( z2d(:,:) ) 273 CALL iom_get( inum, jpdom_ data, 'bottom_level' , z2d , lrowattr=ln_use_jattr) ! last wet T-points291 CALL iom_get( inum, jpdom_global, 'bottom_level' , z2d ) ! last wet T-points 274 292 k_bot(:,:) = NINT( z2d(:,:) ) 275 293 ! -
NEMO/trunk/src/OCE/DOM/dtatsd.F90
r12377 r13286 153 153 IF( nn_cfg == 2 .AND. ln_tsd_dmp ) THEN ! some hand made alterations 154 154 ! 155 ij0 = 101 ; ij1 = 109! Reduced T & S in the Alboran Sea156 ii0 = 141 ; ii1 = 155155 ij0 = 101 + nn_hls ; ij1 = 109 + nn_hls ! Reduced T & S in the Alboran Sea 156 ii0 = 141 + nn_hls - 1 ; ii1 = 155 + nn_hls - 1 157 157 DO jj = mj0(ij0), mj1(ij1) 158 158 DO ji = mi0(ii0), mi1(ii1) … … 167 167 END DO 168 168 END DO 169 ij0 = 87 ; ij1 = 96! Reduced temperature in Red Sea170 ii0 = 148 ; ii1 = 160169 ij0 = 87 + nn_hls ; ij1 = 96 + nn_hls ! Reduced temperature in Red Sea 170 ii0 = 148 + nn_hls - 1 ; ii1 = 160 + nn_hls - 1 171 171 sf_tsd(jp_tem)%fnow( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 4:10 ) = 7.0_wp 172 172 sf_tsd(jp_tem)%fnow( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 11:13 ) = 6.5_wp -
NEMO/trunk/src/OCE/DYN/dynspg_ts.F90
r13237 r13286 901 901 ! ! --------------- 902 902 IF( ln_rstart .AND. ln_bt_fw .AND. (.NOT.l_1st_euler) ) THEN !* Read the restart file 903 CALL iom_get( numror, jpdom_auto glo, 'ub2_b' , ub2_b (:,:), ldxios = lrxios )904 CALL iom_get( numror, jpdom_auto glo, 'vb2_b' , vb2_b (:,:), ldxios = lrxios )905 CALL iom_get( numror, jpdom_auto glo, 'un_bf' , un_bf (:,:), ldxios = lrxios )906 CALL iom_get( numror, jpdom_auto glo, 'vn_bf' , vn_bf (:,:), ldxios = lrxios )903 CALL iom_get( numror, jpdom_auto, 'ub2_b' , ub2_b (:,:), cd_type = 'U', psgn = -1._wp, ldxios = lrxios ) 904 CALL iom_get( numror, jpdom_auto, 'vb2_b' , vb2_b (:,:), cd_type = 'V', psgn = -1._wp, ldxios = lrxios ) 905 CALL iom_get( numror, jpdom_auto, 'un_bf' , un_bf (:,:), cd_type = 'U', psgn = -1._wp, ldxios = lrxios ) 906 CALL iom_get( numror, jpdom_auto, 'vn_bf' , vn_bf (:,:), cd_type = 'V', psgn = -1._wp, ldxios = lrxios ) 907 907 IF( .NOT.ln_bt_av ) THEN 908 CALL iom_get( numror, jpdom_auto glo, 'sshbb_e' , sshbb_e(:,:), ldxios = lrxios )909 CALL iom_get( numror, jpdom_auto glo, 'ubb_e' , ubb_e(:,:), ldxios = lrxios )910 CALL iom_get( numror, jpdom_auto glo, 'vbb_e' , vbb_e(:,:), ldxios = lrxios )911 CALL iom_get( numror, jpdom_auto glo, 'sshb_e' , sshb_e(:,:), ldxios = lrxios )912 CALL iom_get( numror, jpdom_auto glo, 'ub_e' , ub_e(:,:), ldxios = lrxios )913 CALL iom_get( numror, jpdom_auto glo, 'vb_e' , vb_e(:,:), ldxios = lrxios )908 CALL iom_get( numror, jpdom_auto, 'sshbb_e' , sshbb_e(:,:), cd_type = 'T', psgn = 1._wp, ldxios = lrxios ) 909 CALL iom_get( numror, jpdom_auto, 'ubb_e' , ubb_e(:,:), cd_type = 'U', psgn = -1._wp, ldxios = lrxios ) 910 CALL iom_get( numror, jpdom_auto, 'vbb_e' , vbb_e(:,:), cd_type = 'V', psgn = -1._wp, ldxios = lrxios ) 911 CALL iom_get( numror, jpdom_auto, 'sshb_e' , sshb_e(:,:), cd_type = 'T', psgn = 1._wp, ldxios = lrxios ) 912 CALL iom_get( numror, jpdom_auto, 'ub_e' , ub_e(:,:), cd_type = 'U', psgn = -1._wp, ldxios = lrxios ) 913 CALL iom_get( numror, jpdom_auto, 'vb_e' , vb_e(:,:), cd_type = 'V', psgn = -1._wp, ldxios = lrxios ) 914 914 ENDIF 915 915 #if defined key_agrif 916 916 ! Read time integrated fluxes 917 917 IF ( .NOT.Agrif_Root() ) THEN 918 CALL iom_get( numror, jpdom_auto glo, 'ub2_i_b' , ub2_i_b(:,:), ldxios = lrxios )919 CALL iom_get( numror, jpdom_auto glo, 'vb2_i_b' , vb2_i_b(:,:), ldxios = lrxios )918 CALL iom_get( numror, jpdom_auto, 'ub2_i_b' , ub2_i_b(:,:), cd_type = 'U', psgn = -1._wp, ldxios = lrxios ) 919 CALL iom_get( numror, jpdom_auto, 'vb2_i_b' , vb2_i_b(:,:), cd_type = 'V', psgn = -1._wp, ldxios = lrxios ) 920 920 ENDIF 921 921 #endif … … 976 976 ! Max courant number for ext. grav. waves 977 977 ! 978 DO_2D_ 11_11978 DO_2D_00_00 979 979 zxr2 = r1_e1t(ji,jj) * r1_e1t(ji,jj) 980 980 zyr2 = r1_e2t(ji,jj) * r1_e2t(ji,jj) … … 982 982 END_2D 983 983 ! 984 zcmax = MAXVAL( zcu( :,:) )984 zcmax = MAXVAL( zcu(Nis0:Nie0,Njs0:Nje0) ) 985 985 CALL mpp_max( 'dynspg_ts', zcmax ) 986 986 -
NEMO/trunk/src/OCE/DYN/dynvor.F90
r13237 r13286 80 80 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: di_e2u_2 ! = di(e2u)/2 used in T-point metric term calculation 81 81 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: dj_e1v_2 ! = dj(e1v)/2 - - - - 82 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: di_e2v_2e1e2f ! = di(e2 u)/(2*e1e2f) used in F-point metric term calculation83 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: dj_e1u_2e1e2f ! = dj(e1 v)/(2*e1e2f) - - - -82 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: di_e2v_2e1e2f ! = di(e2v)/(2*e1e2f) used in F-point metric term calculation 83 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: dj_e1u_2e1e2f ! = dj(e1u)/(2*e1e2f) - - - - 84 84 85 85 REAL(wp) :: r1_4 = 0.250_wp ! =1/4 -
NEMO/trunk/src/OCE/DYN/dynzdf.F90
r13237 r13286 107 107 ! ! time stepping except vertical diffusion 108 108 IF( ln_dynadv_vec .OR. ln_linssh ) THEN ! applied on velocity 109 DO jk = 1, jpkm1110 puu( :,:,jk,Kaa) = ( puu(:,:,jk,Kbb) + rDt * puu(:,:,jk,Krhs) ) * umask(:,:,jk)111 pvv( :,:,jk,Kaa) = ( pvv(:,:,jk,Kbb) + rDt * pvv(:,:,jk,Krhs) ) * vmask(:,:,jk)112 END DO109 DO_3D_00_00( 1, jpkm1 ) 110 puu(ji,jj,jk,Kaa) = ( puu(ji,jj,jk,Kbb) + rDt * puu(ji,jj,jk,Krhs) ) * umask(ji,jj,jk) 111 pvv(ji,jj,jk,Kaa) = ( pvv(ji,jj,jk,Kbb) + rDt * pvv(ji,jj,jk,Krhs) ) * vmask(ji,jj,jk) 112 END_3D 113 113 ELSE ! applied on thickness weighted velocity 114 DO jk = 1, jpkm1115 puu( :,:,jk,Kaa) = ( e3u(:,:,jk,Kbb) * puu(:,:,jk,Kbb) &116 & + rDt * e3u(:,:,jk,Kmm) * puu(:,:,jk,Krhs) )&117 & / e3u(:,:,jk,Kaa) * umask(:,:,jk)118 pvv( :,:,jk,Kaa) = ( e3v(:,:,jk,Kbb) * pvv(:,:,jk,Kbb) &119 & + rDt * e3v(:,:,jk,Kmm) * pvv(:,:,jk,Krhs) )&120 & / e3v(:,:,jk,Kaa) * vmask(:,:,jk)121 END DO114 DO_3D_00_00( 1, jpkm1 ) 115 puu(ji,jj,jk,Kaa) = ( e3u(ji,jj,jk,Kbb) * puu(ji,jj,jk,Kbb ) & 116 & + rDt * e3u(ji,jj,jk,Kmm) * puu(ji,jj,jk,Krhs) ) & 117 & / e3u(ji,jj,jk,Kaa) * umask(ji,jj,jk) 118 pvv(ji,jj,jk,Kaa) = ( e3v(ji,jj,jk,Kbb) * pvv(ji,jj,jk,Kbb ) & 119 & + rDt * e3v(ji,jj,jk,Kmm) * pvv(ji,jj,jk,Krhs) ) & 120 & / e3v(ji,jj,jk,Kaa) * vmask(ji,jj,jk) 121 END_3D 122 122 ENDIF 123 123 ! ! add top/bottom friction … … 127 127 ! G. Madec : in linear free surface, e3u(:,:,:,Kaa) = e3u(:,:,:,Kmm) = e3u_0, so systematic use of e3u(:,:,:,Kaa) 128 128 IF( ln_drgimp .AND. ln_dynspg_ts ) THEN 129 DO jk = 1, jpkm1! remove barotropic velocities130 puu( :,:,jk,Kaa) = ( puu(:,:,jk,Kaa) - uu_b(:,:,Kaa) ) * umask(:,:,jk)131 pvv( :,:,jk,Kaa) = ( pvv(:,:,jk,Kaa) - vv_b(:,:,Kaa) ) * vmask(:,:,jk)132 END DO129 DO_3D_00_00( 1, jpkm1 ) ! remove barotropic velocities 130 puu(ji,jj,jk,Kaa) = ( puu(ji,jj,jk,Kaa) - uu_b(ji,jj,Kaa) ) * umask(ji,jj,jk) 131 pvv(ji,jj,jk,Kaa) = ( pvv(ji,jj,jk,Kaa) - vv_b(ji,jj,Kaa) ) * vmask(ji,jj,jk) 132 END_3D 133 133 DO_2D_00_00 134 134 iku = mbku(ji,jj) ! ocean bottom level at u- and v-points -
NEMO/trunk/src/OCE/DYN/sshwzv.F90
r13237 r13286 28 28 USE bdydyn2d ! bdy_ssh routine 29 29 #if defined key_agrif 30 USE agrif_oce 30 31 USE agrif_oce_interp 31 32 #endif … … 215 216 ENDIF 216 217 ! 217 #if defined key_agrif 218 IF( .NOT. AGRIF_Root() ) THEN 218 #if defined key_agrif 219 IF( .NOT. AGRIF_Root() ) THEN 220 ! 219 221 ! Mask vertical velocity at first/last columns/row 220 222 ! inside computational domain (cosmetic) 221 ! --- West --- ! 222 IF( lk_west) THEN 223 DO ji = mi0(2), mi1(2) 224 DO jj = 1, jpj 225 pww(ji,jj,:) = 0._wp 226 ENDDO 227 ENDDO 228 ENDIF 229 ! 230 ! --- East --- ! 231 IF( lk_east) THEN 232 DO ji = mi0(jpiglo-1), mi1(jpiglo-1) 233 DO jj = 1, jpj 234 pww(ji,jj,:) = 0._wp 235 ENDDO 236 ENDDO 237 ENDIF 238 ! 239 ! --- South --- ! 240 IF( lk_south) THEN 241 DO jj = mj0(2), mj1(2) 242 DO ji = 1, jpi 243 pww(ji,jj,:) = 0._wp 244 ENDDO 245 ENDDO 246 ENDIF 247 ! 248 ! --- North --- ! 249 IF( lk_north) THEN 250 DO jj = mj0(jpjglo-1), mj1(jpjglo-1) 251 DO ji = 1, jpi 252 pww(ji,jj,:) = 0._wp 253 ENDDO 254 ENDDO 255 ENDIF 223 DO jk = 1, jpkm1 224 IF( lk_west ) THEN ! --- West --- ! 225 DO ji = mi0(2+nn_hls), mi1(2+nn_hls) 226 DO jj = 1, jpj 227 pww(ji,jj,jk) = 0._wp 228 END DO 229 END DO 230 ENDIF 231 IF( lk_east ) THEN ! --- East --- ! 232 DO ji = mi0(jpiglo-1-nn_hls), mi1(jpiglo-1-nn_hls) 233 DO jj = 1, jpj 234 pww(ji,jj,jk) = 0._wp 235 END DO 236 END DO 237 ENDIF 238 IF( lk_south ) THEN ! --- South --- ! 239 DO jj = mj0(2+nn_hls), mj1(2+nn_hls) 240 DO ji = 1, jpi 241 pww(ji,jj,jk) = 0._wp 242 END DO 243 END DO 244 ENDIF 245 IF( lk_north ) THEN ! --- North --- ! 246 DO jj = mj0(jpjglo-1-nn_hls), mj1(jpjglo-1-nn_hls) 247 DO ji = 1, jpi 248 pww(ji,jj,jk) = 0._wp 249 END DO 250 END DO 251 ENDIF 252 ! 253 END DO 256 254 ! 257 255 ENDIF 258 #endif 256 #endif 259 257 ! 260 258 IF( ln_timing ) CALL timing_stop('wzv') -
NEMO/trunk/src/OCE/FLO/floblk.F90
r13237 r13286 106 106 222 DO jfl = 1, jpnfl 107 107 # if defined key_mpp_mpi 108 IF( iil(jfl) >= mig( nldi) .AND. iil(jfl) <= mig(nlei) .AND. &109 ijl(jfl) >= mjg( nldj) .AND. ijl(jfl) <= mjg(nlej) ) THEN108 IF( iil(jfl) >= mig(Nis0) .AND. iil(jfl) <= mig(Nie0) .AND. & 109 ijl(jfl) >= mjg(Njs0) .AND. ijl(jfl) <= mjg(Nje0) ) THEN 110 110 iiloc(jfl) = iil(jfl) - mig(1) + 1 111 111 ijloc(jfl) = ijl(jfl) - mjg(1) + 1 -
NEMO/trunk/src/OCE/FLO/flodom.F90
r12377 r13286 155 155 ikmfl(jfl) = 0 156 156 # if defined key_mpp_mpi 157 DO ji = MAX( nldi,2), nlei158 DO jj = MAX( nldj,2), nlej! NO vector opt.157 DO ji = MAX(Nis0,2), Nie0 158 DO jj = MAX(Njs0,2), Nje0 ! NO vector opt. 159 159 # else 160 160 DO ji = 2, jpi -
NEMO/trunk/src/OCE/FLO/florst.F90
r11536 r13286 98 98 IF( lk_mpp ) THEN 99 99 DO jfl = 1, jpnfl 100 IF( (INT(tpifl(jfl)) >= mig( nldi)) .AND. &101 &(INT(tpifl(jfl)) <= mig( nlei)) .AND. &102 &(INT(tpjfl(jfl)) >= mjg( nldj)) .AND. &103 &(INT(tpjfl(jfl)) <= mjg( nlej)) ) THEN100 IF( (INT(tpifl(jfl)) >= mig(Nis0)) .AND. & 101 &(INT(tpifl(jfl)) <= mig(Nie0)) .AND. & 102 &(INT(tpjfl(jfl)) >= mjg(Njs0)) .AND. & 103 &(INT(tpjfl(jfl)) <= mjg(Nje0)) ) THEN 104 104 iperproc(narea) = iperproc(narea)+1 105 105 ENDIF -
NEMO/trunk/src/OCE/FLO/flowri.F90
r12489 r13286 105 105 ibfloc = mj1( ibfl ) 106 106 107 IF( nldi <= iafloc .AND. iafloc <= nlei.AND. &108 & nldj <= ibfloc .AND. ibfloc <= nlej) THEN107 IF( Nis0 <= iafloc .AND. iafloc <= Nie0 .AND. & 108 & Njs0 <= ibfloc .AND. ibfloc <= Nje0 ) THEN 109 109 110 110 !the float is inside of current proc's area -
NEMO/trunk/src/OCE/ICB/icb_oce.F90
r13281 r13286 147 147 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nicbfldexpect !: nfold expected number of bergs 148 148 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nicbfldreq !: nfold message handle (immediate send) 149 150 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: griddata !: work array for icbrst151 152 149 !!---------------------------------------------------------------------- 153 150 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 197 194 icb_alloc = icb_alloc + ill 198 195 199 ALLOCATE( griddata(jpi,jpj,1), STAT=ill )200 icb_alloc = icb_alloc + ill201 202 196 CALL mpp_sum ( 'icb_oce', icb_alloc ) 203 197 IF( icb_alloc > 0 ) CALL ctl_warn('icb_alloc: allocation of arrays failed') -
NEMO/trunk/src/OCE/ICB/icbini.F90
r13281 r13286 133 133 ! first entry with narea for this processor is left hand interior index 134 134 ! last entry is right hand interior index 135 jj = nlcj/2135 jj = jpj/2 136 136 nicbdi = -1 137 137 nicbei = -1 … … 149 149 ! 150 150 ! repeat for j direction 151 ji = nlci/2151 ji = jpi/2 152 152 nicbdj = -1 153 153 nicbej = -1 … … 166 166 ! special for east-west boundary exchange we save the destination index 167 167 i1 = MAX( nicbdi-1, 1) 168 i3 = INT( src_calving(i1, nlcj/2) )168 i3 = INT( src_calving(i1,jpj/2) ) 169 169 jj = INT( i3/nicbpack ) 170 170 ricb_left = REAL( i3 - nicbpack*jj, wp ) 171 171 i1 = MIN( nicbei+1, jpi ) 172 i3 = INT( src_calving(i1, nlcj/2) )172 i3 = INT( src_calving(i1,jpj/2) ) 173 173 jj = INT( i3/nicbpack ) 174 174 ricb_right = REAL( i3 - nicbpack*jj, wp ) … … 203 203 WRITE(numicb,*) 'processor ', narea 204 204 WRITE(numicb,*) 'jpi, jpj ', jpi, jpj 205 WRITE(numicb,*) ' nldi, nlei ', nldi, nlei206 WRITE(numicb,*) ' nldj, nlej ', nldj, nlej205 WRITE(numicb,*) 'Nis0, Nie0 ', Nis0, Nie0 206 WRITE(numicb,*) 'Njs0, Nje0 ', Njs0, Nje0 207 207 WRITE(numicb,*) 'berg i interior ', nicbdi, nicbei 208 208 WRITE(numicb,*) 'berg j interior ', nicbdj, nicbej 209 209 WRITE(numicb,*) 'berg left ', ricb_left 210 210 WRITE(numicb,*) 'berg right ', ricb_right 211 jj = nlcj/2211 jj = jpj/2 212 212 WRITE(numicb,*) "central j line:" 213 213 WRITE(numicb,*) "i processor" … … 215 215 WRITE(numicb,*) "i point" 216 216 WRITE(numicb,*) (INT(src_calving(ji,jj)), ji=1,jpi) 217 ji = nlci/2217 ji = jpi/2 218 218 WRITE(numicb,*) "central i line:" 219 219 WRITE(numicb,*) "j processor" … … 256 256 ivar = iom_varid( inum, 'maxclass', ldstop=.FALSE. ) 257 257 IF( ivar > 0 ) THEN 258 CALL iom_get ( inum, jpdom_ data, 'maxclass', src_calving ) ! read the max distribution array258 CALL iom_get ( inum, jpdom_global, 'maxclass', src_calving ) ! read the max distribution array 259 259 berg_grid%maxclass(:,:) = INT( src_calving ) 260 260 src_calving(:,:) = 0._wp -
NEMO/trunk/src/OCE/ICB/icbrst.F90
r13062 r13286 91 91 ij = INT( localpt%yj + 0.5 ) 92 92 ! Only proceed if this iceberg is on the local processor (excluding halos). 93 IF ( ii .GE. nldi+nimpp-1 .AND. ii .LE. nlei+nimpp-1 .AND.&94 & ij .GE. nldj+njmpp-1 .AND. ij .LE. nlej+njmpp-1) THEN95 96 CALL iom_get( ncid, jpdom_unknown, 'number' 93 IF ( ii >= mig(Nis0) .AND. ii <= mig(Nie0) .AND. & 94 & ij >= mjg(Njs0) .AND. ij <= mjg(Nje0) ) THEN 95 96 CALL iom_get( ncid, jpdom_unknown, 'number', zdata(:) , ktime=jn, kstart=(/1/), kcount=(/nkounts/) ) 97 97 localberg%number(:) = INT(zdata(:)) 98 98 imax_icb = MAX( imax_icb, INT(zdata(1)) ) … … 123 123 124 124 ! Gridded variables 125 CALL iom_get( ncid, jpdom_autoglo, 'calving' , src_calving ) 126 CALL iom_get( ncid, jpdom_autoglo, 'calving_hflx', src_calving_hflx ) 127 CALL iom_get( ncid, jpdom_autoglo, 'stored_heat' , berg_grid%stored_heat ) 128 CALL iom_get( ncid, jpdom_autoglo_xy, 'stored_ice' , berg_grid%stored_ice, kstart=(/1,1,1/), kcount=(/1,1,nclasses/) ) 125 CALL iom_get( ncid, jpdom_auto, 'calving' , src_calving ) 126 CALL iom_get( ncid, jpdom_auto, 'calving_hflx', src_calving_hflx ) 127 CALL iom_get( ncid, jpdom_auto, 'stored_heat' , berg_grid%stored_heat ) 128 ! with jpdom_auto_xy, ue use only the third element of kstart and kcount. 129 CALL iom_get( ncid, jpdom_auto_xy, 'stored_ice' , berg_grid%stored_ice, kstart=(/-99,-99,1/), kcount=(/-99,-99,nclasses/) ) 129 130 130 131 CALL iom_get( ncid, jpdom_unknown, 'kount' , zdata(:) ) … … 229 230 230 231 ! Dimensions 231 nret = NF90_DEF_DIM(ncid, 'x', jpi, ix_dim)232 nret = NF90_DEF_DIM(ncid, 'x', Ni_0, ix_dim) 232 233 IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_def_dim x failed') 233 234 234 nret = NF90_DEF_DIM(ncid, 'y', jpj, iy_dim)235 nret = NF90_DEF_DIM(ncid, 'y', Nj_0, iy_dim) 235 236 IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_def_dim y failed') 236 237 … … 244 245 IF( lk_mpp ) THEN 245 246 ! Set domain parameters (assume jpdom_local_full) 246 nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_number_total' , jpnij )247 nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_number' , narea-1 )248 nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_dimensions_ids' , (/ 1 , 2/) )249 nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_size_global' , (/ jpiglo, jpjglo/) )250 nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_size_local' , (/ jpi , jpj/) )251 nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_position_first' , (/ nimpp , njmpp/) )252 nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_position_last' , (/ nimpp + jpi - 1 , njmpp + jpj - 1/) )253 nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_halo_size_start', (/ nldi - 1 , nldj - 1/) )254 nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_halo_size_end' , (/ jpi - nlei , jpj - nlej/) )255 nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_type' , 'BOX' )247 nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_number_total' , jpnij ) 248 nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_number' , narea-1 ) 249 nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_dimensions_ids' , (/ 1 , 2 /) ) 250 nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_size_global' , (/ Ni0glo , Nj0glo /) ) 251 nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_size_local' , (/ Ni_0 , Nj_0 /) ) 252 nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_position_first' , (/ mig0(Nis0), mjg0(Njs0) /) ) 253 nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_position_last' , (/ mig0(Nie0), mjg0(Nje0) /) ) 254 nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_halo_size_start', (/ 0 , 0 /) ) 255 nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_halo_size_end' , (/ 0 , 0 /) ) 256 nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_type' , 'BOX' ) 256 257 ENDIF 257 258 … … 344 345 nstrt3(1) = 1 345 346 nstrt3(2) = 1 346 nlngth3(1) = jpi347 nlngth3(2) = jpj347 nlngth3(1) = Ni_0 348 nlngth3(2) = Nj_0 348 349 nlngth3(3) = 1 349 350 350 351 DO jn=1,nclasses 351 griddata(:,:,1) = berg_grid%stored_ice(:,:,jn)352 352 nstrt3(3) = jn 353 nret = NF90_PUT_VAR( ncid, nsiceid, griddata, nstrt3, nlngth3 )353 nret = NF90_PUT_VAR( ncid, nsiceid, berg_grid%stored_ice(Nis0:Nie0,Njs0:Nje0,jn), nstrt3, nlngth3 ) 354 354 IF (nret .ne. NF90_NOERR) THEN 355 355 IF( lwp ) WRITE(numout,*) TRIM(NF90_STRERROR( nret )) … … 362 362 IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_put_var kount failed') 363 363 364 nret = NF90_PUT_VAR( ncid, nsheatid, berg_grid%stored_heat( :,:) )364 nret = NF90_PUT_VAR( ncid, nsheatid, berg_grid%stored_heat(Nis0:Nie0,Njs0:Nje0) ) 365 365 IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_put_var stored_heat failed') 366 366 IF( lwp ) WRITE(numout,*) 'file: ',TRIM(cl_path)//TRIM(cl_filename),' var: stored_heat written' 367 367 368 nret = NF90_PUT_VAR( ncid, ncalvid , src_calving( :,:) )368 nret = NF90_PUT_VAR( ncid, ncalvid , src_calving(Nis0:Nie0,Njs0:Nje0) ) 369 369 IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_put_var calving failed') 370 nret = NF90_PUT_VAR( ncid, ncalvhid, src_calving_hflx( :,:) )370 nret = NF90_PUT_VAR( ncid, ncalvhid, src_calving_hflx(Nis0:Nie0,Njs0:Nje0) ) 371 371 IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_put_var calving_hflx failed') 372 372 IF( lwp ) WRITE(numout,*) 'file: ',TRIM(cl_path)//TRIM(cl_filename),' var: calving written' -
NEMO/trunk/src/OCE/IOM/in_out_manager.F90
r12933 r13286 118 118 LOGICAL :: ln_timing !: run control for timing 119 119 LOGICAL :: ln_diacfl !: flag whether to create CFL diagnostics 120 INTEGER :: nn_print !: level of print (0 no print)121 120 INTEGER :: nn_ictls !: Start i indice for the SUM control 122 121 INTEGER :: nn_ictle !: End i indice for the SUM control … … 125 124 INTEGER :: nn_isplt !: number of processors following i 126 125 INTEGER :: nn_jsplt !: number of processors following j 127 !128 INTEGER :: nprint, nictls, nictle, njctls, njctle, isplt, jsplt !: OLD namelist names129 130 INTEGER :: ijsplt = 1 !: nb of local domain = nb of processors131 126 132 127 !!---------------------------------------------------------------------- -
NEMO/trunk/src/OCE/IOM/iom.F90
r13226 r13286 21 21 !!---------------------------------------------------------------------- 22 22 USE dom_oce ! ocean space and time domain 23 USE domutl ! 23 24 USE c1d ! 1D vertical configuration 24 25 USE flo_oce ! floats module declarations … … 34 35 USE ice , ONLY : jpl 35 36 #endif 36 USE domngb ! ocean space and time domain37 37 USE phycst ! physical constants 38 38 USE dianam ! build name of file … … 101 101 CONTAINS 102 102 103 SUBROUTINE iom_init( cdname, fname, ld_ tmppatch, ld_closedef )103 SUBROUTINE iom_init( cdname, fname, ld_closedef ) 104 104 !!---------------------------------------------------------------------- 105 105 !! *** ROUTINE *** … … 110 110 CHARACTER(len=*), INTENT(in) :: cdname 111 111 CHARACTER(len=*), OPTIONAL, INTENT(in) :: fname 112 LOGICAL , OPTIONAL, INTENT(in) :: ld_tmppatch113 112 LOGICAL , OPTIONAL, INTENT(in) :: ld_closedef 114 113 #if defined key_iomput … … 123 122 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zt_bnds, zw_bnds 124 123 REAL(wp), DIMENSION(2,jpkam1) :: za_bnds ! ABL vertical boundaries 125 LOGICAL :: ll_tmppatch = .TRUE. !: seb: patch before we remove periodicity126 INTEGER :: nldi_save, nlei_save !: and close boundaries in output files127 INTEGER :: nldj_save, nlej_save !:128 124 LOGICAL :: ll_closedef = .TRUE. 129 125 !!---------------------------------------------------------------------- 130 126 ! 131 ! seb: patch before we remove periodicity and close boundaries in output files132 IF( PRESENT(ld_tmppatch) ) THEN ; ll_tmppatch = ld_tmppatch133 ELSE ; ll_tmppatch = .TRUE.134 ENDIF135 IF ( ll_tmppatch ) THEN136 nldi_save = nldi ; nlei_save = nlei137 nldj_save = nldj ; nlej_save = nlej138 IF( nimpp == 1 ) nldi = 1139 IF( nimpp + jpi - 1 == jpiglo ) nlei = jpi140 IF( njmpp == 1 ) nldj = 1141 IF( njmpp + jpj - 1 == jpjglo ) nlej = jpj142 ENDIF143 127 IF ( PRESENT(ld_closedef) ) ll_closedef = ld_closedef 144 128 ! … … 157 141 158 142 SELECT CASE ( nleapy ) ! Choose calendar for IOIPSL 159 CASE ( 1) ; CALL xios_define_calendar( TYPE = "Gregorian", time_origin = xios_date(irefyear,irefmonth,irefday,00,00,00),&160 & start_date = xios_date(nyear,nmonth,nday,0,0,0) )161 CASE ( 0) ; CALL xios_define_calendar( TYPE = "NoLeap" , time_origin = xios_date(irefyear,irefmonth,irefday,00,00,00),&162 & start_date = xios_date(nyear,nmonth,nday,0,0,0) )163 CASE (30) ; CALL xios_define_calendar( TYPE = "D360" , time_origin = xios_date(irefyear,irefmonth,irefday,00,00,00),&164 & start_date = xios_date(nyear,nmonth,nday,0,0,0) )143 CASE ( 1) ; CALL xios_define_calendar( TYPE = "Gregorian", time_origin = xios_date(irefyear,irefmonth,irefday,0,0,0), & 144 & start_date = xios_date( nyear, nmonth, nday,0,0,0) ) 145 CASE ( 0) ; CALL xios_define_calendar( TYPE = "NoLeap" , time_origin = xios_date(irefyear,irefmonth,irefday,0,0,0), & 146 & start_date = xios_date( nyear, nmonth, nday,0,0,0) ) 147 CASE (30) ; CALL xios_define_calendar( TYPE = "D360" , time_origin = xios_date(irefyear,irefmonth,irefday,0,0,0), & 148 & start_date = xios_date( nyear, nmonth, nday,0,0,0) ) 165 149 END SELECT 166 150 … … 176 160 ! 177 161 IF( ln_cfmeta ) THEN ! Add additional grid metadata 178 CALL iom_set_domain_attr("grid_T", area = real( e1e2t( nldi:nlei, nldj:nlej), dp))179 CALL iom_set_domain_attr("grid_U", area = real( e1e2u( nldi:nlei, nldj:nlej), dp))180 CALL iom_set_domain_attr("grid_V", area = real( e1e2v( nldi:nlei, nldj:nlej), dp))181 CALL iom_set_domain_attr("grid_W", area = real( e1e2t( nldi:nlei, nldj:nlej), dp))162 CALL iom_set_domain_attr("grid_T", area = real( e1e2t(Nis0:Nie0, Njs0:Nje0), dp)) 163 CALL iom_set_domain_attr("grid_U", area = real( e1e2u(Nis0:Nie0, Njs0:Nje0), dp)) 164 CALL iom_set_domain_attr("grid_V", area = real( e1e2v(Nis0:Nie0, Njs0:Nje0), dp)) 165 CALL iom_set_domain_attr("grid_W", area = real( e1e2t(Nis0:Nie0, Njs0:Nje0), dp)) 182 166 CALL set_grid_bounds( "T", glamf, gphif, glamt, gphit ) 183 167 CALL set_grid_bounds( "U", glamv, gphiv, glamu, gphiu ) … … 199 183 ! 200 184 IF( ln_cfmeta .AND. .NOT. llrst_context) THEN ! Add additional grid metadata 201 CALL iom_set_domain_attr("grid_T", area = real(e1e2t_crs( nldi:nlei, nldj:nlej), dp))202 CALL iom_set_domain_attr("grid_U", area = real(e1u_crs( nldi:nlei, nldj:nlej) * e2u_crs(nldi:nlei, nldj:nlej), dp))203 CALL iom_set_domain_attr("grid_V", area = real(e1v_crs( nldi:nlei, nldj:nlej) * e2v_crs(nldi:nlei, nldj:nlej), dp))204 CALL iom_set_domain_attr("grid_W", area = real(e1e2t_crs( nldi:nlei, nldj:nlej), dp ))185 CALL iom_set_domain_attr("grid_T", area = real(e1e2t_crs(Nis0:Nie0, Njs0:Nje0), dp)) 186 CALL iom_set_domain_attr("grid_U", area = real(e1u_crs(Nis0:Nie0, Njs0:Nje0) * e2u_crs(Nis0:Nie0, Njs0:Nje0), dp)) 187 CALL iom_set_domain_attr("grid_V", area = real(e1v_crs(Nis0:Nie0, Njs0:Nje0) * e2v_crs(Nis0:Nie0, Njs0:Nje0), dp)) 188 CALL iom_set_domain_attr("grid_W", area = real(e1e2t_crs(Nis0:Nie0, Njs0:Nje0), dp)) 205 189 CALL set_grid_bounds( "T", glamf_crs, gphif_crs, glamt_crs, gphit_crs ) 206 190 CALL set_grid_bounds( "U", glamv_crs, gphiv_crs, glamu_crs, gphiu_crs ) … … 288 272 DEALLOCATE( zt_bnds, zw_bnds ) 289 273 ! 290 IF ( ll_tmppatch ) THEN291 nldi = nldi_save ; nlei = nlei_save292 nldj = nldj_save ; nlej = nlej_save293 ENDIF294 274 #endif 295 275 ! … … 671 651 672 652 673 SUBROUTINE iom_open( cdname, kiomid, ldwrt, kdom,ldstop, ldiof, kdlev, cdcomp )653 SUBROUTINE iom_open( cdname, kiomid, ldwrt, ldstop, ldiof, kdlev, cdcomp ) 674 654 !!--------------------------------------------------------------------- 675 655 !! *** SUBROUTINE iom_open *** … … 680 660 INTEGER , INTENT( out) :: kiomid ! iom identifier of the opened file 681 661 LOGICAL , INTENT(in ), OPTIONAL :: ldwrt ! open in write modeb (default = .FALSE.) 682 INTEGER , INTENT(in ), OPTIONAL :: kdom ! Type of domain to be written (default = jpdom_local_noovlap)683 662 LOGICAL , INTENT(in ), OPTIONAL :: ldstop ! stop if open to read a non-existing file (default = .TRUE.) 684 663 LOGICAL , INTENT(in ), OPTIONAL :: ldiof ! Interp On the Fly, needed for AGRIF (default = .FALSE.) … … 693 672 LOGICAL :: llok ! check the existence 694 673 LOGICAL :: llwrt ! local definition of ldwrt 695 LOGICAL :: llnoov ! local definition to read overlap696 674 LOGICAL :: llstop ! local definition of ldstop 697 675 LOGICAL :: lliof ! local definition of ldiof 698 676 INTEGER :: icnt ! counter for digits in clcpu (max = jpmax_digits) 699 677 INTEGER :: iln, ils ! lengths of character 700 INTEGER :: idom ! type of domain701 678 INTEGER :: istop ! 702 INTEGER, DIMENSION(2,5) :: idompar ! domain parameters:703 679 ! local number of points for x,y dimensions 704 680 ! position of first local point for x,y dimensions … … 732 708 ELSE ; lliof = .FALSE. 733 709 ENDIF 734 ! do we read the overlap735 ! ugly patch SM+JMM+RB to overwrite global definition in some cases736 llnoov = (jpni * jpnj ) == jpnij .AND. .NOT. lk_agrif737 710 ! create the file name by added, if needed, TRIM(Agrif_CFixed()) and TRIM(clsuffix) 738 711 ! ============= … … 774 747 lxios_sini = .TRUE. 775 748 ENDIF 776 IF( llwrt ) THEN777 ! check the domain definition778 ! JMM + SM: ugly patch before getting the new version of lib_mpp)779 ! idom = jpdom_local_noovlap ! default definition780 IF( llnoov ) THEN ; idom = jpdom_local_noovlap ! default definition781 ELSE ; idom = jpdom_local_full ! default definition782 ENDIF783 IF( PRESENT(kdom) ) idom = kdom784 ! create the domain informations785 ! =============786 SELECT CASE (idom)787 CASE (jpdom_local_full)788 idompar(:,1) = (/ jpi , jpj /)789 idompar(:,2) = (/ nimpp , njmpp /)790 idompar(:,3) = (/ nimpp + jpi - 1 , njmpp + jpj - 1 /)791 idompar(:,4) = (/ nldi - 1 , nldj - 1 /)792 idompar(:,5) = (/ jpi - nlei , jpj - nlej /)793 CASE (jpdom_local_noextra)794 idompar(:,1) = (/ nlci , nlcj /)795 idompar(:,2) = (/ nimpp , njmpp /)796 idompar(:,3) = (/ nimpp + nlci - 1, njmpp + nlcj - 1 /)797 idompar(:,4) = (/ nldi - 1 , nldj - 1 /)798 idompar(:,5) = (/ nlci - nlei , nlcj - nlej /)799 CASE (jpdom_local_noovlap)800 idompar(:,1) = (/ nlei - nldi + 1, nlej - nldj + 1 /)801 idompar(:,2) = (/ nimpp + nldi - 1, njmpp + nldj - 1 /)802 idompar(:,3) = (/ nimpp + nlei - 1, njmpp + nlej - 1 /)803 idompar(:,4) = (/ 0 , 0 /)804 idompar(:,5) = (/ 0 , 0 /)805 CASE DEFAULT806 CALL ctl_stop( TRIM(clinfo), 'wrong value of kdom, only jpdom_local* cases are accepted' )807 END SELECT808 ENDIF809 749 ! Open the NetCDF file 810 750 ! ============= … … 830 770 ENDIF 831 771 IF( istop == nstop ) THEN ! no error within this routine 832 CALL iom_nf90_open( clname, kiomid, llwrt, llok, idompar,kdlev = kdlev, cdcomp = cdcomp )772 CALL iom_nf90_open( clname, kiomid, llwrt, llok, kdlev = kdlev, cdcomp = cdcomp ) 833 773 ENDIF 834 774 ! … … 1091 1031 END SUBROUTINE iom_g1d_dp 1092 1032 1093 SUBROUTINE iom_g2d_sp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr, ldxios) 1094 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1095 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 1096 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 1097 REAL(sp) , INTENT( out), DIMENSION(:,:) :: pvar ! read field 1098 REAL(dp) , ALLOCATABLE , DIMENSION(:,:) :: ztmp_pvar ! tmp var to read field 1099 INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number 1100 INTEGER , INTENT(in ), DIMENSION(2) , OPTIONAL :: kstart ! start axis position of the reading 1101 INTEGER , INTENT(in ), DIMENSION(2) , OPTIONAL :: kcount ! number of points in each axis 1102 LOGICAL , INTENT(in ) , OPTIONAL :: lrowattr ! logical flag telling iom_get to 1103 ! look for and use a file attribute 1104 ! called open_ocean_jstart to set the start 1105 ! value for the 2nd dimension (netcdf only) 1106 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS 1033 SUBROUTINE iom_g2d_sp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount, ldxios) 1034 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1035 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 1036 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 1037 REAL(sp) , INTENT( out), DIMENSION(:,:) :: pvar ! read field 1038 REAL(dp) , ALLOCATABLE , DIMENSION(:,:) :: ztmp_pvar ! tmp var to read field 1039 INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number 1040 CHARACTER(len=1), INTENT(in ) , OPTIONAL :: cd_type ! nature of grid-points (T, U, V, F, W) 1041 REAL(dp) , INTENT(in ) , OPTIONAL :: psgn ! -1.(1.): (not) change sign across the north fold 1042 INTEGER , INTENT(in ) , OPTIONAL :: kfill ! value of kfillmode in lbc_lbk 1043 INTEGER , INTENT(in ), DIMENSION(2), OPTIONAL :: kstart ! start axis position of the reading 1044 INTEGER , INTENT(in ), DIMENSION(2), OPTIONAL :: kcount ! number of points in each axis 1045 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS 1107 1046 ! 1108 1047 IF( kiomid > 0 ) THEN 1109 1048 IF( iom_file(kiomid)%nfid > 0 ) THEN 1110 1049 ALLOCATE(ztmp_pvar(size(pvar,1), size(pvar,2))) 1111 CALL iom_get_123d( kiomid, kdom , cdvar , pv_r2d=ztmp_pvar, & 1112 & ktime=ktime, kstart=kstart, kcount=kcount, & 1113 & lrowattr=lrowattr, ldxios=ldxios) 1050 CALL iom_get_123d( kiomid, kdom, cdvar , pv_r2d = ztmp_pvar , ktime = ktime, & 1051 & cd_type = cd_type, psgn = psgn , kfill = kfill, & 1052 & kstart = kstart , kcount = kcount, ldxios=ldxios ) 1053 pvar = ztmp_pvar 1054 DEALLOCATE(ztmp_pvar) 1055 ENDIF 1056 ENDIF 1057 END SUBROUTINE iom_g2d_sp 1058 1059 SUBROUTINE iom_g2d_dp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount, ldxios) 1060 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1061 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 1062 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 1063 REAL(dp) , INTENT( out), DIMENSION(:,:) :: pvar ! read field 1064 INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number 1065 CHARACTER(len=1), INTENT(in ) , OPTIONAL :: cd_type ! nature of grid-points (T, U, V, F, W) 1066 REAL(dp) , INTENT(in ) , OPTIONAL :: psgn ! -1.(1.): (not) change sign across the north fold 1067 INTEGER , INTENT(in ) , OPTIONAL :: kfill ! value of kfillmode in lbc_lbk 1068 INTEGER , INTENT(in ), DIMENSION(2), OPTIONAL :: kstart ! start axis position of the reading 1069 INTEGER , INTENT(in ), DIMENSION(2), OPTIONAL :: kcount ! number of points in each axis 1070 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS 1071 ! 1072 IF( kiomid > 0 ) THEN 1073 IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom, cdvar , pv_r2d = pvar , ktime = ktime, & 1074 & cd_type = cd_type, psgn = psgn , kfill = kfill, & 1075 & kstart = kstart , kcount = kcount, ldxios=ldxios ) 1076 ENDIF 1077 END SUBROUTINE iom_g2d_dp 1078 1079 SUBROUTINE iom_g3d_sp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount, ldxios ) 1080 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1081 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 1082 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 1083 REAL(sp) , INTENT( out), DIMENSION(:,:,:) :: pvar ! read field 1084 REAL(dp) , ALLOCATABLE , DIMENSION(:,:,:) :: ztmp_pvar ! tmp var to read field 1085 INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number 1086 CHARACTER(len=1), INTENT(in ) , OPTIONAL :: cd_type ! nature of grid-points (T, U, V, F, W) 1087 REAL(dp) , INTENT(in ) , OPTIONAL :: psgn ! -1.(1.) : (not) change sign across the north fold 1088 INTEGER , INTENT(in ) , OPTIONAL :: kfill ! value of kfillmode in lbc_lbk 1089 INTEGER , INTENT(in ), DIMENSION(3), OPTIONAL :: kstart ! start axis position of the reading 1090 INTEGER , INTENT(in ), DIMENSION(3), OPTIONAL :: kcount ! number of points in each axis 1091 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS 1092 ! 1093 IF( kiomid > 0 ) THEN 1094 IF( iom_file(kiomid)%nfid > 0 ) THEN 1095 ALLOCATE(ztmp_pvar(size(pvar,1), size(pvar,2), size(pvar,3))) 1096 CALL iom_get_123d( kiomid, kdom, cdvar , pv_r3d = ztmp_pvar , ktime = ktime, & 1097 & cd_type = cd_type, psgn = psgn , kfill = kfill, & 1098 & kstart = kstart , kcount = kcount, ldxios=ldxios ) 1114 1099 pvar = ztmp_pvar 1115 1100 DEALLOCATE(ztmp_pvar) 1116 1101 END IF 1117 1102 ENDIF 1118 END SUBROUTINE iom_g2d_sp 1119 1120 1121 SUBROUTINE iom_g2d_dp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr, ldxios) 1122 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1123 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 1124 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 1125 REAL(dp) , INTENT( out), DIMENSION(:,:) :: pvar ! read field 1126 INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number 1127 INTEGER , INTENT(in ), DIMENSION(2) , OPTIONAL :: kstart ! start axis position of the reading 1128 INTEGER , INTENT(in ), DIMENSION(2) , OPTIONAL :: kcount ! number of points in each axis 1129 LOGICAL , INTENT(in ) , OPTIONAL :: lrowattr ! logical flag telling iom_get to 1130 ! look for and use a file attribute 1131 ! called open_ocean_jstart to set the start 1132 ! value for the 2nd dimension (netcdf only) 1133 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS 1134 ! 1135 IF( kiomid > 0 ) THEN 1136 IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom , cdvar , pv_r2d=pvar, & 1137 & ktime=ktime, kstart=kstart, kcount=kcount, & 1138 & lrowattr=lrowattr, ldxios=ldxios) 1139 ENDIF 1140 END SUBROUTINE iom_g2d_dp 1141 1142 SUBROUTINE iom_g3d_sp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr, ldxios ) 1143 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1144 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 1145 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 1146 REAL(sp) , INTENT( out), DIMENSION(:,:,:) :: pvar ! read field 1147 REAL(dp) , ALLOCATABLE , DIMENSION(:,:,:) :: ztmp_pvar ! tmp var to read field 1148 INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number 1149 INTEGER , INTENT(in ), DIMENSION(3) , OPTIONAL :: kstart ! start axis position of the reading 1150 INTEGER , INTENT(in ), DIMENSION(3) , OPTIONAL :: kcount ! number of points in each axis 1151 LOGICAL , INTENT(in ) , OPTIONAL :: lrowattr ! logical flag telling iom_get to 1152 ! look for and use a file attribute 1153 ! called open_ocean_jstart to set the start 1154 ! value for the 2nd dimension (netcdf only) 1155 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS 1103 END SUBROUTINE iom_g3d_sp 1104 1105 SUBROUTINE iom_g3d_dp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount, ldxios ) 1106 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1107 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 1108 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 1109 REAL(dp) , INTENT( out), DIMENSION(:,:,:) :: pvar ! read field 1110 INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number 1111 CHARACTER(len=1), INTENT(in ) , OPTIONAL :: cd_type ! nature of grid-points (T, U, V, F, W) 1112 REAL(dp) , INTENT(in ) , OPTIONAL :: psgn ! -1.(1.) : (not) change sign across the north fold 1113 INTEGER , INTENT(in ) , OPTIONAL :: kfill ! value of kfillmode in lbc_lbk 1114 INTEGER , INTENT(in ), DIMENSION(3), OPTIONAL :: kstart ! start axis position of the reading 1115 INTEGER , INTENT(in ), DIMENSION(3), OPTIONAL :: kcount ! number of points in each axis 1116 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS 1156 1117 ! 1157 1118 IF( kiomid > 0 ) THEN 1158 1119 IF( iom_file(kiomid)%nfid > 0 ) THEN 1159 ALLOCATE(ztmp_pvar(size(pvar,1), size(pvar,2), size(pvar,3))) 1160 CALL iom_get_123d( kiomid, kdom , cdvar , pv_r3d=ztmp_pvar, & 1161 & ktime=ktime, kstart=kstart, kcount=kcount, & 1162 & lrowattr=lrowattr, ldxios=ldxios ) 1163 pvar = ztmp_pvar 1164 DEALLOCATE(ztmp_pvar) 1120 CALL iom_get_123d( kiomid, kdom, cdvar , pv_r3d = pvar , ktime = ktime, & 1121 & cd_type = cd_type, psgn = psgn , kfill = kfill, & 1122 & kstart = kstart , kcount = kcount, ldxios=ldxios ) 1165 1123 END IF 1166 1124 ENDIF 1167 END SUBROUTINE iom_g3d_sp1168 1169 SUBROUTINE iom_g3d_dp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr, ldxios )1170 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file1171 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read1172 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable1173 REAL(dp) , INTENT( out), DIMENSION(:,:,:) :: pvar ! read field1174 INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number1175 INTEGER , INTENT(in ), DIMENSION(3) , OPTIONAL :: kstart ! start axis position of the reading1176 INTEGER , INTENT(in ), DIMENSION(3) , OPTIONAL :: kcount ! number of points in each axis1177 LOGICAL , INTENT(in ) , OPTIONAL :: lrowattr ! logical flag telling iom_get to1178 ! look for and use a file attribute1179 ! called open_ocean_jstart to set the start1180 ! value for the 2nd dimension (netcdf only)1181 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS1182 !1183 IF( kiomid > 0 ) THEN1184 IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom , cdvar , pv_r3d=pvar, &1185 & ktime=ktime, kstart=kstart, kcount=kcount, &1186 & lrowattr=lrowattr, ldxios=ldxios )1187 ENDIF1188 1125 END SUBROUTINE iom_g3d_dp 1189 1126 1190 1191 1192 1127 !!---------------------------------------------------------------------- 1193 1128 1194 SUBROUTINE iom_get_123d( kiomid, kdom , cdvar , & 1195 & pv_r1d, pv_r2d, pv_r3d, & 1196 & ktime , kstart, kcount, & 1197 & lrowattr, ldxios ) 1129 SUBROUTINE iom_get_123d( kiomid , kdom, cdvar, pv_r1d, pv_r2d, pv_r3d, ktime , & 1130 & cd_type, psgn, kfill, kstart, kcount, ldxios ) 1198 1131 !!----------------------------------------------------------------------- 1199 1132 !! *** ROUTINE iom_get_123d *** … … 1203 1136 !! ** Method : read ONE record at each CALL 1204 1137 !!----------------------------------------------------------------------- 1205 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1206 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 1207 CHARACTER(len=*) , INTENT(in ) :: cdvar ! Name of the variable 1208 REAL(dp), DIMENSION(:) , INTENT( out), OPTIONAL :: pv_r1d ! read field (1D case) 1209 REAL(dp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pv_r2d ! read field (2D case) 1210 REAL(dp), DIMENSION(:,:,:) , INTENT( out), OPTIONAL :: pv_r3d ! read field (3D case) 1211 INTEGER , INTENT(in ), OPTIONAL :: ktime ! record number 1212 INTEGER , DIMENSION(:) , INTENT(in ), OPTIONAL :: kstart ! start position of the reading in each axis 1213 INTEGER , DIMENSION(:) , INTENT(in ), OPTIONAL :: kcount ! number of points to be read in each axis 1214 LOGICAL , INTENT(in ), OPTIONAL :: lrowattr ! logical flag telling iom_get to 1215 ! look for and use a file attribute 1216 ! called open_ocean_jstart to set the start 1217 ! value for the 2nd dimension (netcdf only) 1218 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! use XIOS to read restart 1219 ! 1220 LOGICAL :: llxios ! local definition for XIOS read 1221 LOGICAL :: llnoov ! local definition to read overlap 1222 LOGICAL :: luse_jattr ! local definition to read open_ocean_jstart file attribute 1223 INTEGER :: jstartrow ! start point for 2nd dimension optionally set by file attribute 1138 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1139 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 1140 CHARACTER(len=*) , INTENT(in ) :: cdvar ! Name of the variable 1141 REAL(dp), DIMENSION(:) , INTENT( out), OPTIONAL :: pv_r1d ! read field (1D case) 1142 REAL(dp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pv_r2d ! read field (2D case) 1143 REAL(dp), DIMENSION(:,:,:) , INTENT( out), OPTIONAL :: pv_r3d ! read field (3D case) 1144 INTEGER , INTENT(in ), OPTIONAL :: ktime ! record number 1145 CHARACTER(len=1) , INTENT(in ), OPTIONAL :: cd_type ! nature of grid-points (T, U, V, F, W) 1146 REAL(dp) , INTENT(in ), OPTIONAL :: psgn ! -1.(1.) : (not) change sign across the north fold 1147 INTEGER , INTENT(in ), OPTIONAL :: kfill ! value of kfillmode in lbc_lbk 1148 INTEGER , DIMENSION(:) , INTENT(in ), OPTIONAL :: kstart ! start position of the reading in each axis 1149 INTEGER , DIMENSION(:) , INTENT(in ), OPTIONAL :: kcount ! number of points to be read in each axis 1150 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! use XIOS to read restart 1151 ! 1152 LOGICAL :: llok ! true if ok! 1153 LOGICAL :: llxios ! local definition for XIOS read 1224 1154 INTEGER :: jl ! loop on number of dimension 1225 1155 INTEGER :: idom ! type of domain … … 1238 1168 INTEGER, DIMENSION(jpmax_dims) :: ishape ! size of the dimensions of the variable 1239 1169 REAL(dp) :: zscf, zofs ! sacle_factor and add_offset 1170 REAL(wp) :: zsgn ! local value of psgn 1240 1171 INTEGER :: itmp ! temporary integer 1241 1172 CHARACTER(LEN=256) :: clinfo ! info character 1242 1173 CHARACTER(LEN=256) :: clname ! file name 1243 1174 CHARACTER(LEN=1) :: clrankpv, cldmspc ! 1244 LOGICAL :: ll_depth_spec ! T => if kstart, kcount present then *only* use values for 3rd spatial dimension. 1175 CHARACTER(LEN=1) :: cl_type ! local value of cd_type 1176 LOGICAL :: ll_only3rd ! T => if kstart, kcount present then *only* use values for 3rd spatial dimension. 1245 1177 INTEGER :: inlev ! number of levels for 3D data 1246 1178 REAL(dp) :: gma, gmi … … 1251 1183 ! 1252 1184 llxios = .FALSE. 1253 if(PRESENT(ldxios))llxios = ldxios1254 idvar = iom_varid( kiomid, cdvar )1185 IF( PRESENT(ldxios) ) llxios = ldxios 1186 ! 1255 1187 idom = kdom 1188 istop = nstop 1256 1189 ! 1257 1190 IF(.NOT.llxios) THEN 1258 1191 clname = iom_file(kiomid)%name ! esier to read 1259 1192 clinfo = ' iom_get_123d, file: '//trim(clname)//', var: '//trim(cdvar) 1260 ! local definition of the domain ?1261 ! do we read the overlap1262 ! ugly patch SM+JMM+RB to overwrite global definition in some cases1263 llnoov = (jpni * jpnj ) == jpnij .AND. .NOT. lk_agrif1264 1193 ! check kcount and kstart optionals parameters... 1265 IF( PRESENT(kcount) .AND. (.NOT. PRESENT(kstart)) ) CALL ctl_stop(trim(clinfo), 'kcount present needs kstart present') 1266 IF( PRESENT(kstart) .AND. (.NOT. PRESENT(kcount)) ) CALL ctl_stop(trim(clinfo), 'kstart present needs kcount present') 1267 IF( PRESENT(kstart) .AND. idom /= jpdom_unknown .AND. idom /= jpdom_autoglo_xy ) & 1268 & CALL ctl_stop(trim(clinfo), 'kstart present needs kdom = jpdom_unknown or kdom = jpdom_autoglo_xy') 1269 1270 luse_jattr = .false. 1271 IF( PRESENT(lrowattr) ) THEN 1272 IF( lrowattr .AND. idom /= jpdom_data ) CALL ctl_stop(trim(clinfo), 'lrowattr present and true needs kdom = jpdom_data') 1273 IF( lrowattr .AND. idom == jpdom_data ) luse_jattr = .true. 1274 ENDIF 1275 1194 IF( PRESENT(kcount) .AND. .NOT. PRESENT(kstart) ) CALL ctl_stop(trim(clinfo), 'kcount present needs kstart present') 1195 IF( PRESENT(kstart) .AND. .NOT. PRESENT(kcount) ) CALL ctl_stop(trim(clinfo), 'kstart present needs kcount present') 1196 IF( PRESENT(kstart) .AND. idom /= jpdom_unknown .AND. idom /= jpdom_auto_xy ) & 1197 & CALL ctl_stop(TRIM(clinfo), 'kstart present needs idom = jpdom_unknown or idom = jpdom_auto_xy') 1198 IF( idom == jpdom_auto_xy .AND. .NOT. PRESENT(kstart) ) & 1199 & CALL ctl_stop(TRIM(clinfo), 'idom = jpdom_auto_xy requires kstart to be present') 1200 ! 1276 1201 ! Search for the variable in the data base (eventually actualize data) 1277 istop = nstop1278 1202 ! 1203 idvar = iom_varid( kiomid, cdvar ) 1279 1204 IF( idvar > 0 ) THEN 1280 ! to write iom_file(kiomid)%dimsz in a shorter way !1281 idimsz(:) = iom_file(kiomid)%dimsz(:, idvar) 1205 ! 1206 idimsz(:) = iom_file(kiomid)%dimsz(:, idvar) ! to write iom_file(kiomid)%dimsz in a shorter way 1282 1207 inbdim = iom_file(kiomid)%ndims(idvar) ! number of dimensions in the file 1283 1208 idmspc = inbdim ! number of spatial dimensions in the file … … 1285 1210 IF( idmspc > 3 ) CALL ctl_stop(trim(clinfo), 'the file has more than 3 spatial dimensions this case is not coded...') 1286 1211 ! 1287 ! update idom definition... 1288 ! Identify the domain in case of jpdom_auto(glo/dta) definition 1289 IF( idom == jpdom_autoglo_xy ) THEN 1290 ll_depth_spec = .TRUE. 1291 idom = jpdom_autoglo 1292 ELSE 1293 ll_depth_spec = .FALSE. 1294 ENDIF 1295 IF( idom == jpdom_autoglo .OR. idom == jpdom_autodta ) THEN 1296 IF( idom == jpdom_autoglo ) THEN ; idom = jpdom_global 1297 ELSE ; idom = jpdom_data 1298 ENDIF 1212 ! Identify the domain in case of jpdom_auto definition 1213 IF( idom == jpdom_auto .OR. idom == jpdom_auto_xy ) THEN 1214 idom = jpdom_global ! default 1215 ! else: if the file name finishes with _xxxx.nc with xxxx any number 1299 1216 ind1 = INDEX( clname, '_', back = .TRUE. ) + 1 1300 1217 ind2 = INDEX( clname, '.', back = .TRUE. ) - 1 1301 1218 IF( ind2 > ind1 ) THEN ; IF( VERIFY( clname(ind1:ind2), '0123456789' ) == 0 ) idom = jpdom_local ; ENDIF 1302 ENDIF1303 ! Identify the domain in case of jpdom_local definition1304 IF( idom == jpdom_local ) THEN1305 IF( idimsz(1) == jpi .AND. idimsz(2) == jpj ) THEN ; idom = jpdom_local_full1306 ELSEIF( idimsz(1) == nlci .AND. idimsz(2) == nlcj ) THEN ; idom = jpdom_local_noextra1307 ELSEIF( idimsz(1) == (nlei - nldi + 1) .AND. idimsz(2) == (nlej - nldj + 1) ) THEN ; idom = jpdom_local_noovlap1308 ELSE ; CALL ctl_stop( trim(clinfo), 'impossible to identify the local domain' )1309 ENDIF1310 1219 ENDIF 1311 1220 ! … … 1320 1229 WRITE(cldmspc , fmt='(i1)') idmspc 1321 1230 ! 1322 !!GS: we consider 2D data as 3D data with vertical dim size = 1 1323 !IF( idmspc < irankpv ) THEN 1324 ! CALL ctl_stop( TRIM(clinfo), 'The file has only '//cldmspc//' spatial dimension', & 1325 ! & 'it is impossible to read a '//clrankpv//'D array from this file...' ) 1326 !ELSEIF( idmspc == irankpv ) THEN 1327 IF( idmspc == irankpv ) THEN 1231 IF( idmspc < irankpv ) THEN ! it seems we want to read more than we can... 1232 IF( irankpv == 3 .AND. idmspc == 2 ) THEN ! 3D input array from 2D spatial data in the file: 1233 llok = inlev == 1 ! -> 3rd dimension must be equal to 1 1234 ELSEIF( irankpv == 3 .AND. idmspc == 1 ) THEN ! 3D input array from 1D spatial data in the file: 1235 llok = inlev == 1 .AND. SIZE(pv_r3d, 2) == 1 ! -> 2nd and 3rd dimensions must be equal to 1 1236 ELSEIF( irankpv == 2 .AND. idmspc == 2 ) THEN ! 2D input array from 1D spatial data in the file: 1237 llok = SIZE(pv_r2d, 2) == 1 ! -> 2nd dimension must be equal to 1 1238 ELSE 1239 llok = .FALSE. 1240 ENDIF 1241 IF( .NOT. llok ) CALL ctl_stop( TRIM(clinfo), 'The file has only '//cldmspc//' spatial dimension', & 1242 & '=> cannot read a true '//clrankpv//'D array from this file...' ) 1243 ELSEIF( idmspc == irankpv ) THEN 1328 1244 IF( PRESENT(pv_r1d) .AND. idom /= jpdom_unknown ) & 1329 1245 & CALL ctl_stop( TRIM(clinfo), 'case not coded...You must use jpdom_unknown' ) 1330 ELSEIF( idmspc > irankpv ) THEN 1246 ELSEIF( idmspc > irankpv ) THEN ! it seems we want to read less than we should... 1331 1247 IF( PRESENT(pv_r2d) .AND. itime == 1 .AND. idimsz(3) == 1 .AND. idmspc == 3 ) THEN 1332 CALL ctl_warn( trim(clinfo), '2D array but 3 spatial dimensions for the data...' , &1248 CALL ctl_warn( trim(clinfo), '2D array input but 3 spatial dimensions in the file...' , & 1333 1249 & 'As the size of the z dimension is 1 and as we try to read the first record, ', & 1334 1250 & 'we accept this case, even if there is a possible mix-up between z and time dimension' ) … … 1344 1260 ! definition of istart and icnt 1345 1261 ! 1346 icnt (:) = 1 1347 istart(:) = 1 1348 istart(idmspc+1) = itime 1349 1350 IF( PRESENT(kstart) .AND. .NOT. ll_depth_spec ) THEN 1351 istart(1:idmspc) = kstart(1:idmspc) 1352 icnt (1:idmspc) = kcount(1:idmspc) 1353 ELSE 1354 IF(idom == jpdom_unknown ) THEN 1355 icnt(1:idmspc) = idimsz(1:idmspc) 1356 ELSE 1357 IF( .NOT. PRESENT(pv_r1d) ) THEN ! not a 1D array 1358 IF( idom == jpdom_data ) THEN 1359 jstartrow = 1 1360 IF( luse_jattr ) THEN 1361 CALL iom_getatt(kiomid, 'open_ocean_jstart', jstartrow ) ! -999 is returned if the attribute is not found 1362 jstartrow = MAX(1,jstartrow) 1363 ENDIF 1364 istart(1:2) = (/ mig(1), mjg(1) + jstartrow - 1 /) ! icnt(1:2) done below 1365 ELSEIF( idom == jpdom_global ) THEN ; istart(1:2) = (/ nimpp , njmpp /) ! icnt(1:2) done below 1366 ENDIF 1367 ! we do not read the overlap -> we start to read at nldi, nldj 1368 ! JMM + SM: ugly patch before getting the new version of lib_mpp) 1369 ! IF( idom /= jpdom_local_noovlap ) istart(1:2) = istart(1:2) + (/ nldi - 1, nldj - 1 /) 1370 IF( llnoov .AND. idom /= jpdom_local_noovlap ) istart(1:2) = istart(1:2) + (/ nldi - 1, nldj - 1 /) 1371 ! we do not read the overlap and the extra-halos -> from nldi to nlei and from nldj to nlej 1372 ! JMM + SM: ugly patch before getting the new version of lib_mpp) 1373 ! icnt(1:2) = (/ nlei - nldi + 1, nlej - nldj + 1 /) 1374 IF( llnoov ) THEN ; icnt(1:2) = (/ nlei - nldi + 1, nlej - nldj + 1 /) 1375 ELSE ; icnt(1:2) = (/ nlci , nlcj /) 1376 ENDIF 1377 IF( PRESENT(pv_r3d) ) THEN 1378 IF( idom == jpdom_data ) THEN ; icnt(3) = inlev 1379 ELSEIF( ll_depth_spec .AND. PRESENT(kstart) ) THEN ; istart(3) = kstart(3) ; icnt(3) = kcount(3) 1380 ELSE ; icnt(3) = inlev 1381 ENDIF 1382 ENDIF 1262 icnt (:) = 1 ! default definition (simple way to deal with special cases listed above) 1263 istart(:) = 1 ! default definition (simple way to deal with special cases listed above) 1264 istart(idmspc+1) = itime ! temporal dimenstion 1265 ! 1266 IF( idom == jpdom_unknown ) THEN 1267 IF( PRESENT(kstart) .AND. idom /= jpdom_auto_xy ) THEN 1268 istart(1:idmspc) = kstart(1:idmspc) 1269 icnt (1:idmspc) = kcount(1:idmspc) 1270 ELSE 1271 icnt (1:idmspc) = idimsz(1:idmspc) 1272 ENDIF 1273 ELSE ! not a 1D array as pv_r1d requires jpdom_unknown 1274 ! we do not read the overlap and the extra-halos -> from Nis0 to Nie0 and from Njs0 to Nje0 1275 IF( idom == jpdom_global ) istart(1:2) = (/ mig0(Nis0), mjg0(Njs0) /) 1276 icnt(1:2) = (/ Ni_0, Nj_0 /) 1277 IF( PRESENT(pv_r3d) ) THEN 1278 IF( idom == jpdom_auto_xy ) THEN 1279 istart(3) = kstart(3) 1280 icnt (3) = kcount(3) 1281 ELSE 1282 icnt (3) = inlev 1383 1283 ENDIF 1384 1284 ENDIF 1385 1285 ENDIF 1386 1286 ! 1387 1287 ! check that istart and icnt can be used with this file 1388 1288 !- … … 1395 1295 ENDIF 1396 1296 END DO 1397 1297 ! 1398 1298 ! check that icnt matches the input array 1399 1299 !- … … 1405 1305 ELSE 1406 1306 IF( irankpv == 2 ) THEN 1407 ! JMM + SM: ugly patch before getting the new version of lib_mpp) 1408 ! ishape(1:2) = SHAPE(pv_r2d(nldi:nlei,nldj:nlej )) ; ctmp1 = 'd(nldi:nlei,nldj:nlej)' 1409 IF( llnoov ) THEN ; ishape(1:2)=SHAPE(pv_r2d(nldi:nlei,nldj:nlej )) ; ctmp1='d(nldi:nlei,nldj:nlej)' 1410 ELSE ; ishape(1:2)=SHAPE(pv_r2d(1 :nlci,1 :nlcj )) ; ctmp1='d(1:nlci,1:nlcj)' 1411 ENDIF 1307 ishape(1:2) = SHAPE(pv_r2d(Nis0:Nie0,Njs0:Nje0 )) ; ctmp1 = 'd(Nis0:Nie0,Njs0:Nje0)' 1412 1308 ENDIF 1413 1309 IF( irankpv == 3 ) THEN 1414 ! JMM + SM: ugly patch before getting the new version of lib_mpp) 1415 ! ishape(1:3) = SHAPE(pv_r3d(nldi:nlei,nldj:nlej,:)) ; ctmp1 = 'd(nldi:nlei,nldj:nlej,:)' 1416 IF( llnoov ) THEN ; ishape(1:3)=SHAPE(pv_r3d(nldi:nlei,nldj:nlej,:)) ; ctmp1='d(nldi:nlei,nldj:nlej,:)' 1417 ELSE ; ishape(1:3)=SHAPE(pv_r3d(1 :nlci,1 :nlcj,:)) ; ctmp1='d(1:nlci,1:nlcj,:)' 1418 ENDIF 1310 ishape(1:3) = SHAPE(pv_r3d(Nis0:Nie0,Njs0:Nje0,:)) ; ctmp1 = 'd(Nis0:Nie0,Njs0:Nje0,:)' 1419 1311 ENDIF 1420 ENDIF 1421 1312 ENDIF 1422 1313 DO jl = 1, irankpv 1423 1314 WRITE( ctmp2, FMT="(', ', i1,'): ', i5,' /= icnt(', i1,'):', i5)" ) jl, ishape(jl), jl, icnt(jl) … … 1431 1322 IF( idvar > 0 .AND. istop == nstop ) THEN ! no additional errors until this point... 1432 1323 ! 1433 ! find the right index of the array to be read 1434 ! JMM + SM: ugly patch before getting the new version of lib_mpp) 1435 ! IF( idom /= jpdom_unknown ) THEN ; ix1 = nldi ; ix2 = nlei ; iy1 = nldj ; iy2 = nlej 1436 ! ELSE ; ix1 = 1 ; ix2 = icnt(1) ; iy1 = 1 ; iy2 = icnt(2) 1437 ! ENDIF 1438 IF( llnoov ) THEN 1439 IF( idom /= jpdom_unknown ) THEN ; ix1 = nldi ; ix2 = nlei ; iy1 = nldj ; iy2 = nlej 1440 ELSE ; ix1 = 1 ; ix2 = icnt(1) ; iy1 = 1 ; iy2 = icnt(2) 1441 ENDIF 1442 ELSE 1443 IF( idom /= jpdom_unknown ) THEN ; ix1 = 1 ; ix2 = nlci ; iy1 = 1 ; iy2 = nlcj 1444 ELSE ; ix1 = 1 ; ix2 = icnt(1) ; iy1 = 1 ; iy2 = icnt(2) 1445 ENDIF 1324 ! find the right index of the array to be read 1325 IF( idom /= jpdom_unknown ) THEN ; ix1 = Nis0 ; ix2 = Nie0 ; iy1 = Njs0 ; iy2 = Nje0 1326 ELSE ; ix1 = 1 ; ix2 = icnt(1) ; iy1 = 1 ; iy2 = icnt(2) 1446 1327 ENDIF 1447 1328 … … 1450 1331 IF( istop == nstop ) THEN ! no additional errors until this point... 1451 1332 IF(lwp) WRITE(numout,"(10x,' read ',a,' (rec: ',i6,') in ',a,' ok')") TRIM(cdvar), itime, TRIM(iom_file(kiomid)%name) 1452 1333 1334 cl_type = 'T' 1335 IF( PRESENT(cd_type) ) cl_type = cd_type 1336 zsgn = 1._wp 1337 IF( PRESENT(psgn ) ) zsgn = psgn 1453 1338 !--- overlap areas and extra hallows (mpp) 1454 IF( PRESENT(pv_r2d) .AND. idom /= jpdom_unknown ) THEN 1455 CALL lbc_lnk( 'iom', pv_r2d,'Z', -999.0_wp, kfillmode = jpfillnothing ) 1456 ELSEIF( PRESENT(pv_r3d) .AND. idom /= jpdom_unknown ) THEN 1457 ! this if could be simplified with the new lbc_lnk that works with any size of the 3rd dimension 1458 IF( icnt(3) == inlev ) THEN 1459 CALL lbc_lnk( 'iom', pv_r3d,'Z', -999.0_wp, kfillmode = jpfillnothing ) 1460 ELSE ! put some arbitrary value (a call to lbc_lnk will be done later...) 1461 DO jj = nlcj+1, jpj ; pv_r3d(1:nlci, jj, :) = pv_r3d(1:nlci, nlej, :) ; END DO 1462 DO ji = nlci+1, jpi ; pv_r3d(ji , : , :) = pv_r3d(nlei , : , :) ; END DO 1463 ENDIF 1339 IF( PRESENT(pv_r2d) .AND. idom /= jpdom_unknown .AND. cl_type /= 'Z' ) THEN 1340 CALL lbc_lnk( 'iom', pv_r2d, cl_type, zsgn, kfillmode = kfill ) 1341 ELSEIF( PRESENT(pv_r3d) .AND. idom /= jpdom_unknown .AND. cl_type /= 'Z' ) THEN 1342 CALL lbc_lnk( 'iom', pv_r3d, cl_type, zsgn, kfillmode = kfill ) 1464 1343 ENDIF 1465 1344 ! … … 1478 1357 CALL iom_swap( TRIM(crxios_context) ) 1479 1358 IF( PRESENT(pv_r3d) ) THEN 1480 pv_r3d(:, :, :) = 0. 1481 if(lwp) write(numout,*) 'XIOS RST READ (3D): ',trim(cdvar) 1359 IF(lwp) WRITE(numout,*) 'XIOS RST READ (3D): ',TRIM(cdvar) 1482 1360 CALL xios_recv_field( trim(cdvar), pv_r3d) 1483 IF(idom /= jpdom_unknown ) then 1484 CALL lbc_lnk( 'iom', pv_r3d,'Z', -999.0_wp, kfillmode = jpfillnothing) 1485 ENDIF 1361 IF(idom /= jpdom_unknown ) CALL lbc_lnk( 'iom', pv_r3d,'Z', -999., kfillmode = jpfillnothing) 1486 1362 ELSEIF( PRESENT(pv_r2d) ) THEN 1487 pv_r2d(:, :) = 0. 1488 if(lwp) write(numout,*) 'XIOS RST READ (2D): ', trim(cdvar) 1363 IF(lwp) WRITE(numout,*) 'XIOS RST READ (2D): ', TRIM(cdvar) 1489 1364 CALL xios_recv_field( trim(cdvar), pv_r2d) 1490 IF(idom /= jpdom_unknown ) THEN 1491 CALL lbc_lnk('iom', pv_r2d,'Z',-999.0_wp, kfillmode = jpfillnothing) 1492 ENDIF 1365 IF(idom /= jpdom_unknown ) CALL lbc_lnk('iom', pv_r2d,'Z',-999., kfillmode = jpfillnothing) 1493 1366 ELSEIF( PRESENT(pv_r1d) ) THEN 1494 pv_r1d(:) = 0. 1495 if(lwp) write(numout,*) 'XIOS RST READ (1D): ', trim(cdvar) 1367 IF(lwp) WRITE(numout,*) 'XIOS RST READ (1D): ', TRIM(cdvar) 1496 1368 CALL xios_recv_field( trim(cdvar), pv_r1d) 1497 1369 ENDIF … … 2036 1908 CHARACTER(LEN=*) , INTENT(in) :: cdname 2037 1909 REAL(sp), DIMENSION(:,:), INTENT(in) :: pfield2d 2038 #if defined key_iomput 2039 CALL xios_send_field(cdname, pfield2d) 1910 IF( iom_use(cdname) ) THEN 1911 #if defined key_iomput 1912 IF( SIZE(pfield2d, dim=1) == jpi .AND. SIZE(pfield2d, dim=2) == jpj ) THEN 1913 CALL xios_send_field( cdname, pfield2d(Nis0:Nie0, Njs0:Nje0) ) ! this extraction will create a copy of pfield2d 1914 ELSE 1915 CALL xios_send_field( cdname, pfield2d ) 1916 ENDIF 2040 1917 #else 2041 IF( .FALSE. ) WRITE(numout,*) cdname, pfield2d ! useless test to avoid compilation warnings 2042 #endif 1918 WRITE(numout,*) pfield2d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings 1919 #endif 1920 ENDIF 2043 1921 END SUBROUTINE iom_p2d_sp 2044 1922 … … 2046 1924 CHARACTER(LEN=*) , INTENT(in) :: cdname 2047 1925 REAL(dp), DIMENSION(:,:), INTENT(in) :: pfield2d 2048 #if defined key_iomput 2049 CALL xios_send_field(cdname, pfield2d) 1926 IF( iom_use(cdname) ) THEN 1927 #if defined key_iomput 1928 IF( SIZE(pfield2d, dim=1) == jpi .AND. SIZE(pfield2d, dim=2) == jpj ) THEN 1929 CALL xios_send_field( cdname, pfield2d(Nis0:Nie0, Njs0:Nje0) ) ! this extraction will create a copy of pfield2d 1930 ELSE 1931 CALL xios_send_field( cdname, pfield2d ) 1932 ENDIF 2050 1933 #else 2051 IF( .FALSE. ) WRITE(numout,*) cdname, pfield2d ! useless test to avoid compilation warnings 2052 #endif 1934 WRITE(numout,*) pfield2d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings 1935 #endif 1936 ENDIF 2053 1937 END SUBROUTINE iom_p2d_dp 2054 1938 … … 2056 1940 CHARACTER(LEN=*) , INTENT(in) :: cdname 2057 1941 REAL(sp), DIMENSION(:,:,:), INTENT(in) :: pfield3d 2058 #if defined key_iomput 2059 CALL xios_send_field( cdname, pfield3d ) 1942 IF( iom_use(cdname) ) THEN 1943 #if defined key_iomput 1944 IF( SIZE(pfield3d, dim=1) == jpi .AND. SIZE(pfield3d, dim=2) == jpj ) THEN 1945 CALL xios_send_field( cdname, pfield3d(Nis0:Nie0, Njs0:Nje0,:) ) ! this extraction will create a copy of pfield3d 1946 ELSE 1947 CALL xios_send_field( cdname, pfield3d ) 1948 ENDIF 2060 1949 #else 2061 IF( .FALSE. ) WRITE(numout,*) cdname, pfield3d ! useless test to avoid compilation warnings 2062 #endif 1950 WRITE(numout,*) pfield3d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings 1951 #endif 1952 ENDIF 2063 1953 END SUBROUTINE iom_p3d_sp 2064 1954 … … 2066 1956 CHARACTER(LEN=*) , INTENT(in) :: cdname 2067 1957 REAL(dp), DIMENSION(:,:,:), INTENT(in) :: pfield3d 2068 #if defined key_iomput 2069 CALL xios_send_field( cdname, pfield3d ) 1958 IF( iom_use(cdname) ) THEN 1959 #if defined key_iomput 1960 IF( SIZE(pfield3d, dim=1) == jpi .AND. SIZE(pfield3d, dim=2) == jpj ) THEN 1961 CALL xios_send_field( cdname, pfield3d(Nis0:Nie0, Njs0:Nje0,:) ) ! this extraction will create a copy of pfield3d 1962 ELSE 1963 CALL xios_send_field( cdname, pfield3d ) 1964 ENDIF 2070 1965 #else 2071 IF( .FALSE. ) WRITE(numout,*) cdname, pfield3d ! useless test to avoid compilation warnings 2072 #endif 1966 WRITE(numout,*) pfield3d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings 1967 #endif 1968 ENDIF 2073 1969 END SUBROUTINE iom_p3d_dp 2074 1970 … … 2076 1972 CHARACTER(LEN=*) , INTENT(in) :: cdname 2077 1973 REAL(sp), DIMENSION(:,:,:,:), INTENT(in) :: pfield4d 2078 #if defined key_iomput 2079 CALL xios_send_field(cdname, pfield4d) 1974 IF( iom_use(cdname) ) THEN 1975 #if defined key_iomput 1976 IF( SIZE(pfield4d, dim=1) == jpi .AND. SIZE(pfield4d, dim=2) == jpj ) THEN 1977 CALL xios_send_field( cdname, pfield4d(Nis0:Nie0, Njs0:Nje0,:,:) ) ! this extraction will create a copy of pfield4d 1978 ELSE 1979 CALL xios_send_field (cdname, pfield4d ) 1980 ENDIF 2080 1981 #else 2081 IF( .FALSE. ) WRITE(numout,*) cdname, pfield4d ! useless test to avoid compilation warnings 2082 #endif 1982 WRITE(numout,*) pfield4d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings 1983 #endif 1984 ENDIF 2083 1985 END SUBROUTINE iom_p4d_sp 2084 1986 … … 2086 1988 CHARACTER(LEN=*) , INTENT(in) :: cdname 2087 1989 REAL(dp), DIMENSION(:,:,:,:), INTENT(in) :: pfield4d 2088 #if defined key_iomput 2089 CALL xios_send_field(cdname, pfield4d) 1990 IF( iom_use(cdname) ) THEN 1991 #if defined key_iomput 1992 IF( SIZE(pfield4d, dim=1) == jpi .AND. SIZE(pfield4d, dim=2) == jpj ) THEN 1993 CALL xios_send_field( cdname, pfield4d(Nis0:Nie0, Njs0:Nje0,:,:) ) ! this extraction will create a copy of pfield4d 1994 ELSE 1995 CALL xios_send_field (cdname, pfield4d ) 1996 ENDIF 2090 1997 #else 2091 IF( .FALSE. ) WRITE(numout,*) cdname, pfield4d ! useless test to avoid compilation warnings 2092 #endif 1998 WRITE(numout,*) pfield4d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings 1999 #endif 2000 ENDIF 2093 2001 END SUBROUTINE iom_p4d_dp 2094 2002 … … 2287 2195 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: plat 2288 2196 ! 2289 INTEGER :: ni, nj2290 2197 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask 2291 2198 LOGICAL, INTENT(IN) :: ldxios, ldrxios 2292 2199 !!---------------------------------------------------------------------- 2293 2200 ! 2294 ni = nlei-nldi+1 2295 nj = nlej-nldj+1 2296 ! 2297 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) 2298 CALL iom_set_domain_attr("grid_"//cdgrd, data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj) 2201 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) 2202 CALL iom_set_domain_attr("grid_"//cdgrd, data_dim=2, data_ibegin = 0, data_ni = Ni_0, data_jbegin = 0, data_nj = Nj_0) 2299 2203 !don't define lon and lat for restart reading context. 2300 2204 IF ( .NOT.ldrxios ) & 2301 CALL iom_set_domain_attr("grid_"//cdgrd, lonvalue = real(RESHAPE(plon( nldi:nlei, nldj:nlej),(/ ni*nj /)),dp), &2302 & latvalue = real(RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /)),dp ))2205 CALL iom_set_domain_attr("grid_"//cdgrd, lonvalue = real(RESHAPE(plon(Nis0:Nie0, Njs0:Nje0),(/ Ni_0*Nj_0 /)),dp), & 2206 & latvalue = real(RESHAPE(plat(Nis0:Nie0, Njs0:Nje0),(/ Ni_0*Nj_0 /)),dp )) 2303 2207 ! 2304 2208 IF ( ln_mskland .AND. (.NOT.ldxios) ) THEN … … 2306 2210 SELECT CASE ( cdgrd ) 2307 2211 CASE('T') ; zmask(:,:,:) = tmask(:,:,:) 2308 CASE('U') ; zmask(2:jpim1,:,:) = tmask(2:jpim1,:,:) + tmask(3:jpi,:,:) ; CALL lbc_lnk( 'iom', zmask, 'U', 1.0_wp )2309 CASE('V') ; zmask(:,2:jpjm1,:) = tmask(:,2:jpjm1,:) + tmask(:,3:jpj,:) ; CALL lbc_lnk( 'iom', zmask, 'V', 1.0_wp )2212 CASE('U') ; zmask(2:jpim1,:,:) = tmask(2:jpim1,:,:) + tmask(3:jpi,:,:) 2213 CASE('V') ; zmask(:,2:jpjm1,:) = tmask(:,2:jpjm1,:) + tmask(:,3:jpj,:) 2310 2214 CASE('W') ; zmask(:,:,2:jpk ) = tmask(:,:,1:jpkm1) + tmask(:,:,2:jpk) ; zmask(:,:,1) = tmask(:,:,1) 2311 2215 END SELECT 2312 2216 ! 2313 CALL iom_set_domain_attr( "grid_"//cdgrd , mask = RESHAPE(zmask( nldi:nlei,nldj:nlej,1),(/ni*nj/)) /= 0. )2314 CALL iom_set_grid_attr ( "grid_"//cdgrd//"_3D", mask = RESHAPE(zmask( nldi:nlei,nldj:nlej,:),(/ni,nj,jpk/)) /= 0. )2217 CALL iom_set_domain_attr( "grid_"//cdgrd , mask = RESHAPE(zmask(Nis0:Nie0,Njs0:Nje0,1),(/Ni_0*Nj_0 /)) /= 0. ) 2218 CALL iom_set_grid_attr ( "grid_"//cdgrd//"_3D", mask = RESHAPE(zmask(Nis0:Nie0,Njs0:Nje0,:),(/Ni_0,Nj_0,jpk/)) /= 0. ) 2315 2219 ENDIF 2316 2220 ! 2317 2221 END SUBROUTINE set_grid 2318 2319 2222 2320 2223 SUBROUTINE set_grid_bounds( cdgrd, plon_cnr, plat_cnr, plon_pnt, plat_pnt ) … … 2329 2232 REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: plon_pnt, plat_pnt ! Lat/lon coord. of the point of cell (i,j) 2330 2233 ! 2331 INTEGER :: ji, jj, jn , ni, nj2234 INTEGER :: ji, jj, jn 2332 2235 INTEGER :: icnr, jcnr ! Offset such that the vertex coordinate (i+icnr,j+jcnr) 2333 ! ! represents the bottom-left corner of cell (i,j) 2236 ! ! represents the 2237 ! bottom-left corner of 2238 ! cell (i,j) 2334 2239 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: z_bnds ! Lat/lon coordinates of the vertices of cell (i,j) 2335 2240 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_fld ! Working array to determine where to rotate cells … … 2346 2251 END SELECT 2347 2252 ! 2348 ni = nlei-nldi+1 ! Dimensions of subdomain interior2349 nj = nlej-nldj+12350 !2351 2253 z_fld(:,:) = 1._wp 2352 2254 CALL lbc_lnk( 'iom', z_fld, cdgrd, -1.0_wp ) ! Working array for location of northfold 2353 2255 ! 2354 2256 ! Cell vertices that can be defined 2355 DO jj = 2, jpjm1 2356 DO ji = 2, jpim1 2357 z_bnds(1,ji,jj,1) = plat_cnr(ji+icnr, jj+jcnr ) ! Bottom-left 2358 z_bnds(2,ji,jj,1) = plat_cnr(ji+icnr+1,jj+jcnr ) ! Bottom-right 2359 z_bnds(3,ji,jj,1) = plat_cnr(ji+icnr+1,jj+jcnr+1) ! Top-right 2360 z_bnds(4,ji,jj,1) = plat_cnr(ji+icnr, jj+jcnr+1) ! Top-left 2361 z_bnds(1,ji,jj,2) = plon_cnr(ji+icnr, jj+jcnr ) ! Bottom-left 2362 z_bnds(2,ji,jj,2) = plon_cnr(ji+icnr+1,jj+jcnr ) ! Bottom-right 2363 z_bnds(3,ji,jj,2) = plon_cnr(ji+icnr+1,jj+jcnr+1) ! Top-right 2364 z_bnds(4,ji,jj,2) = plon_cnr(ji+icnr, jj+jcnr+1) ! Top-left 2365 END DO 2366 END DO 2367 ! 2368 ! Cell vertices on boundries 2369 DO jn = 1, 4 2370 CALL lbc_lnk( 'iom', z_bnds(jn,:,:,1), cdgrd, 1.0_wp, pfillval=999._wp ) 2371 CALL lbc_lnk( 'iom', z_bnds(jn,:,:,2), cdgrd, 1.0_wp, pfillval=999._wp ) 2372 END DO 2373 ! 2374 ! Zero-size cells at closed boundaries if cell points provided, 2375 ! otherwise they are closed cells with unrealistic bounds 2376 IF( PRESENT(plon_pnt) .AND. PRESENT(plat_pnt) ) THEN 2377 IF( (nbondi == -1 .OR. nbondi == 2) .AND. .NOT. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6) ) THEN 2378 DO jn = 1, 4 ! (West or jpni = 1), closed E-W 2379 z_bnds(jn,1,:,1) = plat_pnt(1,:) ; z_bnds(jn,1,:,2) = plon_pnt(1,:) 2380 END DO 2381 ENDIF 2382 IF( (nbondi == 1 .OR. nbondi == 2) .AND. .NOT. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6) ) THEN 2383 DO jn = 1, 4 ! (East or jpni = 1), closed E-W 2384 z_bnds(jn,nlci,:,1) = plat_pnt(nlci,:) ; z_bnds(jn,nlci,:,2) = plon_pnt(nlci,:) 2385 END DO 2386 ENDIF 2387 IF( nbondj == -1 .OR. (nbondj == 2 .AND. jperio /= 2) ) THEN 2388 DO jn = 1, 4 ! South or (jpnj = 1, not symmetric) 2389 z_bnds(jn,:,1,1) = plat_pnt(:,1) ; z_bnds(jn,:,1,2) = plon_pnt(:,1) 2390 END DO 2391 ENDIF 2392 IF( (nbondj == 1 .OR. nbondj == 2) .AND. jperio < 3 ) THEN 2393 DO jn = 1, 4 ! (North or jpnj = 1), no north fold 2394 z_bnds(jn,:,nlcj,1) = plat_pnt(:,nlcj) ; z_bnds(jn,:,nlcj,2) = plon_pnt(:,nlcj) 2395 END DO 2396 ENDIF 2397 ENDIF 2398 ! 2399 IF( (nbondj == 1 .OR. nbondj == 2) .AND. jperio >= 3 ) THEN ! Rotate cells at the north fold 2400 DO jj = 1, jpj 2401 DO ji = 1, jpi 2402 IF( z_fld(ji,jj) == -1. ) THEN 2403 z_rot(1,:) = z_bnds(3,ji,jj,:) ; z_rot(2,:) = z_bnds(4,ji,jj,:) 2404 z_rot(3,:) = z_bnds(1,ji,jj,:) ; z_rot(4,:) = z_bnds(2,ji,jj,:) 2405 z_bnds(:,ji,jj,:) = z_rot(:,:) 2406 ENDIF 2407 END DO 2408 END DO 2409 ELSE IF( nbondj == 2 .AND. jperio == 2 ) THEN ! Invert cells at the symmetric equator 2410 DO ji = 1, jpi 2411 z_rot(1:2,:) = z_bnds(3:4,ji,1,:) 2412 z_rot(3:4,:) = z_bnds(1:2,ji,1,:) 2413 z_bnds(:,ji,1,:) = z_rot(:,:) 2414 END DO 2415 ENDIF 2416 ! 2417 CALL iom_set_domain_attr("grid_"//cdgrd, bounds_lat =real( RESHAPE(z_bnds(:,nldi:nlei,nldj:nlej,1),(/ 4,ni*nj /)), dp), & 2418 & bounds_lon =real( RESHAPE(z_bnds(:,nldi:nlei,nldj:nlej,2),(/ 4,ni*nj /)), dp), nvertex=4 ) 2419 ! 2420 DEALLOCATE( z_bnds, z_fld, z_rot ) 2257 DO_2D_00_00 2258 z_bnds(1,ji,jj,1) = plat_cnr(ji+icnr, jj+jcnr ) ! Bottom-left 2259 z_bnds(2,ji,jj,1) = plat_cnr(ji+icnr+1,jj+jcnr ) ! Bottom-right 2260 z_bnds(3,ji,jj,1) = plat_cnr(ji+icnr+1,jj+jcnr+1) ! Top-right 2261 z_bnds(4,ji,jj,1) = plat_cnr(ji+icnr, jj+jcnr+1) ! Top-left 2262 z_bnds(1,ji,jj,2) = plon_cnr(ji+icnr, jj+jcnr ) ! Bottom-left 2263 z_bnds(2,ji,jj,2) = plon_cnr(ji+icnr+1,jj+jcnr ) ! Bottom-right 2264 z_bnds(3,ji,jj,2) = plon_cnr(ji+icnr+1,jj+jcnr+1) ! Top-right 2265 z_bnds(4,ji,jj,2) = plon_cnr(ji+icnr, jj+jcnr+1) ! Top-left 2266 END_2D 2267 ! 2268 DO_2D_00_00 2269 IF( z_fld(ji,jj) == -1. ) THEN 2270 z_rot(1,:) = z_bnds(3,ji,jj,:) ; z_rot(2,:) = z_bnds(4,ji,jj,:) 2271 z_rot(3,:) = z_bnds(1,ji,jj,:) ; z_rot(4,:) = z_bnds(2,ji,jj,:) 2272 z_bnds(:,ji,jj,:) = z_rot(:,:) 2273 ENDIF 2274 END_2D 2275 ! 2276 CALL iom_set_domain_attr("grid_"//cdgrd, bounds_lat = real(RESHAPE(z_bnds(:,Nis0:Nie0,Njs0:Nje0,1),(/ 4,Ni_0*Nj_0 /)), dp), & 2277 & bounds_lon = real(RESHAPE(z_bnds(:,Nis0:Nie0,Njs0:Nje0,2),(/ 4,Ni_0*Nj_0 /)), dp), nvertex=4 ) 2278 ! 2279 DEALLOCATE( z_bnds, z_fld, z_rot ) 2421 2280 ! 2422 2281 END SUBROUTINE set_grid_bounds 2423 2282 2424 2425 2283 SUBROUTINE set_grid_znl( plat ) 2426 2284 !!---------------------------------------------------------------------- … … 2432 2290 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: plat 2433 2291 ! 2434 INTEGER :: ni, nj,ix, iy2292 INTEGER :: ix, iy 2435 2293 REAL(wp), DIMENSION(:), ALLOCATABLE :: zlon 2436 2294 !!---------------------------------------------------------------------- 2437 2295 ! 2438 ni=nlei-nldi+1 ! define zonal mean domain (jpj*jpk) 2439 nj=nlej-nldj+1 2440 ALLOCATE( zlon(ni*nj) ) ; zlon(:) = 0._wp 2296 ALLOCATE( zlon(Ni_0*Nj_0) ) ; zlon(:) = 0._wp 2441 2297 ! 2442 2298 ! CALL dom_ngb( -168.53_wp, 65.03_wp, ix, iy, 'T' ) ! i-line that passes through Bering Strait: Reference latitude (used in plots) 2443 2299 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) 2444 CALL iom_set_domain_attr("gznl", ni_glo= jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-2, jbegin=njmpp+nldj-2, ni=ni, nj=nj)2445 CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj)2300 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) 2301 CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = 0, data_ni = Ni_0, data_jbegin = 0, data_nj = Nj_0) 2446 2302 CALL iom_set_domain_attr("gznl", lonvalue = real(zlon, dp), & 2447 & latvalue = real(RESHAPE(plat( nldi:nlei, nldj:nlej),(/ ni*nj/)),dp))2448 CALL iom_set_zoom_domain_attr("ptr", ibegin=ix-1, jbegin=0, ni=1, nj= jpjglo)2303 & latvalue = real(RESHAPE(plat(Nis0:Nie0, Njs0:Nje0),(/ Ni_0*Nj_0 /)),dp)) 2304 CALL iom_set_zoom_domain_attr("ptr", ibegin=ix-1, jbegin=0, ni=1, nj=Nj_0) 2449 2305 ! 2450 2306 CALL iom_update_file_name('ptr') … … 2523 2379 ! Equatorial section (attributs: jbegin, ni, name_suffix) 2524 2380 CALL dom_ngb( 0.0_wp, 0.0_wp, ix, iy, cl1 ) 2525 CALL iom_set_zoom_domain_attr('Eq'//cl1, ibegin=0, jbegin=iy-1, ni= jpiglo, nj=1 )2381 CALL iom_set_zoom_domain_attr('Eq'//cl1, ibegin=0, jbegin=iy-1, ni=Ni0glo, nj=1 ) 2526 2382 CALL iom_get_file_attr ('Eq'//cl1, name_suffix = clsuff ) 2527 2383 CALL iom_set_file_attr ('Eq'//cl1, name_suffix = TRIM(clsuff)//'_Eq') -
NEMO/trunk/src/OCE/IOM/iom_def.F90
r13062 r13286 13 13 PRIVATE 14 14 15 INTEGER, PARAMETER, PUBLIC :: jpdom_data = 1 !: ( 1 :jpiglo, 1 :jpjglo) !!gm to be suppressed 16 INTEGER, PARAMETER, PUBLIC :: jpdom_global = 2 !: ( 1 :jpiglo, 1 :jpjglo) 17 INTEGER, PARAMETER, PUBLIC :: jpdom_local = 3 !: One of the 3 following cases 18 INTEGER, PARAMETER, PUBLIC :: jpdom_local_full = 4 !: ( 1 :jpi , 1 :jpi ) 19 INTEGER, PARAMETER, PUBLIC :: jpdom_local_noextra = 5 !: ( 1 :nlci , 1 :nlcj ) 20 INTEGER, PARAMETER, PUBLIC :: jpdom_local_noovlap = 6 !: (nldi:nlei ,nldj:nlej ) 21 INTEGER, PARAMETER, PUBLIC :: jpdom_unknown = 7 !: No dimension checking 22 INTEGER, PARAMETER, PUBLIC :: jpdom_autoglo = 8 !: 23 INTEGER, PARAMETER, PUBLIC :: jpdom_autoglo_xy = 9 !: Automatically set horizontal dimensions only 24 INTEGER, PARAMETER, PUBLIC :: jpdom_autodta = 10 !: 15 INTEGER, PARAMETER, PUBLIC :: jpdom_global = 1 !: ( 1 :Ni0glo, 1 :Nj0glo) 16 INTEGER, PARAMETER, PUBLIC :: jpdom_local = 2 !: (Nis0: Nie0 ,Njs0: Nje0 ) 17 INTEGER, PARAMETER, PUBLIC :: jpdom_unknown = 3 !: No dimension checking 18 INTEGER, PARAMETER, PUBLIC :: jpdom_auto = 4 !: 19 INTEGER, PARAMETER, PUBLIC :: jpdom_auto_xy = 5 !: Automatically set horizontal dimensions only 25 20 26 21 INTEGER, PARAMETER, PUBLIC :: jp_r8 = 200 !: write REAL(8) … … 35 30 INTEGER, PARAMETER, PUBLIC :: jpmax_digits = 9 !: maximum number of digits for the cpu number in the file name 36 31 37 38 32 !$AGRIF_DO_NOT_TREAT 39 33 INTEGER, PUBLIC :: iom_open_init = 0 !: used to initialize iom_file(:)%nfid to 0 … … 45 39 LOGICAL, PUBLIC :: lxios_sini = .FALSE. ! is restart in a single file 46 40 LOGICAL, PUBLIC :: lxios_set = .FALSE. 47 48 49 41 50 42 TYPE, PUBLIC :: file_descriptor -
NEMO/trunk/src/OCE/IOM/iom_nf90.F90
r13226 r13286 47 47 CONTAINS 48 48 49 SUBROUTINE iom_nf90_open( cdname, kiomid, ldwrt, ldok, kd ompar, kdlev, cdcomp )49 SUBROUTINE iom_nf90_open( cdname, kiomid, ldwrt, ldok, kdlev, cdcomp ) 50 50 !!--------------------------------------------------------------------- 51 51 !! *** SUBROUTINE iom_open *** … … 57 57 LOGICAL , INTENT(in ) :: ldwrt ! read or write the file? 58 58 LOGICAL , INTENT(in ) :: ldok ! check the existence 59 INTEGER, DIMENSION(2,5), INTENT(in ), OPTIONAL :: kdompar ! domain parameters:60 59 INTEGER , INTENT(in ), OPTIONAL :: kdlev ! size of the ice/abl third dimension 61 60 CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cdcomp ! name of component calling iom_nf90_open … … 134 133 CALL iom_nf90_check(NF90_SET_FILL( if90id, NF90_NOFILL, idmy ), clinfo) 135 134 ! define dimensions 136 CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'x', kdompar(1,1), idmy ), clinfo)137 CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'y', kdompar(2,1), idmy ), clinfo)135 CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'x', Ni_0, idmy ), clinfo) 136 CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'y', Nj_0, idmy ), clinfo) 138 137 SELECT CASE (clcomp) 139 CASE ('OCE') ; CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'nav_lev', 140 CASE ('ICE') ; CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'numcat', 141 CASE ('ABL') ; CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'nav_lev', 142 CASE ('SED') ; CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'numsed', 138 CASE ('OCE') ; CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'nav_lev', jpk, idmy ), clinfo) 139 CASE ('ICE') ; CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'numcat', kdlev, idmy ), clinfo) 140 CASE ('ABL') ; CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'nav_lev', kdlev, idmy ), clinfo) 141 CASE ('SED') ; CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'numsed', kdlev, idmy ), clinfo) 143 142 CASE DEFAULT ; CALL ctl_stop( 'iom_nf90_open unknown component type' ) 144 143 END SELECT 145 144 CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'time_counter', NF90_UNLIMITED, idmy ), clinfo) 146 145 ! global attributes 147 CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_number_total' , jpnij ), clinfo)148 CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_number' , narea-1 ), clinfo)149 CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_dimensions_ids' , (/ 1 , 2/) ), clinfo)150 CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_size_global' , (/ jpiglo, jpjglo/) ), clinfo)151 CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_size_local' , kdompar(:,1)), clinfo)152 CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_position_first' , kdompar(:,2)), clinfo)153 CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_position_last' , kdompar(:,3)), clinfo)154 CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_halo_size_start', kdompar(:,4)), clinfo)155 CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_halo_size_end' , kdompar(:,5)), clinfo)156 CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_type' , 'BOX' ), clinfo)146 CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_number_total' , jpnij ), clinfo) 147 CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_number' , narea-1 ), clinfo) 148 CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_dimensions_ids' , (/ 1 , 2 /) ), clinfo) 149 CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_size_global' , (/ Ni0glo , Nj0glo /) ), clinfo) 150 CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_size_local' , (/ Ni_0 , Nj_0 /) ), clinfo) 151 CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_position_first' , (/ mig0(Nis0), mjg0(Njs0) /) ), clinfo) 152 CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_position_last' , (/ mig0(Nie0), mjg0(Nje0) /) ), clinfo) 153 CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_halo_size_start', (/ 0 , 0 /) ), clinfo) 154 CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_halo_size_end' , (/ 0 , 0 /) ), clinfo) 155 CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_type' , 'BOX' ), clinfo) 157 156 ELSE !* the file should be open for read mode so it must exist... 158 157 CALL ctl_stop( TRIM(clinfo), ' should be impossible case...' ) … … 672 671 IF( PRESENT(pv_r2d) .OR. PRESENT(pv_r3d) ) THEN 673 672 idimsz(1:2) = iom_file(kiomid)%dimsz(1:2,idvar) 674 IF( idimsz(1) == (nlei - nldi + 1) .AND. idimsz(2) == (nlej - nldj + 1)) THEN675 ix1 = nldi ; ix2 = nlei ; iy1 = nldj ; iy2 = nlej676 ELSEIF( idimsz(1) == nlci .AND. idimsz(2) == nlcj) THEN677 ix1 = 1 ; ix2 = nlci ; iy1 = 1 ; iy2 = nlcj678 ELSEIF( idimsz(1) == jpi .AND. idimsz(2) == jpj) THEN673 IF( idimsz(1) == Ni_0 .AND. idimsz(2) == Nj_0 ) THEN 674 ix1 = Nis0 ; ix2 = Nie0 ; iy1 = Njs0 ; iy2 = Nje0 675 ELSEIF( idimsz(1) == jpi .AND. idimsz(2) == jpj ) THEN 676 ix1 = 1 ; ix2 = jpi ; iy1 = 1 ; iy2 = jpj 677 ELSEIF( idimsz(1) == jpi .AND. idimsz(2) == jpj ) THEN 679 678 ix1 = 1 ; ix2 = jpi ; iy1 = 1 ; iy2 = jpj 680 679 ELSE -
NEMO/trunk/src/OCE/IOM/prtctl.F90
r12377 r13286 8 8 !!---------------------------------------------------------------------- 9 9 USE dom_oce ! ocean space and time domain variables 10 #if defined key_nemocice_decomp11 USE ice_domain_size, only: nx_global, ny_global12 #endif13 10 USE in_out_manager ! I/O manager 11 USE mppini ! distributed memory computing 14 12 USE lib_mpp ! distributed memory computing 15 13 16 14 IMPLICIT NONE 17 15 PRIVATE 18 19 INTEGER , DIMENSION(:), ALLOCATABLE, SAVE :: numid 20 INTEGER , DIMENSION(:), ALLOCATABLE, SAVE :: nlditl , nldjtl ! first, last indoor index for each i-domain 21 INTEGER , DIMENSION(:), ALLOCATABLE, SAVE :: nleitl , nlejtl ! first, last indoor index for each j-domain 22 INTEGER , DIMENSION(:), ALLOCATABLE, SAVE :: nimpptl, njmpptl ! i-, j-indexes for each processor 23 INTEGER , DIMENSION(:), ALLOCATABLE, SAVE :: nlcitl , nlcjtl ! dimensions of every subdomain 24 INTEGER , DIMENSION(:), ALLOCATABLE, SAVE :: ibonitl, ibonjtl ! 25 26 REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: t_ctll , s_ctll ! previous tracer trend values 27 REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: u_ctll , v_ctll ! previous velocity trend values 28 29 INTEGER :: ktime ! time step 30 16 17 INTEGER , DIMENSION( :), ALLOCATABLE :: numprt_oce, numprt_top 18 INTEGER , DIMENSION( :), ALLOCATABLE :: nall_ictls, nall_ictle ! first, last indoor index for each i-domain 19 INTEGER , DIMENSION( :), ALLOCATABLE :: nall_jctls, nall_jctle ! first, last indoor index for each j-domain 20 REAL(wp), DIMENSION( :), ALLOCATABLE :: t_ctl , s_ctl ! previous tracer trend values 21 REAL(wp), DIMENSION( :), ALLOCATABLE :: u_ctl , v_ctl ! previous velocity trend values 22 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: tra_ctl ! previous top trend values 23 ! 31 24 PUBLIC prt_ctl ! called by all subroutines 32 25 PUBLIC prt_ctl_info ! called by all subroutines 33 PUBLIC prt_ctl_init ! called by opa.F90 34 PUBLIC sub_dom ! called by opa.F90 26 PUBLIC prt_ctl_init ! called by nemogcm.F90 and prt_ctl_trc_init 35 27 36 28 !!---------------------------------------------------------------------- … … 41 33 CONTAINS 42 34 43 SUBROUTINE prt_ctl (tab2d_1, tab3d_1, mask1, clinfo1, tab2d_2, tab3d_2, &44 & mask2, clinfo2, kdim, clinfo3)35 SUBROUTINE prt_ctl (tab2d_1, tab3d_1, tab4d_1, tab2d_2, tab3d_2, mask1, mask2, & 36 & clinfo, clinfo1, clinfo2, clinfo3, kdim ) 45 37 !!---------------------------------------------------------------------- 46 38 !! *** ROUTINE prt_ctl *** … … 68 60 !! tab2d_1 : first 2D array 69 61 !! tab3d_1 : first 3D array 62 !! tab4d_1 : first 4D array 70 63 !! mask1 : mask (3D) to apply to the tab[23]d_1 array 71 64 !! clinfo1 : information about the tab[23]d_1 array … … 77 70 !! clinfo3 : additional information 78 71 !!---------------------------------------------------------------------- 79 REAL(wp), DIMENSION(:,:) , INTENT(in), OPTIONAL :: tab2d_1 80 REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: tab3d_1 81 REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask1 82 CHARACTER (len=*) , INTENT(in), OPTIONAL :: clinfo1 83 REAL(wp), DIMENSION(:,:) , INTENT(in), OPTIONAL :: tab2d_2 84 REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: tab3d_2 85 REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask2 86 CHARACTER (len=*) , INTENT(in), OPTIONAL :: clinfo2 87 INTEGER , INTENT(in), OPTIONAL :: kdim 88 CHARACTER (len=*) , INTENT(in), OPTIONAL :: clinfo3 89 ! 90 CHARACTER (len=15) :: cl2 91 INTEGER :: jn, sind, eind, kdir,j_id 72 REAL(wp), DIMENSION(:,:) , INTENT(in), OPTIONAL :: tab2d_1 73 REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: tab3d_1 74 REAL(wp), DIMENSION(:,:,:,:), INTENT(in), OPTIONAL :: tab4d_1 75 REAL(wp), DIMENSION(:,:) , INTENT(in), OPTIONAL :: tab2d_2 76 REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: tab3d_2 77 REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: mask1 78 REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: mask2 79 CHARACTER(len=*), DIMENSION(:) , INTENT(in), OPTIONAL :: clinfo ! information about the tab3d array 80 CHARACTER(len=*) , INTENT(in), OPTIONAL :: clinfo1 81 CHARACTER(len=*) , INTENT(in), OPTIONAL :: clinfo2 82 CHARACTER(len=*) , INTENT(in), OPTIONAL :: clinfo3 83 INTEGER , INTENT(in), OPTIONAL :: kdim 84 ! 85 CHARACTER(len=30) :: cl1, cl2 86 INTEGER :: jn, jl, kdir 87 INTEGER :: iis, iie, jjs, jje 88 INTEGER :: itra, inum 92 89 REAL(wp) :: zsum1, zsum2, zvctl1, zvctl2 93 REAL(wp), DIMENSION(jpi,jpj) :: ztab2d_1, ztab2d_2 94 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask1, zmask2, ztab3d_1, ztab3d_2 95 !!---------------------------------------------------------------------- 96 90 !!---------------------------------------------------------------------- 91 ! 97 92 ! Arrays, scalars initialization 98 kdir = jpkm1 99 cl2 = '' 100 zsum1 = 0.e0 101 zsum2 = 0.e0 102 zvctl1 = 0.e0 103 zvctl2 = 0.e0 104 ztab2d_1(:,:) = 0.e0 105 ztab2d_2(:,:) = 0.e0 106 ztab3d_1(:,:,:) = 0.e0 107 ztab3d_2(:,:,:) = 0.e0 108 zmask1 (:,:,:) = 1.e0 109 zmask2 (:,:,:) = 1.e0 93 cl1 = '' 94 cl2 = '' 95 kdir = jpkm1 96 itra = 1 110 97 111 98 ! Control of optional arguments 112 IF( PRESENT(clinfo2) ) cl2 = clinfo2 113 IF( PRESENT(kdim) ) kdir = kdim 114 IF( PRESENT(tab2d_1) ) ztab2d_1(:,:) = tab2d_1(:,:) 115 IF( PRESENT(tab2d_2) ) ztab2d_2(:,:) = tab2d_2(:,:) 116 IF( PRESENT(tab3d_1) ) ztab3d_1(:,:,1:kdir) = tab3d_1(:,:,1:kdir) 117 IF( PRESENT(tab3d_2) ) ztab3d_2(:,:,1:kdir) = tab3d_2(:,:,1:kdir) 118 IF( PRESENT(mask1) ) zmask1 (:,:,:) = mask1 (:,:,:) 119 IF( PRESENT(mask2) ) zmask2 (:,:,:) = mask2 (:,:,:) 120 121 IF( lk_mpp .AND. jpnij > 1 ) THEN ! processor number 122 sind = narea 123 eind = narea 124 ELSE ! processors total number 125 sind = 1 126 eind = ijsplt 127 ENDIF 99 IF( PRESENT(clinfo1) ) cl1 = clinfo1 100 IF( PRESENT(clinfo2) ) cl2 = clinfo2 101 IF( PRESENT(kdim) ) kdir = kdim 102 IF( PRESENT(tab4d_1) ) itra = SIZE(tab4d_1,dim=4) 128 103 129 104 ! Loop over each sub-domain, i.e. the total number of processors ijsplt 130 DO jn = sind, eind 131 ! Set logical unit 132 j_id = numid(jn - narea + 1) 133 ! Set indices for the SUM control 134 IF( .NOT. lsp_area ) THEN 135 IF (lk_mpp .AND. jpnij > 1) THEN 136 nictls = MAX( 1, nlditl(jn) ) 137 nictle = MIN(jpi, nleitl(jn) ) 138 njctls = MAX( 1, nldjtl(jn) ) 139 njctle = MIN(jpj, nlejtl(jn) ) 140 ! Do not take into account the bound of the domain 141 IF( ibonitl(jn) == -1 .OR. ibonitl(jn) == 2 ) nictls = MAX(2, nictls) 142 IF( ibonjtl(jn) == -1 .OR. ibonjtl(jn) == 2 ) njctls = MAX(2, njctls) 143 IF( ibonitl(jn) == 1 .OR. ibonitl(jn) == 2 ) nictle = MIN(nictle, nleitl(jn) - 1) 144 IF( ibonjtl(jn) == 1 .OR. ibonjtl(jn) == 2 ) njctle = MIN(njctle, nlejtl(jn) - 1) 105 DO jl = 1, SIZE(nall_ictls) 106 107 ! define shoter names... 108 iis = nall_ictls(jl) 109 iie = nall_ictle(jl) 110 jjs = nall_jctls(jl) 111 jje = nall_jctle(jl) 112 113 IF( PRESENT(clinfo) ) THEN ; inum = numprt_top(jl) 114 ELSE ; inum = numprt_oce(jl) 115 ENDIF 116 117 DO jn = 1, itra 118 119 IF( PRESENT(clinfo3) ) THEN 120 IF ( clinfo3 == 'tra-ta' ) THEN 121 zvctl1 = t_ctl(jl) 122 ELSEIF( clinfo3 == 'tra' ) THEN 123 zvctl1 = t_ctl(jl) 124 zvctl2 = s_ctl(jl) 125 ELSEIF( clinfo3 == 'dyn' ) THEN 126 zvctl1 = u_ctl(jl) 127 zvctl2 = v_ctl(jl) 128 ELSE 129 zvctl1 = tra_ctl(jn,jl) 130 ENDIF 131 ENDIF 132 133 ! 2D arrays 134 IF( PRESENT(tab2d_1) ) THEN 135 IF( PRESENT(mask1) ) THEN ; zsum1 = SUM( tab2d_1(iis:iie,jjs:jje) * mask1(iis:iie,jjs:jje,1) ) 136 ELSE ; zsum1 = SUM( tab2d_1(iis:iie,jjs:jje) ) 137 ENDIF 138 ENDIF 139 IF( PRESENT(tab2d_2) ) THEN 140 IF( PRESENT(mask2) ) THEN ; zsum2 = SUM( tab2d_2(iis:iie,jjs:jje) * mask2(iis:iie,jjs:jje,1) ) 141 ELSE ; zsum2 = SUM( tab2d_2(iis:iie,jjs:jje) ) 142 ENDIF 143 ENDIF 144 145 ! 3D arrays 146 IF( PRESENT(tab3d_1) ) THEN 147 IF( PRESENT(mask1) ) THEN ; zsum1 = SUM( tab3d_1(iis:iie,jjs:jje,1:kdir) * mask1(iis:iie,jjs:jje,1:kdir) ) 148 ELSE ; zsum1 = SUM( tab3d_1(iis:iie,jjs:jje,1:kdir) ) 149 ENDIF 150 ENDIF 151 IF( PRESENT(tab3d_2) ) THEN 152 IF( PRESENT(mask2) ) THEN ; zsum2 = SUM( tab3d_2(iis:iie,jjs:jje,1:kdir) * mask2(iis:iie,jjs:jje,1:kdir) ) 153 ELSE ; zsum2 = SUM( tab3d_2(iis:iie,jjs:jje,1:kdir) ) 154 ENDIF 155 ENDIF 156 157 ! 4D arrays 158 IF( PRESENT(tab4d_1) ) THEN 159 IF( PRESENT(mask1) ) THEN ; zsum1 = SUM( tab4d_1(iis:iie,jjs:jje,1:kdir,jn) * mask1(iis:iie,jjs:jje,1:kdir) ) 160 ELSE ; zsum1 = SUM( tab4d_1(iis:iie,jjs:jje,1:kdir,jn) ) 161 ENDIF 162 ENDIF 163 164 ! Print the result 165 IF( PRESENT(clinfo ) ) cl1 = clinfo(jn) 166 IF( PRESENT(clinfo3) ) THEN 167 ! 168 IF( PRESENT(tab2d_2) .OR. PRESENT(tab3d_2) ) THEN 169 WRITE(inum, "(3x,a,' : ',D23.16,3x,a,' : ',D23.16)") cl1, zsum1 - zvctl1, cl2, zsum2 - zvctl2 170 ELSE 171 WRITE(inum, "(3x,a,' : ',D23.16 )") cl1, zsum1 - zvctl1 172 ENDIF 173 ! 174 SELECT CASE( clinfo3 ) 175 CASE ( 'tra-ta' ) 176 t_ctl(jl) = zsum1 177 CASE ( 'tra' ) 178 t_ctl(jl) = zsum1 179 s_ctl(jl) = zsum2 180 CASE ( 'dyn' ) 181 u_ctl(jl) = zsum1 182 v_ctl(jl) = zsum2 183 CASE default 184 tra_ctl(jn,jl) = zsum1 185 END SELECT 186 ELSEIF ( PRESENT(tab2d_2) .OR. PRESENT(tab3d_2) ) THEN 187 WRITE(inum, "(3x,a,' : ',D23.16,3x,a,' : ',D23.16)") cl1, zsum1, cl2, zsum2 145 188 ELSE 146 nictls = MAX( 1, nimpptl(jn) - 1 + nlditl(jn) ) 147 nictle = MIN(jpi, nimpptl(jn) - 1 + nleitl(jn) ) 148 njctls = MAX( 1, njmpptl(jn) - 1 + nldjtl(jn) ) 149 njctle = MIN(jpj, njmpptl(jn) - 1 + nlejtl(jn) ) 150 ! Do not take into account the bound of the domain 151 IF( ibonitl(jn) == -1 .OR. ibonitl(jn) == 2 ) nictls = MAX(2, nictls) 152 IF( ibonjtl(jn) == -1 .OR. ibonjtl(jn) == 2 ) njctls = MAX(2, njctls) 153 IF( ibonitl(jn) == 1 .OR. ibonitl(jn) == 2 ) nictle = MIN(nictle, nimpptl(jn) + nleitl(jn) - 2) 154 IF( ibonjtl(jn) == 1 .OR. ibonjtl(jn) == 2 ) njctle = MIN(njctle, njmpptl(jn) + nlejtl(jn) - 2) 155 ENDIF 156 ENDIF 157 158 IF( PRESENT(clinfo3)) THEN 159 IF ( clinfo3 == 'tra' ) THEN 160 zvctl1 = t_ctll(jn) 161 zvctl2 = s_ctll(jn) 162 ELSEIF ( clinfo3 == 'dyn' ) THEN 163 zvctl1 = u_ctll(jn) 164 zvctl2 = v_ctll(jn) 165 ENDIF 166 ENDIF 167 168 ! Compute the sum control 169 ! 2D arrays 170 IF( PRESENT(tab2d_1) ) THEN 171 zsum1 = SUM( ztab2d_1(nictls:nictle,njctls:njctle)*zmask1(nictls:nictle,njctls:njctle,1) ) 172 zsum2 = SUM( ztab2d_2(nictls:nictle,njctls:njctle)*zmask2(nictls:nictle,njctls:njctle,1) ) 173 ENDIF 174 175 ! 3D arrays 176 IF( PRESENT(tab3d_1) ) THEN 177 zsum1 = SUM( ztab3d_1(nictls:nictle,njctls:njctle,1:kdir)*zmask1(nictls:nictle,njctls:njctle,1:kdir) ) 178 zsum2 = SUM( ztab3d_2(nictls:nictle,njctls:njctle,1:kdir)*zmask2(nictls:nictle,njctls:njctle,1:kdir) ) 179 ENDIF 180 181 ! Print the result 182 IF( PRESENT(clinfo3) ) THEN 183 WRITE(j_id,FMT='(a,D23.16,3x,a,D23.16)')clinfo1, zsum1-zvctl1, cl2, zsum2-zvctl2 184 SELECT CASE( clinfo3 ) 185 CASE ( 'tra-ta' ) 186 t_ctll(jn) = zsum1 187 CASE ( 'tra' ) 188 t_ctll(jn) = zsum1 189 s_ctll(jn) = zsum2 190 CASE ( 'dyn' ) 191 u_ctll(jn) = zsum1 192 v_ctll(jn) = zsum2 193 END SELECT 194 ELSEIF ( PRESENT(clinfo2) .OR. PRESENT(tab2d_2) .OR. PRESENT(tab3d_2) ) THEN 195 WRITE(j_id,FMT='(a,D23.16,3x,a,D23.16)')clinfo1, zsum1, cl2, zsum2 196 ELSE 197 WRITE(j_id,FMT='(a,D23.16)')clinfo1, zsum1 198 ENDIF 199 200 ENDDO 201 ! 202 END SUBROUTINE prt_ctl 203 204 205 SUBROUTINE prt_ctl_info (clinfo1, ivar1, clinfo2, ivar2, itime) 206 !!---------------------------------------------------------------------- 207 !! *** ROUTINE prt_ctl_info *** 208 !! 209 !! ** Purpose : - print information without any computation 210 !! 211 !! ** Action : - input arguments 212 !! clinfo1 : information about the ivar1 213 !! ivar1 : value to print 214 !! clinfo2 : information about the ivar2 215 !! ivar2 : value to print 216 !!---------------------------------------------------------------------- 217 CHARACTER (len=*), INTENT(in) :: clinfo1 218 INTEGER , INTENT(in), OPTIONAL :: ivar1 219 CHARACTER (len=*), INTENT(in), OPTIONAL :: clinfo2 220 INTEGER , INTENT(in), OPTIONAL :: ivar2 221 INTEGER , INTENT(in), OPTIONAL :: itime 222 ! 223 INTEGER :: jn, sind, eind, iltime, j_id 224 !!---------------------------------------------------------------------- 225 226 IF( lk_mpp .AND. jpnij > 1 ) THEN ! processor number 227 sind = narea 228 eind = narea 229 ELSE ! total number of processors 230 sind = 1 231 eind = ijsplt 232 ENDIF 233 234 ! Set to zero arrays at each new time step 235 IF( PRESENT(itime) ) THEN 236 iltime = itime 237 IF( iltime > ktime ) THEN 238 t_ctll(:) = 0.e0 ; s_ctll(:) = 0.e0 239 u_ctll(:) = 0.e0 ; v_ctll(:) = 0.e0 240 ktime = iltime 241 ENDIF 242 ENDIF 243 244 ! Loop over each sub-domain, i.e. number of processors ijsplt 245 DO jn = sind, eind 246 ! 247 j_id = numid(jn - narea + 1) ! Set logical unit 248 ! 249 IF( PRESENT(ivar1) .AND. PRESENT(clinfo2) .AND. PRESENT(ivar2) ) THEN 250 WRITE(j_id,*)clinfo1, ivar1, clinfo2, ivar2 251 ELSEIF ( PRESENT(ivar1) .AND. PRESENT(clinfo2) .AND. .NOT. PRESENT(ivar2) ) THEN 252 WRITE(j_id,*)clinfo1, ivar1, clinfo2 253 ELSEIF ( PRESENT(ivar1) .AND. .NOT. PRESENT(clinfo2) .AND. PRESENT(ivar2) ) THEN 254 WRITE(j_id,*)clinfo1, ivar1, ivar2 255 ELSEIF ( PRESENT(ivar1) .AND. .NOT. PRESENT(clinfo2) .AND. .NOT. PRESENT(ivar2) ) THEN 256 WRITE(j_id,*)clinfo1, ivar1 257 ELSE 258 WRITE(j_id,*)clinfo1 259 ENDIF 260 ! 261 END DO 262 ! 263 END SUBROUTINE prt_ctl_info 264 265 266 SUBROUTINE prt_ctl_init 267 !!---------------------------------------------------------------------- 268 !! *** ROUTINE prt_ctl_init *** 269 !! 270 !! ** Purpose : open ASCII files & compute indices 271 !!---------------------------------------------------------------------- 272 INTEGER :: jn, sind, eind, j_id 273 CHARACTER (len=28) :: clfile_out 274 CHARACTER (len=23) :: clb_name 275 CHARACTER (len=19) :: cl_run 276 !!---------------------------------------------------------------------- 277 278 ! Allocate arrays 279 ALLOCATE( nlditl(ijsplt) , nleitl(ijsplt) , nimpptl(ijsplt) , ibonitl(ijsplt) , & 280 & nldjtl(ijsplt) , nlejtl(ijsplt) , njmpptl(ijsplt) , ibonjtl(ijsplt) , & 281 & nlcitl(ijsplt) , t_ctll(ijsplt) , u_ctll (ijsplt) , & 282 & nlcjtl(ijsplt) , s_ctll(ijsplt) , v_ctll (ijsplt) ) 283 284 ! Initialization 285 t_ctll(:) = 0.e0 286 s_ctll(:) = 0.e0 287 u_ctll(:) = 0.e0 288 v_ctll(:) = 0.e0 289 ktime = 1 290 291 IF( lk_mpp .AND. jpnij > 1 ) THEN 292 sind = narea 293 eind = narea 294 clb_name = "('mpp.output_',I4.4)" 295 cl_run = 'MULTI processor run' 296 ! use indices for each area computed by mpp_init subroutine 297 nlditl(1:jpnij) = nldit(:) 298 nleitl(1:jpnij) = nleit(:) 299 nldjtl(1:jpnij) = nldjt(:) 300 nlejtl(1:jpnij) = nlejt(:) 301 ! 302 nimpptl(1:jpnij) = nimppt(:) 303 njmpptl(1:jpnij) = njmppt(:) 304 ! 305 nlcitl(1:jpnij) = nlcit(:) 306 nlcjtl(1:jpnij) = nlcjt(:) 307 ! 308 ibonitl(1:jpnij) = ibonit(:) 309 ibonjtl(1:jpnij) = ibonjt(:) 310 ELSE 311 sind = 1 312 eind = ijsplt 313 clb_name = "('mono.output_',I4.4)" 314 cl_run = 'MONO processor run ' 315 ! compute indices for each area as done in mpp_init subroutine 316 CALL sub_dom 317 ENDIF 318 319 ALLOCATE( numid(eind-sind+1) ) 320 321 DO jn = sind, eind 322 WRITE(clfile_out,FMT=clb_name) jn-1 323 CALL ctl_opn( numid(jn -narea + 1), clfile_out, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', 1, numout, .FALSE. ) 324 j_id = numid(jn -narea + 1) 325 WRITE(j_id,*) 326 WRITE(j_id,*) ' L O D Y C - I P S L' 327 WRITE(j_id,*) ' O P A model' 328 WRITE(j_id,*) ' Ocean General Circulation Model' 329 WRITE(j_id,*) ' version OPA 9.0 (2005) ' 330 WRITE(j_id,*) 331 WRITE(j_id,*) ' PROC number: ', jn 332 WRITE(j_id,*) 333 WRITE(j_id,FMT="(19x,a20)")cl_run 334 335 ! Print the SUM control indices 336 IF( .NOT. lsp_area ) THEN 337 nictls = nimpptl(jn) + nlditl(jn) - 1 338 nictle = nimpptl(jn) + nleitl(jn) - 1 339 njctls = njmpptl(jn) + nldjtl(jn) - 1 340 njctle = njmpptl(jn) + nlejtl(jn) - 1 341 ENDIF 342 WRITE(j_id,*) 343 WRITE(j_id,*) 'prt_ctl : Sum control indices' 344 WRITE(j_id,*) '~~~~~~~' 345 WRITE(j_id,*) 346 WRITE(j_id,9000)' nlej = ', nlejtl(jn), ' ' 347 WRITE(j_id,9000)' ------------- njctle = ', njctle, ' -------------' 348 WRITE(j_id,9001)' | |' 349 WRITE(j_id,9001)' | |' 350 WRITE(j_id,9001)' | |' 351 WRITE(j_id,9002)' nictls = ', nictls, ' nictle = ', nictle 352 WRITE(j_id,9002)' nldi = ', nlditl(jn), ' nlei = ', nleitl(jn) 353 WRITE(j_id,9001)' | |' 354 WRITE(j_id,9001)' | |' 355 WRITE(j_id,9001)' | |' 356 WRITE(j_id,9004)' njmpp = ',njmpptl(jn),' ------------- njctls = ', njctls, ' -------------' 357 WRITE(j_id,9003)' nimpp = ', nimpptl(jn), ' nldj = ', nldjtl(jn), ' ' 358 WRITE(j_id,*) 359 WRITE(j_id,*) 360 361 9000 FORMAT(a41,i4.4,a14) 362 9001 FORMAT(a59) 363 9002 FORMAT(a20,i4.4,a36,i3.3) 364 9003 FORMAT(a20,i4.4,a17,i4.4) 365 9004 FORMAT(a11,i4.4,a26,i4.4,a14) 366 END DO 367 ! 368 END SUBROUTINE prt_ctl_init 369 370 371 SUBROUTINE sub_dom 372 !!---------------------------------------------------------------------- 373 !! *** ROUTINE sub_dom *** 374 !! 375 !! ** Purpose : Lay out the global domain over processors. 376 !! CAUTION: 377 !! This part has been extracted from the mpp_init 378 !! subroutine and names of variables/arrays have been 379 !! slightly changed to avoid confusion but the computation 380 !! is exactly the same. Any modification about indices of 381 !! each sub-domain in the mppini.F90 module should be reported 382 !! here. 383 !! 384 !! ** Method : Global domain is distributed in smaller local domains. 385 !! Periodic condition is a function of the local domain position 386 !! (global boundary or neighbouring domain) and of the global 387 !! periodic 388 !! Type : jperio global periodic condition 389 !! 390 !! ** Action : - set domain parameters 391 !! nimpp : longitudinal index 392 !! njmpp : latitudinal index 393 !! narea : number for local area 394 !! nlcil : first dimension 395 !! nlcjl : second dimension 396 !! nbondil : mark for "east-west local boundary" 397 !! nbondjl : mark for "north-south local boundary" 398 !! 399 !! History : 400 !! ! 94-11 (M. Guyon) Original code 401 !! ! 95-04 (J. Escobar, M. Imbard) 402 !! ! 98-02 (M. Guyon) FETI method 403 !! ! 98-05 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI versions 404 !! 8.5 ! 02-08 (G. Madec) F90 : free form 405 !!---------------------------------------------------------------------- 406 INTEGER :: ji, jj, jn ! dummy loop indices 407 INTEGER :: & 408 ii, ij, & ! temporary integers 409 irestil, irestjl, & ! " " 410 ijpi , ijpj, nlcil, & ! temporary logical unit 411 nlcjl , nbondil, nbondjl, & 412 nrecil, nrecjl, nldil, nleil, nldjl, nlejl 413 414 INTEGER, DIMENSION(jpi,jpj) :: iimpptl, ijmpptl, ilcitl, ilcjtl ! workspace 415 REAL(wp) :: zidom, zjdom ! temporary scalars 416 INTEGER :: inum ! local logical unit 417 !!---------------------------------------------------------------------- 418 419 ! 420 ! 421 ! 1. Dimension arrays for subdomains 422 ! ----------------------------------- 423 ! Computation of local domain sizes ilcitl() ilcjtl() 424 ! These dimensions depend on global sizes isplt,jsplt and jpiglo,jpjglo 425 ! The subdomains are squares leeser than or equal to the global 426 ! dimensions divided by the number of processors minus the overlap 427 ! array (cf. par_oce.F90). 428 429 #if defined key_nemocice_decomp 430 ijpi = ( nx_global+2-2*nn_hls + (isplt-1) ) / isplt + 2*nn_hls 431 ijpj = ( ny_global+2-2*nn_hls + (jsplt-1) ) / jsplt + 2*nn_hls 432 #else 433 ijpi = ( jpiglo-2*nn_hls + (isplt-1) ) / isplt + 2*nn_hls 434 ijpj = ( jpjglo-2*nn_hls + (jsplt-1) ) / jsplt + 2*nn_hls 435 #endif 436 437 438 nrecil = 2 * nn_hls 439 nrecjl = 2 * nn_hls 440 irestil = MOD( jpiglo - nrecil , isplt ) 441 irestjl = MOD( jpjglo - nrecjl , jsplt ) 442 443 IF( irestil == 0 ) irestil = isplt 444 #if defined key_nemocice_decomp 445 446 ! In order to match CICE the size of domains in NEMO has to be changed 447 ! The last line of blocks (west) will have fewer points 448 DO jj = 1, jsplt 449 DO ji=1, isplt-1 450 ilcitl(ji,jj) = ijpi 451 END DO 452 ilcitl(isplt,jj) = jpiglo - (isplt - 1) * (ijpi - nrecil) 453 END DO 454 455 #else 456 457 DO jj = 1, jsplt 458 DO ji = 1, irestil 459 ilcitl(ji,jj) = ijpi 460 END DO 461 DO ji = irestil+1, isplt 462 ilcitl(ji,jj) = ijpi -1 189 WRITE(inum, "(3x,a,' : ',D23.16 )") cl1, zsum1 190 ENDIF 191 463 192 END DO 464 193 END DO 465 466 #endif 467 468 IF( irestjl == 0 ) irestjl = jsplt 469 #if defined key_nemocice_decomp 470 471 ! Same change to domains in North-South direction as in East-West. 472 DO ji = 1, isplt 473 DO jj=1, jsplt-1 474 ilcjtl(ji,jj) = ijpj 475 END DO 476 ilcjtl(ji,jsplt) = jpjglo - (jsplt - 1) * (ijpj - nrecjl) 477 END DO 478 479 #else 480 481 DO ji = 1, isplt 482 DO jj = 1, irestjl 483 ilcjtl(ji,jj) = ijpj 484 END DO 485 DO jj = irestjl+1, jsplt 486 ilcjtl(ji,jj) = ijpj -1 487 END DO 194 ! 195 END SUBROUTINE prt_ctl 196 197 198 SUBROUTINE prt_ctl_info (clinfo, ivar, cdcomp ) 199 !!---------------------------------------------------------------------- 200 !! *** ROUTINE prt_ctl_info *** 201 !! 202 !! ** Purpose : - print information without any computation 203 !! 204 !! ** Action : - input arguments 205 !! clinfo : information about the ivar 206 !! ivar : value to print 207 !!---------------------------------------------------------------------- 208 CHARACTER(len=*), INTENT(in) :: clinfo 209 INTEGER , OPTIONAL, INTENT(in) :: ivar 210 CHARACTER(len=3), OPTIONAL, INTENT(in) :: cdcomp ! only 'top' is accepted 211 ! 212 CHARACTER(len=3) :: clcomp 213 INTEGER :: jl, inum 214 !!---------------------------------------------------------------------- 215 ! 216 IF( PRESENT(cdcomp) ) THEN ; clcomp = cdcomp 217 ELSE ; clcomp = 'oce' 218 ENDIF 219 ! 220 DO jl = 1, SIZE(nall_ictls) 221 ! 222 IF( clcomp == 'oce' ) inum = numprt_oce(jl) 223 IF( clcomp == 'top' ) inum = numprt_top(jl) 224 ! 225 IF ( PRESENT(ivar) ) THEN ; WRITE(inum,*) clinfo, ivar 226 ELSE ; WRITE(inum,*) clinfo 227 ENDIF 228 ! 488 229 END DO 489 490 #endif 491 zidom = nrecil 492 DO ji = 1, isplt 493 zidom = zidom + ilcitl(ji,1) - nrecil 230 ! 231 END SUBROUTINE prt_ctl_info 232 233 234 SUBROUTINE prt_ctl_init( cdcomp, kntra ) 235 !!---------------------------------------------------------------------- 236 !! *** ROUTINE prt_ctl_init *** 237 !! 238 !! ** Purpose : open ASCII files & compute indices 239 !!---------------------------------------------------------------------- 240 CHARACTER(len=3), OPTIONAL, INTENT(in ) :: cdcomp ! only 'top' is accepted 241 INTEGER , OPTIONAL, INTENT(in ) :: kntra ! only for 'top': number of tracers 242 ! 243 INTEGER :: ji, jj, jl 244 INTEGER :: inum, idg, idg2 245 INTEGER :: ijsplt, iimax, ijmax 246 INTEGER, DIMENSION(:,:), ALLOCATABLE :: iimppt, ijmppt, ijpi, ijpj, iproc 247 INTEGER, DIMENSION( :), ALLOCATABLE :: iipos, ijpos 248 LOGICAL, DIMENSION(:,:), ALLOCATABLE :: llisoce 249 CHARACTER(len=64) :: clfile_out 250 CHARACTER(LEN=64) :: clfmt, clfmt2, clfmt3, clfmt4 251 CHARACTER(len=32) :: clname, cl_run 252 CHARACTER(len= 3) :: clcomp 253 !!---------------------------------------------------------------------- 254 ! 255 clname = 'output' 256 IF( PRESENT(cdcomp) ) THEN 257 clname = TRIM(clname)//'.'//TRIM(cdcomp) 258 clcomp = cdcomp 259 ELSE 260 clcomp = 'oce' 261 ENDIF 262 ! 263 IF( jpnij > 1 ) THEN ! MULTI processor run 264 cl_run = 'MULTI processor run' 265 idg = MAX( INT(LOG10(REAL(MAX(1,jpnij-1),wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 266 WRITE(clfmt, "('(a,i', i1, '.', i1, ')')") idg, idg ! '(a,ix.x)' 267 WRITE(clfile_out,clfmt) 'mpp.'//trim(clname)//'_', narea - 1 268 ijsplt = 1 269 ELSE ! MONO processor run 270 cl_run = 'MONO processor run ' 271 IF(lwp) THEN ! control print 272 WRITE(numout,*) 273 WRITE(numout,*) 'prt_ctl_init: sn_cfctl%l_prtctl parameters' 274 WRITE(numout,*) '~~~~~~~~~~~~~' 275 ENDIF 276 IF( nn_ictls+nn_ictle+nn_jctls+nn_jctle == 0 ) THEN ! print control done over the default area 277 nn_isplt = MAX(1, nn_isplt) ! number of processors following i-direction 278 nn_jsplt = MAX(1, nn_jsplt) ! number of processors following j-direction 279 ijsplt = nn_isplt * nn_jsplt ! total number of processors ijsplt 280 IF( ijsplt == 1 ) CALL ctl_warn( 'nn_isplt & nn_jsplt are equal to 1 -> control sum done over the whole domain' ) 281 IF(lwp) WRITE(numout,*) ' number of proc. following i nn_isplt = ', nn_isplt 282 IF(lwp) WRITE(numout,*) ' number of proc. following j nn_jsplt = ', nn_jsplt 283 idg = MAX( INT(LOG10(REAL(MAX(1,ijsplt-1),wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 284 WRITE(clfmt, "('(a,i', i1, '.', i1, ')')") idg, idg ! '(a,ix.x)' 285 IF( ijsplt == 1 ) WRITE(clfile_out,clfmt) 'mono.'//trim(clname)//'_', 0 286 ELSE ! print control done over a specific area 287 ijsplt = 1 288 IF( nn_ictls < 1 .OR. nn_ictls > Ni0glo ) THEN 289 CALL ctl_warn( ' - nictls must be 1<=nictls>=Ni0glo, it is forced to 1' ) 290 nn_ictls = 1 291 ENDIF 292 IF( nn_ictle < 1 .OR. nn_ictle > Ni0glo ) THEN 293 CALL ctl_warn( ' - nictle must be 1<=nictle>=Ni0glo, it is forced to Ni0glo' ) 294 nn_ictle = Ni0glo 295 ENDIF 296 IF( nn_jctls < 1 .OR. nn_jctls > Nj0glo ) THEN 297 CALL ctl_warn( ' - njctls must be 1<=njctls>=Nj0glo, it is forced to 1' ) 298 nn_jctls = 1 299 ENDIF 300 IF( nn_jctle < 1 .OR. nn_jctle > Nj0glo ) THEN 301 CALL ctl_warn( ' - njctle must be 1<=njctle>=Nj0glo, it is forced to Nj0glo' ) 302 nn_jctle = Nj0glo 303 ENDIF 304 WRITE(numout,*) ' Start i indice for SUM control nn_ictls = ', nn_ictls 305 WRITE(numout,*) ' End i indice for SUM control nn_ictle = ', nn_ictle 306 WRITE(numout,*) ' Start j indice for SUM control nn_jctls = ', nn_jctls 307 WRITE(numout,*) ' End j indice for SUM control nn_jctle = ', nn_jctle 308 idg = MAXVAL( (/ nn_ictls,nn_ictle,nn_jctls,nn_jctle /) ) ! temporary use of idg to store the largest index 309 idg = MAX( INT(LOG10(REAL(idg,wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 310 WRITE(clfmt, "('(4(a,i', i1, '.', i1, '))')") idg, idg ! '(4(a,ix.x))' 311 WRITE(clfile_out,clfmt) 'mono.'//trim(clname)//'_', nn_ictls, '_', nn_ictle, '_', nn_jctls, '_', nn_jctle 312 ENDIF 313 ENDIF 314 315 ! Allocate arrays 316 IF( .NOT. ALLOCATED(nall_ictls) ) ALLOCATE( nall_ictls(ijsplt), nall_ictle(ijsplt), nall_jctls(ijsplt), nall_jctle(ijsplt) ) 317 318 IF( jpnij > 1 ) THEN ! MULTI processor run 319 ! 320 nall_ictls(1) = Nis0 321 nall_ictle(1) = Nie0 322 nall_jctls(1) = Njs0 323 nall_jctle(1) = Nje0 324 ! 325 ELSE ! MONO processor run 326 ! 327 IF( nn_ictls+nn_ictle+nn_jctls+nn_jctle == 0 ) THEN ! print control done over the default area 328 ! 329 ALLOCATE( iimppt(nn_isplt,nn_jsplt), ijmppt(nn_isplt,nn_jsplt), ijpi(nn_isplt,nn_jsplt), ijpj(nn_isplt,nn_jsplt), & 330 & llisoce(nn_isplt,nn_jsplt), iproc(nn_isplt,nn_jsplt), iipos(nn_isplt*nn_jsplt), ijpos(nn_isplt*nn_jsplt) ) 331 CALL mpp_basesplit( jpiglo, jpjglo, nn_hls, nn_isplt, nn_jsplt, iimax, ijmax, iimppt, ijmppt, ijpi, ijpj ) 332 CALL mpp_is_ocean( llisoce ) 333 CALL mpp_getnum( llisoce, iproc, iipos, ijpos ) 334 ! 335 DO jj = 1,nn_jsplt 336 DO ji = 1, nn_isplt 337 jl = iproc(ji,jj) + 1 338 nall_ictls(jl) = iimppt(ji,jj) - 1 + 1 + nn_hls 339 nall_ictle(jl) = iimppt(ji,jj) - 1 + ijpi(ji,jj) - nn_hls 340 nall_jctls(jl) = ijmppt(ji,jj) - 1 + 1 + nn_hls 341 nall_jctle(jl) = ijmppt(ji,jj) - 1 + ijpj(ji,jj) - nn_hls 342 END DO 343 END DO 344 ! 345 DEALLOCATE( iimppt, ijmppt, ijpi, ijpj, llisoce, iproc, iipos, ijpos ) 346 ! 347 ELSE ! print control done over a specific area 348 ! 349 nall_ictls(1) = nn_ictls + nn_hls 350 nall_ictle(1) = nn_ictle + nn_hls 351 nall_jctls(1) = nn_jctls + nn_hls 352 nall_jctle(1) = nn_jctle + nn_hls 353 ! 354 ENDIF 355 ENDIF 356 357 ! Initialization 358 IF( clcomp == 'oce' ) THEN 359 ALLOCATE( t_ctl(ijsplt), s_ctl(ijsplt), u_ctl(ijsplt), v_ctl(ijsplt), numprt_oce(ijsplt) ) 360 t_ctl(:) = 0.e0 361 s_ctl(:) = 0.e0 362 u_ctl(:) = 0.e0 363 v_ctl(:) = 0.e0 364 ENDIF 365 IF( clcomp == 'top' ) THEN 366 ALLOCATE( tra_ctl(kntra,ijsplt), numprt_top(ijsplt) ) 367 tra_ctl(:,:) = 0.e0 368 ENDIF 369 370 DO jl = 1,ijsplt 371 372 IF( ijsplt > 1 ) WRITE(clfile_out,clfmt) 'mono.'//trim(clname)//'_', jl-1 373 374 CALL ctl_opn( inum, clfile_out, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', 1, numout, .FALSE. ) 375 IF( clcomp == 'oce' ) numprt_oce(jl) = inum 376 IF( clcomp == 'top' ) numprt_top(jl) = inum 377 WRITE(inum,*) 378 WRITE(inum,*) ' CNRS - NERC - Met OFFICE - MERCATOR-ocean - CMCC' 379 WRITE(inum,*) ' NEMO team' 380 WRITE(inum,*) ' Ocean General Circulation Model' 381 IF( clcomp == 'oce' ) WRITE(inum,*) ' NEMO version 4.x (2020) ' 382 IF( clcomp == 'top' ) WRITE(inum,*) ' TOP vversion x (2020) ' 383 WRITE(inum,*) 384 IF( ijsplt > 1 ) & 385 & WRITE(inum,*) ' MPI-subdomain number: ', jl-1 386 IF( jpnij > 1 ) & 387 & WRITE(inum,*) ' MPI-subdomain number: ', narea-1 388 WRITE(inum,*) 389 WRITE(inum,'(19x,a20)') cl_run 390 WRITE(inum,*) 391 WRITE(inum,*) 'prt_ctl : Sum control indices' 392 WRITE(inum,*) '~~~~~~~' 393 WRITE(inum,*) 394 ! 395 ! clfmt2: ' ----- jctle = XXX (YYY) -----' -> '(18x, 13a1, a9, iM, a2, iN, a2, 13a1)' 396 ! clfmt3: ' | |' -> '(18x, a1, Nx, a1)' 397 ! clfmt4: ' ictls = XXX (YYY) ictle = XXX (YYY)' -> '(Nx, a9, iM, a2, iP, a2, Qx, a9, iM, a2, iP, a2)' 398 ! ' | |' 399 ! ' ----- jctle = XXX (YYY) -----' 400 ! clfmt5: ' njmpp = XXX' -> '(Nx, a9, iM)' 401 ! clfmt6: ' nimpp = XXX' -> '(Nx, a9, iM)' 402 ! 403 idg = MAXVAL( (/ nall_ictls(jl), nall_ictle(jl), nall_jctls(jl), nall_jctle(jl) /) ) ! temporary use of idg 404 idg = INT(LOG10(REAL(idg,wp))) + 1 ! how many digits do we use? 405 idg2 = MAXVAL( (/ mig0(nall_ictls(jl)), mig0(nall_ictle(jl)), mjg0(nall_jctls(jl)), mjg0(nall_jctle(jl)) /) ) 406 idg2 = INT(LOG10(REAL(idg2,wp))) + 1 ! how many digits do we use? 407 WRITE(clfmt2, "('(18x, 13a1, a9, i', i1, ', a2, i',i1,', a2, 13a1)')") idg, idg2 408 WRITE(clfmt3, "('(18x, a1, ', i2,'x, a1)')") 13+9+idg+2+idg2+2+13 - 2 409 WRITE(clfmt4, "('(', i2,'x, a9, i', i1,', a2, i', i1,', a2, ', i2,'x, a9, i', i1,', a2, i', i1,', a2)')") & 410 & 18-7, idg, idg2, 13+9+idg+2+idg2+2+13 - (2+idg+2+idg2+2+8), idg, idg2 411 WRITE(inum,clfmt2) ('-', ji=1,13), ' jctle = ', nall_jctle(jl), ' (', mjg0(nall_jctle(jl)), ') ', ('-', ji=1,13) 412 WRITE(inum,clfmt3) '|', '|' 413 WRITE(inum,clfmt3) '|', '|' 414 WRITE(inum,clfmt3) '|', '|' 415 WRITE(inum,clfmt4) ' ictls = ', nall_ictls(jl), ' (', mig0(nall_ictls(jl)), ') ', & 416 & ' ictle = ', nall_ictle(jl), ' (', mig0(nall_ictle(jl)), ') ' 417 WRITE(inum,clfmt3) '|', '|' 418 WRITE(inum,clfmt3) '|', '|' 419 WRITE(inum,clfmt3) '|', '|' 420 WRITE(inum,clfmt2) ('-', ji=1,13), ' jctls = ', nall_jctls(jl), ' (', mjg0(nall_jctls(jl)), ') ', ('-', ji=1,13) 421 WRITE(inum,*) 422 WRITE(inum,*) 423 ! 494 424 END DO 495 IF(lwp) WRITE(numout,*) 496 IF(lwp) WRITE(numout,*)' sum ilcitl(i,1) = ', zidom, ' jpiglo = ', jpiglo 497 498 zjdom = nrecjl 499 DO jj = 1, jsplt 500 zjdom = zjdom + ilcjtl(1,jj) - nrecjl 501 END DO 502 IF(lwp) WRITE(numout,*)' sum ilcitl(1,j) = ', zjdom, ' jpjglo = ', jpjglo 503 IF(lwp) WRITE(numout,*) 504 505 506 ! 2. Index arrays for subdomains 507 ! ------------------------------- 508 509 iimpptl(:,:) = 1 510 ijmpptl(:,:) = 1 511 512 IF( isplt > 1 ) THEN 513 DO jj = 1, jsplt 514 DO ji = 2, isplt 515 iimpptl(ji,jj) = iimpptl(ji-1,jj) + ilcitl(ji-1,jj) - nrecil 516 END DO 517 END DO 518 ENDIF 519 520 IF( jsplt > 1 ) THEN 521 DO jj = 2, jsplt 522 DO ji = 1, isplt 523 ijmpptl(ji,jj) = ijmpptl(ji,jj-1)+ilcjtl(ji,jj-1)-nrecjl 524 END DO 525 END DO 526 ENDIF 527 528 ! 3. Subdomain description 529 ! ------------------------ 530 531 DO jn = 1, ijsplt 532 ii = 1 + MOD( jn-1, isplt ) 533 ij = 1 + (jn-1) / isplt 534 nimpptl(jn) = iimpptl(ii,ij) 535 njmpptl(jn) = ijmpptl(ii,ij) 536 nlcitl (jn) = ilcitl (ii,ij) 537 nlcil = nlcitl (jn) 538 nlcjtl (jn) = ilcjtl (ii,ij) 539 nlcjl = nlcjtl (jn) 540 nbondjl = -1 ! general case 541 IF( jn > isplt ) nbondjl = 0 ! first row of processor 542 IF( jn > (jsplt-1)*isplt ) nbondjl = 1 ! last row of processor 543 IF( jsplt == 1 ) nbondjl = 2 ! one processor only in j-direction 544 ibonjtl(jn) = nbondjl 545 546 nbondil = 0 ! 547 IF( MOD( jn, isplt ) == 1 ) nbondil = -1 ! 548 IF( MOD( jn, isplt ) == 0 ) nbondil = 1 ! 549 IF( isplt == 1 ) nbondil = 2 ! one processor only in i-direction 550 ibonitl(jn) = nbondil 551 552 nldil = 1 + nn_hls 553 nleil = nlcil - nn_hls 554 IF( nbondil == -1 .OR. nbondil == 2 ) nldil = 1 555 IF( nbondil == 1 .OR. nbondil == 2 ) nleil = nlcil 556 nldjl = 1 + nn_hls 557 nlejl = nlcjl - nn_hls 558 IF( nbondjl == -1 .OR. nbondjl == 2 ) nldjl = 1 559 IF( nbondjl == 1 .OR. nbondjl == 2 ) nlejl = nlcjl 560 nlditl(jn) = nldil 561 nleitl(jn) = nleil 562 nldjtl(jn) = nldjl 563 nlejtl(jn) = nlejl 564 END DO 565 ! 566 ! Save processor layout in layout_prtctl.dat file 567 IF(lwp) THEN 568 CALL ctl_opn( inum, 'layout_prtctl.dat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea ) 569 WRITE(inum,'(a)') 'nproc nlcil nlcjl nldil nldjl nleil nlejl nimpptl njmpptl ibonitl ibonjtl' 570 ! 571 DO jn = 1, ijsplt 572 WRITE(inum,'(i5,6i6,4i8)') jn-1,nlcitl(jn), nlcjtl(jn), & 573 & nlditl(jn), nldjtl(jn), & 574 & nleitl(jn), nlejtl(jn), & 575 & nimpptl(jn), njmpptl(jn), & 576 & ibonitl(jn), ibonjtl(jn) 577 END DO 578 CLOSE(inum) 579 END IF 580 ! 581 ! 582 END SUBROUTINE sub_dom 425 ! 426 END SUBROUTINE prt_ctl_init 427 583 428 584 429 !!====================================================================== -
NEMO/trunk/src/OCE/IOM/restart.F90
r13237 r13286 214 214 IF( .NOT.lxios_set ) THEN 215 215 IF(lwp) WRITE(numout,*) 'Enable restart reading by XIOS' 216 CALL iom_init( crxios_context , ld_tmppatch = .false.)216 CALL iom_init( crxios_context ) 217 217 lxios_set = .TRUE. 218 218 ENDIF 219 219 ENDIF 220 220 IF( TRIM(Agrif_CFixed()) /= '0' .AND. lrxios) THEN 221 CALL iom_init( crxios_context , ld_tmppatch = .false.)221 CALL iom_init( crxios_context ) 222 222 IF(lwp) WRITE(numout,*) 'Enable restart reading by XIOS for AGRIF' 223 223 lxios_set = .TRUE. … … 259 259 260 260 ! Diurnal DSST 261 IF( ln_diurnal ) CALL iom_get( numror, jpdom_auto glo, 'Dsst' , x_dsst, ldxios = lrxios )261 IF( ln_diurnal ) CALL iom_get( numror, jpdom_auto, 'Dsst' , x_dsst, ldxios = lrxios ) 262 262 IF ( ln_diurnal_only ) THEN 263 263 IF(lwp) WRITE( numout, * ) & 264 264 & "rst_read:- ln_diurnal_only set, setting rhop=rho0" 265 265 rhop = rho0 266 CALL iom_get( numror, jpdom_auto glo, 'tn' , w3d, ldxios = lrxios )266 CALL iom_get( numror, jpdom_auto, 'tn' , w3d, ldxios = lrxios ) 267 267 ts(:,:,1,jp_tem,Kmm) = w3d(:,:,1) 268 268 RETURN … … 270 270 271 271 IF( iom_varid( numror, 'ub', ldstop = .FALSE. ) > 0 ) THEN 272 CALL iom_get( numror, jpdom_autoglo, 'ub' , uu(:,:,: ,Kbb), ldxios = lrxios ) ! before fields 273 CALL iom_get( numror, jpdom_autoglo, 'vb' , vv(:,:,: ,Kbb), ldxios = lrxios ) 274 CALL iom_get( numror, jpdom_autoglo, 'tb' , ts(:,:,:,jp_tem,Kbb), ldxios = lrxios ) 275 CALL iom_get( numror, jpdom_autoglo, 'sb' , ts(:,:,:,jp_sal,Kbb), ldxios = lrxios ) 276 CALL iom_get( numror, jpdom_autoglo, 'sshb' ,ssh(:,: ,Kbb), ldxios = lrxios ) 272 ! before fields 273 CALL iom_get( numror, jpdom_auto, 'ub' , uu(:,:,: ,Kbb), ldxios = lrxios, cd_type = 'U', psgn = -1._wp ) 274 CALL iom_get( numror, jpdom_auto, 'vb' , vv(:,:,: ,Kbb), ldxios = lrxios, cd_type = 'V', psgn = -1._wp ) 275 CALL iom_get( numror, jpdom_auto, 'tb' , ts(:,:,:,jp_tem,Kbb), ldxios = lrxios ) 276 CALL iom_get( numror, jpdom_auto, 'sb' , ts(:,:,:,jp_sal,Kbb), ldxios = lrxios ) 277 CALL iom_get( numror, jpdom_auto, 'sshb' ,ssh(:,: ,Kbb), ldxios = lrxios ) 277 278 ELSE 278 279 l_1st_euler = .TRUE. ! before field not found, forced euler 1st time-step 279 280 ENDIF 280 281 ! 281 CALL iom_get( numror, jpdom_autoglo, 'un' , uu(:,:,: ,Kmm), ldxios = lrxios ) ! now fields 282 CALL iom_get( numror, jpdom_autoglo, 'vn' , vv(:,:,: ,Kmm), ldxios = lrxios ) 283 CALL iom_get( numror, jpdom_autoglo, 'tn' , ts(:,:,:,jp_tem,Kmm), ldxios = lrxios ) 284 CALL iom_get( numror, jpdom_autoglo, 'sn' , ts(:,:,:,jp_sal,Kmm), ldxios = lrxios ) 285 CALL iom_get( numror, jpdom_autoglo, 'sshn' ,ssh(:,: ,Kmm), ldxios = lrxios ) 282 ! now fields 283 CALL iom_get( numror, jpdom_auto, 'un' , uu(:,:,: ,Kmm), ldxios = lrxios, cd_type = 'U', psgn = -1._wp ) 284 CALL iom_get( numror, jpdom_auto, 'vn' , vv(:,:,: ,Kmm), ldxios = lrxios, cd_type = 'V', psgn = -1._wp ) 285 CALL iom_get( numror, jpdom_auto, 'tn' , ts(:,:,:,jp_tem,Kmm), ldxios = lrxios ) 286 CALL iom_get( numror, jpdom_auto, 'sn' , ts(:,:,:,jp_sal,Kmm), ldxios = lrxios ) 287 CALL iom_get( numror, jpdom_auto, 'sshn' ,ssh(:,: ,Kmm), ldxios = lrxios ) 286 288 IF( iom_varid( numror, 'rhop', ldstop = .FALSE. ) > 0 ) THEN 287 CALL iom_get( numror, jpdom_auto glo, 'rhop' , rhop, ldxios = lrxios ) ! now potential density289 CALL iom_get( numror, jpdom_auto, 'rhop' , rhop, ldxios = lrxios ) ! now potential density 288 290 ELSE 289 291 CALL eos( ts(:,:,:,:,Kmm), rhd, rhop, gdept(:,:,:,Kmm) ) -
NEMO/trunk/src/OCE/ISF/isfcpl.F90
r13237 r13286 20 20 USE domqco , ONLY: dom_qco_zgr ! vertical scale factor interpolation 21 21 #endif 22 USE dom ngb, ONLY: dom_ngb ! find the closest grid point from a given lon/lat position22 USE domutl , ONLY: dom_ngb ! find the closest grid point from a given lon/lat position 23 23 ! 24 24 USE oce ! ocean dynamics and tracers … … 183 183 !!---------------------------------------------------------------------- 184 184 ! 185 CALL iom_get( numror, jpdom_auto glo, 'ssmask' , zssmask_b, ldxios = lrxios ) ! need to extrapolate T/S185 CALL iom_get( numror, jpdom_auto, 'ssmask' , zssmask_b, ldxios = lrxios ) ! need to extrapolate T/S 186 186 187 187 ! compute new ssh if we open a full water column … … 264 264 !!---------------------------------------------------------------------- 265 265 ! 266 CALL iom_get( numror, jpdom_auto glo, 'tmask' , ztmask_b, ldxios = lrxios ) ! need to extrapolate T/S267 !CALL iom_get( numror, jpdom_auto glo, 'wmask' , zwmask_b, ldxios = lrxios ) ! need to extrapolate T/S268 !CALL iom_get( numror, jpdom_auto glo, 'gdepw_n', zdepw_b(:,:,:), ldxios = lrxios ) ! need to interpol vertical profile (vvl)266 CALL iom_get( numror, jpdom_auto, 'tmask' , ztmask_b, ldxios = lrxios ) ! need to extrapolate T/S 267 !CALL iom_get( numror, jpdom_auto, 'wmask' , zwmask_b, ldxios = lrxios ) ! need to extrapolate T/S 268 !CALL iom_get( numror, jpdom_auto, 'gdepw_n', zdepw_b(:,:,:), ldxios = lrxios ) ! need to interpol vertical profile (vvl) 269 269 ! 270 270 ! … … 410 410 !!---------------------------------------------------------------------- 411 411 ! 412 CALL iom_get( numror, jpdom_auto glo, 'tmask' , ztmask_b, ldxios = lrxios )413 CALL iom_get( numror, jpdom_auto glo, 'e3u_n' , ze3u_b , ldxios = lrxios )414 CALL iom_get( numror, jpdom_auto glo, 'e3v_n' , ze3v_b , ldxios = lrxios )412 CALL iom_get( numror, jpdom_auto, 'tmask' , ztmask_b, ldxios = lrxios ) 413 CALL iom_get( numror, jpdom_auto, 'e3u_n' , ze3u_b , ldxios = lrxios ) 414 CALL iom_get( numror, jpdom_auto, 'e3v_n' , ze3v_b , ldxios = lrxios ) 415 415 ! 416 416 ! 1.0: compute horizontal volume flux divergence difference before-after coupling … … 520 520 521 521 ! get restart variable 522 CALL iom_get( numror, jpdom_auto glo, 'tmask' , ztmask_b(:,:,:), ldxios = lrxios ) ! need to extrapolate T/S523 CALL iom_get( numror, jpdom_auto glo, 'e3t_n' , ze3t_b(:,:,:) , ldxios = lrxios )524 CALL iom_get( numror, jpdom_auto glo, 'tn' , zt_b(:,:,:) , ldxios = lrxios )525 CALL iom_get( numror, jpdom_auto glo, 'sn' , zs_b(:,:,:) , ldxios = lrxios )522 CALL iom_get( numror, jpdom_auto, 'tmask' , ztmask_b(:,:,:), ldxios = lrxios ) ! need to extrapolate T/S 523 CALL iom_get( numror, jpdom_auto, 'e3t_n' , ze3t_b(:,:,:) , ldxios = lrxios ) 524 CALL iom_get( numror, jpdom_auto, 'tn' , zt_b(:,:,:) , ldxios = lrxios ) 525 CALL iom_get( numror, jpdom_auto, 'sn' , zs_b(:,:,:) , ldxios = lrxios ) 526 526 527 527 ! compute run length … … 544 544 545 545 DO jk = 1,jpk-1 546 DO jj = nldj,nlej547 DO ji = nldi,nlei546 DO jj = Njs0,Nje0 547 DO ji = Nis0,Nie0 548 548 549 549 ! volume diff … … 578 578 nisfl(:)=0 579 579 DO jk = 1,jpk-1 580 DO jj = nldj,nlej581 DO ji = nldi,nlei580 DO jj = Njs0,Nje0 581 DO ji = Nis0,Nie0 582 582 jip1=MIN(ji+1,jpi) ; jim1=MAX(ji-1,1) ; jjp1=MIN(jj+1,jpj) ; jjm1=MAX(jj-1,1) ; 583 583 IF ( tmask(ji,jj,jk) == 0._wp .AND. ztmask_b(ji,jj,jk) == 1._wp ) THEN … … 600 600 jisf = 0 601 601 DO jk = 1,jpk-1 602 DO jj = nldj,nlej603 DO ji = nldi,nlei602 DO jj = Njs0,Nje0 603 DO ji = Nis0,Nie0 604 604 IF ( tmask(ji,jj,jk) == 0._wp .AND. ztmask_b(ji,jj,jk) == 1._wp ) THEN 605 605 -
NEMO/trunk/src/OCE/ISF/isfrst.F90
r11931 r13286 53 53 IF( iom_varid( numror, cfwf_b, ldstop = .FALSE. ) > 0 ) THEN 54 54 IF(lwp) WRITE(numout,*) ' nit000-1 isf tracer content forcing fields read in the restart file' 55 CALL iom_get( numror, jpdom_auto glo, cfwf_b, pfwf_b(:,:) , ldxios = lrxios ) ! before ice shelf melt56 CALL iom_get( numror, jpdom_auto glo, chc_b , ptsc_b (:,:,jp_tem), ldxios = lrxios ) ! before ice shelf heat flux57 CALL iom_get( numror, jpdom_auto glo, csc_b , ptsc_b (:,:,jp_sal), ldxios = lrxios ) ! before ice shelf heat flux55 CALL iom_get( numror, jpdom_auto, cfwf_b, pfwf_b(:,:) , ldxios = lrxios ) ! before ice shelf melt 56 CALL iom_get( numror, jpdom_auto, chc_b , ptsc_b (:,:,jp_tem), ldxios = lrxios ) ! before ice shelf heat flux 57 CALL iom_get( numror, jpdom_auto, csc_b , ptsc_b (:,:,jp_sal), ldxios = lrxios ) ! before ice shelf heat flux 58 58 ELSE 59 59 pfwf_b(:,:) = pfwf(:,:) -
NEMO/trunk/src/OCE/ISF/isfutils.F90
r12271 r13286 12 12 !!---------------------------------------------------------------------- 13 13 14 USE iom , ONLY: iom_open, iom_get, iom_close, jpdom_ data! read input file14 USE iom , ONLY: iom_open, iom_get, iom_close, jpdom_global ! read input file 15 15 USE lib_fortran , ONLY: glob_sum, glob_min, glob_max ! compute global value 16 USE par_oce , ONLY: jpi,jpj,jpk, jpnij 17 USE dom_oce , ONLY: n ldi, nlei, nldj, nlej, narea, tmask_h, tmask_i! local domain16 USE par_oce , ONLY: jpi,jpj,jpk, jpnij, Nis0, Nie0, Njs0, Nje0 ! domain size 17 USE dom_oce , ONLY: narea, tmask_h, tmask_i ! local domain 18 18 USE in_out_manager, ONLY: i8, wp, lwp, numout ! miscelenious 19 19 USE lib_mpp … … 47 47 48 48 CALL iom_open( TRIM(cdfile), inum ) 49 CALL iom_get( inum, jpdom_ data, TRIM(cdvar), pvar)49 CALL iom_get( inum, jpdom_global, TRIM(cdvar), pvar) 50 50 CALL iom_close(inum) 51 51 … … 84 84 ! 85 85 ! local MOD sum 86 DO jj= nldj,nlej87 DO ji= nldi,nlei86 DO jj=Njs0,Nje0 87 DO ji=Nis0,Nie0 88 88 idums = ABS(MOD(TRANSFER(pvar(ji,jj), ip),imodd)) 89 89 itmps(narea) = MOD(itmps(narea) + idums, imods) … … 138 138 ! local MOD sum 139 139 DO jk=1,jpk 140 DO jj= nldj,nlej141 DO ji= nldi,nlei140 DO jj=Njs0,Nje0 141 DO ji=Nis0,Nie0 142 142 idums = ABS(MOD(TRANSFER(pvar(ji,jj,jk), ip),imodd)) 143 143 itmps(narea) = MOD(itmps(narea) + idums, imods) -
NEMO/trunk/src/OCE/LBC/lbc_lnk_multi_generic.h90
r13226 r13286 39 39 & , pt5, cdna5, psgn5, pt6 , cdna6 , psgn6 , pt7 , cdna7 , psgn7 , pt8, cdna8, psgn8 & 40 40 & , pt9, cdna9, psgn9, pt10, cdna10, psgn10, pt11, cdna11, psgn11 & 41 & , kfillmode, pfillval, lsend, lrecv , ihlcom)41 & , kfillmode, pfillval, lsend, lrecv ) 42 42 !!--------------------------------------------------------------------- 43 43 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine … … 51 51 REAL(wp) , OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries) 52 52 LOGICAL, DIMENSION(4), OPTIONAL , INTENT(in ) :: lsend, lrecv ! indicate how communications are to be carried out 53 INTEGER , OPTIONAL , INTENT(in ) :: ihlcom ! number of ranks and rows to be communicated54 53 !! 55 54 INTEGER :: kfld ! number of elements that will be attributed … … 76 75 IF( PRESENT(psgn11) ) CALL ROUTINE_LOAD( pt11, cdna11, psgn11, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 77 76 ! 78 CALL lbc_lnk_ptr ( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, lsend, lrecv , ihlcom)77 CALL lbc_lnk_ptr ( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, lsend, lrecv ) 79 78 ! 80 79 END SUBROUTINE ROUTINE_MULTI -
NEMO/trunk/src/OCE/LBC/lbc_nfd_ext_generic.h90
r13226 r13286 34 34 ! 35 35 SELECT CASE ( jpni ) 36 CASE ( 1 ) ; ipj = nlcj! 1 proc only along the i-direction36 CASE ( 1 ) ; ipj = jpj ! 1 proc only along the i-direction 37 37 CASE DEFAULT ; ipj = 4 ! several proc along the i-direction 38 38 END SELECT -
NEMO/trunk/src/OCE/LBC/lbc_nfd_generic.h90
r13226 r13286 10 10 # endif 11 11 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j) 12 # define J_SIZE(ptab) SIZE(ptab(1)%pt2d,2) 12 13 # define K_SIZE(ptab) 1 13 14 # define L_SIZE(ptab) 1 … … 20 21 # endif 21 22 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k) 23 # define J_SIZE(ptab) SIZE(ptab(1)%pt3d,2) 22 24 # define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3) 23 25 # define L_SIZE(ptab) 1 … … 30 32 # endif 31 33 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l) 34 # define J_SIZE(ptab) SIZE(ptab(1)%pt4d,2) 32 35 # define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3) 33 36 # define L_SIZE(ptab) SIZE(ptab(1)%pt4d,4) … … 40 43 # if defined DIM_2d 41 44 # define ARRAY_IN(i,j,k,l,f) ptab(i,j) 45 # define J_SIZE(ptab) SIZE(ptab,2) 42 46 # define K_SIZE(ptab) 1 43 47 # define L_SIZE(ptab) 1 … … 45 49 # if defined DIM_3d 46 50 # define ARRAY_IN(i,j,k,l,f) ptab(i,j,k) 51 # define J_SIZE(ptab) SIZE(ptab,2) 47 52 # define K_SIZE(ptab) SIZE(ptab,3) 48 53 # define L_SIZE(ptab) 1 … … 50 55 # if defined DIM_4d 51 56 # define ARRAY_IN(i,j,k,l,f) ptab(i,j,k,l) 57 # define J_SIZE(ptab) SIZE(ptab,2) 52 58 # define K_SIZE(ptab) SIZE(ptab,3) 53 59 # define L_SIZE(ptab) SIZE(ptab,4) … … 76 82 REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary 77 83 ! 78 INTEGER :: ji, jj, jk, jl, jh,jf ! dummy loop indices79 INTEGER :: ipi, ipj, ipk, ipl,ipf ! dimension of the input array80 INTEGER :: i jt, iju, ipjm184 INTEGER :: ji, jj, jk, jl, jf ! dummy loop indices 85 INTEGER :: ipj, ipk, ipl, ipf ! dimension of the input array 86 INTEGER :: ii1, ii2, ij1, ij2 81 87 !!---------------------------------------------------------------------- 82 88 ! 83 ipk = K_SIZE(ptab) ! 3rd dimension 89 ipj = J_SIZE(ptab) ! 2nd dimension 90 ipk = K_SIZE(ptab) ! 3rd - 84 91 ipl = L_SIZE(ptab) ! 4th - 85 92 ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers) 86 !87 !88 SELECT CASE ( jpni )89 CASE ( 1 ) ; ipj = nlcj ! 1 proc only along the i-direction90 CASE DEFAULT ; ipj = 4 ! several proc along the i-direction91 END SELECT92 ipjm1 = ipj-193 94 93 ! 95 94 DO jf = 1, ipf ! Loop on the number of arrays to be treated … … 101 100 SELECT CASE ( NAT_IN(jf) ) 102 101 CASE ( 'T' , 'W' ) ! T-, W-point 103 DO ji = 2, jpiglo 104 ijt = jpiglo-ji+2 105 ARRAY_IN(ji,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-2,:,:,jf) 106 END DO 107 ARRAY_IN(1,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(3,ipj-2,:,:,jf) 108 DO ji = jpiglo/2+1, jpiglo 109 ijt = jpiglo-ji+2 110 ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipjm1,:,:,jf) 111 END DO 102 DO jl = 1, ipl; DO jk = 1, ipk 103 ! 104 ! last nn_hls lines (from ipj to ipj-nn_hls+1) : full 105 DO jj = 1, nn_hls 106 ij1 = ipj - jj + 1 ! ends at: ipj - nn_hls + 1 107 ij2 = ipj - 2*nn_hls + jj - 1 ! ends at: ipj - 2*nn_hls + nn_hls - 1 = ipj - nn_hls - 1 108 ! 109 DO ji = 1, nn_hls ! first nn_hls points 110 ii1 = ji ! ends at: nn_hls 111 ii2 = 2*nn_hls + 2 - ji ! ends at: 2*nn_hls + 2 - nn_hls = nn_hls + 2 112 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 113 END DO 114 DO ji = 1, 1 ! point nn_hls+1 115 ii1 = nn_hls + ji 116 ii2 = ii1 117 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 118 END DO 119 DO ji = 1, Ni0glo - 1 ! points from nn_hls+2 to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 120 ii1 = 2 + nn_hls + ji - 1 ! ends at: 2 + nn_hls + jpiglo - 2*nn_hls - 1 - 1 = jpiglo - nn_hls 121 ii2 = jpiglo - nn_hls - ji + 1 ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls - 1 ) + 1 = nn_hls + 2 122 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 123 END DO 124 DO ji = 1, 1 ! point jpiglo - nn_hls + 1 125 ii1 = jpiglo - nn_hls + ji 126 ii2 = nn_hls + ji 127 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 128 END DO 129 DO ji = 1, nn_hls-1 ! last nn_hls-1 points 130 ii1 = jpiglo - nn_hls + 1 + ji ! ends at: jpiglo - nn_hls + 1 + nn_hls - 1 = jpiglo 131 ii2 = jpiglo - nn_hls + 1 - ji ! ends at: jpiglo - nn_hls + 1 - nn_hls + 1 = jpiglo - 2*nn_hls + 2 132 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 133 END DO 134 END DO 135 ! 136 ! line number ipj-nn_hls : right half 137 DO jj = 1, 1 138 ij1 = ipj - nn_hls 139 ij2 = ij1 ! same line 140 ! 141 DO ji = 1, Ni0glo/2-1 ! points from jpiglo/2+2 to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 142 ii1 = jpiglo/2 + ji + 1 ! ends at: jpiglo/2 + (jpiglo/2 - nn_hls - 1) + 1 = jpiglo - nn_hls 143 ii2 = jpiglo/2 - ji + 1 ! ends at: jpiglo/2 - (jpiglo/2 - nn_hls - 1) + 1 = nn_hls + 2 144 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 145 END DO 146 DO ji = 1, nn_hls ! first nn_hls points: redo them just in case (if e-w periodocity already done) 147 ! ! as we just changed points jpiglo-2nn_hls+1 to jpiglo-nn_hls 148 ii1 = ji ! ends at: nn_hls 149 ii2 = 2*nn_hls + 2 - ji ! ends at: 2*nn_hls + 2 - nn_hls = nn_hls + 2 150 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 151 END DO 152 ! ! last nn_hls-1 points: have been / will done by e-w periodicity 153 END DO 154 ! 155 END DO; END DO 112 156 CASE ( 'U' ) ! U-point 113 DO ji = 1, jpiglo-1 114 iju = jpiglo-ji+1 115 ARRAY_IN(ji,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-2,:,:,jf) 116 END DO 117 ARRAY_IN( 1 ,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN( 2 ,ipj-2,:,:,jf) 118 ARRAY_IN(jpiglo,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpiglo-1,ipj-2,:,:,jf) 119 DO ji = jpiglo/2, jpiglo-1 120 iju = jpiglo-ji+1 121 ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipjm1,:,:,jf) 122 END DO 157 DO jl = 1, ipl; DO jk = 1, ipk 158 ! 159 ! last nn_hls lines (from ipj to ipj-nn_hls+1) : full 160 DO jj = 1, nn_hls 161 ij1 = ipj - jj + 1 ! ends at: ipj - nn_hls + 1 162 ij2 = ipj - 2*nn_hls + jj - 1 ! ends at: ipj - 2*nn_hls + nn_hls - 1 = ipj - nn_hls - 1 163 ! 164 DO ji = 1, nn_hls ! first nn_hls points 165 ii1 = ji ! ends at: nn_hls 166 ii2 = 2*nn_hls + 1 - ji ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1 167 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 168 END DO 169 DO ji = 1, Ni0glo ! points from nn_hls to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 170 ii1 = nn_hls + ji ! ends at: nn_hls + jpiglo - 2*nn_hls = jpiglo - nn_hls 171 ii2 = jpiglo - nn_hls - ji + 1 ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls ) + 1 = nn_hls + 1 172 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 173 END DO 174 DO ji = 1, nn_hls ! last nn_hls points 175 ii1 = jpiglo - nn_hls + ji ! ends at: jpiglo - nn_hls + nn_hls = jpiglo 176 ii2 = jpiglo - nn_hls + 1 - ji ! ends at: jpiglo - nn_hls + 1 - nn_hls = jpiglo - 2*nn_hls + 1 177 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 178 END DO 179 END DO 180 ! 181 ! line number ipj-nn_hls : right half 182 DO jj = 1, 1 183 ij1 = ipj - nn_hls 184 ij2 = ij1 ! same line 185 ! 186 DO ji = 1, Ni0glo/2 ! points from jpiglo/2+1 to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 187 ii1 = jpiglo/2 + ji ! ends at: jpiglo/2 + (jpiglo/2 - nn_hls) = jpiglo - nn_hls 188 ii2 = jpiglo/2 - ji + 1 ! ends at: jpiglo/2 - (jpiglo/2 - nn_hls) + 1 = nn_hls + 1 189 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 190 END DO 191 DO ji = 1, nn_hls ! first nn_hls points: redo them just in case (if e-w periodocity already done) 192 ! ! as we just changed points jpiglo-2nn_hls+1 to jpiglo-nn_hls 193 ii1 = ji ! ends at: nn_hls 194 ii2 = 2*nn_hls + 1 - ji ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1 195 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 196 END DO 197 ! ! last nn_hls-1 points: have been / will done by e-w periodicity 198 END DO 199 ! 200 END DO; END DO 123 201 CASE ( 'V' ) ! V-point 124 DO ji = 2, jpiglo 125 ijt = jpiglo-ji+2 126 ARRAY_IN(ji,ipj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-2,:,:,jf) 127 ARRAY_IN(ji,ipj ,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-3,:,:,jf) 128 END DO 129 ARRAY_IN(1,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(3,ipj-3,:,:,jf) 202 DO jl = 1, ipl; DO jk = 1, ipk 203 ! 204 ! last nn_hls+1 lines (from ipj to ipj-nn_hls) : full 205 DO jj = 1, nn_hls+1 206 ij1 = ipj - jj + 1 ! ends at: ipj - ( nn_hls + 1 ) + 1 = ipj - nn_hls 207 ij2 = ipj - 2*nn_hls + jj - 2 ! ends at: ipj - 2*nn_hls + nn_hls + 1 - 2 = ipj - nn_hls - 1 208 ! 209 DO ji = 1, nn_hls ! first nn_hls points 210 ii1 = ji ! ends at: nn_hls 211 ii2 = 2*nn_hls + 2 - ji ! ends at: 2*nn_hls + 2 - nn_hls = nn_hls + 2 212 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 213 END DO 214 DO ji = 1, 1 ! point nn_hls+1 215 ii1 = nn_hls + ji 216 ii2 = ii1 217 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 218 END DO 219 DO ji = 1, Ni0glo - 1 ! points from nn_hls+2 to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 220 ii1 = 2 + nn_hls + ji - 1 ! ends at: 2 + nn_hls + jpiglo - 2*nn_hls - 1 - 1 = jpiglo - nn_hls 221 ii2 = jpiglo - nn_hls - ji + 1 ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls - 1 ) + 1 = nn_hls + 2 222 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 223 END DO 224 DO ji = 1, 1 ! point jpiglo - nn_hls + 1 225 ii1 = jpiglo - nn_hls + ji 226 ii2 = nn_hls + ji 227 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 228 END DO 229 DO ji = 1, nn_hls-1 ! last nn_hls-1 points 230 ii1 = jpiglo - nn_hls + 1 + ji ! ends at: jpiglo - nn_hls + 1 + nn_hls - 1 = jpiglo 231 ii2 = jpiglo - nn_hls + 1 - ji ! ends at: jpiglo - nn_hls + 1 - nn_hls + 1 = jpiglo - 2*nn_hls + 2 232 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 233 END DO 234 END DO 235 ! 236 END DO; END DO 130 237 CASE ( 'F' ) ! F-point 131 DO ji = 1, jpiglo-1 132 iju = jpiglo-ji+1 133 ARRAY_IN(ji,ipj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-2,:,:,jf) 134 ARRAY_IN(ji,ipj ,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-3,:,:,jf) 135 END DO 136 ARRAY_IN( 1 ,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN( 2 ,ipj-3,:,:,jf) 137 ARRAY_IN(jpiglo,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpiglo-1,ipj-3,:,:,jf) 138 END SELECT 238 DO jl = 1, ipl; DO jk = 1, ipk 239 ! 240 ! last nn_hls+1 lines (from ipj to ipj-nn_hls) : full 241 DO jj = 1, nn_hls+1 242 ij1 = ipj - jj + 1 ! ends at: ipj - ( nn_hls + 1 ) + 1 = ipj - nn_hls 243 ij2 = ipj - 2*nn_hls + jj - 2 ! ends at: ipj - 2*nn_hls + nn_hls + 1 - 2 = ipj - nn_hls - 1 244 ! 245 DO ji = 1, nn_hls ! first nn_hls points 246 ii1 = ji ! ends at: nn_hls 247 ii2 = 2*nn_hls + 1 - ji ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1 248 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 249 END DO 250 DO ji = 1, Ni0glo ! points from nn_hls to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 251 ii1 = nn_hls + ji ! ends at: nn_hls + jpiglo - 2*nn_hls = jpiglo - nn_hls 252 ii2 = jpiglo - nn_hls - ji + 1 ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls ) + 1 = nn_hls + 1 253 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 254 END DO 255 DO ji = 1, nn_hls ! last nn_hls points 256 ii1 = jpiglo - nn_hls + ji ! ends at: jpiglo - nn_hls + nn_hls = jpiglo 257 ii2 = jpiglo - nn_hls + 1 - ji ! ends at: jpiglo - nn_hls + 1 - nn_hls = jpiglo - 2*nn_hls + 1 258 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 259 END DO 260 END DO 261 ! 262 END DO; END DO 263 END SELECT ! NAT_IN(jf) 139 264 ! 140 265 CASE ( 5 , 6 ) ! * North fold F-point pivot … … 142 267 SELECT CASE ( NAT_IN(jf) ) 143 268 CASE ( 'T' , 'W' ) ! T-, W-point 144 DO ji = 1, jpiglo 145 ijt = jpiglo-ji+1 146 ARRAY_IN(ji,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-1,:,:,jf) 147 END DO 269 DO jl = 1, ipl; DO jk = 1, ipk 270 ! 271 ! first: line number ipj-nn_hls : 3 points 272 DO jj = 1, 1 273 ij1 = ipj - nn_hls 274 ij2 = ij1 ! same line 275 ! 276 DO ji = 1, 1 ! points from jpiglo/2+1 277 ii1 = jpiglo/2 + ji 278 ii2 = jpiglo/2 - ji + 1 279 ARRAY_IN(ii1,ij1,jk,jl,jf) = ARRAY_IN(ii2,ij2,jk,jl,jf) ! Warning: pb with sign... 280 END DO 281 DO ji = 1, 1 ! points jpiglo - nn_hls 282 ii1 = jpiglo - nn_hls + ji - 1 283 ii2 = nn_hls + ji 284 ARRAY_IN(ii1,ij1,jk,jl,jf) = ARRAY_IN(ii2,ij2,jk,jl,jf) ! Warning: pb with sign... 285 END DO 286 DO ji = 1, 1 ! point nn_hls: redo it just in case (if e-w periodocity already done) 287 ! ! as we just changed point jpiglo - nn_hls 288 ii1 = nn_hls + ji - 1 289 ii2 = nn_hls + ji 290 ARRAY_IN(ii1,ij1,jk,jl,jf) = ARRAY_IN(ii2,ij2,jk,jl,jf) ! Warning: pb with sign... 291 END DO 292 END DO 293 ! 294 ! Second: last nn_hls lines (from ipj to ipj-nn_hls+1) : full 295 DO jj = 1, nn_hls 296 ij1 = ipj + 1 - jj ! ends at: ipj + 1 - nn_hls 297 ij2 = ipj - 2*nn_hls + jj ! ends at: ipj - 2*nn_hls + nn_hls = ipj - nn_hls 298 ! 299 DO ji = 1, nn_hls ! first nn_hls points 300 ii1 = ji ! ends at: nn_hls 301 ii2 = 2*nn_hls + 1 - ji ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1 302 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 303 END DO 304 DO ji = 1, Ni0glo ! points from nn_hls to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 305 ii1 = nn_hls + ji ! ends at: nn_hls + jpiglo - 2*nn_hls = jpiglo - nn_hls 306 ii2 = jpiglo - nn_hls - ji + 1 ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls ) + 1 = nn_hls + 1 307 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 308 END DO 309 DO ji = 1, nn_hls ! last nn_hls points 310 ii1 = jpiglo - nn_hls + ji ! ends at: jpiglo - nn_hls + nn_hls = jpiglo 311 ii2 = jpiglo - nn_hls + 1 - ji ! ends at: jpiglo - nn_hls + 1 - nn_hls = jpiglo - 2*nn_hls + 1 312 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 313 END DO 314 END DO 315 ! 316 END DO; END DO 148 317 CASE ( 'U' ) ! U-point 149 DO ji = 1, jpiglo-1 150 iju = jpiglo-ji 151 ARRAY_IN(ji,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-1,:,:,jf) 152 END DO 153 ARRAY_IN(jpiglo,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpiglo-2,ipj-1,:,:,jf) 318 DO jl = 1, ipl; DO jk = 1, ipk 319 ! 320 ! last nn_hls lines (from ipj to ipj-nn_hls+1) : full 321 DO jj = 1, nn_hls 322 ij1 = ipj + 1 - jj ! ends at: ipj + 1 - nn_hls 323 ij2 = ipj - 2*nn_hls + jj ! ends at: ipj - 2*nn_hls + nn_hls = ipj - nn_hls 324 ! 325 DO ji = 1, nn_hls-1 ! first nn_hls-1 points 326 ii1 = ji ! ends at: nn_hls-1 327 ii2 = 2*nn_hls - ji ! ends at: 2*nn_hls - ( nn_hls - 1 ) = nn_hls + 1 328 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 329 END DO 330 DO ji = 1, 1 ! point nn_hls 331 ii1 = nn_hls + ji - 1 332 ii2 = jpiglo - ii1 333 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 334 END DO 335 DO ji = 1, Ni0glo - 1 ! points from nn_hls+1 to jpiglo - nn_hls - 1 (note: Ni0glo = jpiglo - 2*nn_hls) 336 ii1 = nn_hls + ji ! ends at: nn_hls + ( jpiglo - 2*nn_hls - 1 ) = jpiglo - nn_hls - 1 337 ii2 = jpiglo - nn_hls - ji ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls - 1 ) = nn_hls + 1 338 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 339 END DO 340 DO ji = 1, 1 ! point jpiglo - nn_hls 341 ii1 = jpiglo - nn_hls + ji - 1 342 ii2 = ii1 343 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 344 END DO 345 DO ji = 1, nn_hls ! last nn_hls points 346 ii1 = jpiglo - nn_hls + ji ! ends at: jpiglo - nn_hls + nn_hls = jpiglo 347 ii2 = jpiglo - nn_hls - ji ! ends at: jpiglo - nn_hls - nn_hls = jpiglo - 2*nn_hls 348 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 349 END DO 350 END DO 351 ! 352 END DO; END DO 154 353 CASE ( 'V' ) ! V-point 155 DO ji = 1, jpiglo 156 ijt = jpiglo-ji+1 157 ARRAY_IN(ji,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-2,:,:,jf) 158 END DO 159 DO ji = jpiglo/2+1, jpiglo 160 ijt = jpiglo-ji+1 161 ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipjm1,:,:,jf) 162 END DO 354 DO jl = 1, ipl; DO jk = 1, ipk 355 ! 356 ! last nn_hls lines (from ipj to ipj-nn_hls+1) : full 357 DO jj = 1, nn_hls 358 ij1 = ipj - jj + 1 ! ends at: ipj - nn_hls + 1 359 ij2 = ipj - 2*nn_hls + jj - 1 ! ends at: ipj - 2*nn_hls + nn_hls - 1 = ipj - nn_hls - 1 360 ! 361 DO ji = 1, nn_hls ! first nn_hls points 362 ii1 = ji ! ends at: nn_hls 363 ii2 = 2*nn_hls + 1 - ji ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1 364 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 365 END DO 366 DO ji = 1, Ni0glo ! points from nn_hls to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 367 ii1 = nn_hls + ji ! ends at: nn_hls + jpiglo - 2*nn_hls = jpiglo - nn_hls 368 ii2 = jpiglo - nn_hls - ji + 1 ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls ) + 1 = nn_hls + 1 369 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 370 END DO 371 DO ji = 1, nn_hls ! last nn_hls points 372 ii1 = jpiglo - nn_hls + ji ! ends at: jpiglo - nn_hls + nn_hls = jpiglo 373 ii2 = jpiglo - nn_hls + 1 - ji ! ends at: jpiglo - nn_hls + 1 - nn_hls = jpiglo - 2*nn_hls + 1 374 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 375 END DO 376 END DO 377 ! 378 ! line number ipj-nn_hls : right half 379 DO jj = 1, 1 380 ij1 = ipj - nn_hls 381 ij2 = ij1 ! same line 382 ! 383 DO ji = 1, Ni0glo/2 ! points from jpiglo/2+1 to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 384 ii1 = jpiglo/2 + ji ! ends at: jpiglo/2 + (jpiglo/2 - nn_hls) = jpiglo - nn_hls 385 ii2 = jpiglo/2 - ji + 1 ! ends at: jpiglo/2 - (jpiglo/2 - nn_hls) + 1 = nn_hls + 1 386 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 387 END DO 388 DO ji = 1, nn_hls ! first nn_hls points: redo them just in case (if e-w periodocity already done) 389 ! ! as we just changed points jpiglo-2nn_hls+1 to jpiglo-nn_hls 390 ii1 = ji ! ends at: nn_hls 391 ii2 = 2*nn_hls + 1 - ji ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1 392 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 393 END DO 394 ! ! last nn_hls points: have been / will done by e-w periodicity 395 END DO 396 ! 397 END DO; END DO 163 398 CASE ( 'F' ) ! F-point 164 DO ji = 1, jpiglo-1 165 iju = jpiglo-ji 166 ARRAY_IN(ji,ipj ,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-2,:,:,jf) 167 END DO 168 ARRAY_IN(jpiglo,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpiglo-2,ipj-2,:,:,jf) 169 DO ji = jpiglo/2+1, jpiglo-1 170 iju = jpiglo-ji 171 ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipjm1,:,:,jf) 172 END DO 173 END SELECT 399 DO jl = 1, ipl; DO jk = 1, ipk 400 ! 401 ! last nn_hls lines (from ipj to ipj-nn_hls+1) : full 402 DO jj = 1, nn_hls 403 ij1 = ipj - jj + 1 ! ends at: ipj - nn_hls + 1 404 ij2 = ipj - 2*nn_hls + jj - 1 ! ends at: ipj - 2*nn_hls + nn_hls - 1 = ipj - nn_hls - 1 405 ! 406 DO ji = 1, nn_hls-1 ! first nn_hls-1 points 407 ii1 = ji ! ends at: nn_hls-1 408 ii2 = 2*nn_hls - ji ! ends at: 2*nn_hls - ( nn_hls - 1 ) = nn_hls + 1 409 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 410 END DO 411 DO ji = 1, 1 ! point nn_hls 412 ii1 = nn_hls + ji - 1 413 ii2 = jpiglo - ii1 414 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 415 END DO 416 DO ji = 1, Ni0glo - 1 ! points from nn_hls+1 to jpiglo - nn_hls - 1 (note: Ni0glo = jpiglo - 2*nn_hls) 417 ii1 = nn_hls + ji ! ends at: nn_hls + ( jpiglo - 2*nn_hls - 1 ) = jpiglo - nn_hls - 1 418 ii2 = jpiglo - nn_hls - ji ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls - 1 ) = nn_hls + 1 419 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 420 END DO 421 DO ji = 1, 1 ! point jpiglo - nn_hls 422 ii1 = jpiglo - nn_hls + ji - 1 423 ii2 = ii1 424 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 425 END DO 426 DO ji = 1, nn_hls ! last nn_hls points 427 ii1 = jpiglo - nn_hls + ji ! ends at: jpiglo - nn_hls + nn_hls = jpiglo 428 ii2 = jpiglo - nn_hls - ji ! ends at: jpiglo - nn_hls - nn_hls = jpiglo - 2*nn_hls 429 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 430 END DO 431 END DO 432 ! 433 ! line number ipj-nn_hls : right half 434 DO jj = 1, 1 435 ij1 = ipj - nn_hls 436 ij2 = ij1 ! same line 437 ! 438 DO ji = 1, Ni0glo/2-1 ! points from jpiglo/2+1 to jpiglo - nn_hls-1 (note: Ni0glo = jpiglo - 2*nn_hls) 439 ii1 = jpiglo/2 + ji ! ends at: jpiglo/2 + (jpiglo/2 - nn_hls) = jpiglo - nn_hls 440 ii2 = jpiglo/2 - ji ! ends at: jpiglo/2 - (jpiglo/2 - nn_hls - 1 ) = nn_hls + 1 441 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 442 END DO 443 DO ji = 1, nn_hls-1 ! first nn_hls-1 points: redo them just in case (if e-w periodocity already done) 444 ! ! as we just changed points jpiglo-2nn_hls+1 to jpiglo-nn_hl-1 445 ii1 = ji ! ends at: nn_hls 446 ii2 = 2*nn_hls - ji ! ends at: 2*nn_hls - ( nn_hls - 1 ) = nn_hls + 1 447 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 448 END DO 449 ! ! last nn_hls points: have been / will done by e-w periodicity 450 END DO 451 ! 452 END DO; END DO 453 END SELECT ! NAT_IN(jf) 174 454 ! 175 CASE DEFAULT ! * closed : the code probably never go through 176 ! 177 SELECT CASE ( NAT_IN(jf) ) 178 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 179 ARRAY_IN(:, 1 ,:,:,jf) = 0._wp 180 ARRAY_IN(:,ipj,:,:,jf) = 0._wp 181 CASE ( 'F' ) ! F-point 182 ARRAY_IN(:,ipj,:,:,jf) = 0._wp 183 END SELECT 184 ! 185 END SELECT ! npolj 455 END SELECT ! npolj 186 456 ! 187 END DO 457 END DO ! ipf 188 458 ! 189 459 END SUBROUTINE ROUTINE_NFD … … 194 464 #undef NAT_IN 195 465 #undef SGN_IN 466 #undef J_SIZE 196 467 #undef K_SIZE 197 468 #undef L_SIZE -
NEMO/trunk/src/OCE/LBC/lbc_nfd_nogather_generic.h90
r13226 r13286 60 60 # define L_SIZE(ptab) SIZE(ptab,4) 61 61 # endif 62 # define ARRAY2_IN(i,j,k,l,f) ptab2(i,j,k,l)63 62 # define J_SIZE(ptab2) SIZE(ptab2,2) 63 # define ARRAY2_IN(i,j,k,l,f) ptab2(i,j,k,l) 64 64 # if defined SINGLE_PRECISION 65 65 # define ARRAY_TYPE(i,j,k,l,f) REAL(sp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) … … 82 82 !! 83 83 !!---------------------------------------------------------------------- 84 ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied85 ARRAY2_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied84 ARRAY_TYPE(:,:,:,:,:) 85 ARRAY2_TYPE(:,:,:,:,:) 86 86 CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points 87 87 REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary 88 88 INTEGER, OPTIONAL, INTENT(in ) :: kfld ! number of pt3d arrays 89 89 ! 90 INTEGER :: ji, jj, jk, 91 INTEGER :: ipi, ipj, ipk, ipl, ipf 92 INTEGER :: ijt, iju, ij pj, ijpjp1, ijta, ijua, jia, startloop, endloop90 INTEGER :: ji, jj, jk, jn, ii, jl, jh, jf ! dummy loop indices 91 INTEGER :: ipi, ipj, ipk, ipl, ipf, iij, ijj ! dimension of the input array 92 INTEGER :: ijt, iju, ijta, ijua, jia, startloop, endloop 93 93 LOGICAL :: l_fast_exchanges 94 94 !!---------------------------------------------------------------------- … … 100 100 ! Security check for further developments 101 101 IF ( ipf > 1 ) CALL ctl_stop( 'STOP', 'lbc_nfd_nogather: multiple fields not allowed. Revise implementation...' ) 102 !103 ijpj = 1 ! index of first modified line104 ijpjp1 = 2 ! index + 1105 106 102 ! 2nd dimension determines exchange speed 107 103 IF (ipj == 1 ) THEN … … 120 116 ! 121 117 CASE ( 'T' , 'W' ) ! T-, W-point 122 IF ( nimpp /= 1 ) THEN ; startloop = 1 123 ELSE ; startloop = 2 124 ENDIF 125 ! 126 DO jl = 1, ipl; DO jk = 1, ipk 127 DO ji = startloop, nlci 128 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 129 ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf) 118 IF ( nimpp /= 1 ) THEN ; startloop = 1 119 ELSE ; startloop = 1 + nn_hls 120 ENDIF 121 ! 122 DO jl = 1, ipl; DO jk = 1, ipk 123 DO jj = 1, nn_hls 124 ijj = jpj -jj +1 125 DO ji = startloop, jpi 126 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 127 ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf) 128 END DO 130 129 END DO 131 130 END DO; END DO 132 131 IF( nimpp == 1 ) THEN 133 132 DO jl = 1, ipl; DO jk = 1, ipk 134 ARRAY_IN(1,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(3,nlcj-2,jk,jl,jf) 135 END DO; END DO 136 ENDIF 137 ! 138 IF ( .NOT. l_fast_exchanges ) THEN 139 IF( nimpp >= jpiglo/2+1 ) THEN 133 DO jj = 1, nn_hls 134 ijj = jpj -jj +1 135 DO ii = 0, nn_hls-1 136 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) 137 END DO 138 END DO 139 END DO; END DO 140 ENDIF 141 ! 142 IF ( .NOT. l_fast_exchanges ) THEN 143 IF( nimpp >= Ni0glo/2+2 ) THEN 140 144 startloop = 1 141 ELSEIF( nimpp+ nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1) THEN142 startloop = jpiglo/2+1 - nimpp + 1143 ELSE 144 startloop = nlci + 1145 ENDIF 146 IF( startloop <= nlci ) THEN145 ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN 146 startloop = Ni0glo/2+2 - nimpp + nn_hls 147 ELSE 148 startloop = jpi + 1 149 ENDIF 150 IF( startloop <= jpi ) THEN 147 151 DO jl = 1, ipl; DO jk = 1, ipk 148 DO ji = startloop, nlci149 ijt = jpiglo - ji - nimpp - nfi impp(isendto(1),jpnj) + 4152 DO ji = startloop, jpi 153 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 150 154 jia = ji + nimpp - 1 151 155 ijta = jpiglo - jia + 2 152 156 IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN 153 ARRAY_IN(ji, nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ijta-nimpp+1,nlcj-1,jk,jl,jf)157 ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ijta-nimpp+nn_hls,jpj-nn_hls,jk,jl,jf) 154 158 ELSE 155 ARRAY_IN(ji, nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjp1,jk,jl,jf)159 ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,nn_hls+1,jk,jl,jf) 156 160 ENDIF 157 161 END DO … … 159 163 ENDIF 160 164 ENDIF 161 162 165 CASE ( 'U' ) ! U-point 163 IF( nimpp + nlci - 1 /= jpiglo ) THEN164 endloop = nlci166 IF( nimpp + jpi - 1 /= jpiglo ) THEN 167 endloop = jpi 165 168 ELSE 166 endloop = nlci - 1 167 ENDIF 168 DO jl = 1, ipl; DO jk = 1, ipk 169 DO ji = 1, endloop 170 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 171 ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf) 169 endloop = jpi - nn_hls 170 ENDIF 171 DO jl = 1, ipl; DO jk = 1, ipk 172 DO jj = 1, nn_hls 173 ijj = jpj -jj +1 174 DO ji = 1, endloop 175 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 176 ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf) 177 END DO 172 178 END DO 173 179 END DO; END DO 174 180 IF (nimpp .eq. 1) THEN 175 ARRAY_IN(1,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2,nlcj-2,:,:,jf) 176 ENDIF 177 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 178 ARRAY_IN(nlci,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,nlcj-2,:,:,jf) 179 ENDIF 180 ! 181 IF ( .NOT. l_fast_exchanges ) THEN 182 IF( nimpp + nlci - 1 /= jpiglo ) THEN 183 endloop = nlci 184 ELSE 185 endloop = nlci - 1 186 ENDIF 187 IF( nimpp >= jpiglo/2 ) THEN 188 startloop = 1 189 ELSEIF( ( nimpp+nlci-1 >= jpiglo/2 ) .AND. ( nimpp < jpiglo/2 ) ) THEN 190 startloop = jpiglo/2 - nimpp + 1 181 DO jj = 1, nn_hls 182 ijj = jpj -jj +1 183 DO ii = 0, nn_hls-1 184 ARRAY_IN(ii+1,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2*nn_hls-ii,jpj-2*nn_hls+jj-1,:,:,jf) 185 END DO 186 END DO 187 ENDIF 188 IF((nimpp + jpi - 1) .eq. jpiglo) THEN 189 DO jj = 1, nn_hls 190 ijj = jpj -jj +1 191 DO ii = 1, nn_hls 192 ARRAY_IN(jpi-ii+1,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpi-2*nn_hls+ii,jpj-2*nn_hls+jj-1,:,:,jf) 193 END DO 194 END DO 195 ENDIF 196 ! 197 IF ( .NOT. l_fast_exchanges ) THEN 198 IF( nimpp + jpi - 1 /= jpiglo ) THEN 199 endloop = jpi 200 ELSE 201 endloop = jpi - nn_hls 202 ENDIF 203 IF( nimpp >= Ni0glo/2+1 ) THEN 204 startloop = nn_hls 205 ELSEIF( ( nimpp + jpi - 1 >= Ni0glo/2+1 ) .AND. ( nimpp < Ni0glo/2+1 ) ) THEN 206 startloop = Ni0glo/2+1 - nimpp + nn_hls 191 207 ELSE 192 208 startloop = endloop + 1 … … 195 211 DO jl = 1, ipl; DO jk = 1, ipk 196 212 DO ji = startloop, endloop 197 iju = jpiglo - ji - nimpp - nfi impp(isendto(1),jpnj) + 3198 jia = ji + nimpp - 1 199 ijua = jpiglo - jia + 1 213 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 214 jia = ji + nimpp - 1 215 ijua = jpiglo - jia + 1 200 216 IF( ijua >= startloop+nimpp-1 .AND. ijua < jia ) THEN 201 ARRAY_IN(ji, nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ijua-nimpp+1,nlcj-1,jk,jl,jf)217 ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ijua-nimpp+1,jpj-nn_hls,jk,jl,jf) 202 218 ELSE 203 ARRAY_IN(ji, nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjp1,jk,jl,jf)219 ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,nn_hls+1,jk,jl,jf) 204 220 ENDIF 205 221 END DO … … 210 226 CASE ( 'V' ) ! V-point 211 227 IF( nimpp /= 1 ) THEN 212 startloop = 1 228 startloop = 1 213 229 ELSE 214 startloop = 2 215 ENDIF 216 IF ( .NOT. l_fast_exchanges ) THEN 217 DO jl = 1, ipl; DO jk = 1, ipk 218 DO ji = startloop, nlci 219 ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 220 ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjp1,jk,jl,jf) 221 END DO 222 END DO; END DO 223 ENDIF 224 DO jl = 1, ipl; DO jk = 1, ipk 225 DO ji = startloop, nlci 226 ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 227 ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf) 230 startloop = 1 + nn_hls 231 ENDIF 232 IF ( .NOT. l_fast_exchanges ) THEN 233 DO jl = 1, ipl; DO jk = 1, ipk 234 DO jj = 2, nn_hls+1 235 ijj = jpj -jj +1 236 DO ji = startloop, jpi 237 ijt=jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 238 ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf) 239 END DO 240 END DO 241 END DO; END DO 242 ENDIF 243 DO jl = 1, ipl; DO jk = 1, ipk 244 DO ji = startloop, jpi 245 ijt=jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 246 ARRAY_IN(ji,jpj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,1,jk,jl,jf) 228 247 END DO 229 248 END DO; END DO 230 249 IF (nimpp .eq. 1) THEN 231 ARRAY_IN(1,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(3,nlcj-3,:,:,jf) 250 DO jj = 1, nn_hls 251 ijj = jpj-jj+1 252 DO ii = 0, nn_hls-1 253 ARRAY_IN(ii+1,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2*nn_hls-ii+1,jpj-2*nn_hls+jj-1,:,:,jf) 254 END DO 255 END DO 232 256 ENDIF 233 257 CASE ( 'F' ) ! F-point 234 IF( nimpp + nlci - 1 /= jpiglo ) THEN235 endloop = nlci258 IF( nimpp + jpi - 1 /= jpiglo ) THEN 259 endloop = jpi 236 260 ELSE 237 endloop = nlci - 1 238 ENDIF 239 IF ( .NOT. l_fast_exchanges ) THEN 240 DO jl = 1, ipl; DO jk = 1, ipk 241 DO ji = 1, endloop 242 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 243 ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjp1,jk,jl,jf) 244 END DO 261 endloop = jpi - nn_hls 262 ENDIF 263 IF ( .NOT. l_fast_exchanges ) THEN 264 DO jl = 1, ipl; DO jk = 1, ipk 265 DO jj = 2, nn_hls+1 266 ijj = jpj -jj +1 267 DO ji = 1, endloop 268 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 269 ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf) 270 END DO 271 END DO 245 272 END DO; END DO 246 273 ENDIF 247 274 DO jl = 1, ipl; DO jk = 1, ipk 248 275 DO ji = 1, endloop 249 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 250 ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf) 251 END DO 252 END DO; END DO 253 IF (nimpp .eq. 1) THEN 254 ARRAY_IN(1,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2,nlcj-3,:,:,jf) 255 IF ( .NOT. l_fast_exchanges ) & 256 ARRAY_IN(1,nlcj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2,nlcj-2,:,:,jf) 257 ENDIF 258 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 259 ARRAY_IN(nlci,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,nlcj-3,:,:,jf) 260 IF ( .NOT. l_fast_exchanges ) & 261 ARRAY_IN(nlci,nlcj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,nlcj-2,:,:,jf) 262 ENDIF 263 ! 264 END SELECT 276 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 277 ARRAY_IN(ji,jpj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,1,jk,jl,jf) 278 END DO 279 END DO; END DO 280 IF (nimpp .eq. 1) THEN 281 DO ii = 1, nn_hls 282 ARRAY_IN(ii,jpj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2*nn_hls-ii,jpj-2*nn_hls-1,:,:,jf) 283 END DO 284 IF ( .NOT. l_fast_exchanges ) THEN 285 DO jj = 1, nn_hls 286 ijj = jpj -jj 287 DO ii = 0, nn_hls-1 288 ARRAY_IN(ii+1,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2*nn_hls-ii,jpj-2*nn_hls+jj-1,:,:,jf) 289 END DO 290 END DO 291 ENDIF 292 ENDIF 293 IF((nimpp + jpi - 1 ) .eq. jpiglo) THEN 294 DO ii = 1, nn_hls 295 ARRAY_IN(jpi-ii+1,jpj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpi-2*nn_hls+ii,jpj-2*nn_hls-1,:,:,jf) 296 END DO 297 IF ( .NOT. l_fast_exchanges ) THEN 298 DO jj = 1, nn_hls 299 ijj = jpj -jj 300 DO ii = 1, nn_hls 301 ARRAY_IN(jpi-ii+1,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpi-2*nn_hls+ii,jpj-2*nn_hls+jj-1,:,:,jf) 302 END DO 303 END DO 304 ENDIF 305 ENDIF 306 ! 307 END SELECT 265 308 ! 266 309 CASE ( 5, 6 ) ! * North fold F-point pivot … … 269 312 CASE ( 'T' , 'W' ) ! T-, W-point 270 313 DO jl = 1, ipl; DO jk = 1, ipk 271 DO ji = 1, nlci 272 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 273 ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf) 274 END DO 314 DO jj = 1, nn_hls 315 ijj = jpj-jj+1 316 DO ji = 1, jpi 317 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 318 ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf) 319 END DO 320 END DO 275 321 END DO; END DO 276 322 ! 277 323 CASE ( 'U' ) ! U-point 278 IF( nimpp + nlci - 1 /= jpiglo ) THEN279 endloop = nlci324 IF( nimpp + jpi - 1 /= jpiglo ) THEN 325 endloop = jpi 280 326 ELSE 281 endloop = nlci - 1 282 ENDIF 283 DO jl = 1, ipl; DO jk = 1, ipk 284 DO ji = 1, endloop 285 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 286 ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf) 287 END DO 288 END DO; END DO 289 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 290 DO jl = 1, ipl; DO jk = 1, ipk 291 ARRAY_IN(nlci,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(nlci-2,nlcj-1,jk,jl,jf) 327 endloop = jpi - nn_hls 328 ENDIF 329 DO jl = 1, ipl; DO jk = 1, ipk 330 DO jj = 1, nn_hls 331 ijj = jpj-jj+1 332 DO ji = 1, endloop 333 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2 334 ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf) 335 END DO 336 END DO 337 END DO; END DO 338 IF(nimpp + jpi - 1 .eq. jpiglo) THEN 339 DO jl = 1, ipl; DO jk = 1, ipk 340 DO jj = 1, nn_hls 341 ijj = jpj-jj+1 342 DO ii = 1, nn_hls 343 iij = jpi-ii+1 344 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) 345 END DO 346 END DO 292 347 END DO; END DO 293 348 ENDIF … … 295 350 CASE ( 'V' ) ! V-point 296 351 DO jl = 1, ipl; DO jk = 1, ipk 297 DO ji = 1, nlci 298 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 299 ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf) 352 DO jj = 1, nn_hls 353 ijj = jpj -jj +1 354 DO ji = 1, jpi 355 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 356 ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf) 357 END DO 300 358 END DO 301 359 END DO; END DO 302 360 303 361 IF ( .NOT. l_fast_exchanges ) THEN 304 IF( nimpp >= jpiglo/2+1) THEN362 IF( nimpp >= Ni0glo/2+2 ) THEN 305 363 startloop = 1 306 ELSEIF( nimpp+ nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1) THEN307 startloop = jpiglo/2+1 - nimpp + 1308 ELSE 309 startloop = nlci + 1310 ENDIF 311 IF( startloop <= nlci ) THEN312 DO jl = 1, ipl; DO jk = 1, ipk 313 DO ji = startloop, nlci314 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3315 ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjp1,jk,jl,jf)316 END DO364 ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN 365 startloop = Ni0glo/2+2 - nimpp + nn_hls 366 ELSE 367 startloop = jpi + 1 368 ENDIF 369 IF( startloop <= jpi ) THEN 370 DO jl = 1, ipl; DO jk = 1, ipk 371 DO ji = startloop, jpi 372 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 373 ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,nn_hls+1,jk,jl,jf) 374 END DO 317 375 END DO; END DO 318 376 ENDIF … … 320 378 ! 321 379 CASE ( 'F' ) ! F-point 322 IF( nimpp + nlci - 1 /= jpiglo ) THEN323 endloop = nlci380 IF( nimpp + jpi - 1 /= jpiglo ) THEN 381 endloop = jpi 324 382 ELSE 325 endloop = nlci - 1 326 ENDIF 327 DO jl = 1, ipl; DO jk = 1, ipk 328 DO ji = 1, endloop 329 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 330 ARRAY_IN(ji,nlcj ,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf) 331 END DO 332 END DO; END DO 333 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 334 DO jl = 1, ipl; DO jk = 1, ipk 335 ARRAY_IN(nlci,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(nlci-2,nlcj-2,jk,jl,jf) 336 END DO; END DO 337 ENDIF 338 ! 339 IF ( .NOT. l_fast_exchanges ) THEN 340 IF( nimpp + nlci - 1 /= jpiglo ) THEN 341 endloop = nlci 342 ELSE 343 endloop = nlci - 1 344 ENDIF 345 IF( nimpp >= jpiglo/2+1 ) THEN 346 startloop = 1 347 ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 348 startloop = jpiglo/2+1 - nimpp + 1 383 endloop = jpi - nn_hls 384 ENDIF 385 DO jl = 1, ipl; DO jk = 1, ipk 386 DO jj = 1, nn_hls 387 ijj = jpj -jj +1 388 DO ji = 1, endloop 389 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2 390 ARRAY_IN(ji,ijj ,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf) 391 END DO 392 END DO 393 END DO; END DO 394 IF((nimpp + jpi - 1) .eq. jpiglo) THEN 395 DO jl = 1, ipl; DO jk = 1, ipk 396 DO jj = 1, nn_hls 397 ijj = jpj -jj +1 398 DO ii = 1, nn_hls 399 iij = jpi -ii+1 400 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) 401 END DO 402 END DO 403 END DO; END DO 404 ENDIF 405 ! 406 IF ( .NOT. l_fast_exchanges ) THEN 407 IF( nimpp + jpi - 1 /= jpiglo ) THEN 408 endloop = jpi 409 ELSE 410 endloop = jpi - nn_hls 411 ENDIF 412 IF( nimpp >= Ni0glo/2+2 ) THEN 413 startloop = 1 414 ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN 415 startloop = Ni0glo/2+2 - nimpp + nn_hls 349 416 ELSE 350 417 startloop = endloop + 1 … … 353 420 DO jl = 1, ipl; DO jk = 1, ipk 354 421 DO ji = startloop, endloop 355 iju = jpiglo - ji - nimpp - nfi impp(isendto(1),jpnj) + 2356 ARRAY_IN(ji, nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjp1,jk,jl,jf)422 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2 423 ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,nn_hls+1,jk,jl,jf) 357 424 END DO 358 425 END DO; END DO -
NEMO/trunk/src/OCE/LBC/lbcnfd.F90
r13226 r13286 70 70 71 71 INTEGER, PUBLIC, PARAMETER :: jpmaxngh = 3 !: 72 INTEGER, PUBLIC :: nsndto , nfsloop, nfeloop!:72 INTEGER, PUBLIC :: nsndto !: 73 73 INTEGER, PUBLIC, DIMENSION (jpmaxngh) :: isendto !: processes to which communicate 74 INTEGER, PUBLIC :: ijpj 74 75 75 76 !!---------------------------------------------------------------------- -
NEMO/trunk/src/OCE/LBC/lib_mpp.F90
r13226 r13286 1098 1098 ! Look for how many procs on the northern boundary 1099 1099 ndim_rank_north = 0 1100 DO jjproc = 1, jpni j1101 IF( n jmppt(jjproc) == njmppmax) ndim_rank_north = ndim_rank_north + 11100 DO jjproc = 1, jpni 1101 IF( nfproc(jjproc) /= -1 ) ndim_rank_north = ndim_rank_north + 1 1102 1102 END DO 1103 1103 ! … … 1109 1109 ! Note : the rank start at 0 in MPI 1110 1110 ii = 0 1111 DO ji = 1, jpni j1112 IF ( n jmppt(ji) == njmppmax) THEN1111 DO ji = 1, jpni 1112 IF ( nfproc(ji) /= -1 ) THEN 1113 1113 ii=ii+1 1114 nrank_north(ii)= ji-11114 nrank_north(ii)=nfproc(ji) 1115 1115 END IF 1116 1116 END DO -
NEMO/trunk/src/OCE/LBC/mpp_lbc_north_icb_generic.h90
r13226 r13286 36 36 ! 37 37 INTEGER :: ji, jj, jr 38 INTEGER :: ierr, itaille , ildi, ilei, iilb39 INTEGER :: ipj, ij, iproc 38 INTEGER :: ierr, itaille 39 INTEGER :: ipj, ij, iproc, ijnr, ii1, ipi, impp 40 40 ! 41 41 REAL(PRECISION), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e … … 47 47 ALLOCATE( ztab_e(jpiglo, 1-kextj:ipj+kextj) , & 48 48 & znorthloc_e(jpimax, 1-kextj:ipj+kextj) , & 49 & znorthgloio_e(jpimax, 1-kextj:ipj+kextj, jpni) )49 & znorthgloio_e(jpimax, 1-kextj:ipj+kextj,ndim_rank_north) ) 50 50 ! 51 51 # if defined SINGLE_PRECISION … … 73 73 IF( ln_timing ) CALL tic_tac(.FALSE.) 74 74 ! 75 ijnr = 0 75 76 DO jr = 1, ndim_rank_north ! recover the global north array 76 iproc = nrank_north(jr) + 1 77 ildi = nldit (iproc) 78 ilei = nleit (iproc) 79 iilb = nimppt(iproc) 80 DO jj = 1-kextj, ipj+kextj 81 DO ji = ildi, ilei 82 ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr) 77 iproc = nfproc(jr) 78 IF( iproc /= -1 ) THEN 79 impp = nfimpp(jr) 80 ipi = nfjpi(jr) 81 ijnr = ijnr + 1 82 DO jj = 1-kextj, ipj+kextj 83 DO ji = 1, ipi 84 ii1 = impp + ji - 1 ! corresponds to mig(ji) but for subdomain iproc 85 ztab_e(ii1,jj) = znorthgloio_e(ji,jj,ijnr) 86 END DO 83 87 END DO 84 END DO88 ENDIF 85 89 END DO 86 90 -
NEMO/trunk/src/OCE/LBC/mpp_lnk_generic.h90
r13226 r13286 72 72 73 73 #if defined MULTI 74 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv , ihlcom)74 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv ) 75 75 INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays 76 76 #else 77 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn , kfillmode, pfillval, lsend, lrecv , ihlcom)77 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn , kfillmode, pfillval, lsend, lrecv ) 78 78 #endif 79 79 ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied … … 84 84 REAL(wp), OPTIONAL, INTENT(in ) :: pfillval ! background value (used at closed boundaries) 85 85 LOGICAL, DIMENSION(4),OPTIONAL, INTENT(in ) :: lsend, lrecv ! communication with other 4 proc 86 INTEGER ,OPTIONAL, INTENT(in ) :: ihlcom ! number of ranks and rows to be communicated87 86 ! 88 87 INTEGER :: ji, jj, jk, jl, jf ! dummy loop indices … … 92 91 INTEGER :: ierr 93 92 INTEGER :: ifill_we, ifill_ea, ifill_so, ifill_no 94 INTEGER :: ihl ! number of ranks and rows to be communicated 95 REAL(PRECISION) :: zland 93 REAL(wp) :: zland 96 94 INTEGER , DIMENSION(MPI_STATUS_SIZE) :: istat ! for mpi_isend 97 95 REAL(PRECISION), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_we, zrcv_we, zsnd_ea, zrcv_ea ! east -west & west - east halos … … 109 107 ipl = L_SIZE(ptab) ! 4th - 110 108 ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers) 111 !112 IF( PRESENT(ihlcom) ) THEN ; ihl = ihlcom113 ELSE ; ihl = 1114 END IF115 109 ! 116 110 IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. ) … … 175 169 ! 176 170 ! Must exchange the whole column (from 1 to jpj) to get the corners if we have no south/north neighbourg 177 isize = ihl* jpj * ipk * ipl * ipf171 isize = nn_hls * jpj * ipk * ipl * ipf 178 172 ! 179 173 ! Allocate local temporary arrays to be sent/received. Fill arrays to be sent 180 IF( llsend_we ) ALLOCATE( zsnd_we( ihl,jpj,ipk,ipl,ipf) )181 IF( llsend_ea ) ALLOCATE( zsnd_ea( ihl,jpj,ipk,ipl,ipf) )182 IF( llrecv_we ) ALLOCATE( zrcv_we( ihl,jpj,ipk,ipl,ipf) )183 IF( llrecv_ea ) ALLOCATE( zrcv_ea( ihl,jpj,ipk,ipl,ipf) )174 IF( llsend_we ) ALLOCATE( zsnd_we(nn_hls,jpj,ipk,ipl,ipf) ) 175 IF( llsend_ea ) ALLOCATE( zsnd_ea(nn_hls,jpj,ipk,ipl,ipf) ) 176 IF( llrecv_we ) ALLOCATE( zrcv_we(nn_hls,jpj,ipk,ipl,ipf) ) 177 IF( llrecv_ea ) ALLOCATE( zrcv_ea(nn_hls,jpj,ipk,ipl,ipf) ) 184 178 ! 185 179 IF( llsend_we ) THEN ! copy western side of the inner mpi domain in local temporary array to be sent by MPI 186 ishift = ihl187 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl188 zsnd_we(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf) ! ihl + 1 -> 2*ihl180 ishift = nn_hls 181 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 182 zsnd_we(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf) ! nn_hls + 1 -> 2*nn_hls 189 183 END DO ; END DO ; END DO ; END DO ; END DO 190 184 ENDIF 191 185 ! 192 186 IF(llsend_ea ) THEN ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI 193 ishift = jpi - 2 * ihl194 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl195 zsnd_ea(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf) ! jpi - 2* ihl + 1 -> jpi - ihl187 ishift = jpi - 2 * nn_hls 188 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 189 zsnd_ea(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf) ! jpi - 2*nn_hls + 1 -> jpi - nn_hls 196 190 END DO ; END DO ; END DO ; END DO ; END DO 197 191 ENDIF … … 215 209 ! 2.1 fill weastern halo 216 210 ! ---------------------- 217 ! ishift = 0 ! fill halo from ji = 1 to ihl211 ! ishift = 0 ! fill halo from ji = 1 to nn_hls 218 212 SELECT CASE ( ifill_we ) 219 213 CASE ( jpfillnothing ) ! no filling 220 214 CASE ( jpfillmpi ) ! use data received by MPI 221 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl222 ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_we(ji,jj,jk,jl,jf) ! 1 -> ihl223 END DO ; END DO ; END DO ; END DO ; END DO215 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 216 ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_we(ji,jj,jk,jl,jf) ! 1 -> nn_hls 217 END DO ; END DO ; END DO ; END DO ; END DO 224 218 CASE ( jpfillperio ) ! use east-weast periodicity 225 ishift2 = jpi - 2 * ihl226 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl219 ishift2 = jpi - 2 * nn_hls 220 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 227 221 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf) 228 END DO ; END DO ; END DO ; END DO ; END DO222 END DO ; END DO ; END DO ; END DO ; END DO 229 223 CASE ( jpfillcopy ) ! filling with inner domain values 230 DO jf = 1, ipf ! number of arrays to be treated 231 IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point 232 DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl 233 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ihl+1,jj,jk,jl,jf) 234 END DO ; END DO ; END DO ; END DO 235 ENDIF 236 END DO 224 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 225 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(nn_hls+1,jj,jk,jl,jf) 226 END DO ; END DO ; END DO ; END DO ; END DO 237 227 CASE ( jpfillcst ) ! filling with constant value 238 DO jf = 1, ipf ! number of arrays to be treated 239 IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point 240 DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl 241 ARRAY_IN(ji,jj,jk,jl,jf) = zland 242 END DO; END DO ; END DO ; END DO 243 ENDIF 244 END DO 228 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 229 ARRAY_IN(ji,jj,jk,jl,jf) = zland 230 END DO ; END DO ; END DO ; END DO ; END DO 245 231 END SELECT 246 232 ! 247 233 ! 2.2 fill eastern halo 248 234 ! --------------------- 249 ishift = jpi - ihl ! fill halo from ji = jpi-ihl+1 to jpi235 ishift = jpi - nn_hls ! fill halo from ji = jpi-nn_hls+1 to jpi 250 236 SELECT CASE ( ifill_ea ) 251 237 CASE ( jpfillnothing ) ! no filling 252 238 CASE ( jpfillmpi ) ! use data received by MPI 253 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl254 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zrcv_ea(ji,jj,jk,jl,jf) ! jpi - ihl+ 1 -> jpi239 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 240 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zrcv_ea(ji,jj,jk,jl,jf) ! jpi - nn_hls + 1 -> jpi 255 241 END DO ; END DO ; END DO ; END DO ; END DO 256 242 CASE ( jpfillperio ) ! use east-weast periodicity 257 ishift2 = ihl258 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl243 ishift2 = nn_hls 244 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 259 245 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf) 260 246 END DO ; END DO ; END DO ; END DO ; END DO 261 247 CASE ( jpfillcopy ) ! filling with inner domain values 262 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl248 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 263 249 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift,jj,jk,jl,jf) 264 250 END DO ; END DO ; END DO ; END DO ; END DO 265 251 CASE ( jpfillcst ) ! filling with constant value 266 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl252 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 267 253 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zland 268 END DO ; END DO ; END DO ; END DO ; END DO254 END DO ; END DO ; END DO ; END DO ; END DO 269 255 END SELECT 270 256 ! … … 278 264 ! 279 265 SELECT CASE ( jpni ) 280 CASE ( 1 ) ; CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! only 1 northern proc, no mpp281 CASE DEFAULT ; CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! for all northern procs.266 CASE ( 1 ) ; CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! only 1 northern proc, no mpp 267 CASE DEFAULT ; CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:), ifill_no, zland OPT_K(:) ) ! for all northern procs. 282 268 END SELECT 283 269 ! … … 290 276 ! ---------------------------------------------------- ! 291 277 ! 292 IF( llsend_so ) ALLOCATE( zsnd_so(jpi, ihl,ipk,ipl,ipf) )293 IF( llsend_no ) ALLOCATE( zsnd_no(jpi, ihl,ipk,ipl,ipf) )294 IF( llrecv_so ) ALLOCATE( zrcv_so(jpi, ihl,ipk,ipl,ipf) )295 IF( llrecv_no ) ALLOCATE( zrcv_no(jpi, ihl,ipk,ipl,ipf) )296 ! 297 isize = jpi * ihl* ipk * ipl * ipf278 IF( llsend_so ) ALLOCATE( zsnd_so(jpi,nn_hls,ipk,ipl,ipf) ) 279 IF( llsend_no ) ALLOCATE( zsnd_no(jpi,nn_hls,ipk,ipl,ipf) ) 280 IF( llrecv_so ) ALLOCATE( zrcv_so(jpi,nn_hls,ipk,ipl,ipf) ) 281 IF( llrecv_no ) ALLOCATE( zrcv_no(jpi,nn_hls,ipk,ipl,ipf) ) 282 ! 283 isize = jpi * nn_hls * ipk * ipl * ipf 298 284 299 285 ! allocate local temporary arrays to be sent/received. Fill arrays to be sent 300 286 IF( llsend_so ) THEN ! copy sourhern side of the inner mpi domain in local temporary array to be sent by MPI 301 ishift = ihl302 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl; DO ji = 1, jpi303 zsnd_so(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf) ! ihl+1 -> 2*ihl287 ishift = nn_hls 288 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 289 zsnd_so(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf) ! nn_hls+1 -> 2*nn_hls 304 290 END DO ; END DO ; END DO ; END DO ; END DO 305 291 ENDIF 306 292 ! 307 293 IF( llsend_no ) THEN ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI 308 ishift = jpj - 2 * ihl309 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl; DO ji = 1, jpi310 zsnd_no(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf) ! jpj-2* ihl+1 -> jpj-ihl294 ishift = jpj - 2 * nn_hls 295 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 296 zsnd_no(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf) ! jpj-2*nn_hls+1 -> jpj-nn_hls 311 297 END DO ; END DO ; END DO ; END DO ; END DO 312 298 ENDIF … … 329 315 ! 5.1 fill southern halo 330 316 ! ---------------------- 331 ! ishift = 0 ! fill halo from jj = 1 to ihl317 ! ishift = 0 ! fill halo from jj = 1 to nn_hls 332 318 SELECT CASE ( ifill_so ) 333 319 CASE ( jpfillnothing ) ! no filling 334 320 CASE ( jpfillmpi ) ! use data received by MPI 335 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl; DO ji = 1, jpi336 ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_so(ji,jj,jk,jl,jf) ! 1 -> ihl337 END DO ; END DO ; END DO ; END DO ; END DO321 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 322 ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_so(ji,jj,jk,jl,jf) ! 1 -> nn_hls 323 END DO ; END DO ; END DO ; END DO ; END DO 338 324 CASE ( jpfillperio ) ! use north-south periodicity 339 ishift2 = jpj - 2 * ihl340 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl; DO ji = 1, jpi325 ishift2 = jpj - 2 * nn_hls 326 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 341 327 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf) 342 END DO ; END DO ; END DO ; END DO ; END DO328 END DO ; END DO ; END DO ; END DO ; END DO 343 329 CASE ( jpfillcopy ) ! filling with inner domain values 344 DO jf = 1, ipf ! number of arrays to be treated 345 IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point 346 DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi 347 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ihl+1,jk,jl,jf) 348 END DO ; END DO ; END DO ; END DO 349 ENDIF 350 END DO 330 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 331 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,nn_hls+1,jk,jl,jf) 332 END DO ; END DO ; END DO ; END DO ; END DO 351 333 CASE ( jpfillcst ) ! filling with constant value 352 DO jf = 1, ipf ! number of arrays to be treated 353 IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point 354 DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi 355 ARRAY_IN(ji,jj,jk,jl,jf) = zland 356 END DO; END DO ; END DO ; END DO 357 ENDIF 358 END DO 334 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 335 ARRAY_IN(ji,jj,jk,jl,jf) = zland 336 END DO ; END DO ; END DO ; END DO ; END DO 359 337 END SELECT 360 338 ! 361 339 ! 5.2 fill northern halo 362 340 ! ---------------------- 363 ishift = jpj - ihl ! fill halo from jj = jpj-ihl+1 to jpj341 ishift = jpj - nn_hls ! fill halo from jj = jpj-nn_hls+1 to jpj 364 342 SELECT CASE ( ifill_no ) 365 343 CASE ( jpfillnothing ) ! no filling 366 344 CASE ( jpfillmpi ) ! use data received by MPI 367 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl; DO ji = 1, jpi368 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zrcv_no(ji,jj,jk,jl,jf) ! jpj- ihl+1 -> jpj345 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 346 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zrcv_no(ji,jj,jk,jl,jf) ! jpj-nn_hls+1 -> jpj 369 347 END DO ; END DO ; END DO ; END DO ; END DO 370 348 CASE ( jpfillperio ) ! use north-south periodicity 371 ishift2 = ihl372 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl; DO ji = 1, jpi349 ishift2 = nn_hls 350 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 373 351 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf) 374 END DO ; END DO ; END DO ; END DO ; END DO352 END DO ; END DO ; END DO ; END DO ; END DO 375 353 CASE ( jpfillcopy ) ! filling with inner domain values 376 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl; DO ji = 1, jpi354 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 377 355 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift,jk,jl,jf) 378 END DO ; END DO ; END DO ; END DO ; END DO356 END DO ; END DO ; END DO ; END DO ; END DO 379 357 CASE ( jpfillcst ) ! filling with constant value 380 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl; DO ji = 1, jpi358 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 381 359 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zland 382 END DO ; END DO ; END DO ; END DO ; END DO360 END DO ; END DO ; END DO ; END DO ; END DO 383 361 END SELECT 384 362 ! … … 410 388 ! 411 389 END SUBROUTINE ROUTINE_LNK 412 390 #undef PRECISION 391 #undef SENDROUTINE 392 #undef RECVROUTINE 413 393 #undef ARRAY_TYPE 414 394 #undef NAT_IN -
NEMO/trunk/src/OCE/LBC/mpp_lnk_icb_generic.h90
r13226 r13286 105 105 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 106 106 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 107 iihom = jpi -nreci-kexti107 iihom = jpi - (2 * nn_hls) -kexti 108 108 DO jl = 1, ipreci 109 109 r2dew(:,jl,1) = pt2d(nn_hls+jl,:) … … 165 165 ! 166 166 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 167 ijhom = jpj -nrecj-kextj167 ijhom = jpj - (2 * nn_hls) - kextj 168 168 DO jl = 1, iprecj 169 169 r2dsn(:,jl,1) = pt2d(:,ijhom +jl) -
NEMO/trunk/src/OCE/LBC/mpp_loc_generic.h90
r13226 r13286 109 109 #undef PRECISION 110 110 #undef ARRAY_TYPE 111 #undef MA X_TYPE111 #undef MASK_TYPE 112 112 #undef ARRAY_IN 113 113 #undef MASK_IN -
NEMO/trunk/src/OCE/LBC/mpp_nfd_generic.h90
r13226 r13286 74 74 # endif 75 75 76 SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kf ld )76 SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kfillmode, pfillval, kfld ) 77 77 !!---------------------------------------------------------------------- 78 78 ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied 79 79 CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points 80 80 REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary 81 INTEGER , INTENT(in ) :: kfillmode ! filling method for halo over land 82 REAL(wp) , INTENT(in ) :: pfillval ! background value (used at closed boundaries) 81 83 INTEGER, OPTIONAL, INTENT(in ) :: kfld ! number of pt3d arrays 82 84 ! 85 LOGICAL :: ll_add_line 83 86 INTEGER :: ji, jj, jk, jl, jh, jf, jr ! dummy loop indices 84 INTEGER :: ipi, ipj, ip k, ipl, ipf! dimension of the input array87 INTEGER :: ipi, ipj, ipj2, ipk, ipl, ipf ! dimension of the input array 85 88 INTEGER :: imigr, iihom, ijhom ! local integers 86 INTEGER :: ierr, ibuffsize, ilci, ildi, ilei, iilb 87 INTEGER :: ij, iproc 89 INTEGER :: ierr, ibuffsize, iis0, iie0, impp 90 INTEGER :: ii1, ii2, ij1, ij2 91 INTEGER :: ipimax, i0max 92 INTEGER :: ij, iproc, ipni, ijnr 88 93 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf ! for mpi_isend when avoiding mpi_allgather 89 94 INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather 90 95 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for mpi_isend when avoiding mpi_allgather 91 96 ! ! Workspace for message transfers avoiding mpi_allgather 92 INTEGER :: ip f_j! sum of lines for all multi fields93 INTEGER :: js ! counter94 INTEGER , DIMENSION(:,:),ALLOCATABLE :: jj_s ! position of sent lines95 INTEGER , DIMENSION(:), ALLOCATABLE :: ipj_s ! number of sentlines96 REAL(PRECISION), DIMENSION(:,:,:) , ALLOCATABLE :: ztabl97 REAL(PRECISION), DIMENSION(:,:,:,: ,:) , ALLOCATABLE :: ztab, ztabr98 REAL(PRECISION), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: z northloc, zfoldwk99 REAL(PRECISION), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: znorthglo io97 INTEGER :: ipj_b ! sum of lines for all multi fields 98 INTEGER :: i012 ! 0, 1 or 2 99 INTEGER , DIMENSION(:,:) , ALLOCATABLE :: jj_s ! position of sent lines 100 INTEGER , DIMENSION(:,:) , ALLOCATABLE :: jj_b ! position of buffer lines 101 INTEGER , DIMENSION(:) , ALLOCATABLE :: ipj_s ! number of sent lines 102 REAL(PRECISION), DIMENSION(:,:,:,:) , ALLOCATABLE :: ztabb, ztabr, ztabw ! buffer, receive and work arrays 103 REAL(PRECISION), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: ztabglo, znorthloc 104 REAL(PRECISION), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: znorthglo 100 105 !!---------------------------------------------------------------------- 101 106 ! … … 106 111 IF( l_north_nogather ) THEN !== no allgather exchanges ==! 107 112 108 ALLOCATE(ipj_s(ipf)) 109 110 ipj = 2 ! Max 2nd dimension of message transfers (last two j-line only) 111 ipj_s(:) = 1 ! Real 2nd dimension of message transfers (depending on perf requirement) 112 ! by default, only one line is exchanged 113 114 ALLOCATE( jj_s(ipf,2) ) 115 116 ! re-define number of exchanged lines : 117 ! must be two during the first two time steps 118 ! to correct possible incoherent values on North fold lines from restart 119 113 ! --- define number of exchanged lines --- 114 ! 115 ! In theory we should exchange only nn_hls lines. 116 ! 117 ! However, some other points are duplicated in the north pole folding: 118 ! - jperio=[34], grid=T : half of the last line (jpiglo/2+2:jpiglo-nn_hls) 119 ! - jperio=[34], grid=U : half of the last line (jpiglo/2+1:jpiglo-nn_hls) 120 ! - jperio=[34], grid=V : all the last line nn_hls+1 and (nn_hls+2:jpiglo-nn_hls) 121 ! - jperio=[34], grid=F : all the last line (nn_hls+1:jpiglo-nn_hls) 122 ! - jperio=[56], grid=T : 2 points of the last line (jpiglo/2+1 and jpglo-nn_hls) 123 ! - jperio=[56], grid=U : no points are duplicated 124 ! - jperio=[56], grid=V : half of the last line (jpiglo/2+1:jpiglo-nn_hls) 125 ! - jperio=[56], grid=F : half of the last line (jpiglo/2+1:jpiglo-nn_hls-1) 126 ! The order of the calculations may differ for these duplicated points (as, for example jj+1 becomes jj-1) 127 ! This explain why these duplicated points may have different values even if they are at the exact same location. 128 ! In consequence, we may want to force the folding on these points by setting l_full_nf_update = .TRUE. 129 ! This is slightly slower but necessary to avoid different values on identical grid points!! 130 ! 120 131 !!!!!!!!! temporary switch off this optimisation ==> force TRUE !!!!!!!! 121 132 !!!!!!!!! needed to get the same results without agrif and with agrif and no zoom !!!!!!!! 122 133 !!!!!!!!! I don't know why we must do that... !!!!!!!! 123 134 l_full_nf_update = .TRUE. 124 125 ! Two lines update (slower but necessary to avoid different values ion identical grid points 126 IF ( l_full_nf_update .OR. & ! if coupling fields 127 ( ncom_stp == nit000 .AND. .NOT. ln_rstart ) ) & ! at first time step, if not restart 128 ipj_s(:) = 2 135 ! also force it if not restart during the first 2 steps (leap frog?) 136 ll_add_line = l_full_nf_update .OR. ( ncom_stp <= nit000+1 .AND. .NOT. ln_rstart ) 137 138 ALLOCATE(ipj_s(ipf)) ! how many lines do we exchange? 139 IF( ll_add_line ) THEN 140 DO jf = 1, ipf ! Loop over the number of arrays to be processed 141 ipj_s(jf) = nn_hls + COUNT( (/ npolj == 3 .OR. npolj == 4 .OR. NAT_IN(jf) == 'V' .OR. NAT_IN(jf) == 'F' /) ) 142 END DO 143 ELSE 144 ipj_s(:) = nn_hls 145 ENDIF 146 147 ipj = MAXVAL(ipj_s(:)) ! Max 2nd dimension of message transfers 148 ipj_b = SUM( ipj_s(:)) ! Total number of lines to be exchanged 149 ALLOCATE( jj_s(ipj, ipf), jj_b(ipj, ipf) ) 129 150 130 151 ! Index of modifying lines in input 152 ij1 = 0 131 153 DO jf = 1, ipf ! Loop over the number of arrays to be processed 132 154 ! 133 155 SELECT CASE ( npolj ) 134 !135 156 CASE ( 3, 4 ) ! * North fold T-point pivot 136 !137 157 SELECT CASE ( NAT_IN(jf) ) 138 ! 139 CASE ( 'T' , 'W' ,'U' ) ! T-, U-, W-point 140 jj_s(jf,1) = nlcj - 2 ; jj_s(jf,2) = nlcj - 1 141 CASE ( 'V' , 'F' ) ! V-, F-point 142 jj_s(jf,1) = nlcj - 3 ; jj_s(jf,2) = nlcj - 2 158 CASE ( 'T', 'W', 'U' ) ; i012 = 1 ! T-, U-, W-point 159 CASE ( 'V', 'F' ) ; i012 = 2 ! V-, F-point 143 160 END SELECT 144 ! 145 CASE ( 5, 6 ) ! * North fold F-point pivot 161 CASE ( 5, 6 ) ! * North fold F-point pivot 146 162 SELECT CASE ( NAT_IN(jf) ) 147 ! 148 CASE ( 'T' , 'W' ,'U' ) ! T-, U-, W-point 149 jj_s(jf,1) = nlcj - 1 150 ipj_s(jf) = 1 ! need only one line anyway 151 CASE ( 'V' , 'F' ) ! V-, F-point 152 jj_s(jf,1) = nlcj - 2 ; jj_s(jf,2) = nlcj - 1 163 CASE ( 'T', 'W', 'U' ) ; i012 = 0 ! T-, U-, W-point 164 CASE ( 'V', 'F' ) ; i012 = 1 ! V-, F-point 153 165 END SELECT 154 !155 166 END SELECT 156 ! 157 ENDDO 158 ! 159 ipf_j = sum (ipj_s(:)) ! Total number of lines to be exchanged 160 ! 161 ALLOCATE( znorthloc(jpimax,ipf_j,ipk,ipl,1) ) 162 ! 163 js = 0 164 DO jf = 1, ipf ! Loop over the number of arrays to be processed 167 ! 165 168 DO jj = 1, ipj_s(jf) 166 js = js + 1 167 DO jl = 1, ipl 168 DO jk = 1, ipk 169 znorthloc(1:jpi,js,jk,jl,1) = ARRAY_IN(1:jpi,jj_s(jf,jj),jk,jl,jf) 170 END DO 171 END DO 169 ij1 = ij1 + 1 170 jj_b(jj,jf) = ij1 171 jj_s(jj,jf) = jpj - 2*nn_hls + jj - i012 172 172 END DO 173 ! 173 174 END DO 174 175 ! 175 ibuffsize = jpimax * ipf_j * ipk * ipl 176 ! 177 ALLOCATE( zfoldwk(jpimax,ipf_j,ipk,ipl,1) ) 178 ALLOCATE( ztabr(jpimax*jpmaxngh,ipj,ipk,ipl,ipf) ) 179 ! when some processors of the north fold are suppressed, 180 ! values of ztab* arrays corresponding to these suppressed domain won't be defined 181 ! and we need a default definition to 0. 182 ! a better test should be: a testing if "suppressed land-processors" belongs to the north-pole folding 183 IF ( jpni*jpnj /= jpnij ) ztabr(:,:,:,:,:) = 0._wp 176 ALLOCATE( ztabb(jpimax,ipj_b,ipk,ipl) ) ! store all the data to be sent in a buffer array 177 ibuffsize = jpimax * ipj_b * ipk * ipl 178 ! 179 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk 180 DO jj = 1, ipj_s(jf) 181 ij1 = jj_b(jj,jf) 182 ij2 = jj_s(jj,jf) 183 DO ji = 1, jpi 184 ztabb(ji,ij1,jk,jl) = ARRAY_IN(ji,ij2,jk,jl,jf) 185 END DO 186 DO ji = jpi+1, jpimax 187 ztabb(ji,ij1,jk,jl) = HUGE(0._wp) ! avoid sending uninitialized values (make sure we don't use it) 188 END DO 189 END DO 190 END DO ; END DO ; END DO 184 191 ! 185 192 ! start waiting time measurement 186 193 IF( ln_timing ) CALL tic_tac(.TRUE.) 187 194 ! 195 ! send the data as soon as possible 188 196 DO jr = 1, nsndto 189 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 190 CALL SENDROUTINE( 5, znorthloc, ibuffsize, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) ) 197 iproc = nfproc(isendto(jr)) 198 IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 199 CALL SENDROUTINE( 5, ztabb, ibuffsize, iproc, ml_req_nf(jr) ) 191 200 ENDIF 192 201 END DO 193 202 ! 203 ipimax = jpimax * jpmaxngh 204 ALLOCATE( ztabw(jpimax,ipj_b,ipk,ipl), ztabr(ipimax,ipj_b,ipk,ipl) ) 205 ! 206 DO jr = 1, nsndto 207 ! 208 ipni = isendto(jr) 209 iproc = nfproc(ipni) 210 ipi = nfjpi (ipni) 211 ! 212 IF( ipni == 1 ) THEN ; iis0 = 1 ! domain left side: as e-w comm already done -> from 1st column 213 ELSE ; iis0 = 1 + nn_hls ! default: -> from inner domain 214 ENDIF 215 IF( ipni == jpni ) THEN ; iie0 = ipi ! domain right side: as e-w comm already done -> until last column 216 ELSE ; iie0 = ipi - nn_hls ! default: -> until inner domain 217 ENDIF 218 impp = nfimpp(ipni) - nfimpp(isendto(1)) 219 ! 220 IF( iproc == -1 ) THEN ! No neighbour (land proc that was suppressed) 221 ! 222 SELECT CASE ( kfillmode ) 223 CASE ( jpfillnothing ) ! no filling 224 CASE ( jpfillcopy ) ! filling with inner domain values 225 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk 226 DO jj = 1, ipj_s(jf) 227 ij1 = jj_b(jj,jf) 228 ij2 = jj_s(jj,jf) 229 DO ji = iis0, iie0 230 ztabr(impp+ji,ij1,jk,jl) = ARRAY_IN(Nis0,ij2,jk,jl,jf) ! chose to take the 1st iner domain point 231 END DO 232 END DO 233 END DO ; END DO ; END DO 234 CASE ( jpfillcst ) ! filling with constant value 235 DO jl = 1, ipl ; DO jk = 1, ipk 236 DO jj = 1, ipj_b 237 DO ji = iis0, iie0 238 ztabr(impp+ji,jj,jk,jl) = pfillval 239 END DO 240 END DO 241 END DO ; END DO 242 END SELECT 243 ! 244 ELSE IF( iproc == narea-1 ) THEN ! get data from myself! 245 ! 246 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk 247 DO jj = 1, ipj_s(jf) 248 ij1 = jj_b(jj,jf) 249 ij2 = jj_s(jj,jf) 250 DO ji = iis0, iie0 251 ztabr(impp+ji,ij1,jk,jl) = ARRAY_IN(ji,ij2,jk,jl,jf) 252 END DO 253 END DO 254 END DO ; END DO ; END DO 255 ! 256 ELSE ! get data from a neighbour trough communication 257 ! 258 CALL RECVROUTINE(5, ztabw, ibuffsize, iproc) 259 DO jl = 1, ipl ; DO jk = 1, ipk 260 DO jj = 1, ipj_b 261 DO ji = iis0, iie0 262 ztabr(impp+ji,jj,jk,jl) = ztabw(ji,jj,jk,jl) 263 END DO 264 END DO 265 END DO ; END DO 266 267 ENDIF 268 ! 269 END DO ! nsndto 270 ! 271 IF( ln_timing ) CALL tic_tac(.FALSE.) 272 ! 273 ! North fold boundary condition 274 ! 275 DO jf = 1, ipf 276 ij1 = jj_b( 1 ,jf) 277 ij2 = jj_b(ipj_s(jf),jf) 278 CALL lbc_nfd_nogather( ARRAY_IN(:,:,:,:,jf), ztabr(:,ij1:ij2,:,:), cd_nat LBC_ARG, psgn LBC_ARG ) 279 END DO 280 ! 281 DEALLOCATE( ztabr, ztabw, jj_s, jj_b, ipj_s ) 282 ! 194 283 DO jr = 1,nsndto 195 iproc = nfipproc(isendto(jr),jpnj) 196 IF(iproc /= -1) THEN 197 iilb = nimppt(iproc+1) 198 ilci = nlcit (iproc+1) 199 ildi = nldit (iproc+1) 200 ilei = nleit (iproc+1) 201 IF( iilb == 1 ) ildi = 1 ! e-w boundary already done -> force to take 1st column 202 IF( iilb + ilci - 1 == jpiglo ) ilei = ilci ! e-w boundary already done -> force to take last column 203 iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 204 ENDIF 284 iproc = nfproc(isendto(jr)) 205 285 IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 206 CALL RECVROUTINE(5, zfoldwk, ibuffsize, iproc) 207 js = 0 208 DO jf = 1, ipf ; DO jj = 1, ipj_s(jf) 209 js = js + 1 210 DO jl = 1, ipl 211 DO jk = 1, ipk 212 DO ji = ildi, ilei 213 ztabr(iilb+ji,jj,jk,jl,jf) = zfoldwk(ji,js,jk,jl,1) 214 END DO 215 END DO 216 END DO 217 END DO; END DO 218 ELSE IF( iproc == narea-1 ) THEN 219 DO jf = 1, ipf ; DO jj = 1, ipj_s(jf) 220 DO jl = 1, ipl 221 DO jk = 1, ipk 222 DO ji = ildi, ilei 223 ztabr(iilb+ji,jj,jk,jl,jf) = ARRAY_IN(ji,jj_s(jf,jj),jk,jl,jf) 224 END DO 225 END DO 226 END DO 227 END DO; END DO 286 CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err ) ! put the wait at the very end just before the deallocate 228 287 ENDIF 229 288 END DO 230 DO jr = 1,nsndto 231 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 232 CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err ) 233 ENDIF 234 END DO 235 ! 236 IF( ln_timing ) CALL tic_tac(.FALSE.) 237 ! 238 ! North fold boundary condition 239 ! 240 DO jf = 1, ipf 241 CALL lbc_nfd_nogather( ARRAY_IN(:,:,:,:,jf), ztabr(:,1:ipj_s(jf),:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG ) 242 END DO 243 ! 244 DEALLOCATE( zfoldwk, ztabr, jj_s, ipj_s ) 289 DEALLOCATE( ztabb ) 245 290 ! 246 291 ELSE !== allgather exchanges ==! 247 292 ! 248 ipj = 4 ! 2nd dimension of message transfers (last j-lines) 249 ! 250 ALLOCATE( znorthloc(jpimax,ipj,ipk,ipl,ipf) ) 251 ! 252 DO jf = 1, ipf ! put in znorthloc the last ipj j-lines of ptab 253 DO jl = 1, ipl 254 DO jk = 1, ipk 255 DO jj = nlcj - ipj +1, nlcj 256 ij = jj - nlcj + ipj 257 znorthloc(1:jpi,ij,jk,jl,jf) = ARRAY_IN(1:jpi,jj,jk,jl,jf) 258 END DO 293 ! how many lines do we exchange at max? -> ipj (no further optimizations in this case...) 294 ipj = nn_hls + 2 295 ! how many lines do we need at max? -> ipj2 (no further optimizations in this case...) 296 ipj2 = 2 * nn_hls + 2 297 ! 298 i0max = jpimax - 2 * nn_hls 299 ibuffsize = i0max * ipj * ipk * ipl * ipf 300 ALLOCATE( znorthloc(i0max,ipj,ipk,ipl,ipf), znorthglo(i0max,ipj,ipk,ipl,ipf,ndim_rank_north) ) 301 ! 302 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ! put in znorthloc ipj j-lines of ptab 303 DO jj = 1, ipj 304 ij2 = jpj - ipj2 + jj ! the first ipj lines of the last ipj2 lines 305 DO ji = 1, Ni_0 306 ii2 = Nis0 - 1 + ji ! inner domain: Nis0 to Nie0 307 znorthloc(ji,jj,jk,jl,jf) = ARRAY_IN(ii2,ij2,jk,jl,jf) 308 END DO 309 DO ji = Ni_0+1, i0max 310 znorthloc(ji,jj,jk,jl,jf) = HUGE(0._wp) ! avoid sending uninitialized values (make sure we don't use it) 259 311 END DO 260 312 END DO 261 END DO 262 ! 263 ibuffsize = jpimax * ipj * ipk * ipl * ipf 264 ! 265 ALLOCATE( ztab (jpiglo,ipj,ipk,ipl,ipf ) ) 266 ALLOCATE( znorthgloio(jpimax,ipj,ipk,ipl,ipf,jpni) ) 267 ! 268 ! when some processors of the north fold are suppressed, 269 ! values of ztab* arrays corresponding to these suppressed domain won't be defined 270 ! and we need a default definition to 0. 271 ! a better test should be: a testing if "suppressed land-processors" belongs to the north-pole folding 272 IF ( jpni*jpnj /= jpnij ) ztab(:,:,:,:,:) = 0._wp 313 END DO ; END DO ; END DO 273 314 ! 274 315 ! start waiting time measurement 275 316 IF( ln_timing ) CALL tic_tac(.TRUE.) 276 CALL MPI_ALLGATHER( znorthloc , ibuffsize, MPI_TYPE, & 277 & znorthgloio, ibuffsize, MPI_TYPE, ncomm_north, ierr ) 278 ! 317 CALL MPI_ALLGATHER( znorthloc, ibuffsize, MPI_TYPE, znorthglo, ibuffsize, MPI_TYPE, ncomm_north, ierr ) 279 318 ! stop waiting time measurement 280 319 IF( ln_timing ) CALL tic_tac(.FALSE.) 281 ! 282 DO jr = 1, ndim_rank_north ! recover the global north array 283 iproc = nrank_north(jr) + 1 284 iilb = nimppt(iproc) 285 ilci = nlcit (iproc) 286 ildi = nldit (iproc) 287 ilei = nleit (iproc) 288 IF( iilb == 1 ) ildi = 1 ! e-w boundary already done -> force to take 1st column 289 IF( iilb + ilci - 1 == jpiglo ) ilei = ilci ! e-w boundary already done -> force to take last column 290 DO jf = 1, ipf 291 DO jl = 1, ipl 292 DO jk = 1, ipk 320 DEALLOCATE( znorthloc ) 321 ALLOCATE( ztabglo(jpiglo,ipj2,ipk,ipl,ipf) ) 322 ! 323 ! need to fill only the first ipj lines of ztabglo as lbc_nfd don't use the last nn_hls lines 324 ijnr = 0 325 DO jr = 1, jpni ! recover the global north array 326 iproc = nfproc(jr) 327 impp = nfimpp(jr) 328 ipi = nfjpi( jr) - 2 * nn_hls ! corresponds to Ni_0 but for subdomain iproc 329 IF( iproc == -1 ) THEN ! No neighbour (land proc that was suppressed) 330 ! 331 SELECT CASE ( kfillmode ) 332 CASE ( jpfillnothing ) ! no filling 333 CASE ( jpfillcopy ) ! filling with inner domain values 334 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk 293 335 DO jj = 1, ipj 294 DO ji = ildi, ilei 295 ztab(ji+iilb-1,jj,jk,jl,jf) = znorthgloio(ji,jj,jk,jl,jf,jr) 336 ij2 = jpj - ipj2 + jj ! the first ipj lines of the last ipj2 lines 337 DO ji = 1, ipi 338 ii1 = impp + nn_hls + ji - 1 ! corresponds to mig(nn_hls + ji) but for subdomain iproc 339 ztabglo(ii1,jj,jk,jl,jf) = ARRAY_IN(Nis0,ij2,jk,jl,jf) ! chose to take the 1st iner domain point 296 340 END DO 297 341 END DO 342 END DO ; END DO ; END DO 343 CASE ( jpfillcst ) ! filling with constant value 344 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk 345 DO jj = 1, ipj 346 DO ji = 1, ipi 347 ii1 = impp + nn_hls + ji - 1 ! corresponds to mig(nn_hls + ji) but for subdomain iproc 348 ztabglo(ii1,jj,jk,jl,jf) = pfillval 349 END DO 350 END DO 351 END DO ; END DO ; END DO 352 END SELECT 353 ! 354 ELSE 355 ijnr = ijnr + 1 356 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk 357 DO jj = 1, ipj 358 DO ji = 1, ipi 359 ii1 = impp + nn_hls + ji - 1 ! corresponds to mig(nn_hls + ji) but for subdomain iproc 360 ztabglo(ii1,jj,jk,jl,jf) = znorthglo(ji,jj,jk,jl,jf,ijnr) 361 END DO 298 362 END DO 363 END DO ; END DO ; END DO 364 ENDIF 365 ! 366 END DO ! jpni 367 DEALLOCATE( znorthglo ) 368 ! 369 DO jf = 1, ipf 370 CALL lbc_nfd( ztabglo(:,:,:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG ) ! North fold boundary condition 371 DO jl = 1, ipl ; DO jk = 1, ipk ! e-w periodicity 372 DO jj = 1, nn_hls + 1 373 ij1 = ipj2 - (nn_hls + 1) + jj ! need only the last nn_hls + 1 lines until ipj2 374 ztabglo( 1:nn_hls,ij1,jk,jl,jf) = ztabglo(jpiglo-2*nn_hls+1:jpiglo-nn_hls,ij1,jk,jl,jf) 375 ztabglo(jpiglo-nn_hls+1:jpiglo,ij1,jk,jl,jf) = ztabglo( nn_hls+1: 2*nn_hls,ij1,jk,jl,jf) 376 END DO 377 END DO ; END DO 378 END DO 379 ! 380 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ! Scatter back to ARRAY_IN 381 DO jj = 1, nn_hls + 1 382 ij1 = jpj - (nn_hls + 1) + jj ! last nn_hls + 1 lines until jpj 383 ij2 = ipj2 - (nn_hls + 1) + jj ! last nn_hls + 1 lines until ipj2 384 DO ji= 1, jpi 385 ii2 = mig(ji) 386 ARRAY_IN(ji,ij1,jk,jl,jf) = ztabglo(ii2,ij2,jk,jl,jf) 299 387 END DO 300 388 END DO 301 END DO 302 DO jf = 1, ipf 303 CALL lbc_nfd( ztab(:,:,:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG ) ! North fold boundary condition 304 END DO 305 ! 306 DO jf = 1, ipf 307 DO jl = 1, ipl 308 DO jk = 1, ipk 309 DO jj = nlcj-ipj+1, nlcj ! Scatter back to ARRAY_IN 310 ij = jj - nlcj + ipj 311 DO ji= 1, nlci 312 ARRAY_IN(ji,jj,jk,jl,jf) = ztab(ji+nimpp-1,ij,jk,jl,jf) 313 END DO 314 END DO 315 END DO 316 END DO 317 END DO 318 ! 319 ! 320 DEALLOCATE( ztab ) 321 DEALLOCATE( znorthgloio ) 322 ENDIF 323 ! 324 DEALLOCATE( znorthloc ) 389 END DO ; END DO ; END DO 390 ! 391 DEALLOCATE( ztabglo ) 392 ! 393 ENDIF ! l_north_nogather 325 394 ! 326 395 END SUBROUTINE ROUTINE_NFD -
NEMO/trunk/src/OCE/LBC/mppini.F90
r13216 r13286 8 8 !! 8.0 ! 1998-05 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI versions 9 9 !! NEMO 1.0 ! 2004-01 (G. Madec, J.M Molines) F90 : free form , north fold jpni > 1 10 !! 3.4 ! 2011-10 (A. C. Coward, NOCS & J. Donners, PRACE) add mpp_init_nfdcom11 !! 3. ! 2013-06 (I. Epicoco, S. Mocavero, CMCC) mpp_init_nfdcom: setup avoiding MPI communication10 !! 3.4 ! 2011-10 (A. C. Coward, NOCS & J. Donners, PRACE) add init_nfdcom 11 !! 3. ! 2013-06 (I. Epicoco, S. Mocavero, CMCC) init_nfdcom: setup avoiding MPI communication 12 12 !! 4.0 ! 2016-06 (G. Madec) use domain configuration file instead of bathymetry file 13 13 !! 4.0 ! 2017-06 (J.M. Molines, T. Lovato) merge of mppini and mppini_2 … … 15 15 16 16 !!---------------------------------------------------------------------- 17 !! mpp_init : Lay out the global domain over processors with/without land processor elimination 18 !! mpp_init_mask : Read global bathymetric information to facilitate land suppression 19 !! mpp_init_ioipsl : IOIPSL initialization in mpp 20 !! mpp_init_partition: Calculate MPP domain decomposition 21 !! factorise : Calculate the factors of the no. of MPI processes 22 !! mpp_init_nfdcom : Setup for north fold exchanges with explicit point-to-point messaging 17 !! mpp_init : Lay out the global domain over processors with/without land processor elimination 18 !! init_ioipsl: IOIPSL initialization in mpp 19 !! init_nfdcom: Setup for north fold exchanges with explicit point-to-point messaging 20 !! init_doloop: set the starting/ending indices of DO-loop used in do_loop_substitute 23 21 !!---------------------------------------------------------------------- 24 22 USE dom_oce ! ocean space and time domain 25 23 USE bdy_oce ! open BounDarY 26 24 ! 27 USE lbcnfd , ONLY : isendto, nsndto , nfsloop, nfeloop! Setup of north fold exchanges25 USE lbcnfd , ONLY : isendto, nsndto ! Setup of north fold exchanges 28 26 USE lib_mpp ! distribued memory computing library 29 27 USE iom ! nemo I/O library … … 34 32 PRIVATE 35 33 36 PUBLIC mpp_init ! called by opa.F90 37 38 INTEGER :: numbot = -1 ! 'bottom_level' local logical unit 39 INTEGER :: numbdy = -1 ! 'bdy_msk' local logical unit 34 PUBLIC mpp_init ! called by nemogcm.F90 35 PUBLIC mpp_getnum ! called by prtctl 36 PUBLIC mpp_basesplit ! called by prtctl 37 PUBLIC mpp_is_ocean ! called by prtctl 38 39 INTEGER :: numbot = -1 ! 'bottom_level' local logical unit 40 INTEGER :: numbdy = -1 ! 'bdy_msk' local logical unit 40 41 41 42 !!---------------------------------------------------------------------- … … 61 62 !!---------------------------------------------------------------------- 62 63 ! 64 jpiglo = Ni0glo 65 jpjglo = Nj0glo 63 66 jpimax = jpiglo 64 67 jpjmax = jpjglo … … 66 69 jpj = jpjglo 67 70 jpk = jpkglo 68 jpim1 = jpi-1 ! inner domain indices 69 jpjm1 = jpj-1 ! " " 70 jpkm1 = MAX( 1, jpk-1 ) ! " " 71 jpim1 = jpi-1 ! inner domain indices 72 jpjm1 = jpj-1 ! " " 73 jpkm1 = MAX( 1, jpk-1 ) ! " " 74 ! 75 CALL init_doloop ! set start/end indices or do-loop depending on the halo width value (nn_hls) 76 ! 71 77 jpij = jpi*jpj 72 78 jpni = 1 73 79 jpnj = 1 74 80 jpnij = jpni*jpnj 75 nimpp = 1 ! 81 nn_hls = 1 82 nimpp = 1 76 83 njmpp = 1 77 nlci = jpi78 nlcj = jpj79 nldi = 180 nldj = 181 nlei = jpi82 nlej = jpj83 84 nbondi = 2 84 85 nbondj = 2 … … 135 136 !! njmpp : latitudinal index 136 137 !! narea : number for local area 137 !! nlci : first dimension138 !! nlcj : second dimension139 138 !! nbondi : mark for "east-west local boundary" 140 139 !! nbondj : mark for "north-south local boundary" … … 147 146 INTEGER :: ji, jj, jn, jproc, jarea ! dummy loop indices 148 147 INTEGER :: inijmin 149 INTEGER :: i2add150 148 INTEGER :: inum ! local logical unit 151 INTEGER :: idir, ifreq , icont! local integers149 INTEGER :: idir, ifreq ! local integers 152 150 INTEGER :: ii, il1, ili, imil ! - - 153 151 INTEGER :: ij, il2, ilj, ijm1 ! - - … … 162 160 INTEGER, ALLOCATABLE, DIMENSION(:) :: iin, ii_nono, ii_noea ! 1D workspace 163 161 INTEGER, ALLOCATABLE, DIMENSION(:) :: ijn, ii_noso, ii_nowe ! - - 164 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iimppt, i lci, ibondi, ipproc ! 2D workspace165 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ijmppt, i lcj, ibondj, ipolj ! - -166 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: i lei, ildi, iono, ioea ! - -167 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: i lej, ildj, ioso, iowe ! - -162 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iimppt, ijpi, ibondi, ipproc ! 2D workspace 163 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ijmppt, ijpj, ibondj, ipolj ! - - 164 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iie0, iis0, iono, ioea ! - - 165 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ije0, ijs0, ioso, iowe ! - - 168 166 LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: llisoce ! - - 169 167 NAMELIST/nambdy/ ln_bdy, nb_bdy, ln_coords_file, cn_coords_file, & … … 173 171 & cn_ice, nn_ice_dta, & 174 172 & ln_vol, nn_volctl, nn_rimwidth 175 NAMELIST/nammpp/ jpni, jpnj, ln_nnogather, ln_listonly173 NAMELIST/nammpp/ jpni, jpnj, nn_hls, ln_nnogather, ln_listonly 176 174 !!---------------------------------------------------------------------- 177 175 ! … … 186 184 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nammpp in configuration namelist' ) 187 185 ! 186 nn_hls = MAX(1, nn_hls) ! nn_hls must be > 0 188 187 IF(lwp) THEN 189 188 WRITE(numout,*) ' Namelist nammpp' … … 195 194 ENDIF 196 195 WRITE(numout,*) ' avoid use of mpi_allgather at the north fold ln_nnogather = ', ln_nnogather 196 WRITE(numout,*) ' halo width (applies to both rows and columns) nn_hls = ', nn_hls 197 197 ENDIF 198 198 ! 199 199 IF(lwm) WRITE( numond, nammpp ) 200 200 ! 201 !!!------------------------------------ 202 !!! nn_hls shloud be read in nammpp 203 !!!------------------------------------ 204 jpiglo = Ni0glo + 2 * nn_hls 205 jpjglo = Nj0glo + 2 * nn_hls 206 ! 201 207 ! do we need to take into account bdy_msk? 202 208 READ ( numnam_ref, nambdy, IOSTAT = ios, ERR = 903) … … 208 214 IF( ln_bdy .AND. ln_mask_file ) CALL iom_open( cn_mask_file, numbdy ) 209 215 ! 210 IF( ln_listonly ) CALL mpp_init_bestpartition( MAX(mppsize,jpni*jpnj), ldlist = .TRUE. ) ! must be done by all core216 IF( ln_listonly ) CALL bestpartition( MAX(mppsize,jpni*jpnj), ldlist = .TRUE. ) ! must be done by all core 211 217 ! 212 218 ! 1. Dimension arrays for subdomains 213 219 ! ----------------------------------- 214 220 ! 215 ! If dimensions of processor grid weren't specified in the namelist file221 ! If dimensions of processors grid weren't specified in the namelist file 216 222 ! then we calculate them here now that we have our communicator size 217 223 IF(lwp) THEN … … 221 227 ENDIF 222 228 IF( jpni < 1 .OR. jpnj < 1 ) THEN 223 CALL mpp_init_bestpartition( mppsize, jpni, jpnj ) ! best mpi decomposition for mppsize mpi processes229 CALL bestpartition( mppsize, jpni, jpnj ) ! best mpi decomposition for mppsize mpi processes 224 230 llauto = .TRUE. 225 231 llbest = .TRUE. 226 232 ELSE 227 233 llauto = .FALSE. 228 CALL mpp_init_bestpartition( mppsize, inbi, inbj, icnt2 ) ! best mpi decomposition for mppsize mpi processes234 CALL bestpartition( mppsize, inbi, inbj, icnt2 ) ! best mpi decomposition for mppsize mpi processes 229 235 ! largest subdomain size for mpi decoposition jpni*jpnj given in the namelist 230 CALL mpp_bas ic_decomposition(jpni, jpnj, jpimax, jpjmax )231 ! largest subdomain size for mpi decoposition inbi*inbj given by mpp_init_bestpartition232 CALL mpp_bas ic_decomposition(inbi, inbj, iimax, ijmax )236 CALL mpp_basesplit( jpiglo, jpjglo, nn_hls, jpni, jpnj, jpimax, jpjmax ) 237 ! largest subdomain size for mpi decoposition inbi*inbj given by bestpartition 238 CALL mpp_basesplit( jpiglo, jpjglo, nn_hls, inbi, inbj, iimax, ijmax ) 233 239 icnt1 = jpni*jpnj - mppsize ! number of land subdomains that should be removed to use mppsize mpi processes 234 240 IF(lwp) THEN … … 261 267 ! look for land mpi subdomains... 262 268 ALLOCATE( llisoce(jpni,jpnj) ) 263 CALL mpp_i nit_isoce( jpni, jpnj,llisoce )269 CALL mpp_is_ocean( llisoce ) 264 270 inijmin = COUNT( llisoce ) ! number of oce subdomains 265 271 … … 270 276 WRITE(ctmp4,*) ' ==>>> There is the list of best domain decompositions you should use: ' 271 277 CALL ctl_stop( ctmp1, ctmp2, ctmp3, ' ', ctmp4, ' ' ) 272 CALL mpp_init_bestpartition( mppsize, ldlist = .TRUE. ) ! must be done by all core278 CALL bestpartition( mppsize, ldlist = .TRUE. ) ! must be done by all core 273 279 ENDIF 274 280 … … 294 300 WRITE(numout,*) 295 301 ENDIF 296 CALL mpp_init_bestpartition( mppsize, ldlist = .TRUE. ) ! must be done by all core302 CALL bestpartition( mppsize, ldlist = .TRUE. ) ! must be done by all core 297 303 ENDIF 298 304 … … 319 325 9003 FORMAT (a, i5) 320 326 321 IF( numbot /= -1 ) CALL iom_close( numbot ) 322 IF( numbdy /= -1 ) CALL iom_close( numbdy ) 323 324 ALLOCATE( nfiimpp(jpni,jpnj), nfipproc(jpni,jpnj), nfilcit(jpni,jpnj) , & 325 & nimppt(jpnij) , ibonit(jpnij) , nlcit(jpnij) , nlcjt(jpnij) , & 326 & njmppt(jpnij) , ibonjt(jpnij) , nldit(jpnij) , nldjt(jpnij) , & 327 & nleit(jpnij) , nlejt(jpnij) , & 327 ALLOCATE( nfimpp(jpni ) , nfproc(jpni ) , nfjpi(jpni ) , & 328 & nimppt(jpnij) , ibonit(jpnij) , jpiall(jpnij) , jpjall(jpnij) , & 329 & njmppt(jpnij) , ibonjt(jpnij) , nis0all(jpnij) , njs0all(jpnij) , & 330 & nie0all(jpnij) , nje0all(jpnij) , & 328 331 & iin(jpnij), ii_nono(jpnij), ii_noea(jpnij), & 329 332 & ijn(jpnij), ii_noso(jpnij), ii_nowe(jpnij), & 330 & iimppt(jpni,jpnj), i lci(jpni,jpnj), ibondi(jpni,jpnj), ipproc(jpni,jpnj), &331 & ijmppt(jpni,jpnj), i lcj(jpni,jpnj), ibondj(jpni,jpnj),ipolj(jpni,jpnj), &332 & ilei(jpni,jpnj), ildi(jpni,jpnj), iono(jpni,jpnj),ioea(jpni,jpnj), &333 & ilej(jpni,jpnj), ildj(jpni,jpnj), ioso(jpni,jpnj),iowe(jpni,jpnj), &333 & iimppt(jpni,jpnj), ijpi(jpni,jpnj), ibondi(jpni,jpnj), ipproc(jpni,jpnj), & 334 & ijmppt(jpni,jpnj), ijpj(jpni,jpnj), ibondj(jpni,jpnj), ipolj(jpni,jpnj), & 335 & iie0(jpni,jpnj), iis0(jpni,jpnj), iono(jpni,jpnj), ioea(jpni,jpnj), & 336 & ije0(jpni,jpnj), ijs0(jpni,jpnj), ioso(jpni,jpnj), iowe(jpni,jpnj), & 334 337 & STAT=ierr ) 335 338 CALL mpp_sum( 'mppini', ierr ) … … 345 348 ! ----------------------------------- 346 349 ! 347 nreci = 2 * nn_hls 348 nrecj = 2 * nn_hls 349 CALL mpp_basic_decomposition( jpni, jpnj, jpimax, jpjmax, iimppt, ijmppt, ilci, ilcj ) 350 nfiimpp(:,:) = iimppt(:,:) 351 nfilcit(:,:) = ilci(:,:) 350 CALL mpp_basesplit( jpiglo, jpjglo, nn_hls, jpni, jpnj, jpimax, jpjmax, iimppt, ijmppt, ijpi, ijpj ) 351 CALL mpp_getnum( llisoce, ipproc, iin, ijn ) 352 ! 353 !DO jn = 1, jpni 354 ! jproc = ipproc(jn,jpnj) 355 ! ii = iin(jproc+1) 356 ! ij = ijn(jproc+1) 357 ! nfproc(jn) = jproc 358 ! nfimpp(jn) = iimppt(ii,ij) 359 ! nfjpi (jn) = ijpi(ii,ij) 360 !END DO 361 nfproc(:) = ipproc(:,jpnj) 362 nfimpp(:) = iimppt(:,jpnj) 363 nfjpi (:) = ijpi(:,jpnj) 352 364 ! 353 365 IF(lwp) THEN … … 358 370 WRITE(numout,*) ' jpni = ', jpni 359 371 WRITE(numout,*) ' jpnj = ', jpnj 372 WRITE(numout,*) ' jpnij = ', jpnij 360 373 WRITE(numout,*) 361 WRITE(numout,*) ' sum i lci(i,1) = ', sum(ilci(:,1)), ' jpiglo = ', jpiglo362 WRITE(numout,*) ' sum i lcj(1,j) = ', sum(ilcj(1,:)), ' jpjglo = ', jpjglo374 WRITE(numout,*) ' sum ijpi(i,1) = ', sum(ijpi(:,1)), ' jpiglo = ', jpiglo 375 WRITE(numout,*) ' sum ijpj(1,j) = ', sum(ijpj(1,:)), ' jpjglo = ', jpjglo 363 376 ENDIF 364 377 … … 375 388 ii = 1 + MOD(iarea0,jpni) 376 389 ij = 1 + iarea0/jpni 377 ili = i lci(ii,ij)378 ilj = i lcj(ii,ij)390 ili = ijpi(ii,ij) 391 ilj = ijpj(ii,ij) 379 392 ibondi(ii,ij) = 0 ! default: has e-w neighbours 380 393 IF( ii == 1 ) ibondi(ii,ij) = -1 ! first column, has only e neighbour … … 391 404 ioea(ii,ij) = iarea0 + 1 392 405 iono(ii,ij) = iarea0 + jpni 393 i ldi(ii,ij) = 1 + nn_hls394 i lei(ii,ij) = ili - nn_hls395 i ldj(ii,ij) = 1 + nn_hls396 i lej(ii,ij) = ilj - nn_hls406 iis0(ii,ij) = 1 + nn_hls 407 iie0(ii,ij) = ili - nn_hls 408 ijs0(ii,ij) = 1 + nn_hls 409 ije0(ii,ij) = ilj - nn_hls 397 410 398 411 ! East-West periodicity: change ibondi, ioea, iowe … … 432 445 ! ---------------------------- 433 446 ! 434 ! specify which subdomains are oce subdomains; other are land subdomains435 ipproc(:,:) = -1436 icont = -1437 DO jarea = 1, jpni*jpnj438 iarea0 = jarea - 1439 ii = 1 + MOD(iarea0,jpni)440 ij = 1 + iarea0/jpni441 IF( llisoce(ii,ij) ) THEN442 icont = icont + 1443 ipproc(ii,ij) = icont444 iin(icont+1) = ii445 ijn(icont+1) = ij446 ENDIF447 END DO448 ! if needed add some land subdomains to reach jpnij active subdomains449 i2add = jpnij - inijmin450 DO jarea = 1, jpni*jpnj451 iarea0 = jarea - 1452 ii = 1 + MOD(iarea0,jpni)453 ij = 1 + iarea0/jpni454 IF( .NOT. llisoce(ii,ij) .AND. i2add > 0 ) THEN455 icont = icont + 1456 ipproc(ii,ij) = icont457 iin(icont+1) = ii458 ijn(icont+1) = ij459 i2add = i2add - 1460 ENDIF461 END DO462 nfipproc(:,:) = ipproc(:,:)463 464 447 ! neighbour treatment: change ibondi, ibondj if next to a land zone 465 448 DO jarea = 1, jpni*jpnj … … 500 483 ENDIF 501 484 END DO 502 503 ! Update il[de][ij] according to modified ibond[ij]504 ! ----------------------505 DO jproc = 1, jpnij506 ii = iin(jproc)507 ij = ijn(jproc)508 IF( ibondi(ii,ij) == -1 .OR. ibondi(ii,ij) == 2 ) ildi(ii,ij) = 1509 IF( ibondi(ii,ij) == 1 .OR. ibondi(ii,ij) == 2 ) ilei(ii,ij) = ilci(ii,ij)510 IF( ibondj(ii,ij) == -1 .OR. ibondj(ii,ij) == 2 ) ildj(ii,ij) = 1511 IF( ibondj(ii,ij) == 1 .OR. ibondj(ii,ij) == 2 ) ilej(ii,ij) = ilcj(ii,ij)512 END DO513 485 514 486 ! 5. Subdomain print … … 523 495 DO jj = jpnj, 1, -1 524 496 WRITE(numout,9403) (' ',ji=il1,il2-1) 525 WRITE(numout,9402) jj, (i lci(ji,jj),ilcj(ji,jj),ji=il1,il2)497 WRITE(numout,9402) jj, (ijpi(ji,jj),ijpj(ji,jj),ji=il1,il2) 526 498 WRITE(numout,9404) (ipproc(ji,jj),ji=il1,il2) 527 499 WRITE(numout,9403) (' ',ji=il1,il2-1) … … 580 552 noea = ii_noea(narea) 581 553 nono = ii_nono(narea) 582 nlci = ilci(ii,ij)583 nldi = ildi(ii,ij)584 nlei = ilei(ii,ij)585 nlcj = ilcj(ii,ij)586 nldj = ildj(ii,ij)587 nlej = ilej(ii,ij)554 jpi = ijpi(ii,ij) 555 !!$ Nis0 = iis0(ii,ij) 556 !!$ Nie0 = iie0(ii,ij) 557 jpj = ijpj(ii,ij) 558 !!$ Njs0 = ijs0(ii,ij) 559 !!$ Nje0 = ije0(ii,ij) 588 560 nbondi = ibondi(ii,ij) 589 561 nbondj = ibondj(ii,ij) 590 562 nimpp = iimppt(ii,ij) 591 563 njmpp = ijmppt(ii,ij) 592 jpi = nlci 593 jpj = nlcj 594 jpk = jpkglo ! third dim 595 #if defined key_agrif 596 ! simple trick to use same vertical grid as parent but different number of levels: 597 ! Save maximum number of levels in jpkglo, then define all vertical grids with this number. 598 ! Suppress once vertical online interpolation is ok 599 !!$ IF(.NOT.Agrif_Root()) jpkglo = Agrif_Parent( jpkglo ) 600 #endif 601 jpim1 = jpi-1 ! inner domain indices 602 jpjm1 = jpj-1 ! " " 603 jpkm1 = MAX( 1, jpk-1 ) ! " " 604 jpij = jpi*jpj ! jpi x j 564 jpk = jpkglo ! third dim 565 ! 566 CALL init_doloop ! set start/end indices of do-loop, depending on the halo width value (nn_hls) 567 ! 568 jpim1 = jpi-1 ! inner domain indices 569 jpjm1 = jpj-1 ! " " 570 jpkm1 = MAX( 1, jpk-1 ) ! " " 571 jpij = jpi*jpj ! jpi x j 605 572 DO jproc = 1, jpnij 606 573 ii = iin(jproc) 607 574 ij = ijn(jproc) 608 nlcit(jproc) = ilci(ii,ij)609 n ldit(jproc) = ildi(ii,ij)610 n leit(jproc) = ilei(ii,ij)611 nlcjt(jproc) = ilcj(ii,ij)612 n ldjt(jproc) = ildj(ii,ij)613 n lejt(jproc) = ilej(ii,ij)575 jpiall (jproc) = ijpi(ii,ij) 576 nis0all(jproc) = iis0(ii,ij) 577 nie0all(jproc) = iie0(ii,ij) 578 jpjall (jproc) = ijpj(ii,ij) 579 njs0all(jproc) = ijs0(ii,ij) 580 nje0all(jproc) = ije0(ii,ij) 614 581 ibonit(jproc) = ibondi(ii,ij) 615 582 ibonjt(jproc) = ibondj(ii,ij) … … 625 592 WRITE(inum,'(6i8,a,3i8,a)') jpnij,jpimax,jpjmax,jpk,jpiglo,jpjglo,& 626 593 & ' ( local: ',narea,jpi,jpj,' )' 627 WRITE(inum,'(a)') 'nproc nlci nlcj nldi nldj nlei nlejnimp njmp nono noso nowe noea nbondi nbondj '594 WRITE(inum,'(a)') 'nproc jpi jpj Nis0 Njs0 Nie0 Nje0 nimp njmp nono noso nowe noea nbondi nbondj ' 628 595 629 596 DO jproc = 1, jpnij 630 WRITE(inum,'(13i5,2i7)') jproc-1, nlcit (jproc), nlcjt(jproc), &631 & n ldit (jproc), nldjt(jproc), &632 & n leit (jproc), nlejt(jproc), &597 WRITE(inum,'(13i5,2i7)') jproc-1, jpiall(jproc), jpjall(jproc), & 598 & nis0all(jproc), njs0all(jproc), & 599 & nie0all(jproc), nje0all(jproc), & 633 600 & nimppt (jproc), njmppt (jproc), & 634 601 & ii_nono(jproc), ii_noso(jproc), & … … 664 631 WRITE(numout,*) ' l_Iperio = ', l_Iperio 665 632 WRITE(numout,*) ' l_Jperio = ', l_Jperio 666 WRITE(numout,*) ' nlci = ', nlci667 WRITE(numout,*) ' nlcj = ', nlcj668 633 WRITE(numout,*) ' nimpp = ', nimpp 669 634 WRITE(numout,*) ' njmpp = ', njmpp 670 WRITE(numout,*) ' nreci = ', nreci671 WRITE(numout,*) ' nrecj = ', nrecj672 WRITE(numout,*) ' nn_hls = ', nn_hls673 635 ENDIF 674 636 … … 692 654 ENDIF 693 655 ! 694 CALL mpp_init_ioipsl ! Prepare NetCDF output file (if necessary)656 CALL init_ioipsl ! Prepare NetCDF output file (if necessary) 695 657 ! 696 658 IF (( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ).AND.( ln_nnogather )) THEN 697 CALL mpp_init_nfdcom ! northfold neighbour lists659 CALL init_nfdcom ! northfold neighbour lists 698 660 IF (llwrtlay) THEN 699 661 WRITE(inum,*) 700 662 WRITE(inum,*) 701 663 WRITE(inum,*) 'north fold exchanges with explicit point-to-point messaging :' 702 WRITE(inum,*) 'nfsloop : ', nfsloop703 WRITE(inum,*) 'nfeloop : ', nfeloop704 664 WRITE(inum,*) 'nsndto : ', nsndto 705 665 WRITE(inum,*) 'isendto : ', isendto … … 711 671 DEALLOCATE(iin, ijn, ii_nono, ii_noea, ii_noso, ii_nowe, & 712 672 & iimppt, ijmppt, ibondi, ibondj, ipproc, ipolj, & 713 & i lci, ilcj, ilei, ilej, ildi, ildj, &673 & ijpi, ijpj, iie0, ije0, iis0, ijs0, & 714 674 & iono, ioea, ioso, iowe, llisoce) 715 675 ! … … 717 677 718 678 719 SUBROUTINE mpp_bas ic_decomposition(knbi, knbj, kimax, kjmax, kimppt, kjmppt, klci, klcj)720 !!---------------------------------------------------------------------- 721 !! *** ROUTINE mpp_bas ic_decomposition***679 SUBROUTINE mpp_basesplit( kiglo, kjglo, khls, knbi, knbj, kimax, kjmax, kimppt, kjmppt, klci, klcj) 680 !!---------------------------------------------------------------------- 681 !! *** ROUTINE mpp_basesplit *** 722 682 !! 723 683 !! ** Purpose : Lay out the global domain over processors. … … 731 691 !! klcj : second dimension 732 692 !!---------------------------------------------------------------------- 693 INTEGER, INTENT(in ) :: kiglo, kjglo 694 INTEGER, INTENT(in ) :: khls 733 695 INTEGER, INTENT(in ) :: knbi, knbj 734 696 INTEGER, INTENT( out) :: kimax, kjmax … … 737 699 ! 738 700 INTEGER :: ji, jj 701 INTEGER :: i2hls 739 702 INTEGER :: iresti, irestj, irm, ijpjmin 740 INTEGER :: ireci, irecj741 !!----------------------------------------------------------------------703 !!---------------------------------------------------------------------- 704 i2hls = 2*khls 742 705 ! 743 706 #if defined key_nemocice_decomp 744 kimax = ( nx_global+2- 2*nn_hls + (knbi-1) ) / knbi + 2*nn_hls ! first dim.745 kjmax = ( ny_global+2- 2*nn_hls + (knbj-1) ) / knbj + 2*nn_hls ! second dim.707 kimax = ( nx_global+2-i2hls + (knbi-1) ) / knbi + i2hls ! first dim. 708 kjmax = ( ny_global+2-i2hls + (knbj-1) ) / knbj + i2hls ! second dim. 746 709 #else 747 kimax = ( jpiglo - 2*nn_hls + (knbi-1) ) / knbi + 2*nn_hls ! first dim.748 kjmax = ( jpjglo - 2*nn_hls + (knbj-1) ) / knbj + 2*nn_hls ! second dim.710 kimax = ( kiglo - i2hls + (knbi-1) ) / knbi + i2hls ! first dim. 711 kjmax = ( kjglo - i2hls + (knbj-1) ) / knbj + i2hls ! second dim. 749 712 #endif 750 713 IF( .NOT. PRESENT(kimppt) ) RETURN … … 753 716 ! ----------------------------------- 754 717 ! Computation of local domain sizes klci() klcj() 755 ! These dimensions depend on global sizes knbi,knbj and jpiglo,jpjglo718 ! These dimensions depend on global sizes knbi,knbj and kiglo,kjglo 756 719 ! The subdomains are squares lesser than or equal to the global 757 720 ! dimensions divided by the number of processors minus the overlap array. 758 721 ! 759 ireci = 2 * nn_hls 760 irecj = 2 * nn_hls 761 iresti = 1 + MOD( jpiglo - ireci -1 , knbi ) 762 irestj = 1 + MOD( jpjglo - irecj -1 , knbj ) 722 iresti = 1 + MOD( kiglo - i2hls - 1 , knbi ) 723 irestj = 1 + MOD( kjglo - i2hls - 1 , knbj ) 763 724 ! 764 725 ! Need to use kimax and kjmax here since jpi and jpj not yet defined 765 726 #if defined key_nemocice_decomp 766 727 ! Change padding to be consistent with CICE 767 klci(1:knbi-1 ,:) = kimax768 klci( knbi ,:) = jpiglo - (knbi - 1) * (kimax - nreci)769 klcj(: ,1:knbj-1) = kjmax770 klcj(: , knbj) = jpjglo - (knbj - 1) * (kjmax - nrecj)728 klci(1:knbi-1,: ) = kimax 729 klci( knbi ,: ) = kiglo - (knbi - 1) * (kimax - i2hls) 730 klcj(: ,1:knbj-1) = kjmax 731 klcj(: , knbj ) = kjglo - (knbj - 1) * (kjmax - i2hls) 771 732 #else 772 733 klci(1:iresti ,:) = kimax 773 734 klci(iresti+1:knbi ,:) = kimax-1 774 IF( MINVAL(klci) < 3) THEN775 WRITE(ctmp1,*) ' mpp_bas ic_decomposition: minimum value of jpi must be >= 3'735 IF( MINVAL(klci) < 2*i2hls ) THEN 736 WRITE(ctmp1,*) ' mpp_basesplit: minimum value of jpi must be >= ', 2*i2hls 776 737 WRITE(ctmp2,*) ' We have ', MINVAL(klci) 777 738 CALL ctl_stop( 'STOP', ctmp1, ctmp2 ) … … 779 740 IF( jperio == 3 .OR. jperio == 4 .OR. jperio == 5 .OR. jperio == 6 ) THEN 780 741 ! minimize the size of the last row to compensate for the north pole folding coast 781 IF( jperio == 3 .OR. jperio == 4 ) ijpjmin = 5 ! V and F folding involves line jpj-3 that must not be south boundary 782 IF( jperio == 5 .OR. jperio == 6 ) ijpjmin = 4 ! V and F folding involves line jpj-2 that must not be south boundary 783 irm = knbj - irestj ! total number of lines to be removed 784 klcj(:, knbj) = MAX( ijpjmin, kjmax-irm ) ! we must have jpj >= ijpjmin in the last row 785 irm = irm - ( kjmax - klcj(1,knbj) ) ! remaining number of lines to remove 786 irestj = knbj - 1 - irm 787 klcj(:, 1:irestj) = kjmax 742 IF( jperio == 3 .OR. jperio == 4 ) ijpjmin = 2+3*khls ! V and F folding must be outside of southern halos 743 IF( jperio == 5 .OR. jperio == 6 ) ijpjmin = 1+3*khls ! V and F folding must be outside of southern halos 744 irm = knbj - irestj ! total number of lines to be removed 745 klcj(:,knbj) = MAX( ijpjmin, kjmax-irm ) ! we must have jpj >= ijpjmin in the last row 746 irm = irm - ( kjmax - klcj(1,knbj) ) ! remaining number of lines to remove 747 irestj = knbj - 1 - irm 788 748 klcj(:, irestj+1:knbj-1) = kjmax-1 789 749 ELSE 790 ijpjmin = 3 791 klcj(:, 1:irestj) = kjmax 792 klcj(:, irestj+1:knbj) = kjmax-1 793 ENDIF 794 IF( MINVAL(klcj) < ijpjmin ) THEN 795 WRITE(ctmp1,*) ' mpp_basic_decomposition: minimum value of jpj must be >= ', ijpjmin 750 klcj(:, irestj+1:knbj ) = kjmax-1 751 ENDIF 752 klcj(:,1:irestj) = kjmax 753 IF( MINVAL(klcj) < 2*i2hls ) THEN 754 WRITE(ctmp1,*) ' mpp_basesplit: minimum value of jpj must be >= ', 2*i2hls 796 755 WRITE(ctmp2,*) ' We have ', MINVAL(klcj) 797 756 CALL ctl_stop( 'STOP', ctmp1, ctmp2 ) … … 807 766 DO jj = 1, knbj 808 767 DO ji = 2, knbi 809 kimppt(ji,jj) = kimppt(ji-1,jj) + klci(ji-1,jj) - i reci768 kimppt(ji,jj) = kimppt(ji-1,jj) + klci(ji-1,jj) - i2hls 810 769 END DO 811 770 END DO … … 815 774 DO jj = 2, knbj 816 775 DO ji = 1, knbi 817 kjmppt(ji,jj) = kjmppt(ji,jj-1) + klcj(ji,jj-1) - i recj776 kjmppt(ji,jj) = kjmppt(ji,jj-1) + klcj(ji,jj-1) - i2hls 818 777 END DO 819 778 END DO 820 779 ENDIF 821 780 822 END SUBROUTINE mpp_bas ic_decomposition823 824 825 SUBROUTINE mpp_init_bestpartition( knbij, knbi, knbj, knbcnt, ldlist )826 !!---------------------------------------------------------------------- 827 !! *** ROUTINE mpp_init_bestpartition ***781 END SUBROUTINE mpp_basesplit 782 783 784 SUBROUTINE bestpartition( knbij, knbi, knbj, knbcnt, ldlist ) 785 !!---------------------------------------------------------------------- 786 !! *** ROUTINE bestpartition *** 828 787 !! 829 788 !! ** Purpose : … … 867 826 inbimax = 0 868 827 inbjmax = 0 869 isziref = jpiglo*jpjglo+1870 iszjref = jpiglo*jpjglo+1828 isziref = Ni0glo*Nj0glo+1 829 iszjref = Ni0glo*Nj0glo+1 871 830 ! 872 831 ! get the list of knbi that gives a smaller jpimax than knbi-1 … … 876 835 iszitst = ( nx_global+2-2*nn_hls + (ji-1) ) / ji + 2*nn_hls ! first dim. 877 836 #else 878 iszitst = ( jpiglo - 2*nn_hls+ (ji-1) ) / ji + 2*nn_hls837 iszitst = ( Ni0glo + (ji-1) ) / ji + 2*nn_hls 879 838 #endif 880 839 IF( iszitst < isziref ) THEN … … 887 846 iszjtst = ( ny_global+2-2*nn_hls + (ji-1) ) / ji + 2*nn_hls ! first dim. 888 847 #else 889 iszjtst = ( jpjglo - 2*nn_hls+ (ji-1) ) / ji + 2*nn_hls848 iszjtst = ( Nj0glo + (ji-1) ) / ji + 2*nn_hls 890 849 #endif 891 850 IF( iszjtst < iszjref ) THEN … … 927 886 iszij1(:) = iszi1(:) * iszj1(:) 928 887 929 ! if ther ris no land and no print888 ! if there is no land and no print 930 889 IF( .NOT. llist .AND. numbot == -1 .AND. numbdy == -1 ) THEN 931 890 ! get the smaller partition which gives the smallest subdomain size … … 942 901 isz0 = 0 ! number of best partitions 943 902 inbij = 1 ! start with the min value of inbij1 => 1 944 iszij = jpiglo*jpjglo+1 ! default: larger than global domain903 iszij = Ni0glo*Nj0glo+1 ! default: larger than global domain 945 904 DO WHILE( inbij <= inbijmax ) ! if we did not reach the max of inbij1 946 905 ii = MINLOC(iszij1, mask = inbij1 == inbij, dim = 1) ! warning: send back the first occurence if multiple results … … 975 934 ji = isz0 ! initialization with the largest value 976 935 ALLOCATE( llisoce(inbi0(ji), inbj0(ji)) ) 977 CALL mpp_i nit_isoce( inbi0(ji), inbj0(ji), llisoce )! Warning: must be call by all cores (call mpp_sum)936 CALL mpp_is_ocean( llisoce ) ! Warning: must be call by all cores (call mpp_sum) 978 937 inbijold = COUNT(llisoce) 979 938 DEALLOCATE( llisoce ) 980 939 DO ji =isz0-1,1,-1 981 940 ALLOCATE( llisoce(inbi0(ji), inbj0(ji)) ) 982 CALL mpp_i nit_isoce( inbi0(ji), inbj0(ji), llisoce )! Warning: must be call by all cores (call mpp_sum)941 CALL mpp_is_ocean( llisoce ) ! Warning: must be call by all cores (call mpp_sum) 983 942 inbij = COUNT(llisoce) 984 943 DEALLOCATE( llisoce ) … … 1006 965 ii = ii -1 1007 966 ALLOCATE( llisoce(inbi0(ii), inbj0(ii)) ) 1008 CALL mpp_i nit_isoce( inbi0(ii), inbj0(ii),llisoce ) ! must be done by all core967 CALL mpp_is_ocean( llisoce ) ! must be done by all core 1009 968 inbij = COUNT(llisoce) 1010 969 DEALLOCATE( llisoce ) … … 1015 974 DEALLOCATE( inbi0, inbj0 ) 1016 975 ! 1017 END SUBROUTINE mpp_init_bestpartition976 END SUBROUTINE bestpartition 1018 977 1019 978 … … 1024 983 !! ** Purpose : the the proportion of land points in the surface land-sea mask 1025 984 !! 1026 !! ** Method : read iproc strips (of length jpiglo) of the land-sea mask985 !! ** Method : read iproc strips (of length Ni0glo) of the land-sea mask 1027 986 !!---------------------------------------------------------------------- 1028 987 REAL(wp), INTENT( out) :: propland ! proportion of land points in the global domain (between 0 and 1) … … 1041 1000 1042 1001 ! number of processes reading the bathymetry file 1043 iproc = MINVAL( (/mppsize, jpjglo/2, 100/) ) ! read a least 2 lines, no more that 100 processes reading at the same time1002 iproc = MINVAL( (/mppsize, Nj0glo/2, 100/) ) ! read a least 2 lines, no more that 100 processes reading at the same time 1044 1003 1045 1004 ! we want to read iproc strips of the land-sea mask. -> pick up iproc processes every idiv processes starting at 1 … … 1051 1010 IF( MOD( narea-1, idiv ) == 0 .AND. iarea < iproc ) THEN ! beware idiv can be = to 1 1052 1011 ! 1053 ijsz = jpjglo / iproc ! width of the stripe to read1054 IF( iarea < MOD( jpjglo,iproc) ) ijsz = ijsz + 11055 ijstr = iarea*( jpjglo/iproc) + MIN(iarea, MOD(jpjglo,iproc)) + 1 ! starting j position of the reading1056 ! 1057 ALLOCATE( lloce( jpiglo, ijsz) ) ! allocate the strip1058 CALL mpp_init_readbot_strip( ijstr, ijsz, lloce )1012 ijsz = Nj0glo / iproc ! width of the stripe to read 1013 IF( iarea < MOD(Nj0glo,iproc) ) ijsz = ijsz + 1 1014 ijstr = iarea*(Nj0glo/iproc) + MIN(iarea, MOD(Nj0glo,iproc)) + 1 ! starting j position of the reading 1015 ! 1016 ALLOCATE( lloce(Ni0glo, ijsz) ) ! allocate the strip 1017 CALL readbot_strip( ijstr, ijsz, lloce ) 1059 1018 inboce = COUNT(lloce) ! number of ocean point in the stripe 1060 1019 DEALLOCATE(lloce) … … 1065 1024 CALL mpp_sum( 'mppini', inboce ) ! total number of ocean points over the global domain 1066 1025 ! 1067 propland = REAL( jpiglo*jpjglo - inboce, wp ) / REAL( jpiglo*jpjglo, wp )1026 propland = REAL( Ni0glo*Nj0glo - inboce, wp ) / REAL( Ni0glo*Nj0glo, wp ) 1068 1027 ! 1069 1028 END SUBROUTINE mpp_init_landprop 1070 1029 1071 1030 1072 SUBROUTINE mpp_init_isoce( knbi, knbj, ldisoce ) 1073 !!---------------------------------------------------------------------- 1074 !! *** ROUTINE mpp_init_nboce *** 1075 !! 1076 !! ** Purpose : check for a mpi domain decomposition knbi x knbj which 1077 !! subdomains contain at least 1 ocean point 1078 !! 1079 !! ** Method : read knbj strips (of length jpiglo) of the land-sea mask 1080 !!---------------------------------------------------------------------- 1081 INTEGER, INTENT(in ) :: knbi, knbj ! domain decomposition 1082 LOGICAL, DIMENSION(knbi,knbj), INTENT( out) :: ldisoce ! .true. if a sub domain constains 1 ocean point 1083 ! 1084 INTEGER, DIMENSION(knbi,knbj) :: inboce ! number oce oce pint in each mpi subdomain 1085 INTEGER, DIMENSION(knbi*knbj) :: inboce_1d 1031 SUBROUTINE mpp_is_ocean( ldisoce ) 1032 !!---------------------------------------------------------------------- 1033 !! *** ROUTINE mpp_is_ocean *** 1034 !! 1035 !! ** Purpose : Check for a mpi domain decomposition inbi x inbj which 1036 !! subdomains, including 1 halo (even if nn_hls>1), contain 1037 !! at least 1 ocean point. 1038 !! We must indeed ensure that each subdomain that is a neighbour 1039 !! of a land subdomain as only land points on its boundary 1040 !! (inside the inner subdomain) with the land subdomain. 1041 !! This is needed to get the proper bondary conditions on 1042 !! a subdomain with a closed boundary. 1043 !! 1044 !! ** Method : read inbj strips (of length Ni0glo) of the land-sea mask 1045 !!---------------------------------------------------------------------- 1046 LOGICAL, DIMENSION(:,:), INTENT( out) :: ldisoce ! .true. if a sub domain constains 1 ocean point 1047 ! 1086 1048 INTEGER :: idiv, iimax, ijmax, iarea 1049 INTEGER :: inbi, inbj, inx, iny, inry, isty 1087 1050 INTEGER :: ji, jn 1088 LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: lloce ! lloce(i,j) = .true. if the point (i,j) is ocean 1089 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iimppt, ilci 1090 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ijmppt, ilcj 1051 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: inboce ! number oce oce pint in each mpi subdomain 1052 INTEGER, ALLOCATABLE, DIMENSION(: ) :: inboce_1d 1053 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iimppt, ijpi 1054 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ijmppt, ijpj 1055 LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: lloce ! lloce(i,j) = .true. if the point (i,j) is ocean 1091 1056 !!---------------------------------------------------------------------- 1092 1057 ! do nothing if there is no land-sea mask … … 1095 1060 RETURN 1096 1061 ENDIF 1097 1098 ! we want to read knbj strips of the land-sea mask. -> pick up knbj processes every idiv processes starting at 1 1099 IF ( knbj == 1 ) THEN ; idiv = mppsize 1100 ELSE IF ( mppsize < knbj ) THEN ; idiv = 1 1101 ELSE ; idiv = ( mppsize - 1 ) / ( knbj - 1 ) 1102 ENDIF 1062 ! 1063 inbi = SIZE( ldisoce, dim = 1 ) 1064 inbj = SIZE( ldisoce, dim = 2 ) 1065 ! 1066 ! we want to read inbj strips of the land-sea mask. -> pick up inbj processes every idiv processes starting at 1 1067 IF ( inbj == 1 ) THEN ; idiv = mppsize 1068 ELSE IF ( mppsize < inbj ) THEN ; idiv = 1 1069 ELSE ; idiv = ( mppsize - 1 ) / ( inbj - 1 ) 1070 ENDIF 1071 ! 1072 ALLOCATE( inboce(inbi,inbj), inboce_1d(inbi*inbj) ) 1103 1073 inboce(:,:) = 0 ! default no ocean point found 1104 1105 DO jn = 0, ( knbj-1)/mppsize ! if mppsize < knbj : more strips than mpi processes (because of potential land domains)1106 ! 1107 iarea = (narea-1)/idiv + jn * mppsize ! involed process number (starting counting at 0)1108 IF( MOD( narea-1, idiv ) == 0 .AND. iarea < knbj ) THEN! beware idiv can be = to 11074 ! 1075 DO jn = 0, (inbj-1)/mppsize ! if mppsize < inbj : more strips than mpi processes (because of potential land domains) 1076 ! 1077 iarea = (narea-1)/idiv + jn * mppsize + 1 ! involed process number (starting counting at 1) 1078 IF( MOD( narea-1, idiv ) == 0 .AND. iarea <= inbj ) THEN ! beware idiv can be = to 1 1109 1079 ! 1110 ALLOCATE( iimppt( knbi,knbj), ijmppt(knbi,knbj), ilci(knbi,knbj), ilcj(knbi,knbj) )1111 CALL mpp_bas ic_decomposition( knbi, knbj, iimax, ijmax, iimppt, ijmppt, ilci, ilcj )1080 ALLOCATE( iimppt(inbi,inbj), ijmppt(inbi,inbj), ijpi(inbi,inbj), ijpj(inbi,inbj) ) 1081 CALL mpp_basesplit( Ni0glo, Nj0glo, 0, inbi, inbj, iimax, ijmax, iimppt, ijmppt, ijpi, ijpj ) 1112 1082 ! 1113 ALLOCATE( lloce(jpiglo, ilcj(1,iarea+1)) ) ! allocate the strip 1114 CALL mpp_init_readbot_strip( ijmppt(1,iarea+1), ilcj(1,iarea+1), lloce ) ! read the strip 1115 DO ji = 1, knbi 1116 inboce(ji,iarea+1) = COUNT( lloce(iimppt(ji,1):iimppt(ji,1)+ilci(ji,1)-1,:) ) ! number of ocean point in subdomain 1083 inx = Ni0glo + 2 ; iny = ijpj(1,iarea) + 2 ! strip size + 1 halo on each direction (even if nn_hls>1) 1084 ALLOCATE( lloce(inx, iny) ) ! allocate the strip 1085 inry = iny - COUNT( (/ iarea == 1, iarea == inbj /) ) ! number of point to read in y-direction 1086 isty = 1 + COUNT( (/ iarea == 1 /) ) ! read from the first or the second line? 1087 CALL readbot_strip( ijmppt(1,iarea) - 2 + isty, inry, lloce(2:inx-1, isty:inry+isty-1) ) ! read the strip 1088 ! 1089 IF( iarea == 1 ) THEN ! the first line was not read 1090 IF( jperio == 2 .OR. jperio == 7 ) THEN ! north-south periodocity 1091 CALL readbot_strip( Nj0glo, 1, lloce(2:inx-1, 1) ) ! read the last line -> first line of lloce 1092 ELSE 1093 lloce(2:inx-1, 1) = .FALSE. ! closed boundary 1094 ENDIF 1095 ENDIF 1096 IF( iarea == inbj ) THEN ! the last line was not read 1097 IF( jperio == 2 .OR. jperio == 7 ) THEN ! north-south periodocity 1098 CALL readbot_strip( 1, 1, lloce(2:inx-1,iny) ) ! read the first line -> last line of lloce 1099 ELSEIF( jperio == 3 .OR. jperio == 4 ) THEN ! north-pole folding T-pivot, T-point 1100 lloce(2,iny) = lloce(2,iny-2) ! here we have 1 halo (even if nn_hls>1) 1101 DO ji = 3,inx-1 1102 lloce(ji,iny ) = lloce(inx-ji+2,iny-2) ! ok, we have at least 3 lines 1103 END DO 1104 DO ji = inx/2+2,inx-1 1105 lloce(ji,iny-1) = lloce(inx-ji+2,iny-1) 1106 END DO 1107 ELSEIF( jperio == 5 .OR. jperio == 6 ) THEN ! north-pole folding F-pivot, T-point, 1 halo 1108 lloce(inx/2+1,iny-1) = lloce(inx/2,iny-1) ! here we have 1 halo (even if nn_hls>1) 1109 lloce(inx -1,iny-1) = lloce(2 ,iny-1) 1110 DO ji = 2,inx-1 1111 lloce(ji,iny) = lloce(inx-ji+1,iny-1) 1112 END DO 1113 ELSE ! closed boundary 1114 lloce(2:inx-1,iny) = .FALSE. 1115 ENDIF 1116 ENDIF 1117 ! ! first and last column were not read 1118 IF( jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7 ) THEN 1119 lloce(1,:) = lloce(inx-1,:) ; lloce(inx,:) = lloce(2,:) ! east-west periodocity 1120 ELSE 1121 lloce(1,:) = .FALSE. ; lloce(inx,:) = .FALSE. ! closed boundary 1122 ENDIF 1123 ! 1124 DO ji = 1, inbi 1125 inboce(ji,iarea) = COUNT( lloce(iimppt(ji,1):iimppt(ji,1)+ijpi(ji,1)+1,:) ) ! lloce as 2 points more than Ni0glo 1117 1126 END DO 1118 1127 ! 1119 1128 DEALLOCATE(lloce) 1120 DEALLOCATE(iimppt, ijmppt, i lci, ilcj)1129 DEALLOCATE(iimppt, ijmppt, ijpi, ijpj) 1121 1130 ! 1122 1131 ENDIF 1123 1132 END DO 1124 1133 1125 inboce_1d = RESHAPE(inboce, (/ knbi*knbj /))1134 inboce_1d = RESHAPE(inboce, (/ inbi*inbj /)) 1126 1135 CALL mpp_sum( 'mppini', inboce_1d ) 1127 inboce = RESHAPE(inboce_1d, (/ knbi, knbj/))1136 inboce = RESHAPE(inboce_1d, (/inbi, inbj/)) 1128 1137 ldisoce(:,:) = inboce(:,:) /= 0 1129 ! 1130 END SUBROUTINE mpp_init_isoce 1138 DEALLOCATE(inboce, inboce_1d) 1139 ! 1140 END SUBROUTINE mpp_is_ocean 1131 1141 1132 1142 1133 SUBROUTINE mpp_init_readbot_strip( kjstr, kjcnt, ldoce )1134 !!---------------------------------------------------------------------- 1135 !! *** ROUTINE mpp_init_readbot_strip ***1143 SUBROUTINE readbot_strip( kjstr, kjcnt, ldoce ) 1144 !!---------------------------------------------------------------------- 1145 !! *** ROUTINE readbot_strip *** 1136 1146 !! 1137 1147 !! ** Purpose : Read relevant bathymetric information in order to … … 1139 1149 !! of land domains, in an mpp computation. 1140 1150 !! 1141 !! ** Method : read stipe of size ( jpiglo,...)1142 !!---------------------------------------------------------------------- 1143 INTEGER , INTENT(in ) :: kjstr ! starting j position of the reading1144 INTEGER , INTENT(in ) :: kjcnt ! number of lines to read1145 LOGICAL, DIMENSION( jpiglo,kjcnt), INTENT( out) ::ldoce ! ldoce(i,j) = .true. if the point (i,j) is ocean1151 !! ** Method : read stipe of size (Ni0glo,...) 1152 !!---------------------------------------------------------------------- 1153 INTEGER , INTENT(in ) :: kjstr ! starting j position of the reading 1154 INTEGER , INTENT(in ) :: kjcnt ! number of lines to read 1155 LOGICAL, DIMENSION(Ni0glo,kjcnt), INTENT( out) :: ldoce ! ldoce(i,j) = .true. if the point (i,j) is ocean 1146 1156 ! 1147 1157 INTEGER :: inumsave ! local logical unit 1148 REAL(wp), DIMENSION( jpiglo,kjcnt) :: zbot, zbdy1158 REAL(wp), DIMENSION(Ni0glo,kjcnt) :: zbot, zbdy 1149 1159 !!---------------------------------------------------------------------- 1150 1160 ! 1151 1161 inumsave = numout ; numout = numnul ! redirect all print to /dev/null 1152 1162 ! 1153 IF( numbot /= -1 ) THEN 1154 CALL iom_get( numbot, jpdom_unknown, 'bottom_level', zbot, kstart = (/1,kjstr/), kcount = (/ jpiglo, kjcnt/) )1163 IF( numbot /= -1 ) THEN 1164 CALL iom_get( numbot, jpdom_unknown, 'bottom_level', zbot, kstart = (/1,kjstr/), kcount = (/Ni0glo, kjcnt/) ) 1155 1165 ELSE 1156 zbot(:,:) = 1. 1157 ENDIF 1158 1159 IF( numbdy /= -1 ) THEN! Adjust with bdy_msk if it exists1160 CALL iom_get ( numbdy, jpdom_unknown, 'bdy_msk', zbdy, kstart = (/1,kjstr/), kcount = (/jpiglo, kjcnt/) )1166 zbot(:,:) = 1._wp ! put a non-null value 1167 ENDIF 1168 ! 1169 IF( numbdy /= -1 ) THEN ! Adjust with bdy_msk if it exists 1170 CALL iom_get ( numbdy, jpdom_unknown, 'bdy_msk', zbdy, kstart = (/1,kjstr/), kcount = (/Ni0glo, kjcnt/) ) 1161 1171 zbot(:,:) = zbot(:,:) * zbdy(:,:) 1162 1172 ENDIF 1163 1173 ! 1164 ldoce(:,:) = zbot(:,:) > 0. 1174 ldoce(:,:) = zbot(:,:) > 0._wp 1165 1175 numout = inumsave 1166 1176 ! 1167 END SUBROUTINE mpp_init_readbot_strip 1168 1169 1170 SUBROUTINE mpp_init_ioipsl 1171 !!---------------------------------------------------------------------- 1172 !! *** ROUTINE mpp_init_ioipsl *** 1177 END SUBROUTINE readbot_strip 1178 1179 1180 SUBROUTINE mpp_getnum( ldisoce, kproc, kipos, kjpos ) 1181 !!---------------------------------------------------------------------- 1182 !! *** ROUTINE mpp_getnum *** 1183 !! 1184 !! ** Purpose : give a number to each MPI subdomains (starting at 0) 1185 !! 1186 !! ** Method : start from bottom left. First skip land subdomain, and finally use them if needed 1187 !!---------------------------------------------------------------------- 1188 LOGICAL, DIMENSION(:,:), INTENT(in ) :: ldisoce ! F if land process 1189 INTEGER, DIMENSION(:,:), INTENT( out) :: kproc ! subdomain number (-1 if supressed, starting at 0) 1190 INTEGER, DIMENSION( :), INTENT( out) :: kipos ! i-position of the subdomain (from 1 to jpni) 1191 INTEGER, DIMENSION( :), INTENT( out) :: kjpos ! j-position of the subdomain (from 1 to jpnj) 1192 ! 1193 INTEGER :: ii, ij, jarea, iarea0 1194 INTEGER :: icont, i2add , ini, inj, inij 1195 !!---------------------------------------------------------------------- 1196 ! 1197 ini = SIZE(ldisoce, dim = 1) 1198 inj = SIZE(ldisoce, dim = 2) 1199 inij = SIZE(kipos) 1200 ! 1201 ! specify which subdomains are oce subdomains; other are land subdomains 1202 kproc(:,:) = -1 1203 icont = -1 1204 DO jarea = 1, ini*inj 1205 iarea0 = jarea - 1 1206 ii = 1 + MOD(iarea0,ini) 1207 ij = 1 + iarea0/ini 1208 IF( ldisoce(ii,ij) ) THEN 1209 icont = icont + 1 1210 kproc(ii,ij) = icont 1211 kipos(icont+1) = ii 1212 kjpos(icont+1) = ij 1213 ENDIF 1214 END DO 1215 ! if needed add some land subdomains to reach inij active subdomains 1216 i2add = inij - COUNT( ldisoce ) 1217 DO jarea = 1, ini*inj 1218 iarea0 = jarea - 1 1219 ii = 1 + MOD(iarea0,ini) 1220 ij = 1 + iarea0/ini 1221 IF( .NOT. ldisoce(ii,ij) .AND. i2add > 0 ) THEN 1222 icont = icont + 1 1223 kproc(ii,ij) = icont 1224 kipos(icont+1) = ii 1225 kjpos(icont+1) = ij 1226 i2add = i2add - 1 1227 ENDIF 1228 END DO 1229 ! 1230 END SUBROUTINE mpp_getnum 1231 1232 1233 SUBROUTINE init_ioipsl 1234 !!---------------------------------------------------------------------- 1235 !! *** ROUTINE init_ioipsl *** 1173 1236 !! 1174 1237 !! ** Purpose : … … 1187 1250 ! Set idompar values equivalent to the jpdom_local_noextra definition 1188 1251 ! used in IOM. This works even if jpnij .ne. jpni*jpnj. 1189 iglo(1) = jpiglo 1190 iglo(2) = jpjglo 1191 iloc(1) = nlci 1192 iloc(2) = nlcj 1193 iabsf(1) = nimppt(narea) 1194 iabsf(2) = njmppt(narea) 1252 iglo( :) = (/ Ni0glo, Nj0glo /) 1253 iloc( :) = (/ Ni_0 , Nj_0 /) 1254 iabsf(:) = (/ Nis0 , Njs0 /) + (/ nimpp, njmpp /) - 1 - nn_hls ! corresponds to mig0(Nis0) but mig0 is not yet defined! 1195 1255 iabsl(:) = iabsf(:) + iloc(:) - 1 1196 ihals(1) = nldi - 1 1197 ihals(2) = nldj - 1 1198 ihale(1) = nlci - nlei 1199 ihale(2) = nlcj - nlej 1200 idid(1) = 1 1201 idid(2) = 2 1256 ihals(:) = (/ 0 , 0 /) 1257 ihale(:) = (/ 0 , 0 /) 1258 idid( :) = (/ 1 , 2 /) 1202 1259 1203 1260 IF(lwp) THEN 1204 1261 WRITE(numout,*) 1205 WRITE(numout,*) 'mpp _init_ioipsl : iloc = ', iloc (1), iloc (2)1206 WRITE(numout,*) '~~~~~~~~~~~~~~~ iabsf = ', iabsf (1), iabsf(2)1207 WRITE(numout,*) ' ihals = ', ihals (1), ihals(2)1208 WRITE(numout,*) ' ihale = ', ihale (1), ihale(2)1262 WRITE(numout,*) 'mpp init_ioipsl : iloc = ', iloc 1263 WRITE(numout,*) '~~~~~~~~~~~~~~~ iabsf = ', iabsf 1264 WRITE(numout,*) ' ihals = ', ihals 1265 WRITE(numout,*) ' ihale = ', ihale 1209 1266 ENDIF 1210 1267 ! 1211 1268 CALL flio_dom_set ( jpnij, nproc, idid, iglo, iloc, iabsf, iabsl, ihals, ihale, 'BOX', nidom) 1212 1269 ! 1213 END SUBROUTINE mpp_init_ioipsl1214 1215 1216 SUBROUTINE mpp_init_nfdcom1217 !!---------------------------------------------------------------------- 1218 !! *** ROUTINE mpp_init_nfdcom ***1270 END SUBROUTINE init_ioipsl 1271 1272 1273 SUBROUTINE init_nfdcom 1274 !!---------------------------------------------------------------------- 1275 !! *** ROUTINE init_nfdcom *** 1219 1276 !! ** Purpose : Setup for north fold exchanges with explicit 1220 1277 !! point-to-point messaging … … 1226 1283 !!---------------------------------------------------------------------- 1227 1284 INTEGER :: sxM, dxM, sxT, dxT, jn 1228 INTEGER :: njmppmax 1229 !!---------------------------------------------------------------------- 1230 ! 1231 njmppmax = MAXVAL( njmppt ) 1285 !!---------------------------------------------------------------------- 1232 1286 ! 1233 1287 !initializes the north-fold communication variables … … 1235 1289 nsndto = 0 1236 1290 ! 1237 IF ( njmpp == njmppmax) THEN ! if I am a process in the north1291 IF ( njmpp == MAXVAL( njmppt ) ) THEN ! if I am a process in the north 1238 1292 ! 1239 1293 !sxM is the first point (in the global domain) needed to compute the north-fold for the current process 1240 sxM = jpiglo - nimppt(narea) - nlcit(narea) + 11294 sxM = jpiglo - nimppt(narea) - jpiall(narea) + 1 1241 1295 !dxM is the last point (in the global domain) needed to compute the north-fold for the current process 1242 1296 dxM = jpiglo - nimppt(narea) + 2 … … 1247 1301 DO jn = 1, jpni 1248 1302 ! 1249 sxT = nfi impp(jn, jpnj)! sxT = 1st point (in the global domain) of the jn process1250 dxT = nfi impp(jn, jpnj) + nfilcit(jn, jpnj) - 1 ! dxT = last point (in the global domain) of the jn process1303 sxT = nfimpp(jn) ! sxT = 1st point (in the global domain) of the jn process 1304 dxT = nfimpp(jn) + nfjpi(jn) - 1 ! dxT = last point (in the global domain) of the jn process 1251 1305 ! 1252 1306 IF ( sxT < sxM .AND. sxM < dxT ) THEN … … 1262 1316 ! 1263 1317 END DO 1264 nfsloop = 11265 nfeloop = nlci1266 DO jn = 2,jpni-11267 IF( nfipproc(jn,jpnj) == (narea - 1) ) THEN1268 IF( nfipproc(jn-1,jpnj) == -1 ) nfsloop = nldi1269 IF( nfipproc(jn+1,jpnj) == -1 ) nfeloop = nlei1270 ENDIF1271 END DO1272 1318 ! 1273 1319 ENDIF 1274 1320 l_north_nogather = .TRUE. 1275 1321 ! 1276 END SUBROUTINE mpp_init_nfdcom 1277 1322 END SUBROUTINE init_nfdcom 1278 1323 1279 1324 #endif 1280 1325 1326 SUBROUTINE init_doloop 1327 !!---------------------------------------------------------------------- 1328 !! *** ROUTINE init_doloop *** 1329 !! 1330 !! ** Purpose : set the starting/ending indices of DO-loop 1331 !! These indices are used in do_loop_substitute.h90 1332 !!---------------------------------------------------------------------- 1333 ! 1334 Nis0 = 1+nn_hls ; Nis1 = Nis0-1 ; Nis2 = MAX( 1, Nis0-2) 1335 Njs0 = 1+nn_hls ; Njs1 = Njs0-1 ; Njs2 = MAX( 1, Njs0-2) 1336 ! 1337 Nie0 = jpi-nn_hls ; Nie1 = Nie0+1 ; Nie2 = MIN(jpi, Nie0+2) 1338 Nje0 = jpj-nn_hls ; Nje1 = Nje0+1 ; Nje2 = MIN(jpj, Nje0+2) 1339 ! 1340 IF( nn_hls == 1 ) THEN !* halo size of 1 1341 ! 1342 Nis1nxt2 = Nis0 ; Njs1nxt2 = Njs0 1343 Nie1nxt2 = Nie0 ; Nje1nxt2 = Nje0 1344 ! 1345 ELSE !* larger halo size... 1346 ! 1347 Nis1nxt2 = Nis1 ; Njs1nxt2 = Njs1 1348 Nie1nxt2 = Nie1 ; Nje1nxt2 = Nje1 1349 ! 1350 ENDIF 1351 ! 1352 Ni_0 = Nie0 - Nis0 + 1 1353 Nj_0 = Nje0 - Njs0 + 1 1354 Ni_1 = Nie1 - Nis1 + 1 1355 Nj_1 = Nje1 - Njs1 + 1 1356 Ni_2 = Nie2 - Nis2 + 1 1357 Nj_2 = Nje2 - Njs2 + 1 1358 ! 1359 END SUBROUTINE init_doloop 1360 1281 1361 !!====================================================================== 1282 1362 END MODULE mppini -
NEMO/trunk/src/OCE/LDF/ldfdyn.F90
r13226 r13286 267 267 IF(lwp) WRITE(numout,*) ' ==>>> eddy viscosity = F(i,j) read in eddy_viscosity.nc file' 268 268 CALL iom_open( 'eddy_viscosity_2D.nc', inum ) 269 CALL iom_get ( inum, jpdom_ data, 'ahmt_2d', ahmt(:,:,1))270 CALL iom_get ( inum, jpdom_ data, 'ahmf_2d', ahmf(:,:,1))269 CALL iom_get ( inum, jpdom_global, 'ahmt_2d', ahmt(:,:,1), cd_type = 'T', psgn = 1._wp ) 270 CALL iom_get ( inum, jpdom_global, 'ahmf_2d', ahmf(:,:,1), cd_type = 'F', psgn = 1._wp ) 271 271 CALL iom_close( inum ) 272 272 DO jk = 2, jpkm1 … … 284 284 IF(lwp) WRITE(numout,*) ' ==>>> eddy viscosity = F(i,j,k) read in eddy_viscosity_3D.nc file' 285 285 CALL iom_open( 'eddy_viscosity_3D.nc', inum ) 286 CALL iom_get ( inum, jpdom_ data, 'ahmt_3d', ahmt)287 CALL iom_get ( inum, jpdom_ data, 'ahmf_3d', ahmf)286 CALL iom_get ( inum, jpdom_global, 'ahmt_3d', ahmt, cd_type = 'T', psgn = 1._wp ) 287 CALL iom_get ( inum, jpdom_global, 'ahmf_3d', ahmf, cd_type = 'F', psgn = 1._wp ) 288 288 CALL iom_close( inum ) 289 289 ! -
NEMO/trunk/src/OCE/LDF/ldftra.F90
r13237 r13286 317 317 IF(lwp) WRITE(numout,*) ' ==>>> eddy diffusivity = F(i,j) read in eddy_diffusivity.nc file' 318 318 CALL iom_open( 'eddy_diffusivity_2D.nc', inum ) 319 CALL iom_get ( inum, jpdom_ data, 'ahtu_2D', ahtu(:,:,1))320 CALL iom_get ( inum, jpdom_ data, 'ahtv_2D', ahtv(:,:,1))319 CALL iom_get ( inum, jpdom_global, 'ahtu_2D', ahtu(:,:,1), cd_type = 'U', psgn = 1._wp ) 320 CALL iom_get ( inum, jpdom_global, 'ahtv_2D', ahtv(:,:,1), cd_type = 'V', psgn = 1._wp ) 321 321 CALL iom_close( inum ) 322 322 DO jk = 2, jpkm1 … … 345 345 IF(lwp) WRITE(numout,*) ' ==>>> eddy diffusivity = F(i,j,k) read in eddy_diffusivity.nc file' 346 346 CALL iom_open( 'eddy_diffusivity_3D.nc', inum ) 347 CALL iom_get ( inum, jpdom_ data, 'ahtu_3D', ahtu)348 CALL iom_get ( inum, jpdom_ data, 'ahtv_3D', ahtv)347 CALL iom_get ( inum, jpdom_global, 'ahtu_3D', ahtu, cd_type = 'U', psgn = 1._wp ) 348 CALL iom_get ( inum, jpdom_global, 'ahtv_3D', ahtv, cd_type = 'V', psgn = 1._wp ) 349 349 CALL iom_close( inum ) 350 350 ! … … 572 572 IF(lwp) WRITE(numout,*) ' ==>>> eddy induced velocity coef. = F(i,j) read in eddy_diffusivity_2D.nc file' 573 573 CALL iom_open ( 'eddy_induced_velocity_2D.nc', inum ) 574 CALL iom_get ( inum, jpdom_ data, 'aeiu', aeiu(:,:,1))575 CALL iom_get ( inum, jpdom_ data, 'aeiv', aeiv(:,:,1))574 CALL iom_get ( inum, jpdom_global, 'aeiu', aeiu(:,:,1), cd_type = 'U', psgn = 1._wp ) 575 CALL iom_get ( inum, jpdom_global, 'aeiv', aeiv(:,:,1), cd_type = 'V', psgn = 1._wp ) 576 576 CALL iom_close( inum ) 577 577 DO jk = 2, jpkm1 … … 596 596 IF(lwp) WRITE(numout,*) ' ==>>> eddy induced velocity coef. = F(i,j,k) read in eddy_diffusivity_3D.nc file' 597 597 CALL iom_open ( 'eddy_induced_velocity_3D.nc', inum ) 598 CALL iom_get ( inum, jpdom_ data, 'aeiu', aeiu)599 CALL iom_get ( inum, jpdom_ data, 'aeiv', aeiv)598 CALL iom_get ( inum, jpdom_global, 'aeiu', aeiu, cd_type = 'U', psgn = 1._wp ) 599 CALL iom_get ( inum, jpdom_global, 'aeiv', aeiv, cd_type = 'V', psgn = 1._wp ) 600 600 CALL iom_close( inum ) 601 601 ! -
NEMO/trunk/src/OCE/OBS/find_obs_proc.h90
r10068 r13286 41 41 ! first and last indoor i- and j-indexes kldi, klei, kldj, klej 42 42 ! exclude any obs in the bottom-left overlap region 43 ! also any obs outside to whole region (defined by nlci and nlcj)43 ! also any obs outside to whole region (defined by jpi and jpj) 44 44 ! I am assuming that kobsp does not need to be the correct processor 45 45 ! number -
NEMO/trunk/src/OCE/OBS/mpp_map.F90
r10068 r13286 11 11 !!---------------------------------------------------------------------- 12 12 USE par_kind, ONLY : wp ! Precision variables 13 USE par_oce , ONLY : jpi, jpj 14 USE dom_oce , ONLY : mig, mjg, n ldi, nlei, nldj, nlej, nlci, nlcj, narea! Ocean space and time domain variables13 USE par_oce , ONLY : jpi, jpj, Nis0, Nie0, Njs0, Nje0 ! Ocean parameters 14 USE dom_oce , ONLY : mig, mjg, narea ! Ocean space and time domain variables 15 15 #if defined key_mpp_mpi 16 USE lib_mpp , ONLY : mpi_comm_oce ! MPP library16 USE lib_mpp , ONLY : mpi_comm_oce ! MPP library 17 17 #endif 18 18 USE in_out_manager ! I/O manager … … 65 65 66 66 ! ! Setup local grid points 67 imppmap(mig(1):mig( nlci),mjg(1):mjg(nlcj)) = narea67 imppmap(mig(1):mig(jpi),mjg(1):mjg(jpj)) = narea 68 68 69 69 ! Get global data -
NEMO/trunk/src/OCE/OBS/obs_grid.F90
r12933 r13286 129 129 IF ( cdgrid == 'T' ) THEN 130 130 CALL obs_grd_bruteforce( jpi, jpj, jpiglo, jpjglo, & 131 & 1, nlci, 1, nlcj,&131 & 1, jpi, 1, jpj, & 132 132 & nproc, jpnij, & 133 133 & glamt, gphit, tmask, & … … 136 136 ELSEIF ( cdgrid == 'U' ) THEN 137 137 CALL obs_grd_bruteforce( jpi, jpj, jpiglo, jpjglo, & 138 & 1, nlci, 1, nlcj,&138 & 1, jpi, 1, jpj, & 139 139 & nproc, jpnij, & 140 140 & glamu, gphiu, umask, & … … 143 143 ELSEIF ( cdgrid == 'V' ) THEN 144 144 CALL obs_grd_bruteforce( jpi, jpj, jpiglo, jpjglo, & 145 & 1, nlci, 1, nlcj,&145 & 1, jpi, 1, jpj, & 146 146 & nproc, jpnij, & 147 147 & glamv, gphiv, vmask, & … … 150 150 ELSEIF ( cdgrid == 'F' ) THEN 151 151 CALL obs_grd_bruteforce( jpi, jpj, jpiglo, jpjglo, & 152 & 1, nlci, 1, nlcj,&152 & 1, jpi, 1, jpj, & 153 153 & nproc, jpnij, & 154 154 & glamf, gphif, fmask, & … … 279 279 zmskg(:,:) = -1.e+10 280 280 ! Add various grids here. 281 DO jj = 1, nlcj282 DO ji = 1, nlci281 DO jj = 1, jpj 282 DO ji = 1, jpi 283 283 zlamg(mig(ji),mjg(jj)) = glamt(ji,jj) 284 284 zphig(mig(ji),mjg(jj)) = gphit(ji,jj) … … 819 819 820 820 CALL obs_grd_bruteforce( jpi, jpj, jpiglo, jpjglo, & 821 & 1, nlci, 1, nlcj,&821 & 1, jpi, 1, jpj, & 822 822 & nproc, jpnij, & 823 823 & glamt, gphit, tmask, & -
NEMO/trunk/src/OCE/OBS/obs_read_altbias.F90
r12377 r13286 125 125 ! Get the Alt bias data 126 126 127 CALL iom_get( numaltbias, jpdom_ data, 'altbias', z_altbias(:,:), 1)127 CALL iom_get( numaltbias, jpdom_global, 'altbias', z_altbias(:,:) ) 128 128 129 129 ! Close the file -
NEMO/trunk/src/OCE/OBS/obs_readmdt.F90
r12377 r13286 90 90 CALL iom_open( mdtname, nummdt ) ! Open the file 91 91 ! ! Get the MDT data 92 CALL iom_get ( nummdt, jpdom_ data, 'sossheig', z_mdt(:,:), 1)92 CALL iom_get ( nummdt, jpdom_global, 'sossheig', z_mdt(:,:) ) 93 93 CALL iom_close(nummdt) ! Close the file 94 94 -
NEMO/trunk/src/OCE/OBS/obs_sstbias.F90
r12377 r13286 139 139 cl_bias_files(jtype) ) 140 140 ! Get the SST bias data 141 CALL iom_get( numsstbias, jpdom_ data, 'tn', z_sstbias_2d(:,:), 1 )141 CALL iom_get( numsstbias, jpdom_global, 'tn', z_sstbias_2d(:,:), 1 ) 142 142 z_sstbias(:,:,jtype) = z_sstbias_2d(:,:) 143 143 ! Close the file -
NEMO/trunk/src/OCE/SBC/cpl_oasis3.F90
r12527 r13286 69 69 INTEGER, PUBLIC, PARAMETER :: nmaxcat=5 ! Maximum number of coupling fields 70 70 INTEGER, PUBLIC, PARAMETER :: nmaxcpl=5 ! Maximum number of coupling fields 71 LOGICAL, PARAMETER :: ltmp_wapatch = .TRUE. ! patch to restore wraparound rows in cpl_send, cpl_rcv, cpl_define72 INTEGER :: nldi_save, nlei_save73 INTEGER :: nldj_save, nlej_save74 71 75 72 TYPE, PUBLIC :: FLD_CPL !: Type for coupling field information … … 148 145 !!-------------------------------------------------------------------- 149 146 150 ! patch to restore wraparound rows in cpl_send, cpl_rcv, cpl_define151 IF( ltmp_wapatch ) THEN152 nldi_save = nldi ; nlei_save = nlei153 nldj_save = nldj ; nlej_save = nlej154 IF( nimpp == 1 ) nldi = 1155 IF( nimpp + jpi - 1 == jpiglo ) nlei = jpi156 IF( njmpp == 1 ) nldj = 1157 IF( njmpp + jpj - 1 == jpjglo ) nlej = jpj158 ENDIF159 147 IF(lwp) WRITE(numout,*) 160 148 IF(lwp) WRITE(numout,*) 'cpl_define : initialization in coupled ocean/atmosphere case' … … 182 170 ! 183 171 ishape(1) = 1 184 ishape(2) = nlei-nldi+1172 ishape(2) = Ni_0 185 173 ishape(3) = 1 186 ishape(4) = nlej-nldj+1174 ishape(4) = Nj_0 187 175 ! 188 176 ! ... Allocate memory for data exchange 189 177 ! 190 ALLOCATE(exfld( nlei-nldi+1, nlej-nldj+1), stat = nerror)178 ALLOCATE(exfld(Ni_0, Nj_0), stat = nerror) 191 179 IF( nerror > 0 ) THEN 192 180 CALL oasis_abort ( ncomp_id, 'cpl_define', 'Failure in allocating exfld') ; RETURN … … 198 186 199 187 paral(1) = 2 ! box partitioning 200 paral(2) = jpiglo * ( nldj-1+njmpp-1) + (nldi-1+nimpp-1) ! NEMO lower left corner global offset201 paral(3) = nlei-nldi+1! local extent in i202 paral(4) = nlej-nldj+1! local extent in j188 paral(2) = jpiglo * (Njs0-1+njmpp-1) + (Nis0-1+nimpp-1) ! NEMO lower left corner global offset 189 paral(3) = Ni_0 ! local extent in i 190 paral(4) = Nj_0 ! local extent in j 203 191 paral(5) = jpiglo ! global extent in x 204 192 … … 206 194 WRITE(numout,*) ' multiexchg: paral (1:5)', paral 207 195 WRITE(numout,*) ' multiexchg: jpi, jpj =', jpi, jpj 208 WRITE(numout,*) ' multiexchg: nldi, nlei, nimpp =', nldi, nlei, nimpp209 WRITE(numout,*) ' multiexchg: nldj, nlej, njmpp =', nldj, nlej, njmpp196 WRITE(numout,*) ' multiexchg: Nis0, Nie0, nimpp =', Nis0, Nie0, nimpp 197 WRITE(numout,*) ' multiexchg: Njs0, Nje0, njmpp =', Njs0, Nje0, njmpp 210 198 ENDIF 211 199 … … 316 304 #endif 317 305 ! 318 IF( ltmp_wapatch ) THEN319 nldi = nldi_save ; nlei = nlei_save320 nldj = nldj_save ; nlej = nlej_save321 ENDIF322 306 END SUBROUTINE cpl_define 323 307 … … 337 321 INTEGER :: jc,jm ! local loop index 338 322 !!-------------------------------------------------------------------- 339 ! patch to restore wraparound rows in cpl_send, cpl_rcv, cpl_define340 IF( ltmp_wapatch ) THEN341 nldi_save = nldi ; nlei_save = nlei342 nldj_save = nldj ; nlej_save = nlej343 IF( nimpp == 1 ) nldi = 1344 IF( nimpp + jpi - 1 == jpiglo ) nlei = jpi345 IF( njmpp == 1 ) nldj = 1346 IF( njmpp + jpj - 1 == jpjglo ) nlej = jpj347 ENDIF348 323 ! 349 324 ! snd data to OASIS3 … … 353 328 354 329 IF( ssnd(kid)%nid(jc,jm) /= -1 ) THEN 355 CALL oasis_put ( ssnd(kid)%nid(jc,jm), kstep, pdata( nldi:nlei, nldj:nlej,jc), kinfo )330 CALL oasis_put ( ssnd(kid)%nid(jc,jm), kstep, pdata(Nis0:Nie0, Njs0:Nje0,jc), kinfo ) 356 331 357 332 IF ( sn_cfctl%l_oasout ) THEN … … 363 338 WRITE(numout,*) 'oasis_put: kstep ', kstep 364 339 WRITE(numout,*) 'oasis_put: info ', kinfo 365 WRITE(numout,*) ' - Minimum value is ', MINVAL(pdata( nldi:nlei,nldj:nlej,jc))366 WRITE(numout,*) ' - Maximum value is ', MAXVAL(pdata( nldi:nlei,nldj:nlej,jc))367 WRITE(numout,*) ' - Sum value is ', SUM(pdata( nldi:nlei,nldj:nlej,jc))340 WRITE(numout,*) ' - Minimum value is ', MINVAL(pdata(Nis0:Nie0,Njs0:Nje0,jc)) 341 WRITE(numout,*) ' - Maximum value is ', MAXVAL(pdata(Nis0:Nie0,Njs0:Nje0,jc)) 342 WRITE(numout,*) ' - Sum value is ', SUM(pdata(Nis0:Nie0,Njs0:Nje0,jc)) 368 343 WRITE(numout,*) '****************' 369 344 ENDIF … … 374 349 ENDDO 375 350 ENDDO 376 IF( ltmp_wapatch ) THEN377 nldi = nldi_save ; nlei = nlei_save378 nldj = nldj_save ; nlej = nlej_save379 ENDIF380 351 ! 381 352 END SUBROUTINE cpl_snd … … 396 367 !! 397 368 INTEGER :: jc,jm ! local loop index 398 LOGICAL :: llaction, ll fisrt369 LOGICAL :: llaction, ll_1st 399 370 !!-------------------------------------------------------------------- 400 ! patch to restore wraparound rows in cpl_send, cpl_rcv, cpl_define401 IF( ltmp_wapatch ) THEN402 nldi_save = nldi ; nlei_save = nlei403 nldj_save = nldj ; nlej_save = nlej404 ENDIF405 371 ! 406 372 ! receive local data from OASIS3 on every process … … 409 375 ! 410 376 DO jc = 1, srcv(kid)%nct 411 IF( ltmp_wapatch ) THEN 412 IF( nimpp == 1 ) nldi = 1 413 IF( nimpp + jpi - 1 == jpiglo ) nlei = jpi 414 IF( njmpp == 1 ) nldj = 1 415 IF( njmpp + jpj - 1 == jpjglo ) nlej = jpj 416 ENDIF 417 llfisrt = .TRUE. 377 ll_1st = .TRUE. 418 378 419 379 DO jm = 1, srcv(kid)%ncplmodel … … 431 391 432 392 kinfo = OASIS_Rcv 433 IF( ll fisrt ) THEN434 pdata( nldi:nlei,nldj:nlej,jc) = exfld(:,:) * pmask(nldi:nlei,nldj:nlej,jm)435 ll fisrt = .FALSE.393 IF( ll_1st ) THEN 394 pdata(Nis0:Nie0,Njs0:Nje0,jc) = exfld(:,:) * pmask(Nis0:Nie0,Njs0:Nje0,jm) 395 ll_1st = .FALSE. 436 396 ELSE 437 pdata(nldi:nlei,nldj:nlej,jc) = pdata(nldi:nlei,nldj:nlej,jc) + exfld(:,:) * pmask(nldi:nlei,nldj:nlej,jm) 397 pdata(Nis0:Nie0,Njs0:Nje0,jc) = pdata(Nis0:Nie0,Njs0:Nje0,jc) & 398 & + exfld(:,:) * pmask(Nis0:Nie0,Njs0:Nje0,jm) 438 399 ENDIF 439 400 … … 444 405 WRITE(numout,*) 'oasis_get: kstep', kstep 445 406 WRITE(numout,*) 'oasis_get: info ', kinfo 446 WRITE(numout,*) ' - Minimum value is ', MINVAL(pdata( nldi:nlei,nldj:nlej,jc))447 WRITE(numout,*) ' - Maximum value is ', MAXVAL(pdata( nldi:nlei,nldj:nlej,jc))448 WRITE(numout,*) ' - Sum value is ', SUM(pdata( nldi:nlei,nldj:nlej,jc))407 WRITE(numout,*) ' - Minimum value is ', MINVAL(pdata(Nis0:Nie0,Njs0:Nje0,jc)) 408 WRITE(numout,*) ' - Maximum value is ', MAXVAL(pdata(Nis0:Nie0,Njs0:Nje0,jc)) 409 WRITE(numout,*) ' - Sum value is ', SUM(pdata(Nis0:Nie0,Njs0:Nje0,jc)) 449 410 WRITE(numout,*) '****************' 450 411 ENDIF … … 456 417 ENDDO 457 418 458 IF( ltmp_wapatch ) THEN459 nldi = nldi_save ; nlei = nlei_save460 nldj = nldj_save ; nlej = nlej_save461 ENDIF462 419 !--- Fill the overlap areas and extra hallows (mpp) 463 420 !--- check periodicity conditions (all cases) 464 IF( . not. llfisrt ) THEN421 IF( .NOT. ll_1st ) THEN 465 422 CALL lbc_lnk( 'cpl_oasis3', pdata(:,:,jc), srcv(kid)%clgrid, srcv(kid)%nsgn ) 466 423 ENDIF -
NEMO/trunk/src/OCE/SBC/fldread.F90
r13237 r13286 53 53 LOGICAL :: ln_tint ! time interpolation or not (T/F) 54 54 LOGICAL :: ln_clim ! climatology or not (T/F) 55 CHARACTER(len = 8) :: cl type! type of data file 'daily', 'monthly' or yearly'55 CHARACTER(len = 8) :: clftyp ! type of data file 'daily', 'monthly' or yearly' 56 56 CHARACTER(len = 256) :: wname ! generic name of a NetCDF weights file to be used, blank if not 57 57 CHARACTER(len = 34) :: vcomp ! symbolic component name if a vector that needs rotation … … 69 69 LOGICAL :: ln_tint ! time interpolation or not (T/F) 70 70 LOGICAL :: ln_clim ! climatology or not (T/F) 71 CHARACTER(len = 8) :: cltype ! type of data file 'daily', 'monthly' or yearly' 71 CHARACTER(len = 8) :: clftyp ! type of data file 'daily', 'monthly' or yearly' 72 CHARACTER(len = 1) :: cltype ! nature of grid-points: T, U, V... 73 REAL(wp) :: zsgn ! -1. the sign change across the north fold, = 1. otherwise 72 74 INTEGER :: num ! iom id of the jpfld files to be read 73 INTEGER , DIMENSION(2) :: nrec_b ! before record (1: index, 2: second since Jan. 1st 00h of nit000 year) 74 INTEGER , DIMENSION(2) :: nrec_a ! after record (1: index, 2: second since Jan. 1st 00h of nit000 year) 75 INTEGER , ALLOCATABLE, DIMENSION(: ) :: nrecsec ! 76 REAL(wp), ALLOCATABLE, DIMENSION(:,:,: ) :: fnow ! input fields interpolated to now time step 77 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: fdta ! 2 consecutive record of input fields 75 INTEGER , DIMENSION(2,2) :: nrec ! before/after record (1: index, 2: second since Jan. 1st 00h of yr nit000) 76 INTEGER :: nbb ! index of before values 77 INTEGER :: naa ! index of after values 78 INTEGER , ALLOCATABLE, DIMENSION(:) :: nrecsec ! 79 REAL(wp), POINTER, DIMENSION(:,:,: ) :: fnow ! input fields interpolated to now time step 80 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: fdta ! 2 consecutive record of input fields 78 81 CHARACTER(len = 256) :: wgtname ! current name of the NetCDF weight file acting as a key 79 82 ! ! into the WGTLIST structure … … 157 160 INTEGER :: jf ! dummy indices 158 161 INTEGER :: isecsbc ! number of seconds between Jan. 1st 00h of nit000 year and the middle of sbc time step 162 INTEGER :: ibb, iaa ! shorter name for sd(jf)%nbb and sd(jf)%naa 159 163 LOGICAL :: ll_firstcall ! true if this is the first call to fld_read for this set of fields 160 164 REAL(wp) :: zt_offset ! local time offset variable … … 204 208 IF( TRIM(sd(jf)%clrootname) == 'NOT USED' ) CYCLE 205 209 ! 210 ibb = sd(jf)%nbb ; iaa = sd(jf)%naa 211 ! 206 212 IF( sd(jf)%ln_tint ) THEN ! temporal interpolation 207 213 IF(lwp .AND. kt - nit000 <= 100 ) THEN … … 209 215 & "', records b/a: ', i6.4, '/', i6.4, ' (days ', f9.4,'/', f9.4, ')')" 210 216 WRITE(numout, clfmt) TRIM( sd(jf)%clvar ), kt, REAL(isecsbc,wp)/rday, nyear, nmonth, nday, & 211 & 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)/rday217 & 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 212 218 WRITE(numout, *) ' zt_offset is : ',zt_offset 213 219 ENDIF 214 220 ! temporal interpolation weights 215 ztinta = REAL( isecsbc - sd(jf)%nrec _b(2), wp ) / REAL( sd(jf)%nrec_a(2) - sd(jf)%nrec_b(2), wp )221 ztinta = REAL( isecsbc - sd(jf)%nrec(2,ibb), wp ) / REAL( sd(jf)%nrec(2,iaa) - sd(jf)%nrec(2,ibb), wp ) 216 222 ztintb = 1. - ztinta 217 sd(jf)%fnow(:,:,:) = ztintb * sd(jf)%fdta(:,:,:, 1) + ztinta * sd(jf)%fdta(:,:,:,2)223 sd(jf)%fnow(:,:,:) = ztintb * sd(jf)%fdta(:,:,:,ibb) + ztinta * sd(jf)%fdta(:,:,:,iaa) 218 224 ELSE ! nothing to do... 219 225 IF(lwp .AND. kt - nit000 <= 100 ) THEN … … 221 227 & "', record: ', i6.4, ' (days ', f9.4, ' <-> ', f9.4, ')')" 222 228 WRITE(numout, clfmt) TRIM(sd(jf)%clvar), kt, REAL(isecsbc,wp)/rday, nyear, nmonth, nday, & 223 & sd(jf)%nrec _a(1), REAL(sd(jf)%nrec_b(2),wp)/rday, REAL(sd(jf)%nrec_a(2),wp)/rday229 & sd(jf)%nrec(1,iaa), REAL(sd(jf)%nrec(2,ibb),wp)/rday, REAL(sd(jf)%nrec(2,iaa),wp)/rday 224 230 ENDIF 225 231 ENDIF … … 251 257 ! 252 258 CALL fld_clopn( sdjf ) 253 sdjf%nrec _a(:) = (/ 1, nflag /) ! default definition to force flp_update to read the file.259 sdjf%nrec(:,sdjf%naa) = (/ 1, nflag /) ! default definition to force flp_update to read the file. 254 260 ! 255 261 END SUBROUTINE fld_init … … 262 268 !! ** Purpose : Compute 263 269 !! if sdjf%ln_tint = .TRUE. 264 !! nrec _a: record number and its time (nrec_b is obtained from nrec_awhen swapping)270 !! nrec(:,iaa): record number and its time (nrec(:,ibb) is obtained from nrec(:,iaa) when swapping) 265 271 !! if sdjf%ln_tint = .FALSE. 266 !! nrec _a(1): record number267 !! nrec _b(2) and nrec_a(2): time of the beginning and end of the record272 !! nrec(1,iaa): record number 273 !! nrec(2,ibb) and nrec(2,iaa): time of the beginning and end of the record 268 274 !!---------------------------------------------------------------------- 269 275 INTEGER , INTENT(in ) :: ksecsbc ! … … 271 277 INTEGER , OPTIONAL, INTENT(in ) :: Kmm ! ocean time level index 272 278 ! 273 INTEGER :: ja ! end of this record (in seconds) 274 !!---------------------------------------------------------------------- 275 ! 276 IF( ksecsbc > sdjf%nrec_a(2) ) THEN ! --> we need to update after data 279 INTEGER :: ja ! end of this record (in seconds) 280 INTEGER :: ibb, iaa ! shorter name for sdjf%nbb and sdjf%naa 281 !!---------------------------------------------------------------------- 282 ibb = sdjf%nbb ; iaa = sdjf%naa 283 ! 284 IF( ksecsbc > sdjf%nrec(2,iaa) ) THEN ! --> we need to update after data 277 285 278 ! find where is the new after record... (it is not necessary sdjf%nrec _a(1)+1 )279 ja = sdjf%nrec _a(1)286 ! find where is the new after record... (it is not necessary sdjf%nrec(1,iaa)+1 ) 287 ja = sdjf%nrec(1,iaa) 280 288 DO WHILE ( ksecsbc >= sdjf%nrecsec(ja) .AND. ja < sdjf%nreclast ) ! Warning: make sure ja <= sdjf%nreclast in this test 281 289 ja = ja + 1 … … 284 292 285 293 ! if ln_tint and if the new after is not ja+1, we need also to update after data before the swap 286 ! so, after the swap, sdjf%nrec _b(2) will still be the closest value located just before ksecsbc287 IF( sdjf%ln_tint .AND. ( ja > sdjf%nrec _a(1) + 1 .OR. sdjf%nrec_a(2) == nflag ) ) THEN288 sdjf%nrec _a(:) = (/ ja-1, sdjf%nrecsec(ja-1) /) ! update nrec_awith before information289 CALL fld_get( sdjf, Kmm ) ! read after data that will be used as before data294 ! so, after the swap, sdjf%nrec(2,ibb) will still be the closest value located just before ksecsbc 295 IF( sdjf%ln_tint .AND. ( ja > sdjf%nrec(1,iaa) + 1 .OR. sdjf%nrec(2,iaa) == nflag ) ) THEN 296 sdjf%nrec(:,iaa) = (/ ja-1, sdjf%nrecsec(ja-1) /) ! update nrec(:,iaa) with before information 297 CALL fld_get( sdjf, Kmm ) ! read after data that will be used as before data 290 298 ENDIF 291 299 … … 310 318 ! if ln_tint and if after is not the first record, we must (potentially again) update after data before the swap 311 319 IF( sdjf%ln_tint .AND. ja > 1 ) THEN 312 IF( sdjf%nrecsec(0) /= nflag ) THEN ! no trick used: after file is not the current file313 sdjf%nrec _a(:) = (/ ja-1, sdjf%nrecsec(ja-1) /) ! update nrec_awith before information314 CALL fld_get( sdjf, Kmm ) ! read after data that will be used as before data320 IF( sdjf%nrecsec(0) /= nflag ) THEN ! no trick used: after file is not the current file 321 sdjf%nrec(:,iaa) = (/ ja-1, sdjf%nrecsec(ja-1) /) ! update nrec(:,iaa) with before information 322 CALL fld_get( sdjf, Kmm ) ! read after data that will be used as before data 315 323 ENDIF 316 324 ENDIF … … 318 326 ENDIF 319 327 320 IF( sdjf%ln_tint ) THEN 321 ! Swap data 322 sdjf%nrec_b(:) = sdjf%nrec_a(:) ! swap before record informations 323 sdjf%rotn(1) = sdjf%rotn(2) ! swap before rotate informations 324 sdjf%fdta(:,:,:,1) = sdjf%fdta(:,:,:,2) ! swap before record field 325 ELSE 326 sdjf%nrec_b(:) = (/ ja-1, sdjf%nrecsec(ja-1) /) ! only for print 328 IF( sdjf%ln_tint ) THEN ! Swap data 329 sdjf%nbb = sdjf%naa ! swap indices 330 sdjf%naa = 3 - sdjf%naa ! = 2(1) if naa == 1(2) 331 ELSE ! No swap 332 sdjf%nrec(:,ibb) = (/ ja-1, sdjf%nrecsec(ja-1) /) ! only for print 327 333 ENDIF 328 334 329 335 ! read new after data 330 sdjf%nrec _a(:) = (/ ja, sdjf%nrecsec(ja) /) ! update nrec_aas it is used by fld_get331 CALL fld_get( sdjf, Kmm ) ! read after data (with nrec_ainformations)336 sdjf%nrec(:,sdjf%naa) = (/ ja, sdjf%nrecsec(ja) /) ! update nrec(:,naa) as it is used by fld_get 337 CALL fld_get( sdjf, Kmm ) ! read after data (with nrec(:,naa) informations) 332 338 333 339 ENDIF … … 346 352 ! 347 353 INTEGER :: ipk ! number of vertical levels of sdjf%fdta ( 2D: ipk=1 ; 3D: ipk=jpk ) 354 INTEGER :: iaa ! shorter name for sdjf%naa 348 355 INTEGER :: iw ! index into wgts array 349 INTEGER :: ipdom ! index of the domain350 356 INTEGER :: idvar ! variable ID 351 357 INTEGER :: idmspc ! number of spatial dimensions 352 358 LOGICAL :: lmoor ! C1D case: point data 353 !!--------------------------------------------------------------------- 354 ! 355 ipk = SIZE( sdjf%fnow, 3 ) 356 ! 357 IF( ASSOCIATED(sdjf%imap) ) THEN 358 IF( sdjf%ln_tint ) THEN ; CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fdta(:,:,:,2), sdjf%nrec_a(1), & 359 & sdjf%imap, sdjf%igrd, sdjf%ibdy, sdjf%ltotvel, sdjf%lzint, Kmm ) 360 ELSE ; CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fnow(:,:,: ), sdjf%nrec_a(1), & 361 & sdjf%imap, sdjf%igrd, sdjf%ibdy, sdjf%ltotvel, sdjf%lzint, Kmm ) 362 ENDIF 363 ELSE IF( LEN(TRIM(sdjf%wgtname)) > 0 ) THEN 359 REAL(wp), DIMENSION(:,:,:), POINTER :: dta_alias ! short cut 360 !!--------------------------------------------------------------------- 361 iaa = sdjf%naa 362 ! 363 IF( sdjf%ln_tint ) THEN ; dta_alias => sdjf%fdta(:,:,:,iaa) 364 ELSE ; dta_alias => sdjf%fnow(:,:,: ) 365 ENDIF 366 ipk = SIZE( dta_alias, 3 ) 367 ! 368 IF( ASSOCIATED(sdjf%imap) ) THEN ! BDY case 369 CALL fld_map( sdjf%num, sdjf%clvar, dta_alias(:,:,:), sdjf%nrec(1,iaa), & 370 & sdjf%imap, sdjf%igrd, sdjf%ibdy, sdjf%ltotvel, sdjf%lzint, Kmm ) 371 ELSE IF( LEN(TRIM(sdjf%wgtname)) > 0 ) THEN ! On-the-fly interpolation 364 372 CALL wgt_list( sdjf, iw ) 365 IF( sdjf%ln_tint ) THEN ; CALL fld_interp( sdjf%num, sdjf%clvar, iw, ipk, sdjf%fdta(:,:,:,2), & 366 & sdjf%nrec_a(1), sdjf%lsmname ) 367 ELSE ; CALL fld_interp( sdjf%num, sdjf%clvar, iw, ipk, sdjf%fnow(:,:,: ), & 368 & sdjf%nrec_a(1), sdjf%lsmname ) 369 ENDIF 370 ELSE 371 IF( SIZE(sdjf%fnow, 1) == jpi ) THEN ; ipdom = jpdom_data 372 ELSE ; ipdom = jpdom_unknown 373 ENDIF 373 CALL fld_interp( sdjf%num, sdjf%clvar, iw, ipk, dta_alias(:,:,:), sdjf%nrec(1,iaa), sdjf%lsmname ) 374 CALL lbc_lnk( 'fldread', dta_alias(:,:,:), sdjf%cltype, sdjf%zsgn, kfillmode = jpfillcopy ) 375 ELSE ! default case 374 376 ! C1D case: If product of spatial dimensions == ipk, then x,y are of 375 377 ! size 1 (point/mooring data): this must be read onto the central grid point 376 378 idvar = iom_varid( sdjf%num, sdjf%clvar ) 377 379 idmspc = iom_file ( sdjf%num )%ndims( idvar ) 378 IF( iom_file( sdjf%num )%luld( idvar ) ) idmspc = idmspc - 1 379 lmoor = ( idmspc == 0 .OR. PRODUCT( iom_file( sdjf%num )%dimsz( 1:MAX(idmspc,1) ,idvar ) ) == ipk ) 380 ! 381 SELECT CASE( ipk ) 382 CASE(1) 383 IF( lk_c1d .AND. lmoor ) THEN 384 IF( sdjf%ln_tint ) THEN 385 CALL iom_get( sdjf%num, sdjf%clvar, sdjf%fdta(2,2,1,2), sdjf%nrec_a(1) ) 386 CALL lbc_lnk( 'fldread', sdjf%fdta(:,:,1,2),'Z',1.0_wp ) 387 ELSE 388 CALL iom_get( sdjf%num, sdjf%clvar, sdjf%fnow(2,2,1 ), sdjf%nrec_a(1) ) 389 CALL lbc_lnk( 'fldread', sdjf%fnow(:,:,1 ),'Z',1.0_wp ) 390 ENDIF 391 ELSE 392 IF( sdjf%ln_tint ) THEN ; CALL iom_get( sdjf%num, ipdom, sdjf%clvar, sdjf%fdta(:,:,1,2), sdjf%nrec_a(1) ) 393 ELSE ; CALL iom_get( sdjf%num, ipdom, sdjf%clvar, sdjf%fnow(:,:,1 ), sdjf%nrec_a(1) ) 394 ENDIF 395 ENDIF 396 CASE DEFAULT 397 IF(lk_c1d .AND. lmoor ) THEN 398 IF( sdjf%ln_tint ) THEN 399 CALL iom_get( sdjf%num, jpdom_unknown, sdjf%clvar, sdjf%fdta(2,2,:,2), sdjf%nrec_a(1) ) 400 CALL lbc_lnk( 'fldread', sdjf%fdta(:,:,:,2),'Z',1.0_wp ) 401 ELSE 402 CALL iom_get( sdjf%num, jpdom_unknown, sdjf%clvar, sdjf%fnow(2,2,: ), sdjf%nrec_a(1) ) 403 CALL lbc_lnk( 'fldread', sdjf%fnow(:,:,: ),'Z',1.0_wp ) 404 ENDIF 405 ELSE 406 IF( sdjf%ln_tint ) THEN ; CALL iom_get( sdjf%num, ipdom, sdjf%clvar, sdjf%fdta(:,:,:,2), sdjf%nrec_a(1) ) 407 ELSE ; CALL iom_get( sdjf%num, ipdom, sdjf%clvar, sdjf%fnow(:,:,: ), sdjf%nrec_a(1) ) 408 ENDIF 409 ENDIF 410 END SELECT 411 ENDIF 412 ! 413 sdjf%rotn(2) = .false. ! vector not yet rotated 380 IF( iom_file( sdjf%num )%luld( idvar ) ) idmspc = idmspc - 1 ! id of the last spatial dimension 381 lmoor = ( idmspc == 0 .OR. PRODUCT( iom_file( sdjf%num )%dimsz( 1:MAX(idmspc,1) ,idvar ) ) == ipk ) 382 ! 383 IF( lk_c1d .AND. lmoor ) THEN 384 CALL iom_get( sdjf%num, jpdom_unknown, sdjf%clvar, dta_alias(2,2,:), sdjf%nrec(1,iaa) ) ! jpdom_unknown -> no lbc_lnk 385 CALL lbc_lnk( 'fldread', dta_alias(:,:,:), 'T', 1., kfillmode = jpfillcopy ) 386 ELSE 387 CALL iom_get( sdjf%num, jpdom_global, sdjf%clvar, dta_alias(:,:,:), sdjf%nrec(1,iaa), & 388 & sdjf%cltype, sdjf%zsgn, kfill = jpfillcopy ) 389 ENDIF 390 ENDIF 391 ! 392 sdjf%rotn(iaa) = .false. ! vector not yet rotated 414 393 ! 415 394 END SUBROUTINE fld_get … … 447 426 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zdta_read_z ! work space local data requiring vertical interpolation 448 427 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zdta_read_dz ! work space local data requiring vertical interpolation 449 CHARACTER(LEN=1),DIMENSION(3) :: cl grid428 CHARACTER(LEN=1),DIMENSION(3) :: cltype 450 429 LOGICAL :: lluld ! is the variable using the unlimited dimension 451 430 LOGICAL :: llzint ! local value of ldzint 452 431 !!--------------------------------------------------------------------- 453 432 ! 454 cl grid= (/'t','u','v'/)433 cltype = (/'t','u','v'/) 455 434 ! 456 435 ipi = SIZE( pdta, 1 ) … … 487 466 IF( ipkb /= ipk .OR. llzint ) THEN ! boundary data not on model vertical grid : vertical interpolation 488 467 ! 489 IF( ipk == jpk .AND. iom_varid(knum,'gdep'//cl grid(kgrd)) /= -1 .AND. iom_varid(knum,'e3'//clgrid(kgrd)) /= -1 ) THEN468 IF( ipk == jpk .AND. iom_varid(knum,'gdep'//cltype(kgrd)) /= -1 .AND. iom_varid(knum,'e3'//cltype(kgrd)) /= -1 ) THEN 490 469 491 470 ALLOCATE( zdta_read(ipi,ipj,ipkb), zdta_read_z(ipi,ipj,ipkb), zdta_read_dz(ipi,ipj,ipkb) ) 492 471 493 472 CALL fld_map_core( zz_read, kmap, zdta_read ) 494 CALL iom_get ( knum, jpdom_unknown, 'gdep'//cl grid(kgrd), zz_read ) ! read only once? Potential temporal evolution?473 CALL iom_get ( knum, jpdom_unknown, 'gdep'//cltype(kgrd), zz_read ) ! read only once? Potential temporal evolution? 495 474 CALL fld_map_core( zz_read, kmap, zdta_read_z ) 496 CALL iom_get ( knum, jpdom_unknown, 'e3'//cl grid(kgrd), zz_read ) ! read only once? Potential temporal evolution?475 CALL iom_get ( knum, jpdom_unknown, 'e3'//cltype(kgrd), zz_read ) ! read only once? Potential temporal evolution? 497 476 CALL fld_map_core( zz_read, kmap, zdta_read_dz ) 498 477 … … 504 483 IF( ipk /= jpk ) CALL ctl_stop( 'fld_map : this should be an impossible case...' ) 505 484 WRITE(ctmp1,*) 'fld_map : vertical interpolation for bdy variable '//TRIM(cdvar)//' requires ' 506 IF( iom_varid(knum, 'gdep'//cl grid(kgrd)) == -1 ) CALL ctl_stop( ctmp1//'gdep'//clgrid(kgrd)//' variable' )507 IF( iom_varid(knum, 'e3'//cl grid(kgrd)) == -1 ) CALL ctl_stop( ctmp1// 'e3'//clgrid(kgrd)//' variable' )485 IF( iom_varid(knum, 'gdep'//cltype(kgrd)) == -1 ) CALL ctl_stop( ctmp1//'gdep'//cltype(kgrd)//' variable' ) 486 IF( iom_varid(knum, 'e3'//cltype(kgrd)) == -1 ) CALL ctl_stop( ctmp1// 'e3'//cltype(kgrd)//' variable' ) 508 487 509 488 ENDIF … … 728 707 CHARACTER (LEN=100) :: clcomp ! dummy weight name 729 708 REAL(wp), DIMENSION(jpi,jpj) :: utmp, vtmp ! temporary arrays for vector rotation 709 REAL(wp), DIMENSION(:,:,:), POINTER :: dta_u, dta_v ! short cut 730 710 !!--------------------------------------------------------------------- 731 711 ! … … 747 727 END DO 748 728 IF( iv > 0 ) THEN ! fields ju and iv are two components which need to be rotated together 729 IF( sd(ju)%ln_tint ) THEN ; dta_u => sd(ju)%fdta(:,:,:,jn) ; dta_v => sd(iv)%fdta(:,:,:,jn) 730 ELSE ; dta_u => sd(ju)%fnow(:,:,: ) ; dta_v => sd(iv)%fnow(:,:,: ) 731 ENDIF 749 732 DO jk = 1, SIZE( sd(ju)%fnow, 3 ) 750 IF( sd(ju)%ln_tint )THEN 751 CALL rot_rep( sd(ju)%fdta(:,:,jk,jn), sd(iv)%fdta(:,:,jk,jn), 'T', 'en->i', utmp(:,:) ) 752 CALL rot_rep( sd(ju)%fdta(:,:,jk,jn), sd(iv)%fdta(:,:,jk,jn), 'T', 'en->j', vtmp(:,:) ) 753 sd(ju)%fdta(:,:,jk,jn) = utmp(:,:) ; sd(iv)%fdta(:,:,jk,jn) = vtmp(:,:) 754 ELSE 755 CALL rot_rep( sd(ju)%fnow(:,:,jk ), sd(iv)%fnow(:,:,jk ), 'T', 'en->i', utmp(:,:) ) 756 CALL rot_rep( sd(ju)%fnow(:,:,jk ), sd(iv)%fnow(:,:,jk ), 'T', 'en->j', vtmp(:,:) ) 757 sd(ju)%fnow(:,:,jk ) = utmp(:,:) ; sd(iv)%fnow(:,:,jk ) = vtmp(:,:) 758 ENDIF 733 CALL rot_rep( dta_u(:,:,jk), dta_v(:,:,jk), 'T', 'en->i', utmp(:,:) ) 734 CALL rot_rep( dta_u(:,:,jk), dta_v(:,:,jk), 'T', 'en->j', vtmp(:,:) ) 735 dta_u(:,:,jk) = utmp(:,:) ; dta_v(:,:,jk) = vtmp(:,:) 759 736 END DO 760 737 sd(ju)%rotn(jn) = .TRUE. ! vector was rotated … … 802 779 803 780 ! current file parameters 804 IF( sdjf%cl type(1:4) == 'week' ) THEN! find the day of the beginning of the current week805 isecwk = ksec_week( sdjf%cl type(6:8) ) ! seconds between the beginning of the week and half of current time step806 llprevmt = isecwk > nsec_month 781 IF( sdjf%clftyp(1:4) == 'week' ) THEN ! find the day of the beginning of the current week 782 isecwk = ksec_week( sdjf%clftyp(6:8) ) ! seconds between the beginning of the week and half of current time step 783 llprevmt = isecwk > nsec_month ! longer time since beginning of the current week than the current month 807 784 llprevyr = llprevmt .AND. nmonth == 1 808 785 iyr = nyear - COUNT((/llprevyr/)) 809 786 imt = nmonth - COUNT((/llprevmt/)) + 12 * COUNT((/llprevyr/)) 810 787 idy = nday + nmonth_len(nmonth-1) * COUNT((/llprevmt/)) - isecwk / idaysec 811 isecwk = nsec_year - isecwk ! seconds between 00h jan 1st of current year and current week beginning788 isecwk = nsec_year - isecwk ! seconds between 00h jan 1st of current year and current week beginning 812 789 ELSE 813 790 iyr = nyear … … 819 796 ! previous file parameters 820 797 IF( llprev ) THEN 821 IF( sdjf%cl type(1:4) == 'week' ) THEN! find the day of the beginning of previous week822 isecwk = isecwk + 7 * idaysec ! seconds between the beginning of previous week and half of the time step823 llprevmt = isecwk > nsec_month 798 IF( sdjf%clftyp(1:4) == 'week' ) THEN ! find the day of the beginning of previous week 799 isecwk = isecwk + 7 * idaysec ! seconds between the beginning of previous week and half of the time step 800 llprevmt = isecwk > nsec_month ! longer time since beginning of the previous week than the current month 824 801 llprevyr = llprevmt .AND. nmonth == 1 825 802 iyr = nyear - COUNT((/llprevyr/)) 826 803 imt = nmonth - COUNT((/llprevmt/)) + 12 * COUNT((/llprevyr/)) 827 804 idy = nday + nmonth_len(nmonth-1) * COUNT((/llprevmt/)) - isecwk / idaysec 828 isecwk = nsec_year - isecwk ! seconds between 00h jan 1st of current year and previous week beginning805 isecwk = nsec_year - isecwk ! seconds between 00h jan 1st of current year and previous week beginning 829 806 ELSE 830 idy = nday - COUNT((/ sdjf%cl type== 'daily' /))831 imt = nmonth - COUNT((/ sdjf%cl type== 'monthly' .OR. idy == 0 /))832 iyr = nyear - COUNT((/ sdjf%cl type== 'yearly' .OR. imt == 0 /))807 idy = nday - COUNT((/ sdjf%clftyp == 'daily' /)) 808 imt = nmonth - COUNT((/ sdjf%clftyp == 'monthly' .OR. idy == 0 /)) 809 iyr = nyear - COUNT((/ sdjf%clftyp == 'yearly' .OR. imt == 0 /)) 833 810 IF( idy == 0 ) idy = nmonth_len(imt) 834 811 IF( imt == 0 ) imt = 12 … … 839 816 ! next file parameters 840 817 IF( llnext ) THEN 841 IF( sdjf%cl type(1:4) == 'week' ) THEN! find the day of the beginning of next week842 isecwk = 7 * idaysec - isecwk ! seconds between half of the time step and the beginning of next week818 IF( sdjf%clftyp(1:4) == 'week' ) THEN ! find the day of the beginning of next week 819 isecwk = 7 * idaysec - isecwk ! seconds between half of the time step and the beginning of next week 843 820 llnextmt = isecwk > ( nmonth_len(nmonth)*idaysec - nsec_month ) ! larger than the seconds to the end of the month 844 821 llnextyr = llnextmt .AND. nmonth == 12 … … 846 823 imt = nmonth + COUNT((/llnextmt/)) - 12 * COUNT((/llnextyr/)) 847 824 idy = nday - nmonth_len(nmonth) * COUNT((/llnextmt/)) + isecwk / idaysec + 1 848 isecwk = nsec_year + isecwk ! seconds between 00h jan 1st of current year and next week beginning825 isecwk = nsec_year + isecwk ! seconds between 00h jan 1st of current year and next week beginning 849 826 ELSE 850 idy = nday + COUNT((/ sdjf%cl type== 'daily' /))851 imt = nmonth + COUNT((/ sdjf%cl type== 'monthly' .OR. idy > nmonth_len(nmonth) /))852 iyr = nyear + COUNT((/ sdjf%cl type== 'yearly' .OR. imt == 13 /))827 idy = nday + COUNT((/ sdjf%clftyp == 'daily' /)) 828 imt = nmonth + COUNT((/ sdjf%clftyp == 'monthly' .OR. idy > nmonth_len(nmonth) /)) 829 iyr = nyear + COUNT((/ sdjf%clftyp == 'yearly' .OR. imt == 13 /)) 853 830 IF( idy > nmonth_len(nmonth) ) idy = 1 854 831 IF( imt == 13 ) imt = 1 … … 867 844 IF ( NINT(sdjf%freqh) == -12 ) THEN ; ireclast = 1 ! yearly mean: consider only 1 record 868 845 ELSEIF( NINT(sdjf%freqh) == -1 ) THEN ! monthly mean: 869 IF( sdjf%cl type== 'monthly' ) THEN ; ireclast = 1 ! consider that the file has 1 record846 IF( sdjf%clftyp == 'monthly' ) THEN ; ireclast = 1 ! consider that the file has 1 record 870 847 ELSE ; ireclast = 12 ! consider that the file has 12 record 871 848 ENDIF 872 849 ELSE ! higher frequency mean (in hours) 873 IF( sdjf%cl type== 'monthly' ) THEN ; ireclast = NINT( 24. * REAL(nmonth_len(indexmt), wp) / sdjf%freqh )874 ELSEIF( sdjf%cl type(1:4) == 'week' ) THEN ; ireclast = NINT( 24. * 7. / sdjf%freqh )875 ELSEIF( sdjf%cl type== 'daily' ) THEN ; ireclast = NINT( 24. / sdjf%freqh )850 IF( sdjf%clftyp == 'monthly' ) THEN ; ireclast = NINT( 24. * REAL(nmonth_len(indexmt), wp) / sdjf%freqh ) 851 ELSEIF( sdjf%clftyp(1:4) == 'week' ) THEN ; ireclast = NINT( 24. * 7. / sdjf%freqh ) 852 ELSEIF( sdjf%clftyp == 'daily' ) THEN ; ireclast = NINT( 24. / sdjf%freqh ) 876 853 ELSE ; ireclast = NINT( 24. * REAL( nyear_len(indexyr), wp) / sdjf%freqh ) 877 854 ENDIF … … 891 868 sdjf%nrecsec(1) = sdjf%nrecsec(0) + nyear_len( indexyr ) * idaysec 892 869 ELSEIF( NINT(sdjf%freqh) == -1 ) THEN ! monthly mean: 893 IF( sdjf%cl type== 'monthly' ) THEN ! monthly file870 IF( sdjf%clftyp == 'monthly' ) THEN ! monthly file 894 871 sdjf%nrecsec(0 ) = nsec1jan000 + nmonth_beg(indexmt ) 895 872 sdjf%nrecsec(1 ) = nsec1jan000 + nmonth_beg(indexmt+1) … … 899 876 ENDIF 900 877 ELSE ! higher frequency mean (in hours) 901 IF( sdjf%cl type== 'monthly' ) THEN ; istart = nsec1jan000 + nmonth_beg(indexmt)902 ELSEIF( sdjf%cl type(1:4) == 'week' ) THEN ; istart = nsec1jan000 + isecwk903 ELSEIF( sdjf%cl type== 'daily' ) THEN ; istart = nsec1jan000 + nmonth_beg(indexmt) + ( idy - 1 ) * idaysec878 IF( sdjf%clftyp == 'monthly' ) THEN ; istart = nsec1jan000 + nmonth_beg(indexmt) 879 ELSEIF( sdjf%clftyp(1:4) == 'week' ) THEN ; istart = nsec1jan000 + isecwk 880 ELSEIF( sdjf%clftyp == 'daily' ) THEN ; istart = nsec1jan000 + nmonth_beg(indexmt) + ( idy - 1 ) * idaysec 904 881 ELSEIF( indexyr == 0 ) THEN ; istart = nsec1jan000 - nyear_len( 0 ) * idaysec 905 882 ELSEIF( indexyr == 2 ) THEN ; istart = nsec1jan000 + nyear_len( 1 ) * idaysec … … 942 919 IF( sdjf%num <= 0 .OR. .NOT. sdjf%ln_clim ) THEN 943 920 IF( sdjf%num > 0 ) CALL iom_close( sdjf%num ) ! close file if already open 944 CALL iom_open( sdjf%clname, sdjf%num, ldstop = llstop, ldiof = LEN (TRIM(sdjf%wgtname)) > 0 )921 CALL iom_open( sdjf%clname, sdjf%num, ldstop = llstop, ldiof = LEN_TRIM(sdjf%wgtname) > 0 ) 945 922 ENDIF 946 923 ! … … 964 941 ENDIF 965 942 ! 966 CALL iom_open( sdjf%clname, sdjf%num, ldiof = LEN (TRIM(sdjf%wgtname)) > 0 )943 CALL iom_open( sdjf%clname, sdjf%num, ldiof = LEN_TRIM(sdjf%wgtname) > 0 ) 967 944 ! 968 945 ENDIF … … 997 974 sdf(jf)%ln_tint = sdf_n(jf)%ln_tint 998 975 sdf(jf)%ln_clim = sdf_n(jf)%ln_clim 999 sdf(jf)%cltype = sdf_n(jf)%cltype 976 sdf(jf)%clftyp = sdf_n(jf)%clftyp 977 sdf(jf)%cltype = 'T' ! by default don't do any call to lbc_lnk in iom_get 978 sdf(jf)%zsgn = 1. ! by default don't do change signe across the north fold 1000 979 sdf(jf)%num = -1 980 sdf(jf)%nbb = 1 ! start with before data in 1 981 sdf(jf)%naa = 2 ! start with after data in 2 1001 982 sdf(jf)%wgtname = " " 1002 983 IF( LEN( TRIM(sdf_n(jf)%wname) ) > 0 ) sdf(jf)%wgtname = TRIM( cdir )//sdf_n(jf)%wname … … 1005 986 sdf(jf)%vcomp = sdf_n(jf)%vcomp 1006 987 sdf(jf)%rotn(:) = .TRUE. ! pretend to be rotated -> won't try to rotate data before the first call to fld_get 1007 IF( sdf(jf)%cl type(1:4) == 'week' .AND. nn_leapy == 0 ) &988 IF( sdf(jf)%clftyp(1:4) == 'week' .AND. nn_leapy == 0 ) & 1008 989 & CALL ctl_stop('fld_clopn: weekly file ('//TRIM(sdf(jf)%clrootname)//') needs nn_leapy = 1') 1009 IF( sdf(jf)%cl type(1:4) == 'week' .AND. sdf(jf)%ln_clim ) &990 IF( sdf(jf)%clftyp(1:4) == 'week' .AND. sdf(jf)%ln_clim ) & 1010 991 & CALL ctl_stop('fld_clopn: weekly file ('//TRIM(sdf(jf)%clrootname)//') needs ln_clim = .FALSE.') 1011 992 sdf(jf)%nreclast = -1 ! Set to non zero default value to avoid errors, is updated to meaningful value during fld_clopn … … 1033 1014 WRITE(numout,*) ' weights: ' , TRIM( sdf(jf)%wgtname ), & 1034 1015 & ' pairing: ' , TRIM( sdf(jf)%vcomp ), & 1035 & ' data type: ' , sdf(jf)%cl type, &1016 & ' data type: ' , sdf(jf)%clftyp , & 1036 1017 & ' land/sea mask:' , TRIM( sdf(jf)%lsmname ) 1037 1018 call flush(numout) … … 1051 1032 !!---------------------------------------------------------------------- 1052 1033 TYPE( FLD ), INTENT(in ) :: sd ! field with name of weights file 1053 INTEGER , INTENT( inout) :: kwgt ! index of weights1034 INTEGER , INTENT( out) :: kwgt ! index of weights 1054 1035 ! 1055 1036 INTEGER :: kw, nestid ! local integer 1056 LOGICAL :: found ! local logical1057 1037 !!---------------------------------------------------------------------- 1058 1038 ! 1059 1039 !! search down linked list 1060 1040 !! weights filename is either present or we hit the end of the list 1061 found = .FALSE.1062 1041 ! 1063 1042 !! because agrif nest part of filenames are now added in iom_open … … 1069 1048 #endif 1070 1049 DO kw = 1, nxt_wgt-1 1071 IF( TRIM(ref_wgts(kw)%wgtname) == TRIM(sd%wgtname).AND. &1072 ref_wgts(kw)%nestid == nestid) THEN1050 IF( ref_wgts(kw)%wgtname == sd%wgtname .AND. & 1051 ref_wgts(kw)%nestid == nestid) THEN 1073 1052 kwgt = kw 1074 found = .TRUE. 1075 EXIT 1053 RETURN 1076 1054 ENDIF 1077 1055 END DO 1078 IF( .NOT.found ) THEN 1079 kwgt = nxt_wgt 1080 CALL fld_weight( sd ) 1081 ENDIF 1056 kwgt = nxt_wgt 1057 CALL fld_weight( sd ) 1082 1058 ! 1083 1059 END SUBROUTINE wgt_list … … 1122 1098 TYPE( FLD ), INTENT(in) :: sd ! field with name of weights file 1123 1099 !! 1124 INTEGER :: j n! dummy loop indices1100 INTEGER :: ji,jj,jn ! dummy loop indices 1125 1101 INTEGER :: inum ! local logical unit 1126 1102 INTEGER :: id ! local variable id … … 1128 1104 INTEGER :: zwrap ! local integer 1129 1105 LOGICAL :: cyclical ! 1130 CHARACTER (len=5) :: aname !1131 INTEGER , DIMENSION( :), ALLOCATABLE:: ddims1132 INTEGER , DIMENSION(jpi,jpj) :: data_src1106 CHARACTER (len=5) :: clname ! 1107 INTEGER , DIMENSION(4) :: ddims 1108 INTEGER :: isrc 1133 1109 REAL(wp), DIMENSION(jpi,jpj) :: data_tmp 1134 1110 !!---------------------------------------------------------------------- … … 1143 1119 !! current weights file 1144 1120 1145 !! open input data file (non-model grid) 1146 CALL iom_open( sd%clname, inum, ldiof = LEN(TRIM(sd%wgtname)) > 0 ) 1147 1148 !! get dimensions: we consider 2D data as 3D data with vertical dim size = 1 1149 IF( SIZE(sd%fnow, 3) > 0 ) THEN 1150 ALLOCATE( ddims(4) ) 1151 ELSE 1152 ALLOCATE( ddims(3) ) 1153 ENDIF 1154 id = iom_varid( inum, sd%clvar, ddims ) 1155 1156 !! close it 1157 CALL iom_close( inum ) 1121 !! get data grid dimensions 1122 id = iom_varid( sd%num, sd%clvar, ddims ) 1158 1123 1159 1124 !! now open the weights file 1160 1161 1125 CALL iom_open ( sd%wgtname, inum ) ! interpolation weights 1162 1126 IF( inum > 0 ) THEN … … 1194 1158 !! two possible cases: bilinear (4 weights) or bicubic (16 weights) 1195 1159 id = iom_varid(inum, 'src05', ldstop=.FALSE.) 1196 IF( id <= 0) THEN 1197 ref_wgts(nxt_wgt)%numwgt = 4 1198 ELSE 1199 ref_wgts(nxt_wgt)%numwgt = 16 1200 ENDIF 1201 1202 ALLOCATE( ref_wgts(nxt_wgt)%data_jpi(jpi,jpj,4) ) 1203 ALLOCATE( ref_wgts(nxt_wgt)%data_jpj(jpi,jpj,4) ) 1204 ALLOCATE( ref_wgts(nxt_wgt)%data_wgt(jpi,jpj,ref_wgts(nxt_wgt)%numwgt) ) 1160 IF( id <= 0 ) THEN ; ref_wgts(nxt_wgt)%numwgt = 4 1161 ELSE ; ref_wgts(nxt_wgt)%numwgt = 16 1162 ENDIF 1163 1164 ALLOCATE( ref_wgts(nxt_wgt)%data_jpi(Nis0:Nie0,Njs0:Nje0,4) ) 1165 ALLOCATE( ref_wgts(nxt_wgt)%data_jpj(Nis0:Nie0,Njs0:Nje0,4) ) 1166 ALLOCATE( ref_wgts(nxt_wgt)%data_wgt(Nis0:Nie0,Njs0:Nje0,ref_wgts(nxt_wgt)%numwgt) ) 1205 1167 1206 1168 DO jn = 1,4 1207 aname = ' '1208 WRITE(aname,'(a3,i2.2)') 'src',jn1209 data_tmp(:,:) =01210 CALL iom_get ( inum, jpdom_data, aname, data_tmp(:,:) )1211 data_src(:,:) = INT(data_tmp(:,:))1212 ref_wgts(nxt_wgt)%data_jpj(:,:,jn) = 1 + (data_src(:,:)-1)/ ref_wgts(nxt_wgt)%ddims(1)1213 ref_wgts(nxt_wgt)%data_jpi(:,:,jn) = data_src(:,:) - ref_wgts(nxt_wgt)%ddims(1)*(ref_wgts(nxt_wgt)%data_jpj(:,:,jn)-1)1169 WRITE(clname,'(a3,i2.2)') 'src',jn 1170 CALL iom_get ( inum, jpdom_global, clname, data_tmp(:,:), cd_type = 'Z' ) ! no call to lbc_lnk 1171 DO_2D_00_00 1172 isrc = NINT(data_tmp(ji,jj)) - 1 1173 ref_wgts(nxt_wgt)%data_jpi(ji,jj,jn) = 1 + MOD(isrc, ref_wgts(nxt_wgt)%ddims(1)) 1174 ref_wgts(nxt_wgt)%data_jpj(ji,jj,jn) = 1 + isrc / ref_wgts(nxt_wgt)%ddims(1) 1175 END_2D 1214 1176 END DO 1215 1177 1216 1178 DO jn = 1, ref_wgts(nxt_wgt)%numwgt 1217 aname = ' ' 1218 WRITE(aname,'(a3,i2.2)') 'wgt',jn 1219 ref_wgts(nxt_wgt)%data_wgt(:,:,jn) = 0.0 1220 CALL iom_get ( inum, jpdom_data, aname, ref_wgts(nxt_wgt)%data_wgt(:,:,jn) ) 1179 WRITE(clname,'(a3,i2.2)') 'wgt',jn 1180 CALL iom_get ( inum, jpdom_global, clname, data_tmp(:,:), cd_type = 'Z' ) ! no call to lbc_lnk 1181 DO_2D_00_00 1182 ref_wgts(nxt_wgt)%data_wgt(ji,jj,jn) = data_tmp(ji,jj) 1183 END_2D 1221 1184 END DO 1222 1185 CALL iom_close (inum) 1223 1186 1224 1187 ! find min and max indices in grid 1225 ref_wgts(nxt_wgt)%botleft( 1) = MINVAL(ref_wgts(nxt_wgt)%data_jpi(:,:,:))1226 ref_wgts(nxt_wgt)%botleft( 2) = MINVAL(ref_wgts(nxt_wgt)%data_jpj(:,:,:))1188 ref_wgts(nxt_wgt)%botleft( 1) = MINVAL(ref_wgts(nxt_wgt)%data_jpi(:,:,:)) 1189 ref_wgts(nxt_wgt)%botleft( 2) = MINVAL(ref_wgts(nxt_wgt)%data_jpj(:,:,:)) 1227 1190 ref_wgts(nxt_wgt)%topright(1) = MAXVAL(ref_wgts(nxt_wgt)%data_jpi(:,:,:)) 1228 1191 ref_wgts(nxt_wgt)%topright(2) = MAXVAL(ref_wgts(nxt_wgt)%data_jpj(:,:,:)) … … 1248 1211 CALL ctl_stop( ' fld_weight : unable to read the file ' ) 1249 1212 ENDIF 1250 1251 DEALLOCATE (ddims )1252 1213 ! 1253 1214 END SUBROUTINE fld_weight … … 1282 1243 SELECT CASE( SIZE(zfieldo(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:),3) ) 1283 1244 CASE(1) 1284 CALL iom_get( inum, jpdom_unknown, 'LSM', zslmec1(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,1), 1, rec1_lsm, recn_lsm) 1245 CALL iom_get( inum, jpdom_unknown, 'LSM', zslmec1(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,1), & 1246 & 1, kstart = rec1_lsm, kcount = recn_lsm) 1285 1247 CASE DEFAULT 1286 CALL iom_get( inum, jpdom_unknown, 'LSM', zslmec1(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:), 1, rec1_lsm, recn_lsm) 1248 CALL iom_get( inum, jpdom_unknown, 'LSM', zslmec1(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:), & 1249 & 1, kstart = rec1_lsm, kcount = recn_lsm) 1287 1250 END SELECT 1288 1251 CALL iom_close( inum ) … … 1357 1320 1358 1321 1359 SUBROUTINE fld_interp( num, clvar, kw, kk, dta, & 1360 & nrec, lsmfile) 1322 SUBROUTINE fld_interp( num, clvar, kw, kk, dta, nrec, lsmfile) 1361 1323 !!--------------------------------------------------------------------- 1362 1324 !! *** ROUTINE fld_interp *** … … 1376 1338 INTEGER, DIMENSION(3) :: rec1_lsm, recn_lsm ! temporary arrays for start and length in case of seaoverland 1377 1339 INTEGER :: ii_lsm1,ii_lsm2,ij_lsm1,ij_lsm2 ! temporary indices 1378 INTEGER :: jk, jn, jm, jir, jjr ! loop counters 1340 INTEGER :: ji, jj, jk, jn, jir, jjr ! loop counters 1341 INTEGER :: ipk 1379 1342 INTEGER :: ni, nj ! lengths 1380 1343 INTEGER :: jpimin,jpiwid ! temporary indices … … 1387 1350 REAL(wp),DIMENSION(:,:,:), ALLOCATABLE :: ztmp_fly_dta ! local array of values on input grid 1388 1351 !!---------------------------------------------------------------------- 1352 ipk = SIZE(dta, 3) 1389 1353 ! 1390 1354 !! for weighted interpolation we have weights at four corners of a box surrounding … … 1416 1380 1417 1381 1418 IF( LEN ( TRIM(lsmfile)) > 0 ) THEN1382 IF( LEN_TRIM(lsmfile) > 0 ) THEN 1419 1383 !! indeces for ztmp_fly_dta 1420 1384 ! -------------------------- … … 1446 1410 CASE(1) 1447 1411 CALL iom_get( num, jpdom_unknown, clvar, ztmp_fly_dta(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,1), & 1448 & nrec, rec1_lsm,recn_lsm)1412 & nrec, kstart = rec1_lsm, kcount = recn_lsm) 1449 1413 CASE DEFAULT 1450 1414 CALL iom_get( num, jpdom_unknown, clvar, ztmp_fly_dta(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:), & 1451 & nrec, rec1_lsm,recn_lsm)1415 & nrec, kstart = rec1_lsm, kcount = recn_lsm) 1452 1416 END SELECT 1453 1417 CALL apply_seaoverland(lsmfile,ztmp_fly_dta(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:), & … … 1469 1433 1470 1434 ref_wgts(kw)%fly_dta(:,:,:) = 0.0 1471 CALL iom_get( num, jpdom_unknown, clvar, ref_wgts(kw)%fly_dta(jpi1:jpi2,jpj1:jpj2,:), nrec, rec1,recn)1435 CALL iom_get( num, jpdom_unknown, clvar, ref_wgts(kw)%fly_dta(jpi1:jpi2,jpj1:jpj2,:), nrec, kstart = rec1, kcount = recn) 1472 1436 ENDIF 1473 1437 … … 1475 1439 !! first four weights common to both bilinear and bicubic 1476 1440 !! data_jpi, data_jpj have already been shifted to (1,1) corresponding to botleft 1477 !! note that we have to offset by 1 into fly_dta array because of halo 1478 dta(:,:,:) = 0.0 1479 DO jk = 1,4 1480 DO jn = 1, jpj 1481 DO jm = 1,jpi 1482 ni = ref_wgts(kw)%data_jpi(jm,jn,jk) 1483 nj = ref_wgts(kw)%data_jpj(jm,jn,jk) 1484 dta(jm,jn,:) = dta(jm,jn,:) + ref_wgts(kw)%data_wgt(jm,jn,jk) * ref_wgts(kw)%fly_dta(ni+1,nj+1,:) 1485 END DO 1486 END DO 1441 !! note that we have to offset by 1 into fly_dta array because of halo added to fly_dta (rec1 definition) 1442 dta(:,:,:) = 0._wp 1443 DO jn = 1,4 1444 DO_3D_00_00( 1,ipk ) 1445 ni = ref_wgts(kw)%data_jpi(ji,jj,jn) + 1 1446 nj = ref_wgts(kw)%data_jpj(ji,jj,jn) + 1 1447 dta(ji,jj,jk) = dta(ji,jj,jk) + ref_wgts(kw)%data_wgt(ji,jj,jn) * ref_wgts(kw)%fly_dta(ni,nj,jk) 1448 END_3D 1487 1449 END DO 1488 1450 1489 1451 IF(ref_wgts(kw)%numwgt .EQ. 16) THEN 1490 1452 1491 !! fix up halo points that we couldnt read from file 1492 IF( jpi1 == 2 ) THEN 1493 ref_wgts(kw)%fly_dta(jpi1-1,:,:) = ref_wgts(kw)%fly_dta(jpi1,:,:) 1494 ENDIF 1495 IF( jpi2 + jpimin - 1 == ref_wgts(kw)%ddims(1)+1 ) THEN 1496 ref_wgts(kw)%fly_dta(jpi2+1,:,:) = ref_wgts(kw)%fly_dta(jpi2,:,:) 1497 ENDIF 1498 IF( jpj1 == 2 ) THEN 1499 ref_wgts(kw)%fly_dta(:,jpj1-1,:) = ref_wgts(kw)%fly_dta(:,jpj1,:) 1500 ENDIF 1501 IF( jpj2 + jpjmin - 1 == ref_wgts(kw)%ddims(2)+1 .AND. jpj2 .lt. jpjwid+2 ) THEN 1502 ref_wgts(kw)%fly_dta(:,jpj2+1,:) = 2.0*ref_wgts(kw)%fly_dta(:,jpj2,:) - ref_wgts(kw)%fly_dta(:,jpj2-1,:) 1503 ENDIF 1504 1505 !! if data grid is cyclic we can do better on east-west edges 1506 !! but have to allow for whether first and last columns are coincident 1507 IF( ref_wgts(kw)%cyclic ) THEN 1508 rec1(2) = MAX( jpjmin-1, 1 ) 1509 recn(1) = 1 1510 recn(2) = MIN( jpjwid+2, ref_wgts(kw)%ddims(2)-rec1(2)+1 ) 1511 jpj1 = 2 + rec1(2) - jpjmin 1512 jpj2 = jpj1 + recn(2) - 1 1513 IF( jpi1 == 2 ) THEN 1514 rec1(1) = ref_wgts(kw)%ddims(1) - ref_wgts(kw)%overlap 1515 CALL iom_get( num, jpdom_unknown, clvar, ref_wgts(kw)%col(:,jpj1:jpj2,:), nrec, rec1, recn) 1516 ref_wgts(kw)%fly_dta(jpi1-1,jpj1:jpj2,:) = ref_wgts(kw)%col(1,jpj1:jpj2,:) 1517 ENDIF 1518 IF( jpi2 + jpimin - 1 == ref_wgts(kw)%ddims(1)+1 ) THEN 1519 rec1(1) = 1 + ref_wgts(kw)%overlap 1520 CALL iom_get( num, jpdom_unknown, clvar, ref_wgts(kw)%col(:,jpj1:jpj2,:), nrec, rec1, recn) 1521 ref_wgts(kw)%fly_dta(jpi2+1,jpj1:jpj2,:) = ref_wgts(kw)%col(1,jpj1:jpj2,:) 1522 ENDIF 1523 ENDIF 1524 1525 ! gradient in the i direction 1526 DO jk = 1,4 1527 DO jn = 1, jpj 1528 DO jm = 1,jpi 1529 ni = ref_wgts(kw)%data_jpi(jm,jn,jk) 1530 nj = ref_wgts(kw)%data_jpj(jm,jn,jk) 1531 dta(jm,jn,:) = dta(jm,jn,:) + ref_wgts(kw)%data_wgt(jm,jn,jk+4) * 0.5 * & 1532 (ref_wgts(kw)%fly_dta(ni+2,nj+1,:) - ref_wgts(kw)%fly_dta(ni,nj+1,:)) 1533 END DO 1534 END DO 1535 END DO 1536 1537 ! gradient in the j direction 1538 DO jk = 1,4 1539 DO jn = 1, jpj 1540 DO jm = 1,jpi 1541 ni = ref_wgts(kw)%data_jpi(jm,jn,jk) 1542 nj = ref_wgts(kw)%data_jpj(jm,jn,jk) 1543 dta(jm,jn,:) = dta(jm,jn,:) + ref_wgts(kw)%data_wgt(jm,jn,jk+8) * 0.5 * & 1544 (ref_wgts(kw)%fly_dta(ni+1,nj+2,:) - ref_wgts(kw)%fly_dta(ni+1,nj,:)) 1545 END DO 1546 END DO 1547 END DO 1548 1549 ! gradient in the ij direction 1550 DO jk = 1,4 1551 DO jn = 1, jpj 1552 DO jm = 1,jpi 1553 ni = ref_wgts(kw)%data_jpi(jm,jn,jk) 1554 nj = ref_wgts(kw)%data_jpj(jm,jn,jk) 1555 dta(jm,jn,:) = dta(jm,jn,:) + ref_wgts(kw)%data_wgt(jm,jn,jk+12) * 0.25 * ( & 1556 (ref_wgts(kw)%fly_dta(ni+2,nj+2,:) - ref_wgts(kw)%fly_dta(ni ,nj+2,:)) - & 1557 (ref_wgts(kw)%fly_dta(ni+2,nj ,:) - ref_wgts(kw)%fly_dta(ni ,nj ,:))) 1558 END DO 1559 END DO 1453 !! fix up halo points that we couldnt read from file 1454 IF( jpi1 == 2 ) THEN 1455 ref_wgts(kw)%fly_dta(jpi1-1,:,:) = ref_wgts(kw)%fly_dta(jpi1,:,:) 1456 ENDIF 1457 IF( jpi2 + jpimin - 1 == ref_wgts(kw)%ddims(1)+1 ) THEN 1458 ref_wgts(kw)%fly_dta(jpi2+1,:,:) = ref_wgts(kw)%fly_dta(jpi2,:,:) 1459 ENDIF 1460 IF( jpj1 == 2 ) THEN 1461 ref_wgts(kw)%fly_dta(:,jpj1-1,:) = ref_wgts(kw)%fly_dta(:,jpj1,:) 1462 ENDIF 1463 IF( jpj2 + jpjmin - 1 == ref_wgts(kw)%ddims(2)+1 .AND. jpj2 .LT. jpjwid+2 ) THEN 1464 ref_wgts(kw)%fly_dta(:,jpj2+1,:) = 2.0*ref_wgts(kw)%fly_dta(:,jpj2,:) - ref_wgts(kw)%fly_dta(:,jpj2-1,:) 1465 ENDIF 1466 1467 !! if data grid is cyclic we can do better on east-west edges 1468 !! but have to allow for whether first and last columns are coincident 1469 IF( ref_wgts(kw)%cyclic ) THEN 1470 rec1(2) = MAX( jpjmin-1, 1 ) 1471 recn(1) = 1 1472 recn(2) = MIN( jpjwid+2, ref_wgts(kw)%ddims(2)-rec1(2)+1 ) 1473 jpj1 = 2 + rec1(2) - jpjmin 1474 jpj2 = jpj1 + recn(2) - 1 1475 IF( jpi1 == 2 ) THEN 1476 rec1(1) = ref_wgts(kw)%ddims(1) - ref_wgts(kw)%overlap 1477 CALL iom_get( num, jpdom_unknown, clvar, ref_wgts(kw)%col(:,jpj1:jpj2,:), nrec, kstart = rec1, kcount = recn) 1478 ref_wgts(kw)%fly_dta(jpi1-1,jpj1:jpj2,:) = ref_wgts(kw)%col(1,jpj1:jpj2,:) 1479 ENDIF 1480 IF( jpi2 + jpimin - 1 == ref_wgts(kw)%ddims(1)+1 ) THEN 1481 rec1(1) = 1 + ref_wgts(kw)%overlap 1482 CALL iom_get( num, jpdom_unknown, clvar, ref_wgts(kw)%col(:,jpj1:jpj2,:), nrec, kstart = rec1, kcount = recn) 1483 ref_wgts(kw)%fly_dta(jpi2+1,jpj1:jpj2,:) = ref_wgts(kw)%col(1,jpj1:jpj2,:) 1484 ENDIF 1485 ENDIF 1486 ! 1487 !!$ DO jn = 1,4 1488 !!$ DO_3D_00_00( 1,ipk ) 1489 !!$ ni = ref_wgts(kw)%data_jpi(ji,jj,jn) + 1 1490 !!$ nj = ref_wgts(kw)%data_jpj(ji,jj,jn) + 1 1491 !!$ dta(ji,jj,jk) = dta(ji,jj,jk) & 1492 !!$ ! gradient in the i direction 1493 !!$ & + ref_wgts(kw)%data_wgt(ji,jj,jn+4) * 0.5_wp * & 1494 !!$ & (ref_wgts(kw)%fly_dta(ni+1,nj ,jk) - ref_wgts(kw)%fly_dta(ni-1,nj ,jk)) & 1495 !!$ ! gradient in the j direction 1496 !!$ & + ref_wgts(kw)%data_wgt(ji,jj,jn+8) * 0.5_wp * & 1497 !!$ & (ref_wgts(kw)%fly_dta(ni ,nj+1,jk) - ref_wgts(kw)%fly_dta(ni ,nj-1,jk)) & 1498 !!$ ! gradient in the ij direction 1499 !!$ & + ref_wgts(kw)%data_wgt(ji,jj,jn+12) * 0.25_wp * & 1500 !!$ & ((ref_wgts(kw)%fly_dta(ni+1,nj+1,jk) - ref_wgts(kw)%fly_dta(ni-1,nj+1,jk)) - & 1501 !!$ & (ref_wgts(kw)%fly_dta(ni+1,nj-1,jk) - ref_wgts(kw)%fly_dta(ni-1,nj-1,jk))) 1502 !!$ END_3D 1503 !!$ END DO 1504 ! 1505 DO jn = 1,4 1506 DO_3D_00_00( 1,ipk ) 1507 ni = ref_wgts(kw)%data_jpi(ji,jj,jn) 1508 nj = ref_wgts(kw)%data_jpj(ji,jj,jn) 1509 ! gradient in the i direction 1510 dta(ji,jj,jk) = dta(ji,jj,jk) + ref_wgts(kw)%data_wgt(ji,jj,jn+4) * 0.5_wp * & 1511 & (ref_wgts(kw)%fly_dta(ni+2,nj+1,jk) - ref_wgts(kw)%fly_dta(ni ,nj+1,jk)) 1512 END_3D 1513 END DO 1514 DO jn = 1,4 1515 DO_3D_00_00( 1,ipk ) 1516 ni = ref_wgts(kw)%data_jpi(ji,jj,jn) 1517 nj = ref_wgts(kw)%data_jpj(ji,jj,jn) 1518 ! gradient in the j direction 1519 dta(ji,jj,jk) = dta(ji,jj,jk) + ref_wgts(kw)%data_wgt(ji,jj,jn+8) * 0.5_wp * & 1520 & (ref_wgts(kw)%fly_dta(ni+1,nj+2,jk) - ref_wgts(kw)%fly_dta(ni+1,nj ,jk)) 1521 END_3D 1522 END DO 1523 DO jn = 1,4 1524 DO_3D_00_00( 1,ipk ) 1525 ni = ref_wgts(kw)%data_jpi(ji,jj,jn) 1526 nj = ref_wgts(kw)%data_jpj(ji,jj,jn) 1527 ! gradient in the ij direction 1528 dta(ji,jj,jk) = dta(ji,jj,jk) + ref_wgts(kw)%data_wgt(ji,jj,jn+12) * 0.25_wp * ( & 1529 & (ref_wgts(kw)%fly_dta(ni+2,nj+2,jk) - ref_wgts(kw)%fly_dta(ni ,nj+2,jk)) - & 1530 & (ref_wgts(kw)%fly_dta(ni+2,nj ,jk) - ref_wgts(kw)%fly_dta(ni ,nj ,jk))) 1531 END_3D 1560 1532 END DO 1561 1533 ! … … 1584 1556 IF( .NOT. sdjf%ln_clim ) THEN 1585 1557 WRITE(clname, '(a,"_y",i4.4)' ) TRIM( sdjf%clrootname ), kyear ! add year 1586 IF( sdjf%cl type/= 'yearly' ) WRITE(clname, '(a, "m",i2.2)' ) TRIM( clname ), kmonth ! add month1558 IF( sdjf%clftyp /= 'yearly' ) WRITE(clname, '(a, "m",i2.2)' ) TRIM( clname ), kmonth ! add month 1587 1559 ELSE 1588 1560 ! build the new filename if climatological data 1589 IF( sdjf%cl type/= 'yearly' ) WRITE(clname, '(a,"_m",i2.2)' ) TRIM( sdjf%clrootname ), kmonth ! add month1590 ENDIF 1591 IF( sdjf%cl type == 'daily' .OR. sdjf%cltype(1:4) == 'week' ) &1561 IF( sdjf%clftyp /= 'yearly' ) WRITE(clname, '(a,"_m",i2.2)' ) TRIM( sdjf%clrootname ), kmonth ! add month 1562 ENDIF 1563 IF( sdjf%clftyp == 'daily' .OR. sdjf%clftyp(1:4) == 'week' ) & 1592 1564 & WRITE(clname, '(a,"d" ,i2.2)' ) TRIM( clname ), kday ! add day 1593 1565 … … 1613 1585 IF( cl_week(ijul) == TRIM(cdday) ) EXIT 1614 1586 END DO 1615 IF( ijul .GT. 7 ) CALL ctl_stop( 'ksec_week: wrong day for sdjf%cl type(6:8): '//TRIM(cdday) )1587 IF( ijul .GT. 7 ) CALL ctl_stop( 'ksec_week: wrong day for sdjf%clftyp(6:8): '//TRIM(cdday) ) 1616 1588 ! 1617 1589 ishift = ijul * NINT(rday) -
NEMO/trunk/src/OCE/SBC/sbcapr.F90
r12489 r13286 154 154 IF( ln_rstart .AND. iom_varid( numror, 'ssh_ibb', ldstop = .FALSE. ) > 0 ) THEN 155 155 IF(lwp) WRITE(numout,*) 'sbc_apr: ssh_ibb read in the restart file' 156 CALL iom_get( numror, jpdom_auto glo, 'ssh_ibb', ssh_ibb, ldxios = lrxios ) ! before inv. barometer ssh156 CALL iom_get( numror, jpdom_auto, 'ssh_ibb', ssh_ibb, ldxios = lrxios ) ! before inv. barometer ssh 157 157 ! 158 158 ELSE !* no restart: set from nit000 values -
NEMO/trunk/src/OCE/SBC/sbccpl.F90
r13237 r13286 1039 1039 xcplmask(:,:,:) = 0. 1040 1040 CALL iom_open( 'cplmask', inum ) 1041 CALL iom_get( inum, jpdom_unknown, 'cplmask', xcplmask(1: nlci,1:nlcj,1:nn_cplmodel), &1042 & kstart = (/ mig(1),mjg(1),1 /), kcount = (/ nlci,nlcj,nn_cplmodel /) )1041 CALL iom_get( inum, jpdom_unknown, 'cplmask', xcplmask(1:jpi,1:jpj,1:nn_cplmodel), & 1042 & kstart = (/ mig(1),mjg(1),1 /), kcount = (/ jpi,jpj,nn_cplmodel /) ) 1043 1043 CALL iom_close( inum ) 1044 1044 ELSE -
NEMO/trunk/src/OCE/SBC/sbcfwb.F90
r13226 r13286 186 186 erp(:,:) = erp(:,:) + zerp_cor(:,:) 187 187 ! 188 IF( nprint == 1 .AND.lwp ) THEN ! control print188 IF( lwp ) THEN ! control print 189 189 IF( z_fwf < 0._wp ) THEN 190 190 WRITE(numout,*)' z_fwf < 0' -
NEMO/trunk/src/OCE/SBC/sbcice_cice.F90
r13237 r13286 880 880 ! pcg(:,:)=0.0 881 881 DO jn=1,jpnij 882 DO jj=n ldjt(jn),nlejt(jn)883 DO ji=n ldit(jn),nleit(jn)882 DO jj=njs0all(jn),nje0all(jn) 883 DO ji=nis0all(jn),nie0all(jn) 884 884 png2(ji+nimppt(jn)-1,jj+njmppt(jn)-1)=png(ji,jj,jn) 885 885 ENDDO … … 1001 1001 png(:,:,:)=0.0 1002 1002 DO jn=1,jpnij 1003 DO jj=n ldjt(jn),nlejt(jn)1004 DO ji=n ldit(jn),nleit(jn)1003 DO jj=njs0all(jn),nje0all(jn) 1004 DO ji=nis0all(jn),nie0all(jn) 1005 1005 png(ji,jj,jn)=pcg(ji+nimppt(jn)-1-ji_off,jj+njmppt(jn)-1-jj_off) 1006 1006 ENDDO -
NEMO/trunk/src/OCE/SBC/sbcmod.F90
r13226 r13286 507 507 & iom_varid( numror, 'utau_b', ldstop = .FALSE. ) > 0 ) THEN 508 508 IF(lwp) WRITE(numout,*) ' nit000-1 surface forcing fields red in the restart file' 509 CALL iom_get( numror, jpdom_auto glo, 'utau_b', utau_b, ldxios = lrxios) ! before i-stress (U-point)510 CALL iom_get( numror, jpdom_auto glo, 'vtau_b', vtau_b, ldxios = lrxios) ! before j-stress (V-point)511 CALL iom_get( numror, jpdom_auto glo, 'qns_b', qns_b, ldxios = lrxios ) ! before non solar heat flux (T-point)509 CALL iom_get( numror, jpdom_auto, 'utau_b', utau_b, ldxios = lrxios, cd_type = 'U', psgn = -1._wp ) ! before i-stress (U-point) 510 CALL iom_get( numror, jpdom_auto, 'vtau_b', vtau_b, ldxios = lrxios, cd_type = 'V', psgn = -1._wp ) ! before j-stress (V-point) 511 CALL iom_get( numror, jpdom_auto, 'qns_b', qns_b, ldxios = lrxios ) ! before non solar heat flux (T-point) 512 512 ! The 3D heat content due to qsr forcing is treated in traqsr 513 ! CALL iom_get( numror, jpdom_auto glo, 'qsr_b' , qsr_b, ldxios = lrxios ) ! before solar heat flux (T-point)514 CALL iom_get( numror, jpdom_auto glo, 'emp_b', emp_b, ldxios = lrxios ) ! before freshwater flux (T-point)513 ! CALL iom_get( numror, jpdom_auto, 'qsr_b' , qsr_b, ldxios = lrxios ) ! before solar heat flux (T-point) 514 CALL iom_get( numror, jpdom_auto, 'emp_b', emp_b, ldxios = lrxios ) ! before freshwater flux (T-point) 515 515 ! To ensure restart capability with 3.3x/3.4 restart files !! to be removed in v3.6 516 516 IF( iom_varid( numror, 'sfx_b', ldstop = .FALSE. ) > 0 ) THEN 517 CALL iom_get( numror, jpdom_auto glo, 'sfx_b', sfx_b, ldxios = lrxios ) ! before salt flux (T-point)517 CALL iom_get( numror, jpdom_auto, 'sfx_b', sfx_b, ldxios = lrxios ) ! before salt flux (T-point) 518 518 ELSE 519 519 sfx_b (:,:) = sfx(:,:) -
NEMO/trunk/src/OCE/SBC/sbcrnf.F90
r13237 r13286 160 160 & iom_varid( numror, 'rnf_b', ldstop = .FALSE. ) > 0 ) THEN 161 161 IF(lwp) WRITE(numout,*) ' nit000-1 runoff forcing fields red in the restart file', lrxios 162 CALL iom_get( numror, jpdom_auto glo, 'rnf_b', rnf_b, ldxios = lrxios ) ! before runoff163 CALL iom_get( numror, jpdom_auto glo, 'rnf_hc_b', rnf_tsc_b(:,:,jp_tem), ldxios = lrxios ) ! before heat content of runoff164 CALL iom_get( numror, jpdom_auto glo, 'rnf_sc_b', rnf_tsc_b(:,:,jp_sal), ldxios = lrxios ) ! before salinity content of runoff162 CALL iom_get( numror, jpdom_auto, 'rnf_b', rnf_b, ldxios = lrxios ) ! before runoff 163 CALL iom_get( numror, jpdom_auto, 'rnf_hc_b', rnf_tsc_b(:,:,jp_tem), ldxios = lrxios ) ! before heat content of runoff 164 CALL iom_get( numror, jpdom_auto, 'rnf_sc_b', rnf_tsc_b(:,:,jp_sal), ldxios = lrxios ) ! before salinity content of runoff 165 165 ELSE !* no restart: set from nit000 values 166 166 IF(lwp) WRITE(numout,*) ' nit000-1 runoff forcing fields set to nit000' … … 354 354 rn_dep_file = TRIM( cn_dir )//TRIM( sn_dep_rnf%clname ) 355 355 IF( .NOT. sn_dep_rnf%ln_clim ) THEN ; WRITE(rn_dep_file, '(a,"_y",i4)' ) TRIM( rn_dep_file ), nyear ! add year 356 IF( sn_dep_rnf%cl type== 'monthly' ) WRITE(rn_dep_file, '(a,"m",i2)' ) TRIM( rn_dep_file ), nmonth ! add month357 ENDIF 358 CALL iom_open ( rn_dep_file, inum ) ! open file359 CALL iom_get ( inum, jpdom_ data, sn_dep_rnf%clvar, h_rnf ) ! read the river mouth array360 CALL iom_close( inum ) ! close file356 IF( sn_dep_rnf%clftyp == 'monthly' ) WRITE(rn_dep_file, '(a,"m",i2)' ) TRIM( rn_dep_file ), nmonth ! add month 357 ENDIF 358 CALL iom_open ( rn_dep_file, inum ) ! open file 359 CALL iom_get ( inum, jpdom_global, sn_dep_rnf%clvar, h_rnf ) ! read the river mouth array 360 CALL iom_close( inum ) ! close file 361 361 ! 362 362 nk_rnf(:,:) = 0 ! set the number of level over which river runoffs are applied … … 391 391 CALL iom_open( TRIM( sn_rnf%clname ), inum ) ! open runoff file 392 392 nbrec = iom_getszuld( inum ) 393 zrnfcl(:,:,1) = 0._wp ! init the max to 0. in 1393 zrnfcl(:,:,1) = 0._wp ! init the max to 0. in 1 394 394 DO jm = 1, nbrec 395 CALL iom_get( inum, jpdom_ data, TRIM( sn_rnf%clvar ), zrnfcl(:,:,2), jm ) ! read the value in 2396 zrnfcl(:,:,1) = MAXVAL( zrnfcl(:,:,:), DIM=3 ) ! store the maximum value in time in 1395 CALL iom_get( inum, jpdom_global, TRIM( sn_rnf%clvar ), zrnfcl(:,:,2), jm ) ! read the value in 2 396 zrnfcl(:,:,1) = MAXVAL( zrnfcl(:,:,:), DIM=3 ) ! store the maximum value in time in 1 397 397 END DO 398 398 CALL iom_close( inum ) … … 519 519 cl_rnfile = TRIM( cn_dir )//TRIM( sn_cnf%clname ) 520 520 IF( .NOT. sn_cnf%ln_clim ) THEN ; WRITE(cl_rnfile, '(a,"_y",i4)' ) TRIM( cl_rnfile ), nyear ! add year 521 IF( sn_cnf%cl type== 'monthly' ) WRITE(cl_rnfile, '(a,"m",i2)' ) TRIM( cl_rnfile ), nmonth ! add month521 IF( sn_cnf%clftyp == 'monthly' ) WRITE(cl_rnfile, '(a,"m",i2)' ) TRIM( cl_rnfile ), nmonth ! add month 522 522 ENDIF 523 523 ! 524 524 ! horizontal mask (read in NetCDF file) 525 CALL iom_open ( cl_rnfile, inum ) ! open file526 CALL iom_get ( inum, jpdom_ data, sn_cnf%clvar, rnfmsk ) ! read the river mouth array527 CALL iom_close( inum ) ! close file525 CALL iom_open ( cl_rnfile, inum ) ! open file 526 CALL iom_get ( inum, jpdom_global, sn_cnf%clvar, rnfmsk ) ! read the river mouth array 527 CALL iom_close( inum ) ! close file 528 528 ! 529 529 IF( l_clo_rnf ) CALL clo_rnf( rnfmsk ) ! closed sea inflow set as river mouth -
NEMO/trunk/src/OCE/SBC/sbcssm.F90
r13237 r13286 208 208 IF( ln_rstart .AND. iom_varid( numror, 'nn_fsbc', ldstop = .FALSE. ) > 0 ) THEN 209 209 l_ssm_mean = .TRUE. 210 CALL iom_get( numror , 'nn_fsbc', zf_sbc, ldxios = lrxios )! sbc frequency of previous run211 CALL iom_get( numror, jpdom_auto glo, 'ssu_m' , ssu_m, ldxios = lrxios) ! sea surface mean velocity (U-point)212 CALL iom_get( numror, jpdom_auto glo, 'ssv_m' , ssv_m, ldxios = lrxios) ! " " velocity (V-point)213 CALL iom_get( numror, jpdom_auto glo, 'sst_m' , sst_m, ldxios = lrxios) ! " " temperature (T-point)214 CALL iom_get( numror, jpdom_auto glo, 'sss_m' , sss_m, ldxios = lrxios) ! " " salinity (T-point)215 CALL iom_get( numror, jpdom_auto glo, 'ssh_m' , ssh_m, ldxios = lrxios) ! " " height (T-point)216 CALL iom_get( numror, jpdom_auto glo, 'e3t_m' , e3t_m, ldxios = lrxios) ! 1st level thickness (T-point)210 CALL iom_get( numror , 'nn_fsbc', zf_sbc,ldxios = lrxios ) ! sbc frequency of previous run 211 CALL iom_get( numror, jpdom_auto, 'ssu_m' , ssu_m, ldxios = lrxios, cd_type = 'U', psgn = -1._wp ) ! sea surface mean velocity (U-point) 212 CALL iom_get( numror, jpdom_auto, 'ssv_m' , ssv_m, ldxios = lrxios, cd_type = 'V', psgn = -1._wp ) ! " " velocity (V-point) 213 CALL iom_get( numror, jpdom_auto, 'sst_m' , sst_m, ldxios = lrxios ) ! " " temperature (T-point) 214 CALL iom_get( numror, jpdom_auto, 'sss_m' , sss_m, ldxios = lrxios ) ! " " salinity (T-point) 215 CALL iom_get( numror, jpdom_auto, 'ssh_m' , ssh_m, ldxios = lrxios ) ! " " height (T-point) 216 CALL iom_get( numror, jpdom_auto, 'e3t_m' , e3t_m, ldxios = lrxios ) ! 1st level thickness (T-point) 217 217 ! fraction of solar net radiation absorbed in 1st T level 218 218 IF( iom_varid( numror, 'frq_m', ldstop = .FALSE. ) > 0 ) THEN 219 CALL iom_get( numror, jpdom_auto glo, 'frq_m' , frq_m, ldxios = lrxios )219 CALL iom_get( numror, jpdom_auto, 'frq_m' , frq_m, ldxios = lrxios ) 220 220 ELSE 221 221 frq_m(:,:) = 1._wp ! default definition -
NEMO/trunk/src/OCE/STO/stopar.F90
r13226 r13286 709 709 DO jsto = 1 , jpsto2d 710 710 WRITE(clsto2d(7:9),'(i3.3)') jsto 711 CALL iom_get( numstor, jpdom_auto glo, clsto2d , sto2d(:,:,jsto) )711 CALL iom_get( numstor, jpdom_auto, clsto2d, sto2d(:,:, jsto) ) 712 712 END DO 713 713 ! 3D stochastic parameters 714 714 DO jsto = 1 , jpsto3d 715 715 WRITE(clsto3d(7:9),'(i3.3)') jsto 716 CALL iom_get( numstor, jpdom_auto glo, clsto3d, sto3d(:,:,:,jsto) )716 CALL iom_get( numstor, jpdom_auto, clsto3d, sto3d(:,:,:,jsto) ) 717 717 END DO 718 718 -
NEMO/trunk/src/OCE/TDE/tide_mod.F90
r13226 r13286 400 400 ! 401 401 DO itide = 1, nb_harmo 402 CALL iom_get ( inum, jpdom_ data,TRIM(tide_components(itide)%cname_tide)//'_z1', ztr(:,:) )403 CALL iom_get ( inum, jpdom_ data,TRIM(tide_components(itide)%cname_tide)//'_z2', zti(:,:) )402 CALL iom_get ( inum, jpdom_global,TRIM(tide_components(itide)%cname_tide)//'_z1', ztr(:,:) ) 403 CALL iom_get ( inum, jpdom_global,TRIM(tide_components(itide)%cname_tide)//'_z2', zti(:,:) ) 404 404 ! 405 405 DO ji=1,jpi -
NEMO/trunk/src/OCE/TRA/traadv_fct.F90
r13237 r13286 172 172 END_2D 173 173 ELSE ! no cavities: only at the ocean surface 174 zwz(:,:,1) = pW(:,:,1) * pt(:,:,1,jn,Kbb) 174 DO_2D_11_11 175 zwz(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kbb) 176 END_2D 175 177 ENDIF 176 178 ENDIF -
NEMO/trunk/src/OCE/TRA/tradmp.F90
r12377 r13286 208 208 ! ! Read in mask from file 209 209 CALL iom_open ( cn_resto, imask) 210 CALL iom_get ( imask, jpdom_auto glo, 'resto', resto )210 CALL iom_get ( imask, jpdom_auto, 'resto', resto ) 211 211 CALL iom_close( imask ) 212 212 ENDIF -
NEMO/trunk/src/OCE/TRA/traqsr.F90
r13237 r13286 138 138 IF(lwp) WRITE(numout,*) ' nit000-1 qsr tracer content forcing field read in the restart file' 139 139 z1_2 = 0.5_wp 140 CALL iom_get( numror, jpdom_auto glo, 'qsr_hc_b', qsr_hc_b, ldxios = lrxios ) ! before heat content trend due to Qsr flux140 CALL iom_get( numror, jpdom_auto, 'qsr_hc_b', qsr_hc_b, ldxios = lrxios ) ! before heat content trend due to Qsr flux 141 141 ELSE ! No restart or restart not found: Euler forward time stepping 142 142 z1_2 = 1._wp … … 423 423 ! 1st ocean level attenuation coefficient (used in sbcssm) 424 424 IF( iom_varid( numror, 'fraqsr_1lev', ldstop = .FALSE. ) > 0 ) THEN 425 CALL iom_get( numror, jpdom_auto glo, 'fraqsr_1lev' , fraqsr_1lev, ldxios = lrxios )425 CALL iom_get( numror, jpdom_auto, 'fraqsr_1lev' , fraqsr_1lev, ldxios = lrxios ) 426 426 ELSE 427 427 fraqsr_1lev(:,:) = 1._wp ! default : no penetration -
NEMO/trunk/src/OCE/TRA/trasbc.F90
r13237 r13286 112 112 zfact = 0.5_wp 113 113 sbc_tsc(:,:,:) = 0._wp 114 CALL iom_get( numror, jpdom_auto glo, 'sbc_hc_b', sbc_tsc_b(:,:,jp_tem), ldxios = lrxios ) ! before heat content sbc trend115 CALL iom_get( numror, jpdom_auto glo, 'sbc_sc_b', sbc_tsc_b(:,:,jp_sal), ldxios = lrxios ) ! before salt content sbc trend114 CALL iom_get( numror, jpdom_auto, 'sbc_hc_b', sbc_tsc_b(:,:,jp_tem), ldxios = lrxios ) ! before heat content sbc trend 115 CALL iom_get( numror, jpdom_auto, 'sbc_sc_b', sbc_tsc_b(:,:,jp_sal), ldxios = lrxios ) ! before salt content sbc trend 116 116 ELSE ! No restart or restart not found: Euler forward time stepping 117 117 zfact = 1._wp -
NEMO/trunk/src/OCE/TRD/trdmxl_rst.F90
r11536 r13286 149 149 IF( ln_trdmxl_instant ) THEN 150 150 !-- Temperature 151 CALL iom_get( inum, jpdom_auto glo, 'tmlbb' , tmlbb )152 CALL iom_get( inum, jpdom_auto glo, 'tmlbn' , tmlbn )153 CALL iom_get( inum, jpdom_auto glo, 'tmlatfb' , tmlatfb )151 CALL iom_get( inum, jpdom_auto, 'tmlbb' , tmlbb ) 152 CALL iom_get( inum, jpdom_auto, 'tmlbn' , tmlbn ) 153 CALL iom_get( inum, jpdom_auto, 'tmlatfb' , tmlatfb ) 154 154 ! 155 155 !-- Salinity 156 CALL iom_get( inum, jpdom_auto glo, 'smlbb' , smlbb )157 CALL iom_get( inum, jpdom_auto glo, 'smlbn' , smlbn )158 CALL iom_get( inum, jpdom_auto glo, 'smlatfb' , smlatfb )156 CALL iom_get( inum, jpdom_auto, 'smlbb' , smlbb ) 157 CALL iom_get( inum, jpdom_auto, 'smlbn' , smlbn ) 158 CALL iom_get( inum, jpdom_auto, 'smlatfb' , smlatfb ) 159 159 ELSE 160 CALL iom_get( inum, jpdom_auto glo, 'hmxlbn' , hmxlbn ) ! needed for hmxl_sum160 CALL iom_get( inum, jpdom_auto, 'hmxlbn' , hmxlbn ) ! needed for hmxl_sum 161 161 ! 162 162 !-- Temperature 163 CALL iom_get( inum, jpdom_auto glo, 'tmlbn' , tmlbn ) ! needed for tml_sum164 CALL iom_get( inum, jpdom_auto glo, 'tml_sumb' , tml_sumb )163 CALL iom_get( inum, jpdom_auto, 'tmlbn' , tmlbn ) ! needed for tml_sum 164 CALL iom_get( inum, jpdom_auto, 'tml_sumb' , tml_sumb ) 165 165 DO jk = 1, jpltrd 166 166 IF( jk < 10 ) THEN ; WRITE(charout,FMT="('tmltrd_csum_ub_', I1)") jk 167 167 ELSE ; WRITE(charout,FMT="('tmltrd_csum_ub_', I2)") jk 168 168 ENDIF 169 CALL iom_get( inum, jpdom_auto glo, charout, tmltrd_csum_ub(:,:,jk) )169 CALL iom_get( inum, jpdom_auto, charout, tmltrd_csum_ub(:,:,jk) ) 170 170 END DO 171 CALL iom_get( inum, jpdom_auto glo, 'tmltrd_atf_sumb' , tmltrd_atf_sumb)171 CALL iom_get( inum, jpdom_auto, 'tmltrd_atf_sumb' , tmltrd_atf_sumb) 172 172 ! 173 173 !-- Salinity 174 CALL iom_get( inum, jpdom_auto glo, 'smlbn' , smlbn ) ! needed for sml_sum175 CALL iom_get( inum, jpdom_auto glo, 'sml_sumb' , sml_sumb )174 CALL iom_get( inum, jpdom_auto, 'smlbn' , smlbn ) ! needed for sml_sum 175 CALL iom_get( inum, jpdom_auto, 'sml_sumb' , sml_sumb ) 176 176 DO jk = 1, jpltrd 177 177 IF( jk < 10 ) THEN ; WRITE(charout,FMT="('smltrd_csum_ub_', I1)") jk 178 178 ELSE ; WRITE(charout,FMT="('smltrd_csum_ub_', I2)") jk 179 179 ENDIF 180 CALL iom_get( inum, jpdom_auto glo, charout, smltrd_csum_ub(:,:,jk) )180 CALL iom_get( inum, jpdom_auto, charout, smltrd_csum_ub(:,:,jk) ) 181 181 END DO 182 CALL iom_get( inum, jpdom_auto glo, 'smltrd_atf_sumb' , smltrd_atf_sumb)182 CALL iom_get( inum, jpdom_auto, 'smltrd_atf_sumb' , smltrd_atf_sumb) 183 183 ! 184 184 CALL iom_close( inum ) -
NEMO/trunk/src/OCE/USR/usrdef_fmask.F90
r12377 r13286 68 68 ! 69 69 IF(lwp) WRITE(numout,*) ' Gibraltar ' 70 ij0 = 101 ; ij1 = 101 ! Gibraltar strait : partial slip (pfmsk=0.5) 71 ii0 = 139 ; ii1 = 140 ; pfmsk( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 0.5_wp 72 ij0 = 102 ; ij1 = 102 73 ii0 = 139 ; ii1 = 140 ; pfmsk( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 0.5_wp 70 ij0 = 101 + nn_hls ; ij1 = 101 + nn_hls ! Gibraltar strait : partial slip (pfmsk=0.5) 71 ii0 = 139 + nn_hls - 1 ; ii1 = 140 + nn_hls - 1 72 pfmsk( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 0.5_wp 73 ij0 = 102 + nn_hls ; ij1 = 102 + nn_hls 74 ii0 = 139 + nn_hls - 1 ; ii1 = 140 + nn_hls - 1 75 pfmsk( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 0.5_wp 74 76 ! 75 77 IF(lwp) WRITE(numout,*) ' Bab el Mandeb ' 76 ij0 = 87 ; ij1 = 88 ! Bab el Mandeb : partial slip (pfmsk=1) 77 ii0 = 160 ; ii1 = 160 ; pfmsk( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 1._wp 78 ij0 = 88 ; ij1 = 88 79 ii0 = 159 ; ii1 = 159 ; pfmsk( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 1._wp 78 ij0 = 87 + nn_hls ; ij1 = 88 + nn_hls ! Bab el Mandeb : partial slip (pfmsk=1) 79 ii0 = 160 + nn_hls - 1 ; ii1 = 160 + nn_hls - 1 80 pfmsk( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 1._wp 81 ij0 = 88 + nn_hls ; ij1 = 88 + nn_hls 82 ii0 = 159 + nn_hls - 1 ; ii1 = 159 + nn_hls - 1 83 pfmsk( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 1._wp 80 84 ! 81 85 ! We keep this as an example but it is instable in this case … … 94 98 !!gm ! Currently these hard-wired indices relate to configuration with extend grid (jpjglo=332) 95 99 ! 96 isrow = 332 - jpjglo100 isrow = 332 - (Nj0glo + 1) ! was 332 - jpjglo -> jpjglo_old_version = Nj0glo + 1 97 101 ! 98 102 IF(lwp) WRITE(numout,*) 99 103 IF(lwp) WRITE(numout,*) ' orca_r1: increase friction near the following straits : ' 100 104 IF(lwp) WRITE(numout,*) ' Gibraltar ' 101 ii0 = 282 ; ii1 = 283 ! Gibraltar Strait 102 ij0 = 241 - isrow ; ij1 = 241 - isrow ; pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp 105 ii0 = 282 + nn_hls - 1 ; ii1 = 283 + nn_hls - 1 ! Gibraltar Strait 106 ij0 = 241 + nn_hls - isrow ; ij1 = 241 + nn_hls - isrow 107 pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp 103 108 ! 104 109 IF(lwp) WRITE(numout,*) ' Bhosporus ' 105 ii0 = 314 ; ii1 = 315 ! Bhosporus Strait 106 ij0 = 248 - isrow ; ij1 = 248 - isrow ; pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp 110 ii0 = 314 + nn_hls - 1 ; ii1 = 315 + nn_hls - 1 ! Bhosporus Strait 111 ij0 = 248 + nn_hls - isrow ; ij1 = 248 + nn_hls - isrow 112 pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp 107 113 ! 108 114 IF(lwp) WRITE(numout,*) ' Makassar (Top) ' 109 ii0 = 48 ; ii1 = 48 ! Makassar Strait (Top) 110 ij0 = 189 - isrow ; ij1 = 190 - isrow ; pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp 115 ii0 = 48 + nn_hls - 1 ; ii1 = 48 + nn_hls - 1 ! Makassar Strait (Top) 116 ij0 = 189 + nn_hls - isrow ; ij1 = 190 + nn_hls - isrow 117 pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp 111 118 ! 112 119 IF(lwp) WRITE(numout,*) ' Lombok ' 113 ii0 = 44 ; ii1 = 44 ! Lombok Strait 114 ij0 = 164 - isrow ; ij1 = 165 - isrow ; pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp 120 ii0 = 44 + nn_hls - 1 ; ii1 = 44 + nn_hls - 1 ! Lombok Strait 121 ij0 = 164 + nn_hls - isrow ; ij1 = 165 + nn_hls - isrow 122 pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp 115 123 ! 116 124 IF(lwp) WRITE(numout,*) ' Ombai ' 117 ii0 = 53 ; ii1 = 53 ! Ombai Strait 118 ij0 = 164 - isrow ; ij1 = 165 - isrow ; pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp 125 ii0 = 53 + nn_hls - 1 ; ii1 = 53 + nn_hls - 1 ! Ombai Strait 126 ij0 = 164 + nn_hls - isrow ; ij1 = 165 + nn_hls - isrow 127 pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp 119 128 ! 120 129 IF(lwp) WRITE(numout,*) ' Timor Passage ' 121 ii0 = 56 ; ii1 = 56 ! Timor Passage 122 ij0 = 164 - isrow ; ij1 = 165 - isrow ; pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp 130 ii0 = 56 + nn_hls - 1 ; ii1 = 56 + nn_hls - 1 ! Timor Passage 131 ij0 = 164 + nn_hls - isrow ; ij1 = 165 + nn_hls - isrow 132 pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp 123 133 ! 124 134 IF(lwp) WRITE(numout,*) ' West Halmahera ' 125 ii0 = 58 ; ii1 = 58 ! West Halmahera Strait 126 ij0 = 181 - isrow ; ij1 = 182 - isrow ; pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp 135 ii0 = 58 + nn_hls - 1 ; ii1 = 58 + nn_hls - 1 ! West Halmahera Strait 136 ij0 = 181 + nn_hls - isrow ; ij1 = 182 + nn_hls - isrow 137 pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp 127 138 ! 128 139 IF(lwp) WRITE(numout,*) ' East Halmahera ' 129 ii0 = 55 ; ii1 = 55 ! East Halmahera Strait 130 ij0 = 181 - isrow ; ij1 = 182 - isrow ; pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp 140 ii0 = 55 + nn_hls - 1 ; ii1 = 55 + nn_hls - 1 ! East Halmahera Strait 141 ij0 = 181 + nn_hls - isrow ; ij1 = 182 + nn_hls - isrow 142 pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp 131 143 ! 132 144 CASE DEFAULT -
NEMO/trunk/src/OCE/USR/usrdef_hgr.F90
r13216 r13286 13 13 !! usr_def_hgr : initialize the horizontal mesh 14 14 !!---------------------------------------------------------------------- 15 USE dom_oce , ONLY: nimpp, njmpp! ocean space and time domain15 USE dom_oce ! ocean space and time domain 16 16 USE par_oce ! ocean space and time domain 17 17 USE phycst ! physical constants … … 90 90 zcos_alpha = SQRT( 2._wp ) * 0.5_wp 91 91 ze1deg = ze1 / (ra * rad) 92 zlam0 = zlam1 + zcos_alpha * ze1deg * REAL( jpjglo-2, wp )93 zphi0 = zphi1 + zsin_alpha * ze1deg * REAL( jpjglo-2, wp )92 zlam0 = zlam1 + zcos_alpha * ze1deg * REAL( Ni0glo - 2, wp ) 93 zphi0 = zphi1 + zsin_alpha * ze1deg * REAL( Nj0glo - 2, wp ) 94 94 95 95 #if defined key_agrif … … 97 97 ! Laurent: Should be modify in case of an east-west cyclic parent grid 98 98 IF (.NOT.Agrif_root()) THEN 99 zlam0 = zlam1 + Agrif_irhox() * REAL(Agrif_Parent( jpjglo)-2, wp) * ze1deg * zcos_alpha &99 zlam0 = zlam1 + Agrif_irhox() * REAL(Agrif_Parent(Ni0glo) -2, wp) * ze1deg * zcos_alpha & 100 100 & + ( Agrif_Ix()*Agrif_irhox()-(0.5_wp+nbghostcells)) * ze1deg * zcos_alpha & 101 101 & + ( Agrif_Iy()*Agrif_irhoy()-(0.5_wp+nbghostcells)) * ze1deg * zsin_alpha 102 zphi0 = zphi1 + Agrif_irhoy() * REAL(Agrif_Parent( jpjglo)-2, wp) * ze1deg * zsin_alpha &102 zphi0 = zphi1 + Agrif_irhoy() * REAL(Agrif_Parent(Nj0glo) -2, wp) * ze1deg * zsin_alpha & 103 103 & - ( Agrif_Ix()*Agrif_irhox()-nbghostcells ) * ze1deg * zsin_alpha & 104 104 & + ( Agrif_Iy()*Agrif_irhoy()-nbghostcells ) * ze1deg * zcos_alpha … … 110 110 CALL ctl_warn( ' GYRE used as Benchmark: e1=e2=106km, no need to adjust rn_Dt, ahm,aht ' ) 111 111 ENDIF 112 IF( nprint==1 .AND.lwp ) THEN112 IF( lwp ) THEN 113 113 WRITE(numout,*) 'ze1', ze1, 'cosalpha', zcos_alpha, 'sinalpha', zsin_alpha 114 114 WRITE(numout,*) 'ze1deg', ze1deg, 'zlam0', zlam0, 'zphi0', zphi0 … … 116 116 ! 117 117 DO_2D_11_11 118 zim1 = REAL( ji + nimpp - 1 ) - 1. ; zim05 = REAL( ji + nimpp - 1 ) - 1.5119 zjm1 = REAL( jj + njmpp - 1 ) - 1. ; zjm05 = REAL( jj + njmpp - 1 ) - 1.5118 zim1 = REAL( mig0_oldcmp(ji), wp ) - 1. ; zim05 = REAL( mig0_oldcmp(ji), wp ) - 1.5 119 zjm1 = REAL( mjg0_oldcmp(jj), wp ) - 1. ; zjm05 = REAL( mjg0_oldcmp(jj), wp ) - 1.5 120 120 ! 121 121 !glamt(i,j) longitude at T-point -
NEMO/trunk/src/OCE/USR/usrdef_nam.F90
r13216 r13286 14 14 !! usr_def_hgr : initialize the horizontal mesh 15 15 !!---------------------------------------------------------------------- 16 USE dom_oce , ONLY: nimpp, njmpp ! ocean space and time domain16 USE dom_oce 17 17 USE par_oce ! ocean space and time domain 18 18 USE phycst ! physical constants … … 70 70 kk_cfg = nn_GYRE 71 71 ! 72 kpi = 30 * nn_GYRE + 2 ! Global Domain size72 kpi = 30 * nn_GYRE + 2 ! 73 73 kpj = 20 * nn_GYRE + 2 74 74 #if defined key_agrif 75 IF( .NOT. Agrif_Root() ) THEN 76 kpi = nbcellsx + 2 + 2*nbghostcells_x 77 kpj = nbcellsy + 2 + 2*nbghostcells_y_s 75 IF( .NOT.Agrif_Root() ) THEN ! Global Domain size: add 1 land point on each side 76 kpi = nbcellsx + 2 * ( nbghostcells + 1 ) 77 kpj = nbcellsy + 2 * ( nbghostcells + 1 ) 78 !!$ kpi = nbcellsx + nbghostcells_x + nbghostcells_x + 2 79 !!$ kpj = nbcellsy + nbghostcells_y_s + nbghostcells_y_n + 2 78 80 ENDIF 79 81 #endif … … 93 95 IF( Agrif_Root() ) THEN 94 96 #endif 95 WRITE(numout,*) ' jpiglo = 30*nn_GYRE+2 jpiglo = ', kpi96 WRITE(numout,*) ' jpjglo = 20*nn_GYRE+2 jpjglo = ', kpj97 WRITE(numout,*) ' Ni0glo = 30*nn_GYRE Ni0glo = ', kpi 98 WRITE(numout,*) ' Nj0glo = 20*nn_GYRE Nj0glo = ', kpj 97 99 #if defined key_agrif 98 100 ENDIF 99 101 #endif 100 WRITE(numout,*) ' number of model levels 102 WRITE(numout,*) ' number of model levels jpkglo = ', kpk 101 103 WRITE(numout,*) ' ' 102 WRITE(numout,*) ' Lateral b.c. of the global domain set to closed 104 WRITE(numout,*) ' Lateral b.c. of the global domain set to closed jperio = ', kperio 103 105 ENDIF 104 106 ! -
NEMO/trunk/src/OCE/USR/usrdef_zgr.F90
r13226 r13286 198 198 IF(lwp) WRITE(numout,*) ' GYRE case : closed flat box ocean without ocean cavities' 199 199 ! 200 z2d(:,:) = REAL( jpkm1 , wp ) ! flat bottom 201 ! 202 CALL lbc_lnk( 'usrdef_zgr', z2d, 'T', 1.0_wp ) ! set surrounding land to zero (here jperio=0 ==>> closed) 200 z2d(:,:) = REAL( jpkm1 , wp ) ! flat bottom 203 201 ! 204 202 k_bot(:,:) = NINT( z2d(:,:) ) ! =jpkm1 over the ocean point, =0 elsewhere -
NEMO/trunk/src/OCE/ZDF/zdfdrg.F90
r13237 r13286 363 363 ! cl_varname is a coefficient in [0,1] giving where to apply the regional boost 364 364 CALL iom_open ( TRIM(cl_file), inum ) 365 CALL iom_get ( inum, jpdom_ data, TRIM(cl_varname), zmsk_boost, 1 )365 CALL iom_get ( inum, jpdom_global, TRIM(cl_varname), zmsk_boost, 1 ) 366 366 CALL iom_close( inum) 367 367 zmsk_boost(:,:) = 1._wp + rn_boost * zmsk_boost(:,:) -
NEMO/trunk/src/OCE/ZDF/zdfgls.F90
r13283 r13286 1070 1070 ! 1071 1071 IF( MIN( id1, id2, id3, id4 ) > 0 ) THEN ! all required arrays exist 1072 CALL iom_get( numror, jpdom_auto glo, 'en' , en , ldxios = lrxios )1073 CALL iom_get( numror, jpdom_auto glo, 'avt_k' , avt_k , ldxios = lrxios )1074 CALL iom_get( numror, jpdom_auto glo, 'avm_k' , avm_k , ldxios = lrxios )1075 CALL iom_get( numror, jpdom_auto glo, 'hmxl_n', hmxl_n, ldxios = lrxios )1072 CALL iom_get( numror, jpdom_auto, 'en' , en , ldxios = lrxios ) 1073 CALL iom_get( numror, jpdom_auto, 'avt_k' , avt_k , ldxios = lrxios ) 1074 CALL iom_get( numror, jpdom_auto, 'avm_k' , avm_k , ldxios = lrxios ) 1075 CALL iom_get( numror, jpdom_auto, 'hmxl_n', hmxl_n, ldxios = lrxios ) 1076 1076 ELSE 1077 1077 IF(lwp) WRITE(numout,*) -
NEMO/trunk/src/OCE/ZDF/zdfiwm.F90
r13237 r13286 140 140 !!---------------------------------------------------------------------- 141 141 ! 142 ! !* Set to zero the 1st and last vertical levels of appropriate variables 143 zemx_iwm (:,:,1) = 0._wp ; zemx_iwm (:,:,jpk) = 0._wp 144 zav_ratio(:,:,1) = 0._wp ; zav_ratio(:,:,jpk) = 0._wp 145 zav_wave (:,:,1) = 0._wp ; zav_wave (:,:,jpk) = 0._wp 142 ! 143 ! Set to zero the 1st and last vertical levels of appropriate variables 144 IF( iom_use("emix_iwm") ) THEN 145 DO_2D_00_00 146 zemx_iwm (ji,jj,1) = 0._wp ; zemx_iwm (ji,jj,jpk) = 0._wp 147 END_2D 148 zemx_iwm ( 1:nn_hls,:,:) = 0._wp ; zemx_iwm (:, 1:nn_hls,:) = 0._wp 149 zemx_iwm (jpi-nn_hls+1:jpi ,:,:) = 0._wp ; zemx_iwm (:,jpj-nn_hls+1: jpj,:) = 0._wp 150 ENDIF 151 IF( iom_use("av_ratio") ) THEN 152 DO_2D_00_00 153 zav_ratio(ji,jj,1) = 0._wp ; zav_ratio(ji,jj,jpk) = 0._wp 154 END_2D 155 zav_ratio( 1:nn_hls,:,:) = 0._wp ; zav_ratio(:, 1:nn_hls,:) = 0._wp 156 zav_ratio(jpi-nn_hls+1:jpi ,:,:) = 0._wp ; zav_ratio(:,jpj-nn_hls+1: jpj,:) = 0._wp 157 ENDIF 158 IF( iom_use("av_wave") ) THEN 159 DO_2D_00_00 160 zav_wave (ji,jj,1) = 0._wp ; zav_wave (ji,jj,jpk) = 0._wp 161 END_2D 162 zav_wave( 1:nn_hls,:,:) = 0._wp ; zav_wave(:, 1:nn_hls,:) = 0._wp 163 zav_wave(jpi-nn_hls+1:jpi ,:,:) = 0._wp ; zav_wave(:,jpj-nn_hls+1: jpj,:) = 0._wp 164 ENDIF 146 165 ! 147 166 ! ! ----------------------------- ! … … 151 170 ! !* Critical slope mixing: distribute energy over the time-varying ocean depth, 152 171 ! using an exponential decay from the seafloor. 153 DO_2D_ 11_11172 DO_2D_00_00 154 173 zhdep(ji,jj) = gdepw_0(ji,jj,mbkt(ji,jj)+1) ! depth of the ocean 155 174 zfact(ji,jj) = rho0 * ( 1._wp - EXP( -zhdep(ji,jj) / hcri_iwm(ji,jj) ) ) … … 157 176 END_2D 158 177 !!gm gde3w ==>>> check for ssh taken into account.... seem OK gde3w_n=gdept(:,:,:,Kmm) - ssh(:,:,Kmm) 159 DO_3D_ 11_11( 2, jpkm1 )178 DO_3D_00_00( 2, jpkm1 ) 160 179 IF ( zfact(ji,jj) == 0._wp .OR. wmask(ji,jj,jk) == 0._wp ) THEN ! optimization 161 180 zemx_iwm(ji,jj,jk) = 0._wp … … 177 196 CASE ( 1 ) ! Dissipation scales as N (recommended) 178 197 ! 179 zfact(:,:) = 0._wp180 DO jk = 2, jpkm1 ! part independent of the level181 zfact(:,:) = &182 & zfact(:,:) + &183 & e3w(:,:,jk,Kmm) * SQRT( MAX( 0._wp, rn2(:,:,jk) ) ) * wmask(:,:,jk)184 END DO185 ! 186 DO_2D_ 11_11198 DO_2D_00_00 199 zfact(ji,jj) = 0._wp 200 END_2D 201 DO_3D_00_00( 2, jpkm1 ) ! part independent of the level 202 zfact(ji,jj) = zfact(ji,jj) + e3w(ji,jj,jk,Kmm) * SQRT( MAX( 0._wp, rn2(ji,jj,jk) ) ) * wmask(ji,jj,jk) 203 END_3D 204 ! 205 DO_2D_00_00 187 206 IF( zfact(ji,jj) /= 0 ) zfact(ji,jj) = epyc_iwm(ji,jj) / ( rho0 * zfact(ji,jj) ) 188 207 END_2D 189 208 ! 190 DO jk = 2, jpkm1! complete with the level-dependent part191 zemx_iwm( :,:,jk) = zemx_iwm(:,:,jk) + zfact(:,:) * SQRT( MAX( 0._wp, rn2(:,:,jk) ) ) * wmask(:,:,jk)192 END DO209 DO_3D_00_00( 2, jpkm1 ) ! complete with the level-dependent part 210 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) 211 END_3D 193 212 ! 194 213 CASE ( 2 ) ! Dissipation scales as N^2 195 214 ! 196 zfact(:,:) = 0._wp 197 DO jk = 2, jpkm1 ! part independent of the level 198 zfact(:,:) = zfact(:,:) + e3w(:,:,jk,Kmm) * MAX( 0._wp, rn2(:,:,jk) ) * wmask(:,:,jk) 199 END DO 200 ! 201 DO_2D_11_11 215 DO_2D_00_00 216 zfact(ji,jj) = 0._wp 217 END_2D 218 DO_3D_00_00( 2, jpkm1 ) ! part independent of the level 219 zfact(ji,jj) = zfact(ji,jj) + e3w(ji,jj,jk,Kmm) * MAX( 0._wp, rn2(ji,jj,jk) ) * wmask(ji,jj,jk) 220 END_3D 221 ! 222 DO_2D_00_00 202 223 IF( zfact(ji,jj) /= 0 ) zfact(ji,jj) = epyc_iwm(ji,jj) / ( rho0 * zfact(ji,jj) ) 203 224 END_2D 204 225 ! 205 DO jk = 2, jpkm1! complete with the level-dependent part206 zemx_iwm( :,:,jk) = zemx_iwm(:,:,jk) + zfact(:,:) * MAX( 0._wp, rn2(:,:,jk) ) * wmask(:,:,jk)207 END DO226 DO_3D_00_00( 2, jpkm1 ) ! complete with the level-dependent part 227 zemx_iwm(ji,jj,jk) = zemx_iwm(ji,jj,jk) + zfact(ji,jj) * MAX( 0._wp, rn2(ji,jj,jk) ) * wmask(ji,jj,jk) 228 END_3D 208 229 ! 209 230 END SELECT … … 212 233 ! !* ocean depth as proportional to rn2 * exp(-z_wkb/rn_hbot) 213 234 ! 214 zwkb (:,:,:) = 0._wp 215 zfact(:,:) = 0._wp 216 DO jk = 2, jpkm1 217 zfact(:,:) = zfact(:,:) + e3w(:,:,jk,Kmm) * SQRT( MAX( 0._wp, rn2(:,:,jk) ) ) * wmask(:,:,jk) 218 zwkb(:,:,jk) = zfact(:,:) 219 END DO 220 !!gm even better: 221 ! DO jk = 2, jpkm1 222 ! zwkb(:,:) = zwkb(:,:) + e3w(:,:,jk,Kmm) * SQRT( MAX( 0._wp, rn2(:,:,jk) ) ) 223 ! END DO 224 ! zfact(:,:) = zwkb(:,:,jpkm1) 225 !!gm or just use zwkb(k=jpk-1) instead of zfact... 226 !!gm 227 ! 228 DO_3D_11_11( 2, jpkm1 ) 235 DO_2D_00_00 236 zwkb(ji,jj,1) = 0._wp 237 END_2D 238 DO_3D_00_00( 2, jpkm1 ) 239 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) 240 END_3D 241 DO_2D_00_00 242 zfact(ji,jj) = zwkb(ji,jj,jpkm1) 243 END_2D 244 ! 245 DO_3D_00_00( 2, jpkm1 ) 229 246 IF( zfact(ji,jj) /= 0 ) zwkb(ji,jj,jk) = zhdep(ji,jj) * ( zfact(ji,jj) - zwkb(ji,jj,jk) ) & 230 247 & * wmask(ji,jj,jk) / zfact(ji,jj) 231 248 END_3D 232 zwkb(:,:,1) = zhdep(:,:) * wmask(:,:,1) 233 ! 234 DO_3D_11_11( 2, jpkm1 ) 235 IF ( rn2(ji,jj,jk) <= 0._wp .OR. wmask(ji,jj,jk) == 0._wp ) THEN ! optimization 249 DO_2D_00_00 250 zwkb (ji,jj,1) = zhdep(ji,jj) * wmask(ji,jj,1) 251 END_2D 252 ! 253 DO_3D_00_00( 2, jpkm1 ) 254 IF ( rn2(ji,jj,jk) <= 0._wp .OR. wmask(ji,jj,jk) == 0._wp ) THEN ! optimization: EXP coast a lot 236 255 zweight(ji,jj,jk) = 0._wp 237 256 ELSE … … 241 260 END_3D 242 261 ! 243 zfact(:,:) = 0._wp 244 DO jk = 2, jpkm1 ! part independent of the level 245 zfact(:,:) = zfact(:,:) + zweight(:,:,jk) 246 END DO 247 ! 248 DO_2D_11_11 262 DO_2D_00_00 263 zfact(ji,jj) = 0._wp 264 END_2D 265 DO_3D_00_00( 2, jpkm1 ) ! part independent of the level 266 zfact(ji,jj) = zfact(ji,jj) + zweight(ji,jj,jk) 267 END_3D 268 ! 269 DO_2D_00_00 249 270 IF( zfact(ji,jj) /= 0 ) zfact(ji,jj) = ebot_iwm(ji,jj) / ( rho0 * zfact(ji,jj) ) 250 271 END_2D 251 272 ! 252 DO jk = 2, jpkm1! complete with the level-dependent part253 zemx_iwm( :,:,jk) = zemx_iwm(:,:,jk) + zweight(:,:,jk) * zfact(:,:) * wmask(:,:,jk) &254 & / ( gde3w(:,:,jk) - gde3w(:,:,jk-1) )255 !!gm use of e3t( :,:,:,Kmm) just above?256 END DO273 DO_3D_00_00( 2, jpkm1 ) ! complete with the level-dependent part 274 zemx_iwm(ji,jj,jk) = zemx_iwm(ji,jj,jk) + zweight(ji,jj,jk) * zfact(ji,jj) * wmask(ji,jj,jk) & 275 & / ( gde3w(ji,jj,jk) - gde3w(ji,jj,jk-1) ) 276 !!gm use of e3t(ji,jj,:,Kmm) just above? 277 END_3D 257 278 ! 258 279 !!gm this is to be replaced by just a constant value znu=1.e-6 m2/s 259 280 ! Calculate molecular kinematic viscosity 260 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) & 261 & + 0.02305_wp * ts(:,:,:,jp_sal,Kmm) ) * tmask(:,:,:) * r1_rho0 262 DO jk = 2, jpkm1 263 znu_w(:,:,jk) = 0.5_wp * ( znu_t(:,:,jk-1) + znu_t(:,:,jk) ) * wmask(:,:,jk) 264 END DO 281 DO_3D_00_00( 1, jpkm1 ) 282 znu_t(ji,jj,jk) = 1.e-4_wp * ( 17.91_wp - 0.53810_wp * ts(ji,jj,jk,jp_tem,Kmm) & 283 & + 0.00694_wp * ts(ji,jj,jk,jp_tem,Kmm) * ts(ji,jj,jk,jp_tem,Kmm) & 284 & + 0.02305_wp * ts(ji,jj,jk,jp_sal,Kmm) ) * tmask(ji,jj,jk) * r1_rho0 285 END_3D 286 DO_3D_00_00( 2, jpkm1 ) 287 znu_w(ji,jj,jk) = 0.5_wp * ( znu_t(ji,jj,jk-1) + znu_t(ji,jj,jk) ) * wmask(ji,jj,jk) 288 END_3D 265 289 !!gm end 266 290 ! 267 291 ! Calculate turbulence intensity parameter Reb 268 DO jk = 2, jpkm1269 zReb( :,:,jk) = zemx_iwm(:,:,jk) / MAX( 1.e-20_wp, znu_w(:,:,jk) * rn2(:,:,jk) )270 END DO292 DO_3D_00_00( 2, jpkm1 ) 293 zReb(ji,jj,jk) = zemx_iwm(ji,jj,jk) / MAX( 1.e-20_wp, znu_w(ji,jj,jk) * rn2(ji,jj,jk) ) 294 END_3D 271 295 ! 272 296 ! Define internal wave-induced diffusivity 273 DO jk = 2, jpkm1274 zav_wave( :,:,jk) = znu_w(:,:,jk) * zReb(:,:,jk) * r1_6 ! This corresponds to a constant mixing efficiency of 1/6275 END DO297 DO_3D_00_00( 2, jpkm1 ) 298 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 299 END_3D 276 300 ! 277 301 IF( ln_mevar ) THEN ! Variable mixing efficiency case : modify zav_wave in the 278 DO_3D_ 11_11( 2, jpkm1 )302 DO_3D_00_00( 2, jpkm1 ) 279 303 IF( zReb(ji,jj,jk) > 480.00_wp ) THEN 280 304 zav_wave(ji,jj,jk) = 3.6515_wp * znu_w(ji,jj,jk) * SQRT( zReb(ji,jj,jk) ) … … 285 309 ENDIF 286 310 ! 287 DO jk = 2, jpkm1! Bound diffusivity by molecular value and 100 cm2/s288 zav_wave( :,:,jk) = MIN( MAX( 1.4e-7_wp, zav_wave(:,:,jk) ), 1.e-2_wp ) * wmask(:,:,jk)289 END DO311 DO_3D_00_00( 2, jpkm1 ) ! Bound diffusivity by molecular value and 100 cm2/s 312 zav_wave(ji,jj,jk) = MIN( MAX( 1.4e-7_wp, zav_wave(ji,jj,jk) ), 1.e-2_wp ) * wmask(ji,jj,jk) 313 END_3D 290 314 ! 291 315 IF( kt == nit000 ) THEN !* Control print at first time-step: diagnose the energy consumed by zav_wave 292 316 zztmp = 0._wp 293 317 !!gm used of glosum 3D.... 294 DO_3D_ 11_11( 2, jpkm1 )318 DO_3D_00_00( 2, jpkm1 ) 295 319 zztmp = zztmp + e3w(ji,jj,jk,Kmm) * e1e2t(ji,jj) & 296 320 & * MAX( 0._wp, rn2(ji,jj,jk) ) * zav_wave(ji,jj,jk) * wmask(ji,jj,jk) * tmask_i(ji,jj) … … 314 338 IF( ln_tsdiff ) THEN !* Option for differential mixing of salinity and temperature 315 339 ztmp1 = 0.505_wp + 0.495_wp * TANH( 0.92_wp * ( LOG10( 1.e-20_wp ) - 0.60_wp ) ) 316 DO_3D_ 11_11( 2, jpkm1 )340 DO_3D_00_00( 2, jpkm1 ) 317 341 ztmp2 = zReb(ji,jj,jk) * 5._wp * r1_6 318 342 IF ( ztmp2 > 1.e-20_wp .AND. wmask(ji,jj,jk) == 1._wp ) THEN … … 323 347 END_3D 324 348 CALL iom_put( "av_ratio", zav_ratio ) 325 DO jk = 2, jpkm1!* update momentum & tracer diffusivity with wave-driven mixing326 p_avs( :,:,jk) = p_avs(:,:,jk) + zav_wave(:,:,jk) * zav_ratio(:,:,jk)327 p_avt( :,:,jk) = p_avt(:,:,jk) + zav_wave(:,:,jk)328 p_avm( :,:,jk) = p_avm(:,:,jk) + zav_wave(:,:,jk)329 END DO349 DO_3D_00_00( 2, jpkm1 ) !* update momentum & tracer diffusivity with wave-driven mixing 350 p_avs(ji,jj,jk) = p_avs(ji,jj,jk) + zav_wave(ji,jj,jk) * zav_ratio(ji,jj,jk) 351 p_avt(ji,jj,jk) = p_avt(ji,jj,jk) + zav_wave(ji,jj,jk) 352 p_avm(ji,jj,jk) = p_avm(ji,jj,jk) + zav_wave(ji,jj,jk) 353 END_3D 330 354 ! 331 355 ELSE !* update momentum & tracer diffusivity with wave-driven mixing 332 DO jk = 2, jpkm1333 p_avs( :,:,jk) = p_avs(:,:,jk) + zav_wave(:,:,jk)334 p_avt( :,:,jk) = p_avt(:,:,jk) + zav_wave(:,:,jk)335 p_avm( :,:,jk) = p_avm(:,:,jk) + zav_wave(:,:,jk)336 END DO356 DO_3D_00_00( 2, jpkm1 ) 357 p_avs(ji,jj,jk) = p_avs(ji,jj,jk) + zav_wave(ji,jj,jk) 358 p_avt(ji,jj,jk) = p_avt(ji,jj,jk) + zav_wave(ji,jj,jk) 359 p_avm(ji,jj,jk) = p_avm(ji,jj,jk) + zav_wave(ji,jj,jk) 360 END_3D 337 361 ENDIF 338 362 … … 344 368 IF( iom_use("bflx_iwm") .OR. iom_use("pcmap_iwm") ) THEN 345 369 ALLOCATE( z2d(jpi,jpj) , z3d(jpi,jpj,jpk) ) 346 z3d(:,:,:) = MAX( 0._wp, rn2(:,:,:) ) * zav_wave(:,:,:) 347 z2d(:,:) = 0._wp 348 DO jk = 2, jpkm1 349 z2d(:,:) = z2d(:,:) + e3w(:,:,jk,Kmm) * z3d(:,:,jk) * wmask(:,:,jk) 350 END DO 351 z2d(:,:) = rho0 * z2d(:,:) 352 CALL iom_put( "bflx_iwm", z3d ) 370 ! Initialisation for iom_put 371 DO_2D_00_00 372 z3d(ji,jj,1) = 0._wp ; z3d(ji,jj,jpk) = 0._wp 373 END_2D 374 z3d( 1:nn_hls,:,:) = 0._wp ; z3d(:, 1:nn_hls,:) = 0._wp 375 z3d(jpi-nn_hls+1:jpi ,:,:) = 0._wp ; z3d(:,jpj-nn_hls+1: jpj,:) = 0._wp 376 z2d( 1:nn_hls,: ) = 0._wp ; z2d(:, 1:nn_hls ) = 0._wp 377 z2d(jpi-nn_hls+1:jpi ,: ) = 0._wp ; z2d(:,jpj-nn_hls+1: jpj ) = 0._wp 378 379 DO_3D_00_00( 2, jpkm1 ) 380 z3d(ji,jj,jk) = MAX( 0._wp, rn2(ji,jj,jk) ) * zav_wave(ji,jj,jk) 381 END_3D 382 DO_2D_00_00 383 z2d(ji,jj) = 0._wp 384 END_2D 385 DO_3D_00_00( 2, jpkm1 ) 386 z2d(ji,jj) = z2d(ji,jj) + e3w(ji,jj,jk,Kmm) * z3d(ji,jj,jk) * wmask(ji,jj,jk) 387 END_3D 388 DO_2D_00_00 389 z2d(ji,jj) = rho0 * z2d(ji,jj) 390 END_2D 391 CALL iom_put( "bflx_iwm", z3d ) 353 392 CALL iom_put( "pcmap_iwm", z2d ) 354 393 DEALLOCATE( z2d , z3d ) -
NEMO/trunk/src/OCE/ZDF/zdfosm.F90
r13283 r13286 1474 1474 id1 = iom_varid( numror, 'wn' , ldstop = .FALSE. ) 1475 1475 IF( id1 > 0 ) THEN ! 'wn' exists; read 1476 CALL iom_get( numror, jpdom_auto glo, 'wn', ww, ldxios = lrxios )1476 CALL iom_get( numror, jpdom_auto, 'wn', ww, ldxios = lrxios ) 1477 1477 WRITE(numout,*) ' ===>>>> : ww read from restart file' 1478 1478 ELSE … … 1483 1483 id2 = iom_varid( numror, 'hbli' , ldstop = .FALSE. ) 1484 1484 IF( id1 > 0 .AND. id2 > 0) THEN ! 'hbl' exists; read and return 1485 CALL iom_get( numror, jpdom_auto glo, 'hbl' , hbl , ldxios = lrxios )1486 CALL iom_get( numror, jpdom_auto glo, 'hbli', hbli, ldxios = lrxios )1485 CALL iom_get( numror, jpdom_auto, 'hbl' , hbl , ldxios = lrxios ) 1486 CALL iom_get( numror, jpdom_auto, 'hbli', hbli, ldxios = lrxios ) 1487 1487 WRITE(numout,*) ' ===>>>> : hbl & hbli read from restart file' 1488 1488 RETURN -
NEMO/trunk/src/OCE/ZDF/zdfric.F90
r12489 r13286 214 214 ! 215 215 IF( MIN( id1, id2 ) > 0 ) THEN ! restart exists => read it 216 CALL iom_get( numror, jpdom_auto glo, 'avt_k', avt_k, ldxios = lrxios )217 CALL iom_get( numror, jpdom_auto glo, 'avm_k', avm_k, ldxios = lrxios )216 CALL iom_get( numror, jpdom_auto, 'avt_k', avt_k, ldxios = lrxios ) 217 CALL iom_get( numror, jpdom_auto, 'avm_k', avm_k, ldxios = lrxios ) 218 218 ENDIF 219 219 ENDIF -
NEMO/trunk/src/OCE/ZDF/zdftke.F90
r13237 r13286 737 737 ! 738 738 IF( MIN( id1, id2, id3, id4 ) > 0 ) THEN ! fields exist 739 CALL iom_get( numror, jpdom_auto glo, 'en' , en , ldxios = lrxios )740 CALL iom_get( numror, jpdom_auto glo, 'avt_k', avt_k, ldxios = lrxios )741 CALL iom_get( numror, jpdom_auto glo, 'avm_k', avm_k, ldxios = lrxios )742 CALL iom_get( numror, jpdom_auto glo, 'dissl', dissl, ldxios = lrxios )739 CALL iom_get( numror, jpdom_auto, 'en' , en , ldxios = lrxios ) 740 CALL iom_get( numror, jpdom_auto, 'avt_k', avt_k, ldxios = lrxios ) 741 CALL iom_get( numror, jpdom_auto, 'avm_k', avm_k, ldxios = lrxios ) 742 CALL iom_get( numror, jpdom_auto, 'dissl', dissl, ldxios = lrxios ) 743 743 ELSE ! start TKE from rest 744 744 IF(lwp) WRITE(numout,*) -
NEMO/trunk/src/OCE/do_loop_substitute.h90
r12377 r13286 50 50 ! includes the possibility of strides for which an extra set of DO_3DS macros are defined. 51 51 ! 52 ! In the following definitions the inner PE domain is defined by start indices of (_ __kIs_, __kJs_) and end indices of (__kIe_, __kJe_)53 ! The following macros are defined just below: _ __kIs_, __kJs_, ___kIsm1_, __kJsm1_, ___kIe_, __kJe_, ___kIep1_, __kJep1_.52 ! In the following definitions the inner PE domain is defined by start indices of (_Nis0, Njs0) and end indices of (Nie0, Njs0) 53 ! The following macros are defined just below: _Nis0, Njs0, _Nis1, Njs1, _Nie0, Njs0, _Nie1, Nje1. 54 54 ! These names are chosen to, hopefully, avoid any future, unintended matches elsewhere in the code. 55 55 ! 56 !!gm changes ; 57 ! 58 ! -0- fortran code : defined in par_oce.F90 the folowwing valiables : 59 !!# 60 !!# INTEGER, PUBLIC :: Nis0, Nis1, Nis2 !: start I-index (_0: no halo, _1 & _2: 1 & 2-halos) 61 !!# INTEGER, PUBLIC :: Nie0, Nie1, Nie2 !: end I-index (_0: no halo, _1 & _2: 1 & 2-halos) 62 !!# INTEGER, PUBLIC :: Njs0, Njs1, Njs2 !: start J-index (_0: no halo, _1 & _2: 1 & 2-halos) 63 !!# INTEGER, PUBLIC :: Nje0, Nje1, Nje2 !: end J-index (_0: no halo, _1 & _2: 1 & 2-halos) 64 !!# 65 ! -1- fortran code put in mppinit.F90 : 66 !!# just after the futur read of nn_hls in namXXX (to be defined) 67 !!# NB: currently nn_hls is defined as a parameter in par_oce.F90 68 !!# SUBROUTINE init_do_loop 69 !!# !!---------------------------------------------------------------------- 70 !!# !! *** ROUTINE init_do_loop_indices *** 71 !!# !! 72 !!# !! ** Purpose : set the starting/ending indices of DO-loop 73 !!# !! These indices are used in do_loop_substitute.h90 74 !!# !!----------------------------------------------------------------------!!# ! !== set the starting/ending indices of DO-loop ==! (used in do_loop_substitute.h90) 75 !!# ! 76 !!# IF( nn_hls == 1 ) THEN !* halo size of 1 77 !!# ! 78 !!# Nis0 = 2 ; Nis1 = 1 ; Nis2 = Nis1 79 !!# Njs0 = Nis0 ; Njs1 = Nis1 ; Njs2 = Nis1 80 !!# ! 81 !!# Nie0 = jpi-1 ; Nje1 = jpi ; Nie2 = Nie1 82 !!# Nje0 = jpj-1 ; Nje1 = jpj-1 ; Nje2 = Nie1 83 !!# ! 84 !!# ELSEIF( nn_hls == 2 ) THEN !* halo size of 2 85 !!# ! 86 !!# Nis0 = 3 ; Nis1 = 2 ; Nis2 = 1 87 !!# Njs0 = Nis0 ; Njs1 = Nis1 ; Njs2 = Nis2 88 !!# ! 89 !!# Nie0 = jpi-2 ; Nje1 = jpi-1 ; Nie2 = jpi 90 !!# Nje0 = jpj-2 ; Nje1 = jpj-1 ; Nje2 = jpj 91 !!# ! 92 !!# ELSE !* unexpected halo size 93 !!# CALL ctl_stop( 'STOP', 'ini_mpp: wrong value of halo size : nn_hls= 1 or 2 only !') 94 !!# ENDIF 95 !!# 96 !!# ! 97 !!# END SUBROUTINE init_do_loop 98 ! 99 ! ! -2- in do_loop_substitute becomes : 100 ! 56 101 #endif 57 #define __kIs_ 2 58 #define __kJs_ 2 59 #define __kIsm1_ 1 60 #define __kJsm1_ 1 61 62 #define __kIe_ jpim1 63 #define __kJe_ jpjm1 64 #define __kIep1_ jpi 65 #define __kJep1_ jpj 66 67 #define DO_2D_00_00 DO jj = __kJs_, __kJe_ ; DO ji = __kIs_, __kIe_ 68 #define DO_2D_00_01 DO jj = __kJs_, __kJe_ ; DO ji = __kIs_, __kIep1_ 69 #define DO_2D_00_10 DO jj = __kJs_, __kJe_ ; DO ji = __kIsm1_, __kIe_ 70 #define DO_2D_00_11 DO jj = __kJs_, __kJe_ ; DO ji = __kIsm1_, __kIep1_ 71 72 #define DO_2D_01_00 DO jj = __kJs_, __kJep1_ ; DO ji = __kIs_, __kIe_ 73 #define DO_2D_01_01 DO jj = __kJs_, __kJep1_ ; DO ji = __kIs_, __kIep1_ 74 #define DO_2D_01_10 DO jj = __kJs_, __kJep1_ ; DO ji = __kIsm1_, __kIe_ 75 #define DO_2D_01_11 DO jj = __kJs_, __kJep1_ ; DO ji = __kIsm1_, __kIep1_ 76 77 #define DO_2D_10_00 DO jj = __kJsm1_, __kJe_ ; DO ji = __kIs_, __kIe_ 78 #define DO_2D_10_10 DO jj = __kJsm1_, __kJe_ ; DO ji = __kIsm1_, __kIe_ 79 #define DO_2D_10_11 DO jj = __kJsm1_, __kJe_ ; DO ji = __kIsm1_, __kIep1_ 80 81 #define DO_2D_11_00 DO jj = __kJsm1_, __kJep1_ ; DO ji = __kIs_, __kIe_ 82 #define DO_2D_11_01 DO jj = __kJsm1_, __kJep1_ ; DO ji = __kIs_, __kIep1_ 83 #define DO_2D_11_10 DO jj = __kJsm1_, __kJep1_ ; DO ji = __kIsm1_, __kIe_ 84 #define DO_2D_11_11 DO jj = __kJsm1_, __kJep1_ ; DO ji = __kIsm1_, __kIep1_ 85 86 #define DO_3D_00_00(ks,ke) DO jk = ks, ke ; DO_2D_00_00 87 #define DO_3D_00_10(ks,ke) DO jk = ks, ke ; DO_2D_00_10 88 89 #define DO_3D_01_01(ks,ke) DO jk = ks, ke ; DO_2D_01_01 90 91 #define DO_3D_10_00(ks,ke) DO jk = ks, ke ; DO_2D_10_00 92 #define DO_3D_10_10(ks,ke) DO jk = ks, ke ; DO_2D_10_10 93 #define DO_3D_10_11(ks,ke) DO jk = ks, ke ; DO_2D_10_11 94 95 #define DO_3D_11_11(ks,ke) DO jk = ks, ke ; DO_2D_11_11 96 97 #define DO_3DS_00_00(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_00_00 98 #define DO_3DS_01_01(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_01_01 99 #define DO_3DS_10_10(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_10_10 100 #define DO_3DS_11_11(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_11_11 101 102 103 ! 2D loops with 1 104 105 #define DO_2D_00_00 DO jj = Njs0, Nje0 ; DO ji = Nis0, Nie0 106 #define DO_2D_00_01 DO jj = Njs0, Nje0 ; DO ji = Nis0, Nie1 107 #define DO_2D_00_10 DO jj = Njs0, Nje0 ; DO ji = Nis1, Nie0 108 #define DO_2D_00_11 DO jj = Njs0, Nje0 ; DO ji = Nis1, Nie1 109 110 #define DO_2D_01_00 DO jj = Njs0, Nje1 ; DO ji = Nis0, Nie0 111 #define DO_2D_01_01 DO jj = Njs0, Nje1 ; DO ji = Nis0, Nie1 112 #define DO_2D_01_10 DO jj = Njs0, Nje1 ; DO ji = Nis1, Nie0 113 #define DO_2D_01_11 DO jj = Njs0, Nje1 ; DO ji = Nis1, Nie1 114 115 #define DO_2D_10_00 DO jj = Njs1, Nje0 ; DO ji = Nis0, Nie0 116 #define DO_2D_10_01 DO jj = Njs1, Nje0 ; DO ji = Nis0, Nie1 ! not used ? 117 #define DO_2D_10_10 DO jj = Njs1, Nje0 ; DO ji = Nis1, Nie0 118 #define DO_2D_10_11 DO jj = Njs1, Nje0 ; DO ji = Nis1, Nie1 119 120 #define DO_2D_11_00 DO jj = Njs1, Nje1 ; DO ji = Nis0, Nie0 121 #define DO_2D_11_01 DO jj = Njs1, Nje1 ; DO ji = Nis0, Nie1 122 #define DO_2D_11_10 DO jj = Njs1, Nje1 ; DO ji = Nis1, Nie0 123 #define DO_2D_11_11 DO jj = Njs1, Nje1 ; DO ji = Nis1, Nie1 124 125 ! 2D loops with 1 following a 2/3D loop with 2 126 127 #define DO_2D_00_01nxt2 DO jj = Njs0 , Nje0 ; DO ji = Nis0 , Nie1nxt2 128 #define DO_2D_00_10nxt2 DO jj = Njs0 , Nje0 ; DO ji = Nis1nxt2, Nie0 129 #define DO_2D_00_11nxt2 DO jj = Njs0 , Nje0 ; DO ji = Nis1nxt2, Nie1nxt2 130 131 #define DO_2D_01_00nxt2 DO jj = Njs0 , Nje1nxt2 ; DO ji = Nis0 , Nie0 132 #define DO_2D_01_01nxt2 DO jj = Njs0 , Nje1nxt2 ; DO ji = Nis0 , Nie1nxt2 133 #define DO_2D_01_10nxt2 DO jj = Njs0 , Nje1nxt2 ; DO ji = Nis1nxt2, Nie0 134 #define DO_2D_01_11nxt2 DO jj = Njs0 , Nje1nxt2 ; DO ji = Nis1nxt2, Nie1nxt2 135 136 #define DO_2D_10_00nxt2 DO jj = Njs1nxt2, Nje0 ; DO ji = Nis0 , Nie0 137 #define DO_2D_10_01nxt2 DO jj = Njs1nxt2, Nje0 ; DO ji = Nis0 , Nie1nxt2 ! not used ? 138 #define DO_2D_10_10nxt2 DO jj = Njs1nxt2, Nje0 ; DO ji = Nis1nxt2, Nie0 139 #define DO_2D_10_11nxt2 DO jj = Njs1nxt2, Nje0 ; DO ji = Nis1nxt2, Nie1nxt2 140 141 #define DO_2D_11_00nxt2 DO jj = Njs1nxt2, Nje1nxt2 ; DO ji = Nis0 , Nie0 142 #define DO_2D_11_01nxt2 DO jj = Njs1nxt2, Nje1nxt2 ; DO ji = Nis0 , Nie1nxt2 143 #define DO_2D_11_10nxt2 DO jj = Njs1nxt2, Nje1nxt2 ; DO ji = Nis1nxt2, Nie0 144 #define DO_2D_11_11nxt2 DO jj = Njs1nxt2, Nje1nxt2 ; DO ji = Nis1nxt2, Nie1nxt2 145 146 ! 2D loops with 2 147 148 #define DO_2D_11_12 DO jj = Njs1nxt2, Nje1nxt2 ; DO ji = Nis1nxt2, Nie2 149 #define DO_2D_11_21 DO jj = Njs1nxt2, Nje1nxt2 ; DO ji = Nis2 , Nie1nxt2 150 #define DO_2D_11_22 DO jj = Njs1nxt2, Nje1nxt2 ; DO ji = Nis2 , Nie2 151 152 #define DO_2D_12_11 DO jj = Njs1nxt2, Nje2 ; DO ji = Nis1nxt2, Nie1nxt2 153 #define DO_2D_12_12 DO jj = Njs1nxt2, Nje2 ; DO ji = Nis1nxt2, Nie2 154 #define DO_2D_12_21 DO jj = Njs1nxt2, Nje2 ; DO ji = Nis2 , Nie1nxt2 155 #define DO_2D_12_22 DO jj = Njs1nxt2, Nje2 ; DO ji = Nis2 , Nie2 156 157 #define DO_2D_21_11 DO jj = Njs2 , Nje1nxt2 ; DO ji = Nis1nxt2, Nie1nxt2 158 #define DO_2D_21_12 DO jj = Njs2 , Nje1nxt2 ; DO ji = Nis1nxt2, Nie2 ! not used ? 159 #define DO_2D_21_21 DO jj = Njs2 , Nje1nxt2 ; DO ji = Nis2 , Nie1nxt2 160 #define DO_2D_21_22 DO jj = Njs2 , Nje1nxt2 ; DO ji = Nis2 , Nie2 161 162 #define DO_2D_22_11 DO jj = Njs2 , Nje2 ; DO ji = Nis1nxt2, Nie1nxt2 163 #define DO_2D_22_12 DO jj = Njs2 , Nje2 ; DO ji = Nis1nxt2, Nie2 164 #define DO_2D_22_21 DO jj = Njs2 , Nje2 ; DO ji = Nis2 , Nie1nxt2 165 #define DO_2D_22_22 DO jj = Njs2 , Nje2 ; DO ji = Nis2 , Nie2 166 167 ! 3D loops with 1 168 169 #define DO_3D_00_00(ks,ke) DO jk = ks, ke ; DO_2D_00_00 170 #define DO_3D_00_01(ks,ke) DO jk = ks, ke ; DO_2D_00_01 171 #define DO_3D_00_10(ks,ke) DO jk = ks, ke ; DO_2D_00_10 172 #define DO_3D_00_11(ks,ke) DO jk = ks, ke ; DO_2D_00_11 173 174 #define DO_3D_01_00(ks,ke) DO jk = ks, ke ; DO_2D_01_00 175 #define DO_3D_01_01(ks,ke) DO jk = ks, ke ; DO_2D_01_01 176 #define DO_3D_01_10(ks,ke) DO jk = ks, ke ; DO_2D_01_10 177 #define DO_3D_01_11(ks,ke) DO jk = ks, ke ; DO_2D_01_11 178 179 #define DO_3D_10_00(ks,ke) DO jk = ks, ke ; DO_2D_10_00 180 #define DO_3D_10_01(ks,ke) DO jk = ks, ke ; DO_2D_10_01 181 #define DO_3D_10_10(ks,ke) DO jk = ks, ke ; DO_2D_10_10 182 #define DO_3D_10_11(ks,ke) DO jk = ks, ke ; DO_2D_10_11 183 184 #define DO_3D_11_00(ks,ke) DO jk = ks, ke ; DO_2D_11_00 185 #define DO_3D_11_01(ks,ke) DO jk = ks, ke ; DO_2D_11_01 186 #define DO_3D_11_10(ks,ke) DO jk = ks, ke ; DO_2D_11_10 187 #define DO_3D_11_11(ks,ke) DO jk = ks, ke ; DO_2D_11_11 188 189 ! 3D loops with 1, following a 2/3D loop with 2 190 191 #define DO_3D_00_01nxt2(ks,ke) DO jk = ks, ke ; DO_2D_00_01nxt2 192 #define DO_3D_00_10nxt2(ks,ke) DO jk = ks, ke ; DO_2D_00_10nxt2 193 #define DO_3D_00_11nxt2(ks,ke) DO jk = ks, ke ; DO_2D_00_11nxt2 194 195 #define DO_3D_01_00nxt2(ks,ke) DO jk = ks, ke ; DO_2D_01_00nxt2 196 #define DO_3D_01_01nxt2(ks,ke) DO jk = ks, ke ; DO_2D_01_01nxt2 197 #define DO_3D_01_10nxt2(ks,ke) DO jk = ks, ke ; DO_2D_01_10nxt2 198 #define DO_3D_01_11nxt2(ks,ke) DO jk = ks, ke ; DO_2D_01_11nxt2 199 200 #define DO_3D_10_00nxt2(ks,ke) DO jk = ks, ke ; DO_2D_10_00nxt2 201 #define DO_3D_10_01nxt2(ks,ke) DO jk = ks, ke ; DO_2D_10_01nxt2 202 #define DO_3D_10_10nxt2(ks,ke) DO jk = ks, ke ; DO_2D_10_10nxt2 203 #define DO_3D_10_11nxt2(ks,ke) DO jk = ks, ke ; DO_2D_10_11nxt2 204 205 #define DO_3D_11_00nxt2(ks,ke) DO jk = ks, ke ; DO_2D_11_00nxt2 206 #define DO_3D_11_01nxt2(ks,ke) DO jk = ks, ke ; DO_2D_11_01nxt2 207 #define DO_3D_11_10nxt2(ks,ke) DO jk = ks, ke ; DO_2D_11_10nxt2 208 #define DO_3D_11_11nxt2(ks,ke) DO jk = ks, ke ; DO_2D_11_11nxt2 209 210 ! 3D loops with 2 211 212 #define DO_3D_11_12(ks,ke) DO jk = ks, ke ; DO_2D_11_12 213 #define DO_3D_11_21(ks,ke) DO jk = ks, ke ; DO_2D_11_21 214 #define DO_3D_11_22(ks,ke) DO jk = ks, ke ; DO_2D_11_22 215 216 #define DO_3D_12_11(ks,ke) DO jk = ks, ke ; DO_2D_12_11 217 #define DO_3D_12_12(ks,ke) DO jk = ks, ke ; DO_2D_12_12 218 #define DO_3D_12_21(ks,ke) DO jk = ks, ke ; DO_2D_12_21 219 #define DO_3D_12_22(ks,ke) DO jk = ks, ke ; DO_2D_12_22 220 221 #define DO_3D_21_11(ks,ke) DO jk = ks, ke ; DO_2D_21_11 222 #define DO_3D_21_12(ks,ke) DO jk = ks, ke ; DO_2D_21_12 223 #define DO_3D_21_21(ks,ke) DO jk = ks, ke ; DO_2D_21_21 224 #define DO_3D_21_22(ks,ke) DO jk = ks, ke ; DO_2D_21_22 225 226 #define DO_3D_22_11(ks,ke) DO jk = ks, ke ; DO_2D_22_11 227 #define DO_3D_22_12(ks,ke) DO jk = ks, ke ; DO_2D_22_12 228 #define DO_3D_22_21(ks,ke) DO jk = ks, ke ; DO_2D_22_21 229 #define DO_3D_22_22(ks,ke) DO jk = ks, ke ; DO_2D_22_22 230 231 ! 3D loops with increment with 1 232 233 #define DO_3DS_00_00(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_00_00 234 #define DO_3DS_00_01(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_00_01 235 #define DO_3DS_00_10(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_00_10 236 #define DO_3DS_00_11(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_00_11 237 238 #define DO_3DS_01_00(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_01_00 239 #define DO_3DS_01_01(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_01_01 240 #define DO_3DS_01_10(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_01_10 241 #define DO_3DS_01_11(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_01_11 242 243 #define DO_3DS_10_00(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_10_00 244 #define DO_3DS_10_01(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_10_01 245 #define DO_3DS_10_10(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_10_10 246 #define DO_3DS_10_11(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_10_11 247 248 #define DO_3DS_11_00(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_11_00 249 #define DO_3DS_11_01(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_11_01 250 #define DO_3DS_11_10(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_11_10 251 #define DO_3DS_11_11(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_11_11 252 253 ! 3D loops with increment with 1, following a 2/3D loop with 2 254 255 #define DO_3DS_00_01nxt2(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_00_01nxt2 256 #define DO_3DS_00_10nxt2(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_00_10nxt2 257 #define DO_3DS_00_11nxt2(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_00_11nxt2 258 259 #define DO_3DS_01_00nxt2(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_01_00nxt2 260 #define DO_3DS_01_01nxt2(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_01_01nxt2 261 #define DO_3DS_01_10nxt2(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_01_10nxt2 262 #define DO_3DS_01_11nxt2(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_01_11nxt2 263 264 #define DO_3DS_10_00nxt2(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_10_00nxt2 265 #define DO_3DS_10_01nxt2(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_10_01nxt2 266 #define DO_3DS_10_10nxt2(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_10_10nxt2 267 #define DO_3DS_10_11nxt2(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_10_11nxt2 268 269 #define DO_3DS_11_00nxt2(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_11_00nxt2 270 #define DO_3DS_11_01nxt2(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_11_01nxt2 271 #define DO_3DS_11_10nxt2(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_11_10nxt2 272 #define DO_3DS_11_11nxt2(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_11_11nxt2 273 274 ! 3D loops with increment with 2 275 276 #define DO_3DS_11_12(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_11_12 277 #define DO_3DS_11_21(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_11_21 278 #define DO_3DS_11_22(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_11_22 279 280 #define DO_3DS_12_11(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_12_11 281 #define DO_3DS_12_12(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_12_12 282 #define DO_3DS_12_21(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_12_21 283 #define DO_3DS_12_22(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_12_22 284 285 #define DO_3DS_21_11(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_21_11 286 #define DO_3DS_21_12(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_21_12 287 #define DO_3DS_21_21(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_21_21 288 #define DO_3DS_21_22(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_21_22 289 290 #define DO_3DS_22_11(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_22_11 291 #define DO_3DS_22_12(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_22_12 292 #define DO_3DS_22_21(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_22_21 293 #define DO_3DS_22_22(ks,ke,ki) DO jk = ks, ke, ki ; DO_2D_22_22 294 102 295 #define END_2D END DO ; END DO 103 296 #define END_3D END DO ; END DO ; END DO -
NEMO/trunk/src/OCE/nemogcm.F90
r13237 r13286 47 47 USE usrdef_nam ! user defined configuration 48 48 USE tide_mod, ONLY : tide_init ! tidal components initialization (tide_init routine) 49 USE bdy_oce, ONLY : ln_bdy50 49 USE bdyini ! open boundary cond. setting (bdy_init routine) 51 50 USE istate ! initial state setting (istate_init routine) … … 88 87 #endif 89 88 ! 89 USE prtctl ! Print control 90 90 USE in_out_manager ! I/O manager 91 91 USE lib_mpp ! distributed memory computing 92 92 USE mppini ! shared/distributed memory setting (mpp_init routine) 93 USE lbcnfd , ONLY : isendto, nsndto , nfsloop, nfeloop! Setup of north fold exchanges93 USE lbcnfd , ONLY : isendto, nsndto ! Setup of north fold exchanges 94 94 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 95 95 #if defined key_iomput … … 99 99 USE agrif_all_update ! Master Agrif update 100 100 #endif 101 USE halo_mng 101 102 102 103 IMPLICIT NONE … … 279 280 INTEGER :: ios, ilocal_comm ! local integers 280 281 !! 281 NAMELIST/namctl/ sn_cfctl, nn_print, nn_ictls, nn_ictle, & 282 & nn_isplt , nn_jsplt, nn_jctls, nn_jctle, & 283 & ln_timing, ln_diacfl 282 NAMELIST/namctl/ sn_cfctl, ln_timing, ln_diacfl, & 283 & nn_isplt, nn_jsplt, nn_ictls, nn_ictle, nn_jctls, nn_jctle 284 284 NAMELIST/namcfg/ ln_read_cfg, cn_domcfg, ln_closea, ln_write_cfg, cn_domcfg_out, ln_use_jattr 285 285 !!---------------------------------------------------------------------- … … 399 399 ! 400 400 IF( ln_read_cfg ) THEN ! Read sizes in domain configuration file 401 CALL domain_cfg ( cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio )401 CALL domain_cfg ( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, jperio ) 402 402 ELSE ! user-defined namelist 403 CALL usr_def_nam( cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio )403 CALL usr_def_nam( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, jperio ) 404 404 ENDIF 405 405 ! … … 411 411 CALL mpp_init 412 412 413 CALL halo_mng_init() 413 414 ! Now we know the dimensions of the grid and numout has been set: we can allocate arrays 414 415 CALL nemo_alloc() … … 554 555 WRITE(numout,*) ' sn_cfctl%procincr = ', sn_cfctl%procincr 555 556 WRITE(numout,*) ' sn_cfctl%ptimincr = ', sn_cfctl%ptimincr 556 WRITE(numout,*) ' level of print nn_print = ', nn_print557 WRITE(numout,*) ' Start i indice for SUM control nn_ictls = ', nn_ictls558 WRITE(numout,*) ' End i indice for SUM control nn_ictle = ', nn_ictle559 WRITE(numout,*) ' Start j indice for SUM control nn_jctls = ', nn_jctls560 WRITE(numout,*) ' End j indice for SUM control nn_jctle = ', nn_jctle561 WRITE(numout,*) ' number of proc. following i nn_isplt = ', nn_isplt562 WRITE(numout,*) ' number of proc. following j nn_jsplt = ', nn_jsplt563 557 WRITE(numout,*) ' timing by routine ln_timing = ', ln_timing 564 558 WRITE(numout,*) ' CFL diagnostics ln_diacfl = ', ln_diacfl 565 559 ENDIF 566 560 ! 567 nprint = nn_print ! convert DOCTOR namelist names into OLD names 568 nictls = nn_ictls 569 nictle = nn_ictle 570 njctls = nn_jctls 571 njctle = nn_jctle 572 isplt = nn_isplt 573 jsplt = nn_jsplt 574 561 IF( .NOT.ln_read_cfg ) ln_closea = .false. ! dealing possible only with a domcfg file 575 562 IF(lwp) THEN ! control print 576 563 WRITE(numout,*) … … 583 570 WRITE(numout,*) ' use file attribute if exists as i/p j-start ln_use_jattr = ', ln_use_jattr 584 571 ENDIF 585 IF( .NOT.ln_read_cfg ) ln_closea = .false. ! dealing possible only with a domcfg file586 !587 ! ! Parameter control588 !589 IF( sn_cfctl%l_prtctl .OR. sn_cfctl%l_prttrc ) THEN ! sub-domain area indices for the control prints590 IF( lk_mpp .AND. jpnij > 1 ) THEN591 isplt = jpni ; jsplt = jpnj ; ijsplt = jpni*jpnj ! the domain is forced to the real split domain592 ELSE593 IF( isplt == 1 .AND. jsplt == 1 ) THEN594 CALL ctl_warn( ' - isplt & jsplt are equal to 1', &595 & ' - the print control will be done over the whole domain' )596 ENDIF597 ijsplt = isplt * jsplt ! total number of processors ijsplt598 ENDIF599 IF(lwp) WRITE(numout,*)' - The total number of processors over which the'600 IF(lwp) WRITE(numout,*)' print control will be done is ijsplt : ', ijsplt601 !602 ! ! indices used for the SUM control603 IF( nictls+nictle+njctls+njctle == 0 ) THEN ! print control done over the default area604 lsp_area = .FALSE.605 ELSE ! print control done over a specific area606 lsp_area = .TRUE.607 IF( nictls < 1 .OR. nictls > jpiglo ) THEN608 CALL ctl_warn( ' - nictls must be 1<=nictls>=jpiglo, it is forced to 1' )609 nictls = 1610 ENDIF611 IF( nictle < 1 .OR. nictle > jpiglo ) THEN612 CALL ctl_warn( ' - nictle must be 1<=nictle>=jpiglo, it is forced to jpiglo' )613 nictle = jpiglo614 ENDIF615 IF( njctls < 1 .OR. njctls > jpjglo ) THEN616 CALL ctl_warn( ' - njctls must be 1<=njctls>=jpjglo, it is forced to 1' )617 njctls = 1618 ENDIF619 IF( njctle < 1 .OR. njctle > jpjglo ) THEN620 CALL ctl_warn( ' - njctle must be 1<=njctle>=jpjglo, it is forced to jpjglo' )621 njctle = jpjglo622 ENDIF623 ENDIF624 ENDIF625 572 ! 626 573 IF( 1._wp /= SIGN(1._wp,-0._wp) ) CALL ctl_stop( 'nemo_ctl: The intrinsec SIGN function follows f2003 standard.', & -
NEMO/trunk/src/OCE/par_oce.F90
r13216 r13286 47 47 ! global domain size for AGRIF !!! * total AGRIF computational domain * 48 48 INTEGER, PUBLIC :: nbug_in_agrif_conv_do_not_remove_or_modify = 1 - 1 49 INTEGER, PUBLIC, PARAMETER :: nbghostcells = 3 !: number of ghost cells: default value50 INTEGER, PUBLIC :: nbghostcells_x !: number of ghost cells in i-direction49 INTEGER, PUBLIC, PARAMETER :: nbghostcells = 3 !: number of ghost cells: default value 50 INTEGER, PUBLIC :: nbghostcells_x !: number of ghost cells in i-direction 51 51 INTEGER, PUBLIC :: nbghostcells_y_s !: number of ghost cells in j-direction at south 52 INTEGER, PUBLIC :: nbghostcells_y_n !: number of ghost cells in j-direction at north !: number of ghost cells53 INTEGER, PUBLIC :: nbcellsx ! = jpiglo - 2 - 2*nbghostcells_x!: number of cells in i-direction54 INTEGER, PUBLIC :: nbcellsy ! = jpjglo - 2 - 2*nbghostcells-y!: number of cells in j-direction52 INTEGER, PUBLIC :: nbghostcells_y_n !: number of ghost cells in j-direction at north 53 INTEGER, PUBLIC :: nbcellsx !: number of cells in i-direction 54 INTEGER, PUBLIC :: nbcellsy !: number of cells in j-direction 55 55 56 56 ! local domain size !!! * local computational domain * … … 62 62 INTEGER, PUBLIC :: jpkm1 ! = jpk-1 !: - - - 63 63 INTEGER, PUBLIC :: jpij ! = jpi*jpj !: jpi x jpj 64 INTEGER, PUBLIC :: jpimax! = ( jpiglo-2*nn_hls + (jpni-1) ) / jpni + 2*nn_hls!: maximum jpi65 INTEGER, PUBLIC :: jpjmax! = ( jpjglo-2*nn_hls + (jpnj-1) ) / jpnj + 2*nn_hls!: maximum jpj64 INTEGER, PUBLIC :: jpimax! = ( Ni0glo + jpni-1 ) / jpni + 2*nn_hls !: maximum jpi 65 INTEGER, PUBLIC :: jpjmax! = ( Nj0glo + jpnj-1 ) / jpnj + 2*nn_hls !: maximum jpj 66 66 67 67 !!--------------------------------------------------------------------- … … 81 81 INTEGER, PUBLIC, PARAMETER :: jpr2di = 0 !: number of columns for extra outer halo 82 82 INTEGER, PUBLIC, PARAMETER :: jpr2dj = 0 !: number of rows for extra outer halo 83 INTEGER, PUBLIC, PARAMETER :: nn_hls = 1 !: halo width (applies to both rows and columns) 83 84 ! halo with and starting/inding DO-loop indices 85 INTEGER, PUBLIC :: nn_hls !: halo width (applies to both rows and columns) 86 INTEGER, PUBLIC :: Nis0, Nis1, Nis1nxt2, Nis2 !: start I-index (_0: without halo, _1 or _2: with 1 or 2 halos) 87 INTEGER, PUBLIC :: Nie0, Nie1, Nie1nxt2, Nie2 !: end I-index (_0: without halo, _1 or _2: with 1 or 2 halos) 88 INTEGER, PUBLIC :: Njs0, Njs1, Njs1nxt2, Njs2 !: start J-index (_0: without halo, _1 or _2: with 1 or 2 halos) 89 INTEGER, PUBLIC :: Nje0, Nje1, Nje1nxt2, Nje2 !: end J-index (_0: without halo, _1 or _2: with 1 or 2 halos) 90 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) 91 INTEGER, PUBLIC :: Ni0glo, Nj0glo 84 92 85 93 !!---------------------------------------------------------------------- -
NEMO/trunk/src/OCE/trc_oce.F90
r12377 r13286 158 158 zchl = zrgb(1,jc) 159 159 irgb = NINT( 41 + 20.* LOG10( zchl ) + 1.e-15 ) 160 IF(lwp .AND. nn_print >= 1 ) WRITE(numout,*) ' jc =', jc, ' Chl = ', zchl, ' irgb = ', irgb161 160 IF( irgb /= jc ) THEN 162 161 IF(lwp) WRITE(numout,*) ' jc =', jc, ' Chl = ', zchl, ' Chl class = ', irgb -
NEMO/trunk/src/OFF/dtadyn.F90
r13237 r13286 71 71 INTEGER , SAVE :: jf_uwd ! index of u-transport 72 72 INTEGER , SAVE :: jf_vwd ! index of v-transport 73 INTEGER , SAVE :: jf_wwd ! index of v-transport73 INTEGER , SAVE :: jf_wwd ! index of w-transport 74 74 INTEGER , SAVE :: jf_avt ! index of Kz 75 75 INTEGER , SAVE :: jf_mld ! index of mixed layer deptht … … 128 128 ! 129 129 IF( kt == nit000 ) THEN ; nprevrec = 0 130 ELSE ; nprevrec = sf_dyn(jf_tem)%nrec _a(2)130 ELSE ; nprevrec = sf_dyn(jf_tem)%nrec(2,sf_dyn(jf_tem)%naa) 131 131 ENDIF 132 132 CALL fld_read( kt, 1, sf_dyn ) != read data at kt time step ==! … … 294 294 ! ! fill sf with slf_i and control print 295 295 CALL fld_fill( sf_dyn, slf_d, cn_dir, 'dta_dyn_init', 'Data in file', 'namdta_dyn' ) 296 sf_dyn(jf_uwd)%cltype = 'U' ; sf_dyn(jf_uwd)%zsgn = -1._wp 297 sf_dyn(jf_vwd)%cltype = 'V' ; sf_dyn(jf_vwd)%zsgn = -1._wp 298 sf_dyn(jf_ubl)%cltype = 'U' ; sf_dyn(jf_ubl)%zsgn = 1._wp 299 sf_dyn(jf_vbl)%cltype = 'V' ; sf_dyn(jf_vbl)%zsgn = 1._wp 296 300 ! 297 301 ! Open file for each variable to get his number of dimension … … 330 334 iom_varid( numrtr, 'sshn', ldstop = .FALSE. ) > 0 ) THEN 331 335 IF(lwp) WRITE(numout,*) ' ssh(:,:,Kmm) forcing fields read in the restart file for initialisation' 332 CALL iom_get( numrtr, jpdom_auto glo, 'sshn', ssh(:,:,Kmm) )333 CALL iom_get( numrtr, jpdom_auto glo, 'sshb', ssh(:,:,Kbb) )336 CALL iom_get( numrtr, jpdom_auto, 'sshn', ssh(:,:,Kmm) ) 337 CALL iom_get( numrtr, jpdom_auto, 'sshb', ssh(:,:,Kbb) ) 334 338 ELSE 335 339 IF(lwp) WRITE(numout,*) ' ssh(:,:,Kmm) forcing fields read in the restart file for initialisation' 336 340 CALL iom_open( 'restart', inum ) 337 CALL iom_get( inum, jpdom_auto glo, 'sshn', ssh(:,:,Kmm) )338 CALL iom_get( inum, jpdom_auto glo, 'sshb', ssh(:,:,Kbb) )341 CALL iom_get( inum, jpdom_auto, 'sshn', ssh(:,:,Kmm) ) 342 CALL iom_get( inum, jpdom_auto, 'sshb', ssh(:,:,Kbb) ) 339 343 CALL iom_close( inum ) ! close file 340 344 ENDIF … … 388 392 IF(lwp) WRITE(numout,*) ' read in the file depht over which runoffs are distributed' 389 393 CALL iom_open ( "runoffs", inum ) ! open file 390 CALL iom_get ( inum, jpdom_ data, 'rodepth', h_rnf ) ! read the river mouth array394 CALL iom_get ( inum, jpdom_global, 'rodepth', h_rnf ) ! read the river mouth array 391 395 CALL iom_close( inum ) ! close file 392 396 ! … … 452 456 ! 453 457 IF( kt == nit000 ) THEN ; nprevrec = 0 454 ELSE ; nprevrec = sf_dyn(jf_tem)%nrec _a(2)458 ELSE ; nprevrec = sf_dyn(jf_tem)%nrec(2,sf_dyn(jf_tem)%naa) 455 459 ENDIF 456 460 CALL fld_read( kt, 1, sf_dyn ) != read data at kt time step ==! … … 711 715 !!--------------------------------------------------------------------- 712 716 ! 713 IF( sf_dyn(jf_tem)%ln_tint ) THEN ! Computes slopes (here avt is used as workspace) 717 IF( sf_dyn(jf_tem)%ln_tint ) THEN ! Computes slopes (here avt is used as workspace) 718 ! 714 719 IF( kt == nit000 ) THEN 715 720 IF(lwp) WRITE(numout,*) ' Compute new slopes at kt = ', kt 716 zts(:,:,:,jp_tem) = sf_dyn(jf_tem)%fdta(:,:,:, 1) * tmask(:,:,:) ! temperature717 zts(:,:,:,jp_sal) = sf_dyn(jf_sal)%fdta(:,:,:, 1) * tmask(:,:,:) ! salinity718 avt(:,:,:) = sf_dyn(jf_avt)%fdta(:,:,:, 1) * tmask(:,:,:) ! vertical diffusive coef.721 zts(:,:,:,jp_tem) = sf_dyn(jf_tem)%fdta(:,:,:,sf_dyn(jf_tem)%nbb) * tmask(:,:,:) ! temperature 722 zts(:,:,:,jp_sal) = sf_dyn(jf_sal)%fdta(:,:,:,sf_dyn(jf_sal)%nbb) * tmask(:,:,:) ! salinity 723 avt(:,:,:) = sf_dyn(jf_avt)%fdta(:,:,:,sf_dyn(jf_avt)%nbb) * tmask(:,:,:) ! vertical diffusive coef. 719 724 CALL compute_slopes( kt, zts, zuslp, zvslp, zwslpi, zwslpj, Kbb, Kmm ) 720 725 uslpdta (:,:,:,1) = zuslp (:,:,:) … … 723 728 wslpjdta(:,:,:,1) = zwslpj(:,:,:) 724 729 ! 725 zts(:,:,:,jp_tem) = sf_dyn(jf_tem)%fdta(:,:,:, 2) * tmask(:,:,:) ! temperature726 zts(:,:,:,jp_sal) = sf_dyn(jf_sal)%fdta(:,:,:, 2) * tmask(:,:,:) ! salinity727 avt(:,:,:) = sf_dyn(jf_avt)%fdta(:,:,:, 2) * tmask(:,:,:) ! vertical diffusive coef.730 zts(:,:,:,jp_tem) = sf_dyn(jf_tem)%fdta(:,:,:,sf_dyn(jf_tem)%naa) * tmask(:,:,:) ! temperature 731 zts(:,:,:,jp_sal) = sf_dyn(jf_sal)%fdta(:,:,:,sf_dyn(jf_sal)%naa) * tmask(:,:,:) ! salinity 732 avt(:,:,:) = sf_dyn(jf_avt)%fdta(:,:,:,sf_dyn(jf_avt)%naa) * tmask(:,:,:) ! vertical diffusive coef. 728 733 CALL compute_slopes( kt, zts, zuslp, zvslp, zwslpi, zwslpj, Kbb, Kmm ) 729 734 uslpdta (:,:,:,2) = zuslp (:,:,:) … … 734 739 ! 735 740 iswap = 0 736 IF( sf_dyn(jf_tem)%nrec _a(2) - nprevrec /= 0 ) iswap = 1737 IF( nsecdyn > sf_dyn(jf_tem)%nrec _b(2) .AND. iswap == 1 ) THEN ! read/update the after data741 IF( sf_dyn(jf_tem)%nrec(2,sf_dyn(jf_tem)%naa) - nprevrec /= 0 ) iswap = 1 742 IF( nsecdyn > sf_dyn(jf_tem)%nrec(2,sf_dyn(jf_tem)%nbb) .AND. iswap == 1 ) THEN ! read/update the after data 738 743 IF(lwp) WRITE(numout,*) ' Compute new slopes at kt = ', kt 739 744 uslpdta (:,:,:,1) = uslpdta (:,:,:,2) ! swap the data … … 742 747 wslpjdta(:,:,:,1) = wslpjdta(:,:,:,2) 743 748 ! 744 zts(:,:,:,jp_tem) = sf_dyn(jf_tem)%fdta(:,:,:, 2) * tmask(:,:,:) ! temperature745 zts(:,:,:,jp_sal) = sf_dyn(jf_sal)%fdta(:,:,:, 2) * tmask(:,:,:) ! salinity746 avt(:,:,:) = sf_dyn(jf_avt)%fdta(:,:,:, 2) * tmask(:,:,:) ! vertical diffusive coef.749 zts(:,:,:,jp_tem) = sf_dyn(jf_tem)%fdta(:,:,:,sf_dyn(jf_tem)%naa) * tmask(:,:,:) ! temperature 750 zts(:,:,:,jp_sal) = sf_dyn(jf_sal)%fdta(:,:,:,sf_dyn(jf_sal)%naa) * tmask(:,:,:) ! salinity 751 avt(:,:,:) = sf_dyn(jf_avt)%fdta(:,:,:,sf_dyn(jf_avt)%naa) * tmask(:,:,:) ! vertical diffusive coef. 747 752 CALL compute_slopes( kt, zts, zuslp, zvslp, zwslpi, zwslpj, Kbb, Kmm ) 748 753 ! … … 756 761 ! 757 762 IF( sf_dyn(jf_tem)%ln_tint ) THEN 758 ztinta = REAL( nsecdyn - sf_dyn(jf_tem)%nrec _b(2), wp ) &759 & / REAL( sf_dyn(jf_tem)%nrec _a(2) - sf_dyn(jf_tem)%nrec_b(2), wp )763 ztinta = REAL( nsecdyn - sf_dyn(jf_tem)%nrec(2,sf_dyn(jf_tem)%nbb), wp ) & 764 & / REAL( sf_dyn(jf_tem)%nrec(2,sf_dyn(jf_tem)%naa) - sf_dyn(jf_tem)%nrec(2,sf_dyn(jf_tem)%nbb), wp ) 760 765 ztintb = 1. - ztinta 761 766 IF( l_ldfslp .AND. .NOT.lk_c1d ) THEN ! Computes slopes (here avt is used as workspace) -
NEMO/trunk/src/OFF/nemogcm.F90
r13237 r13286 31 31 USE domqco ! tools for scale factor (dom_qco_r3c routine) 32 32 #endif 33 USE bdy_oce, ONLY : ln_bdy 34 USE bdyini ! open boundary cond. setting (bdy_init routine) 33 USE bdyini ! open boundary cond. setting (bdy_init routine) 35 34 ! ! ocean physics 36 35 USE ldftra ! lateral diffusivity setting (ldf_tra_init routine) … … 64 63 USE timing ! Timing 65 64 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 66 USE lbcnfd , ONLY : isendto, nsndto , nfsloop, nfeloop! Setup of north fold exchanges65 USE lbcnfd , ONLY : isendto, nsndto ! Setup of north fold exchanges 67 66 USE step, ONLY : Nbb, Nnn, Naa, Nrhs ! time level indices 67 USE halo_mng 68 68 69 69 IMPLICIT NONE … … 193 193 INTEGER :: ios, ilocal_comm ! local integers 194 194 !! 195 NAMELIST/namctl/ sn_cfctl, nn_print, nn_ictls, nn_ictle, & 196 & nn_isplt , nn_jsplt, nn_jctls, nn_jctle, & 197 & ln_timing, ln_diacfl 195 NAMELIST/namctl/ sn_cfctl, ln_timing, ln_diacfl, & 196 & nn_isplt, nn_jsplt, nn_ictls, nn_ictle, nn_jctls, nn_jctle 198 197 NAMELIST/namcfg/ ln_read_cfg, cn_domcfg, ln_closea, ln_write_cfg, cn_domcfg_out, ln_use_jattr 199 198 !!---------------------------------------------------------------------- 200 199 ! 201 200 cxios_context = 'nemo' 201 nn_hls = 1 202 202 ! 203 203 ! !-------------------------------------------------! … … 292 292 ! 293 293 IF( ln_read_cfg ) THEN ! Read sizes in domain configuration file 294 CALL domain_cfg ( cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio )294 CALL domain_cfg ( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, jperio ) 295 295 ELSE ! user-defined namelist 296 CALL usr_def_nam( cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio )296 CALL usr_def_nam( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, jperio ) 297 297 ENDIF 298 298 ! … … 306 306 CALL mpp_init 307 307 308 CALL halo_mng_init() 308 309 ! Now we know the dimensions of the grid and numout has been set: we can allocate arrays 309 310 CALL nemo_alloc() … … 386 387 WRITE(numout,*) ' sn_cfctl%procincr = ', sn_cfctl%procincr 387 388 WRITE(numout,*) ' sn_cfctl%ptimincr = ', sn_cfctl%ptimincr 388 WRITE(numout,*) ' level of print nn_print = ', nn_print389 WRITE(numout,*) ' Start i indice for SUM control nn_ictls = ', nn_ictls390 WRITE(numout,*) ' End i indice for SUM control nn_ictle = ', nn_ictle391 WRITE(numout,*) ' Start j indice for SUM control nn_jctls = ', nn_jctls392 WRITE(numout,*) ' End j indice for SUM control nn_jctle = ', nn_jctle393 WRITE(numout,*) ' number of proc. following i nn_isplt = ', nn_isplt394 WRITE(numout,*) ' number of proc. following j nn_jsplt = ', nn_jsplt395 389 WRITE(numout,*) ' timing by routine ln_timing = ', ln_timing 396 390 WRITE(numout,*) ' CFL diagnostics ln_diacfl = ', ln_diacfl 397 391 ENDIF 398 ! 399 nprint = nn_print ! convert DOCTOR namelist names into OLD names 400 nictls = nn_ictls 401 nictle = nn_ictle 402 njctls = nn_jctls 403 njctle = nn_jctle 404 isplt = nn_isplt 405 jsplt = nn_jsplt 406 392 393 IF( .NOT.ln_read_cfg ) ln_closea = .false. ! dealing possible only with a domcfg file 407 394 IF(lwp) THEN ! control print 408 395 WRITE(numout,*) … … 414 401 WRITE(numout,*) ' filename to be written cn_domcfg_out = ', TRIM(cn_domcfg_out) 415 402 WRITE(numout,*) ' use file attribute if exists as i/p j-start ln_use_jattr = ', ln_use_jattr 416 ENDIF417 IF( .NOT.ln_read_cfg ) ln_closea = .false. ! dealing possible only with a domcfg file418 !419 ! ! Parameter control420 !421 IF( sn_cfctl%l_prtctl .OR. sn_cfctl%l_prttrc ) THEN ! sub-domain area indices for the control prints422 IF( lk_mpp .AND. jpnij > 1 ) THEN423 isplt = jpni ; jsplt = jpnj ; ijsplt = jpni*jpnj ! the domain is forced to the real split domain424 ELSE425 IF( isplt == 1 .AND. jsplt == 1 ) THEN426 CALL ctl_warn( ' - isplt & jsplt are equal to 1', &427 & ' - the print control will be done over the whole domain' )428 ENDIF429 ijsplt = isplt * jsplt ! total number of processors ijsplt430 ENDIF431 IF(lwp) WRITE(numout,*)' - The total number of processors over which the'432 IF(lwp) WRITE(numout,*)' print control will be done is ijsplt : ', ijsplt433 !434 ! ! indices used for the SUM control435 IF( nictls+nictle+njctls+njctle == 0 ) THEN ! print control done over the default area436 lsp_area = .FALSE.437 ELSE ! print control done over a specific area438 lsp_area = .TRUE.439 IF( nictls < 1 .OR. nictls > jpiglo ) THEN440 CALL ctl_warn( ' - nictls must be 1<=nictls>=jpiglo, it is forced to 1' )441 nictls = 1442 ENDIF443 IF( nictle < 1 .OR. nictle > jpiglo ) THEN444 CALL ctl_warn( ' - nictle must be 1<=nictle>=jpiglo, it is forced to jpiglo' )445 nictle = jpiglo446 ENDIF447 IF( njctls < 1 .OR. njctls > jpjglo ) THEN448 CALL ctl_warn( ' - njctls must be 1<=njctls>=jpjglo, it is forced to 1' )449 njctls = 1450 ENDIF451 IF( njctle < 1 .OR. njctle > jpjglo ) THEN452 CALL ctl_warn( ' - njctle must be 1<=njctle>=jpjglo, it is forced to jpjglo' )453 njctle = jpjglo454 ENDIF455 ENDIF456 403 ENDIF 457 404 ! -
NEMO/trunk/src/SAO/nemogcm.F90
r12933 r13286 29 29 USE sao_intp 30 30 ! 31 USE prtctl ! Print control 31 32 USE in_out_manager ! I/O manager 32 33 USE lib_mpp ! distributed memory computing 33 34 USE mppini ! shared/distributed memory setting (mpp_init routine) 34 USE lbcnfd , ONLY : isendto, nsndto , nfsloop, nfeloop! Setup of north fold exchanges35 USE lbcnfd , ONLY : isendto, nsndto ! Setup of north fold exchanges 35 36 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 36 37 #if defined key_iomput 37 38 USE xios ! xIOserver 38 39 #endif 40 USE halo_mng 39 41 40 42 IMPLICIT NONE … … 92 94 INTEGER :: ios, ilocal_comm ! local integer 93 95 ! 94 NAMELIST/namctl/ sn_cfctl, nn_print, nn_ictls, nn_ictle, & 95 & nn_isplt , nn_jsplt, nn_jctls, nn_jctle, & 96 & ln_timing, ln_diacfl 96 NAMELIST/namctl/ sn_cfctl, ln_timing, ln_diacfl, & 97 & nn_isplt, nn_jsplt, nn_ictls, nn_ictle, nn_jctls, nn_jctle 97 98 NAMELIST/namcfg/ ln_read_cfg, cn_domcfg, ln_closea, ln_write_cfg, cn_domcfg_out, ln_use_jattr 98 99 !!---------------------------------------------------------------------- 99 100 ! 100 101 cxios_context = 'nemo' 102 nn_hls = 1 101 103 ! 102 104 ! !-------------------------------------------------! … … 205 207 ! 206 208 IF( ln_read_cfg ) THEN ! Read sizes in domain configuration file 207 CALL domain_cfg ( cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio )209 CALL domain_cfg ( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, jperio ) 208 210 ELSE ! user-defined namelist 209 CALL usr_def_nam( cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio )211 CALL usr_def_nam( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, jperio ) 210 212 ENDIF 211 213 ! … … 217 219 CALL mpp_init 218 220 221 CALL halo_mng_init() 219 222 ! Now we know the dimensions of the grid and numout has been set: we can allocate arrays 220 223 CALL nemo_alloc() … … 267 270 WRITE(numout,*) ' sn_cfctl%procincr = ', sn_cfctl%procincr 268 271 WRITE(numout,*) ' sn_cfctl%ptimincr = ', sn_cfctl%ptimincr 269 WRITE(numout,*) ' level of print nn_print = ', nn_print270 WRITE(numout,*) ' Start i indice for SUM control nn_ictls = ', nn_ictls271 WRITE(numout,*) ' End i indice for SUM control nn_ictle = ', nn_ictle272 WRITE(numout,*) ' Start j indice for SUM control nn_jctls = ', nn_jctls273 WRITE(numout,*) ' End j indice for SUM control nn_jctle = ', nn_jctle274 WRITE(numout,*) ' number of proc. following i nn_isplt = ', nn_isplt275 WRITE(numout,*) ' number of proc. following j nn_jsplt = ', nn_jsplt276 272 WRITE(numout,*) ' timing by routine ln_timing = ', ln_timing 277 273 WRITE(numout,*) ' CFL diagnostics ln_diacfl = ', ln_diacfl 278 274 ENDIF 279 275 ! 280 nprint = nn_print ! convert DOCTOR namelist names into OLD names 281 nictls = nn_ictls 282 nictle = nn_ictle 283 njctls = nn_jctls 284 njctle = nn_jctle 285 isplt = nn_isplt 286 jsplt = nn_jsplt 287 276 IF( .NOT.ln_read_cfg ) ln_closea = .false. ! dealing possible only with a domcfg file 288 277 IF(lwp) THEN ! control print 289 278 WRITE(numout,*) … … 295 284 WRITE(numout,*) ' filename to be written cn_domcfg_out = ', TRIM(cn_domcfg_out) 296 285 WRITE(numout,*) ' use file attribute if exists as i/p j-start ln_use_jattr = ', ln_use_jattr 297 ENDIF298 IF( .NOT.ln_read_cfg ) ln_closea = .false. ! dealing possible only with a domcfg file299 !300 ! ! Parameter control301 !302 IF( sn_cfctl%l_prtctl .OR. sn_cfctl%l_prttrc ) THEN ! sub-domain area indices for the control prints303 IF( lk_mpp .AND. jpnij > 1 ) THEN304 isplt = jpni ; jsplt = jpnj ; ijsplt = jpni*jpnj ! the domain is forced to the real split domain305 ELSE306 IF( isplt == 1 .AND. jsplt == 1 ) THEN307 CALL ctl_warn( ' - isplt & jsplt are equal to 1', &308 & ' - the print control will be done over the whole domain' )309 ENDIF310 ijsplt = isplt * jsplt ! total number of processors ijsplt311 ENDIF312 IF(lwp) WRITE(numout,*)' - The total number of processors over which the'313 IF(lwp) WRITE(numout,*)' print control will be done is ijsplt : ', ijsplt314 !315 ! ! indices used for the SUM control316 IF( nictls+nictle+njctls+njctle == 0 ) THEN ! print control done over the default area317 lsp_area = .FALSE.318 ELSE ! print control done over a specific area319 lsp_area = .TRUE.320 IF( nictls < 1 .OR. nictls > jpiglo ) THEN321 CALL ctl_warn( ' - nictls must be 1<=nictls>=jpiglo, it is forced to 1' )322 nictls = 1323 ENDIF324 IF( nictle < 1 .OR. nictle > jpiglo ) THEN325 CALL ctl_warn( ' - nictle must be 1<=nictle>=jpiglo, it is forced to jpiglo' )326 nictle = jpiglo327 ENDIF328 IF( njctls < 1 .OR. njctls > jpjglo ) THEN329 CALL ctl_warn( ' - njctls must be 1<=njctls>=jpjglo, it is forced to 1' )330 njctls = 1331 ENDIF332 IF( njctle < 1 .OR. njctle > jpjglo ) THEN333 CALL ctl_warn( ' - njctle must be 1<=njctle>=jpjglo, it is forced to jpjglo' )334 njctle = jpjglo335 ENDIF336 ENDIF337 286 ENDIF 338 287 ! -
NEMO/trunk/src/SAO/sao_read.F90
r10069 r13286 10 10 USE netcdf 11 11 USE oce, ONLY: tsn, sshn 12 USE dom_oce, ONLY: n lci, nlcj, nimpp, njmpp, tmask12 USE dom_oce, ONLY: nimpp, njmpp, tmask 13 13 USE par_oce, ONLY: jpi, jpj, jpk 14 14 ! … … 94 94 IF (ifcst .LE. ntimes) THEN 95 95 ! Allocate temporary temperature array 96 ALLOCATE(temp_tn( nlci,nlcj,jpk))97 ALLOCATE(temp_sn( nlci,nlcj,jpk))98 ALLOCATE(temp_sshn( nlci,nlcj))96 ALLOCATE(temp_tn(jpi,jpj,jpk)) 97 ALLOCATE(temp_sn(jpi,jpj,jpk)) 98 ALLOCATE(temp_sshn(jpi,jpj)) 99 99 100 100 ! Set temp_tn, temp_sn to 0. … … 104 104 105 105 ! Create start and count arrays 106 start_n = (/ nimpp, njmpp, 1,ifcst /)107 count_n = (/ nlci, nlcj, jpk, 1/)108 start_s = (/ nimpp, njmpp , ifcst /)109 count_s = (/ nlci, nlcj, 1/)106 start_n = (/ nimpp, njmpp, 1, ifcst /) 107 count_n = (/ jpi, jpj, jpk, 1 /) 108 start_s = (/ nimpp, njmpp , ifcst /) 109 count_s = (/ jpi, jpj, 1 /) 110 110 111 111 ! Read information into temporary arrays … … 138 138 139 139 ! Mask out missing data index 140 tsn(1:nlci,1:nlcj,1:jpk,1) = temp_tn(:,:,:) * tmask(1:nlci,1:nlcj,1:jpk) 141 tsn(1:nlci,1:nlcj,1:jpk,2) = temp_sn(:,:,:) * tmask(1:nlci,1:nlcj,1:jpk) 142 sshn(1:nlci,1:nlcj) = temp_sshn(:,:) * tmask(1:nlci,1:nlcj,1) 143 144 ! Remove halo from tmask, tsn, sshn to prevent double obs counting 145 IF (jpi > nlci) THEN 146 tmask(nlci+1:,:,:) = 0 147 tsn(nlci+1:,:,:,1) = 0 148 tsn(nlci+1:,:,:,2) = 0 149 sshn(nlci+1:,:) = 0 150 END IF 151 IF (jpj > nlcj) THEN 152 tmask(:,nlcj+1:,:) = 0 153 tsn(:,nlcj+1:,:,1) = 0 154 tsn(:,nlcj+1:,:,2) = 0 155 sshn(:,nlcj+1:) = 0 156 END IF 157 140 tsn(1:jpi,1:jpj,1:jpk,1) = temp_tn(:,:,:) * tmask(1:jpi,1:jpj,1:jpk) 141 tsn(1:jpi,1:jpj,1:jpk,2) = temp_sn(:,:,:) * tmask(1:jpi,1:jpj,1:jpk) 142 sshn(1:jpi,1:jpj) = temp_sshn(:,:) * tmask(1:jpi,1:jpj,1) 143 158 144 ! Deallocate arrays 159 145 DEALLOCATE(temp_tn, temp_sn, temp_sshn) -
NEMO/trunk/src/SAS/nemogcm.F90
r13216 r13286 35 35 USE step_diu ! diurnal bulk SST timestepping (called from here if run offline) 36 36 ! 37 USE prtctl ! Print control 37 38 USE in_out_manager ! I/O manager 38 39 USE lib_mpp ! distributed memory computing 39 40 USE mppini ! shared/distributed memory setting (mpp_init routine) 40 USE lbcnfd , ONLY : isendto, nsndto , nfsloop, nfeloop! Setup of north fold exchanges41 USE lbcnfd , ONLY : isendto, nsndto ! Setup of north fold exchanges 41 42 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 42 43 #if defined key_iomput … … 46 47 USE agrif_ice_update ! ice update 47 48 #endif 49 USE halo_mng 48 50 49 51 IMPLICIT NONE … … 197 199 INTEGER :: ios, ilocal_comm ! local integers 198 200 !! 199 NAMELIST/namctl/ sn_cfctl, nn_print, nn_ictls, nn_ictle, & 200 & nn_isplt , nn_jsplt, nn_jctls, nn_jctle, & 201 & ln_timing, ln_diacfl 201 NAMELIST/namctl/ sn_cfctl, ln_timing, ln_diacfl, & 202 & nn_isplt, nn_jsplt, nn_ictls, nn_ictle, nn_jctls, nn_jctle 202 203 NAMELIST/namcfg/ ln_read_cfg, cn_domcfg, ln_closea, ln_write_cfg, cn_domcfg_out, ln_use_jattr 203 204 !!---------------------------------------------------------------------- … … 206 207 ELSE ; cxios_context = 'nemo' 207 208 ENDIF 209 nn_hls = 1 208 210 ! 209 211 ! !-------------------------------------------------! … … 324 326 ! 325 327 IF( ln_read_cfg ) THEN ! Read sizes in domain configuration file 326 CALL domain_cfg ( cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio )328 CALL domain_cfg ( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, jperio ) 327 329 ELSE ! user-defined namelist 328 CALL usr_def_nam( cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio )330 CALL usr_def_nam( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, jperio ) 329 331 ENDIF 330 332 ! … … 336 338 CALL mpp_init 337 339 340 CALL halo_mng_init() 338 341 ! Now we know the dimensions of the grid and numout has been set: we can allocate arrays 339 342 CALL nemo_alloc() … … 409 412 WRITE(numout,*) ' sn_cfctl%procincr = ', sn_cfctl%procincr 410 413 WRITE(numout,*) ' sn_cfctl%ptimincr = ', sn_cfctl%ptimincr 411 WRITE(numout,*) ' level of print nn_print = ', nn_print412 WRITE(numout,*) ' Start i indice for SUM control nn_ictls = ', nn_ictls413 WRITE(numout,*) ' End i indice for SUM control nn_ictle = ', nn_ictle414 WRITE(numout,*) ' Start j indice for SUM control nn_jctls = ', nn_jctls415 WRITE(numout,*) ' End j indice for SUM control nn_jctle = ', nn_jctle416 WRITE(numout,*) ' number of proc. following i nn_isplt = ', nn_isplt417 WRITE(numout,*) ' number of proc. following j nn_jsplt = ', nn_jsplt418 414 WRITE(numout,*) ' timing by routine ln_timing = ', ln_timing 419 415 WRITE(numout,*) ' CFL diagnostics ln_diacfl = ', ln_diacfl 420 416 ENDIF 421 417 ! 422 nprint = nn_print ! convert DOCTOR namelist names into OLD names 423 nictls = nn_ictls 424 nictle = nn_ictle 425 njctls = nn_jctls 426 njctle = nn_jctle 427 isplt = nn_isplt 428 jsplt = nn_jsplt 429 418 IF( .NOT.ln_read_cfg ) ln_closea = .FALSE. ! dealing possible only with a domcfg file 430 419 IF(lwp) THEN ! control print 431 420 WRITE(numout,*) … … 438 427 WRITE(numout,*) ' use file attribute if exists as i/p j-start ln_use_jattr = ', ln_use_jattr 439 428 ENDIF 440 IF( .NOT.ln_read_cfg ) ln_closea = .false. ! dealing possible only with a domcfg file441 !442 ! ! Parameter control443 !444 IF( sn_cfctl%l_prtctl .OR. sn_cfctl%l_prttrc ) THEN ! sub-domain area indices for the control prints445 IF( lk_mpp .AND. jpnij > 1 ) THEN446 isplt = jpni ; jsplt = jpnj ; ijsplt = jpni*jpnj ! the domain is forced to the real split domain447 ELSE448 IF( isplt == 1 .AND. jsplt == 1 ) THEN449 CALL ctl_warn( ' - isplt & jsplt are equal to 1', &450 & ' - the print control will be done over the whole domain' )451 ENDIF452 ijsplt = isplt * jsplt ! total number of processors ijsplt453 ENDIF454 IF(lwp) WRITE(numout,*)' - The total number of processors over which the'455 IF(lwp) WRITE(numout,*)' print control will be done is ijsplt : ', ijsplt456 !457 ! ! indices used for the SUM control458 IF( nictls+nictle+njctls+njctle == 0 ) THEN ! print control done over the default area459 lsp_area = .FALSE.460 ELSE ! print control done over a specific area461 lsp_area = .TRUE.462 IF( nictls < 1 .OR. nictls > jpiglo ) THEN463 CALL ctl_warn( ' - nictls must be 1<=nictls>=jpiglo, it is forced to 1' )464 nictls = 1465 ENDIF466 IF( nictle < 1 .OR. nictle > jpiglo ) THEN467 CALL ctl_warn( ' - nictle must be 1<=nictle>=jpiglo, it is forced to jpiglo' )468 nictle = jpiglo469 ENDIF470 IF( njctls < 1 .OR. njctls > jpjglo ) THEN471 CALL ctl_warn( ' - njctls must be 1<=njctls>=jpjglo, it is forced to 1' )472 njctls = 1473 ENDIF474 IF( njctle < 1 .OR. njctle > jpjglo ) THEN475 CALL ctl_warn( ' - njctle must be 1<=njctle>=jpjglo, it is forced to jpjglo' )476 njctle = jpjglo477 ENDIF478 ENDIF479 ENDIF480 429 ! 481 430 IF( 1._wp /= SIGN(1._wp,-0._wp) ) CALL ctl_stop( 'nemo_ctl: The intrinsec SIGN function follows f2003 standard.', & -
NEMO/trunk/src/SAS/sbcssm.F90
r12615 r13286 290 290 ! ! fill sf with slf_i and control print 291 291 CALL fld_fill( sf_ssm_3d, slf_3d, cn_dir, 'sbc_ssm_init', '3D Data in file', 'namsbc_ssm' ) 292 sf_ssm_3d(jf_usp)%cltype = 'U' ; sf_ssm_3d(jf_usp)%zsgn = -1._wp 293 sf_ssm_3d(jf_vsp)%cltype = 'V' ; sf_ssm_3d(jf_vsp)%zsgn = -1._wp 292 294 ENDIF 293 295 ! … … 306 308 ! 307 309 CALL fld_fill( sf_ssm_2d, slf_2d, cn_dir, 'sbc_ssm_init', '2D Data in file', 'namsbc_ssm' ) 310 IF( .NOT. ln_3d_uve ) THEN 311 sf_ssm_2d(jf_usp)%cltype = 'U' ; sf_ssm_2d(jf_usp)%zsgn = -1._wp 312 sf_ssm_2d(jf_vsp)%cltype = 'V' ; sf_ssm_2d(jf_vsp)%zsgn = -1._wp 313 ENDIF 308 314 ENDIF 309 315 ! -
NEMO/trunk/src/TOP/C14/trcini_c14.F90
r12377 r13286 69 69 ! 70 70 CALL iom_get( numrtr, 'co2sbc', co2sbc ) 71 CALL iom_get( numrtr, jpdom_auto glo, 'c14sbc', c14sbc )72 CALL iom_get( numrtr, jpdom_auto glo, 'exch_co2', exch_co2 )73 CALL iom_get( numrtr, jpdom_auto glo, 'exch_c14', exch_c14 )74 CALL iom_get( numrtr, jpdom_auto glo, 'qtr_c14', qtr_c14 )71 CALL iom_get( numrtr, jpdom_auto, 'c14sbc', c14sbc ) 72 CALL iom_get( numrtr, jpdom_auto, 'exch_co2', exch_co2 ) 73 CALL iom_get( numrtr, jpdom_auto, 'exch_c14', exch_c14 ) 74 CALL iom_get( numrtr, jpdom_auto, 'qtr_c14', qtr_c14 ) 75 75 ! 76 76 END IF … … 85 85 ELSE 86 86 ! 87 CALL iom_get( numrtr, jpdom_auto glo, 'qint_c14', qint_c14 )87 CALL iom_get( numrtr, jpdom_auto, 'qint_c14', qint_c14 ) 88 88 ! 89 89 ENDIF -
NEMO/trunk/src/TOP/CFC/trcsms_cfc.F90
r13237 r13286 298 298 DO jn = jp_cfc0, jp_cfc1 299 299 jl = jl + 1 300 CALL iom_get( numrtr, jpdom_auto glo, 'qint_'//ctrcnm(jn), qint_cfc(:,:,jl) )300 CALL iom_get( numrtr, jpdom_auto, 'qint_'//ctrcnm(jn), qint_cfc(:,:,jl) ) 301 301 END DO 302 302 ENDIF -
NEMO/trunk/src/TOP/PISCES/P2Z/p2zbio.F90
r13237 r13286 19 19 ! 20 20 USE lbclnk ! 21 USE prtctl _trc! Print control for debbuging21 USE prtctl ! Print control for debbuging 22 22 USE iom ! 23 23 … … 367 367 IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging) 368 368 WRITE(charout, FMT="('bio')") 369 CALL prt_ctl_ trc_info(charout)370 CALL prt_ctl _trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)369 CALL prt_ctl_info( charout, cdcomp = 'top' ) 370 CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm) 371 371 ENDIF 372 372 ! -
NEMO/trunk/src/TOP/PISCES/P2Z/p2zexp.F90
r13237 r13286 17 17 USE p2zsed 18 18 USE lbclnk 19 USE prtctl _trc! Print control for debbuging19 USE prtctl ! Print control for debbuging 20 20 USE trd_oce 21 21 USE trdtrc … … 140 140 IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging) 141 141 WRITE(charout, FMT="('exp')") 142 CALL prt_ctl_ trc_info(charout)143 CALL prt_ctl _trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)142 CALL prt_ctl_info( charout, cdcomp = 'top' ) 143 CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm) 144 144 ENDIF 145 145 ! … … 214 214 ! 215 215 IF( ln_rsttr ) THEN 216 CALL iom_get( numrtr, jpdom_auto glo, 'SEDB'//ctrcnm(jpdet), sedpocb(:,:) )217 CALL iom_get( numrtr, jpdom_auto glo, 'SEDN'//ctrcnm(jpdet), sedpocn(:,:) )216 CALL iom_get( numrtr, jpdom_auto, 'SEDB'//ctrcnm(jpdet), sedpocb(:,:) ) 217 CALL iom_get( numrtr, jpdom_auto, 'SEDN'//ctrcnm(jpdet), sedpocn(:,:) ) 218 218 ELSE 219 219 sedpocb(:,:) = 0._wp -
NEMO/trunk/src/TOP/PISCES/P2Z/p2zopt.F90
r13237 r13286 18 18 USE trc 19 19 USE sms_pisces 20 USE prtctl _trc! Print control for debbuging20 USE prtctl ! Print control for debbuging 21 21 22 22 IMPLICIT NONE … … 125 125 IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging) 126 126 WRITE(charout, FMT="('opt')") 127 CALL prt_ctl_ trc_info( charout)128 CALL prt_ctl _trc( tab4d=tr(:,:,:,:,Kmm), mask=tmask, clinfo=ctrcnm )127 CALL prt_ctl_info( charout, cdcomp = 'top' ) 128 CALL prt_ctl( tab4d_1=tr(:,:,:,:,Kmm), mask1=tmask, clinfo=ctrcnm ) 129 129 ENDIF 130 130 ! -
NEMO/trunk/src/TOP/PISCES/P2Z/p2zsed.F90
r13237 r13286 18 18 USE lbclnk ! 19 19 USE iom ! 20 USE prtctl _trc! Print control for debbuging20 USE prtctl ! Print control for debbuging 21 21 22 22 IMPLICIT NONE … … 109 109 IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging) 110 110 WRITE(charout, FMT="('sed')") 111 CALL prt_ctl_ trc_info(charout)112 CALL prt_ctl _trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)111 CALL prt_ctl_info( charout, cdcomp = 'top' ) 112 CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm) 113 113 ENDIF 114 114 ! -
NEMO/trunk/src/TOP/PISCES/P4Z/p4zagg.F90
r12377 r13286 17 17 USE trc ! passive tracers common variables 18 18 USE sms_pisces ! PISCES Source Minus Sink variables 19 USE prtctl _trc! print control for debugging19 USE prtctl ! print control for debugging 20 20 21 21 IMPLICIT NONE … … 170 170 IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging) 171 171 WRITE(charout, FMT="('agg')") 172 CALL prt_ctl_ trc_info(charout)173 CALL prt_ctl _trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)172 CALL prt_ctl_info( charout, cdcomp = 'top' ) 173 CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm) 174 174 ENDIF 175 175 ! -
NEMO/trunk/src/TOP/PISCES/P4Z/p4zbc.F90
r13237 r13286 288 288 CALL iom_open ( TRIM( sn_ironsed%clname ), numiron ) 289 289 ALLOCATE( zcmask(jpi,jpj,jpk) ) 290 CALL iom_get ( numiron, jpdom_ data, TRIM( sn_ironsed%clvar ), zcmask(:,:,:), 1 )290 CALL iom_get ( numiron, jpdom_global, TRIM( sn_ironsed%clvar ), zcmask(:,:,:), 1 ) 291 291 CALL iom_close( numiron ) 292 292 ! -
NEMO/trunk/src/TOP/PISCES/P4Z/p4zbio.F90
r13237 r13286 30 30 USE p4zfechem 31 31 USE p4zligand ! Prognostic ligand model 32 USE prtctl _trc! print control for debugging32 USE prtctl ! print control for debugging 33 33 USE iom ! I/O manager 34 34 … … 108 108 IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging) 109 109 WRITE(charout, FMT="('bio ')") 110 CALL prt_ctl_ trc_info(charout)111 CALL prt_ctl _trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)110 CALL prt_ctl_info( charout, cdcomp = 'top' ) 111 CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm) 112 112 ENDIF 113 113 ! -
NEMO/trunk/src/TOP/PISCES/P4Z/p4zfechem.F90
r13237 r13286 16 16 USE p4zche ! chemical model 17 17 USE p4zbc ! Boundary conditions from sediments 18 USE prtctl _trc! print control for debugging18 USE prtctl ! print control for debugging 19 19 USE iom ! I/O manager 20 20 … … 222 222 IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging) 223 223 WRITE(charout, FMT="('fechem')") 224 CALL prt_ctl_ trc_info(charout)225 CALL prt_ctl _trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)224 CALL prt_ctl_info( charout, cdcomp = 'top' ) 225 CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm) 226 226 ENDIF 227 227 ! -
NEMO/trunk/src/TOP/PISCES/P4Z/p4zflx.F90
r13237 r13286 19 19 USE sms_pisces ! PISCES Source Minus Sink variables 20 20 USE p4zche ! Chemical model 21 USE prtctl _trc! print control for debugging21 USE prtctl ! print control for debugging 22 22 USE iom ! I/O manager 23 23 USE fldread ! read input fields … … 178 178 IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging) 179 179 WRITE(charout, FMT="('flx ')") 180 CALL prt_ctl_ trc_info(charout)181 CALL prt_ctl _trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)180 CALL prt_ctl_info( charout, cdcomp = 'top' ) 181 CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm) 182 182 ENDIF 183 183 -
NEMO/trunk/src/TOP/PISCES/P4Z/p4zligand.F90
r12377 r13286 12 12 USE trc ! passive tracers common variables 13 13 USE sms_pisces ! PISCES Source Minus Sink variables 14 USE prtctl _trc! print control for debugging14 USE prtctl ! print control for debugging 15 15 USE iom ! I/O manager 16 16 … … 89 89 IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging) 90 90 WRITE(charout, FMT="('ligand1')") 91 CALL prt_ctl_ trc_info(charout)92 CALL prt_ctl _trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)91 CALL prt_ctl_info( charout, cdcomp = 'top' ) 92 CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm) 93 93 ENDIF 94 94 ! -
NEMO/trunk/src/TOP/PISCES/P4Z/p4zlys.F90
r12377 r13286 20 20 USE sms_pisces ! PISCES Source Minus Sink variables 21 21 USE p4zche ! Chemical model 22 USE prtctl _trc! print control for debugging22 USE prtctl ! print control for debugging 23 23 USE iom ! I/O manager 24 24 … … 130 130 IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging) 131 131 WRITE(charout, FMT="('lys ')") 132 CALL prt_ctl_ trc_info(charout)133 CALL prt_ctl _trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)132 CALL prt_ctl_info( charout, cdcomp = 'top' ) 133 CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm) 134 134 ENDIF 135 135 ! -
NEMO/trunk/src/TOP/PISCES/P4Z/p4zmeso.F90
r12839 r13286 15 15 USE sms_pisces ! PISCES Source Minus Sink variables 16 16 USE p4zprod ! production 17 USE prtctl _trc! print control for debugging17 USE prtctl ! print control for debugging 18 18 USE iom ! I/O manager 19 19 … … 246 246 IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging) 247 247 WRITE(charout, FMT="('meso')") 248 CALL prt_ctl_ trc_info(charout)249 CALL prt_ctl _trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)248 CALL prt_ctl_info( charout, cdcomp = 'top' ) 249 CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm) 250 250 ENDIF 251 251 ! -
NEMO/trunk/src/TOP/PISCES/P4Z/p4zmicro.F90
r12839 r13286 17 17 USE p4zprod ! production 18 18 USE iom ! I/O manager 19 USE prtctl _trc! print control for debugging19 USE prtctl ! print control for debugging 20 20 21 21 IMPLICIT NONE … … 202 202 IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging) 203 203 WRITE(charout, FMT="('micro')") 204 CALL prt_ctl_ trc_info(charout)205 CALL prt_ctl _trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)204 CALL prt_ctl_info( charout, cdcomp = 'top' ) 205 CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm) 206 206 ENDIF 207 207 ! -
NEMO/trunk/src/TOP/PISCES/P4Z/p4zmort.F90
r12377 r13286 15 15 USE p4zprod ! Primary productivity 16 16 USE p4zlim ! Phytoplankton limitation terms 17 USE prtctl _trc! print control for debugging17 USE prtctl ! print control for debugging 18 18 19 19 IMPLICIT NONE … … 120 120 IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging) 121 121 WRITE(charout, FMT="('nano')") 122 CALL prt_ctl_ trc_info(charout)123 CALL prt_ctl _trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)122 CALL prt_ctl_info( charout, cdcomp = 'top' ) 123 CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm) 124 124 ENDIF 125 125 ! … … 192 192 IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging) 193 193 WRITE(charout, FMT="('diat')") 194 CALL prt_ctl_ trc_info(charout)195 CALL prt_ctl _trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)194 CALL prt_ctl_info( charout, cdcomp = 'top' ) 195 CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm) 196 196 ENDIF 197 197 ! -
NEMO/trunk/src/TOP/PISCES/P4Z/p4zopt.F90
r13237 r13286 16 16 USE iom ! I/O manager 17 17 USE fldread ! time interpolation 18 USE prtctl _trc! print control for debugging18 USE prtctl ! print control for debugging 19 19 20 20 IMPLICIT NONE -
NEMO/trunk/src/TOP/PISCES/P4Z/p4zpoc.F90
r13237 r13286 15 15 USE trc ! passive tracers common variables 16 16 USE sms_pisces ! PISCES Source Minus Sink variables 17 USE prtctl _trc! print control for debugging17 USE prtctl ! print control for debugging 18 18 USE iom ! I/O manager 19 19 … … 242 242 IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging) 243 243 WRITE(charout, FMT="('poc1')") 244 CALL prt_ctl_ trc_info(charout)245 CALL prt_ctl _trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)244 CALL prt_ctl_info( charout, cdcomp = 'top' ) 245 CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm) 246 246 ENDIF 247 247 … … 434 434 IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging) 435 435 WRITE(charout, FMT="('poc2')") 436 CALL prt_ctl_ trc_info(charout)437 CALL prt_ctl _trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)436 CALL prt_ctl_info( charout, cdcomp = 'top' ) 437 CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm) 438 438 ENDIF 439 439 ! -
NEMO/trunk/src/TOP/PISCES/P4Z/p4zprod.F90
r13237 r13286 16 16 USE sms_pisces ! PISCES Source Minus Sink variables 17 17 USE p4zlim ! Co-limitations of differents nutrients 18 USE prtctl _trc! print control for debugging18 USE prtctl ! print control for debugging 19 19 USE iom ! I/O manager 20 20 … … 331 331 IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging) 332 332 WRITE(charout, FMT="('prod')") 333 CALL prt_ctl_ trc_info(charout)334 CALL prt_ctl _trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)333 CALL prt_ctl_info( charout, cdcomp = 'top' ) 334 CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm) 335 335 ENDIF 336 336 ! -
NEMO/trunk/src/TOP/PISCES/P4Z/p4zrem.F90
r13237 r13286 18 18 USE p4zprod ! Growth rate of the 2 phyto groups 19 19 USE p4zlim 20 USE prtctl _trc! print control for debugging20 USE prtctl ! print control for debugging 21 21 USE iom ! I/O manager 22 22 … … 196 196 IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging) 197 197 WRITE(charout, FMT="('rem1')") 198 CALL prt_ctl_ trc_info(charout)199 CALL prt_ctl _trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)198 CALL prt_ctl_info( charout, cdcomp = 'top' ) 199 CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm) 200 200 ENDIF 201 201 … … 218 218 IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging) 219 219 WRITE(charout, FMT="('rem2')") 220 CALL prt_ctl_ trc_info(charout)221 CALL prt_ctl _trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)220 CALL prt_ctl_info( charout, cdcomp = 'top' ) 221 CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm) 222 222 ENDIF 223 223 … … 249 249 IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging) 250 250 WRITE(charout, FMT="('rem3')") 251 CALL prt_ctl_ trc_info(charout)252 CALL prt_ctl _trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)251 CALL prt_ctl_info( charout, cdcomp = 'top' ) 252 CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm) 253 253 ENDIF 254 254 -
NEMO/trunk/src/TOP/PISCES/P4Z/p4zsed.F90
r13237 r13286 18 18 USE sed ! Sediment module 19 19 USE iom ! I/O manager 20 USE prtctl _trc! print control for debugging20 USE prtctl ! print control for debugging 21 21 22 22 IMPLICIT NONE … … 315 315 IF(sn_cfctl%l_prttrc) THEN ! print mean trends (USEd for debugging) 316 316 WRITE(charout, fmt="('sed ')") 317 CALL prt_ctl_ trc_info(charout)318 CALL prt_ctl _trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)317 CALL prt_ctl_info( charout, cdcomp = 'top' ) 318 CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm) 319 319 ENDIF 320 320 ! -
NEMO/trunk/src/TOP/PISCES/P4Z/p4zsink.F90
r13237 r13286 17 17 USE sms_pisces ! PISCES Source Minus Sink variables 18 18 USE trcsink ! General routine to compute sedimentation 19 USE prtctl _trc! print control for debugging19 USE prtctl ! print control for debugging 20 20 USE iom ! I/O manager 21 21 USE lib_mpp … … 144 144 IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging) 145 145 WRITE(charout, FMT="('sink')") 146 CALL prt_ctl_ trc_info(charout)147 CALL prt_ctl _trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)146 CALL prt_ctl_info( charout, cdcomp = 'top' ) 147 CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm) 148 148 ENDIF 149 149 ! -
NEMO/trunk/src/TOP/PISCES/P4Z/p4zsms.F90
r13237 r13286 25 25 USE trdtrc ! TOP trends variables 26 26 USE sedmodel ! Sediment model 27 USE prtctl _trc! print control for debugging27 USE prtctl ! print control for debugging 28 28 29 29 IMPLICIT NONE … … 341 341 ! 342 342 IF( iom_varid( numrtr, 'PH', ldstop = .FALSE. ) > 0 ) THEN 343 CALL iom_get( numrtr, jpdom_auto glo, 'PH' , hi(:,:,:) )343 CALL iom_get( numrtr, jpdom_auto, 'PH' , hi(:,:,:) ) 344 344 ELSE 345 345 CALL p4z_che( Kbb, Kmm ) ! initialize the chemical constants 346 346 CALL ahini_for_at( hi, Kbb ) 347 347 ENDIF 348 CALL iom_get( numrtr, jpdom_auto glo, 'Silicalim', xksi(:,:) )348 CALL iom_get( numrtr, jpdom_auto, 'Silicalim', xksi(:,:) ) 349 349 IF( iom_varid( numrtr, 'Silicamax', ldstop = .FALSE. ) > 0 ) THEN 350 CALL iom_get( numrtr, jpdom_auto glo, 'Silicamax' , xksimax(:,:) )350 CALL iom_get( numrtr, jpdom_auto, 'Silicamax' , xksimax(:,:) ) 351 351 ELSE 352 352 xksimax(:,:) = xksi(:,:) … … 361 361 IF( ln_p5z ) THEN 362 362 IF( iom_varid( numrtr, 'sized', ldstop = .FALSE. ) > 0 ) THEN 363 CALL iom_get( numrtr, jpdom_auto glo, 'sizep' , sizep(:,:,:) )364 CALL iom_get( numrtr, jpdom_auto glo, 'sizen' , sizen(:,:,:) )365 CALL iom_get( numrtr, jpdom_auto glo, 'sized' , sized(:,:,:) )363 CALL iom_get( numrtr, jpdom_auto, 'sizep' , sizep(:,:,:) ) 364 CALL iom_get( numrtr, jpdom_auto, 'sizen' , sizen(:,:,:) ) 365 CALL iom_get( numrtr, jpdom_auto, 'sized' , sized(:,:,:) ) 366 366 ELSE 367 367 sizep(:,:,:) = 1. -
NEMO/trunk/src/TOP/PISCES/P4Z/p5zmeso.F90
r12377 r13286 15 15 USE trc ! passive tracers common variables 16 16 USE sms_pisces ! PISCES Source Minus Sink variables 17 USE prtctl _trc! print control for debugging17 USE prtctl ! print control for debugging 18 18 USE iom ! I/O manager 19 19 … … 359 359 IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging) 360 360 WRITE(charout, FMT="('meso')") 361 CALL prt_ctl_ trc_info(charout)362 CALL prt_ctl _trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)361 CALL prt_ctl_info( charout, cdcomp = 'top' ) 362 CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm) 363 363 ENDIF 364 364 ! -
NEMO/trunk/src/TOP/PISCES/P4Z/p5zmicro.F90
r12377 r13286 18 18 USE p5zlim ! Phytoplankton limitation terms 19 19 USE iom ! I/O manager 20 USE prtctl _trc! print control for debugging20 USE prtctl ! print control for debugging 21 21 22 22 IMPLICIT NONE … … 306 306 IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging) 307 307 WRITE(charout, FMT="('micro')") 308 CALL prt_ctl_ trc_info(charout)309 CALL prt_ctl _trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)308 CALL prt_ctl_info( charout, cdcomp = 'top' ) 309 CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm) 310 310 ENDIF 311 311 ! -
NEMO/trunk/src/TOP/PISCES/P4Z/p5zmort.F90
r12377 r13286 16 16 USE p4zlim 17 17 USE p5zlim ! Phytoplankton limitation terms 18 USE prtctl _trc! print control for debugging18 USE prtctl ! print control for debugging 19 19 20 20 IMPLICIT NONE … … 121 121 IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging) 122 122 WRITE(charout, FMT="('nano')") 123 CALL prt_ctl_ trc_info(charout)124 CALL prt_ctl _trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)123 CALL prt_ctl_info( charout, cdcomp = 'top' ) 124 CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm) 125 125 ENDIF 126 126 ! … … 179 179 IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging) 180 180 WRITE(charout, FMT="('pico')") 181 CALL prt_ctl_ trc_info(charout)182 CALL prt_ctl _trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)181 CALL prt_ctl_info( charout, cdcomp = 'top' ) 182 CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm) 183 183 ENDIF 184 184 ! … … 254 254 IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging) 255 255 WRITE(charout, FMT="('diat')") 256 CALL prt_ctl_ trc_info(charout)257 CALL prt_ctl _trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)256 CALL prt_ctl_info( charout, cdcomp = 'top' ) 257 CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm) 258 258 ENDIF 259 259 ! -
NEMO/trunk/src/TOP/PISCES/P4Z/p5zprod.F90
r13237 r13286 18 18 USE p4zlim 19 19 USE p5zlim ! Co-limitations of differents nutrients 20 USE prtctl _trc! print control for debugging20 USE prtctl ! print control for debugging 21 21 USE iom ! I/O manager 22 22 … … 461 461 IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging) 462 462 WRITE(charout, FMT="('prod')") 463 CALL prt_ctl_ trc_info(charout)464 CALL prt_ctl _trc(tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm)463 CALL prt_ctl_info( charout, cdcomp = 'top' ) 464 CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm) 465 465 ENDIF 466 466 ! -
NEMO/trunk/src/TOP/PISCES/SED/sedrst.F90
r12649 r13286 123 123 cltra = TRIM(sedtrcd(jn)) 124 124 IF( iom_varid( numrsr, TRIM(cltra) , ldstop = .FALSE. ) > 0 ) THEN 125 CALL iom_get( numrsr, jpdom_auto glo, TRIM(cltra), zdta(:,:,:,jn) )125 CALL iom_get( numrsr, jpdom_auto, TRIM(cltra), zdta(:,:,:,jn) ) 126 126 ELSE 127 127 zdta(:,:,:,jn) = 0.0 … … 142 142 cltra = TRIM(seddia3d(jn)) 143 143 IF( iom_varid( numrsr, TRIM(cltra) , ldstop = .FALSE. ) > 0 ) THEN 144 CALL iom_get( numrsr, jpdom_auto glo, TRIM(cltra), zdta1(:,:,:,jn) )144 CALL iom_get( numrsr, jpdom_auto, TRIM(cltra), zdta1(:,:,:,jn) ) 145 145 ELSE 146 146 zdta1(:,:,:,jn) = 0.0 … … 169 169 cltra = "dbioturb" 170 170 IF( iom_varid( numrsr, TRIM(cltra) , ldstop = .FALSE. ) > 0 ) THEN 171 CALL iom_get( numrsr, jpdom_auto glo, TRIM(cltra), zdta2(:,:,:) )171 CALL iom_get( numrsr, jpdom_auto, TRIM(cltra), zdta2(:,:,:) ) 172 172 ELSE 173 173 zdta2(:,:,:) = 0.0 … … 179 179 cltra = "irrig" 180 180 IF( iom_varid( numrsr, TRIM(cltra) , ldstop = .FALSE. ) > 0 ) THEN 181 CALL iom_get( numrsr, jpdom_auto glo, TRIM(cltra), zdta2(:,:,:) )181 CALL iom_get( numrsr, jpdom_auto, TRIM(cltra), zdta2(:,:,:) ) 182 182 ELSE 183 183 zdta2(:,:,:) = 0.0 … … 189 189 cltra = "sedligand" 190 190 IF( iom_varid( numrsr, TRIM(cltra) , ldstop = .FALSE. ) > 0 ) THEN 191 CALL iom_get( numrsr, jpdom_auto glo, TRIM(cltra), zdta2(:,:,:) )191 CALL iom_get( numrsr, jpdom_auto, TRIM(cltra), zdta2(:,:,:) ) 192 192 ELSE 193 193 zdta2(:,:,:) = 0.0 -
NEMO/trunk/src/TOP/PISCES/SED/trcdmp_sed.F90
r12377 r13286 21 21 USE trc ! ocean passive tracers variables 22 22 USE trcdta 23 USE prtctl _trc! Print control for debbuging23 USE prtctl ! Print control for debbuging 24 24 USE iom 25 25 … … 107 107 IF( sn_cfctl%l_prttrc ) THEN 108 108 WRITE(charout, FMT="('dmp ')") 109 CALL prt_ctl_ trc_info(charout)110 CALL prt_ctl _trc( tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm, clinfo2='trd' )109 CALL prt_ctl_info( charout, cdcomp = 'top' ) 110 CALL prt_ctl( tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm, clinfo3='trd' ) 111 111 ENDIF 112 112 ! -
NEMO/trunk/src/TOP/TRP/trcadv.F90
r13237 r13286 29 29 USE ldfslp ! Lateral diffusion: slopes of neutral surfaces 30 30 ! 31 USE prtctl _trc! control print31 USE prtctl ! control print 32 32 USE timing ! Timing 33 33 … … 138 138 IF( sn_cfctl%l_prttrc ) THEN !== print mean trends (used for debugging) 139 139 WRITE(charout, FMT="('adv ')") 140 CALL prt_ctl_ trc_info(charout)141 CALL prt_ctl _trc( tab4d=tr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm, clinfo2='trd' )140 CALL prt_ctl_info( charout, cdcomp = 'top' ) 141 CALL prt_ctl( tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm, clinfo3='trd' ) 142 142 END IF 143 143 ! -
NEMO/trunk/src/TOP/TRP/trcatf.F90
r13237 r13286 43 43 ! 44 44 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 45 USE prtctl _trc! Print control for debbuging45 USE prtctl ! Print control for debbuging 46 46 47 47 IMPLICIT NONE … … 184 184 IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging) 185 185 WRITE(charout, FMT="('nxt')") 186 CALL prt_ctl_ trc_info(charout)187 CALL prt_ctl _trc(tab4d=ptr(:,:,:,:,Kmm), mask=tmask, clinfo=ctrcnm)186 CALL prt_ctl_info( charout, cdcomp = 'top' ) 187 CALL prt_ctl(tab4d_1=ptr(:,:,:,:,Kmm), mask1=tmask, clinfo=ctrcnm) 188 188 ENDIF 189 189 ! -
NEMO/trunk/src/TOP/TRP/trcbbl.F90
r12377 r13286 25 25 USE trdtra ! tracer trends 26 26 USE trabbl ! bottom boundary layer 27 USE prtctl _trc! Print control for debbuging27 USE prtctl ! Print control for debbuging 28 28 29 29 PUBLIC trc_bbl ! routine called by trctrp.F90 … … 70 70 CALL tra_bbl_dif( ptr(:,:,:,:,Kbb), ptr(:,:,:,:,Krhs), jptra, Kmm ) 71 71 IF( sn_cfctl%l_prttrc ) THEN 72 WRITE(charout, FMT="(' bbl_dif')") ; CALL prt_ctl_ trc_info(charout)73 CALL prt_ctl _trc( tab4d=ptr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm, clinfo2='trd' )72 WRITE(charout, FMT="(' bbl_dif')") ; CALL prt_ctl_info( charout, cdcomp = 'top' ) 73 CALL prt_ctl( tab4d_1=ptr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm, clinfo3='trd' ) 74 74 ENDIF 75 75 ! … … 81 81 CALL tra_bbl_adv( ptr(:,:,:,:,Kbb), ptr(:,:,:,:,Krhs), jptra, Kmm ) 82 82 IF( sn_cfctl%l_prttrc ) THEN 83 WRITE(charout, FMT="(' bbl_adv')") ; CALL prt_ctl_ trc_info(charout)84 CALL prt_ctl _trc( tab4d=ptr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm, clinfo2='trd' )83 WRITE(charout, FMT="(' bbl_adv')") ; CALL prt_ctl_info( charout, cdcomp = 'top' ) 84 CALL prt_ctl( tab4d_1=ptr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm, clinfo3='trd' ) 85 85 ENDIF 86 86 ! -
NEMO/trunk/src/TOP/TRP/trcdmp.F90
r13237 r13286 24 24 ! 25 25 USE iom 26 USE prtctl _trc! Print control for debbuging26 USE prtctl ! Print control for debbuging 27 27 28 28 IMPLICIT NONE … … 149 149 IF( sn_cfctl%l_prttrc ) THEN 150 150 WRITE(charout, FMT="('dmp ')") 151 CALL prt_ctl_ trc_info(charout)152 CALL prt_ctl _trc( tab4d=ptr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm, clinfo2='trd' )151 CALL prt_ctl_info( charout, cdcomp = 'top' ) 152 CALL prt_ctl( tab4d_1=ptr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm, clinfo3='trd' ) 153 153 ENDIF 154 154 ! … … 205 205 !Read in mask from file 206 206 CALL iom_open ( cn_resto_tr, imask) 207 CALL iom_get ( imask, jpdom_auto glo, 'resto', restotr)207 CALL iom_get ( imask, jpdom_auto, 'resto', restotr) 208 208 CALL iom_close( imask ) 209 209 ! … … 246 246 ! ! ======================= 247 247 CASE ( 1 ) ! eORCA_R1 configuration 248 ! ! ======================= 249 isrow = 332 - jpjglo 250 ! 251 nctsi1(1) = 333 ; nctsj1(1) = 243 - isrow ! Caspian Sea 252 nctsi2(1) = 342 ; nctsj2(1) = 274 - isrow 253 ! 254 nctsi1(2) = 198 ; nctsj1(2) = 258 - isrow ! Lake Superior 255 nctsi2(2) = 204 ; nctsj2(2) = 262 - isrow 256 ! 257 nctsi1(3) = 201 ; nctsj1(3) = 250 - isrow ! Lake Michigan 258 nctsi2(3) = 203 ; nctsj2(3) = 256 - isrow 259 ! 260 nctsi1(4) = 204 ; nctsj1(4) = 252 - isrow ! Lake Huron 261 nctsi2(4) = 209 ; nctsj2(4) = 256 - isrow 262 ! 263 nctsi1(5) = 206 ; nctsj1(5) = 249 - isrow ! Lake Erie 264 nctsi2(5) = 209 ; nctsj2(5) = 251 - isrow 265 ! 266 nctsi1(6) = 210 ; nctsj1(6) = 252 - isrow ! Lake Ontario 267 nctsi2(6) = 212 ; nctsj2(6) = 252 - isrow 268 ! 269 nctsi1(7) = 321 ; nctsj1(7) = 180 - isrow ! Victoria Lake 270 nctsi2(7) = 322 ; nctsj2(7) = 189 - isrow 271 ! 272 nctsi1(8) = 297 ; nctsj1(8) = 270 - isrow ! Baltic Sea 273 nctsi2(8) = 308 ; nctsj2(8) = 293 - isrow 274 ! 275 ! ! ======================= 248 ! ! ======================= 249 ! 250 isrow = 332 - (Nj0glo + 1) ! was 332 - jpjglo -> jpjglo_old_version = Nj0glo + 1 251 ! 252 nctsi1(1) = 333 ; nctsj1(1) = 243 - isrow ! Caspian Sea 253 nctsi2(1) = 342 ; nctsj2(1) = 274 - isrow 254 ! 255 nctsi1(2) = 198 ; nctsj1(2) = 258 - isrow ! Lake Superior 256 nctsi2(2) = 204 ; nctsj2(2) = 262 - isrow 257 ! 258 nctsi1(3) = 201 ; nctsj1(3) = 250 - isrow ! Lake Michigan 259 nctsi2(3) = 203 ; nctsj2(3) = 256 - isrow 260 ! 261 nctsi1(4) = 204 ; nctsj1(4) = 252 - isrow ! Lake Huron 262 nctsi2(4) = 209 ; nctsj2(4) = 256 - isrow 263 ! 264 nctsi1(5) = 206 ; nctsj1(5) = 249 - isrow ! Lake Erie 265 nctsi2(5) = 209 ; nctsj2(5) = 251 - isrow 266 ! 267 nctsi1(6) = 210 ; nctsj1(6) = 252 - isrow ! Lake Ontario 268 nctsi2(6) = 212 ; nctsj2(6) = 252 - isrow 269 ! 270 nctsi1(7) = 321 ; nctsj1(7) = 180 - isrow ! Victoria Lake 271 nctsi2(7) = 322 ; nctsj2(7) = 189 - isrow 272 ! 273 nctsi1(8) = 297 ; nctsj1(8) = 270 - isrow ! Baltic Sea 274 nctsi2(8) = 308 ; nctsj2(8) = 293 - isrow 275 ! 276 ! ! ======================= 276 277 CASE ( 2 ) ! ORCA_R2 configuration 277 278 ! ! ======================= … … 286 287 nctsi2(3) = 181 ; nctsj2(3) = 112 287 288 ! 288 nctsi1(4) = 2 ; nctsj1(4) = 107 ! Black Sea 2 : est part of the Black Sea289 nctsi1(4) = 2 ; nctsj1(4) = 107 ! Black Sea 2 : est part of the Black Sea 289 290 nctsi2(4) = 6 ; nctsj2(4) = 112 290 291 ! 291 292 nctsi1(5) = 145 ; nctsj1(5) = 116 ! Baltic Sea 292 293 nctsi2(5) = 150 ; nctsj2(5) = 126 294 ! 293 295 ! ! ======================= 294 296 CASE ( 4 ) ! ORCA_R4 configuration … … 306 308 nctsi1(4) = 75 ; nctsj1(4) = 59 ! Baltic Sea 307 309 nctsi2(4) = 76 ; nctsj2(4) = 61 310 ! 308 311 ! ! ======================= 309 312 CASE ( 025 ) ! ORCA_R025 configuration … … 319 322 ! 320 323 ENDIF 324 ! 325 nctsi1(:) = nctsi1(:) + nn_hls - 1 ; nctsi2(:) = nctsi2(:) + nn_hls - 1 ! -1 as x-perio included in old input files 326 nctsj1(:) = nctsj1(:) + nn_hls ; nctsj2(:) = nctsj2(:) + nn_hls 321 327 ! 322 328 ! convert the position in local domain indices -
NEMO/trunk/src/TOP/TRP/trcldf.F90
r13237 r13286 25 25 USE trdtra ! trends manager: tracers 26 26 ! 27 USE prtctl _trc! Print control27 USE prtctl ! Print control 28 28 29 29 IMPLICIT NONE … … 115 115 IF( sn_cfctl%l_prttrc ) THEN ! print mean trends (used for debugging) 116 116 WRITE(charout, FMT="('ldf ')") 117 CALL prt_ctl_ trc_info(charout)118 CALL prt_ctl _trc( tab4d=ptr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm, clinfo2='trd' )117 CALL prt_ctl_info( charout, cdcomp = 'top' ) 118 CALL prt_ctl( tab4d_1=ptr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm, clinfo3='trd' ) 119 119 ENDIF 120 120 ! -
NEMO/trunk/src/TOP/TRP/trcrad.F90
r12489 r13286 19 19 USE trd_oce 20 20 USE trdtra 21 USE prtctl _trc! Print control for debbuging21 USE prtctl ! Print control for debbuging 22 22 USE lib_fortran 23 23 … … 72 72 IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging) 73 73 WRITE(charout, FMT="('rad')") 74 CALL prt_ctl_ trc_info( charout)75 CALL prt_ctl _trc( tab4d=ptr(:,:,:,:,Kbb), mask=tmask, clinfo=ctrcnm )74 CALL prt_ctl_info( charout, cdcomp = 'top' ) 75 CALL prt_ctl( tab4d_1=ptr(:,:,:,:,Kbb), mask1=tmask, clinfo=ctrcnm ) 76 76 ENDIF 77 77 ! -
NEMO/trunk/src/TOP/TRP/trcsbc.F90
r13237 r13286 18 18 USE oce_trc ! ocean dynamics and active tracers variables 19 19 USE trc ! ocean passive tracers variables 20 USE prtctl _trc! Print control for debbuging20 USE prtctl ! Print control for debbuging 21 21 USE iom 22 22 USE trd_oce … … 88 88 zfact = 0.5_wp 89 89 DO jn = 1, jptra 90 CALL iom_get( numrtr, jpdom_auto glo, 'sbc_'//TRIM(ctrcnm(jn))//'_b', sbc_trc_b(:,:,jn) ) ! before tracer content sbc90 CALL iom_get( numrtr, jpdom_auto, 'sbc_'//TRIM(ctrcnm(jn))//'_b', sbc_trc_b(:,:,jn) ) ! before tracer content sbc 91 91 END DO 92 92 ELSE ! No restart or restart not found: Euler forward time stepping … … 187 187 ! 188 188 IF( sn_cfctl%l_prttrc ) THEN 189 WRITE(charout, FMT="('sbc ')") ; CALL prt_ctl_ trc_info(charout)190 CALL prt_ctl _trc( tab4d=ptr(:,:,:,:,Krhs), mask=tmask, clinfo=ctrcnm, clinfo2='trd' )189 WRITE(charout, FMT="('sbc ')") ; CALL prt_ctl_info( charout, cdcomp = 'top' ) 190 CALL prt_ctl( tab4d_1=ptr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm, clinfo3='trd' ) 191 191 ENDIF 192 192 IF( l_trdtrc ) DEALLOCATE( ztrtrd ) -
NEMO/trunk/src/TOP/TRP/trczdf.F90
r12489 r13286 22 22 !!gm 23 23 USE trdtra ! trends manager: tracers 24 USE prtctl _trc! Print control24 USE prtctl ! Print control 25 25 26 26 IMPLICIT NONE … … 69 69 IF( sn_cfctl%l_prttrc ) THEN 70 70 WRITE(charout, FMT="('zdf ')") 71 CALL prt_ctl_ trc_info(charout)72 CALL prt_ctl _trc( tab4d=tr(:,:,:,:,Kaa), mask=tmask, clinfo=ctrcnm, clinfo2='trd' )71 CALL prt_ctl_info( charout, cdcomp = 'top' ) 72 CALL prt_ctl( tab4d_1=tr(:,:,:,:,Kaa), mask1=tmask, clinfo=ctrcnm, clinfo3='trd' ) 73 73 END IF 74 74 ! -
NEMO/trunk/src/TOP/TRP/trdmxl_trc_rst.F90
r12377 r13286 144 144 145 145 DO jn = 1, jptra 146 CALL iom_get( inum, jpdom_auto glo, 'tmlbb_trc_' //ctrcnm(jn), tmlbb_trc (:,:,jn) )147 CALL iom_get( inum, jpdom_auto glo, 'tmlbn_trc_' //ctrcnm(jn), tmlbn_trc (:,:,jn) )148 CALL iom_get( inum, jpdom_auto glo, 'tmlatfb_trc_'//ctrcnm(jn), tmlatfb_trc(:,:,jn) )149 CALL iom_get( inum, jpdom_auto glo, 'tmlradb_trc_'//ctrcnm(jn), tmlradb_trc(:,:,jn) )146 CALL iom_get( inum, jpdom_auto, 'tmlbb_trc_' //ctrcnm(jn), tmlbb_trc (:,:,jn) ) 147 CALL iom_get( inum, jpdom_auto, 'tmlbn_trc_' //ctrcnm(jn), tmlbn_trc (:,:,jn) ) 148 CALL iom_get( inum, jpdom_auto, 'tmlatfb_trc_'//ctrcnm(jn), tmlatfb_trc(:,:,jn) ) 149 CALL iom_get( inum, jpdom_auto, 'tmlradb_trc_'//ctrcnm(jn), tmlradb_trc(:,:,jn) ) 150 150 END DO 151 151 152 152 ELSE 153 CALL iom_get( inum, jpdom_auto glo, 'rmldbn_trc', rmldbn_trc ) ! needed for rmld_sum153 CALL iom_get( inum, jpdom_auto, 'rmldbn_trc', rmldbn_trc ) ! needed for rmld_sum 154 154 155 155 ! ! =========== 156 156 DO jn = 1, jptra ! tracer loop 157 157 ! ! =========== 158 CALL iom_get( inum, jpdom_auto glo, 'tmlatfb_trc_' //ctrcnm(jn), tmlatfb_trc(:,:,jn) )159 CALL iom_get( inum, jpdom_auto glo, 'tmlbb_trc_' //ctrcnm(jn), tmlbb_trc (:,:,jn) )160 CALL iom_get( inum, jpdom_auto glo, 'tmlradb_trc_' //ctrcnm(jn), tmlradb_trc(:,:,jn) )161 162 CALL iom_get( inum, jpdom_auto glo, 'tmlbn_trc_' //ctrcnm(jn), tmlbn_trc (:,:,jn) ) ! needed for tml_sum163 CALL iom_get( inum, jpdom_auto glo, 'tml_sumb_trc_'//ctrcnm(jn), tml_sumb_trc(:,:,jn) )158 CALL iom_get( inum, jpdom_auto, 'tmlatfb_trc_' //ctrcnm(jn), tmlatfb_trc(:,:,jn) ) 159 CALL iom_get( inum, jpdom_auto, 'tmlbb_trc_' //ctrcnm(jn), tmlbb_trc (:,:,jn) ) 160 CALL iom_get( inum, jpdom_auto, 'tmlradb_trc_' //ctrcnm(jn), tmlradb_trc(:,:,jn) ) 161 162 CALL iom_get( inum, jpdom_auto, 'tmlbn_trc_' //ctrcnm(jn), tmlbn_trc (:,:,jn) ) ! needed for tml_sum 163 CALL iom_get( inum, jpdom_auto, 'tml_sumb_trc_'//ctrcnm(jn), tml_sumb_trc(:,:,jn) ) 164 164 165 165 DO jk = 1, jpltrd_trc … … 169 169 WRITE(charout,FMT="('tmltrd_csum_ub_trc_', A3, '_', I2)") ctrcnm(jn), jk 170 170 ENDIF 171 CALL iom_get( inum, jpdom_auto glo, charout, tmltrd_csum_ub_trc(:,:,jk,jn) )171 CALL iom_get( inum, jpdom_auto, charout, tmltrd_csum_ub_trc(:,:,jk,jn) ) 172 172 END DO 173 173 174 CALL iom_get( inum, jpdom_auto glo, 'tmltrd_atf_sumb_trc_'//ctrcnm(jn) , &174 CALL iom_get( inum, jpdom_auto, 'tmltrd_atf_sumb_trc_'//ctrcnm(jn) , & 175 175 & tmltrd_atf_sumb_trc(:,:,jn) ) 176 176 177 CALL iom_get( inum, jpdom_auto glo, 'tmltrd_rad_sumb_trc_'//ctrcnm(jn) , &177 CALL iom_get( inum, jpdom_auto, 'tmltrd_rad_sumb_trc_'//ctrcnm(jn) , & 178 178 & tmltrd_rad_sumb_trc(:,:,jn) ) 179 179 ! ! =========== -
NEMO/trunk/src/TOP/oce_trc.F90
r12489 r13286 18 18 USE par_oce , ONLY : jp_tem => jp_tem !: indice for temperature 19 19 USE par_oce , ONLY : jp_sal => jp_sal !: indice for salinity 20 USE par_oce , ONLY : nn_hls => nn_hls !: 21 USE par_oce , ONLY : Nis0 => Nis0 !: 22 USE par_oce , ONLY : Njs0 => Njs0 !: 23 USE par_oce , ONLY : Nie0 => Nie0 !: 24 USE par_oce , ONLY : Nje0 => Nje0 !: 25 USE par_oce , ONLY : Nis1 => Nis1 !: 26 USE par_oce , ONLY : Njs1 => Njs1 !: 27 USE par_oce , ONLY : Nie1 => Nie1 !: 28 USE par_oce , ONLY : Nje1 => Nje1 !: 29 USE par_oce , ONLY : Nis1nxt2 => Nis1nxt2 !: 30 USE par_oce , ONLY : Njs1nxt2 => Njs1nxt2 !: 31 USE par_oce , ONLY : Nie1nxt2 => Nie1nxt2 !: 32 USE par_oce , ONLY : Nje1nxt2 => Nje1nxt2 !: 33 USE par_oce , ONLY : Nis2 => Nis2 !: 34 USE par_oce , ONLY : Njs2 => Njs2 !: 35 USE par_oce , ONLY : Nie2 => Nie2 !: 36 USE par_oce , ONLY : Nje2 => Nje2 !: 37 USE par_oce , ONLY : Ni_0 => Ni_0 !: 38 USE par_oce , ONLY : Nj_0 => Nj_0 !: 39 USE par_oce , ONLY : Ni_1 => Ni_1 !: 40 USE par_oce , ONLY : Nj_1 => Nj_1 !: 41 USE par_oce , ONLY : Ni_2 => Ni_2 !: 42 USE par_oce , ONLY : Nj_2 => Nj_2 !: 20 43 21 44 USE in_out_manager !* IO manager * -
NEMO/trunk/src/TOP/trcini.F90
r13237 r13286 20 20 USE trcnam ! Namelist read 21 21 USE daymod ! calendar manager 22 USE prtctl _trc ! Print control passive tracers (prt_ctl_trc_init routine)22 USE prtctl ! Print control passive tracers (prt_ctl_init routine) 23 23 USE trcrst 24 24 USE lib_mpp ! distribued memory computing library … … 94 94 INTEGER :: jk, jn ! dummy loop indices 95 95 CHARACTER (len=25) :: charout 96 REAL(wp), DIMENSION(jpi,jpj,jpk,jptra) :: zzmsk 97 CHARACTER (len=25), DIMENSION(jptra) :: clseb 96 98 !!---------------------------------------------------------------------- 97 99 ! … … 125 127 IF(lwp) WRITE(numout,*) 126 128 IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging) 127 CALL prt_ctl_ trc_init129 CALL prt_ctl_init( 'top', jptra ) 128 130 WRITE(charout, FMT="('ini ')") 129 CALL prt_ctl_trc_info( charout ) 130 CALL prt_ctl_trc( tab4d=tr(:,:,:,:,Kmm), mask=tmask, clinfo=ctrcnm ) 131 CALL prt_ctl_info( charout, cdcomp = 'top' ) 132 CALL prt_ctl( tab4d_1=tr(:,:,:,:,Kmm), mask1=tmask, clinfo=ctrcnm ) 133 DO jn = 1, jptra 134 zzmsk(:,:,:,jn) = tmask(:,:,:) 135 WRITE(clseb(jn),'(a,i2.2)') 'seb ', jn 136 END DO 137 CALL prt_ctl( tab4d_1=zzmsk, mask1=tmask, clinfo=clseb ) 131 138 ENDIF 132 139 9000 FORMAT(' tracer nb : ',i2,' name :',a10,' initial content :',e18.10) -
NEMO/trunk/src/TOP/trcrst.F90
r13237 r13286 114 114 ! READ prognostic variables and computes diagnostic variable 115 115 DO jn = 1, jptra 116 CALL iom_get( numrtr, jpdom_auto glo, 'TRN'//ctrcnm(jn), tr(:,:,:,jn,Kmm) )117 END DO 118 119 DO jn = 1, jptra 120 CALL iom_get( numrtr, jpdom_auto glo, 'TRB'//ctrcnm(jn), tr(:,:,:,jn,Kbb) )116 CALL iom_get( numrtr, jpdom_auto, 'TRN'//ctrcnm(jn), tr(:,:,:,jn,Kmm) ) 117 END DO 118 119 DO jn = 1, jptra 120 CALL iom_get( numrtr, jpdom_auto, 'TRB'//ctrcnm(jn), tr(:,:,:,jn,Kbb) ) 121 121 END DO 122 122 ! -
NEMO/trunk/src/TOP/trcsms.F90
r12377 r13286 20 20 USE trcsms_age ! AGE 21 21 USE trcsms_my_trc ! MY_TRC tracers 22 USE prtctl _trc! Print control for debbuging22 USE prtctl ! Print control for debbuging 23 23 24 24 IMPLICIT NONE … … 58 58 IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging) 59 59 WRITE(charout, FMT="('sms ')") 60 CALL prt_ctl_ trc_info( charout)61 CALL prt_ctl _trc( tab4d=tr(:,:,:,:,Kmm), mask=tmask, clinfo=ctrcnm )60 CALL prt_ctl_info( charout, cdcomp = 'top' ) 61 CALL prt_ctl( tab4d_1=tr(:,:,:,:,Kmm), mask1=tmask, clinfo=ctrcnm ) 62 62 ENDIF 63 63 ! -
NEMO/trunk/src/TOP/trcstp.F90
r13237 r13286 22 22 USE sms_pisces, ONLY : ln_check_mass 23 23 ! 24 USE prtctl _trc! Print control for debbuging24 USE prtctl ! Print control for debbuging 25 25 USE iom ! 26 26 USE in_out_manager ! … … 92 92 IF(sn_cfctl%l_prttrc) THEN 93 93 WRITE(charout,FMT="('kt =', I4,' d/m/y =',I2,I2,I4)") kt, nday, nmonth, nyear 94 CALL prt_ctl_ trc_info(charout)94 CALL prt_ctl_info( charout, cdcomp = 'top' ) 95 95 ENDIF 96 96 ! … … 200 200 rsecfst = INT( zkt ) * rn_Dt 201 201 IF(lwp) WRITE(numout,*) 'trc_qsr_mean: qsr_mean read in the restart file at time-step rsecfst =', rsecfst, ' s ' 202 CALL iom_get( numrtr, jpdom_auto glo, 'qsr_mean', qsr_mean ) ! A mean of qsr202 CALL iom_get( numrtr, jpdom_auto, 'qsr_mean', qsr_mean ) ! A mean of qsr 203 203 CALL iom_get( numrtr, 'nrdcy', zrec ) ! Number of record per days 204 204 IF( INT( zrec ) == nb_rec_per_day ) THEN … … 206 206 IF( jn <= 9 ) THEN 207 207 WRITE(cl1,'(i1)') jn 208 CALL iom_get( numrtr, jpdom_auto glo, 'qsr_arr_'//cl1, qsr_arr(:,:,jn) ) ! A mean of qsr208 CALL iom_get( numrtr, jpdom_auto, 'qsr_arr_'//cl1, qsr_arr(:,:,jn) ) ! A mean of qsr 209 209 ELSE 210 210 WRITE(cl2,'(i2.2)') jn 211 CALL iom_get( numrtr, jpdom_auto glo, 'qsr_arr_'//cl2, qsr_arr(:,:,jn) ) ! A mean of qsr211 CALL iom_get( numrtr, jpdom_auto, 'qsr_arr_'//cl2, qsr_arr(:,:,jn) ) ! A mean of qsr 212 212 ENDIF 213 213 END DO -
NEMO/trunk/tests/BENCH/EXPREF/namelist_cfg_orca025_like
r12530 r13286 15 15 &namusr_def ! User defined : BENCH configuration: Flat bottom, beta-plane 16 16 !----------------------------------------------------------------------- 17 nn_isize = 144 2! number of point in i-direction of global(local) domain if >0 (<0)18 nn_jsize = 120 7 !! 1050! number of point in j-direction of global(local) domain if >0 (<0)17 nn_isize = 1440 ! number of point in i-direction of global(local) domain if >0 (<0) 18 nn_jsize = 1206 !! 1049 ! number of point in j-direction of global(local) domain if >0 (<0) 19 19 nn_ksize = 75 ! total number of point in k-direction 20 20 nn_perio = 4 ! periodicity … … 30 30 &namctl ! Control prints (default: OFF) 31 31 !----------------------------------------------------------------------- 32 nn_print = 0 ! level of print (0 no extra print)33 32 ln_timing = .false. ! timing by routine write out in timing.output file 34 33 / -
NEMO/trunk/tests/BENCH/EXPREF/namelist_cfg_orca12_like
r12530 r13286 15 15 &namusr_def ! User defined : BENCH configuration: Flat bottom, beta-plane 16 16 !----------------------------------------------------------------------- 17 nn_isize = 432 2! number of point in i-direction of global(local) domain if >0 (<0)18 nn_jsize = 314 7! number of point in j-direction of global(local) domain if >0 (<0)17 nn_isize = 4320 ! number of point in i-direction of global(local) domain if >0 (<0) 18 nn_jsize = 3146 ! number of point in j-direction of global(local) domain if >0 (<0) 19 19 nn_ksize = 75 ! total number of point in k-direction 20 20 nn_perio = 4 ! periodicity … … 30 30 &namctl ! Control prints (default: OFF) 31 31 !----------------------------------------------------------------------- 32 nn_print = 0 ! level of print (0 no extra print)33 32 ln_timing = .false. ! timing by routine write out in timing.output file 34 33 / -
NEMO/trunk/tests/BENCH/EXPREF/namelist_cfg_orca1_like
r12530 r13286 15 15 &namusr_def ! User defined : BENCH configuration: Flat bottom, beta-plane 16 16 !----------------------------------------------------------------------- 17 nn_isize = 36 2! number of point in i-direction of global(local) domain if >0 (<0)18 nn_jsize = 33 2! number of point in j-direction of global(local) domain if >0 (<0)17 nn_isize = 360 ! number of point in i-direction of global(local) domain if >0 (<0) 18 nn_jsize = 331 ! number of point in j-direction of global(local) domain if >0 (<0) 19 19 nn_ksize = 75 ! total number of point in k-direction 20 20 nn_perio = 6 ! periodicity … … 30 30 &namctl ! Control prints (default: OFF) 31 31 !----------------------------------------------------------------------- 32 nn_print = 0 ! level of print (0 no extra print)33 32 ln_timing = .false. ! timing by routine write out in timing.output file 34 33 / -
NEMO/trunk/tests/BENCH/MY_SRC/usrdef_hgr.F90
r12740 r13286 61 61 REAL(wp), DIMENSION(:,:), INTENT(out) :: pe1e2u, pe1e2v ! u- & v-surfaces (if reduction in strait) [m2] 62 62 ! 63 INTEGER :: ji, jj ! dummy loop indices63 INTEGER :: ji, jj ! dummy loop indices 64 64 REAL(wp) :: zres, zf0 65 REAL(wp) :: zti, z ui, ztj, zvj! local scalars65 REAL(wp) :: zti, ztj ! local scalars 66 66 !!------------------------------------------------------------------------------- 67 67 ! … … 72 72 IF(lwp) WRITE(numout,*) ' given by rn_dx and rn_dy' 73 73 ! 74 !75 74 ! Position coordinates (in grid points) 76 75 ! ========== 77 76 DO_2D_11_11 78 77 79 zti = REAL( ji - 1 + nimpp - 1, wp ) ; ztj = REAL( jj - 1 + njmpp - 1, wp )80 z ui = REAL( ji - 1 + nimpp - 1, wp ) + 0.5_wp ; zvj = REAL( jj - 1 + njmpp - 1, wp ) + 0.5_wp78 zti = REAL( mig0_oldcmp(ji) - 1, wp ) ! start at i=0 in the global grid without halos 79 ztj = REAL( mjg0_oldcmp(jj) - 1, wp ) ! start at j=0 in the global grid without halos 81 80 82 81 plamt(ji,jj) = zti 83 plamu(ji,jj) = z ui82 plamu(ji,jj) = zti + 0.5_wp 84 83 plamv(ji,jj) = zti 85 plamf(ji,jj) = z ui84 plamf(ji,jj) = zti + 0.5_wp 86 85 87 86 pphit(ji,jj) = ztj 88 pphiv(ji,jj) = zvj89 87 pphiu(ji,jj) = ztj 90 pphif(ji,jj) = zvj 88 pphiv(ji,jj) = ztj + 0.5_wp 89 pphif(ji,jj) = ztj + 0.5_wp 91 90 92 91 END_2D … … 109 108 kff = 1 ! indicate not to compute Coriolis parameter afterward 110 109 ! 111 zf0 110 zf0 = 2._wp * omega * SIN( rad * 45 ) ! constant coriolis factor corresponding to 45°N 112 111 pff_f(:,:) = zf0 113 112 pff_t(:,:) = zf0 -
NEMO/trunk/tests/BENCH/MY_SRC/usrdef_istate.F90
r12794 r13286 57 57 REAL(wp) :: zfact 58 58 INTEGER :: ji, jj, jk 59 INTEGER :: igloi, igloj ! to be removed in the future, see comment bellow 59 60 !!---------------------------------------------------------------------- 60 61 ! … … 63 64 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~ ' 64 65 ! 65 ! define unique value on each point. z2d ranging from 0.05 to -0.05 66 DO_2D_11_11 67 z2d(ji,jj) = 0.1 * ( 0.5 - REAL( mig(ji) + (mjg(jj)-1) * jpiglo, wp ) / REAL( jpiglo * jpjglo, wp ) ) 66 ! define unique value on each point of the inner global domain. z2d ranging from 0.05 to -0.05 67 ! 68 ! WARNING: to keep compatibility with the trunk that was including periodocity into the input data, 69 ! we must define z2d as bellow. 70 ! Once we decide to forget trunk compatibility, we must simply define z2d as: 71 !!$ DO_2D_00_00 72 !!$ z2d(ji,jj) = 0.1 * ( 0.5 - REAL( mig0_oldcmp(ji) + (mjg0_oldcmp(jj)-1) * Ni0glo, wp ) / REAL( Ni0glo * Nj0glo, wp ) ) 73 !!$ END_2D 74 igloi = Ni0glo + 2 * COUNT( (/ jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7 /) ) 75 igloj = Nj0glo + 2 * COUNT( (/ jperio == 2 .OR. jperio == 7 /) ) + 1 * COUNT( (/ jperio >= 4 .AND. jperio <= 6 /) ) 76 DO_2D_00_00 77 z2d(ji,jj) = 0.1 * ( 0.5 - REAL( mig0_oldcmp(ji) + (mjg0_oldcmp(jj)-1) * igloi, wp ) / REAL( igloi * igloj, wp ) ) 68 78 END_2D 69 79 ! … … 71 81 pssh(:,:) = z2d(:,:) ! +/- 0.05 m 72 82 ! 73 DO jk = 1, jpk83 DO_3D_00_00( 1, jpkm1 ) 74 84 zfact = REAL(jk-1,wp) / REAL(jpk-1,wp) ! 0 to 1 to add a basic stratification 75 85 ! temperature choosen to lead to ~50% ice at the beginning if rn_thres_sst = 0.5 … … 80 90 pu(:,:,jk) = z2d(:,:) * 0.1_wp * umask(:,:,jk) ! +/- 0.005 m/s 81 91 pv(:,:,jk) = z2d(:,:) * 0.01_wp * vmask(:,:,jk) ! +/- 0.0005 m/s 82 ENDDO 92 END_3D 93 pts(:,:,jpk,:) = 0._wp 94 pu( :,:,jpk ) = 0._wp 95 pv( :,:,jpk ) = 0._wp 83 96 ! 84 97 CALL lbc_lnk('usrdef_istate', pssh, 'T', 1. ) ! apply boundary conditions -
NEMO/trunk/tests/BENCH/MY_SRC/usrdef_nam.F90
r12563 r13286 58 58 !! 59 59 NAMELIST/namusr_def/ nn_isize, nn_jsize, nn_ksize, nn_perio 60 NAMELIST/nammpp/ jpni, jpnj, ln_nnogather, ln_listonly60 NAMELIST/nammpp/ jpni, jpnj, nn_hls, ln_nnogather, ln_listonly 61 61 !!---------------------------------------------------------------------- 62 62 ! … … 77 77 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nammpp in configuration namelist' ) 78 78 79 kpi = ( -nn_isize - 2*nn_hls ) * jpni + 2*nn_hls80 kpj = ( -nn_jsize - 2*nn_hls ) * jpnj + 2*nn_hls79 kpi = -nn_isize * jpni 80 kpj = -nn_jsize * jpnj 81 81 ELSE 82 82 kpi = nn_isize -
NEMO/trunk/tests/BENCH/MY_SRC/usrdef_sbc.F90
r12740 r13286 99 99 REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace 100 100 INTEGER :: ji, jj 101 INTEGER :: igloi, igloj ! to be removed in the future, see comment bellow 101 102 !!--------------------------------------------------------------------- 102 103 #if defined key_si3 … … 104 105 ! 105 106 ! define unique value on each point. z2d ranging from 0.05 to -0.05 106 DO_2D_11_11 107 z2d(ji,jj) = 0.1 * ( 0.5 - REAL( nimpp + ji - 1 + ( njmpp + jj - 2 ) * jpiglo, wp ) / REAL( jpiglo * jpjglo, wp ) ) 107 ! 108 ! WARNING: to keep compatibility with the trunk that was including periodocity into the input data, 109 ! we must define z2d as bellow. 110 ! Once we decide to forget trunk compatibility, we must simply define z2d as: 111 !!$ DO_2D_00_00 112 !!$ z2d(ji,jj) = 0.1 * ( 0.5 - REAL( mig0_oldcmp(ji) + (mjg0_oldcmp(jj)-1) * Ni0glo, wp ) / REAL( Ni0glo * Nj0glo, wp ) ) 113 !!$ END_2D 114 igloi = Ni0glo + 2 * COUNT( (/ jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7 /) ) 115 igloj = Nj0glo + 2 * COUNT( (/ jperio == 2 .OR. jperio == 7 /) ) + 1 * COUNT( (/ jperio >= 4 .AND. jperio <= 6 /) ) 116 DO_2D_00_00 117 z2d(ji,jj) = 0.1 * ( 0.5 - REAL( mig0_oldcmp(ji) + (mjg0_oldcmp(jj)-1) * igloi, wp ) / REAL( igloi * igloj, wp ) ) 108 118 END_2D 109 utau_ice(:,:) = 0.1_wp + 110 vtau_ice(:,:) = 0.1_wp + 119 utau_ice(:,:) = 0.1_wp + z2d(:,:) 120 vtau_ice(:,:) = 0.1_wp + z2d(:,:) 111 121 112 122 CALL lbc_lnk_multi( 'usrdef_sbc', utau_ice, 'U', -1., vtau_ice, 'V', -1. ) -
NEMO/trunk/tests/BENCH/MY_SRC/usrdef_zgr.F90
r12377 r13286 192 192 z2d(:,:) = REAL( jpkm1 , wp ) ! flat bottom 193 193 ! 194 IF( jperio == 3 .OR. jperio ==4 ) THEN ! add a small island in the upper corners to avoid model instabilities... 195 z2d(mi0( 1):mi1( 3),mj0(jpjglo-2):mj1(jpjglo)) = 0. 196 z2d(mi0(jpiglo-2):mi1(jpiglo),mj0(jpjglo-2):mj1(jpjglo)) = 0. 197 ENDIF 194 ! 195 ! BENCH should work without these 2 small islands on the 2 poles of the folding... 196 ! -> Comment out these lines if instabilities are too large... 197 ! 198 199 !!$ IF( jperio == 3 .OR. jperio == 4 ) THEN ! add a small island in the upper corners to avoid model instabilities... 200 !!$ z2d(mi0( nn_hls):mi1( nn_hls+2 ),mj0(jpjglo-nn_hls-1):mj1(jpjglo-nn_hls+1)) = 0. 201 !!$ z2d(mi0(jpiglo-nn_hls):mi1(MIN(jpiglo,jpiglo-nn_hls+2)),mj0(jpjglo-nn_hls-1):mj1(jpjglo-nn_hls+1)) = 0. 202 !!$ z2d(mi0(jpiglo/2 ):mi1( jpiglo/2 +2 ),mj0(jpjglo-nn_hls-1):mj1(jpjglo-nn_hls+1)) = 0. 203 !!$ ENDIF 204 !!$ ! 205 !!$ IF( jperio == 5 .OR. jperio == 6 ) THEN ! add a small island in the upper corners to avoid model instabilities... 206 !!$ z2d(mi0( nn_hls):mi1( nn_hls+1),mj0(jpjglo-nn_hls):mj1(jpjglo-nn_hls+1)) = 0. 207 !!$ z2d(mi0(jpiglo-nn_hls):mi1(jpiglo-nn_hls+1),mj0(jpjglo-nn_hls):mj1(jpjglo-nn_hls+1)) = 0. 208 !!$ z2d(mi0(jpiglo/2 ):mi1(jpiglo/2 +1),mj0(jpjglo-nn_hls):mj1(jpjglo-nn_hls+1)) = 0. 209 !!$ ENDIF 210 198 211 ! 199 212 CALL lbc_lnk( 'usrdef_zgr', z2d, 'T', 1. ) ! set surrounding land to zero (here jperio=0 ==>> closed) -
NEMO/trunk/tests/CANAL/MY_SRC/domvvl.F90
r12740 r13286 450 450 ELSE 451 451 ijk_max = MAXLOC( ze3t(:,:,:) ) 452 ijk_max(1) = ijk_max(1) + nimpp - 1453 ijk_max(2) = ijk_max(2) + njmpp - 1452 ijk_max(1) = mig0_oldcmp(ijk_max(1)) 453 ijk_max(2) = mjg0_oldcmp(ijk_max(2)) 454 454 ijk_min = MINLOC( ze3t(:,:,:) ) 455 ijk_min(1) = ijk_min(1) + nimpp - 1456 ijk_min(2) = ijk_min(2) + njmpp - 1455 ijk_min(1) = mig0_oldcmp(ijk_min(1)) 456 ijk_min(2) = mjg0_oldcmp(ijk_min(2)) 457 457 ENDIF 458 458 IF (lwp) THEN … … 793 793 IF( ln_rstart ) THEN !* Read the restart file 794 794 CALL rst_read_open ! open the restart file if necessary 795 CALL iom_get( numror, jpdom_auto glo, 'sshn' , ssh(:,:,Kmm), ldxios = lrxios )795 CALL iom_get( numror, jpdom_auto, 'sshn' , ssh(:,:,Kmm), ldxios = lrxios ) 796 796 ! 797 797 id1 = iom_varid( numror, 'e3t_b', ldstop = .FALSE. ) … … 806 806 ! 807 807 IF( MIN( id1, id2 ) > 0 ) THEN ! all required arrays exist 808 CALL iom_get( numror, jpdom_auto glo, 'e3t_b', e3t(:,:,:,Kbb), ldxios = lrxios )809 CALL iom_get( numror, jpdom_auto glo, 'e3t_n', e3t(:,:,:,Kmm), ldxios = lrxios )808 CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb), ldxios = lrxios ) 809 CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm), ldxios = lrxios ) 810 810 ! needed to restart if land processor not computed 811 811 IF(lwp) write(numout,*) 'dom_vvl_rst : e3t(:,:,:,Kbb) and e3t(:,:,:,Kmm) found in restart files' … … 821 821 IF(lwp) write(numout,*) 'e3t_n set equal to e3t_b.' 822 822 IF(lwp) write(numout,*) 'l_1st_euler is forced to true' 823 CALL iom_get( numror, jpdom_auto glo, 'e3t_b', e3t(:,:,:,Kbb), ldxios = lrxios )823 CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb), ldxios = lrxios ) 824 824 e3t(:,:,:,Kmm) = e3t(:,:,:,Kbb) 825 825 l_1st_euler = .true. … … 828 828 IF(lwp) write(numout,*) 'e3t_b set equal to e3t_n.' 829 829 IF(lwp) write(numout,*) 'l_1st_euler is forced to true' 830 CALL iom_get( numror, jpdom_auto glo, 'e3t_n', e3t(:,:,:,Kmm), ldxios = lrxios )830 CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm), ldxios = lrxios ) 831 831 e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 832 832 l_1st_euler = .true. … … 853 853 ! ! ----------------------- ! 854 854 IF( MIN( id3, id4 ) > 0 ) THEN ! all required arrays exist 855 CALL iom_get( numror, jpdom_auto glo, 'tilde_e3t_b', tilde_e3t_b(:,:,:), ldxios = lrxios )856 CALL iom_get( numror, jpdom_auto glo, 'tilde_e3t_n', tilde_e3t_n(:,:,:), ldxios = lrxios )855 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_b', tilde_e3t_b(:,:,:), ldxios = lrxios ) 856 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_n', tilde_e3t_n(:,:,:), ldxios = lrxios ) 857 857 ELSE ! one at least array is missing 858 858 tilde_e3t_b(:,:,:) = 0.0_wp … … 863 863 ! ! ------------ ! 864 864 IF( id5 > 0 ) THEN ! required array exists 865 CALL iom_get( numror, jpdom_auto glo, 'hdiv_lf', hdiv_lf(:,:,:), ldxios = lrxios )865 CALL iom_get( numror, jpdom_auto, 'hdiv_lf', hdiv_lf(:,:,:), ldxios = lrxios ) 866 866 ELSE ! array is missing 867 867 hdiv_lf(:,:,:) = 0.0_wp -
NEMO/trunk/tests/CANAL/MY_SRC/usrdef_hgr.F90
r12740 r13286 63 63 REAL(wp), DIMENSION(:,:), INTENT(out) :: pe1e2u, pe1e2v ! u- & v-surfaces (if reduction in strait) [m2] 64 64 ! 65 INTEGER :: ji, jj ! dummy loop indices65 INTEGER :: ji, jj ! dummy loop indices 66 66 REAL(wp) :: zphi0, zlam0, zbeta, zf0 67 REAL(wp) :: zti, z ui, ztj, zvj ! local scalars67 REAL(wp) :: zti, ztj ! local scalars 68 68 !!------------------------------------------------------------------------------- 69 69 ! … … 77 77 ! Position coordinates (in kilometers) 78 78 ! ========== 79 zlam0 = -REAL(NINT( jpiglo*rn_0xratio)-1, wp) * rn_dx80 zphi0 = -REAL(NINT( jpjglo*rn_0yratio)-1, wp) * rn_dy79 zlam0 = -REAL(NINT(Ni0glo*rn_0xratio)-1, wp) * rn_dx 80 zphi0 = -REAL(NINT(Nj0glo*rn_0yratio)-1, wp) * rn_dy 81 81 82 82 #if defined key_agrif … … 90 90 #endif 91 91 92 DO_2D_11_11 93 zti = FLOAT( ji - 1 + nimpp - 1 ) ; ztj = FLOAT( jj - 1 + njmpp - 1 )94 z ui = FLOAT( ji - 1 + nimpp - 1 ) + 0.5_wp ; zvj = FLOAT( jj - 1 + njmpp - 1 ) + 0.5_wp92 DO_2D_11_11 93 zti = REAL( mig0_oldcmp(ji) - 1, wp ) ! start at i=0 in the global grid without halos 94 ztj = REAL( mjg0_oldcmp(jj) - 1, wp ) ! start at j=0 in the global grid without halos 95 95 96 plamt(ji,jj) = zlam0 + rn_dx * zti97 plamu(ji,jj) = zlam0 + rn_dx * zui96 plamt(ji,jj) = zlam0 + rn_dx * zti 97 plamu(ji,jj) = zlam0 + rn_dx * ( zti + 0.5_wp ) 98 98 plamv(ji,jj) = plamt(ji,jj) 99 99 plamf(ji,jj) = plamu(ji,jj) 100 100 101 pphit(ji,jj) = zphi0 + rn_dy * ztj102 pphiv(ji,jj) = zphi0 + rn_dy * zvj101 pphit(ji,jj) = zphi0 + rn_dy * ztj 102 pphiv(ji,jj) = zphi0 + rn_dy * ( ztj + 0.5_wp ) 103 103 pphiu(ji,jj) = pphit(ji,jj) 104 104 pphif(ji,jj) = pphiv(ji,jj) -
NEMO/trunk/tests/CANAL/MY_SRC/usrdef_nam.F90
r12377 r13286 14 14 !! usr_def_hgr : initialize the horizontal mesh 15 15 !!---------------------------------------------------------------------- 16 USE dom_oce , ONLY: nimpp , njmpp ! i- & j-indices of the local domain16 USE dom_oce 17 17 USE par_oce ! ocean space and time domain 18 18 USE phycst ! physical constants … … 106 106 kk_cfg = INT( rn_dx ) 107 107 ! 108 ! Global Domain size: EW_CANAL global domain is 1800 km x 1800 Km x 5000 m 109 kpi = NINT( rn_domszx / rn_dx ) + 1 110 kpj = NINT( rn_domszy / rn_dy ) + 3 111 kpk = NINT( rn_domszz / rn_dz ) + 1 112 #if defined key_agrif 113 IF( .NOT. Agrif_Root() ) THEN 114 kpi = nbcellsx + 2 + 2*nbghostcells 115 kpj = nbcellsy + 2 + 2*nbghostcells 108 IF( Agrif_Root() ) THEN ! Global Domain size: EW_CANAL global domain is 1800 km x 1800 Km x 5000 m 109 kpi = NINT( rn_domszx / rn_dx ) + 1 110 kpj = NINT( rn_domszy / rn_dy ) + 3 111 ELSE ! Global Domain size: add nbghostcells + 1 "land" point on each side 112 kpi = nbcellsx + nbghostcells_x + nbghostcells_x + 2 113 kpj = nbcellsy + nbghostcells_y_s + nbghostcells_y_n + 2 116 114 ENDIF 117 #endif 115 kpk = MAX( 2, NINT( rn_domszz / rn_dz ) + 1 ) 118 116 ! 119 117 zh = (kpk-1)*rn_dz -
NEMO/trunk/tests/ICE_ADV1D/MY_SRC/usrdef_hgr.F90
r12740 r13286 64 64 REAL(wp), DIMENSION(:,:), INTENT(out) :: pe1e2u, pe1e2v ! u- & v-surfaces (if reduction in strait) [m2] 65 65 ! 66 INTEGER :: ji, jj ! dummy loop indices66 INTEGER :: ji, jj ! dummy loop indices 67 67 REAL(wp) :: zphi0, zlam0, zbeta, zf0 68 REAL(wp) :: zti, z ui, ztj, zvj ! local scalars68 REAL(wp) :: zti, ztj ! local scalars 69 69 !!------------------------------------------------------------------------------- 70 70 ! … … 75 75 76 76 ! ========== 77 zlam0 = - (jpiglo-1)/2* 1.e-3 * rn_dx78 zphi0 = - (jpjglo-1)/2* 1.e-3 * rn_dy77 zlam0 = -REAL( (Ni0glo-2)/2, wp) * 1.e-3 * rn_dx 78 zphi0 = -REAL( (Nj0glo-2)/2, wp) * 1.e-3 * rn_dy 79 79 80 80 DO_2D_11_11 81 zti = FLOAT( ji - 1 + nimpp - 1 ) ; ztj = FLOAT( jj - 1 + njmpp - 1 )82 z ui = FLOAT( ji - 1 + nimpp - 1 ) + 0.5_wp ; zvj = FLOAT( jj - 1 + njmpp - 1 ) + 0.5_wp81 zti = REAL( mig0_oldcmp(ji) - 1, wp ) ! start at i=0 in the global grid without halos 82 ztj = REAL( mjg0_oldcmp(jj) - 1, wp ) ! start at j=0 in the global grid without halos 83 83 84 plamt(ji,jj) = zlam0 + rn_dx * 1.e-3 * zti85 plamu(ji,jj) = zlam0 + rn_dx * 1.e-3 * zui84 plamt(ji,jj) = zlam0 + rn_dx * 1.e-3 * zti 85 plamu(ji,jj) = zlam0 + rn_dx * 1.e-3 * ( zti + 0.5_wp ) 86 86 plamv(ji,jj) = plamt(ji,jj) 87 87 plamf(ji,jj) = plamu(ji,jj) 88 88 89 pphit(ji,jj) = zphi0 + rn_dy * 1.e-3 * ztj90 pphiv(ji,jj) = zphi0 + rn_dy * 1.e-3 * zvj89 pphit(ji,jj) = zphi0 + rn_dy * 1.e-3 * ztj 90 pphiv(ji,jj) = zphi0 + rn_dy * 1.e-3 * ( ztj + 0.5_wp ) 91 91 pphiu(ji,jj) = pphit(ji,jj) 92 92 pphif(ji,jj) = pphiv(ji,jj) -
NEMO/trunk/tests/ICE_ADV1D/MY_SRC/usrdef_nam.F90
r12377 r13286 14 14 !! usr_def_hgr : initialize the horizontal mesh 15 15 !!---------------------------------------------------------------------- 16 USE dom_oce , ONLY: nimpp , njmpp ! i- & j-indices of the local domain17 16 USE par_oce ! ocean space and time domain 18 17 USE phycst ! physical constants … … 91 90 WRITE(numout,*) ' LX [km]: ', zlx 92 91 WRITE(numout,*) ' LY [km]: ', zly 93 WRITE(numout,*) ' resulting global domain size : jpiglo = ', kpi94 WRITE(numout,*) ' jpjglo = ', kpj92 WRITE(numout,*) ' resulting global domain size : Ni0glo = ', kpi 93 WRITE(numout,*) ' Nj0glo = ', kpj 95 94 WRITE(numout,*) ' jpkglo = ', kpk 96 95 WRITE(numout,*) ' Coriolis:', ln_corio -
NEMO/trunk/tests/ICE_ADV2D/MY_SRC/usrdef_hgr.F90
r12740 r13286 64 64 REAL(wp), DIMENSION(:,:), INTENT(out) :: pe1e2u, pe1e2v ! u- & v-surfaces (if reduction in strait) [m2] 65 65 ! 66 INTEGER :: ji, jj ! dummy loop indices66 INTEGER :: ji, jj ! dummy loop indices 67 67 REAL(wp) :: zphi0, zlam0, zbeta, zf0 68 REAL(wp) :: zti, z ui, ztj, zvj ! local scalars68 REAL(wp) :: zti, ztj ! local scalars 69 69 !!------------------------------------------------------------------------------- 70 70 ! … … 76 76 77 77 ! ========== 78 zlam0 = - (jpiglo-1)/2* 1.e-3 * rn_dx79 zphi0 = - (jpjglo-1)/2 * 1.e-3 * rn_dy78 zlam0 = -REAL( (Ni0glo-2)/2, wp) * 1.e-3 * rn_dx 79 zphi0 = -REAL( (Nj0glo-2)/2, wp) * 1.e-3 * rn_dy 80 80 81 81 #if defined key_agrif … … 83 83 !clem zlam0 = Agrif_Parent(zlam0) + (Agrif_ix())*Agrif_Parent(rn_dx) * 1.e-5 84 84 !clem zphi0 = Agrif_Parent(zphi0) + (Agrif_iy())*Agrif_Parent(rn_dy) * 1.e-5 85 zlam0 = ( 0.5_wp - ( Agrif_parent(jpiglo) - 1 ) / 2) * 1.e-3 * Agrif_irhox() * rn_dx &85 zlam0 = ( 0.5_wp - REAL( (Agrif_parent(Ni0glo) - 2 ) / 2, wp ) ) * 1.e-3 * Agrif_irhox() * rn_dx & 86 86 & + ( Agrif_Ix() + nbghostcells - 1 ) * Agrif_irhox() * rn_dx * 1.e-3 - ( 0.5_wp + nbghostcells ) * rn_dx * 1.e-3 87 zphi0 = ( 0.5_wp - ( Agrif_parent(jpjglo) - 1 ) / 2) * 1.e-3 * Agrif_irhoy() * rn_dy &87 zphi0 = ( 0.5_wp - REAL( (Agrif_parent(Nj0glo) - 2 ) / 2, wp ) ) * 1.e-3 * Agrif_irhoy() * rn_dy & 88 88 & + ( Agrif_Iy() + nbghostcells - 1 ) * Agrif_irhoy() * rn_dy * 1.e-3 - ( 0.5_wp + nbghostcells ) * rn_dy * 1.e-3 89 89 ENDIF … … 91 91 92 92 DO_2D_11_11 93 zti = FLOAT( ji - 1 + nimpp - 1 ) ; ztj = FLOAT( jj - 1 + njmpp - 1 )94 z ui = FLOAT( ji - 1 + nimpp - 1 ) + 0.5_wp ; zvj = FLOAT( jj - 1 + njmpp - 1 ) + 0.5_wp93 zti = REAL( mig0_oldcmp(ji) - 1, wp ) ! start at i=0 in the global grid without halos 94 ztj = REAL( mjg0_oldcmp(jj) - 1, wp ) ! start at j=0 in the global grid without halos 95 95 96 plamt(ji,jj) = zlam0 + rn_dx * 1.e-3 * zti97 plamu(ji,jj) = zlam0 + rn_dx * 1.e-3 * zui96 plamt(ji,jj) = zlam0 + rn_dx * 1.e-3 * zti 97 plamu(ji,jj) = zlam0 + rn_dx * 1.e-3 * ( zti + 0.5_wp ) 98 98 plamv(ji,jj) = plamt(ji,jj) 99 99 plamf(ji,jj) = plamu(ji,jj) 100 100 101 pphit(ji,jj) = zphi0 + rn_dy * 1.e-3 * ztj102 pphiv(ji,jj) = zphi0 + rn_dy * 1.e-3 * zvj101 pphit(ji,jj) = zphi0 + rn_dy * 1.e-3 * ztj 102 pphiv(ji,jj) = zphi0 + rn_dy * 1.e-3 * ( ztj + 0.5_wp ) 103 103 pphiu(ji,jj) = pphit(ji,jj) 104 104 pphif(ji,jj) = pphiv(ji,jj) -
NEMO/trunk/tests/ICE_ADV2D/MY_SRC/usrdef_nam.F90
r12740 r13286 14 14 !! usr_def_hgr : initialize the horizontal mesh 15 15 !!---------------------------------------------------------------------- 16 USE dom_oce , ONLY: nimpp , njmpp, Agrif_Root ! i- & j-indices of the local domain16 USE dom_oce 17 17 USE par_oce ! ocean space and time domain 18 18 USE phycst ! physical constants … … 82 82 kk_cfg = NINT( rn_dx ) 83 83 ! 84 IF( Agrif_Root() ) THEN ! Global Domain size: 84 IF( Agrif_Root() ) THEN ! Global Domain size: ICE_AGRIF domain is 300 km x 300 Km x 10 m 85 85 kpi = NINT( 300.e3 / rn_dx ) - 1 86 86 kpj = NINT( 300.e3 / rn_dy ) - 1 87 ELSE 88 kpi = nbcellsx + 2 + 2*nbghostcells89 kpj = nbcellsy + 2 + 2*nbghostcells87 ELSE ! Global Domain size: add nbghostcells + 1 "land" point on each side 88 kpi = nbcellsx + nbghostcells_x + nbghostcells_x + 2 89 kpj = nbcellsy + nbghostcells_y_s + nbghostcells_y_n + 2 90 90 ENDIF 91 kpk = 191 kpk = 2 92 92 ! 93 93 !! zlx = (kpi-2)*rn_dx*1.e-3 … … 110 110 WRITE(numout,*) ' LX [km]: ', zlx 111 111 WRITE(numout,*) ' LY [km]: ', zly 112 WRITE(numout,*) ' resulting global domain size : jpiglo = ', kpi113 WRITE(numout,*) ' jpjglo = ', kpj112 WRITE(numout,*) ' resulting global domain size : Ni0glo = ', kpi 113 WRITE(numout,*) ' Nj0glo = ', kpj 114 114 WRITE(numout,*) ' jpkglo = ', kpk 115 115 WRITE(numout,*) ' Coriolis:', ln_corio -
NEMO/trunk/tests/ICE_AGRIF/EXPREF/AGRIF_FixedGrids.in
r9159 r13286 1 1 1 2 3 4 63 34 633 3 32 33 62 33 62 3 3 3 3 3 0 -
NEMO/trunk/tests/ICE_AGRIF/MY_SRC/usrdef_hgr.F90
r12740 r13286 64 64 REAL(wp), DIMENSION(:,:), INTENT(out) :: pe1e2u, pe1e2v ! u- & v-surfaces (if reduction in strait) [m2] 65 65 ! 66 INTEGER :: ji, jj ! dummy loop indices66 INTEGER :: ji, jj ! dummy loop indices 67 67 REAL(wp) :: zphi0, zlam0, zbeta, zf0 68 REAL(wp) :: zti, z ui, ztj, zvj ! local scalars68 REAL(wp) :: zti, ztj ! local scalars 69 69 !!------------------------------------------------------------------------------- 70 70 ! … … 76 76 77 77 ! ========== 78 zlam0 = -(jpiglo-1)/2 * 1.e-3 * rn_dx79 zphi0 = -(jpjglo-1)/2 * 1.e-3 * rn_dy80 81 78 #if defined key_agrif 82 IF( .NOT. Agrif_Root() ) THEN 79 IF( Agrif_Root() ) THEN 80 #endif 81 ! Compatibility WITH old version: 82 ! jperio = 7 => Ni0glo = jpigo_old_version - 2 83 ! => jpiglo-1 replaced by Ni0glo+1 84 zlam0 = -REAL( (Ni0glo+1)/2, wp) * 1.e-3 * rn_dx 85 zphi0 = -REAL( (Nj0glo+1)/2, wp) * 1.e-3 * rn_dy ! +1 for compatibility with old version --> to be replaced by -1 as before 86 #if defined key_agrif 87 ELSE 88 ! ! let lower left longitude and latitude from parent 83 89 !clem zlam0 = Agrif_Parent(zlam0) + (Agrif_ix())*Agrif_Parent(rn_dx) * 1.e-5 84 90 !clem zphi0 = Agrif_Parent(zphi0) + (Agrif_iy())*Agrif_Parent(rn_dy) * 1.e-5 85 zlam0 = ( 0.5_wp - ( Agrif_parent(jpiglo) - 1 ) / 2 ) * 1.e-3 * Agrif_irhox() * rn_dx & 91 ! Compatibility WITH old version: 92 ! jperio = 0 => Ni0glo = jpigo_old_version 93 ! => Agrif_parent(jpiglo)-1 replaced by Agrif_parent(Ni0glo)-1 94 zlam0 = ( 0.5_wp - REAL( ( Agrif_parent(Ni0glo)-1 ) / 2, wp) ) * 1.e-3 * Agrif_irhox() * rn_dx & 86 95 & + ( Agrif_Ix() + nbghostcells - 1 ) * Agrif_irhox() * rn_dx * 1.e-3 - ( 0.5_wp + nbghostcells ) * rn_dx * 1.e-3 87 zphi0 = ( 0.5_wp - ( Agrif_parent(jpjglo) - 1 ) / 2) * 1.e-3 * Agrif_irhoy() * rn_dy &96 zphi0 = ( 0.5_wp - REAL( ( Agrif_parent(Nj0glo)-1 ) / 2, wp) ) * 1.e-3 * Agrif_irhoy() * rn_dy & 88 97 & + ( Agrif_Iy() + nbghostcells - 1 ) * Agrif_irhoy() * rn_dy * 1.e-3 - ( 0.5_wp + nbghostcells ) * rn_dy * 1.e-3 89 98 ENDIF … … 91 100 92 101 DO_2D_11_11 93 zti = FLOAT( ji - 1 + nimpp - 1 ) ; ztj = FLOAT( jj - 1 + njmpp - 1 )94 z ui = FLOAT( ji - 1 + nimpp - 1 ) + 0.5_wp ; zvj = FLOAT( jj - 1 + njmpp - 1 ) + 0.5_wp102 zti = REAL( mig0_oldcmp(ji) - 1, wp ) ! start at i=0 in the global grid without halos 103 ztj = REAL( mjg0_oldcmp(jj) - 1, wp ) ! start at j=0 in the global grid without halos 95 104 96 plamt(ji,jj) = zlam0 + rn_dx * 1.e-3 * zti97 plamu(ji,jj) = zlam0 + rn_dx * 1.e-3 * zui105 plamt(ji,jj) = zlam0 + rn_dx * 1.e-3 * zti 106 plamu(ji,jj) = zlam0 + rn_dx * 1.e-3 * ( zti + 0.5_wp ) 98 107 plamv(ji,jj) = plamt(ji,jj) 99 108 plamf(ji,jj) = plamu(ji,jj) 100 109 101 pphit(ji,jj) = zphi0 + rn_dy * 1.e-3 * ztj102 pphiv(ji,jj) = zphi0 + rn_dy * 1.e-3 * zvj110 pphit(ji,jj) = zphi0 + rn_dy * 1.e-3 * ztj 111 pphiv(ji,jj) = zphi0 + rn_dy * 1.e-3 * ( ztj + 0.5_wp ) 103 112 pphiu(ji,jj) = pphit(ji,jj) 104 113 pphif(ji,jj) = pphiv(ji,jj) -
NEMO/trunk/tests/ICE_AGRIF/MY_SRC/usrdef_nam.F90
r12597 r13286 14 14 !! usr_def_hgr : initialize the horizontal mesh 15 15 !!---------------------------------------------------------------------- 16 USE dom_oce , ONLY: nimpp , njmpp ! i- & j-indices of the local domain16 USE dom_oce 17 17 USE par_oce ! ocean space and time domain 18 18 USE phycst ! physical constants … … 85 85 kpi = NINT( 300.e3 / rn_dx ) - 1 86 86 kpj = NINT( 300.e3 / rn_dy ) - 1 87 ELSE 88 kpi = nbcellsx + 2 + 2*nbghostcells 89 kpj = nbcellsy + 2 + 2*nbghostcells 87 kpi = kpi - 2 ! for compatibility with old version (because kerio=7) --> to be removed 88 kpj = kpj - 2 ! for compatibility with old version (because kerio=7) --> to be removed 89 ELSE ! Global Domain size: add nbghostcells + 1 "land" point on each side 90 kpi = nbcellsx + 2 * ( nbghostcells + 1 ) 91 kpj = nbcellsy + 2 * ( nbghostcells + 1 ) 92 !!$ kpi = nbcellsx + nbghostcells_x + nbghostcells_x + 2 93 !!$ kpj = nbcellsy + nbghostcells_y_s + nbghostcells_y_n + 2 90 94 ENDIF 91 95 kpk = 2 … … 110 114 WRITE(numout,*) ' LX [km]: ', zlx 111 115 WRITE(numout,*) ' LY [km]: ', zly 112 WRITE(numout,*) ' resulting global domain size : jpiglo = ', kpi113 WRITE(numout,*) ' jpjglo = ', kpj116 WRITE(numout,*) ' resulting global domain size : Ni0glo = ', kpi 117 WRITE(numout,*) ' Nj0glo = ', kpj 114 118 WRITE(numout,*) ' jpkglo = ', kpk 115 119 WRITE(numout,*) ' Coriolis:', ln_corio -
NEMO/trunk/tests/ISOMIP+/MY_SRC/sbcfwb.F90
r12905 r13286 211 211 erp(:,:) = erp(:,:) + zerp_cor(:,:) 212 212 ! 213 IF( nprint == 1 .AND.lwp ) THEN ! control print213 IF( lwp ) THEN ! control print 214 214 IF( z_fwf < 0._wp ) THEN 215 215 WRITE(numout,*)' z_fwf < 0' -
NEMO/trunk/tests/ISOMIP+/MY_SRC/tradmp.F90
r12905 r13286 208 208 ! ! Read in mask from file 209 209 CALL iom_open ( cn_resto, imask) 210 CALL iom_get ( imask, jpdom_auto glo, 'resto', resto )210 CALL iom_get ( imask, jpdom_auto, 'resto', resto ) 211 211 CALL iom_close( imask ) 212 212 ENDIF -
NEMO/trunk/tests/ISOMIP/MY_SRC/usrdef_hgr.F90
r12740 r13286 14 14 !! usr_def_hgr : initialize the horizontal mesh for ISOMIP configuration 15 15 !!---------------------------------------------------------------------- 16 USE dom_oce , ONLY: nimpp, njmpp ! ocean space and time domain16 USE dom_oce 17 17 USE par_oce ! ocean space and time domain 18 18 USE phycst ! physical constants … … 79 79 DO_2D_11_11 80 80 ! ! longitude (west coast at lon=0°) 81 plamt(ji,jj) = rn_e1deg * ( - 0.5 + REAL( ji-1 + nimpp-1 , wp ) )82 plamu(ji,jj) = rn_e1deg * ( REAL( ji-1 + nimpp-1 , wp ) )81 plamt(ji,jj) = rn_e1deg * ( - 0.5 + REAL( mig0_oldcmp(ji)-1 , wp ) ) 82 plamu(ji,jj) = rn_e1deg * ( REAL( mig0_oldcmp(ji)-1 , wp ) ) 83 83 plamv(ji,jj) = plamt(ji,jj) 84 84 plamf(ji,jj) = plamu(ji,jj) 85 85 ! ! latitude (south coast at lat= 81°) 86 pphit(ji,jj) = rn_e2deg * ( - 0.5 + REAL( jj-1 + njmpp-1 , wp ) ) - 80._wp86 pphit(ji,jj) = rn_e2deg * ( - 0.5 + REAL( mjg0_oldcmp(jj)-1 , wp ) ) - 80._wp 87 87 pphiu(ji,jj) = pphit(ji,jj) 88 pphiv(ji,jj) = rn_e2deg * ( REAL( jj-1 + njmpp-1 , wp ) ) - 80_wp88 pphiv(ji,jj) = rn_e2deg * ( REAL( mjg0_oldcmp(jj)-1 , wp ) ) - 80_wp 89 89 pphif(ji,jj) = pphiv(ji,jj) 90 90 END_2D -
NEMO/trunk/tests/ISOMIP/MY_SRC/usrdef_nam.F90
r12377 r13286 15 15 !! usr_def_hgr : initialize the horizontal mesh 16 16 !!---------------------------------------------------------------------- 17 USE dom_oce , ONLY: nimpp , njmpp ! i- & j-indices of the local domain18 17 USE dom_oce , ONLY: ln_zco, ln_zps, ln_sco ! flag of type of coordinate 19 18 USE par_oce ! ocean space and time domain … … 95 94 WRITE(numout,*) ' vertical resolution rn_e3 = ', rn_e3 , ' meters' 96 95 WRITE(numout,*) ' ISOMIP domain = 15° x 10° x 900 m' 97 WRITE(numout,*) ' resulting global domain size : jpiglo = ', kpi98 WRITE(numout,*) ' jpjglo = ', kpj96 WRITE(numout,*) ' resulting global domain size : Ni0glo = ', kpi 97 WRITE(numout,*) ' Nj0glo = ', kpj 99 98 WRITE(numout,*) ' jpkglo = ', kpk 100 99 WRITE(numout,*) ' ' -
NEMO/trunk/tests/ISOMIP/MY_SRC/usrdef_zgr.F90
r12740 r13286 16 16 !!--------------------------------------------------------------------- 17 17 USE oce ! ocean variables 18 USE dom_oce , ONLY: mj0 , mj1 , nimpp , njmpp! ocean space and time domain19 USE dom_oce , ONLY: glamt , gphit 18 USE dom_oce , ONLY: mj0 , mj1 ! ocean space and time domain 19 USE dom_oce , ONLY: glamt , gphit ! ocean space and time domain 20 20 USE usrdef_nam ! User defined : namelist variables 21 21 ! … … 67 67 REAL(wp), DIMENSION(jpi,jpj) :: zht , zhu ! bottom depth 68 68 REAL(wp), DIMENSION(jpi,jpj) :: zhisf, zhisfu ! top depth 69 REAL(wp), DIMENSION(jpi,jpj) :: zmsk70 REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2d workspace71 69 !!---------------------------------------------------------------------- 72 70 ! … … 87 85 ! !== isfdraft ==! 88 86 ! 89 ! the ocean basin surrounded by land (1 grid-point) set through lbc_lnk call as jperio=090 z2d(:,:) = 1._wp ! surface ocean is the 1st level91 CALL lbc_lnk( 'usrdef_zgr', z2d, 'T', 1. ) ! closed basin since jperio = 0 (see userdef_nam.F90)92 zmsk(:,:) = NINT( z2d(:,:) )93 !94 !95 87 zht (:,:) = rbathy 96 88 zhisf(:,:) = 200._wp 97 ij0 = 1 ; ij1 = 4089 ij0 = 1 ; ij1 = 40+nn_hls 98 90 DO jj = mj0(ij0), mj1(ij1) 99 91 zhisf(:,jj)=700.0_wp-(gphit(:,jj)+80.0_wp)*125.0_wp 100 92 END DO 101 zhisf(:,:) = zhisf(:,:) * zmsk(:,:)102 93 ! 103 94 CALL zgr_z1d( pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d ) ! Reference z-coordinate system -
NEMO/trunk/tests/LOCK_EXCHANGE/MY_SRC/usrdef_hgr.F90
r12740 r13286 13 13 !! usr_def_hgr : initialize the horizontal mesh for LOCK_EXCHANGE configuration 14 14 !!---------------------------------------------------------------------- 15 USE dom_oce , ONLY: nimpp, njmpp ! ocean space and time domain15 USE dom_oce 16 16 USE par_oce ! ocean space and time domain 17 17 USE phycst ! physical constants … … 76 76 DO_2D_11_11 77 77 ! ! longitude 78 plamt(ji,jj) = zfact * ( - 0.5 + REAL( ji-1 + nimpp-1 , wp ) )79 plamu(ji,jj) = zfact * ( REAL( ji-1 + nimpp-1 , wp ) )78 plamt(ji,jj) = zfact * ( - 0.5 + REAL( mig0_oldcmp(ji)-1 , wp ) ) 79 plamu(ji,jj) = zfact * ( REAL( mig0_oldcmp(ji)-1 , wp ) ) 80 80 plamv(ji,jj) = plamt(ji,jj) 81 81 plamf(ji,jj) = plamu(ji,jj) 82 82 ! ! latitude 83 pphit(ji,jj) = zfact * ( - 0.5 + REAL( jj-1 + njmpp-1 , wp ) )83 pphit(ji,jj) = zfact * ( - 0.5 + REAL( mjg0_oldcmp(jj)-1 , wp ) ) 84 84 pphiu(ji,jj) = pphit(ji,jj) 85 pphiv(ji,jj) = zfact * ( REAL( jj-1 + njmpp-1 , wp ) )85 pphiv(ji,jj) = zfact * ( REAL( mjg0_oldcmp(jj)-1 , wp ) ) 86 86 pphif(ji,jj) = pphiv(ji,jj) 87 87 END_2D -
NEMO/trunk/tests/LOCK_EXCHANGE/MY_SRC/usrdef_nam.F90
r12377 r13286 14 14 !! usr_def_hgr : initialize the horizontal mesh 15 15 !!---------------------------------------------------------------------- 16 USE dom_oce , ONLY: nimpp , njmpp ! i- & j-indices of the local domain17 16 USE par_oce ! ocean space and time domain 18 17 USE phycst ! physical constants … … 85 84 WRITE(numout,*) ' vertical resolution rn_dz = ', rn_dz, ' meters' 86 85 WRITE(numout,*) ' LOCK_EXCHANGE domain = 64 km x 3 grid-points x 20 m' 87 WRITE(numout,*) ' resulting global domain size : jpiglo = ', kpi88 WRITE(numout,*) ' jpjglo = ', kpj86 WRITE(numout,*) ' resulting global domain size : Ni0glo = ', kpi 87 WRITE(numout,*) ' Nj0glo = ', kpj 89 88 WRITE(numout,*) ' jpkglo = ', kpk 90 89 WRITE(numout,*) ' ' -
NEMO/trunk/tests/OVERFLOW/MY_SRC/usrdef_hgr.F90
r12740 r13286 13 13 !! usr_def_hgr : initialize the horizontal mesh for OVERFLOW configuration 14 14 !!---------------------------------------------------------------------- 15 USE dom_oce , ONLY: nimpp, njmpp ! ocean space and time domain15 USE dom_oce 16 16 USE par_oce ! ocean space and time domain 17 17 USE phycst ! physical constants … … 76 76 DO_2D_11_11 77 77 ! ! longitude 78 plamt(ji,jj) = zfact * ( - 0.5 + REAL( ji-1 + nimpp-1 , wp ) )79 plamu(ji,jj) = zfact * ( REAL( ji-1 + nimpp-1 , wp ) )78 plamt(ji,jj) = zfact * ( - 0.5 + REAL( mig0_oldcmp(ji)-1 , wp ) ) 79 plamu(ji,jj) = zfact * ( REAL( mig0_oldcmp(ji)-1 , wp ) ) 80 80 plamv(ji,jj) = plamt(ji,jj) 81 81 plamf(ji,jj) = plamu(ji,jj) 82 82 ! ! latitude 83 pphit(ji,jj) = zfact * ( - 0.5 + REAL( jj-1 + njmpp-1 , wp ) )83 pphit(ji,jj) = zfact * ( - 0.5 + REAL( mjg0_oldcmp(jj)-1 , wp ) ) 84 84 pphiu(ji,jj) = pphit(ji,jj) 85 pphiv(ji,jj) = zfact * ( REAL( jj-1 + njmpp-1 , wp ) )85 pphiv(ji,jj) = zfact * ( REAL( mjg0_oldcmp(jj)-1 , wp ) ) 86 86 pphif(ji,jj) = pphiv(ji,jj) 87 87 END_2D -
NEMO/trunk/tests/OVERFLOW/MY_SRC/usrdef_nam.F90
r12377 r13286 14 14 !! usr_def_hgr : initialize the horizontal mesh 15 15 !!---------------------------------------------------------------------- 16 USE dom_oce , ONLY: nimpp , njmpp ! i- & j-indices of the local domain17 16 USE dom_oce , ONLY: ln_zco, ln_zps, ln_sco ! flag of type of coordinate 18 17 USE par_oce ! ocean space and time domain … … 86 85 WRITE(numout,*) ' vertical resolution rn_dz = ', rn_dz, ' meters' 87 86 WRITE(numout,*) ' OVERFLOW domain = 200 km x 3 grid-points x 2000 m' 88 WRITE(numout,*) ' resulting global domain size : jpiglo = ', kpi89 WRITE(numout,*) ' jpjglo = ', kpj87 WRITE(numout,*) ' resulting global domain size : Ni0glo = ', kpi 88 WRITE(numout,*) ' Nj0glo = ', kpj 90 89 WRITE(numout,*) ' jpkglo = ', kpk 91 90 ! -
NEMO/trunk/tests/OVERFLOW/MY_SRC/usrdef_zgr.F90
r12740 r13286 15 15 !!--------------------------------------------------------------------- 16 16 USE oce ! ocean variables 17 USE dom_oce , ONLY: mi0, mi1 , nimpp, njmpp! ocean space and time domain18 USE dom_oce , ONLY: glamt 17 USE dom_oce , ONLY: mi0, mi1 ! ocean space and time domain 18 USE dom_oce , ONLY: glamt ! ocean space and time domain 19 19 USE usrdef_nam ! User defined : namelist variables 20 20 ! -
NEMO/trunk/tests/STATION_ASF/MY_SRC/nemogcm.F90
r13011 r13286 30 30 USE step_c1d ! Time stepping loop for the 1D configuration 31 31 ! 32 USE prtctl ! Print control 32 33 USE in_out_manager ! I/O manager 33 34 USE lib_mpp ! distributed memory computing … … 131 132 INTEGER :: ios, ilocal_comm ! local integers 132 133 !! 133 NAMELIST/namctl/ sn_cfctl, nn_print, nn_ictls, nn_ictle, & 134 & nn_isplt , nn_jsplt, nn_jctls, nn_jctle, & 135 & ln_timing, ln_diacfl 134 NAMELIST/namctl/ sn_cfctl, ln_timing, ln_diacfl, & 135 & nn_isplt, nn_jsplt, nn_ictls, nn_ictle, nn_jctls, nn_jctle 136 136 NAMELIST/namcfg/ ln_read_cfg, cn_domcfg, ln_closea, ln_write_cfg, cn_domcfg_out, ln_use_jattr 137 137 !!---------------------------------------------------------------------- … … 232 232 ! 233 233 IF( ln_read_cfg ) THEN ! Read sizes in domain configuration file 234 CALL domain_cfg ( cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio )234 CALL domain_cfg ( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, jperio ) 235 235 ELSE ! user-defined namelist 236 CALL usr_def_nam( cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio )236 CALL usr_def_nam( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, jperio ) 237 237 ENDIF 238 238 ! … … 306 306 WRITE(numout,*) ' sn_cfctl%procincr = ', sn_cfctl%procincr 307 307 WRITE(numout,*) ' sn_cfctl%ptimincr = ', sn_cfctl%ptimincr 308 WRITE(numout,*) ' level of print nn_print = ', nn_print309 WRITE(numout,*) ' Start i indice for SUM control nn_ictls = ', nn_ictls310 WRITE(numout,*) ' End i indice for SUM control nn_ictle = ', nn_ictle311 WRITE(numout,*) ' Start j indice for SUM control nn_jctls = ', nn_jctls312 WRITE(numout,*) ' End j indice for SUM control nn_jctle = ', nn_jctle313 WRITE(numout,*) ' number of proc. following i nn_isplt = ', nn_isplt314 WRITE(numout,*) ' number of proc. following j nn_jsplt = ', nn_jsplt315 308 WRITE(numout,*) ' timing by routine ln_timing = ', ln_timing 316 309 WRITE(numout,*) ' CFL diagnostics ln_diacfl = ', ln_diacfl 317 310 ENDIF 318 311 ! 319 nprint = nn_print ! convert DOCTOR namelist names into OLD names 320 nictls = nn_ictls 321 nictle = nn_ictle 322 njctls = nn_jctls 323 njctle = nn_jctle 324 isplt = nn_isplt 325 jsplt = nn_jsplt 326 312 IF( .NOT.ln_read_cfg ) ln_closea = .false. ! dealing possible only with a domcfg file 327 313 IF(lwp) THEN ! control print 328 314 WRITE(numout,*) … … 335 321 WRITE(numout,*) ' use file attribute if exists as i/p j-start ln_use_jattr = ', ln_use_jattr 336 322 ENDIF 337 IF( .NOT.ln_read_cfg ) ln_closea = .false. ! dealing possible only with a domcfg file338 !339 ! ! Parameter control340 !341 IF( sn_cfctl%l_prtctl .OR. sn_cfctl%l_prttrc ) THEN ! sub-domain area indices for the control prints342 IF( lk_mpp .AND. jpnij > 1 ) THEN343 isplt = jpni ; jsplt = jpnj ; ijsplt = jpni*jpnj ! the domain is forced to the real split domain344 ELSE345 IF( isplt == 1 .AND. jsplt == 1 ) THEN346 CALL ctl_warn( ' - isplt & jsplt are equal to 1', &347 & ' - the print control will be done over the whole domain' )348 ENDIF349 ijsplt = isplt * jsplt ! total number of processors ijsplt350 ENDIF351 IF(lwp) WRITE(numout,*)' - The total number of processors over which the'352 IF(lwp) WRITE(numout,*)' print control will be done is ijsplt : ', ijsplt353 !354 ! ! indices used for the SUM control355 IF( nictls+nictle+njctls+njctle == 0 ) THEN ! print control done over the default area356 lsp_area = .FALSE.357 ELSE ! print control done over a specific area358 lsp_area = .TRUE.359 IF( nictls < 1 .OR. nictls > jpiglo ) THEN360 CALL ctl_warn( ' - nictls must be 1<=nictls>=jpiglo, it is forced to 1' )361 nictls = 1362 ENDIF363 IF( nictle < 1 .OR. nictle > jpiglo ) THEN364 CALL ctl_warn( ' - nictle must be 1<=nictle>=jpiglo, it is forced to jpiglo' )365 nictle = jpiglo366 ENDIF367 IF( njctls < 1 .OR. njctls > jpjglo ) THEN368 CALL ctl_warn( ' - njctls must be 1<=njctls>=jpjglo, it is forced to 1' )369 njctls = 1370 ENDIF371 IF( njctle < 1 .OR. njctle > jpjglo ) THEN372 CALL ctl_warn( ' - njctle must be 1<=njctle>=jpjglo, it is forced to jpjglo' )373 njctle = jpjglo374 ENDIF375 ENDIF376 ENDIF377 323 ! 378 324 IF( 1._wp /= SIGN(1._wp,-0._wp) ) CALL ctl_stop( 'nemo_ctl: The intrinsec SIGN function follows f2003 standard.', & -
NEMO/trunk/tests/STATION_ASF/MY_SRC/usrdef_hgr.F90
r12629 r13286 14 14 !! usr_def_hgr : initialize the horizontal mesh 15 15 !!---------------------------------------------------------------------- 16 USE dom_oce , ONLY: nimpp, njmpp ! ocean space and time domain17 16 USE c1d , ONLY: rn_lon1d, rn_lat1d ! ocean lon/lat define by namelist 18 17 USE par_oce ! ocean space and time domain -
NEMO/trunk/tests/STATION_ASF/MY_SRC/usrdef_nam.F90
r12629 r13286 15 15 !! usr_def_hgr : initialize the horizontal mesh 16 16 !!---------------------------------------------------------------------- 17 USE dom_oce , ONLY: nimpp, njmpp ! ocean space and time domain18 !!! USE dom_oce , ONLY: ln_zco, ln_zps, ln_sco ! flag of type of coordinate19 17 USE par_oce ! ocean space and time domain 20 18 USE phycst ! physical constants -
NEMO/trunk/tests/VORTEX/MY_SRC/domvvl.F90
r12740 r13286 450 450 ELSE 451 451 ijk_max = MAXLOC( ze3t(:,:,:) ) 452 ijk_max(1) = ijk_max(1) + nimpp - 1453 ijk_max(2) = ijk_max(2) + njmpp - 1452 ijk_max(1) = mig0_oldcmp(ijk_max(1)) 453 ijk_max(2) = mjg0_oldcmp(ijk_max(2)) 454 454 ijk_min = MINLOC( ze3t(:,:,:) ) 455 ijk_min(1) = ijk_min(1) + nimpp - 1456 ijk_min(2) = ijk_min(2) + njmpp - 1455 ijk_min(1) = mig0_oldcmp(ijk_min(1)) 456 ijk_min(2) = mjg0_oldcmp(ijk_min(2)) 457 457 ENDIF 458 458 IF (lwp) THEN … … 793 793 IF( ln_rstart ) THEN !* Read the restart file 794 794 CALL rst_read_open ! open the restart file if necessary 795 CALL iom_get( numror, jpdom_auto glo, 'sshn' , ssh(:,:,Kmm), ldxios = lrxios )795 CALL iom_get( numror, jpdom_auto, 'sshn' , ssh(:,:,Kmm), ldxios = lrxios ) 796 796 ! 797 797 id1 = iom_varid( numror, 'e3t_b', ldstop = .FALSE. ) … … 806 806 ! 807 807 IF( MIN( id1, id2 ) > 0 ) THEN ! all required arrays exist 808 CALL iom_get( numror, jpdom_auto glo, 'e3t_b', e3t(:,:,:,Kbb), ldxios = lrxios )809 CALL iom_get( numror, jpdom_auto glo, 'e3t_n', e3t(:,:,:,Kmm), ldxios = lrxios )808 CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb), ldxios = lrxios ) 809 CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm), ldxios = lrxios ) 810 810 ! needed to restart if land processor not computed 811 811 IF(lwp) write(numout,*) 'dom_vvl_rst : e3t(:,:,:,Kbb) and e3t(:,:,:,Kmm) found in restart files' … … 821 821 IF(lwp) write(numout,*) 'e3t_n set equal to e3t_b.' 822 822 IF(lwp) write(numout,*) 'l_1st_euler is forced to true' 823 CALL iom_get( numror, jpdom_auto glo, 'e3t_b', e3t(:,:,:,Kbb), ldxios = lrxios )823 CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb), ldxios = lrxios ) 824 824 e3t(:,:,:,Kmm) = e3t(:,:,:,Kbb) 825 825 l_1st_euler = .true. … … 828 828 IF(lwp) write(numout,*) 'e3t_b set equal to e3t_n.' 829 829 IF(lwp) write(numout,*) 'l_1st_euler is forced to true' 830 CALL iom_get( numror, jpdom_auto glo, 'e3t_n', e3t(:,:,:,Kmm), ldxios = lrxios )830 CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm), ldxios = lrxios ) 831 831 e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 832 832 l_1st_euler = .true. … … 853 853 ! ! ----------------------- ! 854 854 IF( MIN( id3, id4 ) > 0 ) THEN ! all required arrays exist 855 CALL iom_get( numror, jpdom_auto glo, 'tilde_e3t_b', tilde_e3t_b(:,:,:), ldxios = lrxios )856 CALL iom_get( numror, jpdom_auto glo, 'tilde_e3t_n', tilde_e3t_n(:,:,:), ldxios = lrxios )855 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_b', tilde_e3t_b(:,:,:), ldxios = lrxios ) 856 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_n', tilde_e3t_n(:,:,:), ldxios = lrxios ) 857 857 ELSE ! one at least array is missing 858 858 tilde_e3t_b(:,:,:) = 0.0_wp … … 863 863 ! ! ------------ ! 864 864 IF( id5 > 0 ) THEN ! required array exists 865 CALL iom_get( numror, jpdom_auto glo, 'hdiv_lf', hdiv_lf(:,:,:), ldxios = lrxios )865 CALL iom_get( numror, jpdom_auto, 'hdiv_lf', hdiv_lf(:,:,:), ldxios = lrxios ) 866 866 ELSE ! array is missing 867 867 hdiv_lf(:,:,:) = 0.0_wp -
NEMO/trunk/tests/VORTEX/MY_SRC/usrdef_hgr.F90
r12740 r13286 63 63 REAL(wp), DIMENSION(:,:), INTENT(out) :: pe1e2u, pe1e2v ! u- & v-surfaces (if reduction in strait) [m2] 64 64 ! 65 INTEGER :: ji, jj ! dummy loop indices65 INTEGER :: ji, jj ! dummy loop indices 66 66 REAL(wp) :: zphi0, zlam0, zbeta, zf0 67 REAL(wp) :: zti, z ui, ztj, zvj ! local scalars67 REAL(wp) :: zti, ztj ! local scalars 68 68 !!------------------------------------------------------------------------------- 69 69 ! … … 77 77 ! Position coordinates (in kilometers) 78 78 ! ========== 79 zlam0 = -(jpiglo-1)/2 * 1.e-3 * rn_dx 80 zphi0 = -(jpjglo-1)/2 * 1.e-3 * rn_dy 81 79 #if defined key_agrif 80 IF( Agrif_Root() ) THEN 81 #endif 82 ! Compatibility WITH old version: 83 ! jperio = 0 => Ni0glo = jpigo_old_version 84 ! => jpiglo-1 replaced by Ni0glo-1 85 zlam0 = -REAL( (Ni0glo-1)/2, wp) * 1.e-3 * rn_dx 86 zphi0 = -REAL( (Nj0glo-1)/2, wp) * 1.e-3 * rn_dy 82 87 #if defined key_agrif 83 ! ! let lower left longitude and latitude from parent 84 IF (.NOT.Agrif_root()) THEN 85 zlam0 = (0.5_wp-(Agrif_parent(jpiglo)-1)/2)*1.e-3*Agrif_irhox()*rn_dx & 86 &+(Agrif_Ix()+nbghostcells-1)*Agrif_irhox()*rn_dx*1.e-3-(0.5_wp+nbghostcells)*rn_dx*1.e-3 87 zphi0 = (0.5_wp-(Agrif_parent(jpjglo)-1)/2)*1.e-3*Agrif_irhoy()*rn_dy & 88 &+(Agrif_Iy()+nbghostcells-1)*Agrif_irhoy()*rn_dy*1.e-3-(0.5_wp+nbghostcells)*rn_dy*1.e-3 88 ELSE 89 ! ! let lower left longitude and latitude from parent 90 ! Compatibility WITH old version: 91 ! jperio = 0 => Ni0glo = jpigo_old_version 92 ! => Agrif_parent(jpiglo)-1 replaced by Agrif_parent(Ni0glo)-1 93 zlam0 = ( 0.5_wp - REAL( ( Agrif_parent(Ni0glo)-1 ) / 2, wp) ) * 1.e-3 * Agrif_irhox() * rn_dx & 94 & + ( Agrif_Ix() + nbghostcells - 1 ) * Agrif_irhox() * rn_dx * 1.e-3 - ( 0.5_wp + nbghostcells ) * rn_dx * 1.e-3 95 zphi0 = ( 0.5_wp - REAL( ( Agrif_parent(Nj0glo)-1 ) / 2, wp) ) * 1.e-3 * Agrif_irhoy() * rn_dy & 96 & + ( Agrif_Iy() + nbghostcells - 1 ) * Agrif_irhoy() * rn_dy * 1.e-3 - ( 0.5_wp + nbghostcells ) * rn_dy * 1.e-3 89 97 ENDIF 90 98 #endif 91 99 92 100 DO_2D_11_11 93 zti = FLOAT( ji - 1 + nimpp - 1 ) ; ztj = FLOAT( jj - 1 + njmpp - 1 )94 z ui = FLOAT( ji - 1 + nimpp - 1 ) + 0.5_wp ; zvj = FLOAT( jj - 1 + njmpp - 1 ) + 0.5_wp101 zti = REAL( mig0_oldcmp(ji) - 1, wp ) ! start at i=0 in the global grid without halos 102 ztj = REAL( mjg0_oldcmp(jj) - 1, wp ) ! start at j=0 in the global grid without halos 95 103 96 plamt(ji,jj) = zlam0 + rn_dx * 1.e-3 * zti97 plamu(ji,jj) = zlam0 + rn_dx * 1.e-3 * zui104 plamt(ji,jj) = zlam0 + rn_dx * 1.e-3 * zti 105 plamu(ji,jj) = zlam0 + rn_dx * 1.e-3 * ( zti + 0.5_wp ) 98 106 plamv(ji,jj) = plamt(ji,jj) 99 107 plamf(ji,jj) = plamu(ji,jj) 100 108 101 pphit(ji,jj) = zphi0 + rn_dy * 1.e-3 * ztj102 pphiv(ji,jj) = zphi0 + rn_dy * 1.e-3 * zvj109 pphit(ji,jj) = zphi0 + rn_dy * 1.e-3 * ztj 110 pphiv(ji,jj) = zphi0 + rn_dy * 1.e-3 * ( ztj + 0.5_wp ) 103 111 pphiu(ji,jj) = pphit(ji,jj) 104 112 pphif(ji,jj) = pphiv(ji,jj) -
NEMO/trunk/tests/VORTEX/MY_SRC/usrdef_nam.F90
r12377 r13286 14 14 !! usr_def_hgr : initialize the horizontal mesh 15 15 !!---------------------------------------------------------------------- 16 USE dom_oce , ONLY: nimpp , njmpp ! i- & j-indices of the local domain16 USE dom_oce 17 17 USE par_oce ! ocean space and time domain 18 18 USE phycst ! physical constants … … 84 84 kpi = NINT( 1800.e3 / rn_dx ) + 3 85 85 kpj = NINT( 1800.e3 / rn_dy ) + 3 86 ELSE 87 kpi = nbcellsx + 2 + 2*nbghostcells 88 kpj = nbcellsy + 2 + 2*nbghostcells 86 ELSE ! Global Domain size: add nbghostcells + 1 "land" point on each side 87 kpi = nbcellsx + 2 * ( nbghostcells + 1 ) 88 kpj = nbcellsy + 2 * ( nbghostcells + 1 ) 89 !!$ kpi = nbcellsx + nbghostcells_x + nbghostcells_x + 2 90 !!$ kpj = nbcellsy + nbghostcells_y_s + nbghostcells_y_n + 2 89 91 ENDIF 90 92 kpk = NINT( 5000._wp / rn_dz ) + 1 … … 104 106 WRITE(numout,*) ' horizontal resolution rn_dy = ', rn_dy, ' m' 105 107 WRITE(numout,*) ' vertical resolution rn_dz = ', rn_dz, ' m' 108 WRITE(numout,*) ' resulting global domain size : Ni0glo = ', kpi 109 WRITE(numout,*) ' Nj0glo = ', kpj 110 WRITE(numout,*) ' jpkglo = ', kpk 106 111 WRITE(numout,*) ' VORTEX domain: ' 107 112 WRITE(numout,*) ' LX [km]: ', zlx -
NEMO/trunk/tests/WAD/MY_SRC/usrdef_hgr.F90
r12740 r13286 13 13 !! usr_def_hgr : initialize the horizontal mesh for WAD_TEST_CASES configuration 14 14 !!---------------------------------------------------------------------- 15 USE dom_oce , ONLY: nimpp, njmpp ! ocean space and time domain15 USE dom_oce 16 16 USE par_oce ! ocean space and time domain 17 17 USE phycst ! physical constants … … 76 76 DO_2D_11_11 77 77 ! ! longitude 78 plamt(ji,jj) = zfact * ( - 0.5 + REAL( ji-1 + nimpp-1 , wp ) )79 plamu(ji,jj) = zfact * ( REAL( ji-1 + nimpp-1 , wp ) )78 plamt(ji,jj) = zfact * ( - 0.5 + REAL( mig0_oldcmp(ji)-1 , wp ) ) 79 plamu(ji,jj) = zfact * ( REAL( mig0_oldcmp(ji)-1 , wp ) ) 80 80 plamv(ji,jj) = plamt(ji,jj) 81 81 plamf(ji,jj) = plamu(ji,jj) 82 82 ! ! latitude 83 pphit(ji,jj) = zfact * ( - 0.5 + REAL( jj-1 + njmpp-1 , wp ) )83 pphit(ji,jj) = zfact * ( - 0.5 + REAL( mjg0_oldcmp(jj)-1 , wp ) ) 84 84 pphiu(ji,jj) = pphit(ji,jj) 85 pphiv(ji,jj) = zfact * ( REAL( jj-1 + njmpp-1 , wp ) )85 pphiv(ji,jj) = zfact * ( REAL( mjg0_oldcmp(jj)-1 , wp ) ) 86 86 pphif(ji,jj) = pphiv(ji,jj) 87 87 END_2D -
NEMO/trunk/tests/WAD/MY_SRC/usrdef_nam.F90
r12377 r13286 14 14 !! usr_def_hgr : initialize the horizontal mesh 15 15 !!---------------------------------------------------------------------- 16 USE dom_oce , ONLY: nimpp , njmpp ! i- & j-indices of the local domain17 16 USE par_oce ! ocean space and time domain 18 17 USE phycst ! physical constants … … 77 76 ! ! Set the lateral boundary condition of the global domain 78 77 kperio = 0 ! WAD_TEST_CASES configuration : closed domain 79 IF( nn_wad_test == 8 ) kperio = 7 ! North-South cyclic test 78 IF( nn_wad_test == 8 ) THEN 79 kperio = 7 ! North-South cyclic test 80 kpi = kpi - 2 ! no closed boundary 81 kpj = kpj - 2 ! no closed boundary 82 ENDIF 80 83 ! 81 84 ! ! control print -
NEMO/trunk/tests/WAD/MY_SRC/usrdef_zgr.F90
r12740 r13286 15 15 !!--------------------------------------------------------------------- 16 16 USE oce ! ocean variables 17 USE dom_oce , ONLY: ht_0, mi0, mi1, nimpp, njmpp, & 18 & mj0, mj1, glamt, gphit ! ocean space and time domain 17 USE dom_oce , ONLY: ht_0, mi0, mi1, mj0, mj1, glamt, gphit ! ocean space and time domain 19 18 USE usrdef_nam ! User defined : namelist variables 20 19 USE wet_dry , ONLY: rn_wdmin1, rn_wdmin2, rn_wdld ! Wetting and drying
Note: See TracChangeset
for help on using the changeset viewer.