Changeset 8568
- Timestamp:
- 2017-09-27T16:29:24+02:00 (7 years ago)
- Location:
- branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM
- Files:
-
- 191 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/CONFIG/AMM12/EXP00/namelist_cfg
r8215 r8568 210 210 / 211 211 !----------------------------------------------------------------------- 212 &namtra_adv ! advection scheme for tracer 212 &namtra_adv ! advection scheme for tracer (default: NO advection) 213 213 !----------------------------------------------------------------------- 214 214 ln_traadv_fct = .true. ! FCT scheme 215 215 nn_fct_h = 2 ! =2/4, horizontal 2nd / 4th order 216 216 nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order 217 nn_fct_zts = 0 ! >=1, 2nd order FCT scheme with vertical sub-timestepping218 ! ! (number of sub-timestep = nn_fct_zts)219 217 / 220 218 !----------------------------------------------------------------------- … … 226 224 !---------------------------------------------------------------------------------- 227 225 ! ! Operator type: 226 ln_traldf_NONE = .false. ! No operator (no explicit diffusion) 228 227 ln_traldf_lap = .true. ! laplacian operator 229 228 ln_traldf_blp = .false. ! bilaplacian operator … … 264 263 / 265 264 !----------------------------------------------------------------------- 266 &namdyn_adv ! formulation of the momentum advection 267 !----------------------------------------------------------------------- 265 &namdyn_adv ! formulation of the momentum advection (default: None) 266 !----------------------------------------------------------------------- 267 ln_dynadv_vec = .true. ! vector form - 2nd centered scheme 268 nn_dynkeg = 0 ! grad(KE) scheme: =0 C2 ; =1 Hollingsworth correction 268 269 / 269 270 !----------------------------------------------------------------------- … … 293 294 !----------------------------------------------------------------------- 294 295 ! ! Type of the operator : 295 ! ! no diffusion: set ln_dynldf_lap=..._blp=F296 ln_dynldf_NONE= .false. ! No operator (no explicit diffusion) 296 297 ln_dynldf_lap = .false. ! laplacian operator 297 298 ln_dynldf_blp = .true. ! bilaplacian operator -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/CONFIG/C1D_PAPA/EXP00/namelist_cfg
r8215 r8568 60 60 / 61 61 !----------------------------------------------------------------------- 62 &namcrs ! Grid coarsening for dynamics output and/or63 ! passive tracer coarsened online simulations64 !-----------------------------------------------------------------------65 /66 !-----------------------------------------------------------------------67 62 &namc1d ! 1D configuration options ("key_c1d") 68 63 !----------------------------------------------------------------------- … … 110 105 sn_slp = 'slp.15JUNE2009_fill' , 6 , 'SLP', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' 111 106 112 nn_bulk_algo = 1 ! Bulk algorithm to use to compute bulk transfer coefficients Cd, Ce and Ch113 ! 1 => "NCAR" algorithm (Large and Yeager,2008)114 ! 2 => "COARE 3.0" algorithm (Fairall et al2003)115 ! 3 => "ECMWF" algorithm (IFS cycle 31)116 ! 4 => "COARE 3.5" algorithm (Edson et al 2013)107 ! ! bulk algorithm : 108 ln_NCAR = .true. ! "NCAR" algorithm (Large and Yeager 2008) 109 ln_COARE_3p0= .false. ! "COARE 3.0" algorithm (Fairall et al. 2003) 110 ln_COARE_3p5= .false. ! "COARE 3.5" algorithm (Edson et al. 2013) 111 ln_ECMWF = .false. ! "ECMWF" algorithm (IFS cycle 31) 117 112 118 113 rn_zqt = 2. ! Air temperature and humidity reference height (m) … … 123 118 / 124 119 !----------------------------------------------------------------------- 125 &namsbc_sas ! analytical surface boundary condition 126 !----------------------------------------------------------------------- 127 / 128 !----------------------------------------------------------------------- 129 &namtra_qsr ! penetrative solar radiation 120 &namtra_qsr ! penetrative solar radiation (ln_traqsr =T) 130 121 !----------------------------------------------------------------------- 131 122 ! ! file name ! frequency (hours) ! variable ! time interp. ! clim ! 'yearly'/ ! weights ! rotation ! land/sea mask ! … … 134 125 / 135 126 !----------------------------------------------------------------------- 136 &namsbc_rnf ! runoffs namelist surface boundary condition137 !-----------------------------------------------------------------------138 ln_rnf_mouth = .false. ! specific treatment at rivers mouths139 /140 !-----------------------------------------------------------------------141 127 &namsbc_apr ! Atmospheric pressure used as ocean forcing or in bulk 142 128 !----------------------------------------------------------------------- … … 154 140 / 155 141 !----------------------------------------------------------------------- 156 &namberg ! iceberg parameters157 !-----------------------------------------------------------------------158 /159 !-----------------------------------------------------------------------160 &namlbc ! lateral momentum boundary condition161 !-----------------------------------------------------------------------162 rn_shlat = 0. ! shlat = 0 ! 0 < shlat < 2 ! shlat = 2 ! 2 < shlat163 /164 !-----------------------------------------------------------------------165 &namagrif ! AGRIF zoom ("key_agrif")166 !-----------------------------------------------------------------------167 /168 !-----------------------------------------------------------------------169 &nam_tide ! tide parameters170 !-----------------------------------------------------------------------171 /172 !-----------------------------------------------------------------------173 &nambdy ! unstructured open boundaries174 !-----------------------------------------------------------------------175 /176 !-----------------------------------------------------------------------177 &nambdy_dta ! open boundaries - external data178 !-----------------------------------------------------------------------179 /180 !-----------------------------------------------------------------------181 &nambdy_tide ! tidal forcing at open boundaries182 !-----------------------------------------------------------------------183 /184 !-----------------------------------------------------------------------185 142 &namdrg ! top/bottom drag coefficient (default: NO selection) 186 143 !----------------------------------------------------------------------- … … 192 149 / 193 150 !----------------------------------------------------------------------- 194 &nambbl ! bottom boundary layer scheme195 !-----------------------------------------------------------------------196 /197 !-----------------------------------------------------------------------198 151 &nameos ! ocean physical parameters 199 152 !----------------------------------------------------------------------- … … 203 156 &namtra_adv ! advection scheme for tracer 204 157 !----------------------------------------------------------------------- 205 ! C1D : no advection scheme 206 / 207 !----------------------------------------------------------------------- 208 &namtra_adv_mle ! mixed layer eddy parametrisation (Fox-Kemper param) 158 ln_traadv_NONE= .true. ! No tracer advection 159 / 160 !----------------------------------------------------------------------- 161 &namtra_adv_mle ! mixed layer eddy parametrisation (Fox-Kemper param) (default: NO) 209 162 !----------------------------------------------------------------------- 210 163 / … … 212 165 &namtra_ldf ! lateral diffusion scheme for tracers 213 166 !----------------------------------------------------------------------- 214 ! C1D : no lateral diffusion 215 / 216 !----------------------------------------------------------------------- 217 &namtra_ldfeiv ! eddy induced velocity param. 218 !----------------------------------------------------------------------- 219 ! C1D : no eiv 167 ln_traldf_NONE= .true. ! No operator (no explicit diffusion) 168 / 169 !----------------------------------------------------------------------- 170 &namtra_ldfeiv ! eddy induced velocity param. (default: NO) 171 !----------------------------------------------------------------------- 220 172 / 221 173 !----------------------------------------------------------------------- … … 225 177 / 226 178 !----------------------------------------------------------------------- 227 &namdyn_adv ! formulation of the momentum advection 228 !----------------------------------------------------------------------- 229 ! C1D : no advection scheme 179 &namdyn_adv ! formulation of the momentum advection (default: None) 180 !----------------------------------------------------------------------- 181 ln_dynadv_NONE= .true. ! linear dynamics (no momentum advection) 230 182 / 231 183 !----------------------------------------------------------------------- … … 252 204 &namdyn_ldf ! lateral diffusion on momentum 253 205 !----------------------------------------------------------------------- 254 ln_dynldf_ lap = .false. ! laplacian operator206 ln_dynldf_NONE= .true. ! No operator (no explicit diffusion) 255 207 / 256 208 !----------------------------------------------------------------------- … … 302 254 / 303 255 !----------------------------------------------------------------------- 304 &nammpp ! Massively Parallel Processing ("key_mpp_mpi)305 !-----------------------------------------------------------------------306 /307 !-----------------------------------------------------------------------308 256 &namctl ! Control prints & Benchmark 309 !-----------------------------------------------------------------------310 /311 !-----------------------------------------------------------------------312 &namnc4 ! netcdf4 chunking and compression settings ("key_netcdf4")313 257 !----------------------------------------------------------------------- 314 258 / … … 319 263 / 320 264 !----------------------------------------------------------------------- 321 &namflo ! float parameters ("key_float")322 !-----------------------------------------------------------------------323 /324 !-----------------------------------------------------------------------325 &namptr ! Poleward Transport Diagnostic326 !-----------------------------------------------------------------------327 /328 !-----------------------------------------------------------------------329 265 &namhsb ! Heat and salt budgets 330 266 !----------------------------------------------------------------------- 331 267 / 332 268 !----------------------------------------------------------------------- 333 &namdct ! transports through sections334 !-----------------------------------------------------------------------335 nn_dct = 60 ! time step frequency for transports computing336 nn_dctwri = 60 ! time step frequency for transports writing337 nn_secdebug = 0 ! 0 : no section to debug338 /339 !-----------------------------------------------------------------------340 269 &namobs ! observation usage switch ('key_diaobs') 341 270 !----------------------------------------------------------------------- 342 271 / 343 272 !----------------------------------------------------------------------- 344 &nam_asminc ! assimilation increments ('key_asminc')345 !-----------------------------------------------------------------------346 /347 !-----------------------------------------------------------------------348 273 &namsbc_wave ! External fields from wave model 349 274 !----------------------------------------------------------------------- -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/CONFIG/GYRE_BFM/EXP00/namelist_cfg
r8215 r8568 142 142 / 143 143 !----------------------------------------------------------------------- 144 &namtra_adv ! advection scheme for tracer 144 &namtra_adv ! advection scheme for tracer (default: No selection) 145 145 !----------------------------------------------------------------------- 146 146 ln_traadv_fct = .true. ! FCT scheme 147 147 nn_fct_h = 2 ! =2/4, horizontal 2nd / 4th order 148 148 nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order 149 nn_fct_zts = 0 ! >=1, 2nd order FCT scheme with vertical sub-timestepping 150 ! ! (number of sub-timestep = nn_fct_zts) 151 / 152 !----------------------------------------------------------------------- 153 &namtra_adv_mle ! mixed layer eddy parametrisation (Fox-Kemper param) 154 !----------------------------------------------------------------------- 155 / 156 !---------------------------------------------------------------------------------- 157 &namtra_ldf ! lateral diffusion scheme for tracers 158 !---------------------------------------------------------------------------------- 149 / 150 !----------------------------------------------------------------------- 151 &namtra_adv_mle ! mixed layer eddy parametrisation (Fox-Kemper param) (default: NO) 152 !----------------------------------------------------------------------- 153 / 154 !----------------------------------------------------------------------- 155 &namtra_ldf ! lateral diffusion scheme for tracers (default: No selection) 156 !----------------------------------------------------------------------- 159 157 ! ! Operator type: 158 ln_traldf_NONE = .false. ! No operator (no explicit advection) 160 159 ln_traldf_lap = .true. ! laplacian operator 161 160 ln_traldf_blp = .false. ! bilaplacian operator … … 185 184 rn_bht_0 = 1.e+12 ! lateral eddy diffusivity (bilap. operator) [m4/s] 186 185 / 187 !----------------------------------------------------------------------- -----------188 &namtra_ldfeiv ! eddy induced velocity param. 189 !----------------------------------------------------------------------- -----------186 !----------------------------------------------------------------------- 187 &namtra_ldfeiv ! eddy induced velocity param. (default: NO) 188 !----------------------------------------------------------------------- 190 189 ln_ldfeiv =.false. ! use eddy induced velocity parameterization 191 190 / … … 196 195 / 197 196 !----------------------------------------------------------------------- 198 &namdyn_adv ! formulation of the momentum advection 199 !----------------------------------------------------------------------- 197 &namdyn_adv ! formulation of the momentum advection (default: No selection) 198 !----------------------------------------------------------------------- 199 ln_dynadv_vec = .true. ! vector form - 2nd centered scheme 200 nn_dynkeg = 0 ! grad(KE) scheme: =0 C2 ; =1 Hollingsworth correction 200 201 / 201 202 !----------------------------------------------------------------------- … … 219 220 !----------------------------------------------------------------------- 220 221 ! ! Type of the operator : 221 ! ! no diffusion: set ln_dynldf_lap=..._blp=F222 ln_dynldf_NONE= .false. ! No operator (no explicit diffusion) 222 223 ln_dynldf_lap = .true. ! laplacian operator 223 224 ln_dynldf_blp = .false. ! bilaplacian operator -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/CONFIG/GYRE_BFM/EXP00/namelist_top_cfg
r5836 r8568 22 22 / 23 23 !----------------------------------------------------------------------- 24 &namtrc_adv ! advection scheme for passive tracer 24 &namtrc_adv ! advection scheme for passive tracer (default: NO selection) 25 25 !----------------------------------------------------------------------- 26 26 ln_trcadv_fct = .true. ! FCT scheme 27 27 nn_fct_h = 2 ! =2/4, horizontal 2nd / 4th order 28 28 nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order 29 nn_fct_zts = 0 ! >=1, 2nd order FCT scheme with vertical sub-timestepping30 ! ! (number of sub-timestep = nn_fct_zts)31 29 / 32 30 !----------------------------------------------------------------------- -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/CONFIG/GYRE_PISCES/EXP00/namelist_cfg
r8215 r8568 92 92 / 93 93 !----------------------------------------------------------------------- 94 &namtra_adv ! advection scheme for tracer 94 &namtra_adv ! advection scheme for tracer (default: No selection) 95 95 !----------------------------------------------------------------------- 96 96 ln_traadv_fct = .true. ! FCT scheme 97 97 nn_fct_h = 2 ! =2/4, horizontal 2nd / 4th order 98 98 nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order 99 nn_fct_zts = 0 ! >=1, 2nd order FCT scheme with vertical sub-timestepping 100 ! ! (number of sub-timestep = nn_fct_zts) 101 / 102 !----------------------------------------------------------------------- 103 &namtra_adv_mle ! mixed layer eddy parametrisation (Fox-Kemper param) 104 !----------------------------------------------------------------------- 105 / 106 !---------------------------------------------------------------------------------- 107 &namtra_ldf ! lateral diffusion scheme for tracers 108 !---------------------------------------------------------------------------------- 99 / 100 !----------------------------------------------------------------------- 101 &namtra_adv_mle ! mixed layer eddy parametrisation (Fox-Kemper param) (default: NO) 102 !----------------------------------------------------------------------- 103 / 104 !----------------------------------------------------------------------- 105 &namtra_ldf ! lateral diffusion scheme for tracers (default: No selection) 106 !----------------------------------------------------------------------- 109 107 ! ! Operator type: 108 ln_traldf_NONE = .false. ! No operator (no explicit advection) 110 109 ln_traldf_lap = .true. ! laplacian operator 111 110 ln_traldf_blp = .false. ! bilaplacian operator … … 146 145 / 147 146 !----------------------------------------------------------------------- 148 &namdyn_adv ! formulation of the momentum advection 149 !----------------------------------------------------------------------- 150 / 151 !----------------------------------------------------------------------- 152 &namdyn_vor ! option of physics/algorithm (not control by CPP keys) 147 &namdyn_adv ! formulation of the momentum advection (default: No selection) 148 !----------------------------------------------------------------------- 149 ln_dynadv_vec = .true. ! vector form - 2nd centered scheme 150 nn_dynkeg = 0 ! grad(KE) scheme: =0 C2 ; =1 Hollingsworth correction 151 / 152 !----------------------------------------------------------------------- 153 &namdyn_vor ! option of physics/algorithm (default: No selection) 153 154 !----------------------------------------------------------------------- 154 155 ln_dynvor_ene = .true. ! enstrophy conserving scheme … … 170 171 / 171 172 !----------------------------------------------------------------------- 172 &namdyn_ldf ! lateral diffusion on momentum 173 &namdyn_ldf ! lateral diffusion on momentum (default: No selection) 173 174 !----------------------------------------------------------------------- 174 175 ! ! Type of the operator : 175 ! ! no diffusion: set ln_dynldf_lap=..._blp=F176 ln_dynldf_NONE= .false. ! No operator (no explicit diffusion) 176 177 ln_dynldf_lap = .true. ! laplacian operator 177 178 ln_dynldf_blp = .false. ! bilaplacian operator … … 197 198 rn_ahm_0_lap = 100000. ! horizontal laplacian eddy viscosity [m2/s] 198 199 / 200 199 201 !!====================================================================== 200 202 !! vertical physics namelists !! -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/CONFIG/GYRE_PISCES/EXP00/namelist_top_cfg
r8215 r8568 29 29 / 30 30 !----------------------------------------------------------------------- 31 &namtrc_adv ! advection scheme for passive tracer 31 &namtrc_adv ! advection scheme for passive tracer (default: NO selection) 32 32 !----------------------------------------------------------------------- 33 33 ln_trcadv_fct = .true. ! FCT scheme 34 34 nn_fct_h = 2 ! =2/4, horizontal 2nd / 4th order 35 35 nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order 36 nn_fct_zts = 0 ! >=1, 2nd order FCT scheme with vertical sub-timestepping37 ! ! (number of sub-timestep = nn_fct_zts)38 36 / 39 37 !----------------------------------------------------------------------- -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/CONFIG/ORCA2_LIM3_PISCES/EXP00/1_namelist_cfg
r8215 r8568 116 116 / 117 117 !----------------------------------------------------------------------- 118 &namtra_adv ! advection scheme for tracer 118 &namtra_adv ! advection scheme for tracer (default: NO selection) 119 119 !----------------------------------------------------------------------- 120 120 ln_traadv_fct = .true. ! FCT scheme 121 121 nn_fct_h = 2 ! =2/4, horizontal 2nd / 4th order 122 122 nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order 123 nn_fct_zts = 0 ! >=1, 2nd order FCT scheme with vertical sub-timestepping124 ! ! (number of sub-timestep = nn_fct_zts)125 123 / 126 124 !----------------------------------------------------------------------- 127 125 &namtra_ldf ! lateral diffusion scheme for tracers 128 !----------------------------------------------------------------------- -----------126 !----------------------------------------------------------------------- 129 127 ! ! Operator type: 130 128 ln_traldf_lap = .true. ! laplacian operator … … 161 159 / 162 160 !----------------------------------------------------------------------- 163 &namdyn_adv ! formulation of the momentum advection 164 !----------------------------------------------------------------------- 161 &namdyn_adv ! formulation of the momentum advection (default: No selection) 162 !----------------------------------------------------------------------- 163 ln_dynadv_NONE= .false. ! linear dynamics (no momentum advection) 164 ln_dynadv_vec = .true. ! vector form - 2nd centered scheme 165 nn_dynkeg = 0 ! grad(KE) scheme: =0 C2 ; =1 Hollingsworth correction 166 ln_dynadv_cen2= .false. ! flux form - 2nd order centered scheme 167 ln_dynadv_ubs = .false. ! flux form - 3rd order UBS scheme 165 168 / 166 169 !----------------------------------------------------------------------- -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/CONFIG/ORCA2_LIM3_PISCES/EXP00/namelist_cfg
r8215 r8568 123 123 / 124 124 !----------------------------------------------------------------------- 125 &namtra_adv ! advection scheme for tracer 126 !----------------------------------------------------------------------- 127 ln_traadv_fct = .true.! FCT scheme125 &namtra_adv ! advection scheme for tracer (default: NO advection) 126 !----------------------------------------------------------------------- 127 ln_traadv_fct = .true. ! FCT scheme 128 128 nn_fct_h = 2 ! =2/4, horizontal 2nd / 4th order 129 129 nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order 130 nn_fct_zts = 0 ! > 1 , 2nd order FCT scheme with vertical sub-timestepping 131 ! ! (number of sub-timestep = nn_fct_zts) 132 / 133 !----------------------------------------------------------------------- 134 &namtra_adv_mle ! mixed layer eddy parametrisation (Fox-Kemper param) 130 / 131 !----------------------------------------------------------------------- 132 &namtra_adv_mle ! mixed layer eddy parametrisation (Fox-Kemper param) 135 133 !----------------------------------------------------------------------- 136 134 ln_mle = .true. ! (T) use the Mixed Layer Eddy (MLE) parameterisation … … 140 138 !---------------------------------------------------------------------------------- 141 139 ! ! Operator type: 140 ln_traldf_NONE = .false. ! No operator (no explicit advection) 142 141 ln_traldf_lap = .true. ! laplacian operator 143 142 ln_traldf_blp = .false. ! bilaplacian operator … … 186 185 / 187 186 !----------------------------------------------------------------------- 188 &namdyn_adv ! formulation of the momentum advection 189 !----------------------------------------------------------------------- 187 &namdyn_adv ! formulation of the momentum advection (default: No selection) 188 !----------------------------------------------------------------------- 189 ln_dynadv_NONE= .false. ! linear dynamics (no momentum advection) 190 ln_dynadv_vec = .true. ! vector form - 2nd centered scheme 191 nn_dynkeg = 0 ! grad(KE) scheme: =0 C2 ; =1 Hollingsworth correction 192 ln_dynadv_cen2= .false. ! flux form - 2nd order centered scheme 193 ln_dynadv_ubs = .false. ! flux form - 3rd order UBS scheme 190 194 / 191 195 !----------------------------------------------------------------------- … … 212 216 !----------------------------------------------------------------------- 213 217 ! ! Type of the operator : 214 ! ! no diffusion: set ln_dynldf_lap=..._blp=F218 ln_dynldf_NONE= .false. ! No operator (no explicit diffusion) 215 219 ln_dynldf_lap = .true. ! laplacian operator 216 220 ln_dynldf_blp = .false. ! bilaplacian operator -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/CONFIG/ORCA2_LIM3_PISCES/EXP00/namelist_top_cfg
r8215 r8568 71 71 / 72 72 !----------------------------------------------------------------------- 73 &namtrc_adv ! advection scheme for passive tracer 73 &namtrc_adv ! advection scheme for passive tracer (default: NO selection) 74 74 !----------------------------------------------------------------------- 75 75 ln_trcadv_mus = .true. ! MUSCL scheme -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/CONFIG/ORCA2_OFF_PISCES/EXP00/namelist_cfg
r8215 r8568 71 71 !---------------------------------------------------------------------------------- 72 72 ! ! Operator type: 73 ln_traldf_NONE = .false. ! No operator (no explicit advection) 73 74 ln_traldf_lap = .true. ! laplacian operator 74 75 ln_traldf_blp = .false. ! bilaplacian operator -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/CONFIG/ORCA2_OFF_PISCES/EXP00/namelist_top_cfg
r7646 r8568 71 71 / 72 72 !----------------------------------------------------------------------- 73 &namtrc_adv ! advection scheme for passive tracer 73 &namtrc_adv ! advection scheme for passive tracer (default: No selection) 74 74 !----------------------------------------------------------------------- 75 75 ln_trcadv_mus = .true. ! MUSCL scheme -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/CONFIG/ORCA2_OFF_TRC/EXP00/namelist_cfg
r8215 r8568 72 72 !---------------------------------------------------------------------------------- 73 73 ! ! Operator type: 74 ln_traldf_NONE = .false. ! No explicit diffusion 74 75 ln_traldf_lap = .true. ! laplacian operator 75 76 ln_traldf_blp = .false. ! bilaplacian operator -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/CONFIG/ORCA2_SAS_LIM3/EXP00/namelist_cfg
r8215 r8568 74 74 / 75 75 !----------------------------------------------------------------------- 76 &namtra_adv ! advection scheme for tracer 76 &namtra_adv ! advection scheme for tracer (default: NO selection) 77 77 !----------------------------------------------------------------------- 78 ln_traadv_fct = .true. ! FCT scheme79 nn_fct_h = 2 ! =2/4, horizontal 2nd / 4th order80 nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order81 nn_fct_zts = 0 ! > 1 , 2nd order FCT scheme with vertical sub-timestepping82 ! ! (number of sub-timestep = nn_fct_zts)83 78 / 84 79 !----------------------------------------------------------------------- -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/CONFIG/SHARED/namelist_ref
r8215 r8568 306 306 / 307 307 !----------------------------------------------------------------------- 308 &namsbc_sas ! Stand 308 &namsbc_sas ! Stand-Alone Surface boundary condition 309 309 !----------------------------------------------------------------------- 310 310 ! ! file name ! frequency (hours) ! variable ! time interp.! clim ! 'yearly'/ ! weights ! rotation ! land/sea mask ! … … 602 602 !! *** top/Bottom boundary condition *** !! 603 603 !!====================================================================== 604 !! namdrg top/bottom drag coefficient (default: NO NE)604 !! namdrg top/bottom drag coefficient (default: NO selection) 605 605 !! namdrg_top top friction (ln_isfcav=T) 606 606 !! namdrg_bot bottom friction … … 666 666 667 667 !!====================================================================== 668 !! Tracer (T & S 668 !! Tracer (T & S) namelists 669 669 !!====================================================================== 670 670 !! nameos equation of state … … 679 679 &nameos ! ocean Equation Of Seawater (default: NO) 680 680 !----------------------------------------------------------------------- 681 ln_teos10 = .false. ! = Use TEOS-10 equation of state682 ln_eos80 = .false. ! = Use EOS80 equation of state683 ln_seos = .false. ! = Use simplified equation of state (S-EOS)681 ln_teos10 = .false. ! = Use TEOS-10 682 ln_eos80 = .false. ! = Use EOS80 683 ln_seos = .false. ! = Use S-EOS (simplified Eq.) 684 684 ! 685 685 ! ! S-EOS coefficients (ln_seos=T): … … 694 694 / 695 695 !----------------------------------------------------------------------- 696 &namtra_adv ! advection scheme for tracer (default: NO advection) 697 !----------------------------------------------------------------------- 696 &namtra_adv ! advection scheme for tracer (default: NO selection) 697 !----------------------------------------------------------------------- 698 ln_traadv_NONE= .false. ! No tracer advection 698 699 ln_traadv_cen = .false. ! 2nd order centered scheme 699 700 nn_cen_h = 4 ! =2/4, horizontal 2nd order CEN / 4th order CEN … … 702 703 nn_fct_h = 2 ! =2/4, horizontal 2nd / 4th order 703 704 nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order 704 nn_fct_zts = 0 ! >=1, 2nd order FCT scheme with vertical sub-timestepping705 ! ! (number of sub-timestep = nn_fct_zts)706 705 ln_traadv_mus = .false. ! MUSCL scheme 707 706 ln_mus_ups = .false. ! use upstream scheme near river mouths … … 724 723 / 725 724 !----------------------------------------------------------------------- 726 &namtra_ldf ! lateral diffusion scheme for tracers (default: NO diffusion)725 &namtra_ldf ! lateral diffusion scheme for tracers (default: NO selection) 727 726 !----------------------------------------------------------------------- 728 727 ! ! Operator type: 729 ! ! no diffusion: set ln_traldf_lap=..._blp=F728 ln_traldf_NONE = .false. ! No explicit diffusion 730 729 ln_traldf_lap = .false. ! laplacian operator 731 730 ln_traldf_blp = .false. ! bilaplacian operator … … 759 758 &namtra_ldfeiv ! eddy induced velocity param. (default: NO) 760 759 !----------------------------------------------------------------------- 761 ln_ldfeiv = .false.! use eddy induced velocity parameterization760 ln_ldfeiv = .false. ! use eddy induced velocity parameterization 762 761 rn_aeiv_0 = 2000. ! eddy induced velocity coefficient [m2/s] 763 762 nn_aei_ijk_t = 21 ! space/time variation of the eiv coeficient … … 790 789 !!====================================================================== 791 790 ! 792 !-----------------------------------------------------------------------793 &namdyn_adv ! formulation of the momentum advection (default: vector form)794 !-----------------------------------------------------------------------795 ln_dynadv_vec = .true. ! vector form (T) or flux form (F)796 nn_dynkeg = 0 ! scheme for grad(KE): =0 C2 ; =1 Hollingsworth correction797 ln_dynadv_cen2= .false. ! flux form - 2nd order centered scheme798 ln_dynadv_ubs = .false. ! flux form - 3rd order UBS scheme799 ln_dynzad_zts = .false. ! sub-time-stepping for vertical momentum advection800 /801 791 !----------------------------------------------------------------------- 802 792 &nam_vvl ! vertical coordinate options (default: zstar) … … 814 804 / 815 805 !----------------------------------------------------------------------- 806 &namdyn_adv ! formulation of the momentum advection (default: NO selection) 807 !----------------------------------------------------------------------- 808 ln_dynadv_NONE= .false. ! linear dynamics (no momentum advection) 809 ln_dynadv_vec = .false. ! vector form - 2nd centered scheme 810 nn_dynkeg = 0 ! grad(KE) scheme: =0 C2 ; =1 Hollingsworth correction 811 ln_dynadv_cen2= .false. ! flux form - 2nd order centered scheme 812 ln_dynadv_ubs = .false. ! flux form - 3rd order UBS scheme 813 / 814 !----------------------------------------------------------------------- 816 815 &namdyn_vor ! Vorticity / Coriolis scheme (default: NO) 817 816 !----------------------------------------------------------------------- … … 848 847 / 849 848 !----------------------------------------------------------------------- 850 &namdyn_ldf ! lateral diffusion on momentum (default: NO )849 &namdyn_ldf ! lateral diffusion on momentum (default: NO selection) 851 850 !----------------------------------------------------------------------- 852 851 ! ! Type of the operator : 853 ! ! no diffusion: set ln_dynldf_lap=..._blp=F852 ln_dynldf_NONE= .false. ! No operator (i.e. no explicit diffusion) 854 853 ln_dynldf_lap = .false. ! laplacian operator 855 854 ln_dynldf_blp = .false. ! bilaplacian operator … … 891 890 &namzdf ! vertical physics (default: NO selection) 892 891 !----------------------------------------------------------------------- 893 ! ! type of vertical closure 892 ! ! type of vertical closure (required) 894 893 ln_zdfcst = .false. ! constant mixing 895 894 ln_zdfric = .false. ! local Richardson dependent formulation (T => fill namzdf_ric) … … 971 970 rn_charn = 70000. ! Charnock constant for wb induced roughness length 972 971 rn_hsro = 0.02 ! Minimum surface roughness 973 rn_frac_hs = 1.3 ! Fraction of wave height as roughness (if nn_z0_met =2)972 rn_frac_hs = 1.3 ! Fraction of wave height as roughness (if nn_z0_met>1) 974 973 nn_z0_met = 2 ! Method for surface roughness computation (0/1/2/3) 975 974 ! ! =3 requires ln_wave=T … … 1016 1015 nn_isplt = 1 ! number of processors in i-direction 1017 1016 nn_jsplt = 1 ! number of processors in j-direction 1018 nn_timing = 0 ! timing by routine activated (=1) creates timing.output file, or not (=0)1019 nn_diacfl = 0 ! Write out CFL diagnostics (=1) in cfl_diagnostics.ascii, or not (=0)1017 ln_timing = .false. ! timing by routine write out in timing.output file 1018 ln_diacfl = .false. ! CFL diagnostics write out in cfl_diagnostics.ascii 1020 1019 / 1021 1020 !----------------------------------------------------------------------- -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/CONFIG/SHARED/namelist_top_ref
r8215 r8568 61 61 / 62 62 !----------------------------------------------------------------------- 63 &namtrc_adv ! advection scheme for passive tracer 63 &namtrc_adv ! advection scheme for passive tracer (default: NO selection) 64 64 !----------------------------------------------------------------------- 65 ln_trcadv_NONE= .false. ! No passive tracer advection 65 66 ln_trcadv_cen = .false. ! 2nd order centered scheme 66 67 nn_cen_h = 4 ! =2/4, horizontal 2nd order CEN / 4th order CEN … … 69 70 nn_fct_h = 2 ! =2/4, horizontal 2nd / 4th order 70 71 nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order 71 nn_fct_zts = 0 ! >=1, 2nd order FCT scheme with vertical sub-timestepping72 ! ! (number of sub-timestep = nn_fct_zts)73 72 ln_trcadv_mus = .false. ! MUSCL scheme 74 73 ln_mus_ups = .false. ! use upstream scheme near river mouths -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/CONFIG/TEST_CASES/ISOMIP/EXP00/namelist_cfg
r8215 r8568 230 230 nn_fct_h = 2 ! =2/4, horizontal 2nd / 4th order 231 231 nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order 232 nn_fct_zts = 0 ! >=1, 2nd order FCT scheme with vertical sub-timestepping233 ! ! (number of sub-timestep = nn_fct_zts)234 232 / 235 233 !----------------------------------------------------------------------- … … 280 278 !----------------------------------------------------------------------- 281 279 &namdyn_adv ! formulation of the momentum advection 280 !----------------------------------------------------------------------- 281 ln_dynadv_vec = .true. ! vector form (T) or flux form (F) 282 nn_dynkeg = 0 ! scheme for grad(KE): =0 C2 ; =1 Hollingsworth correction 283 ln_dynadv_cen2= .false. ! flux form - 2nd order centered scheme 284 ln_dynadv_ubs = .false. ! flux form - 3rd order UBS scheme 285 / 282 286 !----------------------------------------------------------------------- 283 287 / -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/CONFIG/TEST_CASES/LOCK_EXCHANGE/EXP00/namelist_FCT2_flux_cen2_cfg
r8215 r8568 95 95 nn_fct_h = 2 ! =2/4, horizontal 2nd / 4th order 96 96 nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order 97 nn_fct_zts = 0 ! >=1, 2nd order FCT scheme with vertical sub-timestepping98 ! ! (number of sub-timestep = nn_fct_zts)99 97 ln_traadv_mus = .false. ! MUSCL scheme 100 98 ln_mus_ups = .false. ! use upstream scheme near river mouths … … 130 128 ln_dynadv_cen2= .true. ! flux form - 2nd order centered scheme 131 129 ln_dynadv_ubs = .false. ! flux form - 3rd order UBS scheme 132 ln_dynzad_zts = .false. ! Use (T) sub timestepping for vertical momentum advection133 130 / 134 131 !----------------------------------------------------------------------- -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/CONFIG/TEST_CASES/LOCK_EXCHANGE/EXP00/namelist_FCT2_flux_ubs_cfg
r8215 r8568 95 95 nn_fct_h = 2 ! =2/4, horizontal 2nd / 4th order 96 96 nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order 97 nn_fct_zts = 0 ! >=1, 2nd order FCT scheme with vertical sub-timestepping98 ! ! (number of sub-timestep = nn_fct_zts)99 97 ln_traadv_mus = .false. ! MUSCL scheme 100 98 ln_mus_ups = .false. ! use upstream scheme near river mouths … … 130 128 ln_dynadv_cen2= .false. ! flux form - 2nd order centered scheme 131 129 ln_dynadv_ubs = .true. ! flux form - 3rd order UBS scheme 132 ln_dynzad_zts = .false. ! Use (T) sub timestepping for vertical momentum advection133 130 / 134 131 !----------------------------------------------------------------------- -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/CONFIG/TEST_CASES/LOCK_EXCHANGE/EXP00/namelist_FCT2_vect_eenH_cfg
r8215 r8568 95 95 nn_fct_h = 2 ! =2/4, horizontal 2nd / 4th order 96 96 nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order 97 nn_fct_zts = 0 ! >=1, 2nd order FCT scheme with vertical sub-timestepping98 ! ! (number of sub-timestep = nn_fct_zts)99 97 ln_traadv_mus = .false. ! MUSCL scheme 100 98 ln_mus_ups = .false. ! use upstream scheme near river mouths … … 130 128 ln_dynadv_cen2= .false. ! flux form - 2nd order centered scheme 131 129 ln_dynadv_ubs = .false. ! flux form - 3rd order UBS scheme 132 ln_dynzad_zts = .false. ! Use (T) sub timestepping for vertical momentum advection133 130 / 134 131 !----------------------------------------------------------------------- -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/CONFIG/TEST_CASES/LOCK_EXCHANGE/EXP00/namelist_FCT2_vect_een_cfg
r8215 r8568 95 95 nn_fct_h = 2 ! =2/4, horizontal 2nd / 4th order 96 96 nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order 97 nn_fct_zts = 0 ! >=1, 2nd order FCT scheme with vertical sub-timestepping98 ! ! (number of sub-timestep = nn_fct_zts)99 97 ln_traadv_mus = .false. ! MUSCL scheme 100 98 ln_mus_ups = .false. ! use upstream scheme near river mouths … … 130 128 ln_dynadv_cen2= .false. ! flux form - 2nd order centered scheme 131 129 ln_dynadv_ubs = .false. ! flux form - 3rd order UBS scheme 132 ln_dynzad_zts = .false. ! Use (T) sub timestepping for vertical momentum advection133 130 / 134 131 !----------------------------------------------------------------------- -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/CONFIG/TEST_CASES/LOCK_EXCHANGE/EXP00/namelist_FCT2_vect_ene_cfg
r8215 r8568 95 95 nn_fct_h = 2 ! =2/4, horizontal 2nd / 4th order 96 96 nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order 97 nn_fct_zts = 0 ! >=1, 2nd order FCT scheme with vertical sub-timestepping98 ! ! (number of sub-timestep = nn_fct_zts)99 97 ln_traadv_mus = .false. ! MUSCL scheme 100 98 ln_mus_ups = .false. ! use upstream scheme near river mouths … … 130 128 ln_dynadv_cen2= .false. ! flux form - 2nd order centered scheme 131 129 ln_dynadv_ubs = .false. ! flux form - 3rd order UBS scheme 132 ln_dynzad_zts = .false. ! Use (T) sub timestepping for vertical momentum advection133 130 / 134 131 !----------------------------------------------------------------------- -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/CONFIG/TEST_CASES/LOCK_EXCHANGE/EXP00/namelist_FCT2_vect_ens_cfg
r8215 r8568 95 95 nn_fct_h = 2 ! =2/4, horizontal 2nd / 4th order 96 96 nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order 97 nn_fct_zts = 0 ! >=1, 2nd order FCT scheme with vertical sub-timestepping98 ! ! (number of sub-timestep = nn_fct_zts)99 97 ln_traadv_mus = .false. ! MUSCL scheme 100 98 ln_mus_ups = .false. ! use upstream scheme near river mouths … … 130 128 ln_dynadv_cen2= .false. ! flux form - 2nd order centered scheme 131 129 ln_dynadv_ubs = .false. ! flux form - 3rd order UBS scheme 132 ln_dynzad_zts = .false. ! Use (T) sub timestepping for vertical momentum advection133 130 / 134 131 !----------------------------------------------------------------------- -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/CONFIG/TEST_CASES/LOCK_EXCHANGE/EXP00/namelist_FCT4_flux_cen2_cfg
r8215 r8568 95 95 nn_fct_h = 4 ! =2/4, horizontal 2nd / 4th order 96 96 nn_fct_v = 4 ! =2/4, vertical 2nd / COMPACT 4th order 97 nn_fct_zts = 0 ! >=1, 2nd order FCT scheme with vertical sub-timestepping98 ! ! (number of sub-timestep = nn_fct_zts)99 97 ln_traadv_mus = .false. ! MUSCL scheme 100 98 ln_mus_ups = .false. ! use upstream scheme near river mouths … … 130 128 ln_dynadv_cen2= .true. ! flux form - 2nd order centered scheme 131 129 ln_dynadv_ubs = .false. ! flux form - 3rd order UBS scheme 132 ln_dynzad_zts = .false. ! Use (T) sub timestepping for vertical momentum advection133 130 / 134 131 !----------------------------------------------------------------------- -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/CONFIG/TEST_CASES/LOCK_EXCHANGE/EXP00/namelist_FCT4_flux_ubs_cfg
r8215 r8568 95 95 nn_fct_h = 4 ! =2/4, horizontal 2nd / 4th order 96 96 nn_fct_v = 4 ! =2/4, vertical 2nd / COMPACT 4th order 97 nn_fct_zts = 0 ! >=1, 2nd order FCT scheme with vertical sub-timestepping98 ! ! (number of sub-timestep = nn_fct_zts)99 97 ln_traadv_mus = .false. ! MUSCL scheme 100 98 ln_mus_ups = .false. ! use upstream scheme near river mouths … … 130 128 ln_dynadv_cen2= .false. ! flux form - 2nd order centered scheme 131 129 ln_dynadv_ubs = .true. ! flux form - 3rd order UBS scheme 132 ln_dynzad_zts = .false. ! Use (T) sub timestepping for vertical momentum advection133 130 / 134 131 !----------------------------------------------------------------------- -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/CONFIG/TEST_CASES/LOCK_EXCHANGE/EXP00/namelist_FCT4_vect_eenH_cfg
r8215 r8568 95 95 nn_fct_h = 4 ! =2/4, horizontal 2nd / 4th order 96 96 nn_fct_v = 4 ! =2/4, vertical 2nd / COMPACT 4th order 97 nn_fct_zts = 0 ! >=1, 2nd order FCT scheme with vertical sub-timestepping98 ! ! (number of sub-timestep = nn_fct_zts)99 97 ln_traadv_mus = .false. ! MUSCL scheme 100 98 ln_mus_ups = .false. ! use upstream scheme near river mouths … … 130 128 ln_dynadv_cen2= .false. ! flux form - 2nd order centered scheme 131 129 ln_dynadv_ubs = .false. ! flux form - 3rd order UBS scheme 132 ln_dynzad_zts = .false. ! Use (T) sub timestepping for vertical momentum advection133 130 / 134 131 !----------------------------------------------------------------------- -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/CONFIG/TEST_CASES/LOCK_EXCHANGE/EXP00/namelist_FCT4_vect_een_cfg
r8215 r8568 95 95 nn_fct_h = 4 ! =2/4, horizontal 2nd / 4th order 96 96 nn_fct_v = 4 ! =2/4, vertical 2nd / COMPACT 4th order 97 nn_fct_zts = 0 ! >=1, 2nd order FCT scheme with vertical sub-timestepping98 ! ! (number of sub-timestep = nn_fct_zts)99 97 ln_traadv_mus = .false. ! MUSCL scheme 100 98 ln_mus_ups = .false. ! use upstream scheme near river mouths … … 130 128 ln_dynadv_cen2= .false. ! flux form - 2nd order centered scheme 131 129 ln_dynadv_ubs = .false. ! flux form - 3rd order UBS scheme 132 ln_dynzad_zts = .false. ! Use (T) sub timestepping for vertical momentum advection133 130 / 134 131 !----------------------------------------------------------------------- -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/CONFIG/TEST_CASES/LOCK_EXCHANGE/EXP00/namelist_FCT4_vect_ene_cfg
r8215 r8568 95 95 nn_fct_h = 4 ! =2/4, horizontal 2nd / 4th order 96 96 nn_fct_v = 4 ! =2/4, vertical 2nd / COMPACT 4th order 97 nn_fct_zts = 0 ! >=1, 2nd order FCT scheme with vertical sub-timestepping98 ! ! (number of sub-timestep = nn_fct_zts)99 97 ln_traadv_mus = .false. ! MUSCL scheme 100 98 ln_mus_ups = .false. ! use upstream scheme near river mouths … … 130 128 ln_dynadv_cen2= .false. ! flux form - 2nd order centered scheme 131 129 ln_dynadv_ubs = .false. ! flux form - 3rd order UBS scheme 132 ln_dynzad_zts = .false. ! Use (T) sub timestepping for vertical momentum advection133 130 / 134 131 !----------------------------------------------------------------------- -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/CONFIG/TEST_CASES/LOCK_EXCHANGE/EXP00/namelist_FCT4_vect_ens_cfg
r8215 r8568 95 95 nn_fct_h = 4 ! =2/4, horizontal 2nd / 4th order 96 96 nn_fct_v = 4 ! =2/4, vertical 2nd / COMPACT 4th order 97 nn_fct_zts = 0 ! >=1, 2nd order FCT scheme with vertical sub-timestepping98 ! ! (number of sub-timestep = nn_fct_zts)99 97 ln_traadv_mus = .false. ! MUSCL scheme 100 98 ln_mus_ups = .false. ! use upstream scheme near river mouths … … 130 128 ln_dynadv_cen2= .false. ! flux form - 2nd order centered scheme 131 129 ln_dynadv_ubs = .false. ! flux form - 3rd order UBS scheme 132 ln_dynzad_zts = .false. ! Use (T) sub timestepping for vertical momentum advection133 130 / 134 131 !----------------------------------------------------------------------- -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/CONFIG/TEST_CASES/LOCK_EXCHANGE/EXP00/namelist_cfg
r8215 r8568 95 95 nn_fct_h = 2 ! =2/4, horizontal 2nd / 4th order 96 96 nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order 97 nn_fct_zts = 0 ! >=1, 2nd order FCT scheme with vertical sub-timestepping98 ! ! (number of sub-timestep = nn_fct_zts)99 97 ln_traadv_mus = .false. ! MUSCL scheme 100 98 ln_mus_ups = .false. ! use upstream scheme near river mouths … … 130 128 ln_dynadv_cen2= .false. ! flux form - 2nd order centered scheme 131 129 ln_dynadv_ubs = .true. ! flux form - 3rd order UBS scheme 132 ln_dynzad_zts = .false. ! Use (T) sub timestepping for vertical momentum advection133 130 / 134 131 !----------------------------------------------------------------------- -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/CONFIG/TEST_CASES/OVERFLOW/EXP00/namelist_cfg
r8215 r8568 80 80 / 81 81 !----------------------------------------------------------------------- 82 &namtra_adv ! advection scheme for tracer 82 &namtra_adv ! advection scheme for tracer (default: NO selection) 83 83 !----------------------------------------------------------------------- 84 84 ln_traadv_cen = .false. ! 2nd order centered scheme … … 88 88 nn_fct_h = 2 ! =2/4, horizontal 2nd / 4th order 89 89 nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order 90 nn_fct_zts = 0 ! >=1, 2nd order FCT scheme with vertical sub-timestepping91 ! ! (number of sub-timestep = nn_fct_zts)92 90 ln_traadv_mus = .false. ! MUSCL scheme 93 91 ln_mus_ups = .false. ! use upstream scheme near river mouths … … 117 115 / 118 116 !----------------------------------------------------------------------- 119 &namdyn_adv ! formulation of the momentum advection 120 !----------------------------------------------------------------------- 117 &namdyn_adv ! formulation of the momentum advection (default: NO selection) 118 !----------------------------------------------------------------------- 119 ln_dynadv_NONE= .false. ! linear dynamics (no momentum advection) 121 120 ln_dynadv_vec = .false. ! vector form (T) or flux form (F) 122 121 nn_dynkeg = 0 ! scheme for grad(KE): =0 C2 ; =1 Hollingsworth correction 123 122 ln_dynadv_cen2= .false. ! flux form - 2nd order centered scheme 124 123 ln_dynadv_ubs = .true. ! flux form - 3rd order UBS scheme 125 ln_dynzad_zts = .false. ! Use (T) sub timestepping for vertical momentum advection126 124 / 127 125 !----------------------------------------------------------------------- -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/CONFIG/TEST_CASES/OVERFLOW/EXP00/namelist_sco_FCT2_flux_ubs_cfg
r8215 r8568 89 89 nn_fct_h = 2 ! =2/4, horizontal 2nd / 4th order 90 90 nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order 91 nn_fct_zts = 0 ! >=1, 2nd order FCT scheme with vertical sub-timestepping92 ! ! (number of sub-timestep = nn_fct_zts)93 91 ln_traadv_mus = .false. ! MUSCL scheme 94 92 ln_mus_ups = .false. ! use upstream scheme near river mouths … … 118 116 / 119 117 !----------------------------------------------------------------------- 120 &namdyn_adv ! formulation of the momentum advection 121 !----------------------------------------------------------------------- 118 &namdyn_adv ! formulation of the momentum advection (default: NO selection) 119 !----------------------------------------------------------------------- 120 ln_dynadv_NONE= .false. ! linear dynamics (no momentum advection) 122 121 ln_dynadv_vec = .false. ! vector form (T) or flux form (F) 123 122 nn_dynkeg = 0 ! scheme for grad(KE): =0 C2 ; =1 Hollingsworth correction 124 123 ln_dynadv_cen2= .false. ! flux form - 2nd order centered scheme 125 124 ln_dynadv_ubs = .true. ! flux form - 3rd order UBS scheme 126 ln_dynzad_zts = .false. ! Use (T) sub timestepping for vertical momentum advection127 125 / 128 126 !----------------------------------------------------------------------- -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/CONFIG/TEST_CASES/OVERFLOW/EXP00/namelist_zps_FCT2_flux_ubs_cfg
r8215 r8568 89 89 nn_fct_h = 2 ! =2/4, horizontal 2nd / 4th order 90 90 nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order 91 nn_fct_zts = 0 ! >=1, 2nd order FCT scheme with vertical sub-timestepping92 ! ! (number of sub-timestep = nn_fct_zts)93 91 ln_traadv_mus = .false. ! MUSCL scheme 94 92 ln_mus_ups = .false. ! use upstream scheme near river mouths … … 118 116 / 119 117 !----------------------------------------------------------------------- 120 &namdyn_adv ! formulation of the momentum advection 121 !----------------------------------------------------------------------- 118 &namdyn_adv ! formulation of the momentum advection (default: NO selection) 119 !----------------------------------------------------------------------- 120 ln_dynadv_NONE= .false. ! linear dynamics (no momentum advection) 122 121 ln_dynadv_vec = .false. ! vector form (T) or flux form (F) 123 122 nn_dynkeg = 0 ! scheme for grad(KE): =0 C2 ; =1 Hollingsworth correction 124 123 ln_dynadv_cen2= .false. ! flux form - 2nd order centered scheme 125 124 ln_dynadv_ubs = .true. ! flux form - 3rd order UBS scheme 126 ln_dynzad_zts = .false. ! Use (T) sub timestepping for vertical momentum advection127 125 / 128 126 !----------------------------------------------------------------------- -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/CONFIG/TEST_CASES/OVERFLOW/EXP00/namelist_zps_FCT4_flux_ubs_cfg
r8215 r8568 89 89 nn_fct_h = 4 ! =2/4, horizontal 2nd / 4th order 90 90 nn_fct_v = 4 ! =2/4, vertical 2nd / COMPACT 4th order 91 nn_fct_zts = 0 ! >=1, 2nd order FCT scheme with vertical sub-timestepping92 ! ! (number of sub-timestep = nn_fct_zts)93 91 ln_traadv_mus = .false. ! MUSCL scheme 94 92 ln_mus_ups = .false. ! use upstream scheme near river mouths … … 118 116 / 119 117 !----------------------------------------------------------------------- 120 &namdyn_adv ! formulation of the momentum advection 121 !----------------------------------------------------------------------- 118 &namdyn_adv ! formulation of the momentum advection (default: NO selection) 119 !----------------------------------------------------------------------- 120 ln_dynadv_NONE= .false. ! linear dynamics (no momentum advection) 122 121 ln_dynadv_vec = .false. ! vector form (T) or flux form (F) 123 122 nn_dynkeg = 0 ! scheme for grad(KE): =0 C2 ; =1 Hollingsworth correction 124 123 ln_dynadv_cen2= .false. ! flux form - 2nd order centered scheme 125 124 ln_dynadv_ubs = .true. ! flux form - 3rd order UBS scheme 126 ln_dynzad_zts = .false. ! Use (T) sub timestepping for vertical momentum advection127 125 / 128 126 !----------------------------------------------------------------------- -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/CONFIG/TEST_CASES/OVERFLOW/EXP00/namelist_zps_FCT4_vect_een_cfg
r8215 r8568 89 89 nn_fct_h = 4 ! =2/4, horizontal 2nd / 4th order 90 90 nn_fct_v = 4 ! =2/4, vertical 2nd / COMPACT 4th order 91 nn_fct_zts = 0 ! >=1, 2nd order FCT scheme with vertical sub-timestepping92 ! ! (number of sub-timestep = nn_fct_zts)93 91 ln_traadv_mus = .false. ! MUSCL scheme 94 92 ln_mus_ups = .false. ! use upstream scheme near river mouths … … 118 116 / 119 117 !----------------------------------------------------------------------- 120 &namdyn_adv ! formulation of the momentum advection 121 !----------------------------------------------------------------------- 118 &namdyn_adv ! formulation of the momentum advection (default: NO selection) 119 !----------------------------------------------------------------------- 120 ln_dynadv_NONE= .false. ! linear dynamics (no momentum advection) 122 121 ln_dynadv_vec = .true. ! vector form (T) or flux form (F) 123 122 nn_dynkeg = 0 ! scheme for grad(KE): =0 C2 ; =1 Hollingsworth correction 124 123 ln_dynadv_cen2= .false. ! flux form - 2nd order centered scheme 125 124 ln_dynadv_ubs = .false. ! flux form - 3rd order UBS scheme 126 ln_dynzad_zts = .false. ! Use (T) sub timestepping for vertical momentum advection127 125 / 128 126 !----------------------------------------------------------------------- -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/CONFIG/TEST_CASES/SAS_BIPER/EXP00/1_namelist_cfg
r8215 r8568 99 99 nn_fct_h = 4 ! =2/4, horizontal 2nd / 4th order 100 100 nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order 101 nn_fct_zts = 0 ! > 1 , 2nd order FCT scheme with vertical sub-timestepping102 ! ! (number of sub-timestep = nn_fct_zts)103 101 / 104 102 !----------------------------------------------------------------------- … … 144 142 &namtra_dmp ! tracer: T & S newtonian damping (default: NO) 145 143 !----------------------------------------------------------------------- 146 !----------------------------------------------------------------------- 147 &namdyn_adv ! formulation of the momentum advection 144 / 145 !----------------------------------------------------------------------- 146 &namdyn_adv ! formulation of the momentum advection (default: NO selection) 147 !----------------------------------------------------------------------- 148 ln_dynadv_NONE= .false. ! linear dynamics (no momentum advection) 149 ln_dynadv_vec = .true. ! vector form (T) or flux form (F) 150 nn_dynkeg = 0 ! scheme for grad(KE): =0 C2 ; =1 Hollingsworth correction 151 ln_dynadv_cen2= .false. ! flux form - 2nd order centered scheme 152 ln_dynadv_ubs = .true. ! flux form - 3rd order UBS scheme 148 153 !----------------------------------------------------------------------- 149 154 / -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/CONFIG/TEST_CASES/SAS_BIPER/EXP00/namelist_cfg
r8215 r8568 100 100 / 101 101 !----------------------------------------------------------------------- 102 &namtra_adv ! advection scheme for tracer 102 &namtra_adv ! advection scheme for tracer (default: NO selection) 103 103 !----------------------------------------------------------------------- 104 104 ln_traadv_fct = .true. ! FCT scheme 105 105 nn_fct_h = 4 ! =2/4, horizontal 2nd / 4th order 106 106 nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order 107 nn_fct_zts = 0 ! > 1 , 2nd order FCT scheme with vertical sub-timestepping108 ! ! (number of sub-timestep = nn_fct_zts)109 107 / 110 108 !----------------------------------------------------------------------- … … 160 158 &namtra_dmp ! tracer: T & S newtonian damping (default: NO) 161 159 !----------------------------------------------------------------------- 162 !----------------------------------------------------------------------- 163 &namdyn_adv ! formulation of the momentum advection 164 !----------------------------------------------------------------------- 160 / 161 !----------------------------------------------------------------------- 162 &namdyn_adv ! formulation of the momentum advection (default: NO selection) 163 !----------------------------------------------------------------------- 164 ln_dynadv_NONE= .false. ! linear dynamics (no momentum advection) 165 ln_dynadv_vec = .true. ! vector form - 2nd centered scheme 166 nn_dynkeg = 0 ! grad(KE) scheme: =0 C2 ; =1 Hollingsworth correction 167 ln_dynadv_cen2= .false. ! flux form - 2nd order centered scheme 168 ln_dynadv_ubs = .false. ! flux form - 3rd order UBS scheme 165 169 / 166 170 !----------------------------------------------------------------------- -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/CONFIG/TEST_CASES/WAD/EXP00/namelist_cfg
r8215 r8568 219 219 / 220 220 !----------------------------------------------------------------------- 221 &namtra_adv ! advection scheme for tracer 222 !----------------------------------------------------------------------- 221 &namtra_adv ! advection scheme for tracer (default: No selection) 222 !----------------------------------------------------------------------- 223 ln_traadv_NONE= .false. ! No tracer advection 223 224 ln_traadv_cen = .false. ! 2nd order centered scheme 224 225 ln_traadv_mus = .false. ! MUSCL scheme … … 226 227 nn_fct_h = 2 ! =2/4, horizontal 2nd / 4th order 227 228 nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order 228 nn_fct_zts = 0 ! >=1, 2nd order FCT scheme with vertical sub-timestepping229 ! ! (number of sub-timestep = nn_fct_zts)230 229 / 231 230 !----------------------------------------------------------------------- … … 275 274 / 276 275 !----------------------------------------------------------------------- 277 &namdyn_adv ! formulation of the momentum advection 276 &namdyn_adv ! formulation of the momentum advection (default: NO selection) 277 !----------------------------------------------------------------------- 278 ln_dynadv_NONE= .false. ! linear dynamics (no momentum advection) 279 ln_dynadv_vec = .true. ! vector form - 2nd centered scheme 280 nn_dynkeg = 0 ! grad(KE) scheme: =0 C2 ; =1 Hollingsworth correction 281 ln_dynadv_cen2= .false. ! flux form - 2nd order centered scheme 282 ln_dynadv_ubs = .false. ! flux form - 3rd order UBS scheme 278 283 !----------------------------------------------------------------------- 279 284 / -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/CONFIG/cfg.txt
r8215 r8568 6 6 ORCA2_OFF_PISCES OPA_SRC OFF_SRC TOP_SRC 7 7 ORCA2_OFF_TRC OPA_SRC OFF_SRC TOP_SRC 8 GYRE_PISCES_XIOS OPA_SRC TOP_SRC 8 9 ORCA2_LIM3_PISCES OPA_SRC LIM_SRC_3 TOP_SRC NST_SRC 9 GYRE_PISCES_ XIOS OPA_SRC TOP_SRC10 GYRE_PISCES_RK3 RK3_SRC TOP_SRC -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/LIM_SRC_3/limrhg.F90
r7753 r8568 674 674 ! print charge ellipse 675 675 ! This can be desactivated once the user is sure that the stress state 676 ! lie on the charge ellipse. See Bouillon et al. 08for more details676 ! lie on the charge ellipse. See Bouillon et al. (2008) for more details 677 677 IF(ln_ctl) THEN 678 678 CALL prt_ctl_info('lim_rhg : numit :',ivar1=numit) -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OFF_SRC/nemogcm.F90
r8215 r8568 157 157 NAMELIST/namctl/ ln_ctl , nn_print, nn_ictls, nn_ictle, & 158 158 & nn_isplt, nn_jsplt, nn_jctls, nn_jctle, & 159 & nn_timing, nn_diacfl159 & ln_timing, ln_diacfl 160 160 161 161 NAMELIST/namcfg/ ln_read_cfg, cn_domcfg, ln_write_cfg, cn_domcfg_out, ln_use_jattr … … 289 289 ENDIF 290 290 ! 291 IF( nn_timing == 1 )CALL timing_init291 IF( ln_timing ) CALL timing_init 292 292 ! 293 293 294 294 ! ! General initialization 295 IF( nn_timing == 1 )CALL timing_start( 'nemo_init')296 ! 297 298 299 IF( lk_c1d 300 301 302 303 304 305 IF( ln_nnogather ) 306 307 IF( ln_ctl 308 309 310 311 312 313 314 IF( l_ldfslp )CALL ldf_slp_init ! slope of lateral mixing315 316 317 IF( ln_trabbl 318 319 320 321 322 323 324 295 IF( ln_timing ) CALL timing_start( 'nemo_init') 296 ! 297 CALL phy_cst ! Physical constants 298 CALL eos_init ! Equation of state 299 IF( lk_c1d ) CALL c1d_init ! 1D column configuration 300 301 CALL dom_init ! Domain 302 303 CALL istate_init ! ocean initial state (Dynamics and tracers) 304 305 IF( ln_nnogather ) CALL nemo_northcomms ! Initialise the northfold neighbour lists (must be done after the masks are defined) 306 307 IF( ln_ctl ) CALL prt_ctl_init ! Print control 308 309 CALL sbc_init ! Forcings : surface module 310 311 CALL ldf_tra_init ! Lateral ocean tracer physics 312 CALL ldf_eiv_init ! Eddy induced velocity param 313 CALL tra_ldf_init ! lateral mixing 314 IF( l_ldfslp ) CALL ldf_slp_init ! slope of lateral mixing 315 316 CALL tra_qsr_init ! penetrative solar radiation qsr 317 IF( ln_trabbl ) CALL tra_bbl_init ! advective (and/or diffusive) bottom boundary layer scheme 318 319 CALL trc_nam_run ! Needed to get restart parameters for passive tracers 320 CALL trc_rst_cal( nit000, 'READ' ) ! calendar 321 CALL dta_dyn_init ! Initialization for the dynamics 322 323 CALL trc_init ! Passive tracers initialization 324 CALL dia_ptr_init ! Initialise diaptr as some variables are used 325 325 ! ! in various advection and diffusion routines 326 326 IF(lwp) WRITE(numout,cform_aaa) ! Flag AAAAAAA 327 327 ! 328 IF( nn_timing == 1 )CALL timing_stop( 'nemo_init')328 IF( ln_timing ) CALL timing_stop( 'nemo_init') 329 329 ! 330 330 END SUBROUTINE nemo_init … … 353 353 WRITE(numout,*) ' number of proc. following i nn_isplt = ', nn_isplt 354 354 WRITE(numout,*) ' number of proc. following j nn_jsplt = ', nn_jsplt 355 WRITE(numout,*) ' timing activated (0/1) nn_timing = ', nn_timing 355 WRITE(numout,*) ' timing by routine ln_timing = ', ln_timing 356 WRITE(numout,*) ' CFL diagnostics ln_diacfl = ', ln_diacfl 356 357 ENDIF 357 358 ! … … 363 364 isplt = nn_isplt 364 365 jsplt = nn_jsplt 366 !!gm to be remove at the end of the 2017 merge party 367 if( ln_timing ) then ; nn_timing = 1 368 else ; nn_timing = 0 369 endif 370 !!gm end 365 371 366 372 -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DIA/diacfl.F90
r7753 r8568 1 1 MODULE diacfl 2 !!====================================================================== ========2 !!====================================================================== 3 3 !! *** MODULE diacfl *** 4 4 !! Output CFL diagnostics to ascii file 5 !!====================================================================== ========6 !! History : 1.0! 2010-03 (E. Blockley) Original code7 !! ! 2014-06 (T Graham)Removed CPP key & Updated to vn3.68 !! 5 !!====================================================================== 6 !! History : 3.4 ! 2010-03 (E. Blockley) Original code 7 !! 3.6 ! 2014-06 (T. Graham) Removed CPP key & Updated to vn3.6 8 !! 4.0 ! 2017-09 (G. Madec) style + comments 9 9 !!---------------------------------------------------------------------- 10 10 !! dia_cfl : Compute and output Courant numbers at each timestep … … 12 12 USE oce ! ocean dynamics and active tracers 13 13 USE dom_oce ! ocean space and time domain 14 USE domvvl ! 15 ! 14 16 USE lib_mpp ! distribued memory computing 15 17 USE lbclnk ! ocean lateral boundary condition (or mpp link) 16 18 USE in_out_manager ! I/O manager 17 USE domvvl18 19 USE timing ! Performance output 19 20 … … 21 22 PRIVATE 22 23 23 REAL(wp) :: cu_max, cv_max, cw_max ! Run max U Courant number24 INTEGER , DIMENSION(3) :: cu_loc, cv_loc, cw_loc ! Run max locations25 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: zcu_cfl ! Courant number arrays26 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: zcv_cfl ! Courant number arrays27 REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: zcw_cfl ! Courant number arrays24 CHARACTER(LEN=50) :: clname="cfl_diagnostics.ascii" ! ascii filename 25 INTEGER :: numcfl ! outfile unit 26 ! 27 INTEGER, DIMENSION(3) :: nCu_loc, nCv_loc, nCw_loc ! U, V, and W run max locations in the global domain 28 REAL(wp) :: rCu_max, rCv_max, rCw_max ! associated run max Courant number 28 29 29 INTEGER :: numcfl ! outfile unit 30 CHARACTER(LEN=50) :: clname="cfl_diagnostics.ascii" ! ascii filename 30 !!gm CAUTION: need to declare these arrays here, otherwise the calculation fails in multi-proc ! 31 !!gm 8 don't understand why. 32 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zCu_cfl, zCv_cfl, zCw_cfl ! workspace 33 !!gm end 31 34 32 35 PUBLIC dia_cfl ! routine called by step.F90 … … 40 43 !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 41 44 !!---------------------------------------------------------------------- 42 43 44 45 CONTAINS 45 46 46 47 47 SUBROUTINE dia_cfl ( kt ) … … 52 52 !! and output to ascii file 'cfl_diagnostics.ascii' 53 53 !!---------------------------------------------------------------------- 54 INTEGER, INTENT(in) :: kt ! ocean time-step index 55 ! 56 INTEGER :: ji, jj, jk ! dummy loop indices 57 REAL(wp):: z2dt, zCu_max, zCv_max, zCw_max ! local scalars 58 INTEGER , DIMENSION(3) :: iloc_u , iloc_v , iloc_w , iloc ! workspace 59 !!gm this does not work REAL(wp), DIMENSION(jpi,jpj,jpk) :: zCu_cfl, zCv_cfl, zCw_cfl ! workspace 60 !!---------------------------------------------------------------------- 61 ! 62 IF( nn_timing == 1 ) CALL timing_start('dia_cfl') 63 ! 64 ! ! setup timestep multiplier to account for initial Eulerian timestep 65 IF( neuler == 0 .AND. kt == nit000 ) THEN ; z2dt = rdt 66 ELSE ; z2dt = rdt * 2._wp 67 ENDIF 68 ! 69 ! 70 DO jk = 1, jpk ! calculate Courant numbers 71 DO jj = 1, jpj 72 DO ji = 1, fs_jpim1 ! vector opt. 73 zCu_cfl(ji,jj,jk) = ABS( un(ji,jj,jk) ) * z2dt / e1u (ji,jj) ! for i-direction 74 zCv_cfl(ji,jj,jk) = ABS( vn(ji,jj,jk) ) * z2dt / e2v (ji,jj) ! for j-direction 75 zCw_cfl(ji,jj,jk) = ABS( wn(ji,jj,jk) ) * z2dt / e3w_n(ji,jj,jk) ! for k-direction 76 END DO 77 END DO 78 END DO 79 ! 80 ! ! calculate maximum values and locations 81 IF( lk_mpp ) THEN 82 CALL mpp_maxloc( zCu_cfl, umask, zCu_max, iloc_u(1), iloc_u(2), iloc_u(3) ) 83 CALL mpp_maxloc( zCv_cfl, vmask, zCv_max, iloc_v(1), iloc_v(2), iloc_v(3) ) 84 CALL mpp_maxloc( zCw_cfl, wmask, zCw_max, iloc_w(1), iloc_w(2), iloc_w(3) ) 85 ELSE 86 iloc = MAXLOC( ABS( zcu_cfl(:,:,:) ) ) 87 iloc_u(1) = iloc(1) + nimpp - 1 88 iloc_u(2) = iloc(2) + njmpp - 1 89 iloc_u(3) = iloc(3) 90 zCu_max = zCu_cfl(iloc(1),iloc(2),iloc(3)) 91 ! 92 iloc = MAXLOC( ABS( zcv_cfl(:,:,:) ) ) 93 iloc_v(1) = iloc(1) + nimpp - 1 94 iloc_v(2) = iloc(2) + njmpp - 1 95 iloc_v(3) = iloc(3) 96 zCv_max = zCv_cfl(iloc(1),iloc(2),iloc(3)) 97 ! 98 iloc = MAXLOC( ABS( zcw_cfl(:,:,:) ) ) 99 iloc_w(1) = iloc(1) + nimpp - 1 100 iloc_w(2) = iloc(2) + njmpp - 1 101 iloc_w(3) = iloc(3) 102 zCw_max = zCw_cfl(iloc(1),iloc(2),iloc(3)) 103 ENDIF 104 ! 105 ! ! write out to file 106 IF( lwp ) THEN 107 WRITE(numcfl,FMT='(2x,i4,5x,a6,5x,f6.4,1x,i4,1x,i4,1x,i4)') kt, 'Max Cu', zCu_max, iloc_u(1), iloc_u(2), iloc_u(3) 108 WRITE(numcfl,FMT='(11x, a6,5x,f6.4,1x,i4,1x,i4,1x,i4)') 'Max Cv', zCv_max, iloc_v(1), iloc_v(2), iloc_v(3) 109 WRITE(numcfl,FMT='(11x, a6,5x,f6.4,1x,i4,1x,i4,1x,i4)') 'Max Cw', zCw_max, iloc_w(1), iloc_w(2), iloc_w(3) 110 ENDIF 111 ! 112 ! ! update maximum Courant numbers from whole run if applicable 113 IF( zCu_max > rCu_max ) THEN ; rCu_max = zCu_max ; nCu_loc(:) = iloc_u(:) ; ENDIF 114 IF( zCv_max > rCv_max ) THEN ; rCv_max = zCv_max ; nCv_loc(:) = iloc_v(:) ; ENDIF 115 IF( zCw_max > rCw_max ) THEN ; rCw_max = zCw_max ; nCw_loc(:) = iloc_w(:) ; ENDIF 54 116 55 INTEGER, INTENT(in) :: kt ! ocean time-step index 117 ! ! at end of run output max Cu and Cv and close ascii file 118 IF( kt == nitend .AND. lwp ) THEN 119 ! to ascii file 120 WRITE(numcfl,*) '******************************************' 121 WRITE(numcfl,FMT='(3x,a12,7x,f6.4,1x,i4,1x,i4,1x,i4)') 'Run Max Cu', rCu_max, nCu_loc(1), nCu_loc(2), nCu_loc(3) 122 WRITE(numcfl,FMT='(3x,a8,11x,f15.1)') ' => dt/C', z2dt/rCu_max 123 WRITE(numcfl,*) '******************************************' 124 WRITE(numcfl,FMT='(3x,a12,7x,f6.4,1x,i4,1x,i4,1x,i4)') 'Run Max Cv', rCv_max, nCv_loc(1), nCv_loc(2), nCv_loc(3) 125 WRITE(numcfl,FMT='(3x,a8,11x,f15.1)') ' => dt/C', z2dt/rCv_max 126 WRITE(numcfl,*) '******************************************' 127 WRITE(numcfl,FMT='(3x,a12,7x,f6.4,1x,i4,1x,i4,1x,i4)') 'Run Max Cw', rCw_max, nCw_loc(1), nCw_loc(2), nCw_loc(3) 128 WRITE(numcfl,FMT='(3x,a8,11x,f15.1)') ' => dt/C', z2dt/rCw_max 129 CLOSE( numcfl ) 130 ! 131 ! to ocean output 132 WRITE(numout,*) 133 WRITE(numout,*) 'dia_cfl : Maximum Courant number information for the run ' 134 WRITE(numout,*) '~~~~~~~' 135 WRITE(numout,*) ' Max Cu = ', rCu_max, ' at (i,j,k) = (',nCu_loc(1),nCu_loc(2),nCu_loc(3),') => dt/C = ', z2dt/rCu_max 136 WRITE(numout,*) ' Max Cv = ', rCv_max, ' at (i,j,k) = (',nCv_loc(1),nCv_loc(2),nCv_loc(3),') => dt/C = ', z2dt/rCv_max 137 WRITE(numout,*) ' Max Cw = ', rCw_max, ' at (i,j,k) = (',nCw_loc(1),nCw_loc(2),nCw_loc(3),') => dt/C = ', z2dt/rCw_max 138 ENDIF 139 ! 140 IF( nn_timing == 1 ) CALL timing_stop('dia_cfl') 141 ! 142 END SUBROUTINE dia_cfl 56 143 57 REAL(wp) :: zcu_max, zcv_max, zcw_max ! max Courant numbers per timestep58 INTEGER, DIMENSION(3) :: zcu_loc, zcv_loc, zcw_loc ! max Courant number locations59 60 REAL(wp) :: dt ! temporary scalars61 INTEGER, DIMENSION(3) :: zlocu, zlocv, zlocw ! temporary arrays62 INTEGER :: ji, jj, jk ! dummy loop indices63 64 65 IF( nn_diacfl == 1) THEN66 IF( nn_timing == 1 ) CALL timing_start('dia_cfl')67 ! setup timestep multiplier to account for initial Eulerian timestep68 IF( neuler == 0 .AND. kt == nit000 ) THEN ; dt = rdt69 ELSE ; dt = rdt * 2.070 ENDIF71 72 ! calculate Courant numbers73 DO jk = 1, jpk74 DO jj = 1, jpj75 DO ji = 1, fs_jpim1 ! vector opt.76 77 ! Courant number for x-direction (zonal current)78 zcu_cfl(ji,jj,jk) = ABS(un(ji,jj,jk))*dt/e1u(ji,jj)79 80 ! Courant number for y-direction (meridional current)81 zcv_cfl(ji,jj,jk) = ABS(vn(ji,jj,jk))*dt/e2v(ji,jj)82 83 ! Courant number for z-direction (vertical current)84 zcw_cfl(ji,jj,jk) = ABS(wn(ji,jj,jk))*dt/e3w_n(ji,jj,jk)85 END DO86 END DO87 END DO88 89 ! calculate maximum values and locations90 IF( lk_mpp ) THEN91 CALL mpp_maxloc(zcu_cfl,umask,zcu_max, zcu_loc(1), zcu_loc(2), zcu_loc(3))92 CALL mpp_maxloc(zcv_cfl,vmask,zcv_max, zcv_loc(1), zcv_loc(2), zcv_loc(3))93 CALL mpp_maxloc(zcw_cfl,tmask,zcw_max, zcw_loc(1), zcw_loc(2), zcw_loc(3))94 ELSE95 zlocu = MAXLOC( ABS( zcu_cfl(:,:,:) ) )96 zcu_loc(1) = zlocu(1) + nimpp - 197 zcu_loc(2) = zlocu(2) + njmpp - 198 zcu_loc(3) = zlocu(3)99 zcu_max = zcu_cfl(zcu_loc(1),zcu_loc(2),zcu_loc(3))100 101 zlocv = MAXLOC( ABS( zcv_cfl(:,:,:) ) )102 zcv_loc(1) = zlocv(1) + nimpp - 1103 zcv_loc(2) = zlocv(2) + njmpp - 1104 zcv_loc(3) = zlocv(3)105 zcv_max = zcv_cfl(zcv_loc(1),zcv_loc(2),zcv_loc(3))106 107 zlocw = MAXLOC( ABS( zcw_cfl(:,:,:) ) )108 zcw_loc(1) = zlocw(1) + nimpp - 1109 zcw_loc(2) = zlocw(2) + njmpp - 1110 zcw_loc(3) = zlocw(3)111 zcw_max = zcw_cfl(zcw_loc(1),zcw_loc(2),zcw_loc(3))112 ENDIF113 114 ! write out to file115 IF( lwp ) THEN116 WRITE(numcfl,FMT='(2x,i4,5x,a6,5x,f6.4,1x,i4,1x,i4,1x,i4)') kt, 'Max Cu', zcu_max, zcu_loc(1), zcu_loc(2), zcu_loc(3)117 WRITE(numcfl,FMT='(11x,a6,5x,f6.4,1x,i4,1x,i4,1x,i4)') 'Max Cv', zcv_max, zcv_loc(1), zcv_loc(2), zcv_loc(3)118 WRITE(numcfl,FMT='(11x,a6,5x,f6.4,1x,i4,1x,i4,1x,i4)') 'Max Cw', zcw_max, zcw_loc(1), zcw_loc(2), zcw_loc(3)119 ENDIF120 121 ! update maximum Courant numbers from whole run if applicable122 IF( zcu_max > cu_max ) THEN123 cu_max = zcu_max124 cu_loc = zcu_loc125 ENDIF126 IF( zcv_max > cv_max ) THEN127 cv_max = zcv_max128 cv_loc = zcv_loc129 ENDIF130 IF( zcw_max > cw_max ) THEN131 cw_max = zcw_max132 cw_loc = zcw_loc133 ENDIF134 135 ! at end of run output max Cu and Cv and close ascii file136 IF( kt == nitend .AND. lwp ) THEN137 ! to ascii file138 WRITE(numcfl,*) '******************************************'139 WRITE(numcfl,FMT='(3x,a12,7x,f6.4,1x,i4,1x,i4,1x,i4)') 'Run Max Cu', cu_max, cu_loc(1), cu_loc(2), cu_loc(3)140 WRITE(numcfl,FMT='(3x,a8,11x,f7.1)') ' => dt/C', dt*(1.0/cu_max)141 WRITE(numcfl,*) '******************************************'142 WRITE(numcfl,FMT='(3x,a12,7x,f6.4,1x,i4,1x,i4,1x,i4)') 'Run Max Cv', cv_max, cv_loc(1), cv_loc(2), cv_loc(3)143 WRITE(numcfl,FMT='(3x,a8,11x,f7.1)') ' => dt/C', dt*(1.0/cv_max)144 WRITE(numcfl,*) '******************************************'145 WRITE(numcfl,FMT='(3x,a12,7x,f6.4,1x,i4,1x,i4,1x,i4)') 'Run Max Cw', cw_max, cw_loc(1), cw_loc(2), cw_loc(3)146 WRITE(numcfl,FMT='(3x,a8,11x,f7.1)') ' => dt/C', dt*(1.0/cw_max)147 CLOSE( numcfl )148 149 ! to ocean output150 WRITE(numout,*)151 WRITE(numout,*) 'dia_cfl : Maximum Courant number information for the run:'152 WRITE(numout,*) '~~~~~~~~~~~~'153 WRITE(numout,FMT='(12x,a12,7x,f6.4,5x,a16,i4,1x,i4,1x,i4,a1)') 'Run Max Cu', cu_max, 'at (i, j, k) = (', cu_loc(1), cu_loc(2), cu_loc(3), ')'154 WRITE(numout,FMT='(12x,a8,11x,f7.1)') ' => dt/C', dt*(1.0/cu_max)155 WRITE(numout,FMT='(12x,a12,7x,f6.4,5x,a16,i4,1x,i4,1x,i4,a1)') 'Run Max Cv', cv_max, 'at (i, j, k) = (', cv_loc(1), cv_loc(2), cv_loc(3), ')'156 WRITE(numout,FMT='(12x,a8,11x,f7.1)') ' => dt/C', dt*(1.0/cv_max)157 WRITE(numout,FMT='(12x,a12,7x,f6.4,5x,a16,i4,1x,i4,1x,i4,a1)') 'Run Max Cw', cw_max, 'at (i, j, k) = (', cw_loc(1), cw_loc(2), cw_loc(3), ')'158 WRITE(numout,FMT='(12x,a8,11x,f7.1)') ' => dt/C', dt*(1.0/cw_max)159 160 ENDIF161 162 IF( nn_timing == 1 ) CALL timing_stop('dia_cfl')163 ENDIF164 165 END SUBROUTINE dia_cfl166 144 167 145 SUBROUTINE dia_cfl_init … … 171 149 !! ** Purpose : create output file, initialise arrays 172 150 !!---------------------------------------------------------------------- 173 174 175 IF( nn_diacfl == 1 ) THEN 176 IF( nn_timing == 1 ) CALL timing_start('dia_cfl_init') 177 178 cu_max=0.0 179 cv_max=0.0 180 cw_max=0.0 181 182 ALLOCATE( zcu_cfl(jpi, jpj, jpk), zcv_cfl(jpi, jpj, jpk), zcw_cfl(jpi, jpj, jpk) ) 183 184 zcu_cfl(:,:,:)=0.0 185 zcv_cfl(:,:,:)=0.0 186 zcw_cfl(:,:,:)=0.0 187 188 IF( lwp ) THEN 189 WRITE(numout,*) 190 WRITE(numout,*) 'dia_cfl : Outputting CFL diagnostics to '//TRIM(clname) 191 WRITE(numout,*) '~~~~~~~~~~~~' 192 WRITE(numout,*) 193 194 ! create output ascii file 195 CALL ctl_opn( numcfl, clname, 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', 1, numout, lwp, 1 ) 196 WRITE(numcfl,*) 'Timestep Direction Max C i j k' 197 WRITE(numcfl,*) '******************************************' 198 ENDIF 199 200 IF( nn_timing == 1 ) CALL timing_stop('dia_cfl_init') 201 151 ! 152 IF(lwp) THEN 153 WRITE(numout,*) 154 WRITE(numout,*) 'dia_cfl : Outputting CFL diagnostics to ',TRIM(clname), ' file' 155 WRITE(numout,*) '~~~~~~~' 156 WRITE(numout,*) 157 ! 158 ! create output ascii file 159 CALL ctl_opn( numcfl, clname, 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', 1, numout, lwp, 1 ) 160 WRITE(numcfl,*) 'Timestep Direction Max C i j k' 161 WRITE(numcfl,*) '******************************************' 202 162 ENDIF 203 163 ! 164 rCu_max = 0._wp 165 rCv_max = 0._wp 166 rCw_max = 0._wp 167 ! 168 !!gm required to work 169 ALLOCATE ( zCu_cfl(jpi,jpj,jpk), zCv_cfl(jpi,jpj,jpk), zCw_cfl(jpi,jpj,jpk) ) 170 !!gm end 171 ! 204 172 END SUBROUTINE dia_cfl_init 205 173 174 !!====================================================================== 206 175 END MODULE diacfl -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DOM/daymod.F90
r7646 r8568 222 222 !!---------------------------------------------------------------------- 223 223 ! 224 IF( nn_timing == 1 )CALL timing_start('day')224 IF( ln_timing ) CALL timing_start('day') 225 225 ! 226 226 zprec = 0.1 / rday … … 276 276 IF( lrst_oce ) CALL day_rst( kt, 'WRITE' ) ! write day restart information 277 277 ! 278 IF( nn_timing == 1 )CALL timing_stop('day')278 IF( ln_timing ) CALL timing_stop('day') 279 279 ! 280 280 END SUBROUTINE day … … 402 402 CALL iom_rstput( kt, nitrst, numrow, 'adatrj' , adatrj ) ! number of elapsed days since 403 403 ! ! the begining of the run [s] 404 CALL iom_rstput( kt, nitrst, numrow, 'ntime' , REAL( nn_time0, wp) ) ! time404 CALL iom_rstput( kt, nitrst, numrow, 'ntime' , REAL( nn_time0, wp) ) ! time 405 405 ENDIF 406 406 ! -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DOM/depth_e3.F90
r7753 r8568 20 20 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 21 21 USE lib_mpp ! distributed memory computing library 22 USE wrk_nemo ! Memory allocation23 22 USE timing ! Timing 24 23 -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DOM/domain.F90
r7822 r8568 45 45 USE lbclnk ! ocean lateral boundary condition (or mpp link) 46 46 USE lib_mpp ! distributed memory computing library 47 USE wrk_nemo ! Memory Allocation48 47 USE timing ! Timing 49 48 … … 83 82 !!---------------------------------------------------------------------- 84 83 ! 85 IF( nn_timing == 1) CALL timing_start('dom_init')84 IF( ln_timing ) CALL timing_start('dom_init') 86 85 ! 87 86 IF(lwp) THEN ! Ocean domain Parameters (control print) … … 199 198 IF( ln_write_cfg ) CALL cfg_write ! create the configuration file 200 199 ! 201 IF( nn_timing == 1) CALL timing_stop('dom_init')200 IF( ln_timing ) CALL timing_stop('dom_init') 202 201 ! 203 202 END SUBROUTINE dom_init -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DOM/domhgr.F90
r7753 r8568 79 79 !!---------------------------------------------------------------------- 80 80 ! 81 IF( nn_timing == 1 )CALL timing_start('dom_hgr')81 IF( ln_timing ) CALL timing_start('dom_hgr') 82 82 ! 83 83 IF(lwp) THEN … … 152 152 ! 153 153 ! 154 IF( nn_timing == 1 )CALL timing_stop('dom_hgr')154 IF( ln_timing ) CALL timing_stop('dom_hgr') 155 155 ! 156 156 END SUBROUTINE dom_hgr -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DOM/dommsk.F90
r7753 r8568 30 30 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 31 31 USE lib_mpp ! Massively Parallel Processing library 32 USE wrk_nemo ! Memory allocation33 32 USE timing ! Timing 34 33 … … 92 91 INTEGER :: iktop, ikbot ! - - 93 92 INTEGER :: ios, inum 94 REAL(wp), POINTER, DIMENSION(:,:) :: zwf ! 2D workspace93 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zwf ! 2D workspace 95 94 !! 96 95 NAMELIST/namlbc/ rn_shlat, ln_vorlat … … 104 103 !!--------------------------------------------------------------------- 105 104 ! 106 IF( nn_timing == 1 )CALL timing_start('dom_msk')105 IF( ln_timing ) CALL timing_start('dom_msk') 107 106 ! 108 107 REWIND( numnam_ref ) ! Namelist namlbc in reference namelist : Lateral momentum boundary condition … … 248 247 IF( rn_shlat /= 0 ) THEN ! Not free-slip lateral boundary condition 249 248 ! 250 CALL wrk_alloc( jpi,jpj, zwf)249 ALLOCATE( zwf(jpi,jpj) ) 251 250 ! 252 251 DO jk = 1, jpk … … 278 277 END DO 279 278 ! 280 CALL wrk_dealloc( jpi,jpj,zwf )279 DEALLOCATE( zwf ) 281 280 ! 282 281 CALL lbc_lnk( fmask, 'F', 1._wp ) ! Lateral boundary conditions on fmask … … 292 291 ! 293 292 ! 294 IF( nn_timing == 1 )CALL timing_stop('dom_msk')293 IF( ln_timing ) CALL timing_stop('dom_msk') 295 294 ! 296 295 END SUBROUTINE dom_msk -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DOM/domngb.F90
r7646 r8568 11 11 !!---------------------------------------------------------------------- 12 12 USE dom_oce ! ocean space and time domain 13 ! 13 14 USE in_out_manager ! I/O manager 14 15 USE lib_mpp ! for mppsum 15 USE wrk_nemo ! Memory allocation16 16 USE timing ! Timing 17 17 … … 45 45 INTEGER , DIMENSION(2) :: iloc 46 46 REAL(wp) :: zlon, zmini 47 REAL(wp), POINTER, DIMENSION(:,:) ::zglam, zgphi, zmask, zdist47 REAL(wp), DIMENSION(jpi,jpj) :: zglam, zgphi, zmask, zdist 48 48 !!-------------------------------------------------------------------- 49 49 ! 50 IF( nn_timing == 1 ) CALL timing_start('dom_ngb') 51 ! 52 CALL wrk_alloc( jpi,jpj, zglam, zgphi, zmask, zdist ) 50 IF( ln_timing ) CALL timing_start('dom_ngb') 53 51 ! 54 52 zmask(:,:) = 0._wp … … 79 77 ENDIF 80 78 ! 81 CALL wrk_dealloc( jpi,jpj, zglam, zgphi, zmask, zdist ) 82 ! 83 IF( nn_timing == 1 ) CALL timing_stop('dom_ngb') 79 IF( ln_timing ) CALL timing_stop('dom_ngb') 84 80 ! 85 81 END SUBROUTINE dom_ngb -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DOM/domvvl.F90
r7753 r8568 6 6 !! History : 2.0 ! 2006-06 (B. Levier, L. Marie) original code 7 7 !! 3.1 ! 2009-02 (G. Madec, M. Leclair, R. Benshila) pure z* coordinate 8 !! 3.3 ! 2011-10 (M. Leclair) totally rewrote domvvl: 9 !! vvl option includes z_star and z_tilde coordinates 8 !! 3.3 ! 2011-10 (M. Leclair) totally rewrote domvvl: vvl option includes z_star and z_tilde coordinates 10 9 !! 3.6 ! 2014-11 (P. Mathiot) add ice shelf capability 11 10 !!---------------------------------------------------------------------- … … 31 30 USE lib_mpp ! distributed memory computing library 32 31 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 33 USE wrk_nemo ! Memory allocation34 32 USE timing ! Timing 35 33 … … 122 120 !!---------------------------------------------------------------------- 123 121 ! 124 IF( nn_timing == 1) CALL timing_start('dom_vvl_init')122 IF( ln_timing ) CALL timing_start('dom_vvl_init') 125 123 ! 126 124 IF(lwp) WRITE(numout,*) … … 242 240 ENDIF 243 241 ! 244 IF( nn_timing == 1 )CALL timing_stop('dom_vvl_init')242 IF( ln_timing ) CALL timing_stop('dom_vvl_init') 245 243 ! 246 244 END SUBROUTINE dom_vvl_init … … 276 274 REAL(wp) :: z2dt, z_tmin, z_tmax ! local scalars 277 275 LOGICAL :: ll_do_bclinic ! local logical 278 REAL(wp), POINTER, DIMENSION(:,:,:) :: ze3t279 REAL(wp), POINTER, DIMENSION(:,: ) :: zht, z_scale, zwu, zwv, zhdiv276 REAL(wp), DIMENSION(jpi,jpj) :: zht, z_scale, zwu, zwv, zhdiv 277 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t 280 278 !!---------------------------------------------------------------------- 281 279 ! 282 280 IF( ln_linssh ) RETURN ! No calculation in linear free surface 283 281 ! 284 IF( nn_timing == 1 ) CALL timing_start('dom_vvl_sf_nxt') 285 ! 286 CALL wrk_alloc( jpi,jpj,zht, z_scale, zwu, zwv, zhdiv ) 287 CALL wrk_alloc( jpi,jpj,jpk, ze3t ) 288 282 IF( ln_timing ) CALL timing_start('dom_vvl_sf_nxt') 283 ! 289 284 IF( kt == nit000 ) THEN 290 285 IF(lwp) WRITE(numout,*) … … 543 538 r1_hv_a(:,:) = ssvmask(:,:) / ( hv_a(:,:) + 1._wp - ssvmask(:,:) ) 544 539 ! 545 CALL wrk_dealloc( jpi,jpj, zht, z_scale, zwu, zwv, zhdiv ) 546 CALL wrk_dealloc( jpi,jpj,jpk, ze3t ) 547 ! 548 IF( nn_timing == 1 ) CALL timing_stop('dom_vvl_sf_nxt') 540 IF( ln_timing ) CALL timing_stop('dom_vvl_sf_nxt') 549 541 ! 550 542 END SUBROUTINE dom_vvl_sf_nxt … … 583 575 IF( ln_linssh ) RETURN ! No calculation in linear free surface 584 576 ! 585 IF( nn_timing == 1 )CALL timing_start('dom_vvl_sf_swp')577 IF( ln_timing ) CALL timing_start('dom_vvl_sf_swp') 586 578 ! 587 579 IF( kt == nit000 ) THEN … … 657 649 ! write restart file 658 650 ! ================== 659 IF( lrst_oce ) CALL dom_vvl_rst( kt, 'WRITE' )660 ! 661 IF( nn_timing == 1) CALL timing_stop('dom_vvl_sf_swp')651 IF( lrst_oce ) CALL dom_vvl_rst( kt, 'WRITE' ) 652 ! 653 IF( ln_timing ) CALL timing_stop('dom_vvl_sf_swp') 662 654 ! 663 655 END SUBROUTINE dom_vvl_sf_swp … … 683 675 !!---------------------------------------------------------------------- 684 676 ! 685 IF( nn_timing == 1) CALL timing_start('dom_vvl_interpol')677 IF( ln_timing ) CALL timing_start('dom_vvl_interpol') 686 678 ! 687 679 IF(ln_wd) THEN … … 770 762 END SELECT 771 763 ! 772 IF( nn_timing == 1) CALL timing_stop('dom_vvl_interpol')764 IF( ln_timing ) CALL timing_stop('dom_vvl_interpol') 773 765 ! 774 766 END SUBROUTINE dom_vvl_interpol … … 794 786 !!---------------------------------------------------------------------- 795 787 ! 796 IF( nn_timing == 1 ) CALL timing_start('dom_vvl_rst') 788 IF( ln_timing ) CALL timing_start('dom_vvl_rst') 789 ! 797 790 IF( TRIM(cdrw) == 'READ' ) THEN ! Read/initialise 798 791 ! ! =============== … … 947 940 ENDIF 948 941 ! 949 IF( nn_timing == 1 )CALL timing_stop('dom_vvl_rst')942 IF( ln_timing ) CALL timing_stop('dom_vvl_rst') 950 943 ! 951 944 END SUBROUTINE dom_vvl_rst -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DOM/domwri.F90
r7646 r8568 24 24 USE lbclnk ! lateral boundary conditions - mpp exchanges 25 25 USE lib_mpp ! MPP library 26 USE wrk_nemo ! Memory allocation27 26 USE timing ! Timing 28 27 … … 75 74 INTEGER :: izco, izps, isco, icav 76 75 ! 77 REAL(wp), POINTER, DIMENSION(:,:) :: zprt, zprw ! 2D workspace 78 REAL(wp), POINTER, DIMENSION(:,:,:) :: zdepu, zdepv ! 3D workspace 79 !!---------------------------------------------------------------------- 80 ! 81 IF( nn_timing == 1 ) CALL timing_start('dom_wri') 82 ! 83 CALL wrk_alloc( jpi,jpj, zprt , zprw ) 84 CALL wrk_alloc( jpi,jpj,jpk, zdepu, zdepv ) 76 REAL(wp), DIMENSION(jpi,jpj) :: zprt, zprw ! 2D workspace 77 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdepu, zdepv ! 3D workspace 78 !!---------------------------------------------------------------------- 79 ! 80 IF( ln_timing ) CALL timing_start('dom_wri') 85 81 ! 86 82 IF(lwp) WRITE(numout,*) … … 206 202 ! ! ============================ 207 203 ! 208 CALL wrk_dealloc( jpi, jpj, zprt, zprw ) 209 CALL wrk_dealloc( jpi, jpj, jpk, zdepu, zdepv ) 210 ! 211 IF( nn_timing == 1 ) CALL timing_stop('dom_wri') 204 IF( ln_timing ) CALL timing_stop('dom_wri') 212 205 ! 213 206 END SUBROUTINE dom_wri … … 229 222 INTEGER :: ji ! dummy loop indices 230 223 LOGICAL, DIMENSION(SIZE(puniq,1),SIZE(puniq,2),1) :: lldbl ! store whether each point is unique or not 231 REAL(wp), POINTER, DIMENSION(:,:) :: ztstref 232 !!---------------------------------------------------------------------- 233 ! 234 IF( nn_timing == 1 ) CALL timing_start('dom_uniq') 235 ! 236 CALL wrk_alloc( jpi, jpj, ztstref ) 224 REAL(wp), DIMENSION(jpi,jpj) :: ztstref 225 !!---------------------------------------------------------------------- 226 ! 227 IF( ln_timing ) CALL timing_start('dom_uniq') 237 228 ! 238 229 ! build an array with different values for each element … … 250 241 puniq(nldi:nlei,nldj:nlej) = REAL( COUNT( lldbl(nldi:nlei,nldj:nlej,:), dim = 3 ) , wp ) 251 242 ! 252 CALL wrk_dealloc( jpi, jpj, ztstref ) 253 ! 254 IF( nn_timing == 1 ) CALL timing_stop('dom_uniq') 243 IF( ln_timing ) CALL timing_stop('dom_uniq') 255 244 ! 256 245 END SUBROUTINE dom_uniq -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DOM/domzgr.F90
r7753 r8568 36 36 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 37 37 USE lib_mpp ! distributed memory computing library 38 USE wrk_nemo ! Memory allocation39 38 USE timing ! Timing 40 39 … … 77 76 !!---------------------------------------------------------------------- 78 77 ! 79 IF( nn_timing == 1) CALL timing_start('dom_zgr')78 IF( ln_timing ) CALL timing_start('dom_zgr') 80 79 ! 81 80 IF(lwp) THEN ! Control print … … 164 163 ENDIF 165 164 ! 166 IF( nn_timing == 1 )CALL timing_stop('dom_zgr')165 IF( ln_timing ) CALL timing_stop('dom_zgr') 167 166 ! 168 167 END SUBROUTINE dom_zgr … … 284 283 ! 285 284 INTEGER :: ji, jj ! dummy loop indices 286 REAL(wp), POINTER, DIMENSION(:,:) :: zk 287 !!---------------------------------------------------------------------- 288 ! 289 IF( nn_timing == 1 ) CALL timing_start('zgr_top_bot') 290 ! 291 CALL wrk_alloc( jpi,jpj, zk ) 285 REAL(wp), DIMENSION(jpi,jpj) :: zk ! workspace 286 !!---------------------------------------------------------------------- 287 ! 288 IF( ln_timing ) CALL timing_start('zgr_top_bot') 292 289 ! 293 290 IF(lwp) WRITE(numout,*) … … 319 316 zk(:,:) = REAL( mbkv(:,:), wp ) ; CALL lbc_lnk( zk, 'V', 1. ) ; mbkv(:,:) = MAX( INT( zk(:,:) ), 1 ) 320 317 ! 321 CALL wrk_dealloc( jpi,jpj, zk ) 322 ! 323 IF( nn_timing == 1 ) CALL timing_stop('zgr_top_bot') 318 IF( ln_timing ) CALL timing_stop('zgr_top_bot') 324 319 ! 325 320 END SUBROUTINE zgr_top_bot -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DOM/dtatsd.F90
r7753 r8568 16 16 !!---------------------------------------------------------------------- 17 17 USE oce ! ocean dynamics and tracers 18 USE phycst ! physical constants 18 19 USE dom_oce ! ocean space and time domain 19 20 USE fldread ! read input fields 21 ! 20 22 USE in_out_manager ! I/O manager 21 USE phycst ! physical constants22 23 USE lib_mpp ! MPP library 23 USE wrk_nemo ! Memory allocation24 24 USE timing ! Timing 25 25 … … 62 62 !!---------------------------------------------------------------------- 63 63 ! 64 IF( nn_timing == 1 )CALL timing_start('dta_tsd_init')64 IF( ln_timing ) CALL timing_start('dta_tsd_init') 65 65 ! 66 66 ! Initialisation … … 120 120 ENDIF 121 121 ! 122 IF( nn_timing == 1 )CALL timing_stop('dta_tsd_init')122 IF( ln_timing ) CALL timing_stop('dta_tsd_init') 123 123 ! 124 124 END SUBROUTINE dta_tsd_init … … 145 145 INTEGER :: ji, jj, jk, jl, jkk ! dummy loop indicies 146 146 INTEGER :: ik, il0, il1, ii0, ii1, ij0, ij1 ! local integers 147 REAL(wp):: zl, zi 148 REAL(wp), POINTER, DIMENSION(:) :: ztp, zsp ! 1D workspace149 !!---------------------------------------------------------------------- 150 ! 151 IF( nn_timing == 1 )CALL timing_start('dta_tsd')147 REAL(wp):: zl, zi ! local scalars 148 REAL(wp), DIMENSION(jpk) :: ztp, zsp ! 1D workspace 149 !!---------------------------------------------------------------------- 150 ! 151 IF( ln_timing ) CALL timing_start('dta_tsd') 152 152 ! 153 153 CALL fld_read( kt, 1, sf_tsd ) !== read T & S data at kt time step ==! … … 185 185 ! 186 186 IF( ln_sco ) THEN !== s- or mixed s-zps-coordinate ==! 187 !188 CALL wrk_alloc( jpk, ztp, zsp )189 187 ! 190 188 IF( kt == nit000 .AND. lwp )THEN … … 222 220 END DO 223 221 ! 224 CALL wrk_dealloc( jpk, ztp, zsp )225 !226 222 ELSE !== z- or zps- coordinate ==! 227 223 ! … … 260 256 ENDIF 261 257 ! 262 IF( nn_timing == 1 )CALL timing_stop('dta_tsd')258 IF( ln_timing ) CALL timing_stop('dta_tsd') 263 259 ! 264 260 END SUBROUTINE dta_tsd -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DOM/iscplhsb.F90
r7646 r8568 13 13 !! iscpl_div : correction of divergence to keep volume conservation 14 14 !!---------------------------------------------------------------------- 15 USE oce ! global tra/dyn variable 15 16 USE dom_oce ! ocean space and time domain 16 17 USE domwri ! ocean space and time domain 18 USE domngb ! 17 19 USE phycst ! physical constants 18 20 USE sbc_oce ! surface boundary condition variables 19 USE oce ! global tra/dyn variable 21 USE iscplini ! 22 ! 20 23 USE in_out_manager ! I/O manager 21 24 USE lib_mpp ! MPP library 22 25 USE lib_fortran ! MPP library 23 USE wrk_nemo ! Memory allocation24 26 USE lbclnk ! 25 USE domngb !26 USE iscplini27 27 28 28 IMPLICIT NONE … … 56 56 REAL(wp), DIMENSION(:,:,: ), INTENT(out) :: pvol_flx !! corrective flux to have volume conservation 57 57 REAL(wp), INTENT(in ) :: prdt_iscpl !! coupling period 58 !! 59 INTEGER :: ji, jj, jk !! loop index 60 INTEGER :: jip1, jim1, jjp1, jjm1 61 !! 62 REAL(wp):: summsk, zsum, zsum1, zarea, zsumn, zsumb 63 REAL(wp):: r1_rdtiscpl 64 REAL(wp):: zjip1_ratio , zjim1_ratio , zjjp1_ratio , zjjm1_ratio 65 !! 66 REAL(wp):: zde3t, zdtem, zdsal 67 REAL(wp), DIMENSION(:,:), POINTER :: zdssh 68 !! 69 REAL(wp), DIMENSION(:), ALLOCATABLE :: zlon, zlat 70 REAL(wp), DIMENSION(:), ALLOCATABLE :: zcorr_vol, zcorr_tem, zcorr_sal 71 INTEGER , DIMENSION(:), ALLOCATABLE :: ixpts, iypts, izpts, inpts 58 ! 59 INTEGER :: ji , jj , jk ! loop index 60 INTEGER :: jip1, jim1, jjp1, jjm1 61 REAL(wp) :: summsk, zsum , zsumn, zjip1_ratio , zjim1_ratio, zdtem, zde3t, z1_rdtiscpl 62 REAL(wp) :: zarea , zsum1, zsumb, zjjp1_ratio , zjjm1_ratio, zdsal 63 REAL(wp), DIMENSION(jpi,jpj) :: zdssh ! workspace 64 REAL(wp), DIMENSION(:), ALLOCATABLE :: zlon, zlat 65 REAL(wp), DIMENSION(:), ALLOCATABLE :: zcorr_vol, zcorr_tem, zcorr_sal 66 INTEGER , DIMENSION(:), ALLOCATABLE :: ixpts, iypts, izpts, inpts 72 67 INTEGER :: jpts, npts 73 74 CALL wrk_alloc(jpi,jpj, zdssh ) 68 !!---------------------------------------------------------------------- 75 69 76 70 ! get imbalance (volume heat and salt) 77 71 ! initialisation difference 78 zde3t = 0. 0_wp; zdsal = 0.0_wp ; zdtem = 0.0_wp72 zde3t = 0._wp ; zdsal = 0._wp ; zdtem = 0._wp 79 73 80 74 ! initialisation correction term 81 pvol_flx(:,:,: ) = 0. 0_wp82 pts_flx (:,:,:,:) = 0. 0_wp75 pvol_flx(:,:,: ) = 0._wp 76 pts_flx (:,:,:,:) = 0._wp 83 77 84 r1_rdtiscpl = 1._wp / prdt_iscpl78 z1_rdtiscpl = 1._wp / prdt_iscpl 85 79 86 80 ! mask tsn and tsb 87 tsb(:,:,:,jp_tem)=tsb(:,:,:,jp_tem)*ptmask_b(:,:,:); tsn(:,:,:,jp_tem)=tsn(:,:,:,jp_tem)*tmask(:,:,:); 88 tsb(:,:,:,jp_sal)=tsb(:,:,:,jp_sal)*ptmask_b(:,:,:); tsn(:,:,:,jp_sal)=tsn(:,:,:,jp_sal)*tmask(:,:,:); 81 tsb(:,:,:,jp_tem) = tsb(:,:,:,jp_tem) * ptmask_b(:,:,:) 82 tsn(:,:,:,jp_tem) = tsn(:,:,:,jp_tem) * tmask (:,:,:) 83 tsb(:,:,:,jp_sal) = tsb(:,:,:,jp_sal) * ptmask_b(:,:,:) 84 tsn(:,:,:,jp_sal) = tsn(:,:,:,jp_sal) * tmask (:,:,:) 89 85 90 86 !============================================================================== … … 118 114 119 115 ! volume, heat and salt differences in each cell 120 pvol_flx(ji,jj,jk) = pvol_flx(ji,jj,jk) + zde3t * r1_rdtiscpl121 pts_flx (ji,jj,jk,jp_sal)= pts_flx (ji,jj,jk,jp_sal) + zdsal * r1_rdtiscpl122 pts_flx (ji,jj,jk,jp_tem)= pts_flx (ji,jj,jk,jp_tem) + zdtem * r1_rdtiscpl116 pvol_flx(ji,jj,jk) = pvol_flx(ji,jj,jk) + zde3t * z1_rdtiscpl 117 pts_flx (ji,jj,jk,jp_sal)= pts_flx (ji,jj,jk,jp_sal) + zdsal * z1_rdtiscpl 118 pts_flx (ji,jj,jk,jp_tem)= pts_flx (ji,jj,jk,jp_tem) + zdtem * z1_rdtiscpl 123 119 124 120 ! case where we close a cell: check if the neighbour cells are wet … … 190 186 ! if no neighbour wet cell in case of 2close a cell", need to find the nearest wet point 191 187 ! allocation and initialisation of the list of problematic point 192 ALLOCATE( inpts(jpnij))193 inpts(:) =0188 ALLOCATE( inpts(jpnij) ) 189 inpts(:) = 0 194 190 195 191 ! fill narea location with the number of problematic point … … 287 283 CALL lbc_sum(pts_flx (:,:,:,jp_sal),'T',1._wp) 288 284 CALL lbc_sum(pts_flx (:,:,:,jp_tem),'T',1._wp) 289 290 ! deallocate variables 291 CALL wrk_dealloc(jpi,jpj, zdssh ) 292 285 ! 293 286 END SUBROUTINE iscpl_cons 287 294 288 295 289 SUBROUTINE iscpl_div( phdivn ) -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DOM/iscplini.F90
r7646 r8568 11 11 !! iscpl_alloc : allocation of correction variables 12 12 !!---------------------------------------------------------------------- 13 USE oce ! global tra/dyn variable 13 14 USE dom_oce ! ocean space and time domain 14 USE oce ! global tra/dyn variable15 ! 15 16 USE lib_mpp ! MPP library 16 17 USE lib_fortran ! MPP library … … 47 48 END FUNCTION iscpl_alloc 48 49 50 49 51 SUBROUTINE iscpl_init() 52 !!---------------------------------------------------------------------- 50 53 INTEGER :: ios ! Local integer output status for namelist read 51 NAMELIST/namsbc_iscpl/ nn_fiscpl,ln_hsb,nn_drown54 NAMELIST/namsbc_iscpl/ nn_fiscpl, ln_hsb, nn_drown 52 55 !!---------------------------------------------------------------------- 53 ! ! ============54 ! ! Namelist55 ! ! ============56 56 ! 57 57 nn_fiscpl = 0 … … 79 79 WRITE(numout,*) ' coupling time step = ', rdt_iscpl 80 80 WRITE(numout,*) ' number of call of the extrapolation loop = ', nn_drown 81 END 82 81 ENDIF 82 ! 83 83 END SUBROUTINE iscpl_init 84 84 85 !!====================================================================== 85 86 END MODULE iscplini -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DOM/iscplrst.F90
r7646 r8568 11 11 !! iscpl_rst_interpol : restart interpolation in case of coupling with ice sheet 12 12 !!---------------------------------------------------------------------- 13 USE oce ! global tra/dyn variable 13 14 USE dom_oce ! ocean space and time domain 14 15 USE domwri ! ocean space and time domain 15 USE domvvl , ONLY : dom_vvl_interpol16 USE domvvl , ONLY : dom_vvl_interpol 16 17 USE phycst ! physical constants 17 18 USE sbc_oce ! surface boundary condition variables 18 USE oce ! global tra/dyn variable 19 USE iscplini ! ice sheet coupling: initialisation 20 USE iscplhsb ! ice sheet coupling: conservation 21 ! 19 22 USE in_out_manager ! I/O manager 20 23 USE iom ! I/O module 21 24 USE lib_mpp ! MPP library 22 25 USE lib_fortran ! MPP library 23 USE wrk_nemo ! Memory allocation24 26 USE lbclnk ! communication 25 USE iscplini ! ice sheet coupling: initialisation26 USE iscplhsb ! ice sheet coupling: conservation27 27 28 28 IMPLICIT NONE … … 50 50 !!---------------------------------------------------------------------- 51 51 INTEGER :: inum0 52 REAL(wp), DIMENSION( :,: ), POINTER:: zsmask_b53 REAL(wp), DIMENSION( :,:,:), POINTER:: ztmask_b, zumask_b, zvmask_b54 REAL(wp), DIMENSION( :,:,:), POINTER:: ze3t_b , ze3u_b , ze3v_b55 REAL(wp), DIMENSION( :,:,:), POINTER:: zdepw_b52 REAL(wp), DIMENSION(jpi,jpj) :: zsmask_b 53 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztmask_b, zumask_b, zvmask_b 54 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t_b , ze3u_b , ze3v_b 55 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdepw_b 56 56 CHARACTER(20) :: cfile 57 57 !!---------------------------------------------------------------------- 58 59 CALL wrk_alloc(jpi,jpj,jpk, ztmask_b, zumask_b, zvmask_b) ! mask before 60 CALL wrk_alloc(jpi,jpj,jpk, ze3t_b , ze3u_b , ze3v_b ) ! e3 before 61 CALL wrk_alloc(jpi,jpj,jpk, zdepw_b ) 62 CALL wrk_alloc(jpi,jpj, zsmask_b ) 63 64 65 !! get restart variable 58 ! 59 ! ! get restart variable 66 60 CALL iom_get( numror, jpdom_autoglo, 'tmask' , ztmask_b ) ! need to extrapolate T/S 67 61 CALL iom_get( numror, jpdom_autoglo, 'umask' , zumask_b ) ! need to correct barotropic velocity … … 72 66 CALL iom_get( numror, jpdom_autoglo, 'e3v_n' , ze3v_b(:,:,:) ) ! need to correct barotropic velocity 73 67 CALL iom_get( numror, jpdom_autoglo, 'gdepw_n', zdepw_b(:,:,:) ) ! need to interpol vertical profile (vvl) 74 75 !! read namelist 76 CALL iscpl_init() 77 78 !! ! Extrapolation/interpolation of modify cell and new cells ... (maybe do it later after domvvl) 68 ! 69 CALL iscpl_init() ! read namelist 70 ! ! Extrapolation/interpolation of modify cell and new cells ... (maybe do it later after domvvl) 79 71 CALL iscpl_rst_interpol( ztmask_b, zumask_b, zvmask_b, zsmask_b, ze3t_b, ze3u_b, ze3v_b, zdepw_b ) 80 81 !! compute correction if conservation needed 82 IF ( ln_hsb ) THEN 72 ! 73 IF ( ln_hsb ) THEN ! compute correction if conservation needed 83 74 IF( iscpl_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'rst_iscpl : unable to allocate rst_iscpl arrays' ) 84 75 CALL iscpl_cons(ztmask_b, zsmask_b, ze3t_b, htsc_iscpl, hdiv_iscpl, rdt_iscpl) 85 76 END IF 86 77 87 ! ! print mesh/mask88 IF( nn_msh /= 0 .AND. ln_iscpl ) CALL dom_wri ! Create a domain file89 78 ! ! create a domain file 79 IF( nn_msh /= 0 .AND. ln_iscpl ) CALL dom_wri 80 ! 90 81 IF ( ln_hsb ) THEN 91 82 cfile='correction' … … 97 88 CALL iom_close ( inum0 ) 98 89 END IF 99 100 CALL wrk_dealloc(jpi,jpj,jpk, ztmask_b,zumask_b,zvmask_b ) 101 CALL wrk_dealloc(jpi,jpj,jpk, ze3t_b ,ze3u_b ,ze3v_b ) 102 CALL wrk_dealloc(jpi,jpj,jpk, zdepw_b ) 103 CALL wrk_dealloc(jpi,jpj, zsmask_b ) 104 105 !! next step is an euler time step 106 neuler = 0 107 108 !! set _b and _n variables equal 90 ! 91 neuler = 0 ! next step is an euler time step 92 ! 93 ! ! set _b and _n variables equal 109 94 tsb (:,:,:,:) = tsn (:,:,:,:) 110 95 ub (:,:,:) = un (:,:,:) 111 96 vb (:,:,:) = vn (:,:,:) 112 97 sshb(:,:) = sshn(:,:) 113 114 ! ! set _b and _n vertical scale factor equal98 ! 99 ! ! set _b and _n vertical scale factor equal 115 100 e3t_b (:,:,:) = e3t_n (:,:,:) 116 101 e3u_b (:,:,:) = e3u_n (:,:,:) 117 102 e3v_b (:,:,:) = e3v_n (:,:,:) 118 103 ! 119 104 e3uw_b (:,:,:) = e3uw_n (:,:,:) 120 105 e3vw_b (:,:,:) = e3vw_n (:,:,:) … … 150 135 REAL(wp):: zdz, zdzm1, zdzp1 151 136 !! 152 REAL(wp), DIMENSION(:,: ), POINTER :: zdmask , zdsmask, zvcorr, zucorr, zde3t 153 REAL(wp), DIMENSION(:,: ), POINTER :: zbub , zbvb , zbun , zbvn 154 REAL(wp), DIMENSION(:,: ), POINTER :: zssh0 , zssh1, zhu1, zhv1 155 REAL(wp), DIMENSION(:,: ), POINTER :: zsmask0, zsmask1 156 REAL(wp), DIMENSION(:,:,: ), POINTER :: ztmask0, ztmask1, ztrp 157 REAL(wp), DIMENSION(:,:,: ), POINTER :: zwmaskn, zwmaskb, ztmp3d 158 REAL(wp), DIMENSION(:,:,:,:), POINTER :: zts0 137 REAL(wp), DIMENSION(jpi,jpj) :: zdmask , zsmask0, zucorr, zbub, zbun, zssh0, zhu1, zde3t 138 REAL(wp), DIMENSION(jpi,jpj) :: zdsmask, zsmask1, zvcorr, zbvb, zbvn, zssh1, zhv1 139 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztmask0, zwmaskn, ztrp 140 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztmask1, zwmaskb, ztmp3d 141 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) :: zts0 159 142 !!---------------------------------------------------------------------- 160 161 !! allocate variables 162 CALL wrk_alloc(jpi,jpj,jpk,2, zts0 ) 163 CALL wrk_alloc(jpi,jpj,jpk, ztmask0, ztmask1 , ztrp, ztmp3d ) 164 CALL wrk_alloc(jpi,jpj,jpk, zwmaskn, zwmaskb ) 165 CALL wrk_alloc(jpi,jpj, zsmask0, zsmask1 ) 166 CALL wrk_alloc(jpi,jpj, zdmask , zdsmask, zvcorr, zucorr, zde3t) 167 CALL wrk_alloc(jpi,jpj, zbub , zbvb , zbun , zbvn ) 168 CALL wrk_alloc(jpi,jpj, zssh0 , zssh1, zhu1, zhv1 ) 169 170 !! mask value to be sure 143 ! 144 ! ! mask value to be sure 171 145 tsn(:,:,:,jp_tem) = tsn(:,:,:,jp_tem) * ptmask_b(:,:,:) 172 146 tsn(:,:,:,jp_sal) = tsn(:,:,:,jp_sal) * ptmask_b(:,:,:) 173 174 ! compute wmask147 ! 148 ! ! compute wmask 175 149 zwmaskn(:,:,1) = tmask (:,:,1) 176 150 zwmaskb(:,:,1) = ptmask_b(:,:,1) … … 179 153 zwmaskb(:,:,jk) = ptmask_b(:,:,jk) * ptmask_b(:,:,jk-1) 180 154 END DO 181 182 ! compute new ssh if we open a full water column (average of the closest neigbourgs)155 ! 156 ! ! compute new ssh if we open a full water column (average of the closest neigbourgs) 183 157 sshb (:,:)=sshn(:,:) 184 158 zssh0(:,:)=sshn(:,:) 185 159 zsmask0(:,:) = psmask_b(:,:) 186 160 zsmask1(:,:) = psmask_b(:,:) 187 DO iz = 1, 10! need to be tuned (configuration dependent) (OK for ISOMIP+)161 DO iz = 1, 10 ! need to be tuned (configuration dependent) (OK for ISOMIP+) 188 162 zdsmask(:,:) = ssmask(:,:)-zsmask0(:,:) 189 163 DO jj = 2,jpj-1 … … 198 172 & + zssh0(ji,jjm1)*zsmask0(ji,jjm1))/summsk 199 173 zsmask1(ji,jj)=1._wp 200 END 174 ENDIF 201 175 END DO 202 176 END DO 203 CALL lbc_lnk( sshn,'T',1._wp)204 CALL lbc_lnk( zsmask1,'T',1._wp)177 CALL lbc_lnk( sshn , 'T', 1._wp ) 178 CALL lbc_lnk( zsmask1, 'T', 1._wp ) 205 179 zssh0 = sshn 206 180 zsmask0 = zsmask1 … … 210 184 !============================================================================= 211 185 !PM: Is this needed since introduction of VVL by default? 212 IF ( .NOT.ln_linssh) THEN186 IF ( .NOT.ln_linssh ) THEN 213 187 ! Reconstruction of all vertical scale factors at now time steps 214 188 ! ============================================================================= … … 224 198 END DO 225 199 END DO 226 200 ! 227 201 CALL dom_vvl_interpol( e3t_n(:,:,:), e3u_n(:,:,:), 'U' ) 228 202 CALL dom_vvl_interpol( e3t_n(:,:,:), e3v_n(:,:,:), 'V' ) 229 203 CALL dom_vvl_interpol( e3u_n(:,:,:), e3f_n(:,:,:), 'F' ) 230 204 231 ! Vertical scale factor interpolations232 ! ------------------------------------205 ! Vertical scale factor interpolations 206 ! ------------------------------------ 233 207 CALL dom_vvl_interpol( e3t_n(:,:,:), e3w_n (:,:,:), 'W' ) 234 208 CALL dom_vvl_interpol( e3u_n(:,:,:), e3uw_n(:,:,:), 'UW' ) 235 209 CALL dom_vvl_interpol( e3v_n(:,:,:), e3vw_n(:,:,:), 'VW' ) 236 237 ! t- and w- points depth238 ! ----------------------210 211 ! t- and w- points depth 212 ! ---------------------- 239 213 gdept_n(:,:,1) = 0.5_wp * e3w_n(:,:,1) 240 214 gdepw_n(:,:,1) = 0.0_wp … … 429 403 ! nothing to do 430 404 ! 431 ! deallocation tmp arrays432 CALL wrk_dealloc(jpi,jpj,jpk,2, zts0 )433 CALL wrk_dealloc(jpi,jpj,jpk, ztmask0, ztmask1 , ztrp )434 CALL wrk_dealloc(jpi,jpj,jpk, zwmaskn, zwmaskb , ztmp3d )435 CALL wrk_dealloc(jpi,jpj, zsmask0, zsmask1 )436 CALL wrk_dealloc(jpi,jpj, zdmask , zdsmask, zvcorr, zucorr, zde3t)437 CALL wrk_dealloc(jpi,jpj, zbub , zbvb , zbun , zbvn )438 CALL wrk_dealloc(jpi,jpj, zssh0 , zssh1 , zhu1 , zhv1 )439 !440 405 END SUBROUTINE iscpl_rst_interpol 441 406 -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DOM/istate.F90
r7753 r8568 36 36 USE lib_mpp ! MPP library 37 37 USE restart ! restart 38 USE wrk_nemo ! Memory allocation39 38 USE timing ! Timing 40 39 … … 60 59 !!---------------------------------------------------------------------- 61 60 INTEGER :: ji, jj, jk ! dummy loop indices 62 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: zuvd ! U & V data workspace 61 !!gm see comment further down 62 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: zuvd ! U & V data workspace 63 !!gm end 63 64 !!---------------------------------------------------------------------- 64 65 ! 65 IF( nn_timing == 1) CALL timing_start('istate_init')66 IF( ln_timing ) CALL timing_start('istate_init') 66 67 ! 67 68 IF(lwp) WRITE(numout,*) … … 121 122 !!gm to be moved in usrdef of C1D case 122 123 ! IF ( ln_uvd_init .AND. lk_c1d ) THEN ! read 3D U and V data at nit000 123 ! CALL wrk_alloc( jpi,jpj,jpk,2, zuvd)124 ! ALLOCATE( zuvd(jpi,jpj,jpk,2) ) 124 125 ! CALL dta_uvd( nit000, zuvd ) 125 126 ! ub(:,:,:) = zuvd(:,:,:,1) ; un(:,:,:) = ub(:,:,:) 126 127 ! vb(:,:,:) = zuvd(:,:,:,2) ; vn(:,:,:) = vb(:,:,:) 127 ! CALL wrk_dealloc( jpi,jpj,jpk,2,zuvd )128 ! DEALLOCATE( zuvd ) 128 129 ! ENDIF 129 130 ! … … 164 165 vb_b(:,:) = vb_b(:,:) * r1_hv_b(:,:) 165 166 ! 166 IF( nn_timing == 1) CALL timing_stop('istate_init')167 IF( ln_timing ) CALL timing_stop('istate_init') 167 168 ! 168 169 END SUBROUTINE istate_init -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DYN/divhor.F90
r7753 r8568 29 29 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 30 30 USE lib_mpp ! MPP library 31 USE wrk_nemo ! Memory Allocation32 31 USE timing ! Timing 33 32 … … 40 39 # include "vectopt_loop_substitute.h90" 41 40 !!---------------------------------------------------------------------- 42 !! NEMO/OPA 3.7 , NEMO Consortium (2014)41 !! NEMO/OPA 4.0 , NEMO Consortium (2017) 43 42 !! $Id$ 44 43 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 64 63 !!---------------------------------------------------------------------- 65 64 ! 66 IF( nn_timing == 1) CALL timing_start('div_hor')65 IF( ln_timing ) CALL timing_start('div_hor') 67 66 ! 68 67 IF( kt == nit000 ) THEN … … 75 74 DO jj = 2, jpjm1 76 75 DO ji = fs_2, fs_jpim1 ! vector opt. 77 hdivn(ji,jj,jk) = ( e2u(ji ,jj) * e3u_n(ji ,jj,jk) * un(ji ,jj,jk) 78 & - e2u(ji-1,jj) * e3u_n(ji-1,jj,jk) * un(ji-1,jj,jk) 79 & + e1v(ji,jj ) * e3v_n(ji,jj ,jk) * vn(ji,jj ,jk) 80 & - e1v(ji,jj-1) * e3v_n(ji,jj-1,jk) * vn(ji,jj-1,jk) )&81 & / ( e1e2t(ji,jj) * e3t_n(ji,jj,jk))76 hdivn(ji,jj,jk) = ( e2u(ji ,jj) * e3u_n(ji ,jj,jk) * un(ji ,jj,jk) & 77 & - e2u(ji-1,jj) * e3u_n(ji-1,jj,jk) * un(ji-1,jj,jk) & 78 & + e1v(ji,jj ) * e3v_n(ji,jj ,jk) * vn(ji,jj ,jk) & 79 & - e1v(ji,jj-1) * e3v_n(ji,jj-1,jk) * vn(ji,jj-1,jk) ) & 80 & * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 82 81 END DO 83 82 END DO … … 90 89 END DO 91 90 ! 92 IF( ln_rnf ) CALL sbc_rnf_div( hdivn ) !== runoffs ==! (update hdivn field)91 IF( ln_rnf ) CALL sbc_rnf_div( hdivn ) !== runoffs ==! (update hdivn field) 93 92 ! 94 IF( ln_isf ) CALL sbc_isf_div( hdivn ) !== ice shelf ==! (update hdivn field)93 IF( ln_isf ) CALL sbc_isf_div( hdivn ) !== ice shelf ==! (update hdivn field) 95 94 ! 96 IF( ln_iscpl .AND. ln_hsb ) CALL iscpl_div( hdivn )!== ice sheet ==! (update hdivn field)95 IF( ln_iscpl .AND. ln_hsb ) CALL iscpl_div( hdivn ) !== ice sheet ==! (update hdivn field) 97 96 ! 98 CALL lbc_lnk( hdivn, 'T', 1. ) !== lateral boundary cond. ==! (no sign change)97 CALL lbc_lnk( hdivn, 'T', 1. ) ! (no sign change) 99 98 ! 100 IF( nn_timing == 1 )CALL timing_stop('div_hor')99 IF( ln_timing ) CALL timing_stop('div_hor') 101 100 ! 102 101 END SUBROUTINE div_hor -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DYN/dynadv.F90
r7646 r8568 7 7 !! 3.3 ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase 8 8 !! 3.6 ! 2015-05 (N. Ducousso, G. Madec) add Hollingsworth scheme as an option 9 !! 4.0 ! 2017-07 (G. Madec) add a linear dynamics option 9 10 !!---------------------------------------------------------------------- 10 11 … … 30 31 31 32 ! !* namdyn_adv namelist * 32 LOGICAL, PUBLIC :: ln_dynadv_vec !: vector form flag 33 INTEGER, PUBLIC :: nn_dynkeg !: scheme of kinetic energy gradient: =0 C2 ; =1 Hollingsworth 33 LOGICAL, PUBLIC :: ln_dynadv_NONE !: linear dynamics (no momentum advection) 34 LOGICAL, PUBLIC :: ln_dynadv_vec !: vector form 35 INTEGER, PUBLIC :: nn_dynkeg !: scheme of grad(KE): =0 C2 ; =1 Hollingsworth 34 36 LOGICAL, PUBLIC :: ln_dynadv_cen2 !: flux form - 2nd order centered scheme flag 35 37 LOGICAL, PUBLIC :: ln_dynadv_ubs !: flux form - 3rd order UBS scheme flag 36 LOGICAL, PUBLIC :: ln_dynzad_zts !: vertical advection with sub-timestepping (requires vector form)37 38 38 INTEGER :: nadv ! choice of the formulation and scheme for the advection 39 INTEGER, PUBLIC :: n_dynadv !: choice of the formulation and scheme for momentum advection 40 ! ! associated indices: 41 INTEGER, PUBLIC, PARAMETER :: np_LIN_dyn = 0 ! no advection: linear dynamics 42 INTEGER, PUBLIC, PARAMETER :: np_VEC_c2 = 1 ! vector form : 2nd order centered scheme 43 INTEGER, PUBLIC, PARAMETER :: np_FLX_c2 = 2 ! flux form : 2nd order centered scheme 44 INTEGER, PUBLIC, PARAMETER :: np_FLX_ubs = 3 ! flux form : 3rd order Upstream Biased Scheme 39 45 40 46 !! * Substitutions 41 47 # include "vectopt_loop_substitute.h90" 42 48 !!---------------------------------------------------------------------- 43 !! NEMO/OPA 3.6 , NEMO Consortium (2015)49 !! NEMO/OPA 4.0 , NEMO Consortium (2017) 44 50 !! $Id$ 45 51 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 53 59 !! ** Purpose : compute the ocean momentum advection trend. 54 60 !! 55 !! ** Method : - Update (ua,va) with the advection term following nadv 61 !! ** Method : - Update (ua,va) with the advection term following n_dynadv 62 !! 56 63 !! NB: in flux form advection (ln_dynadv_cen2 or ln_dynadv_ubs=T) 57 64 !! a metric term is add to the coriolis term while in vector form … … 62 69 !!---------------------------------------------------------------------- 63 70 ! 64 IF( nn_timing == 1 ) CALL timing_start('dyn_adv')71 IF( ln_timing ) CALL timing_start( 'dyn_adv' ) 65 72 ! 66 SELECT CASE ( nadv ) ! compute advection trend and add it to general trend 67 CASE ( 0 ) 68 CALL dyn_keg ( kt, nn_dynkeg ) ! vector form : horizontal gradient of kinetic energy 69 CALL dyn_zad ( kt ) ! vector form : vertical advection 70 CASE ( 1 ) 71 CALL dyn_keg ( kt, nn_dynkeg ) ! vector form : horizontal gradient of kinetic energy 72 CALL dyn_zad_zts ( kt ) ! vector form : vertical advection with sub-timestepping 73 CASE ( 2 ) 74 CALL dyn_adv_cen2( kt ) ! 2nd order centered scheme 75 CASE ( 3 ) 76 CALL dyn_adv_ubs ( kt ) ! 3rd order UBS scheme 73 SELECT CASE( n_dynadv ) !== compute advection trend and add it to general trend ==! 74 CASE( np_VEC_c2 ) 75 CALL dyn_keg ( kt, nn_dynkeg ) ! vector form : horizontal gradient of kinetic energy 76 CALL dyn_zad ( kt ) ! vector form : vertical advection 77 CASE( np_FLX_c2 ) 78 CALL dyn_adv_cen2( kt ) ! 2nd order centered scheme 79 CASE( np_FLX_ubs ) 80 CALL dyn_adv_ubs ( kt ) ! 3rd order UBS scheme (UP3) 77 81 END SELECT 78 82 ! 79 IF( nn_timing == 1 ) CALL timing_stop('dyn_adv')83 IF( ln_timing ) CALL timing_stop( 'dyn_adv' ) 80 84 ! 81 85 END SUBROUTINE dyn_adv … … 87 91 !! 88 92 !! ** Purpose : Control the consistency between namelist options for 89 !! momentum advection formulation & scheme and set n adv93 !! momentum advection formulation & scheme and set n_dynadv 90 94 !!---------------------------------------------------------------------- 91 95 INTEGER :: ioptio, ios ! Local integer 92 96 ! 93 NAMELIST/namdyn_adv/ ln_dynadv_ vec, nn_dynkeg, ln_dynadv_cen2 , ln_dynadv_ubs, ln_dynzad_zts97 NAMELIST/namdyn_adv/ ln_dynadv_NONE, ln_dynadv_vec, nn_dynkeg, ln_dynadv_cen2, ln_dynadv_ubs 94 98 !!---------------------------------------------------------------------- 95 99 ! … … 108 112 WRITE(numout,*) '~~~~~~~~~~~~' 109 113 WRITE(numout,*) ' Namelist namdyn_adv : chose a advection formulation & scheme for momentum' 110 WRITE(numout,*) ' Vector/flux form (T/F) ln_dynadv_vec = ', ln_dynadv_vec111 WRITE(numout,*) ' = 0 standard scheme ; =1 Hollingsworth scheme nn_dynkeg = ', nn_dynkeg112 WRITE(numout,*) ' 2nd order centred advection scheme ln_dynadv_cen2 = ', ln_dynadv_cen2113 WRITE(numout,*) ' 3rd order UBS advection scheme ln_dynadv_ubs = ', ln_dynadv_ubs114 WRITE(numout,*) ' Sub timestepping of vertical advection ln_dynzad_zts = ', ln_dynzad_zts114 WRITE(numout,*) ' linear dynamics : no momentum advection ln_dynadv_NONE = ', ln_dynadv_NONE 115 WRITE(numout,*) ' Vector form: 2nd order centered scheme ln_dynadv_vec = ', ln_dynadv_vec 116 WRITE(numout,*) ' with Hollingsworth scheme (=1) or not (=0) nn_dynkeg = ', nn_dynkeg 117 WRITE(numout,*) ' flux form: 2nd order centred scheme ln_dynadv_cen2 = ', ln_dynadv_cen2 118 WRITE(numout,*) ' 3rd order UBS scheme ln_dynadv_ubs = ', ln_dynadv_ubs 115 119 ENDIF 116 120 117 ioptio = 0 ! Parameter control 118 IF( ln_dynadv_vec ) ioptio = ioptio + 1 119 IF( ln_dynadv_cen2 ) ioptio = ioptio + 1 120 IF( ln_dynadv_ubs ) ioptio = ioptio + 1 121 ioptio = 0 ! parameter control and set n_dynadv 122 IF( ln_dynadv_NONE ) THEN ; ioptio = ioptio + 1 ; n_dynadv = np_LIN_dyn ; ENDIF 123 IF( ln_dynadv_vec ) THEN ; ioptio = ioptio + 1 ; n_dynadv = np_VEC_c2 ; ENDIF 124 IF( ln_dynadv_cen2 ) THEN ; ioptio = ioptio + 1 ; n_dynadv = np_FLX_c2 ; ENDIF 125 IF( ln_dynadv_ubs ) THEN ; ioptio = ioptio + 1 ; n_dynadv = np_FLX_ubs ; ENDIF 121 126 122 IF( ioptio /= 1 ) CALL ctl_stop( 'Choose ONE advection scheme in namelist namdyn_adv' ) 123 IF( ln_dynzad_zts .AND. .NOT. ln_dynadv_vec ) & 124 CALL ctl_stop( 'Sub timestepping of vertical advection requires vector form; set ln_dynadv_vec = .TRUE.' ) 125 IF( nn_dynkeg /= nkeg_C2 .AND. nn_dynkeg /= nkeg_HW ) & 126 CALL ctl_stop( 'KEG scheme wrong value of nn_dynkeg' ) 127 IF( ioptio /= 1 ) CALL ctl_stop( 'choose ONE and only ONE advection scheme' ) 128 IF( nn_dynkeg /= nkeg_C2 .AND. nn_dynkeg /= nkeg_HW ) CALL ctl_stop( 'KEG scheme wrong value of nn_dynkeg' ) 127 129 128 ! ! Set nadv129 IF( ln_dynadv_vec ) nadv = 0130 IF( ln_dynzad_zts ) nadv = 1131 IF( ln_dynadv_cen2 ) nadv = 2132 IF( ln_dynadv_ubs ) nadv = 3133 130 134 131 IF(lwp) THEN ! Print the choice 135 132 WRITE(numout,*) 136 IF( nadv == 0 ) WRITE(numout,*) ' ===>> vector form : keg + zad + vor is used'137 IF( nadv == 1 ) WRITE(numout,*) ' ===>> vector form : keg + zad_zts + vor isused'138 IF( nadv == 0 .OR. nadv == 1 ) THEN133 SELECT CASE( n_dynadv ) 134 CASE( np_LIN_dyn ) ; WRITE(numout,*) ' ===>> linear dynamics : no momentum advection used' 135 CASE( np_VEC_c2 ) ; WRITE(numout,*) ' ===>> vector form : keg + zad + vor is used' 139 136 IF( nn_dynkeg == nkeg_C2 ) WRITE(numout,*) ' with Centered standard keg scheme' 140 137 IF( nn_dynkeg == nkeg_HW ) WRITE(numout,*) ' with Hollingsworth keg scheme' 141 ENDIF142 IF( nadv == 2 ) WRITE(numout,*) ' ===>> flux form : 2nd orderscheme is used'143 IF( nadv == 3 ) WRITE(numout,*) ' ===>> flux form : UBS scheme is used'138 CASE( np_FLX_c2 ) ; WRITE(numout,*) ' ===>> flux form : 2nd order scheme is used' 139 CASE( np_FLX_ubs ) ; WRITE(numout,*) ' ===>> flux form : UBS scheme is used' 140 END SELECT 144 141 ENDIF 145 142 ! -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DYN/dynadv_cen2.F90
r6750 r8568 20 20 USE lib_mpp ! MPP library 21 21 USE prtctl ! Print control 22 USE wrk_nemo ! Memory Allocation23 22 USE timing ! Timing 24 23 … … 31 30 # include "vectopt_loop_substitute.h90" 32 31 !!---------------------------------------------------------------------- 33 !! NEMO/OPA 4.0 , NEMO Consortium (201 1)32 !! NEMO/OPA 4.0 , NEMO Consortium (2017) 34 33 !! $Id$ 35 34 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 51 50 ! 52 51 INTEGER :: ji, jj, jk ! dummy loop indices 53 REAL(wp), POINTER, DIMENSION(:,:,:) :: zfu_t, zfv_t, zfu_f, zfv_f, zfu_uw, zfv_vw, zfw54 REAL(wp), POINTER, DIMENSION(:,:,:) :: zfu, zfv52 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zfu_t, zfu_f, zfu_uw, zfu 53 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zfv_t, zfv_f, zfv_vw, zfv, zfw 55 54 !!---------------------------------------------------------------------- 56 55 ! 57 IF( nn_timing == 1 ) CALL timing_start('dyn_adv_cen2') 58 ! 59 CALL wrk_alloc( jpi,jpj,jpk, zfu_t, zfv_t, zfu_f, zfv_f, zfu_uw, zfv_vw, zfu, zfv, zfw ) 56 IF( ln_timing ) CALL timing_start('dyn_adv_cen2') 60 57 ! 61 58 IF( kt == nit000 .AND. lwp ) THEN … … 148 145 & tab3d_2=va, clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) 149 146 ! 150 CALL wrk_dealloc( jpi, jpj, jpk, zfu_t, zfv_t, zfu_f, zfv_f, zfu_uw, zfv_vw, zfu, zfv, zfw ) 151 ! 152 IF( nn_timing == 1 ) CALL timing_stop('dyn_adv_cen2') 147 IF( ln_timing ) CALL timing_stop('dyn_adv_cen2') 153 148 ! 154 149 END SUBROUTINE dyn_adv_cen2 -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DYN/dynadv_ubs.F90
r6750 r8568 23 23 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 24 24 USE lib_mpp ! MPP library 25 USE wrk_nemo ! Memory Allocation26 25 USE timing ! Timing 27 26 … … 37 36 # include "vectopt_loop_substitute.h90" 38 37 !!---------------------------------------------------------------------- 39 !! NEMO/OPA 4.0 , NEMO Consortium (201 1)38 !! NEMO/OPA 4.0 , NEMO Consortium (2017) 40 39 !! $Id$ 41 40 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 74 73 INTEGER :: ji, jj, jk ! dummy loop indices 75 74 REAL(wp) :: zui, zvj, zfuj, zfvi, zl_u, zl_v ! local scalars 76 REAL(wp), POINTER, DIMENSION(:,:,: ) :: zfu, zfv 77 REAL(wp), POINTER, DIMENSION(:,:,: ) :: zfu_t, zfv_t, zfu_f, zfv_f, zfu_uw, zfv_vw, zfw 78 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: zlu_uu, zlv_vv, zlu_uv, zlv_vu 75 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zfu_t, zfu_f, zfu_uw, zfu 76 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zfv_t, zfv_f, zfv_vw, zfv, zfw 77 REAL(wp), DIMENSION(jpi,jpj,jpk,2) :: zlu_uu, zlu_uv 78 REAL(wp), DIMENSION(jpi,jpj,jpk,2) :: zlv_vv, zlv_vu 79 79 !!---------------------------------------------------------------------- 80 80 ! 81 IF( nn_timing == 1 ) CALL timing_start('dyn_adv_ubs') 82 ! 83 CALL wrk_alloc( jpi,jpj,jpk, zfu_t , zfv_t , zfu_f , zfv_f, zfu_uw, zfv_vw, zfu, zfv, zfw ) 84 CALL wrk_alloc( jpi,jpj,jpk,jpts, zlu_uu, zlv_vv, zlu_uv, zlv_vu ) 81 IF( ln_timing ) CALL timing_start('dyn_adv_ubs') 85 82 ! 86 83 IF( kt == nit000 ) THEN … … 241 238 & tab3d_2=va, clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) 242 239 ! 243 CALL wrk_dealloc( jpi,jpj,jpk, zfu_t , zfv_t , zfu_f , zfv_f, zfu_uw, zfv_vw, zfu, zfv, zfw ) 244 CALL wrk_dealloc( jpi,jpj,jpk,jpts, zlu_uu, zlv_vv, zlu_uv, zlv_vu ) 245 ! 246 IF( nn_timing == 1 ) CALL timing_stop('dyn_adv_ubs') 240 IF( ln_timing ) CALL timing_stop('dyn_adv_ubs') 247 241 ! 248 242 END SUBROUTINE dyn_adv_ubs -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DYN/dynbfr.F90
r8215 r8568 57 57 !!--------------------------------------------------------------------- 58 58 ! 59 IF( nn_timing == 1 )CALL timing_start('dyn_bfr')59 IF( ln_timing ) CALL timing_start('dyn_bfr') 60 60 ! 61 61 !!gm bug : time step is only rdt (not 2 rdt if euler start !) … … 109 109 & tab3d_2=va, clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) 110 110 ! 111 IF( nn_timing == 1 )CALL timing_stop('dyn_bfr')111 IF( ln_timing ) CALL timing_stop('dyn_bfr') 112 112 ! 113 113 END SUBROUTINE dyn_bfr -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DYN/dynhpg.F90
r8215 r8568 44 44 USE lib_mpp ! MPP library 45 45 USE eosbn2 ! compute density 46 USE wrk_nemo ! Memory Allocation47 46 USE timing ! Timing 48 47 USE iom … … 84 83 !!---------------------------------------------------------------------- 85 84 INTEGER, INTENT(in) :: kt ! ocean time-step index 86 REAL(wp), POINTER, DIMENSION(:,:,:) ::ztrdu, ztrdv87 !!---------------------------------------------------------------------- 88 ! 89 IF( nn_timing == 1 )CALL timing_start('dyn_hpg')85 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdu, ztrdv 86 !!---------------------------------------------------------------------- 87 ! 88 IF( ln_timing ) CALL timing_start('dyn_hpg') 90 89 ! 91 90 IF( l_trddyn ) THEN ! Temporary saving of ua and va trends (l_trddyn) 92 CALL wrk_alloc( jpi,jpj,jpk, ztrdu, ztrdv)91 ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) ) 93 92 ztrdu(:,:,:) = ua(:,:,:) 94 93 ztrdv(:,:,:) = va(:,:,:) … … 108 107 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 109 108 CALL trd_dyn( ztrdu, ztrdv, jpdyn_hpg, kt ) 110 CALL wrk_dealloc( jpi,jpj,jpk, ztrdu, ztrdv )109 DEALLOCATE( ztrdu , ztrdv ) 111 110 ENDIF 112 111 ! … … 114 113 & tab3d_2=va, clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) 115 114 ! 116 IF( nn_timing == 1 )CALL timing_stop('dyn_hpg')115 IF( ln_timing ) CALL timing_stop('dyn_hpg') 117 116 ! 118 117 END SUBROUTINE dyn_hpg … … 134 133 INTEGER :: ji, jj, jk, ikt ! dummy loop indices ISF 135 134 REAL(wp) :: znad 136 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztstop, zrhd! hypothesys on isf density137 REAL(wp), POINTER, DIMENSION(:,:) :: zrhdtop_isf! density at bottom of ISF138 REAL(wp), POINTER, DIMENSION(:,:) :: ziceload! density at bottom of ISF135 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zts_top, zrhd ! hypothesys on isf density 136 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zrhdtop_isf ! density at bottom of ISF 137 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: ziceload ! density at bottom of ISF 139 138 !! 140 139 NAMELIST/namdyn_hpg/ ln_hpg_zco, ln_hpg_zps, ln_hpg_sco, & … … 165 164 ! 166 165 IF( ln_hpg_djc ) & 167 & CALL ctl_stop('dyn_hpg_init : Density Jacobian: Cubic polynominal method & 168 & currently disabled (bugs under investigation). Please select & 169 & either ln_hpg_sco or ln_hpg_prj instead') 170 ! 171 IF( .NOT.ln_linssh .AND. .NOT.(ln_hpg_sco.OR.ln_hpg_prj.OR.ln_hpg_isf) ) & 172 & CALL ctl_stop('dyn_hpg_init : non-linear free surface requires either ', & 173 & ' the standard jacobian formulation hpg_sco or ' , & 174 & ' the pressure jacobian formulation hpg_prj' ) 175 176 IF( ln_hpg_isf .AND. .NOT. ln_isfcav ) & 177 & CALL ctl_stop( ' hpg_isf not available if ln_isfcav = false ' ) 178 IF( .NOT. ln_hpg_isf .AND. ln_isfcav ) & 179 & CALL ctl_stop( 'Only hpg_isf has been corrected to work with ice shelf cavity.' ) 166 & CALL ctl_stop('dyn_hpg_init : Density Jacobian: Cubic polynominal method', & 167 & ' currently disabled (bugs under investigation).' , & 168 & ' Please select either ln_hpg_sco or ln_hpg_prj instead' ) 169 ! 170 IF( .NOT.ln_linssh .AND. .NOT.(ln_hpg_sco.OR.ln_hpg_prj.OR.ln_hpg_isf) ) & 171 & CALL ctl_stop('dyn_hpg_init : non-linear free surface requires either ', & 172 & ' the standard jacobian formulation hpg_sco or ' , & 173 & ' the pressure jacobian formulation hpg_prj' ) 174 ! 175 IF( ln_hpg_isf ) THEN 176 IF( .NOT. ln_isfcav ) CALL ctl_stop( ' hpg_isf not available if ln_isfcav = false ' ) 177 ELSE 178 IF( ln_isfcav ) CALL ctl_stop( 'Only hpg_isf has been corrected to work with ice shelf cavity.' ) 179 ENDIF 180 180 ! 181 181 ! ! Set nhpg from ln_hpg_... flags … … 197 197 IF( ioptio /= 1 ) CALL ctl_stop( 'NO or several hydrostatic pressure gradient options used' ) 198 198 ! 199 ! initialisation of ice shelf load 200 IF ( .NOT. ln_isfcav ) riceload(:,:)=0.0 201 IF ( ln_isfcav ) THEN 202 CALL wrk_alloc( jpi,jpj, 2, ztstop) 203 CALL wrk_alloc( jpi,jpj,jpk, zrhd ) 204 CALL wrk_alloc( jpi,jpj, zrhdtop_isf, ziceload) 199 ! 200 IF ( .NOT. ln_isfcav ) THEN !--- no ice shelf load 201 riceload(:,:) = 0._wp 202 ! 203 ELSE !--- set an ice shelf load 205 204 ! 206 205 IF(lwp) WRITE(numout,*) 207 IF(lwp) WRITE(numout,*) 'dyn:hpg_isf : hydrostatic pressure gradient trend for ice shelf' 208 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 209 210 ! To use density and not density anomaly 211 znad=1._wp 212 213 ! assume water displaced by the ice shelf is at T=-1.9 and S=34.4 (rude) 214 ztstop(:,:,1)=-1.9_wp ; ztstop(:,:,2)=34.4_wp 215 216 ! compute density of the water displaced by the ice shelf 217 DO jk = 1, jpk 218 CALL eos(ztstop(:,:,:),gdept_n(:,:,jk),zrhd(:,:,jk)) 219 END DO 220 221 ! compute rhd at the ice/oce interface (ice shelf side) 222 CALL eos(ztstop,risfdep,zrhdtop_isf) 223 224 ! Surface value + ice shelf gradient 225 ! compute pressure due to ice shelf load (used to compute hpgi/j for all the level from 1 to miku/v) 226 ! divided by 2 later 227 ziceload = 0._wp 228 DO jj = 1, jpj 229 DO ji = 1, jpi 230 ikt=mikt(ji,jj) 206 IF(lwp) WRITE(numout,*) ' ice shelf case: set the ice-shelf load' 207 ALLOCATE( zts_top(jpi,jpj,jpts) , zrhd(jpi,jpj,jpk) , zrhdtop_isf(jpi,jpj) , ziceload(jpi,jpj) ) 208 ! 209 znad = 1._wp !- To use density and not density anomaly 210 ! 211 ! !- assume water displaced by the ice shelf is at T=-1.9 and S=34.4 (rude) 212 zts_top(:,:,jp_tem) = -1.9_wp ; zts_top(:,:,jp_sal) = 34.4_wp 213 ! 214 DO jk = 1, jpk !- compute density of the water displaced by the ice shelf 215 CALL eos( zts_top(:,:,:), gdept_n(:,:,jk), zrhd(:,:,jk) ) 216 END DO 217 ! 218 ! !- compute rhd at the ice/oce interface (ice shelf side) 219 CALL eos( zts_top , risfdep, zrhdtop_isf ) 220 ! 221 ! !- Surface value + ice shelf gradient 222 ziceload = 0._wp ! compute pressure due to ice shelf load 223 DO jj = 1, jpj ! (used to compute hpgi/j for all the level from 1 to miku/v) 224 DO ji = 1, jpi ! divided by 2 later 225 ikt = mikt(ji,jj) 231 226 ziceload(ji,jj) = ziceload(ji,jj) + (znad + zrhd(ji,jj,1) ) * e3w_n(ji,jj,1) * (1._wp - tmask(ji,jj,1)) 232 DO jk =2,ikt-1227 DO jk = 2, ikt-1 233 228 ziceload(ji,jj) = ziceload(ji,jj) + (2._wp * znad + zrhd(ji,jj,jk-1) + zrhd(ji,jj,jk)) * e3w_n(ji,jj,jk) & 234 229 & * (1._wp - tmask(ji,jj,jk)) 235 230 END DO 236 231 IF (ikt >= 2) ziceload(ji,jj) = ziceload(ji,jj) + (2._wp * znad + zrhdtop_isf(ji,jj) + zrhd(ji,jj,ikt-1)) & 237 & * ( risfdep(ji,jj) - gdept_1d(ikt-1) ) 238 END DO 239 END DO 240 riceload(:,:)=ziceload(:,:) ! need to be saved for diaar5 241 242 CALL wrk_dealloc( jpi,jpj, 2, ztstop) 243 CALL wrk_dealloc( jpi,jpj,jpk, zrhd ) 244 CALL wrk_dealloc( jpi,jpj, zrhdtop_isf, ziceload) 245 END IF 232 & * ( risfdep(ji,jj) - gdept_1d(ikt-1) ) 233 END DO 234 END DO 235 riceload(:,:) = ziceload(:,:) ! need to be saved for diaar5 236 ! 237 DEALLOCATE( zts_top , zrhd , zrhdtop_isf , ziceload ) 238 ENDIF 246 239 ! 247 240 END SUBROUTINE dyn_hpg_init … … 268 261 INTEGER :: ji, jj, jk ! dummy loop indices 269 262 REAL(wp) :: zcoef0, zcoef1 ! temporary scalars 270 REAL(wp), POINTER, DIMENSION(:,:,:) :: zhpi, zhpj 271 !!---------------------------------------------------------------------- 272 ! 273 CALL wrk_alloc( jpi,jpj,jpk, zhpi, zhpj ) 263 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zhpi, zhpj 264 !!---------------------------------------------------------------------- 274 265 ! 275 266 IF( kt == nit000 ) THEN … … 315 306 END DO 316 307 ! 317 CALL wrk_dealloc( jpi,jpj,jpk, zhpi, zhpj )318 !319 308 END SUBROUTINE hpg_zco 320 309 … … 333 322 INTEGER :: iku, ikv ! temporary integers 334 323 REAL(wp) :: zcoef0, zcoef1, zcoef2, zcoef3 ! temporary scalars 335 REAL(wp), POINTER, DIMENSION(:,:,:) :: zhpi, zhpj 336 !!---------------------------------------------------------------------- 337 ! 338 CALL wrk_alloc( jpi,jpj,jpk, zhpi, zhpj ) 324 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zhpi, zhpj 325 !!---------------------------------------------------------------------- 339 326 ! 340 327 IF( kt == nit000 ) THEN … … 405 392 END DO 406 393 ! 407 CALL wrk_dealloc( jpi,jpj,jpk, zhpi, zhpj )408 !409 394 END SUBROUTINE hpg_zps 410 395 … … 433 418 REAL(wp) :: zcoef0, zuap, zvap, znad, ztmp ! temporary scalars 434 419 LOGICAL :: ll_tmp1, ll_tmp2 ! local logical variables 435 REAL(wp), POINTER, DIMENSION(:,:,:) :: zhpi, zhpj 436 REAL(wp), POINTER, DIMENSION(:,:) :: zcpx, zcpy !W/D pressure filter 437 !!---------------------------------------------------------------------- 438 ! 439 CALL wrk_alloc( jpi,jpj,jpk, zhpi, zhpj ) 440 IF( ln_wd ) CALL wrk_alloc( jpi,jpj, zcpx, zcpy ) 420 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zhpi, zhpj 421 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zcpx, zcpy !W/D pressure filter 422 !!---------------------------------------------------------------------- 441 423 ! 442 424 IF( kt == nit000 ) THEN … … 452 434 ! 453 435 IF( ln_wd ) THEN 454 DO jj = 2, jpjm1 455 DO ji = 2, jpim1 456 ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji+1,jj) ) > & 436 ALLOCATE( zcpx(jpi,jpj) , zcpy(jpi,jpj) ) 437 DO jj = 2, jpjm1 438 DO ji = 2, jpim1 439 ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji+1,jj) ) > & 457 440 & MAX( -ht_wd(ji,jj) , -ht_wd(ji+1,jj) ) .AND. & 458 441 & MAX( sshn(ji,jj) + ht_wd(ji,jj), sshn(ji+1,jj) + ht_wd(ji+1,jj) ) & 459 442 & > rn_wdmin1 + rn_wdmin2 460 ll_tmp2 = ( ABS( sshn(ji,jj) - sshn(ji+1,jj) ) > 1.E-12 ) .AND. ( &443 ll_tmp2 = ( ABS( sshn(ji,jj) - sshn(ji+1,jj) ) > 1.E-12 ) .AND. ( & 461 444 & MAX( sshn(ji,jj) , sshn(ji+1,jj) ) > & 462 445 & MAX( -ht_wd(ji,jj) , -ht_wd(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 ) 463 446 464 IF(ll_tmp1) THEN465 zcpx(ji,jj) = 1.0_wp466 ELSE IF(ll_tmp2) THEN467 ! no worries about sshn(ji+1,jj) - sshn(ji ,jj) = 0, it won't happen ! here468 zcpx(ji,jj) = ABS( (sshn(ji+1,jj) + ht_wd(ji+1,jj) - sshn(ji,jj) - ht_wd(ji,jj))&469 & / (sshn(ji+1,jj) - sshn(ji ,jj)))470 ELSE471 zcpx(ji,jj) = 0._wp472 ENDIF473 474 ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji,jj+1) ) > &447 IF(ll_tmp1) THEN 448 zcpx(ji,jj) = 1.0_wp 449 ELSE IF(ll_tmp2) THEN 450 ! no worries about sshn(ji+1,jj) - sshn(ji ,jj) = 0, it won't happen ! here 451 zcpx(ji,jj) = ABS( ( sshn(ji+1,jj)+ht_wd(ji+1,jj) - sshn(ji,jj)-ht_wd(ji,jj) ) & 452 & / ( sshn(ji+1,jj) - sshn(ji,jj) ) ) 453 ELSE 454 zcpx(ji,jj) = 0._wp 455 ENDIF 456 ! 457 ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji,jj+1) ) > & 475 458 & MAX( -ht_wd(ji,jj) , -ht_wd(ji,jj+1) ) .AND. & 476 459 & MAX( sshn(ji,jj) + ht_wd(ji,jj), sshn(ji,jj+1) + ht_wd(ji,jj+1) ) & 477 460 & > rn_wdmin1 + rn_wdmin2 478 ll_tmp2 = ( ABS( sshn(ji,jj) - sshn(ji,jj+1) ) > 1.E-12 ) .AND. ( &461 ll_tmp2 = ( ABS( sshn(ji,jj) - sshn(ji,jj+1) ) > 1.E-12 ) .AND. ( & 479 462 & MAX( sshn(ji,jj) , sshn(ji,jj+1) ) > & 480 463 & MAX( -ht_wd(ji,jj) , -ht_wd(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 ) 481 482 IF(ll_tmp1) THEN483 zcpy(ji,jj) = 1.0_wp484 ELSE IF(ll_tmp2) THEN485 ! no worries about sshn(ji,jj+1) - sshn(ji,jj ) = 0, it won't happen ! here486 zcpy(ji,jj) = ABS( (sshn(ji,jj+1) + ht_wd(ji,jj+1) - sshn(ji,jj) - ht_wd(ji,jj))&487 & / (sshn(ji,jj+1) - sshn(ji,jj )))488 ELSE489 zcpy(ji,jj) = 0._wp490 ENDIF491 END DO492 END DO493 CALL lbc_lnk( zcpx, 'U', 1._wp ) ; CALL lbc_lnk( zcpy, 'V', 1._wp )494 END 464 ! 465 IF(ll_tmp1) THEN 466 zcpy(ji,jj) = 1.0_wp 467 ELSE IF(ll_tmp2) THEN 468 ! no worries about sshn(ji,jj+1) - sshn(ji,jj ) = 0, it won't happen ! here 469 zcpy(ji,jj) = ABS( ( sshn(ji,jj+1)+ht_wd(ji,jj+1) - sshn(ji,jj) - ht_wd(ji,jj) ) & 470 & / ( sshn(ji,jj+1) - sshn(ji,jj) ) ) 471 ELSE 472 zcpy(ji,jj) = 0._wp 473 ENDIF 474 END DO 475 END DO 476 CALL lbc_lnk( zcpx, 'U', 1._wp ) ; CALL lbc_lnk( zcpy, 'V', 1._wp ) 477 ENDIF 495 478 496 479 ! Surface value … … 507 490 zvap = -zcoef0 * ( rhd (ji,jj+1,1) + rhd (ji,jj,1) + 2._wp * znad ) & 508 491 & * ( gde3w_n(ji,jj+1,1) - gde3w_n(ji,jj,1) ) * r1_e2v(ji,jj) 509 510 492 ! 511 493 IF( ln_wd ) THEN 512 513 zhpi(ji,jj,1) = zhpi(ji,jj,1) * zcpx(ji,jj) 514 zhpj(ji,jj,1) = zhpj(ji,jj,1) * zcpy(ji,jj) 515 zuap = zuap * zcpx(ji,jj) 516 zvap = zvap * zcpy(ji,jj) 494 zhpi(ji,jj,1) = zhpi(ji,jj,1) * zcpx(ji,jj) 495 zhpj(ji,jj,1) = zhpj(ji,jj,1) * zcpy(ji,jj) 496 zuap = zuap * zcpx(ji,jj) 497 zvap = zvap * zcpy(ji,jj) 517 498 ENDIF 518 499 ! 519 500 ! add to the general momentum trend 520 501 ua(ji,jj,1) = ua(ji,jj,1) + zhpi(ji,jj,1) + zuap … … 539 520 zvap = -zcoef0 * ( rhd (ji ,jj+1,jk) + rhd (ji,jj,jk) + 2._wp * znad ) & 540 521 & * ( gde3w_n(ji ,jj+1,jk) - gde3w_n(ji,jj,jk) ) * r1_e2v(ji,jj) 541 522 ! 542 523 IF( ln_wd ) THEN 543 zhpi(ji,jj,jk) = zhpi(ji,jj,jk) * zcpx(ji,jj)544 zhpj(ji,jj,jk) = zhpj(ji,jj,jk) * zcpy(ji,jj)545 zuap = zuap * zcpx(ji,jj)546 zvap = zvap * zcpy(ji,jj)547 ENDIF 548 524 zhpi(ji,jj,jk) = zhpi(ji,jj,jk) * zcpx(ji,jj) 525 zhpj(ji,jj,jk) = zhpj(ji,jj,jk) * zcpy(ji,jj) 526 zuap = zuap * zcpx(ji,jj) 527 zvap = zvap * zcpy(ji,jj) 528 ENDIF 529 ! 549 530 ! add to the general momentum trend 550 531 ua(ji,jj,jk) = ua(ji,jj,jk) + zhpi(ji,jj,jk) + zuap … … 554 535 END DO 555 536 ! 556 CALL wrk_dealloc( jpi,jpj,jpk, zhpi, zhpj ) 557 IF( ln_wd ) CALL wrk_dealloc( jpi,jpj, zcpx, zcpy ) 537 IF( ln_wd ) DEALLOCATE( zcpx , zcpy ) 558 538 ! 559 539 END SUBROUTINE hpg_sco … … 583 563 INTEGER :: ji, jj, jk, ikt, iktp1i, iktp1j ! dummy loop indices 584 564 REAL(wp) :: zcoef0, zuap, zvap, znad ! temporary scalars 585 REAL(wp), POINTER, DIMENSION(:,:,:) :: zhpi, zhpj 586 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztstop 587 REAL(wp), POINTER, DIMENSION(:,:) :: zrhdtop_oce 588 !!---------------------------------------------------------------------- 589 ! 590 CALL wrk_alloc( jpi,jpj, 2, ztstop) 591 CALL wrk_alloc( jpi,jpj,jpk, zhpi, zhpj) 592 CALL wrk_alloc( jpi,jpj, zrhdtop_oce ) 593 ! 594 ! Local constant initialization 595 zcoef0 = - grav * 0.5_wp 596 597 ! To use density and not density anomaly 598 znad=1._wp 599 600 ! iniitialised to 0. zhpi zhpi 601 zhpi(:,:,:)=0._wp ; zhpj(:,:,:)=0._wp 565 REAL(wp), DIMENSION(jpi,jpj,jpk ) :: zhpi, zhpj 566 REAL(wp), DIMENSION(jpi,jpj,jpts) :: zts_top 567 REAL(wp), DIMENSION(jpi,jpj) :: zrhdtop_oce 568 !!---------------------------------------------------------------------- 569 ! 570 zcoef0 = - grav * 0.5_wp ! Local constant initialization 571 ! 572 znad=1._wp ! To use density and not density anomaly 573 ! 574 ! ! iniitialised to 0. zhpi zhpi 575 zhpi(:,:,:) = 0._wp ; zhpj(:,:,:) = 0._wp 602 576 603 577 ! compute rhd at the ice/oce interface (ocean side) 604 578 ! usefull to reduce residual current in the test case ISOMIP with no melting 605 DO ji =1,jpi606 DO jj =1,jpj607 ikt =mikt(ji,jj)608 zts top(ji,jj,1)=tsn(ji,jj,ikt,1)609 zts top(ji,jj,2)=tsn(ji,jj,ikt,2)579 DO ji = 1, jpi 580 DO jj = 1, jpj 581 ikt = mikt(ji,jj) 582 zts_top(ji,jj,1) = tsn(ji,jj,ikt,1) 583 zts_top(ji,jj,2) = tsn(ji,jj,ikt,2) 610 584 END DO 611 585 END DO 612 CALL eos( zts top, risfdep, zrhdtop_oce )586 CALL eos( zts_top, risfdep, zrhdtop_oce ) 613 587 614 588 !================================================================================== … … 667 641 END DO 668 642 END DO 669 !670 CALL wrk_dealloc( jpi,jpj,2 , ztstop)671 CALL wrk_dealloc( jpi,jpj,jpk, zhpi, zhpj)672 CALL wrk_dealloc( jpi,jpj , zrhdtop_oce )673 643 ! 674 644 END SUBROUTINE hpg_isf … … 690 660 REAL(wp) :: z1_12, cffv, cffy ! " " 691 661 LOGICAL :: ll_tmp1, ll_tmp2 ! local logical variables 692 REAL(wp), POINTER, DIMENSION(:,:,:) :: zhpi, zhpj 693 REAL(wp), POINTER, DIMENSION(:,:,:) :: dzx, dzy, dzz, dzu, dzv, dzw 694 REAL(wp), POINTER, DIMENSION(:,:,:) :: drhox, drhoy, drhoz, drhou, drhov, drhow 695 REAL(wp), POINTER, DIMENSION(:,:,:) :: rho_i, rho_j, rho_k 696 REAL(wp), POINTER, DIMENSION(:,:) :: zcpx, zcpy !W/D pressure filter 697 !!---------------------------------------------------------------------- 698 ! 699 CALL wrk_alloc( jpi, jpj, jpk, dzx , dzy , dzz , dzu , dzv , dzw ) 700 CALL wrk_alloc( jpi, jpj, jpk, drhox, drhoy, drhoz, drhou, drhov, drhow ) 701 CALL wrk_alloc( jpi, jpj, jpk, rho_i, rho_j, rho_k, zhpi, zhpj ) 702 IF( ln_wd ) CALL wrk_alloc( jpi,jpj, zcpx, zcpy ) 703 ! 662 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zhpi, zhpj 663 REAL(wp), DIMENSION(jpi,jpj,jpk) :: dzx, dzy, dzz, dzu, dzv, dzw 664 REAL(wp), DIMENSION(jpi,jpj,jpk) :: drhox, drhoy, drhoz, drhou, drhov, drhow 665 REAL(wp), DIMENSION(jpi,jpj,jpk) :: rho_i, rho_j, rho_k 666 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zcpx, zcpy !W/D pressure filter 667 !!---------------------------------------------------------------------- 704 668 ! 705 669 IF( ln_wd ) THEN 706 DO jj = 2, jpjm1 707 DO ji = 2, jpim1 708 ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji+1,jj) ) > & 670 ALLOCATE( zcpx(jpi,jpj) , zcpy(jpi,jpj) ) 671 DO jj = 2, jpjm1 672 DO ji = 2, jpim1 673 ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji+1,jj) ) > & 709 674 & MAX( -ht_wd(ji,jj) , -ht_wd(ji+1,jj) ) .AND. & 710 675 & MAX( sshn(ji,jj) + ht_wd(ji,jj), sshn(ji+1,jj) + ht_wd(ji+1,jj) ) & 711 676 & > rn_wdmin1 + rn_wdmin2 712 ll_tmp2 = ( ABS( sshn(ji,jj) - sshn(ji+1,jj) ) > 1.E-12 ) .AND. ( &677 ll_tmp2 = ( ABS( sshn(ji,jj) - sshn(ji+1,jj) ) > 1.E-12 ) .AND. ( & 713 678 & MAX( sshn(ji,jj) , sshn(ji+1,jj) ) > & 714 679 & MAX( -ht_wd(ji,jj) , -ht_wd(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 ) 715 680 716 IF(ll_tmp1) THEN717 zcpx(ji,jj) = 1.0_wp718 ELSE IF(ll_tmp2) THEN719 ! no worries about sshn(ji+1,jj) - sshn(ji ,jj) = 0, it won't happen ! here720 zcpx(ji,jj) = ABS( (sshn(ji+1,jj) + ht_wd(ji+1,jj) - sshn(ji,jj) - ht_wd(ji,jj)) &721 & / (sshn(ji+1,jj) - sshn(ji ,jj)) )722 ELSE723 zcpx(ji,jj) = 0._wp724 ENDIF681 IF(ll_tmp1) THEN 682 zcpx(ji,jj) = 1.0_wp 683 ELSE IF(ll_tmp2) THEN 684 ! no worries about sshn(ji+1,jj) - sshn(ji ,jj) = 0, it won't happen ! here 685 zcpx(ji,jj) = ABS( (sshn(ji+1,jj) + ht_wd(ji+1,jj) - sshn(ji,jj) - ht_wd(ji,jj)) & 686 & / (sshn(ji+1,jj) - sshn(ji ,jj)) ) 687 ELSE 688 zcpx(ji,jj) = 0._wp 689 ENDIF 725 690 726 ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji,jj+1) ) > &691 ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji,jj+1) ) > & 727 692 & MAX( -ht_wd(ji,jj) , -ht_wd(ji,jj+1) ) .AND. & 728 693 & MAX( sshn(ji,jj) + ht_wd(ji,jj), sshn(ji,jj+1) + ht_wd(ji,jj+1) ) & 729 694 & > rn_wdmin1 + rn_wdmin2 730 ll_tmp2 = ( ABS( sshn(ji,jj) - sshn(ji,jj+1) ) > 1.E-12 ) .AND. ( &695 ll_tmp2 = ( ABS( sshn(ji,jj) - sshn(ji,jj+1) ) > 1.E-12 ) .AND. ( & 731 696 & MAX( sshn(ji,jj) , sshn(ji,jj+1) ) > & 732 697 & MAX( -ht_wd(ji,jj) , -ht_wd(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 ) 733 698 734 IF(ll_tmp1) THEN735 zcpy(ji,jj) = 1.0_wp736 ELSE IF(ll_tmp2) THEN737 ! no worries about sshn(ji,jj+1) - sshn(ji,jj ) = 0, it won't happen ! here738 zcpy(ji,jj) = ABS( (sshn(ji,jj+1) + ht_wd(ji,jj+1) - sshn(ji,jj) - ht_wd(ji,jj)) &739 & / (sshn(ji,jj+1) - sshn(ji,jj )) )740 ELSE741 zcpy(ji,jj) = 0._wp742 ENDIF743 END DO744 END DO745 CALL lbc_lnk( zcpx, 'U', 1._wp ) ; CALL lbc_lnk( zcpy, 'V', 1._wp )746 END 699 IF(ll_tmp1) THEN 700 zcpy(ji,jj) = 1.0_wp 701 ELSE IF(ll_tmp2) THEN 702 ! no worries about sshn(ji,jj+1) - sshn(ji,jj ) = 0, it won't happen ! here 703 zcpy(ji,jj) = ABS( (sshn(ji,jj+1) + ht_wd(ji,jj+1) - sshn(ji,jj) - ht_wd(ji,jj)) & 704 & / (sshn(ji,jj+1) - sshn(ji,jj )) ) 705 ELSE 706 zcpy(ji,jj) = 0._wp 707 ENDIF 708 END DO 709 END DO 710 CALL lbc_lnk( zcpx, 'U', 1._wp ) ; CALL lbc_lnk( zcpy, 'V', 1._wp ) 711 ENDIF 747 712 748 713 IF( kt == nit000 ) THEN … … 903 868 END DO 904 869 END DO 905 CALL lbc_lnk( rho_k,'W',1.)906 CALL lbc_lnk( rho_i,'U',1.)907 CALL lbc_lnk( rho_j,'V',1.)870 CALL lbc_lnk( rho_k, 'W', 1. ) 871 CALL lbc_lnk( rho_i, 'U', 1. ) 872 CALL lbc_lnk( rho_j, 'V', 1. ) 908 873 909 874 … … 949 914 END DO 950 915 ! 951 CALL wrk_dealloc( jpi, jpj, jpk, dzx , dzy , dzz , dzu , dzv , dzw ) 952 CALL wrk_dealloc( jpi, jpj, jpk, drhox, drhoy, drhoz, drhou, drhov, drhow ) 953 CALL wrk_dealloc( jpi, jpj, jpk, rho_i, rho_j, rho_k, zhpi, zhpj ) 954 IF( ln_wd ) CALL wrk_dealloc( jpi,jpj, zcpx, zcpy ) 916 IF( ln_wd ) DEALLOCATE( zcpx, zcpy ) 955 917 ! 956 918 END SUBROUTINE hpg_djc … … 980 942 REAL(wp) :: zrhdt1 981 943 REAL(wp) :: zdpdx1, zdpdx2, zdpdy1, zdpdy2 982 REAL(wp), POINTER, DIMENSION(:,:,:) :: zdept, zrhh 983 REAL(wp), POINTER, DIMENSION(:,:,:) :: zhpi, zu, zv, fsp, xsp, asp, bsp, csp, dsp 984 REAL(wp), POINTER, DIMENSION(:,:) :: zsshu_n, zsshv_n 985 REAL(wp), POINTER, DIMENSION(:,:) :: zcpx, zcpy !W/D pressure filter 986 !!---------------------------------------------------------------------- 987 ! 988 CALL wrk_alloc( jpi,jpj,jpk, zhpi, zu, zv, fsp, xsp, asp, bsp, csp, dsp ) 989 CALL wrk_alloc( jpi,jpj,jpk, zdept, zrhh ) 990 CALL wrk_alloc( jpi,jpj, zsshu_n, zsshv_n ) 991 IF( ln_wd ) CALL wrk_alloc( jpi,jpj, zcpx, zcpy ) 944 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdept, zrhh 945 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zhpi, zu, zv, fsp, xsp, asp, bsp, csp, dsp 946 REAL(wp), DIMENSION(jpi,jpj) :: zsshu_n, zsshv_n 947 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zcpx, zcpy !W/D pressure filter 948 !!---------------------------------------------------------------------- 992 949 ! 993 950 IF( kt == nit000 ) THEN … … 1003 960 1004 961 IF( ln_wd ) THEN 1005 DO jj = 2, jpjm1 1006 DO ji = 2, jpim1 1007 ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji+1,jj) ) > & 962 ALLOCATE( zcpx(jpi,jpj) , zcpy(jpi,jpj) ) 963 DO jj = 2, jpjm1 964 DO ji = 2, jpim1 965 ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji+1,jj) ) > & 1008 966 & MAX( -ht_wd(ji,jj) , -ht_wd(ji+1,jj) ) .AND. & 1009 967 & MAX( sshn(ji,jj) + ht_wd(ji,jj), sshn(ji+1,jj) + ht_wd(ji+1,jj) ) & 1010 968 & > rn_wdmin1 + rn_wdmin2 1011 ll_tmp2 = ( ABS( sshn(ji,jj) - sshn(ji+1,jj) ) > 1.E-12 ) .AND. ( &969 ll_tmp2 = ( ABS( sshn(ji,jj) - sshn(ji+1,jj) ) > 1.E-12 ) .AND. ( & 1012 970 & MAX( sshn(ji,jj) , sshn(ji+1,jj) ) > & 1013 971 & MAX( -ht_wd(ji,jj) , -ht_wd(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 ) 1014 972 1015 IF(ll_tmp1) THEN1016 zcpx(ji,jj) = 1.0_wp1017 ELSE IF(ll_tmp2) THEN1018 ! no worries about sshn(ji+1,jj) - sshn(ji ,jj) = 0, it won't happen ! here1019 zcpx(ji,jj) = ABS( (sshn(ji+1,jj) + ht_wd(ji+1,jj) - sshn(ji,jj) - ht_wd(ji,jj)) &1020 & / (sshn(ji+1,jj) - sshn(ji ,jj)) )1021 ELSE1022 zcpx(ji,jj) = 0._wp1023 ENDIF973 IF(ll_tmp1) THEN 974 zcpx(ji,jj) = 1.0_wp 975 ELSE IF(ll_tmp2) THEN 976 ! no worries about sshn(ji+1,jj) - sshn(ji ,jj) = 0, it won't happen ! here 977 zcpx(ji,jj) = ABS( (sshn(ji+1,jj) + ht_wd(ji+1,jj) - sshn(ji,jj) - ht_wd(ji,jj)) & 978 & / (sshn(ji+1,jj) - sshn(ji ,jj)) ) 979 ELSE 980 zcpx(ji,jj) = 0._wp 981 ENDIF 1024 982 1025 ll_tmp1 = MIN( sshn(ji,jj), sshn(ji,jj+1) ) > &983 ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji,jj+1) ) > & 1026 984 & MAX( -ht_wd(ji,jj) , -ht_wd(ji,jj+1) ) .AND. & 1027 985 & MAX( sshn(ji,jj) + ht_wd(ji,jj), sshn(ji,jj+1) + ht_wd(ji,jj+1) ) & 1028 986 & > rn_wdmin1 + rn_wdmin2 1029 ll_tmp2 = ( ABS( sshn(ji,jj)- sshn(ji,jj+1) ) > 1.E-12 ) .AND. ( &987 ll_tmp2 = ( ABS( sshn(ji,jj) - sshn(ji,jj+1) ) > 1.E-12 ) .AND. ( & 1030 988 & MAX( sshn(ji,jj) , sshn(ji,jj+1) ) > & 1031 989 & MAX( -ht_wd(ji,jj) , -ht_wd(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 ) 1032 990 1033 IF(ll_tmp1) THEN1034 zcpy(ji,jj) = 1.0_wp1035 ELSE IF(ll_tmp2) THEN1036 ! no worries about sshn(ji,jj+1) - sshn(ji,jj ) = 0, it won't happen ! here1037 zcpy(ji,jj) = ABS( (sshn(ji,jj+1) + ht_wd(ji,jj+1) - sshn(ji,jj) - ht_wd(ji,jj)) &991 IF(ll_tmp1) THEN 992 zcpy(ji,jj) = 1.0_wp 993 ELSE IF(ll_tmp2) THEN 994 ! no worries about sshn(ji,jj+1) - sshn(ji,jj ) = 0, it won't happen ! here 995 zcpy(ji,jj) = ABS( (sshn(ji,jj+1) + ht_wd(ji,jj+1) - sshn(ji,jj) - ht_wd(ji,jj)) & 1038 996 & / (sshn(ji,jj+1) - sshn(ji,jj )) ) 1039 ELSE1040 zcpy(ji,jj) = 0._wp1041 ENDIF1042 END DO1043 END DO1044 CALL lbc_lnk( zcpx, 'U', 1._wp ) ; CALL lbc_lnk( zcpy, 'V', 1._wp )1045 END 997 ELSE 998 zcpy(ji,jj) = 0._wp 999 ENDIF 1000 END DO 1001 END DO 1002 CALL lbc_lnk( zcpx, 'U', 1._wp ) ; CALL lbc_lnk( zcpy, 'V', 1._wp ) 1003 ENDIF 1046 1004 1047 1005 ! Clean 3-D work arrays … … 1298 1256 END DO 1299 1257 ! 1300 CALL wrk_dealloc( jpi,jpj,jpk, zhpi, zu, zv, fsp, xsp, asp, bsp, csp, dsp ) 1301 CALL wrk_dealloc( jpi,jpj,jpk, zdept, zrhh ) 1302 CALL wrk_dealloc( jpi,jpj, zsshu_n, zsshv_n ) 1303 IF( ln_wd ) CALL wrk_dealloc( jpi,jpj, zcpx, zcpy ) 1258 IF( ln_wd ) DEALLOCATE( zcpx, zcpy ) 1304 1259 ! 1305 1260 END SUBROUTINE hpg_prj … … 1353 1308 !!Simply geometric average 1354 1309 DO jk = 2, jpkm1-1 1355 zdf1 = (fsp(ji,jj,jk ) - fsp(ji,jj,jk-1)) / (xsp(ji,jj,jk) - xsp(ji,jj,jk-1))1356 zdf2 = (fsp(ji,jj,jk+1) - fsp(ji,jj,jk )) / (xsp(ji,jj,jk+1) - xsp(ji,jj,jk))1310 zdf1 = (fsp(ji,jj,jk ) - fsp(ji,jj,jk-1)) / (xsp(ji,jj,jk ) - xsp(ji,jj,jk-1)) 1311 zdf2 = (fsp(ji,jj,jk+1) - fsp(ji,jj,jk )) / (xsp(ji,jj,jk+1) - xsp(ji,jj,jk )) 1357 1312 1358 1313 IF(zdf1 * zdf2 <= 0._wp) THEN … … 1403 1358 END DO 1404 1359 END DO 1405 1360 ! 1406 1361 ELSE 1407 1408 ENDIF 1409 1362 CALL ctl_stop( 'invalid polynomial type in cspline' ) 1363 ENDIF 1364 ! 1410 1365 END SUBROUTINE cspline 1411 1366 -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DYN/dynkeg.F90
r7753 r8568 22 22 USE lib_mpp ! MPP library 23 23 USE prtctl ! Print control 24 USE wrk_nemo ! Memory Allocation25 24 USE timing ! Timing 26 25 USE bdy_oce ! ocean open boundary conditions … … 39 38 # include "vectopt_loop_substitute.h90" 40 39 !!---------------------------------------------------------------------- 41 !! NEMO/OPA 3.6 , NEMO Consortium (2015)40 !! NEMO/OPA 4.0 , NEMO Consortium (2017) 42 41 !! $Id$ 43 42 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 75 74 INTEGER, INTENT( in ) :: kscheme ! =0/1 type of KEG scheme 76 75 ! 77 INTEGER :: ji, jj, jk ! dummy loop indices 78 REAL(wp) :: zu, zv ! temporary scalars 79 REAL(wp), POINTER, DIMENSION(:,:,:) :: zhke 80 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdu, ztrdv 81 INTEGER :: jb ! dummy loop indices 82 INTEGER :: ii, ij, igrd, ib_bdy ! local integers 83 INTEGER :: fu, fv 76 INTEGER :: ji, jj, jk, jb ! dummy loop indices 77 INTEGER :: ii, ifu, ib_bdy ! local integers 78 INTEGER :: ij, ifv, igrd ! - - 79 REAL(wp) :: zu, zv ! local scalars 80 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zhke 81 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdu, ztrdv 84 82 !!---------------------------------------------------------------------- 85 83 ! 86 IF( nn_timing == 1 ) CALL timing_start('dyn_keg') 87 ! 88 CALL wrk_alloc( jpi,jpj,jpk, zhke ) 84 IF( ln_timing ) CALL timing_start('dyn_keg') 89 85 ! 90 86 IF( kt == nit000 ) THEN … … 94 90 ENDIF 95 91 96 IF( l_trddyn ) THEN ! Save ua and vatrends97 CALL wrk_alloc( jpi,jpj,jpk, ztrdu, ztrdv)92 IF( l_trddyn ) THEN ! Save the input trends 93 ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) ) 98 94 ztrdu(:,:,:) = ua(:,:,:) 99 95 ztrdv(:,:,:) = va(:,:,:) … … 112 108 ii = idx_bdy(ib_bdy)%nbi(jb,igrd) 113 109 ij = idx_bdy(ib_bdy)%nbj(jb,igrd) 114 fu = NINT( idx_bdy(ib_bdy)%flagu(jb,igrd) )115 un(ii- fu,ij,jk) = un(ii,ij,jk) * umask(ii,ij,jk)110 ifu = NINT( idx_bdy(ib_bdy)%flagu(jb,igrd) ) 111 un(ii-ifu,ij,jk) = un(ii,ij,jk) * umask(ii,ij,jk) 116 112 END DO 117 113 END DO … … 122 118 ii = idx_bdy(ib_bdy)%nbi(jb,igrd) 123 119 ij = idx_bdy(ib_bdy)%nbj(jb,igrd) 124 fv = NINT( idx_bdy(ib_bdy)%flagv(jb,igrd) )125 vn(ii,ij- fv,jk) = vn(ii,ij,jk) * vmask(ii,ij,jk)120 ifv = NINT( idx_bdy(ib_bdy)%flagv(jb,igrd) ) 121 vn(ii,ij-ifv,jk) = vn(ii,ij,jk) * vmask(ii,ij,jk) 126 122 END DO 127 123 END DO … … 172 168 ENDIF 173 169 174 175 170 ! 176 171 DO jk = 1, jpkm1 !== grad( KE ) added to the general momentum trends ==! … … 187 182 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 188 183 CALL trd_dyn( ztrdu, ztrdv, jpdyn_keg, kt ) 189 CALL wrk_dealloc( jpi,jpj,jpk, ztrdu, ztrdv )184 DEALLOCATE( ztrdu , ztrdv ) 190 185 ENDIF 191 186 ! … … 193 188 & tab3d_2=va, clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) 194 189 ! 195 CALL wrk_dealloc( jpi,jpj,jpk, zhke ) 196 ! 197 IF( nn_timing == 1 ) CALL timing_stop('dyn_keg') 190 IF( ln_timing ) CALL timing_stop('dyn_keg') 198 191 ! 199 192 END SUBROUTINE dyn_keg -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DYN/dynldf.F90
r8215 r8568 27 27 USE lib_mpp ! distribued memory computing library 28 28 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 29 USE wrk_nemo ! Memory Allocation30 29 USE timing ! Timing 31 30 … … 48 47 # include "vectopt_loop_substitute.h90" 49 48 !!---------------------------------------------------------------------- 50 !! NEMO/OPA 3.7 , NEMO Consortium (2015)49 !! NEMO/OPA 4.0 , NEMO Consortium (2017) 51 50 !! $Id$ 52 51 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 62 61 INTEGER, INTENT(in) :: kt ! ocean time-step index 63 62 ! 64 REAL(wp), POINTER, DIMENSION(:,:,:) ::ztrdu, ztrdv63 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdu, ztrdv 65 64 !!---------------------------------------------------------------------- 66 65 ! 67 IF( nn_timing == 1 )CALL timing_start('dyn_ldf')66 IF( ln_timing ) CALL timing_start('dyn_ldf') 68 67 ! 69 68 IF( l_trddyn ) THEN ! temporary save of momentum trends 70 CALL wrk_alloc( jpi,jpj,jpk, ztrdu, ztrdv)69 ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) ) 71 70 ztrdu(:,:,:) = ua(:,:,:) 72 71 ztrdv(:,:,:) = va(:,:,:) … … 85 84 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 86 85 CALL trd_dyn( ztrdu, ztrdv, jpdyn_ldf, kt ) 87 CALL wrk_dealloc( jpi,jpj,jpk, ztrdu, ztrdv )86 DEALLOCATE ( ztrdu , ztrdv ) 88 87 ENDIF 89 88 ! ! print sum trends (used for debugging) … … 91 90 & tab3d_2=va, clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) 92 91 ! 93 IF( nn_timing == 1 )CALL timing_stop('dyn_ldf')92 IF( ln_timing ) CALL timing_stop('dyn_ldf') 94 93 ! 95 94 END SUBROUTINE dyn_ldf … … 102 101 !! ** Purpose : initializations of the horizontal ocean dynamics physics 103 102 !!---------------------------------------------------------------------- 104 INTEGER :: ioptio, ierr 103 INTEGER :: ioptio, ierr ! temporary integers 105 104 !!---------------------------------------------------------------------- 106 105 ! 107 ! ! Namelist nam_dynldf:already read in ldfdyn module106 ! !== Namelist nam_dynldf ==! already read in ldfdyn module 108 107 ! 109 IF(lwp) THEN ! Namelist print108 IF(lwp) THEN !== Namelist print ==! 110 109 WRITE(numout,*) 111 110 WRITE(numout,*) 'dyn_ldf_init : Choice of the lateral diffusive operator on dynamics' 112 111 WRITE(numout,*) '~~~~~~~~~~~~' 113 112 WRITE(numout,*) ' Namelist nam_dynldf : set lateral mixing parameters (type, direction, coefficients)' 114 WRITE(numout,*) ' laplacian operator ln_dynldf_lap = ', ln_dynldf_lap 115 WRITE(numout,*) ' bilaplacian operator ln_dynldf_blp = ', ln_dynldf_blp 116 WRITE(numout,*) ' iso-level ln_dynldf_lev = ', ln_dynldf_lev 117 WRITE(numout,*) ' horizontal (geopotential) ln_dynldf_hor = ', ln_dynldf_hor 118 WRITE(numout,*) ' iso-neutral ln_dynldf_iso = ', ln_dynldf_iso 113 WRITE(numout,*) ' Type of operator' 114 WRITE(numout,*) ' no explicit diffusion ln_dynldf_NONE = ', ln_dynldf_NONE 115 WRITE(numout,*) ' laplacian operator ln_dynldf_lap = ', ln_dynldf_lap 116 WRITE(numout,*) ' bilaplacian operator ln_dynldf_blp = ', ln_dynldf_blp 117 WRITE(numout,*) ' Direction of action' 118 WRITE(numout,*) ' iso-level ln_dynldf_lev = ', ln_dynldf_lev 119 WRITE(numout,*) ' horizontal (geopotential) ln_dynldf_hor = ', ln_dynldf_hor 120 WRITE(numout,*) ' iso-neutral ln_dynldf_iso = ', ln_dynldf_iso 119 121 ENDIF 120 ! ! use of lateral operator or not122 ! !== use of lateral operator or not ==! 121 123 nldf = np_ERROR 122 124 ioptio = 0 123 IF( ln_dynldf_ lap ) ioptio = ioptio + 1124 IF( ln_dynldf_ blp ) ioptio = ioptio + 1125 IF( ioptio > 1 ) CALL ctl_stop( 'dyn_ldf_init: use ONE or NONE of the 2 lap/bilap operator type on momentum' )126 IF( ioptio == 0 ) nldf = np_no_ldf ! No lateral mixing operator125 IF( ln_dynldf_NONE ) THEN ; nldf = np_no_ldf ; ioptio = ioptio + 1 ; ENDIF 126 IF( ln_dynldf_lap ) THEN ; ioptio = ioptio + 1 ; ENDIF 127 IF( ln_dynldf_blp ) THEN ; ioptio = ioptio + 1 ; ENDIF 128 IF( ioptio /= 1 ) CALL ctl_stop( 'dyn_ldf_init: use ONE of the 3 operator options (NONE/lap/blp)' ) 127 129 ! 128 IF( nldf /= np_no_ldf ) THEN ! direction ==>> type of operator130 IF(.NOT.ln_dynldf_NONE ) THEN !== direction ==>> type of operator ==! 129 131 ioptio = 0 130 132 IF( ln_dynldf_lev ) ioptio = ioptio + 1 131 133 IF( ln_dynldf_hor ) ioptio = ioptio + 1 132 134 IF( ln_dynldf_iso ) ioptio = ioptio + 1 133 IF( ioptio > 1 ) CALL ctl_stop( ' use only ONE direction (level/hor/iso)' ) 134 IF( ioptio == 0 ) CALL ctl_stop( ' use at least ONE direction (level/hor/iso)' ) 135 IF( ioptio /= 1 ) CALL ctl_stop( 'dyn_ldf_init: use ONE of the 3 direction options (level/hor/iso)' ) 135 136 ! 136 ! 137 ! ! Set nldf, the type of lateral diffusion, from ln_dynldf_... logicals 137 138 ierr = 0 138 IF ( ln_dynldf_lap ) THEN! laplacian operator139 IF 139 IF( ln_dynldf_lap ) THEN ! laplacian operator 140 IF( ln_zco ) THEN ! z-coordinate 140 141 IF ( ln_dynldf_lev ) nldf = np_lap ! iso-level = horizontal (no rotation) 141 142 IF ( ln_dynldf_hor ) nldf = np_lap ! iso-level = horizontal (no rotation) 142 143 IF ( ln_dynldf_iso ) nldf = np_lap_i ! iso-neutral ( rotation) 143 144 ENDIF 144 IF ( ln_zps ) THEN! z-coordinate with partial step145 IF( ln_zps ) THEN ! z-coordinate with partial step 145 146 IF ( ln_dynldf_lev ) nldf = np_lap ! iso-level (no rotation) 146 147 IF ( ln_dynldf_hor ) nldf = np_lap ! iso-level (no rotation) 147 148 IF ( ln_dynldf_iso ) nldf = np_lap_i ! iso-neutral ( rotation) 148 149 ENDIF 149 IF ( ln_sco ) THEN! s-coordinate150 IF( ln_sco ) THEN ! s-coordinate 150 151 IF ( ln_dynldf_lev ) nldf = np_lap ! iso-level = horizontal (no rotation) 151 152 IF ( ln_dynldf_hor ) nldf = np_lap_i ! horizontal ( rotation) … … 154 155 ENDIF 155 156 ! 156 IF( ln_dynldf_blp ) THEN 157 IF 158 IF 159 IF 160 IF 157 IF( ln_dynldf_blp ) THEN ! bilaplacian operator 158 IF( ln_zco ) THEN ! z-coordinate 159 IF( ln_dynldf_lev ) nldf = np_blp ! iso-level = horizontal (no rotation) 160 IF( ln_dynldf_hor ) nldf = np_blp ! iso-level = horizontal (no rotation) 161 IF( ln_dynldf_iso ) ierr = 2 ! iso-neutral ( rotation) 161 162 ENDIF 162 IF ( ln_zps ) THEN! z-coordinate with partial step163 IF 164 IF 165 IF 163 IF( ln_zps ) THEN ! z-coordinate with partial step 164 IF( ln_dynldf_lev ) nldf = np_blp ! iso-level (no rotation) 165 IF( ln_dynldf_hor ) nldf = np_blp ! iso-level (no rotation) 166 IF( ln_dynldf_iso ) ierr = 2 ! iso-neutral ( rotation) 166 167 ENDIF 167 IF ( ln_sco ) THEN! s-coordinate168 IF 169 IF 170 IF 168 IF( ln_sco ) THEN ! s-coordinate 169 IF( ln_dynldf_lev ) nldf = np_blp ! iso-level (no rotation) 170 IF( ln_dynldf_hor ) ierr = 2 ! horizontal ( rotation) 171 IF( ln_dynldf_iso ) ierr = 2 ! iso-neutral ( rotation) 171 172 ENDIF 172 173 ENDIF -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DYN/dynldf_iso.F90
r8215 r8568 28 28 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 29 29 USE prtctl ! Print control 30 USE wrk_nemo ! Memory Allocation31 30 USE timing ! Timing 32 31 … … 45 44 # include "vectopt_loop_substitute.h90" 46 45 !!---------------------------------------------------------------------- 47 !! NEMO/OPA 3.3 , NEMO Consortium (2011)46 !! NEMO/OPA 4.0 , NEMO Consortium (2017) 48 47 !! $Id$ 49 48 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 108 107 ! 109 108 INTEGER :: ji, jj, jk ! dummy loop indices 110 REAL(wp) :: zabe1, zabe2, zcof1, zcof2 ! local scalars 111 REAL(wp) :: zmskt, zmskf ! - - 112 REAL(wp) :: zcoef0, zcoef3, zcoef4, zmkt, zmkf ! - - 113 REAL(wp) :: zuav, zvav, zuwslpi, zuwslpj, zvwslpi, zvwslpj ! - - 114 ! 115 REAL(wp), POINTER, DIMENSION(:,:) :: ziut, zjuf, zjvt, zivf, zdku, zdk1u, zdkv, zdk1v 109 REAL(wp) :: zabe1, zmskt, zmkt, zuav, zuwslpi, zuwslpj ! local scalars 110 REAL(wp) :: zabe2, zmskf, zmkf, zvav, zvwslpi, zvwslpj ! - - 111 REAL(wp) :: zcof0, zcof1, zcof2, zcof3, zcof4 ! - - 112 REAL(wp), DIMENSION(jpi,jpj) :: ziut, zivf, zdku, zdk1u ! 2D workspace 113 REAL(wp), DIMENSION(jpi,jpj) :: zjuf, zjvt, zdkv, zdk1v ! - - 116 114 !!---------------------------------------------------------------------- 117 115 ! 118 IF( nn_timing == 1 ) CALL timing_start('dyn_ldf_iso') 119 ! 120 CALL wrk_alloc( jpi, jpj, ziut, zjuf, zjvt, zivf, zdku, zdk1u, zdkv, zdk1v ) 116 IF( ln_timing ) CALL timing_start('dyn_ldf_iso') 121 117 ! 122 118 IF( kt == nit000 ) THEN … … 343 339 DO jk = 2, jpkm1 344 340 DO ji = 2, jpim1 345 zco ef0= 0.5* rn_aht_0 * umask(ji,jj,jk)341 zcof0 = 0.5_wp * rn_aht_0 * umask(ji,jj,jk) 346 342 ! 347 zuwslpi = zco ef0 * ( wslpi(ji+1,jj,jk) + wslpi(ji,jj,jk) )348 zuwslpj = zco ef0 * ( wslpj(ji+1,jj,jk) + wslpj(ji,jj,jk) )343 zuwslpi = zcof0 * ( wslpi(ji+1,jj,jk) + wslpi(ji,jj,jk) ) 344 zuwslpj = zcof0 * ( wslpj(ji+1,jj,jk) + wslpj(ji,jj,jk) ) 349 345 ! 350 zmkt = 1./MAX( tmask(ji,jj,jk-1)+tmask(ji+1,jj,jk-1) &351 + tmask(ji,jj,jk )+tmask(ji+1,jj,jk ) , 1. )352 zmkf = 1./MAX( fmask(ji,jj-1,jk-1) + fmask(ji,jj,jk-1) &353 + fmask(ji,jj-1,jk ) + fmask(ji,jj,jk ) , 1. )354 355 zco ef3 = - e2u(ji,jj) * zmkt * zuwslpi356 zco ef4 = - e1u(ji,jj) * zmkf * zuwslpj346 zmkt = 1./MAX( tmask(ji,jj,jk-1)+tmask(ji+1,jj,jk-1) & 347 + tmask(ji,jj,jk )+tmask(ji+1,jj,jk ) , 1. ) 348 zmkf = 1./MAX( fmask(ji,jj-1,jk-1) + fmask(ji,jj,jk-1) & 349 + fmask(ji,jj-1,jk ) + fmask(ji,jj,jk ) , 1. ) 350 351 zcof3 = - e2u(ji,jj) * zmkt * zuwslpi 352 zcof4 = - e1u(ji,jj) * zmkf * zuwslpj 357 353 ! vertical flux on u field 358 zfuw(ji,jk) = zco ef3 * ( zdiu (ji,jk-1) + zdiu (ji+1,jk-1)&359 +zdiu (ji,jk ) + zdiu (ji+1,jk )) &360 + zcoef4 * ( zdj1u(ji,jk-1) + zdju (ji ,jk-1)&361 +zdj1u(ji,jk ) + zdju (ji ,jk ))354 zfuw(ji,jk) = zcof3 * ( zdiu (ji,jk-1) + zdiu (ji+1,jk-1) & 355 & + zdiu (ji,jk ) + zdiu (ji+1,jk ) ) & 356 & + zcof4 * ( zdj1u(ji,jk-1) + zdju (ji ,jk-1) & 357 & + zdj1u(ji,jk ) + zdju (ji ,jk ) ) 362 358 ! vertical mixing coefficient (akzu) 363 ! Note: zco ef0 include rn_aht_0, so divided by rn_aht_0 to obtain slp^2 * rn_aht_0359 ! Note: zcof0 include rn_aht_0, so divided by rn_aht_0 to obtain slp^2 * rn_aht_0 364 360 akzu(ji,jj,jk) = ( zuwslpi * zuwslpi + zuwslpj * zuwslpj ) / rn_aht_0 365 361 END DO … … 369 365 DO jk = 2, jpkm1 370 366 DO ji = 2, jpim1 371 zco ef0 = 0.5* rn_aht_0 * vmask(ji,jj,jk)372 373 zvwslpi = zco ef0 * ( wslpi(ji,jj+1,jk) + wslpi(ji,jj,jk) )374 zvwslpj = zco ef0 * ( wslpj(ji,jj+1,jk) + wslpj(ji,jj,jk) )375 376 zmkf = 1./MAX( fmask(ji-1,jj,jk-1)+fmask(ji,jj,jk-1) &377 + fmask(ji-1,jj,jk )+fmask(ji,jj,jk ), 1. )378 zmkt = 1./MAX( tmask(ji,jj,jk-1)+tmask(ji,jj+1,jk-1) &379 + tmask(ji,jj,jk )+tmask(ji,jj+1,jk ), 1. )380 381 zco ef3 = - e2v(ji,jj) * zmkf * zvwslpi382 zco ef4 = - e1v(ji,jj) * zmkt * zvwslpj367 zcof0 = 0.5_wp * rn_aht_0 * vmask(ji,jj,jk) 368 ! 369 zvwslpi = zcof0 * ( wslpi(ji,jj+1,jk) + wslpi(ji,jj,jk) ) 370 zvwslpj = zcof0 * ( wslpj(ji,jj+1,jk) + wslpj(ji,jj,jk) ) 371 ! 372 zmkf = 1./MAX( fmask(ji-1,jj,jk-1)+fmask(ji,jj,jk-1) & 373 & + fmask(ji-1,jj,jk )+fmask(ji,jj,jk ) , 1. ) 374 zmkt = 1./MAX( tmask(ji,jj,jk-1)+tmask(ji,jj+1,jk-1) & 375 & + tmask(ji,jj,jk )+tmask(ji,jj+1,jk ) , 1. ) 376 377 zcof3 = - e2v(ji,jj) * zmkf * zvwslpi 378 zcof4 = - e1v(ji,jj) * zmkt * zvwslpj 383 379 ! vertical flux on v field 384 zfvw(ji,jk) = zco ef3 * ( zdiv (ji,jk-1) + zdiv (ji-1,jk-1)&385 & +zdiv (ji,jk ) + zdiv (ji-1,jk )) &386 & + zco ef4 * ( zdjv (ji,jk-1) + zdj1v(ji ,jk-1)&387 & +zdjv (ji,jk ) + zdj1v(ji ,jk ))380 zfvw(ji,jk) = zcof3 * ( zdiv (ji,jk-1) + zdiv (ji-1,jk-1) & 381 & + zdiv (ji,jk ) + zdiv (ji-1,jk ) ) & 382 & + zcof4 * ( zdjv (ji,jk-1) + zdj1v(ji ,jk-1) & 383 & + zdjv (ji,jk ) + zdj1v(ji ,jk ) ) 388 384 ! vertical mixing coefficient (akzv) 389 ! Note: zco ef0 include rn_aht_0, so divided by rn_aht_0 to obtain slp^2 * rn_aht_0385 ! Note: zcof0 include rn_aht_0, so divided by rn_aht_0 to obtain slp^2 * rn_aht_0 390 386 akzv(ji,jj,jk) = ( zvwslpi * zvwslpi + zvwslpj * zvwslpj ) / rn_aht_0 391 387 END DO … … 404 400 END DO ! End of slab 405 401 ! ! =============== 406 CALL wrk_dealloc( jpi, jpj, ziut, zjuf, zjvt, zivf, zdku, zdk1u, zdkv, zdk1v )407 402 ! 408 IF( nn_timing == 1 )CALL timing_stop('dyn_ldf_iso')403 IF( ln_timing ) CALL timing_stop('dyn_ldf_iso') 409 404 ! 410 405 END SUBROUTINE dyn_ldf_iso -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DYN/dynldf_lap_blp.F90
r7753 r8568 19 19 USE in_out_manager ! I/O manager 20 20 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 21 USE wrk_nemo ! Memory Allocation22 21 USE timing ! Timing 23 22 … … 31 30 # include "vectopt_loop_substitute.h90" 32 31 !!---------------------------------------------------------------------- 33 !! NEMO/OPA 3.7 , NEMO Consortium (2014)32 !! NEMO/OPA 4.0 , NEMO Consortium (2017) 34 33 !! $Id$ 35 34 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 57 56 REAL(wp) :: zsign ! local scalars 58 57 REAL(wp) :: zua, zva ! local scalars 59 REAL(wp), POINTER, DIMENSION(:,:) ::zcur, zdiv58 REAL(wp), DIMENSION(jpi,jpj) :: zcur, zdiv 60 59 !!---------------------------------------------------------------------- 61 60 ! … … 66 65 ENDIF 67 66 ! 68 IF( nn_timing == 1 ) CALL timing_start('dyn_ldf_lap') 69 ! 70 CALL wrk_alloc( jpi, jpj, zcur, zdiv ) 67 IF( ln_timing ) CALL timing_start('dyn_ldf_lap') 71 68 ! 72 69 IF( kpass == 1 ) THEN ; zsign = 1._wp ! bilaplacian operator require a minus sign … … 107 104 END DO ! End of slab 108 105 ! ! =============== 109 CALL wrk_dealloc( jpi, jpj, zcur, zdiv )110 106 ! 111 IF( nn_timing == 1 )CALL timing_stop('dyn_ldf_lap')107 IF( ln_timing ) CALL timing_stop('dyn_ldf_lap') 112 108 ! 113 109 END SUBROUTINE dyn_ldf_lap … … 131 127 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pua, pva ! momentum trend 132 128 ! 133 REAL(wp), POINTER, DIMENSION(:,:,:) :: zulap, zvlap ! laplacian at u- and v-point129 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zulap, zvlap ! laplacian at u- and v-point 134 130 !!---------------------------------------------------------------------- 135 131 ! 136 IF( nn_timing == 1 ) CALL timing_start('dyn_ldf_blp') 137 ! 138 CALL wrk_alloc( jpi, jpj, jpk, zulap, zvlap ) 132 IF( ln_timing ) CALL timing_start('dyn_ldf_blp') 139 133 ! 140 134 IF( kt == nit000 ) THEN … … 154 148 CALL dyn_ldf_lap( kt, zulap, zvlap, pua, pva, 2 ) ! rotated laplacian applied to zlap (output in pta) 155 149 ! 156 CALL wrk_dealloc( jpi, jpj, jpk, zulap, zvlap ) 157 ! 158 IF( nn_timing == 1 ) CALL timing_stop('dyn_ldf_blp') 150 IF( ln_timing ) CALL timing_stop('dyn_ldf_blp') 159 151 ! 160 152 END SUBROUTINE dyn_ldf_blp -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DYN/dynnxt.F90
r7753 r8568 44 44 USE lbclnk ! lateral boundary condition (or mpp link) 45 45 USE lib_mpp ! MPP library 46 USE wrk_nemo ! Memory Allocation47 46 USE prtctl ! Print control 48 47 USE timing ! Timing … … 57 56 58 57 !!---------------------------------------------------------------------- 59 !! NEMO/OPA 3.3 , NEMO Consortium (2010)58 !! NEMO/OPA 4.0 , NEMO Consortium (2017) 60 59 !! $Id$ 61 60 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 97 96 REAL(wp) :: zue3a, zue3n, zue3b, zuf, zcoef ! local scalars 98 97 REAL(wp) :: zve3a, zve3n, zve3b, zvf, z1_2dt ! - - 99 REAL(wp), POINTER, DIMENSION(:,:) ::zue, zve100 REAL(wp), POINTER, DIMENSION(:,:,:) ::ze3u_f, ze3v_f, zua, zva98 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zue, zve 99 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ze3u_f, ze3v_f, zua, zva 101 100 !!---------------------------------------------------------------------- 102 101 ! 103 IF( nn_timing == 1 ) CALL timing_start('dyn_nxt') 104 ! 105 IF( ln_dynspg_ts ) CALL wrk_alloc( jpi,jpj, zue, zve) 106 IF( l_trddyn ) CALL wrk_alloc( jpi,jpj,jpk, zua, zva) 102 IF( ln_timing ) CALL timing_start('dyn_nxt') 103 IF( ln_dynspg_ts ) ALLOCATE( zue(jpi,jpj) , zve(jpi,jpj) ) 104 IF( l_trddyn ) ALLOCATE( zua(jpi,jpj,jpk) , zva(jpi,jpj,jpk) ) 107 105 ! 108 106 IF( kt == nit000 ) THEN … … 253 251 ELSE ! Asselin filter applied on thickness weighted velocity 254 252 ! 255 CALL wrk_alloc( jpi,jpj,jpk, ze3u_f, ze3v_f)253 ALLOCATE( ze3u_f(jpi,jpj,jpk) , ze3v_f(jpi,jpj,jpk) ) 256 254 ! Before filtered scale factor at (u/v)-points stored in ze3u_f, ze3v_f 257 255 CALL dom_vvl_interpol( e3t_b(:,:,:), ze3u_f, 'U' ) … … 280 278 e3v_b(:,:,1:jpkm1) = ze3v_f(:,:,1:jpkm1) 281 279 ! 282 CALL wrk_dealloc( jpi,jpj,jpk, ze3u_f, ze3v_f )280 DEALLOCATE( ze3u_f , ze3v_f ) 283 281 ENDIF 284 282 ! … … 346 344 & tab3d_2=vn, clinfo2=' Vn: ' , mask2=vmask ) 347 345 ! 348 IF( ln_dynspg_ts ) CALL wrk_dealloc( jpi,jpj, zue, zve ) 349 IF( l_trddyn ) CALL wrk_dealloc( jpi,jpj,jpk, zua, zva ) 350 ! 351 IF( nn_timing == 1 ) CALL timing_stop('dyn_nxt') 346 IF( ln_dynspg_ts ) DEALLOCATE( zue, zve ) 347 IF( l_trddyn ) DEALLOCATE( zua, zva ) 348 IF( ln_timing ) CALL timing_stop('dyn_nxt') 352 349 ! 353 350 END SUBROUTINE dyn_nxt -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg.F90
r7753 r8568 28 28 USE in_out_manager ! I/O manager 29 29 USE lib_mpp ! MPP library 30 USE wrk_nemo ! Memory Allocation31 30 USE timing ! Timing 32 31 … … 47 46 # include "vectopt_loop_substitute.h90" 48 47 !!---------------------------------------------------------------------- 49 !! NEMO/OPA 3.2 , LODYC-IPSL (2009)48 !! NEMO/OPA 4.0 , LODYC-IPSL (2017) 50 49 !! $Id$ 51 50 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 71 70 !! period is used to prevent the divergence of odd and even time step. 72 71 !!---------------------------------------------------------------------- 73 INTEGER, INTENT(in ) :: kt 74 ! 75 INTEGER :: ji, jj, jk 76 REAL(wp) :: z2dt, zg_2, zintp, zgrau0r ! temporary scalar77 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdu, ztrdv78 REAL(wp), POINTER, DIMENSION(:,:) :: zpice79 !!---------------------------------------------------------------------- 80 ! 81 IF( nn_timing == 1 )CALL timing_start('dyn_spg')72 INTEGER, INTENT(in ) :: kt ! ocean time-step index 73 ! 74 INTEGER :: ji, jj, jk ! dummy loop indices 75 REAL(wp) :: z2dt, zg_2, zintp, zgrau0r ! local scalars 76 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zpice 77 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdu, ztrdv 78 !!---------------------------------------------------------------------- 79 ! 80 IF( ln_timing ) CALL timing_start('dyn_spg') 82 81 ! 83 82 IF( l_trddyn ) THEN ! temporary save of ta and sa trends 84 CALL wrk_alloc( jpi,jpj,jpk, ztrdu, ztrdv)83 ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) ) 85 84 ztrdu(:,:,:) = ua(:,:,:) 86 85 ztrdv(:,:,:) = va(:,:,:) … … 124 123 ! 125 124 IF( nn_ice_embd == 2 ) THEN !== embedded sea ice: Pressure gradient due to snow-ice mass ==! 126 CALL wrk_alloc( jpi,jpj, zpice ) 127 ! 125 ALLOCATE( zpice(jpi,jpj) ) 128 126 zintp = REAL( MOD( kt-1, nn_fsbc ) ) / REAL( nn_fsbc ) 129 127 zgrau0r = - grav * r1_rau0 … … 135 133 END DO 136 134 END DO 137 ! 138 CALL wrk_dealloc( jpi,jpj, zpice ) 135 DEALLOCATE( zpice ) 139 136 ENDIF 140 137 ! … … 161 158 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 162 159 CALL trd_dyn( ztrdu, ztrdv, jpdyn_spg, kt ) 163 CALL wrk_dealloc( jpi,jpj,jpk, ztrdu, ztrdv )160 DEALLOCATE( ztrdu , ztrdv ) 164 161 ENDIF 165 162 ! ! print mean trends (used for debugging) … … 167 164 & tab3d_2=va, clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) 168 165 ! 169 IF( nn_timing == 1 )CALL timing_stop('dyn_spg')166 IF( ln_timing ) CALL timing_stop('dyn_spg') 170 167 ! 171 168 END SUBROUTINE dyn_spg … … 186 183 !!---------------------------------------------------------------------- 187 184 ! 188 IF( nn_timing == 1 )CALL timing_start('dyn_spg_init')185 IF( ln_timing ) CALL timing_start('dyn_spg_init') 189 186 ! 190 187 REWIND( numnam_ref ) ! Namelist namdyn_spg in reference namelist : Free surface … … 227 224 ENDIF 228 225 ! 229 IF( nn_timing == 1 )CALL timing_stop('dyn_spg_init')226 IF( ln_timing ) CALL timing_stop('dyn_spg_init') 230 227 ! 231 228 END SUBROUTINE dyn_spg_init -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_exp.F90
r6140 r8568 61 61 !!---------------------------------------------------------------------- 62 62 ! 63 IF( nn_timing == 1 )CALL timing_start('dyn_spg_exp')63 IF( ln_timing ) CALL timing_start('dyn_spg_exp') 64 64 ! 65 65 IF( kt == nit000 ) THEN … … 93 93 ENDIF 94 94 ! 95 IF( nn_timing == 1 )CALL timing_stop('dyn_spg_exp')95 IF( ln_timing ) CALL timing_stop('dyn_spg_exp') 96 96 ! 97 97 END SUBROUTINE dyn_spg_exp -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_ts.F90
r8215 r8568 162 162 !!---------------------------------------------------------------------- 163 163 ! 164 IF( nn_timing == 1) CALL timing_start('dyn_spg_ts')164 IF( ln_timing ) CALL timing_start('dyn_spg_ts') 165 165 ! 166 166 IF( ln_wd ) ALLOCATE( zcpx(jpi,jpj), zcpy(jpi,jpj) ) … … 1125 1125 IF( ln_wd ) DEALLOCATE( zcpx, zcpy ) 1126 1126 ! 1127 IF 1127 IF( ln_diatmb ) THEN 1128 1128 CALL iom_put( "baro_u" , un_b*umask(:,:,1)+zmdi*(1-umask(:,:,1 ) ) ) ! Barotropic U Velocity 1129 1129 CALL iom_put( "baro_v" , vn_b*vmask(:,:,1)+zmdi*(1-vmask(:,:,1 ) ) ) ! Barotropic V Velocity 1130 1130 ENDIF 1131 IF( nn_timing == 1 )CALL timing_stop('dyn_spg_ts')1131 IF( ln_timing ) CALL timing_stop('dyn_spg_ts') 1132 1132 ! 1133 1133 END SUBROUTINE dyn_spg_ts -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DYN/dynvor.F90
r7753 r8568 14 14 !! 2.0 ! 2006-11 (G. Madec) flux form advection: add metric term 15 15 !! 3.2 ! 2009-04 (R. Benshila) vvl: correction of een scheme 16 !! 3.3 ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase17 !! 3.7 ! 2014-04 (G. Madec) trend simplification: suppress jpdyn_trd_dat vorticity18 !! - ! 2014-06 (G. Madec) suppression of velocity curl from in-core memory16 !! 3.3 ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase 17 !! 3.7 ! 2014-04 (G. Madec) trend simplification: suppress jpdyn_trd_dat vorticity 18 !! - ! 2014-06 (G. Madec) suppression of velocity curl from in-core memory 19 19 !! - ! 2016-12 (G. Madec, E. Clementi) add Stokes-Coriolis trends (ln_stcor=T) 20 !! 4.0 ! 2017-07 (G. Madec) linear dynamics + trends diag. with Stokes-Coriolis 20 21 !!---------------------------------------------------------------------- 21 22 22 23 !!---------------------------------------------------------------------- 23 !! dyn_vor : Update the momentum trend with the vorticity trend24 !! vor_ens : enstrophy conserving scheme (ln_dynvor_ens=T)25 !! vor_ene : energy conserving scheme (ln_dynvor_ene=T)26 !! vor_een : energy and enstrophy conserving (ln_dynvor_een=T)27 !! dyn_vor_init : set and control of the different vorticity option24 !! dyn_vor : Update the momentum trend with the vorticity trend 25 !! vor_ens : enstrophy conserving scheme (ln_dynvor_ens=T) 26 !! vor_ene : energy conserving scheme (ln_dynvor_ene=T) 27 !! vor_een : energy and enstrophy conserving (ln_dynvor_een=T) 28 !! dyn_vor_init : set and control of the different vorticity option 28 29 !!---------------------------------------------------------------------- 29 30 USE oce ! ocean dynamics and tracers 30 31 USE dom_oce ! ocean space and time domain 31 32 USE dommsk ! ocean mask 32 USE dynadv ! momentum advection (use ln_dynadv_vec value)33 USE dynadv ! momentum advection 33 34 USE trd_oce ! trends: ocean variables 34 35 USE trddyn ! trend manager: dynamics … … 40 41 USE in_out_manager ! I/O manager 41 42 USE lib_mpp ! MPP library 42 USE wrk_nemo ! Memory Allocation43 43 USE timing ! Timing 44 45 44 46 45 IMPLICIT NONE … … 80 79 # include "vectopt_loop_substitute.h90" 81 80 !!---------------------------------------------------------------------- 82 !! NEMO/OPA 3.7 , NEMO Consortium (2016)81 !! NEMO/OPA 4.0 , NEMO Consortium (2017) 83 82 !! $Id$ 84 83 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 98 97 INTEGER, INTENT( in ) :: kt ! ocean time-step index 99 98 ! 100 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdu, ztrdv 101 !!---------------------------------------------------------------------- 102 ! 103 IF( nn_timing == 1 ) CALL timing_start('dyn_vor') 104 ! 105 IF( l_trddyn ) CALL wrk_alloc( jpi,jpj,jpk, ztrdu, ztrdv ) 106 ! 107 SELECT CASE ( nvor_scheme ) !== vorticity trend added to the general trend ==! 108 ! 109 CASE ( np_ENE ) !* energy conserving scheme 110 IF( l_trddyn ) THEN ! trend diagnostics: split the trend in two 99 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdu, ztrdv 100 !!---------------------------------------------------------------------- 101 ! 102 IF( ln_timing ) CALL timing_start('dyn_vor') 103 ! 104 IF( l_trddyn ) THEN !== trend diagnostics case : split the added trend in two parts ==! 105 ! 106 ALLOCATE( ztrdu(jpi,jpj,jpk), ztrdv(jpi,jpj,jpk) ) 107 ! 108 ztrdu(:,:,:) = ua(:,:,:) !* planetary vorticity trend (including Stokes-Coriolis force) 109 ztrdv(:,:,:) = va(:,:,:) 110 SELECT CASE( nvor_scheme ) 111 CASE( np_ENE, np_MIX ) ; CALL vor_ene( kt, ncor, un , vn , ua, va ) ! energy conserving scheme 112 IF( ln_stcor ) CALL vor_ene( kt, ncor, usd, vsd, ua, va ) ! add the Stokes-Coriolis trend 113 CASE( np_ENS ) ; CALL vor_ens( kt, ncor, un , vn , ua, va ) ! enstrophy conserving scheme 114 IF( ln_stcor ) CALL vor_ens( kt, ncor, usd, vsd, ua, va ) ! add the Stokes-Coriolis trend 115 CASE( np_EEN ) ; CALL vor_een( kt, ncor, un , vn , ua, va ) ! energy & enstrophy scheme 116 IF( ln_stcor ) CALL vor_een( kt, ncor, usd, vsd, ua, va ) ! add the Stokes-Coriolis trend 117 END SELECT 118 ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) 119 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 120 CALL trd_dyn( ztrdu, ztrdv, jpdyn_pvo, kt ) 121 ! 122 IF( n_dynadv /= np_LIN_dyn ) THEN !* relative vorticity or metric trend (only in non-linear case) 111 123 ztrdu(:,:,:) = ua(:,:,:) 112 124 ztrdv(:,:,:) = va(:,:,:) 113 CALL vor_ene( kt, nrvm, un , vn , ua, va ) ! relative vorticity or metric trend 125 SELECT CASE( nvor_scheme ) 126 CASE( np_ENE ) ; CALL vor_ene( kt, nrvm, un , vn , ua, va ) ! energy conserving scheme 127 CASE( np_ENS, np_MIX ) ; CALL vor_ens( kt, nrvm, un , vn , ua, va ) ! enstrophy conserving scheme 128 CASE( np_EEN ) ; CALL vor_een( kt, nrvm, un , vn , ua, va ) ! energy & enstrophy scheme 129 END SELECT 114 130 ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) 115 131 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 116 132 CALL trd_dyn( ztrdu, ztrdv, jpdyn_rvo, kt ) 117 ztrdu(:,:,:) = ua(:,:,:) 118 ztrdv(:,:,:) = va(:,:,:) 119 CALL vor_ene( kt, ncor, un , vn , ua, va ) ! planetary vorticity trend 120 ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) 121 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 122 CALL trd_dyn( ztrdu, ztrdv, jpdyn_pvo, kt ) 123 ELSE ! total vorticity trend 133 ENDIF 134 ! 135 DEALLOCATE( ztrdu, ztrdv ) 136 ! 137 ELSE !== total vorticity trend added to the general trend ==! 138 ! 139 SELECT CASE ( nvor_scheme ) !== vorticity trend added to the general trend ==! 140 CASE( np_ENE ) !* energy conserving scheme 124 141 CALL vor_ene( kt, ntot, un , vn , ua, va ) ! total vorticity trend 125 142 IF( ln_stcor ) CALL vor_ene( kt, ncor, usd, vsd, ua, va ) ! add the Stokes-Coriolis trend 126 ENDIF 127 ! 128 CASE ( np_ENS ) !* enstrophy conserving scheme 129 IF( l_trddyn ) THEN ! trend diagnostics: splitthe trend in two 130 ztrdu(:,:,:) = ua(:,:,:) 131 ztrdv(:,:,:) = va(:,:,:) 132 CALL vor_ens( kt, nrvm, un , vn , ua, va ) ! relative vorticity or metric trend 133 ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) 134 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 135 CALL trd_dyn( ztrdu, ztrdv, jpdyn_rvo, kt ) 136 ztrdu(:,:,:) = ua(:,:,:) 137 ztrdv(:,:,:) = va(:,:,:) 138 CALL vor_ens( kt, ncor, un , vn , ua, va ) ! planetary vorticity trend 139 ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) 140 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 141 CALL trd_dyn( ztrdu, ztrdv, jpdyn_pvo, kt ) 142 ELSE ! total vorticity trend 143 CASE( np_ENS ) !* enstrophy conserving scheme 143 144 CALL vor_ens( kt, ntot, un , vn , ua, va ) ! total vorticity trend 144 145 IF( ln_stcor ) CALL vor_ens( kt, ncor, usd, vsd, ua, va ) ! add the Stokes-Coriolis trend 145 ENDIF 146 ! 147 CASE ( np_MIX ) !* mixed ene-ens scheme 148 IF( l_trddyn ) THEN ! trend diagnostics: split the trend in two 149 ztrdu(:,:,:) = ua(:,:,:) 150 ztrdv(:,:,:) = va(:,:,:) 151 CALL vor_ens( kt, nrvm, un , vn , ua, va ) ! relative vorticity or metric trend (ens) 152 ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) 153 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 154 CALL trd_dyn( ztrdu, ztrdv, jpdyn_rvo, kt ) 155 ztrdu(:,:,:) = ua(:,:,:) 156 ztrdv(:,:,:) = va(:,:,:) 157 CALL vor_ene( kt, ncor, un , vn , ua, va ) ! planetary vorticity trend (ene) 158 ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) 159 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 160 CALL trd_dyn( ztrdu, ztrdv, jpdyn_pvo, kt ) 161 ELSE ! total vorticity trend 146 CASE( np_MIX ) !* mixed ene-ens scheme 162 147 CALL vor_ens( kt, nrvm, un , vn , ua, va ) ! relative vorticity or metric trend (ens) 163 148 CALL vor_ene( kt, ncor, un , vn , ua, va ) ! planetary vorticity trend (ene) 164 149 IF( ln_stcor ) CALL vor_ene( kt, ncor, usd, vsd, ua, va ) ! add the Stokes-Coriolis trend 165 ENDIF 166 ! 167 CASE ( np_EEN ) !* energy and enstrophy conserving scheme 168 IF( l_trddyn ) THEN ! trend diagnostics: split the trend in two 169 ztrdu(:,:,:) = ua(:,:,:) 170 ztrdv(:,:,:) = va(:,:,:) 171 CALL vor_een( kt, nrvm, un , vn , ua, va ) ! relative vorticity or metric trend 172 ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) 173 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 174 CALL trd_dyn( ztrdu, ztrdv, jpdyn_rvo, kt ) 175 ztrdu(:,:,:) = ua(:,:,:) 176 ztrdv(:,:,:) = va(:,:,:) 177 CALL vor_een( kt, ncor, un , vn , ua, va ) ! planetary vorticity trend 178 ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) 179 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 180 CALL trd_dyn( ztrdu, ztrdv, jpdyn_pvo, kt ) 181 ELSE ! total vorticity trend 150 CASE( np_EEN ) !* energy and enstrophy conserving scheme 182 151 CALL vor_een( kt, ntot, un , vn , ua, va ) ! total vorticity trend 183 152 IF( ln_stcor ) CALL vor_ene( kt, ncor, usd, vsd, ua, va ) ! add the Stokes-Coriolis trend 184 END IF185 ! 186 END SELECT153 END SELECT 154 ! 155 ENDIF 187 156 ! 188 157 ! ! print sum trends (used for debugging) … … 190 159 & tab3d_2=va, clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) 191 160 ! 192 IF( l_trddyn ) CALL wrk_dealloc( jpi,jpj,jpk, ztrdu, ztrdv ) 193 ! 194 IF( nn_timing == 1 ) CALL timing_stop('dyn_vor') 161 IF( ln_timing ) CALL timing_stop('dyn_vor') 195 162 ! 196 163 END SUBROUTINE dyn_vor … … 217 184 !! References : Sadourny, r., 1975, j. atmos. sciences, 32, 680-689. 218 185 !!---------------------------------------------------------------------- 219 INTEGER , INTENT(in ) :: kt ! ocean time-step index 220 INTEGER , INTENT(in ) :: kvor ! =ncor (planetary) ; =ntot (total) ; 221 ! ! =nrvm (relative vorticity or metric) 222 REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) :: pun, pvn ! now velocities 223 REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) :: pua, pva ! total v-trend 186 INTEGER , INTENT(in ):: kt ! ocean time-step index 187 INTEGER , INTENT(in ):: kvor ! total, planetary, relative, or metric 188 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pun, pvn ! now velocities 189 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pua, pva ! total v-trend 224 190 ! 225 191 INTEGER :: ji, jj, jk ! dummy loop indices 226 192 REAL(wp) :: zx1, zy1, zx2, zy2 ! local scalars 227 REAL(wp), POINTER, DIMENSION(:,:) :: zwx, zwy, zwz ! 2D workspace 228 !!---------------------------------------------------------------------- 229 ! 230 IF( nn_timing == 1 ) CALL timing_start('vor_ene') 231 ! 232 CALL wrk_alloc( jpi,jpj, zwx, zwy, zwz ) 193 REAL(wp), DIMENSION(jpi,jpj) :: zwx, zwy, zwz ! 2D workspace 194 !!---------------------------------------------------------------------- 195 ! 196 IF( ln_timing ) CALL timing_start('vor_ene') 233 197 ! 234 198 IF( kt == nit000 ) THEN … … 264 228 DO ji = 1, fs_jpim1 ! vector opt. 265 229 zwz(ji,jj) = ff_f(ji,jj) + ( e2v(ji+1,jj ) * pvn(ji+1,jj ,jk) - e2v(ji,jj) * pvn(ji,jj,jk) & 266 & - e1u(ji ,jj+1) * pun(ji ,jj+1,jk) + e1u(ji,jj) * pun(ji,jj,jk) ) &230 & - e1u(ji ,jj+1) * pun(ji ,jj+1,jk) + e1u(ji,jj) * pun(ji,jj,jk) ) & 267 231 & * r1_e1e2f(ji,jj) 268 232 END DO … … 311 275 END DO ! End of slab 312 276 ! ! =============== 313 CALL wrk_dealloc( jpi, jpj, zwx, zwy, zwz ) 314 ! 315 IF( nn_timing == 1 ) CALL timing_stop('vor_ene') 277 ! 278 IF( ln_timing ) CALL timing_stop('vor_ene') 316 279 ! 317 280 END SUBROUTINE vor_ene … … 338 301 !! References : Sadourny, r., 1975, j. atmos. sciences, 32, 680-689. 339 302 !!---------------------------------------------------------------------- 340 INTEGER , INTENT(in ) :: kt ! ocean time-step index 341 INTEGER , INTENT(in ) :: kvor ! =ncor (planetary) ; =ntot (total) ; 342 ! ! =nrvm (relative vorticity or metric) 343 REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) :: pun, pvn ! now velocities 344 REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) :: pua, pva ! total v-trend 303 INTEGER , INTENT(in ):: kt ! ocean time-step index 304 INTEGER , INTENT(in ):: kvor ! total, planetary, relative, or metric 305 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pun, pvn ! now velocities 306 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pua, pva ! total v-trend 345 307 ! 346 308 INTEGER :: ji, jj, jk ! dummy loop indices 347 309 REAL(wp) :: zuav, zvau ! local scalars 348 REAL(wp), POINTER, DIMENSION(:,:) :: zwx, zwy, zwz, zww ! 2D workspace 349 !!---------------------------------------------------------------------- 350 ! 351 IF( nn_timing == 1 ) CALL timing_start('vor_ens') 352 ! 353 CALL wrk_alloc( jpi,jpj, zwx, zwy, zwz ) 310 REAL(wp), DIMENSION(jpi,jpj) :: zwx, zwy, zwz, zww ! 2D workspace 311 !!---------------------------------------------------------------------- 312 ! 313 IF( ln_timing ) CALL timing_start('vor_ens') 354 314 ! 355 315 IF( kt == nit000 ) THEN … … 431 391 END DO ! End of slab 432 392 ! ! =============== 433 CALL wrk_dealloc( jpi, jpj, zwx, zwy, zwz ) 434 ! 435 IF( nn_timing == 1 ) CALL timing_stop('vor_ens') 393 ! 394 IF( ln_timing ) CALL timing_stop('vor_ens') 436 395 ! 437 396 END SUBROUTINE vor_ens … … 455 414 !! References : Arakawa and Lamb 1980, Mon. Wea. Rev., 109, 18-36 456 415 !!---------------------------------------------------------------------- 457 INTEGER , INTENT(in ) :: kt ! ocean time-step index 458 INTEGER , INTENT(in ) :: kvor ! =ncor (planetary) ; =ntot (total) ; 459 ! ! =nrvm (relative vorticity or metric) 460 REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) :: pun, pvn ! now velocities 461 REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) :: pua, pva ! total v-trend 416 INTEGER , INTENT(in ):: kt ! ocean time-step index 417 INTEGER , INTENT(in ):: kvor ! total, planetary, relative, or metric 418 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pun, pvn ! now velocities 419 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pua, pva ! total v-trend 462 420 ! 463 421 INTEGER :: ji, jj, jk ! dummy loop indices … … 465 423 REAL(wp) :: zua, zva ! local scalars 466 424 REAL(wp) :: zmsk, ze3 ! local scalars 467 ! 468 REAL(wp), POINTER, DIMENSION(:,:) :: zwx, zwy, zwz, z1_e3f 469 REAL(wp), POINTER, DIMENSION(:,:) :: ztnw, ztne, ztsw, ztse 470 !!---------------------------------------------------------------------- 471 ! 472 IF( nn_timing == 1 ) CALL timing_start('vor_een') 473 ! 474 CALL wrk_alloc( jpi,jpj, zwx , zwy , zwz , z1_e3f ) 475 CALL wrk_alloc( jpi,jpj, ztnw, ztne, ztsw, ztse ) 425 REAL(wp), DIMENSION(jpi,jpj) :: zwx , zwy , zwz , z1_e3f 426 REAL(wp), DIMENSION(jpi,jpj) :: ztnw, ztne, ztsw, ztse 427 !!---------------------------------------------------------------------- 428 ! 429 IF( ln_timing ) CALL timing_start('vor_een') 476 430 ! 477 431 IF( kt == nit000 ) THEN … … 599 553 ! ! =============== 600 554 ! 601 CALL wrk_dealloc( jpi,jpj, zwx , zwy , zwz , z1_e3f ) 602 CALL wrk_dealloc( jpi,jpj, ztnw, ztne, ztsw, ztse ) 603 ! 604 IF( nn_timing == 1 ) CALL timing_stop('vor_een') 555 IF( ln_timing ) CALL timing_stop('vor_een') 605 556 ! 606 557 END SUBROUTINE vor_een … … 618 569 INTEGER :: ios ! Local integer output status for namelist read 619 570 !! 620 NAMELIST/namdyn_vor/ ln_dynvor_ens, ln_dynvor_ene, ln_dynvor_mix, ln_dynvor_een, nn_een_e3f, ln_dynvor_msk 571 NAMELIST/namdyn_vor/ ln_dynvor_ens, ln_dynvor_ene, ln_dynvor_mix, & 572 & ln_dynvor_een, nn_een_e3f , ln_dynvor_msk 621 573 !!---------------------------------------------------------------------- 622 574 … … 672 624 ! 673 625 IF(lwp) WRITE(numout,*) ! type of calculated vorticity (set ncor, nrvm, ntot) 674 ncor = np_COR 675 IF( ln_dynadv_vec ) THEN 676 IF(lwp) WRITE(numout,*) ' ===>> Vector form advection : vorticity = Coriolis + relative vorticity' 626 ncor = np_COR ! planetary vorticity 627 SELECT CASE( n_dynadv ) 628 CASE( np_LIN_dyn ) 629 IF(lwp) WRITE(numout,*) ' ===>> linear dynamics : total vorticity = Coriolis' 630 nrvm = np_COR ! planetary vorticity 631 ntot = np_COR ! - - 632 CASE( np_VEC_c2 ) 633 IF(lwp) WRITE(numout,*) ' ===>> vector form dynamics : total vorticity = Coriolis + relative vorticity' 677 634 nrvm = np_RVO ! relative vorticity 678 ntot = np_CRV ! relative + planetary vorticity 679 ELSE680 IF(lwp) WRITE(numout,*) ' ===>> Flux form advection :vorticity = Coriolis + metric term'635 ntot = np_CRV ! relative + planetary vorticity 636 CASE( np_FLX_c2 , np_FLX_ubs ) 637 IF(lwp) WRITE(numout,*) ' ===>> flux form dynamics : total vorticity = Coriolis + metric term' 681 638 nrvm = np_MET ! metric term 682 639 ntot = np_CME ! Coriolis + metric term 683 END IF640 END SELECT 684 641 685 642 IF(lwp) THEN ! Print the choice 686 643 WRITE(numout,*) 687 IF( nvor_scheme == np_ENE ) WRITE(numout,*) ' ===>> energy conserving scheme' 688 IF( nvor_scheme == np_ENS ) WRITE(numout,*) ' ===>> enstrophy conserving scheme' 689 IF( nvor_scheme == np_MIX ) WRITE(numout,*) ' ===>> mixed enstrophy/energy conserving scheme' 690 IF( nvor_scheme == np_EEN ) WRITE(numout,*) ' ===>> energy and enstrophy conserving scheme' 644 SELECT CASE( nvor_scheme ) 645 CASE( np_ENE ) ; WRITE(numout,*) ' ===>> energy conserving scheme' 646 CASE( np_ENS ) ; WRITE(numout,*) ' ===>> enstrophy conserving scheme' 647 CASE( np_MIX ) ; WRITE(numout,*) ' ===>> mixed enstrophy/energy conserving scheme' 648 CASE( np_EEN ) ; WRITE(numout,*) ' ===>> energy and enstrophy conserving scheme' 649 END SELECT 691 650 ENDIF 692 651 ! -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DYN/dynzad.F90
r7753 r8568 5 5 !!====================================================================== 6 6 !! History : OPA ! 1991-01 (G. Madec) Original code 7 !! 7.0 ! 1991-11 (G. Madec)8 !! 7.5 ! 1996-01 (G. Madec) statement function for e39 7 !! NEMO 0.5 ! 2002-07 (G. Madec) Free form, F90 10 8 !!---------------------------------------------------------------------- … … 22 20 USE lib_mpp ! MPP library 23 21 USE prtctl ! Print control 24 USE wrk_nemo ! Memory Allocation25 22 USE timing ! Timing 26 23 … … 29 26 30 27 PUBLIC dyn_zad ! routine called by dynadv.F90 31 PUBLIC dyn_zad_zts ! routine called by dynadv.F9032 28 33 29 !! * Substitutions 34 30 # include "vectopt_loop_substitute.h90" 35 31 !!---------------------------------------------------------------------- 36 !! NEMO/OPA 3.3 , NEMO Consortium (2010)32 !! NEMO/OPA 4.0 , NEMO Consortium (2017) 37 33 !! $Id$ 38 34 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 58 54 INTEGER, INTENT(in) :: kt ! ocean time-step inedx 59 55 ! 60 INTEGER :: ji, jj, jk 61 REAL(wp) :: zua, zva ! temporaryscalars62 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwuw , zwvw63 REAL(wp), POINTER, DIMENSION(:,: ) :: zww64 REAL(wp), POINTER, DIMENSION(:,:,:) ::ztrdu, ztrdv56 INTEGER :: ji, jj, jk ! dummy loop indices 57 REAL(wp) :: zua, zva ! local scalars 58 REAL(wp), DIMENSION(jpi,jpj) :: zww 59 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwuw, zwvw 60 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdu, ztrdv 65 61 !!---------------------------------------------------------------------- 66 62 ! 67 IF( nn_timing == 1 ) CALL timing_start('dyn_zad') 68 ! 69 CALL wrk_alloc( jpi,jpj, zww ) 70 CALL wrk_alloc( jpi,jpj,jpk, zwuw , zwvw ) 63 IF( ln_timing ) CALL timing_start('dyn_zad') 71 64 ! 72 65 IF( kt == nit000 ) THEN 73 IF(lwp) WRITE(numout,*)74 IF(lwp) WRITE(numout,*) 'dyn_zad : arakawaadvection scheme'66 IF(lwp) WRITE(numout,*) 67 IF(lwp) WRITE(numout,*) 'dyn_zad : 2nd order vertical advection scheme' 75 68 ENDIF 76 69 77 70 IF( l_trddyn ) THEN ! Save ua and va trends 78 CALL wrk_alloc( jpi, jpj, jpk, ztrdu, ztrdv)71 ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) ) 79 72 ztrdu(:,:,:) = ua(:,:,:) 80 73 ztrdv(:,:,:) = va(:,:,:) … … 96 89 ! 97 90 ! Surface and bottom advective fluxes set to zero 98 IF 91 IF( ln_isfcav ) THEN 99 92 DO jj = 2, jpjm1 100 93 DO ji = fs_2, fs_jpim1 ! vector opt. … … 119 112 DO jj = 2, jpjm1 120 113 DO ji = fs_2, fs_jpim1 ! vector opt. 121 ! ! vertical momentum advective trends 122 zua = - ( zwuw(ji,jj,jk) + zwuw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj) / e3u_n(ji,jj,jk) 123 zva = - ( zwvw(ji,jj,jk) + zwvw(ji,jj,jk+1) ) * r1_e1e2v(ji,jj) / e3v_n(ji,jj,jk) 124 ! ! add the trends to the general momentum trends 125 ua(ji,jj,jk) = ua(ji,jj,jk) + zua 126 va(ji,jj,jk) = va(ji,jj,jk) + zva 114 ua(ji,jj,jk) = ua(ji,jj,jk) - ( zwuw(ji,jj,jk) + zwuw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj) / e3u_n(ji,jj,jk) 115 va(ji,jj,jk) = va(ji,jj,jk) - ( zwvw(ji,jj,jk) + zwvw(ji,jj,jk+1) ) * r1_e1e2v(ji,jj) / e3v_n(ji,jj,jk) 127 116 END DO 128 117 END DO … … 133 122 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 134 123 CALL trd_dyn( ztrdu, ztrdv, jpdyn_zad, kt ) 135 CALL wrk_dealloc( jpi, jpj, jpk,ztrdu, ztrdv )124 DEALLOCATE( ztrdu, ztrdv ) 136 125 ENDIF 137 126 ! ! Control print … … 139 128 & tab3d_2=va, clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) 140 129 ! 141 CALL wrk_dealloc( jpi,jpj, zww ) 142 CALL wrk_dealloc( jpi,jpj,jpk, zwuw , zwvw ) 143 ! 144 IF( nn_timing == 1 ) CALL timing_stop('dyn_zad') 130 IF( ln_timing ) CALL timing_stop('dyn_zad') 145 131 ! 146 132 END SUBROUTINE dyn_zad 147 133 148 149 SUBROUTINE dyn_zad_zts ( kt )150 !!----------------------------------------------------------------------151 !! *** ROUTINE dynzad_zts ***152 !!153 !! ** Purpose : Compute the now vertical momentum advection trend and154 !! add it to the general trend of momentum equation. This version155 !! uses sub-timesteps for improved numerical stability with small156 !! vertical grid sizes. This is especially relevant when using157 !! embedded ice with thin surface boxes.158 !!159 !! ** Method : The now vertical advection of momentum is given by:160 !! w dz(u) = ua + 1/(e1u*e2u*e3u) mk+1[ mi(e1t*e2t*wn) dk(un) ]161 !! w dz(v) = va + 1/(e1v*e2v*e3v) mk+1[ mj(e1t*e2t*wn) dk(vn) ]162 !! Add this trend to the general trend (ua,va):163 !! (ua,va) = (ua,va) + w dz(u,v)164 !!165 !! ** Action : - Update (ua,va) with the vert. momentum adv. trends166 !! - Save the trends in (ztrdu,ztrdv) ('key_trddyn')167 !!----------------------------------------------------------------------168 INTEGER, INTENT(in) :: kt ! ocean time-step inedx169 !170 INTEGER :: ji, jj, jk, jl ! dummy loop indices171 INTEGER :: jnzts = 5 ! number of sub-timesteps for vertical advection172 INTEGER :: jtb, jtn, jta ! sub timestep pointers for leap-frog/euler forward steps173 REAL(wp) :: zua, zva ! temporary scalars174 REAL(wp) :: zr_rdt ! temporary scalar175 REAL(wp) :: z2dtzts ! length of Euler forward sub-timestep for vertical advection176 REAL(wp) :: zts ! length of sub-timestep for vertical advection177 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwuw , zwvw, zww178 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdu, ztrdv179 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: zus , zvs180 !!----------------------------------------------------------------------181 !182 IF( nn_timing == 1 ) CALL timing_start('dyn_zad_zts')183 !184 CALL wrk_alloc( jpi,jpj,jpk, zwuw, zwvw, zww )185 CALL wrk_alloc( jpi,jpj,jpk,3, zus , zvs )186 !187 IF( kt == nit000 ) THEN188 IF(lwp)WRITE(numout,*)189 IF(lwp)WRITE(numout,*) 'dyn_zad_zts : arakawa advection scheme with sub-timesteps'190 ENDIF191 192 IF( l_trddyn ) THEN ! Save ua and va trends193 CALL wrk_alloc( jpi, jpj, jpk, ztrdu, ztrdv )194 ztrdu(:,:,:) = ua(:,:,:)195 ztrdv(:,:,:) = va(:,:,:)196 ENDIF197 198 IF( neuler == 0 .AND. kt == nit000 ) THEN199 z2dtzts = rdt / REAL( jnzts, wp ) ! = rdt (restart with Euler time stepping)200 ELSE201 z2dtzts = 2._wp * rdt / REAL( jnzts, wp ) ! = 2 rdt (leapfrog)202 ENDIF203 204 DO jk = 2, jpkm1 ! Calculate and store vertical fluxes205 DO jj = 2, jpj206 DO ji = fs_2, jpi ! vector opt.207 zww(ji,jj,jk) = 0.25_wp * e1e2t(ji,jj) * wn(ji,jj,jk)208 END DO209 END DO210 END DO211 212 DO jj = 2, jpjm1 ! Surface and bottom advective fluxes set to zero213 DO ji = fs_2, fs_jpim1 ! vector opt.214 !!gm missing ISF boundary condition215 zwuw(ji,jj, 1 ) = 0._wp216 zwvw(ji,jj, 1 ) = 0._wp217 zwuw(ji,jj,jpk) = 0._wp218 zwvw(ji,jj,jpk) = 0._wp219 END DO220 END DO221 222 ! Start with before values and use sub timestepping to reach after values223 224 zus(:,:,:,1) = ub(:,:,:)225 zvs(:,:,:,1) = vb(:,:,:)226 227 DO jl = 1, jnzts ! Start of sub timestepping loop228 229 IF( jl == 1 ) THEN ! Euler forward to kick things off230 jtb = 1 ; jtn = 1 ; jta = 2231 zts = z2dtzts232 ELSEIF( jl == 2 ) THEN ! First leapfrog step233 jtb = 1 ; jtn = 2 ; jta = 3234 zts = 2._wp * z2dtzts235 ELSE ! Shuffle pointers for subsequent leapfrog steps236 jtb = MOD(jtb,3) + 1237 jtn = MOD(jtn,3) + 1238 jta = MOD(jta,3) + 1239 ENDIF240 241 DO jk = 2, jpkm1 ! Vertical momentum advection at level w and u- and v- vertical242 DO jj = 2, jpjm1 ! vertical momentum advection at w-point243 DO ji = fs_2, fs_jpim1 ! vector opt.244 zwuw(ji,jj,jk) = ( zww(ji+1,jj ,jk) + zww(ji,jj,jk) ) * ( zus(ji,jj,jk-1,jtn)-zus(ji,jj,jk,jtn) ) !* wumask(ji,jj,jk)245 zwvw(ji,jj,jk) = ( zww(ji ,jj+1,jk) + zww(ji,jj,jk) ) * ( zvs(ji,jj,jk-1,jtn)-zvs(ji,jj,jk,jtn) ) !* wvmask(ji,jj,jk)246 END DO247 END DO248 END DO249 DO jk = 1, jpkm1 ! Vertical momentum advection at u- and v-points250 DO jj = 2, jpjm1251 DO ji = fs_2, fs_jpim1 ! vector opt.252 ! ! vertical momentum advective trends253 zua = - ( zwuw(ji,jj,jk) + zwuw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj) / e3u_n(ji,jj,jk)254 zva = - ( zwvw(ji,jj,jk) + zwvw(ji,jj,jk+1) ) * r1_e1e2v(ji,jj) / e3v_n(ji,jj,jk)255 zus(ji,jj,jk,jta) = zus(ji,jj,jk,jtb) + zua * zts256 zvs(ji,jj,jk,jta) = zvs(ji,jj,jk,jtb) + zva * zts257 END DO258 END DO259 END DO260 261 END DO ! End of sub timestepping loop262 263 zr_rdt = 1._wp / ( REAL( jnzts, wp ) * z2dtzts )264 DO jk = 1, jpkm1 ! Recover trends over the outer timestep265 DO jj = 2, jpjm1266 DO ji = fs_2, fs_jpim1 ! vector opt.267 ! ! vertical momentum advective trends268 ! ! add the trends to the general momentum trends269 ua(ji,jj,jk) = ua(ji,jj,jk) + ( zus(ji,jj,jk,jta) - ub(ji,jj,jk)) * zr_rdt270 va(ji,jj,jk) = va(ji,jj,jk) + ( zvs(ji,jj,jk,jta) - vb(ji,jj,jk)) * zr_rdt271 END DO272 END DO273 END DO274 275 IF( l_trddyn ) THEN ! save the vertical advection trends for diagnostic276 ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:)277 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:)278 CALL trd_dyn( ztrdu, ztrdv, jpdyn_zad, kt )279 CALL wrk_dealloc( jpi, jpj, jpk, ztrdu, ztrdv )280 ENDIF281 ! ! Control print282 IF(ln_ctl) CALL prt_ctl( tab3d_1=ua, clinfo1=' zad - Ua: ', mask1=umask, &283 & tab3d_2=va, clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' )284 !285 CALL wrk_dealloc( jpi,jpj,jpk, zwuw, zwvw, zww )286 CALL wrk_dealloc( jpi,jpj,jpk,3, zus , zvs )287 !288 IF( nn_timing == 1 ) CALL timing_stop('dyn_zad_zts')289 !290 END SUBROUTINE dyn_zad_zts291 292 134 !!====================================================================== 293 135 END MODULE dynzad -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DYN/dynzdf.F90
r8215 r8568 76 76 !!--------------------------------------------------------------------- 77 77 ! 78 IF( nn_timing == 1) CALL timing_start('dyn_zdf')78 IF( ln_timing ) CALL timing_start('dyn_zdf') 79 79 ! 80 80 IF( kt == nit000 ) THEN !* initialization … … 392 392 & tab3d_2=va, clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) 393 393 ! 394 IF( nn_timing == 1) CALL timing_stop('dyn_zdf')394 IF( ln_timing ) CALL timing_stop('dyn_zdf') 395 395 ! 396 396 END SUBROUTINE dyn_zdf -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DYN/sshwzv.F90
r7753 r8568 22 22 USE divhor ! horizontal divergence 23 23 USE phycst ! physical constants 24 USE bdy_oce , ONLY: ln_bdy, bdytmask24 USE bdy_oce , ONLY : ln_bdy, bdytmask ! Open BounDarY 25 25 USE bdydyn2d ! bdy_ssh routine 26 26 #if defined key_agrif … … 36 36 USE lbclnk ! ocean lateral boundary condition (or mpp link) 37 37 USE lib_mpp ! MPP library 38 USE wrk_nemo ! Memory Allocation39 38 USE timing ! Timing 40 USE wet_dry 39 USE wet_dry ! Wetting/Drying flux limting 41 40 42 41 IMPLICIT NONE … … 74 73 INTEGER :: jk ! dummy loop indice 75 74 REAL(wp) :: z2dt, zcoef ! local scalars 76 REAL(wp), POINTER, DIMENSION(:,: ) :: zhdiv ! 2D workspace 77 !!---------------------------------------------------------------------- 78 ! 79 IF( nn_timing == 1 ) CALL timing_start('ssh_nxt') 80 ! 81 CALL wrk_alloc( jpi,jpj, zhdiv ) 75 REAL(wp), DIMENSION(jpi,jpj) :: zhdiv ! 2D workspace 76 !!---------------------------------------------------------------------- 77 ! 78 IF( ln_timing ) CALL timing_start('ssh_nxt') 82 79 ! 83 80 IF( kt == nit000 ) THEN … … 134 131 IF(ln_ctl) CALL prt_ctl( tab2d_1=ssha, clinfo1=' ssha - : ', mask1=tmask, ovlap=1 ) 135 132 ! 136 CALL wrk_dealloc( jpi, jpj, zhdiv ) 137 ! 138 IF( nn_timing == 1 ) CALL timing_stop('ssh_nxt') 133 IF( ln_timing ) CALL timing_stop('ssh_nxt') 139 134 ! 140 135 END SUBROUTINE ssh_nxt … … 160 155 INTEGER :: ji, jj, jk ! dummy loop indices 161 156 REAL(wp) :: z1_2dt ! local scalars 162 REAL(wp), POINTER, DIMENSION(:,: ) :: z2d 163 REAL(wp), POINTER, DIMENSION(:,:,:) :: z3d, zhdiv 164 !!---------------------------------------------------------------------- 165 ! 166 IF( nn_timing == 1 ) CALL timing_start('wzv') 157 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zhdiv 158 !!---------------------------------------------------------------------- 159 ! 160 IF( ln_timing ) CALL timing_start('wzv') 167 161 ! 168 162 IF( kt == nit000 ) THEN … … 180 174 ! 181 175 IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! z_tilde and layer cases 182 CALL wrk_alloc( jpi, jpj, jpk, zhdiv)176 ALLOCATE( zhdiv(jpi,jpj,jpk) ) 183 177 ! 184 178 DO jk = 1, jpkm1 … … 200 194 END DO 201 195 ! IF( ln_vvl_layer ) wn(:,:,:) = 0.e0 202 CALL wrk_dealloc( jpi, jpj, jpk,zhdiv )196 DEALLOCATE( zhdiv ) 203 197 ELSE ! z_star and linear free surface cases 204 198 DO jk = jpkm1, 1, -1 ! integrate from the bottom the hor. divergence … … 215 209 ENDIF 216 210 ! 217 IF( nn_timing == 1 )CALL timing_stop('wzv')211 IF( ln_timing ) CALL timing_stop('wzv') 218 212 ! 219 213 END SUBROUTINE wzv … … 244 238 !!---------------------------------------------------------------------- 245 239 ! 246 IF( nn_timing == 1) CALL timing_start('ssh_swp')240 IF( ln_timing ) CALL timing_start('ssh_swp') 247 241 ! 248 242 IF( kt == nit000 ) THEN … … 271 265 IF(ln_ctl) CALL prt_ctl( tab2d_1=sshb, clinfo1=' sshb - : ', mask1=tmask, ovlap=1 ) 272 266 ! 273 IF( nn_timing == 1) CALL timing_stop('ssh_swp')267 IF( ln_timing ) CALL timing_stop('ssh_swp') 274 268 ! 275 269 END SUBROUTINE ssh_swp -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/DYN/wet_dry.F90
r7646 r8568 11 11 12 12 !!---------------------------------------------------------------------- 13 !! wad_lmt : Compute the horizontal flux limiter and the limited velocity 14 !! when wetting and drying happens 15 !!---------------------------------------------------------------------- 16 USE oce ! ocean dynamics and tracers 17 USE dom_oce ! ocean space and time domain 18 USE sbc_oce, ONLY : ln_rnf ! surface boundary condition: ocean 19 USE sbcrnf ! river runoff 20 USE in_out_manager ! I/O manager 21 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 22 USE lib_mpp ! MPP library 23 USE wrk_nemo ! Memory Allocation 24 USE timing ! Timing 13 !! wad_init : initialisation of wetting and drying 14 !! wad_lmt : horizontal flux limiter and limited velocity when wetting and drying happens 15 !! wad_lmt_bt : same as wad_lmt for the barotropic stepping (dynspg_ts) 16 !!---------------------------------------------------------------------- 17 USE oce ! ocean dynamics and tracers 18 USE dom_oce ! ocean space and time domain 19 USE sbc_oce , ONLY: ln_rnf ! surface boundary condition: ocean 20 USE sbcrnf ! river runoff 21 ! 22 USE in_out_manager ! I/O manager 23 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 24 USE lib_mpp ! MPP library 25 USE timing ! Timing 25 26 26 27 IMPLICIT NONE … … 31 32 !! --------------------------------------------------------------------- 32 33 33 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: wdmask 34 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: ht_wd 35 34 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: wdmask !: u- and v- limiter 35 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: ht_wd !: wetting and drying t-pt depths 36 ! ! (can include negative depths) 36 37 37 38 LOGICAL, PUBLIC :: ln_wd !: Wetting/drying activation switch (T:on,F:off) 38 39 REAL(wp), PUBLIC :: rn_wdmin1 !: minimum water depth on dried cells 39 40 REAL(wp), PUBLIC :: rn_wdmin2 !: tolerrance of minimum water depth on dried cells 40 REAL(wp), PUBLIC :: rn_wdld !: land elevation below which wetting/drying 41 !: will be considered 41 REAL(wp), PUBLIC :: rn_wdld !: land elevation below which wetting/drying will be considered 42 42 INTEGER , PUBLIC :: nn_wdit !: maximum number of iteration for W/D limiter 43 43 … … 48 48 !! * Substitutions 49 49 # include "vectopt_loop_substitute.h90" 50 !!---------------------------------------------------------------------- 50 51 CONTAINS 51 52 … … 58 59 !! ** input : - namwad namelist 59 60 !!---------------------------------------------------------------------- 61 INTEGER :: ios, ierr ! Local integer 62 !! 60 63 NAMELIST/namwad/ ln_wd, rn_wdmin1, rn_wdmin2, rn_wdld, nn_wdit 61 INTEGER :: ios ! Local integer output status for namelist read 62 INTEGER :: ierr ! Local integer status array allocation 63 !!---------------------------------------------------------------------- 64 65 REWIND( numnam_ref ) ! Namelist namwad in reference namelist 66 ! : Parameters for Wetting/Drying 64 !!---------------------------------------------------------------------- 65 ! 66 REWIND( numnam_ref ) ! Namelist namwad in reference namelist : Parameters for Wetting/Drying 67 67 READ ( numnam_ref, namwad, IOSTAT = ios, ERR = 905) 68 68 905 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namwad in reference namelist', .TRUE.) 69 REWIND( numnam_cfg ) ! Namelist namwad in configuration namelist 70 ! : Parameters for Wetting/Drying 69 REWIND( numnam_cfg ) ! Namelist namwad in configuration namelist : Parameters for Wetting/Drying 71 70 READ ( numnam_cfg, namwad, IOSTAT = ios, ERR = 906) 72 71 906 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namwad in configuration namelist', .TRUE. ) 73 72 IF(lwm) WRITE ( numond, namwad ) 74 73 ! 75 74 IF(lwp) THEN ! control print 76 75 WRITE(numout,*) … … 103 102 !! ** Action : - calculate flux limiter and W/D flag 104 103 !!---------------------------------------------------------------------- 105 REAL(wp), DIMENSION(:,:), INTENT(inout) :: sshb1 106 REAL(wp), DIMENSION(:,:), INTENT(in ):: sshemp107 REAL(wp) , INTENT(in) ::z2dt104 REAL(wp), DIMENSION(:,:), INTENT(inout) :: sshb1 !!gm DOCTOR names: should start with p ! 105 REAL(wp), DIMENSION(:,:), INTENT(in ) :: sshemp 106 REAL(wp) , INTENT(in ) :: z2dt 108 107 ! 109 108 INTEGER :: ji, jj, jk, jk1 ! dummy loop indices … … 113 112 REAL(wp) :: zdepwd ! local scalar, always wet cell depth 114 113 REAL(wp) :: ztmp ! local scalars 115 REAL(wp), POINTER, DIMENSION(:,:) :: zwdlmtu, zwdlmtv !: W/D flux limiters 116 REAL(wp), POINTER, DIMENSION(:,:) :: zflxp, zflxn ! local 2D workspace 117 REAL(wp), POINTER, DIMENSION(:,:) :: zflxu, zflxv ! local 2D workspace 118 REAL(wp), POINTER, DIMENSION(:,:) :: zflxu1, zflxv1 ! local 2D workspace 119 !!---------------------------------------------------------------------- 120 ! 121 122 IF( nn_timing == 1 ) CALL timing_start('wad_lmt') 123 124 IF(ln_wd) THEN 125 126 CALL wrk_alloc( jpi, jpj, zflxp, zflxn, zflxu, zflxv, zflxu1, zflxv1 ) 127 CALL wrk_alloc( jpi, jpj, zwdlmtu, zwdlmtv) 128 ! 129 130 !IF(lwp) WRITE(numout,*) 131 !IF(lwp) WRITE(numout,*) 'wad_lmt : wetting/drying limiters and velocity limiting' 132 133 jflag = 0 134 zdepwd = 50._wp !maximum depth on which that W/D could possibly happen 135 136 137 zflxp(:,:) = 0._wp 138 zflxn(:,:) = 0._wp 139 zflxu(:,:) = 0._wp 140 zflxv(:,:) = 0._wp 141 142 zwdlmtu(:,:) = 1._wp 143 zwdlmtv(:,:) = 1._wp 144 145 ! Horizontal Flux in u and v direction 146 DO jk = 1, jpkm1 147 DO jj = 1, jpj 148 DO ji = 1, jpi 149 zflxu(ji,jj) = zflxu(ji,jj) + e3u_n(ji,jj,jk) * un(ji,jj,jk) * umask(ji,jj,jk) 150 zflxv(ji,jj) = zflxv(ji,jj) + e3v_n(ji,jj,jk) * vn(ji,jj,jk) * vmask(ji,jj,jk) 151 END DO 152 END DO 153 END DO 154 155 zflxu(:,:) = zflxu(:,:) * e2u(:,:) 156 zflxv(:,:) = zflxv(:,:) * e1v(:,:) 157 158 wdmask(:,:) = 1 159 DO jj = 2, jpj 160 DO ji = 2, jpi 161 162 IF( tmask(ji, jj, 1) < 0.5_wp ) CYCLE ! we don't care about land cells 163 IF( ht_wd(ji,jj) > zdepwd ) CYCLE ! and cells which are unlikely to dry 164 165 zflxp(ji,jj) = max(zflxu(ji,jj), 0._wp) - min(zflxu(ji-1,jj), 0._wp) + & 166 & max(zflxv(ji,jj), 0._wp) - min(zflxv(ji, jj-1), 0._wp) 167 zflxn(ji,jj) = min(zflxu(ji,jj), 0._wp) - max(zflxu(ji-1,jj), 0._wp) + & 168 & min(zflxv(ji,jj), 0._wp) - max(zflxv(ji, jj-1), 0._wp) 169 170 zdep2 = ht_wd(ji,jj) + sshb1(ji,jj) - rn_wdmin1 171 IF(zdep2 .le. 0._wp) THEN !add more safty, but not necessary 172 sshb1(ji,jj) = rn_wdmin1 - ht_wd(ji,jj) 173 IF(zflxu(ji, jj) > 0._wp) zwdlmtu(ji ,jj) = 0._wp 174 IF(zflxu(ji-1,jj) < 0._wp) zwdlmtu(ji-1,jj) = 0._wp 175 IF(zflxv(ji, jj) > 0._wp) zwdlmtv(ji ,jj) = 0._wp 176 IF(zflxv(ji,jj-1) < 0._wp) zwdlmtv(ji,jj-1) = 0._wp 177 wdmask(ji,jj) = 0._wp 178 END IF 179 ENDDO 180 END DO 181 182 183 !! start limiter iterations 184 DO jk1 = 1, nn_wdit + 1 185 186 187 zflxu1(:,:) = zflxu(:,:) * zwdlmtu(:,:) 188 zflxv1(:,:) = zflxv(:,:) * zwdlmtv(:,:) 189 jflag = 0 ! flag indicating if any further iterations are needed 190 191 DO jj = 2, jpj 192 DO ji = 2, jpi 193 194 IF( tmask(ji, jj, 1) < 0.5_wp ) CYCLE 195 IF( ht_wd(ji,jj) > zdepwd ) CYCLE 196 197 ztmp = e1e2t(ji,jj) 198 199 zzflxp = max(zflxu1(ji,jj), 0._wp) - min(zflxu1(ji-1,jj), 0._wp) + & 200 & max(zflxv1(ji,jj), 0._wp) - min(zflxv1(ji, jj-1), 0._wp) 201 zzflxn = min(zflxu1(ji,jj), 0._wp) - max(zflxu1(ji-1,jj), 0._wp) + & 202 & min(zflxv1(ji,jj), 0._wp) - max(zflxv1(ji, jj-1), 0._wp) 203 204 zdep1 = (zzflxp + zzflxn) * z2dt / ztmp 205 zdep2 = ht_wd(ji,jj) + sshb1(ji,jj) - rn_wdmin1 - z2dt * sshemp(ji,jj) 206 207 IF( zdep1 > zdep2 ) THEN 208 wdmask(ji, jj) = 0 209 zcoef = ( ( zdep2 - rn_wdmin2 ) * ztmp - zzflxn * z2dt ) / ( zflxp(ji,jj) * z2dt ) 210 !zcoef = ( ( zdep2 - rn_wdmin2 ) * ztmp - zzflxn * z2dt ) / ( zzflxp * z2dt ) 211 ! flag if the limiter has been used but stop flagging if the only 212 ! changes have zeroed the coefficient since further iterations will 213 ! not change anything 214 IF( zcoef > 0._wp ) THEN 215 jflag = 1 216 ELSE 217 zcoef = 0._wp 218 ENDIF 219 IF(jk1 > nn_wdit) zcoef = 0._wp 220 IF(zflxu1(ji, jj) > 0._wp) zwdlmtu(ji ,jj) = zcoef 221 IF(zflxu1(ji-1,jj) < 0._wp) zwdlmtu(ji-1,jj) = zcoef 222 IF(zflxv1(ji, jj) > 0._wp) zwdlmtv(ji ,jj) = zcoef 223 IF(zflxv1(ji,jj-1) < 0._wp) zwdlmtv(ji,jj-1) = zcoef 224 END IF 225 END DO ! ji loop 226 END DO ! jj loop 227 228 CALL lbc_lnk( zwdlmtu, 'U', 1. ) 229 CALL lbc_lnk( zwdlmtv, 'V', 1. ) 230 231 IF(lk_mpp) CALL mpp_max(jflag) !max over the global domain 232 233 IF(jflag == 0) EXIT 234 235 END DO ! jk1 loop 236 237 DO jk = 1, jpkm1 238 un(:,:,jk) = un(:,:,jk) * zwdlmtu(:, :) 239 vn(:,:,jk) = vn(:,:,jk) * zwdlmtv(:, :) 240 END DO 241 242 CALL lbc_lnk( un, 'U', -1. ) 243 CALL lbc_lnk( vn, 'V', -1. ) 244 ! 245 un_b(:,:) = un_b(:,:) * zwdlmtu(:, :) 246 vn_b(:,:) = vn_b(:,:) * zwdlmtv(:, :) 247 CALL lbc_lnk( un_b, 'U', -1. ) 248 CALL lbc_lnk( vn_b, 'V', -1. ) 249 250 IF(jflag == 1 .AND. lwp) WRITE(numout,*) 'Need more iterations in wad_lmt!!!' 251 252 !IF( ln_rnf ) CALL sbc_rnf_div( hdivn ) ! runoffs (update hdivn field) 253 !IF( nn_cla == 1 ) CALL cla_div ( kt ) ! Cross Land Advection (update hdivn field) 254 ! 255 ! 256 CALL wrk_dealloc( jpi, jpj, zflxp, zflxn, zflxu, zflxv, zflxu1, zflxv1 ) 257 CALL wrk_dealloc( jpi, jpj, zwdlmtu, zwdlmtv) 258 ! 259 ENDIF 260 ! 261 IF( nn_timing == 1 ) CALL timing_stop('wad_lmt') 114 REAL(wp), DIMENSION(jpi,jpj) :: zwdlmtu, zwdlmtv ! W/D flux limiters 115 REAL(wp), DIMENSION(jpi,jpj) :: zflxp , zflxn ! local 2D workspace 116 REAL(wp), DIMENSION(jpi,jpj) :: zflxu , zflxv ! local 2D workspace 117 REAL(wp), DIMENSION(jpi,jpj) :: zflxu1 , zflxv1 ! local 2D workspace 118 !!---------------------------------------------------------------------- 119 ! 120 IF( ln_timing ) CALL timing_start('wad_lmt') 121 ! 122 !IF(lwp) WRITE(numout,*) 123 !IF(lwp) WRITE(numout,*) 'wad_lmt : wetting/drying limiters and velocity limiting' 124 ! 125 jflag = 0 126 zdepwd = 50._wp !maximum depth on which that W/D could possibly happen 127 ! 128 zflxp(:,:) = 0._wp 129 zflxn(:,:) = 0._wp 130 zflxu(:,:) = 0._wp 131 zflxv(:,:) = 0._wp 132 ! 133 zwdlmtu(:,:) = 1._wp 134 zwdlmtv(:,:) = 1._wp 135 ! 136 ! Horizontal Flux in u and v direction 137 DO jk = 1, jpkm1 138 DO jj = 1, jpj 139 DO ji = 1, jpi 140 zflxu(ji,jj) = zflxu(ji,jj) + e3u_n(ji,jj,jk) * un(ji,jj,jk) * umask(ji,jj,jk) 141 zflxv(ji,jj) = zflxv(ji,jj) + e3v_n(ji,jj,jk) * vn(ji,jj,jk) * vmask(ji,jj,jk) 142 END DO 143 END DO 144 END DO 145 ! 146 zflxu(:,:) = zflxu(:,:) * e2u(:,:) 147 zflxv(:,:) = zflxv(:,:) * e1v(:,:) 148 ! 149 wdmask(:,:) = 1 150 DO jj = 2, jpj 151 DO ji = 2, jpi 152 ! 153 IF( tmask(ji, jj, 1) < 0.5_wp ) CYCLE ! we don't care about land cells 154 IF( ht_wd(ji,jj) > zdepwd ) CYCLE ! and cells which are unlikely to dry 155 ! 156 zflxp(ji,jj) = MAX( zflxu(ji,jj) , 0._wp ) - MIN( zflxu(ji-1,jj) , 0._wp ) & 157 & + MAX( zflxv(ji,jj) , 0._wp ) - MIN( zflxv(ji,jj-1) , 0._wp ) 158 zflxn(ji,jj) = MIN( zflxu(ji,jj) , 0._wp ) - MAX( zflxu(ji-1,jj) , 0._wp ) & 159 & + MIN( zflxv(ji,jj) , 0._wp ) - MAX( zflxv(ji,jj-1) , 0._wp ) 160 ! 161 zdep2 = ht_wd(ji,jj) + sshb1(ji,jj) - rn_wdmin1 162 IF( zdep2 .le. 0._wp) THEN !add more safty, but not necessary 163 sshb1(ji,jj) = rn_wdmin1 - ht_wd(ji,jj) 164 IF( zflxu(ji, jj) > 0._wp ) zwdlmtu(ji ,jj) = 0._wp 165 IF( zflxu(ji-1,jj) < 0._wp ) zwdlmtu(ji-1,jj) = 0._wp 166 IF( zflxv(ji, jj) > 0._wp ) zwdlmtv(ji ,jj) = 0._wp 167 IF( zflxv(ji,jj-1) < 0._wp ) zwdlmtv(ji,jj-1) = 0._wp 168 wdmask(ji,jj) = 0._wp 169 ENDIF 170 END DO 171 END DO 172 !! 173 !! start limiter iterations 174 DO jk1 = 1, nn_wdit + 1 175 ! 176 zflxu1(:,:) = zflxu(:,:) * zwdlmtu(:,:) 177 zflxv1(:,:) = zflxv(:,:) * zwdlmtv(:,:) 178 jflag = 0 ! flag indicating if any further iterations are needed 179 ! 180 DO jj = 2, jpj 181 DO ji = 2, jpi 182 ! 183 IF( tmask(ji,jj,1) < 0.5_wp ) CYCLE 184 IF( ht_wd(ji,jj) > zdepwd ) CYCLE 185 ! 186 ztmp = e1e2t(ji,jj) 187 ! 188 zzflxp = MAX( zflxu1(ji,jj) , 0._wp ) - MIN( zflxu1(ji-1,jj) , 0._wp ) & 189 & + MAX( zflxv1(ji,jj) , 0._wp ) - MIN( zflxv1(ji,jj-1) , 0._wp ) 190 zzflxn = MIN( zflxu1(ji,jj) , 0._wp ) - MAX( zflxu1(ji-1,jj) , 0._wp ) & 191 & + MIN( zflxv1(ji,jj) , 0._wp ) - MAX( zflxv1(ji,jj-1) , 0._wp ) 192 ! 193 zdep1 = (zzflxp + zzflxn) * z2dt / ztmp 194 zdep2 = ht_wd(ji,jj) + sshb1(ji,jj) - rn_wdmin1 - z2dt * sshemp(ji,jj) 195 ! 196 IF( zdep1 > zdep2 ) THEN 197 wdmask(ji, jj) = 0 198 zcoef = ( ( zdep2 - rn_wdmin2 ) * ztmp - zzflxn * z2dt ) / ( zflxp(ji,jj) * z2dt ) 199 !zcoef = ( ( zdep2 - rn_wdmin2 ) * ztmp - zzflxn * z2dt ) / ( zzflxp * z2dt ) 200 ! flag if the limiter has been used but stop flagging if the only 201 ! changes have zeroed the coefficient since further iterations will 202 ! not change anything 203 IF( zcoef > 0._wp ) THEN ; jflag = 1 204 ELSE ; zcoef = 0._wp 205 ENDIF 206 IF( jk1 > nn_wdit ) zcoef = 0._wp 207 IF( zflxu1(ji, jj) > 0._wp ) zwdlmtu(ji ,jj) = zcoef 208 IF( zflxu1(ji-1,jj) < 0._wp ) zwdlmtu(ji-1,jj) = zcoef 209 IF( zflxv1(ji, jj) > 0._wp ) zwdlmtv(ji ,jj) = zcoef 210 IF( zflxv1(ji,jj-1) < 0._wp ) zwdlmtv(ji,jj-1) = zcoef 211 ENDIF 212 END DO ! ji loop 213 END DO ! jj loop 214 ! 215 CALL lbc_lnk( zwdlmtu, 'U', 1. ) 216 CALL lbc_lnk( zwdlmtv, 'V', 1. ) 217 ! 218 IF(lk_mpp) CALL mpp_max(jflag) !max over the global domain 219 ! 220 IF(jflag == 0) EXIT 221 ! 222 END DO ! jk1 loop 223 224 DO jk = 1, jpkm1 225 un(:,:,jk) = un(:,:,jk) * zwdlmtu(:,:) 226 vn(:,:,jk) = vn(:,:,jk) * zwdlmtv(:,:) 227 END DO 228 229 !!gm ==> Andrew : the lbclnk below is useless since above lbclnk is applied on zwdlmtu/v 230 !! and un, vn always with lbclnk 231 CALL lbc_lnk( un, 'U', -1. ) 232 CALL lbc_lnk( vn, 'V', -1. ) 233 !!gm end 234 ! 235 un_b(:,:) = un_b(:,:) * zwdlmtu(:,:) 236 vn_b(:,:) = vn_b(:,:) * zwdlmtv(:,:) 237 !!gm ==> Andrew : probably same as above 238 CALL lbc_lnk( un_b, 'U', -1. ) 239 CALL lbc_lnk( vn_b, 'V', -1. ) 240 !!gm end 241 242 IF(jflag == 1 .AND. lwp) WRITE(numout,*) 'Need more iterations in wad_lmt!!!' 243 244 !IF( ln_rnf ) CALL sbc_rnf_div( hdivn ) ! runoffs (update hdivn field) 245 !IF( nn_cla == 1 ) CALL cla_div ( kt ) ! Cross Land Advection (update hdivn field) 246 ! 247 ! 248 ! 249 IF( ln_timing ) CALL timing_stop('wad_lmt') 262 250 ! 263 251 END SUBROUTINE wad_lmt … … 284 272 REAL(wp) :: zdepwd ! local scalar, always wet cell depth 285 273 REAL(wp) :: ztmp ! local scalars 286 REAL(wp), POINTER, DIMENSION(:,:) :: zwdlmtu, zwdlmtv !: W/D flux limiters 287 REAL(wp), POINTER, DIMENSION(:,:) :: zflxp, zflxn ! local 2D workspace 288 REAL(wp), POINTER, DIMENSION(:,:) :: zflxu1, zflxv1 ! local 2D workspace 289 !!---------------------------------------------------------------------- 290 ! 291 IF( nn_timing == 1 ) CALL timing_start('wad_lmt_bt') 292 293 IF(ln_wd) THEN 294 295 CALL wrk_alloc( jpi, jpj, zflxp, zflxn, zflxu1, zflxv1 ) 296 CALL wrk_alloc( jpi, jpj, zwdlmtu, zwdlmtv) 297 ! 298 299 !IF(lwp) WRITE(numout,*) 300 !IF(lwp) WRITE(numout,*) 'wad_lmt_bt : wetting/drying limiters and velocity limiting' 301 302 jflag = 0 303 zdepwd = 50._wp !maximum depth that ocean cells can have W/D processes 304 305 z2dt = rdtbt 306 307 zflxp(:,:) = 0._wp 308 zflxn(:,:) = 0._wp 309 310 zwdlmtu(:,:) = 1._wp 311 zwdlmtv(:,:) = 1._wp 312 313 ! Horizontal Flux in u and v direction 314 315 DO jj = 2, jpj 316 DO ji = 2, jpi 317 318 IF( tmask(ji, jj, 1 ) < 0.5_wp) CYCLE ! we don't care about land cells 319 IF( ht_wd(ji,jj) > zdepwd ) CYCLE ! and cells which are unlikely to dry 320 321 zflxp(ji,jj) = max(zflxu(ji,jj), 0._wp) - min(zflxu(ji-1,jj), 0._wp) + & 322 & max(zflxv(ji,jj), 0._wp) - min(zflxv(ji, jj-1), 0._wp) 323 zflxn(ji,jj) = min(zflxu(ji,jj), 0._wp) - max(zflxu(ji-1,jj), 0._wp) + & 324 & min(zflxv(ji,jj), 0._wp) - max(zflxv(ji, jj-1), 0._wp) 325 326 zdep2 = ht_wd(ji,jj) + sshn_e(ji,jj) - rn_wdmin1 327 IF(zdep2 .le. 0._wp) THEN !add more safety, but not necessary 328 sshn_e(ji,jj) = rn_wdmin1 - ht_wd(ji,jj) 329 IF(zflxu(ji, jj) > 0._wp) zwdlmtu(ji ,jj) = 0._wp 330 IF(zflxu(ji-1,jj) < 0._wp) zwdlmtu(ji-1,jj) = 0._wp 331 IF(zflxv(ji, jj) > 0._wp) zwdlmtv(ji ,jj) = 0._wp 332 IF(zflxv(ji,jj-1) < 0._wp) zwdlmtv(ji,jj-1) = 0._wp 333 END IF 334 ENDDO 335 END DO 274 REAL(wp), DIMENSION(jpi,jpj) :: zwdlmtu, zwdlmtv !: W/D flux limiters 275 REAL(wp), DIMENSION(jpi,jpj) :: zflxp, zflxn ! local 2D workspace 276 REAL(wp), DIMENSION(jpi,jpj) :: zflxu1, zflxv1 ! local 2D workspace 277 !!---------------------------------------------------------------------- 278 ! 279 IF( ln_timing ) CALL timing_start('wad_lmt_bt') 280 ! 281 !IF(lwp) WRITE(numout,*) 282 !IF(lwp) WRITE(numout,*) 'wad_lmt_bt : wetting/drying limiters and velocity limiting' 283 284 jflag = 0 285 zdepwd = 50._wp !maximum depth that ocean cells can have W/D processes 286 287 z2dt = rdtbt 288 289 zflxp(:,:) = 0._wp 290 zflxn(:,:) = 0._wp 291 292 zwdlmtu(:,:) = 1._wp 293 zwdlmtv(:,:) = 1._wp 294 295 ! Horizontal Flux in u and v direction 296 297 DO jj = 2, jpj 298 DO ji = 2, jpi 299 ! 300 IF( tmask(ji,jj,1) < 0.5_wp ) CYCLE ! we don't care about land cells 301 IF( ht_wd(ji,jj) > zdepwd ) CYCLE ! and cells which are unlikely to dry 302 ! 303 zflxp(ji,jj) = MAX( zflxu(ji,jj) , 0._wp ) - MIN( zflxu(ji-1,jj) , 0._wp ) & 304 & + MAX( zflxv(ji,jj) , 0._wp ) - MIN( zflxv(ji,jj-1) , 0._wp ) 305 zflxn(ji,jj) = MIN( zflxu(ji,jj) , 0._wp ) - MAX( zflxu(ji-1,jj) , 0._wp ) & 306 & + MIN( zflxv(ji,jj) , 0._wp ) - MAX( zflxv(ji,jj-1) , 0._wp ) 307 308 zdep2 = ht_wd(ji,jj) + sshn_e(ji,jj) - rn_wdmin1 309 IF(zdep2 .le. 0._wp) THEN !add more safety, but not necessary 310 sshn_e(ji,jj) = rn_wdmin1 - ht_wd(ji,jj) 311 IF( zflxu(ji, jj) > 0._wp ) zwdlmtu(ji ,jj) = 0._wp 312 IF( zflxu(ji-1,jj) < 0._wp ) zwdlmtu(ji-1,jj) = 0._wp 313 IF( zflxv(ji, jj) > 0._wp ) zwdlmtv(ji ,jj) = 0._wp 314 IF( zflxv(ji,jj-1) < 0._wp ) zwdlmtv(ji,jj-1) = 0._wp 315 ENDIF 316 END DO 317 END DO 336 318 337 319 338 !! start limiter iterations 339 DO jk1 = 1, nn_wdit + 1 340 320 !! start limiter iterations 321 DO jk1 = 1, nn_wdit + 1 322 ! 323 zflxu1(:,:) = zflxu(:,:) * zwdlmtu(:,:) 324 zflxv1(:,:) = zflxv(:,:) * zwdlmtv(:,:) 325 jflag = 0 ! flag indicating if any further iterations are needed 326 ! 327 DO jj = 2, jpj 328 DO ji = 2, jpi 329 ! 330 IF( tmask(ji,jj, 1 ) < 0.5_wp ) CYCLE 331 IF( ht_wd(ji,jj) > zdepwd ) CYCLE 332 ! 333 ztmp = e1e2t(ji,jj) 334 ! 335 zzflxp = MAX( zflxu1(ji,jj) , 0._wp ) - MIN( zflxu1(ji-1,jj) , 0._wp ) & 336 & + MAX( zflxv1(ji,jj) , 0._wp ) - MIN( zflxv1(ji,jj-1) , 0._wp ) 337 zzflxn = MIN( zflxu1(ji,jj) , 0._wp ) - MAX( zflxu1(ji-1,jj) , 0._wp ) & 338 & + MIN( zflxv1(ji,jj) , 0._wp ) - MAX( zflxv1(ji,jj-1) , 0._wp ) 341 339 342 zflxu1(:,:) = zflxu(:,:) * zwdlmtu(:,:) 343 zflxv1(:,:) = zflxv(:,:) * zwdlmtv(:,:) 344 jflag = 0 ! flag indicating if any further iterations are needed 340 zdep1 = (zzflxp + zzflxn) * z2dt / ztmp 341 zdep2 = ht_wd(ji,jj) + sshn_e(ji,jj) - rn_wdmin1 - z2dt * zssh_frc(ji,jj) 345 342 346 DO jj = 2, jpj 347 DO ji = 2, jpi 348 349 IF( tmask(ji, jj, 1 ) < 0.5_wp) CYCLE 350 IF( ht_wd(ji,jj) > zdepwd ) CYCLE 351 352 ztmp = e1e2t(ji,jj) 353 354 zzflxp = max(zflxu1(ji,jj), 0._wp) - min(zflxu1(ji-1,jj), 0._wp) + & 355 & max(zflxv1(ji,jj), 0._wp) - min(zflxv1(ji, jj-1), 0._wp) 356 zzflxn = min(zflxu1(ji,jj), 0._wp) - max(zflxu1(ji-1,jj), 0._wp) + & 357 & min(zflxv1(ji,jj), 0._wp) - max(zflxv1(ji, jj-1), 0._wp) 358 359 zdep1 = (zzflxp + zzflxn) * z2dt / ztmp 360 zdep2 = ht_wd(ji,jj) + sshn_e(ji,jj) - rn_wdmin1 - z2dt * zssh_frc(ji,jj) 361 362 IF(zdep1 > zdep2) THEN 363 zcoef = ( ( zdep2 - rn_wdmin2 ) * ztmp - zzflxn * z2dt ) / ( zflxp(ji,jj) * z2dt ) 364 !zcoef = ( ( zdep2 - rn_wdmin2 ) * ztmp - zzflxn * z2dt ) / ( zzflxp * z2dt ) 365 ! flag if the limiter has been used but stop flagging if the only 366 ! changes have zeroed the coefficient since further iterations will 367 ! not change anything 368 IF( zcoef > 0._wp ) THEN 343 IF(zdep1 > zdep2) THEN 344 zcoef = ( ( zdep2 - rn_wdmin2 ) * ztmp - zzflxn * z2dt ) / ( zflxp(ji,jj) * z2dt ) 345 !zcoef = ( ( zdep2 - rn_wdmin2 ) * ztmp - zzflxn * z2dt ) / ( zzflxp * z2dt ) 346 ! flag if the limiter has been used but stop flagging if the only 347 ! changes have zeroed the coefficient since further iterations will 348 ! not change anything 349 IF( zcoef > 0._wp ) THEN 369 350 jflag = 1 370 351 ELSE 371 352 zcoef = 0._wp 372 ENDIF 373 IF(jk1 > nn_wdit) zcoef = 0._wp 374 IF(zflxu1(ji, jj) > 0._wp) zwdlmtu(ji ,jj) = zcoef 375 IF(zflxu1(ji-1,jj) < 0._wp) zwdlmtu(ji-1,jj) = zcoef 376 IF(zflxv1(ji, jj) > 0._wp) zwdlmtv(ji ,jj) = zcoef 377 IF(zflxv1(ji,jj-1) < 0._wp) zwdlmtv(ji,jj-1) = zcoef 378 END IF 379 END DO ! ji loop 380 END DO ! jj loop 381 382 CALL lbc_lnk( zwdlmtu, 'U', 1. ) 383 CALL lbc_lnk( zwdlmtv, 'V', 1. ) 384 385 IF(lk_mpp) CALL mpp_max(jflag) !max over the global domain 386 387 IF(jflag == 0) EXIT 388 389 END DO ! jk1 loop 390 391 zflxu(:,:) = zflxu(:,:) * zwdlmtu(:, :) 392 zflxv(:,:) = zflxv(:,:) * zwdlmtv(:, :) 393 394 CALL lbc_lnk( zflxu, 'U', -1. ) 395 CALL lbc_lnk( zflxv, 'V', -1. ) 396 397 IF(jflag == 1 .AND. lwp) WRITE(numout,*) 'Need more iterations in wad_lmt_bt!!!' 398 399 !IF( ln_rnf ) CALL sbc_rnf_div( hdivn ) ! runoffs (update hdivn field) 400 !IF( nn_cla == 1 ) CALL cla_div ( kt ) ! Cross Land Advection (update hdivn field) 401 ! 402 ! 403 CALL wrk_dealloc( jpi, jpj, zflxp, zflxn, zflxu1, zflxv1 ) 404 CALL wrk_dealloc( jpi, jpj, zwdlmtu, zwdlmtv) 405 ! 406 END IF 407 408 IF( nn_timing == 1 ) CALL timing_stop('wad_lmt') 353 ENDIF 354 IF( jk1 > nn_wdit ) zcoef = 0._wp 355 IF( zflxu1(ji, jj) > 0._wp ) zwdlmtu(ji ,jj) = zcoef 356 IF( zflxu1(ji-1,jj) < 0._wp ) zwdlmtu(ji-1,jj) = zcoef 357 IF( zflxv1(ji, jj) > 0._wp ) zwdlmtv(ji ,jj) = zcoef 358 IF( zflxv1(ji,jj-1) < 0._wp ) zwdlmtv(ji,jj-1) = zcoef 359 ENDIF 360 END DO ! ji loop 361 END DO ! jj loop 362 ! 363 CALL lbc_lnk( zwdlmtu, 'U', 1. ) 364 CALL lbc_lnk( zwdlmtv, 'V', 1. ) 365 ! 366 IF(lk_mpp) CALL mpp_max(jflag) !max over the global domain 367 ! 368 IF( jflag == 0 ) EXIT 369 ! 370 END DO ! jk1 loop 371 ! 372 zflxu(:,:) = zflxu(:,:) * zwdlmtu(:, :) 373 zflxv(:,:) = zflxv(:,:) * zwdlmtv(:, :) 374 ! 375 CALL lbc_lnk( zflxu, 'U', -1. ) 376 CALL lbc_lnk( zflxv, 'V', -1. ) 377 ! 378 IF(jflag == 1 .AND. lwp) WRITE(numout,*) 'Need more iterations in wad_lmt_bt!!!' 379 380 !IF( ln_rnf ) CALL sbc_rnf_div( hdivn ) ! runoffs (update hdivn field) 381 !IF( nn_cla == 1 ) CALL cla_div ( kt ) ! Cross Land Advection (update hdivn field) 382 ! 383 IF( ln_timing ) CALL timing_stop('wad_lmt') 384 ! 409 385 END SUBROUTINE wad_lmt_bt 410 386 -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/IOM/in_out_manager.F90
r8215 r8568 96 96 !!---------------------------------------------------------------------- 97 97 LOGICAL :: ln_ctl !: run control for debugging 98 LOGICAL :: ln_timing !: run control for timing 99 !!gm to be removed at the end of the 2017 merge party 98 100 INTEGER :: nn_timing !: run control for timing 99 INTEGER :: nn_diacfl !: flag whether to create CFL diagnostics 101 !!gm end 102 LOGICAL :: ln_diacfl !: flag whether to create CFL diagnostics 100 103 INTEGER :: nn_print !: level of print (0 no print) 101 104 INTEGER :: nn_ictls !: Start i indice for the SUM control -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r8215 r8568 2350 2350 zain(2,:) = ki + 10000.*kj + 100000000.*kk 2351 2351 ! 2352 CALL MPI_ALLREDUCE( zain, zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror)2352 CALL MPI_ALLREDUCE( zain, zaout, 1, MPI_2DOUBLE_PRECISION, MPI_MAXLOC, MPI_COMM_OPA, ierror ) 2353 2353 ! 2354 2354 pmax = zaout(1,1) -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/LDF/ldfdyn.F90
r7753 r8568 24 24 USE lib_mpp ! distribued memory computing library 25 25 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 26 USE wrk_nemo ! Memory Allocation27 26 28 27 IMPLICIT NONE … … 33 32 34 33 ! !!* Namelist namdyn_ldf : lateral mixing on momentum * 34 LOGICAL , PUBLIC :: ln_dynldf_NONE !: No operator (i.e. no explicit diffusion) 35 35 LOGICAL , PUBLIC :: ln_dynldf_lap !: laplacian operator 36 36 LOGICAL , PUBLIC :: ln_dynldf_blp !: bilaplacian operator … … 96 96 REAL(wp) :: zah0 ! local scalar 97 97 ! 98 NAMELIST/namdyn_ldf/ ln_dynldf_ lap, ln_dynldf_blp, &99 & ln_dynldf_lev, ln_dynldf_hor, ln_dynldf_iso , &100 & nn_ahm_ijk_t , rn_ahm_0, rn_ahm_b, rn_bhm_0 , &101 & rn_csmc , rn_minfac, rn_maxfac 98 NAMELIST/namdyn_ldf/ ln_dynldf_NONE, ln_dynldf_lap, ln_dynldf_blp, & ! type of operator 99 & ln_dynldf_lev, ln_dynldf_hor, ln_dynldf_iso , & ! acting direction of the operator 100 & nn_ahm_ijk_t , rn_ahm_0, rn_ahm_b, rn_bhm_0 , & ! lateral eddy coefficient 101 & rn_csmc , rn_minfac, rn_maxfac ! Smagorinsky settings 102 102 !!---------------------------------------------------------------------- 103 103 ! … … 118 118 ! 119 119 WRITE(numout,*) ' type :' 120 WRITE(numout,*) ' no explicit diffusion ln_dynldf_NONE= ', ln_dynldf_NONE 120 121 WRITE(numout,*) ' laplacian operator ln_dynldf_lap = ', ln_dynldf_lap 121 122 WRITE(numout,*) ' bilaplacian operator ln_dynldf_blp = ', ln_dynldf_blp … … 131 132 WRITE(numout,*) ' background viscosity (iso case) rn_ahm_b = ', rn_ahm_b, ' m2/s' 132 133 WRITE(numout,*) ' lateral bilaplacian eddy viscosity rn_bhm_0 = ', rn_bhm_0, ' m4/s' 133 WRITE(numout,*) ' smagorinsky settings (nn_ahm_ijk_t = 32) :'134 WRITE(numout,*) ' Smagorinsky settings (nn_ahm_ijk_t = 32) :' 134 135 WRITE(numout,*) ' Smagorinsky coefficient rn_csmc = ', rn_csmc 135 136 WRITE(numout,*) ' factor multiplier for theorectical lower limit for ' … … 140 141 141 142 ! ! Parameter control 142 IF( .NOT.ln_dynldf_lap .AND. .NOT.ln_dynldf_blp) THEN143 IF( ln_dynldf_NONE ) THEN 143 144 IF(lwp) WRITE(numout,*) ' No viscous operator selected. ahmt and ahmf are not allocated' 144 145 l_ldfdyn_time = .FALSE. … … 284 285 !!---------------------------------------------------------------------- 285 286 ! 286 IF( nn_timing == 1 )CALL timing_start('ldf_dyn')287 IF( ln_timing ) CALL timing_start('ldf_dyn') 287 288 ! 288 289 SELECT CASE( nn_ahm_ijk_t ) !== Eddy vicosity coefficients ==! … … 411 412 CALL iom_put( "ahmf_3d", ahmf(:,:,:) ) ! 3D v-eddy diffusivity coeff. 412 413 ! 413 IF( nn_timing == 1 )CALL timing_stop('ldf_dyn')414 IF( ln_timing ) CALL timing_stop('ldf_dyn') 414 415 ! 415 416 END SUBROUTINE ldf_dyn -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/LDF/ldfslp.F90
r7753 r8568 32 32 USE lib_mpp ! distribued memory computing library 33 33 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 34 USE wrk_nemo ! work arrays35 34 USE timing ! Timing 36 35 … … 118 117 REAL(wp) :: zck, zfk, zbw ! - - 119 118 REAL(wp) :: zdepu, zdepv ! - - 120 REAL(wp), POINTER, DIMENSION(:,: ) :: zslpml_hmlpu, zslpml_hmlpv 121 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwz, zww 122 REAL(wp), POINTER, DIMENSION(:,:,:) :: zdzr 123 REAL(wp), POINTER, DIMENSION(:,:,:) :: zgru, zgrv 124 !!---------------------------------------------------------------------- 125 ! 126 IF( nn_timing == 1 ) CALL timing_start('ldf_slp') 127 ! 128 CALL wrk_alloc( jpi,jpj,jpk, zwz, zww, zdzr, zgru, zgrv ) 129 CALL wrk_alloc( jpi,jpj, zslpml_hmlpu, zslpml_hmlpv ) 130 119 REAL(wp), DIMENSION(jpi,jpj) :: zslpml_hmlpu, zslpml_hmlpv 120 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zgru, zwz, zdzr 121 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zgrv, zww 122 !!---------------------------------------------------------------------- 123 ! 124 IF( ln_timing ) CALL timing_start('ldf_slp') 125 ! 131 126 zeps = 1.e-20_wp !== Local constant initialization ==! 132 127 z1_16 = 1.0_wp / 16._wp … … 157 152 DO jj = 1, jpjm1 158 153 DO ji = 1, jpim1 159 IF ( miku(ji,jj) > 1 )zgru(ji,jj,miku(ji,jj)) = grui(ji,jj)160 IF ( mikv(ji,jj) > 1 )zgrv(ji,jj,mikv(ji,jj)) = grvi(ji,jj)154 IF( miku(ji,jj) > 1 ) zgru(ji,jj,miku(ji,jj)) = grui(ji,jj) 155 IF( mikv(ji,jj) > 1 ) zgrv(ji,jj,mikv(ji,jj)) = grvi(ji,jj) 161 156 END DO 162 157 END DO … … 375 370 ENDIF 376 371 ! 377 CALL wrk_dealloc( jpi,jpj,jpk, zwz, zww, zdzr, zgru, zgrv ) 378 CALL wrk_dealloc( jpi,jpj, zslpml_hmlpu, zslpml_hmlpv ) 379 ! 380 IF( nn_timing == 1 ) CALL timing_stop('ldf_slp') 372 IF( ln_timing ) CALL timing_stop('ldf_slp') 381 373 ! 382 374 END SUBROUTINE ldf_slp … … 409 401 REAL(wp) :: zdzrho_raw 410 402 REAL(wp) :: zbeta0, ze3_e1, ze3_e2 411 REAL(wp), POINTER, DIMENSION(:,:) :: z1_mlbw 412 REAL(wp), POINTER, DIMENSION(:,:,:) :: zalbet 413 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: zdxrho , zdyrho, zdzrho ! Horizontal and vertical density gradients 414 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: zti_mlb, ztj_mlb ! for Griffies operator only 415 !!---------------------------------------------------------------------- 416 ! 417 IF( nn_timing == 1 ) CALL timing_start('ldf_slp_triad') 418 ! 419 CALL wrk_alloc( jpi,jpj, z1_mlbw ) 420 CALL wrk_alloc( jpi,jpj,jpk, zalbet ) 421 CALL wrk_alloc( jpi,jpj,jpk,2, zdxrho , zdyrho, zdzrho, klstart = 0 ) 422 CALL wrk_alloc( jpi,jpj, 2,2, zti_mlb, ztj_mlb, kkstart = 0, klstart = 0 ) 403 REAL(wp), DIMENSION(jpi,jpj) :: z1_mlbw 404 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zalbet 405 REAL(wp), DIMENSION(jpi,jpj,jpk,0:1) :: zdxrho , zdyrho, zdzrho ! Horizontal and vertical density gradients 406 REAL(wp), DIMENSION(jpi,jpj,0:1,0:1) :: zti_mlb, ztj_mlb ! for Griffies operator only 407 !!---------------------------------------------------------------------- 408 ! 409 IF( ln_timing ) CALL timing_start('ldf_slp_triad') 410 ! 423 411 ! 424 412 !--------------------------------! … … 624 612 CALL lbc_lnk( wslp2, 'W', 1. ) ! lateral boundary confition on wslp2 only ==>>> gm : necessary ? to be checked 625 613 ! 626 CALL wrk_dealloc( jpi,jpj, z1_mlbw ) 627 CALL wrk_dealloc( jpi,jpj,jpk, zalbet ) 628 CALL wrk_dealloc( jpi,jpj,jpk,2, zdxrho , zdyrho, zdzrho, klstart = 0 ) 629 CALL wrk_dealloc( jpi,jpj, 2,2, zti_mlb, ztj_mlb, kkstart = 0, klstart = 0 ) 630 ! 631 IF( nn_timing == 1 ) CALL timing_stop('ldf_slp_triad') 614 IF( ln_timing ) CALL timing_stop('ldf_slp_triad') 632 615 ! 633 616 END SUBROUTINE ldf_slp_triad … … 663 646 !!---------------------------------------------------------------------- 664 647 ! 665 IF( nn_timing == 1 )CALL timing_start('ldf_slp_mxl')648 IF( ln_timing ) CALL timing_start('ldf_slp_mxl') 666 649 ! 667 650 zeps = 1.e-20_wp !== Local constant initialization ==! … … 746 729 CALL lbc_lnk( wslpiml, 'W', -1. ) ; CALL lbc_lnk( wslpjml, 'W', -1. ) ! lateral boundary conditions 747 730 ! 748 IF( nn_timing == 1 )CALL timing_stop('ldf_slp_mxl')731 IF( ln_timing ) CALL timing_stop('ldf_slp_mxl') 749 732 ! 750 733 END SUBROUTINE ldf_slp_mxl … … 763 746 !!---------------------------------------------------------------------- 764 747 ! 765 IF( nn_timing == 1 )CALL timing_start('ldf_slp_init')748 IF( ln_timing ) CALL timing_start('ldf_slp_init') 766 749 ! 767 750 IF(lwp) THEN … … 821 804 ENDIF 822 805 ! 823 IF( nn_timing == 1 )CALL timing_stop('ldf_slp_init')806 IF( ln_timing ) CALL timing_stop('ldf_slp_init') 824 807 ! 825 808 END SUBROUTINE ldf_slp_init -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/LDF/ldftra.F90
r7753 r8568 30 30 USE lib_mpp ! distribued memory computing library 31 31 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 32 USE wrk_nemo ! work arrays33 32 USE timing ! timing 34 33 … … 45 44 ! !!* Namelist namtra_ldf : lateral mixing on tracers * 46 45 ! != Operator type =! 46 LOGICAL , PUBLIC :: ln_traldf_NONE !: no operator: No explicit diffusion 47 47 LOGICAL , PUBLIC :: ln_traldf_lap !: laplacian operator 48 48 LOGICAL , PUBLIC :: ln_traldf_blp !: bilaplacian operator … … 119 119 INTEGER :: ierr, inum, ios ! local integer 120 120 REAL(wp) :: zah0 ! local scalar 121 ! 122 NAMELIST/namtra_ldf/ ln_traldf_ lap, ln_traldf_blp ,& ! type of operator123 & ln_traldf_lev , ln_traldf_hor , ln_traldf_triad, & ! acting direction of the operator124 & ln_traldf_iso , ln_traldf_msc , rn_slpmax , & ! option for iso-neutral operator125 & ln_triad_iso , ln_botmix_triad, rn_sw_triad , & ! option for triad operator126 & rn_aht_0 , rn_bht_0 , nn_aht_ijk_t ! lateral eddy coefficient121 !! 122 NAMELIST/namtra_ldf/ ln_traldf_NONE, ln_traldf_lap , ln_traldf_blp , & ! type of operator 123 & ln_traldf_lev , ln_traldf_hor , ln_traldf_triad, & ! acting direction of the operator 124 & ln_traldf_iso , ln_traldf_msc , rn_slpmax , & ! option for iso-neutral operator 125 & ln_triad_iso , ln_botmix_triad, rn_sw_triad , & ! option for triad operator 126 & rn_aht_0 , rn_bht_0 , nn_aht_ijk_t ! lateral eddy coefficient 127 127 !!---------------------------------------------------------------------- 128 128 ! … … 144 144 WRITE(numout,*) '~~~~~~~~~~~~ ' 145 145 WRITE(numout,*) ' Namelist namtra_ldf : lateral mixing parameters (type, direction, coefficients)' 146 !147 146 WRITE(numout,*) ' type :' 147 WRITE(numout,*) ' no explicit diffusion ln_traldf_NONE = ', ln_traldf_NONE 148 148 WRITE(numout,*) ' laplacian operator ln_traldf_lap = ', ln_traldf_lap 149 149 WRITE(numout,*) ' bilaplacian operator ln_traldf_blp = ', ln_traldf_blp 150 !151 150 WRITE(numout,*) ' direction of action :' 152 151 WRITE(numout,*) ' iso-level ln_traldf_lev = ', ln_traldf_lev … … 159 158 WRITE(numout,*) ' switching triad or not rn_sw_triad = ', rn_sw_triad 160 159 WRITE(numout,*) ' lateral mixing on bottom ln_botmix_triad = ', ln_botmix_triad 161 !162 160 WRITE(numout,*) ' coefficients :' 163 161 WRITE(numout,*) ' lateral eddy diffusivity (lap case) rn_aht_0 = ', rn_aht_0 … … 168 166 ! ! Parameter control 169 167 ! 170 IF( .NOT.ln_traldf_lap .AND. .NOT.ln_traldf_blp) THEN168 IF( ln_traldf_NONE ) THEN 171 169 IF(lwp) WRITE(numout,*) ' No diffusive operator selected. ahtu and ahtv are not allocated' 172 170 l_ldftra_time = .FALSE. … … 490 488 ! 491 489 INTEGER :: ji, jj, jk ! dummy loop indices 492 REAL(wp) :: zfw, ze3w, zn2, z1_f20, zaht, zaht_min, zzaei ! local scalars 493 REAL(wp), DIMENSION(:,:), POINTER :: zn, zah, zhw, zross, zaeiw ! 2D workspace 494 !!---------------------------------------------------------------------- 495 ! 496 IF( nn_timing == 1 ) CALL timing_start('ldf_eiv') 497 ! 498 CALL wrk_alloc( jpi,jpj, zn, zah, zhw, zross, zaeiw ) 499 ! 490 REAL(wp) :: zfw, ze3w, zn2, z1_f20, zaht, zaht_min, zzaei ! local scalars 491 REAL(wp), DIMENSION(jpi,jpj) :: zn, zah, zhw, zross, zaeiw ! 2D workspace 492 !!---------------------------------------------------------------------- 493 ! 494 IF( ln_timing ) CALL timing_start('ldf_eiv') 495 ! 500 496 zn (:,:) = 0._wp ! Local initialization 501 497 zhw (:,:) = 5._wp … … 575 571 END DO 576 572 ! 577 CALL wrk_dealloc( jpi,jpj, zn, zah, zhw, zross, zaeiw ) 578 ! 579 IF( nn_timing == 1 ) CALL timing_stop('ldf_eiv') 573 IF( ln_timing ) CALL timing_stop('ldf_eiv') 580 574 ! 581 575 END SUBROUTINE ldf_eiv … … 610 604 REAL(wp) :: zuwk, zuwk1, zuwi, zuwi1 ! local scalars 611 605 REAL(wp) :: zvwk, zvwk1, zvwj, zvwj1 ! - - 612 REAL(wp), POINTER, DIMENSION(:,:,:) :: zpsi_uw, zpsi_vw 613 !!---------------------------------------------------------------------- 614 ! 615 IF( nn_timing == 1 ) CALL timing_start( 'ldf_eiv_trp') 616 ! 617 CALL wrk_alloc( jpi,jpj,jpk, zpsi_uw, zpsi_vw ) 618 606 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zpsi_uw, zpsi_vw 607 !!---------------------------------------------------------------------- 608 ! 609 IF( ln_timing ) CALL timing_start( 'ldf_eiv_trp') 610 ! 619 611 IF( kt == kit000 ) THEN 620 612 IF(lwp) WRITE(numout,*) … … 658 650 IF( ln_ldfeiv_dia .AND. cdtype == 'TRA' ) CALL ldf_eiv_dia( zpsi_uw, zpsi_vw ) 659 651 ! 660 CALL wrk_dealloc( jpi,jpj,jpk, zpsi_uw, zpsi_vw ) 661 ! 662 IF( nn_timing == 1 ) CALL timing_stop( 'ldf_eiv_trp') 652 IF( ln_timing ) CALL timing_stop( 'ldf_eiv_trp') 663 653 ! 664 654 END SUBROUTINE ldf_eiv_trp … … 679 669 INTEGER :: ji, jj, jk ! dummy loop indices 680 670 REAL(wp) :: zztmp ! local scalar 681 REAL(wp), DIMENSION(:,:) , POINTER :: zw2d ! 2D workspace 682 REAL(wp), DIMENSION(:,:,:), POINTER :: zw3d ! 3D workspace 683 !!---------------------------------------------------------------------- 684 ! 685 IF( nn_timing == 1 ) CALL timing_start( 'ldf_eiv_dia') 671 REAL(wp), DIMENSION(jpi,jpj) :: zw2d ! 2D workspace 672 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zw3d ! 3D workspace 673 !!---------------------------------------------------------------------- 674 ! 675 !!gm I don't like this routine.... Crazy way of doing things, not optimal at all... 676 !!gm to be redesigned.... 677 IF( ln_timing ) CALL timing_start( 'ldf_eiv_dia') 686 678 ! 687 679 ! !== eiv stream function: output ==! … … 693 685 ! 694 686 ! !== eiv velocities: calculate and output ==! 695 CALL wrk_alloc( jpi,jpj,jpk, zw3d )696 687 ! 697 688 zw3d(:,:,jpk) = 0._wp ! bottom value always 0 … … 718 709 CALL iom_put( "woce_eiv", zw3d ) 719 710 ! 720 !721 !722 CALL wrk_alloc( jpi,jpj, zw2d )723 711 ! 724 712 zztmp = 0.5_wp * rau0 * rcp … … 792 780 IF( ln_diaptr ) CALL dia_ptr_hst( jp_sal, 'eiv', 0.5 * zw3d ) 793 781 ! 794 CALL wrk_dealloc( jpi,jpj, zw2d ) 795 CALL wrk_dealloc( jpi,jpj,jpk, zw3d ) 796 ! 797 IF( nn_timing == 1 ) CALL timing_stop( 'ldf_eiv_dia') 782 ! 783 IF( ln_timing ) CALL timing_stop( 'ldf_eiv_dia') 798 784 ! 799 785 END SUBROUTINE ldf_eiv_dia -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/TRA/eosbn2.F90
r8215 r8568 46 46 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 47 47 USE prtctl ! Print control 48 USE wrk_nemo ! Memory Allocation49 48 USE lbclnk ! ocean lateral boundary conditions 50 49 USE timing ! Timing … … 231 230 !!---------------------------------------------------------------------- 232 231 ! 233 IF( nn_timing == 1) CALL timing_start('eos-insitu')232 IF( ln_timing ) CALL timing_start('eos-insitu') 234 233 ! 235 234 SELECT CASE( neos ) … … 298 297 IF(ln_ctl) CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-insitu : ', ovlap=1, kdim=jpk ) 299 298 ! 300 IF( nn_timing == 1) CALL timing_stop('eos-insitu')299 IF( ln_timing ) CALL timing_stop('eos-insitu') 301 300 ! 302 301 END SUBROUTINE eos_insitu … … 329 328 !!---------------------------------------------------------------------- 330 329 ! 331 IF( nn_timing == 1) CALL timing_start('eos-pot')330 IF( ln_timing ) CALL timing_start('eos-pot') 332 331 ! 333 332 SELECT CASE ( neos ) … … 465 464 IF(ln_ctl) CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-pot: ', tab3d_2=prhop, clinfo2=' pot : ', ovlap=1, kdim=jpk ) 466 465 ! 467 IF( nn_timing == 1) CALL timing_stop('eos-pot')466 IF( ln_timing ) CALL timing_stop('eos-pot') 468 467 ! 469 468 END SUBROUTINE eos_insitu_pot … … 491 490 !!---------------------------------------------------------------------- 492 491 ! 493 IF( nn_timing == 1) CALL timing_start('eos2d')492 IF( ln_timing ) CALL timing_start('eos2d') 494 493 ! 495 494 prd(:,:) = 0._wp … … 560 559 IF(ln_ctl) CALL prt_ctl( tab2d_1=prd, clinfo1=' eos2d: ' ) 561 560 ! 562 IF( nn_timing == 1) CALL timing_stop('eos2d')561 IF( ln_timing ) CALL timing_stop('eos2d') 563 562 ! 564 563 END SUBROUTINE eos_insitu_2d … … 583 582 !!---------------------------------------------------------------------- 584 583 ! 585 IF( nn_timing == 1) CALL timing_start('rab_3d')584 IF( ln_timing ) CALL timing_start('rab_3d') 586 585 ! 587 586 SELECT CASE ( neos ) … … 674 673 & tab3d_2=pab(:,:,:,jp_sal), clinfo2=' rab_3d_s : ', ovlap=1, kdim=jpk ) 675 674 ! 676 IF( nn_timing == 1) CALL timing_stop('rab_3d')675 IF( ln_timing ) CALL timing_stop('rab_3d') 677 676 ! 678 677 END SUBROUTINE rab_3d … … 696 695 !!---------------------------------------------------------------------- 697 696 ! 698 IF( nn_timing == 1 )CALL timing_start('rab_2d')697 IF( ln_timing ) CALL timing_start('rab_2d') 699 698 ! 700 699 pab(:,:,:) = 0._wp … … 791 790 & tab2d_2=pab(:,:,jp_sal), clinfo2=' rab_2d_s : ' ) 792 791 ! 793 IF( nn_timing == 1) CALL timing_stop('rab_2d')792 IF( ln_timing ) CALL timing_stop('rab_2d') 794 793 ! 795 794 END SUBROUTINE rab_2d … … 812 811 !!---------------------------------------------------------------------- 813 812 ! 814 IF( nn_timing == 1 )CALL timing_start('rab_2d')813 IF( ln_timing ) CALL timing_start('rab_2d') 815 814 ! 816 815 pab(:) = 0._wp … … 888 887 END SELECT 889 888 ! 890 IF( nn_timing == 1) CALL timing_stop('rab_2d')889 IF( ln_timing ) CALL timing_stop('rab_2d') 891 890 ! 892 891 END SUBROUTINE rab_0d … … 915 914 !!---------------------------------------------------------------------- 916 915 ! 917 IF( nn_timing == 1 )CALL timing_start('bn2')916 IF( ln_timing ) CALL timing_start('bn2') 918 917 ! 919 918 DO jk = 2, jpkm1 ! interior points only (2=< jk =< jpkm1 ) … … 935 934 IF(ln_ctl) CALL prt_ctl( tab3d_1=pn2, clinfo1=' bn2 : ', ovlap=1, kdim=jpk ) 936 935 ! 937 IF( nn_timing == 1) CALL timing_stop('bn2')936 IF( ln_timing ) CALL timing_stop('bn2') 938 937 ! 939 938 END SUBROUTINE bn2 … … 963 962 !!---------------------------------------------------------------------- 964 963 ! 965 IF ( nn_timing == 1) CALL timing_start('eos_pt_from_ct')964 IF( ln_timing ) CALL timing_start('eos_pt_from_ct') 966 965 ! 967 966 zdeltaS = 5._wp … … 994 993 END DO 995 994 ! 996 IF( nn_timing == 1) CALL timing_stop('eos_pt_from_ct')995 IF( ln_timing ) CALL timing_stop('eos_pt_from_ct') 997 996 ! 998 997 END FUNCTION eos_pt_from_ct … … 1128 1127 !!---------------------------------------------------------------------- 1129 1128 ! 1130 IF( nn_timing == 1) CALL timing_start('eos_pen')1129 IF( ln_timing ) CALL timing_start('eos_pen') 1131 1130 ! 1132 1131 SELECT CASE ( neos ) … … 1222 1221 END SELECT 1223 1222 ! 1224 IF( nn_timing == 1) CALL timing_stop('eos_pen')1223 IF( ln_timing ) CALL timing_stop('eos_pen') 1225 1224 ! 1226 1225 END SUBROUTINE eos_pen -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/TRA/traadv.F90
r7753 r8568 14 14 !!---------------------------------------------------------------------- 15 15 !! tra_adv : compute ocean tracer advection trend 16 !! tra_adv_ ctl: control the different options of advection scheme16 !! tra_adv_init : control the different options of advection scheme 17 17 !!---------------------------------------------------------------------- 18 18 USE oce ! ocean dynamics and active tracers 19 19 USE dom_oce ! ocean space and time domain 20 20 USE domvvl ! variable vertical scale factors 21 USE sbcwave ! wave module 22 USE sbc_oce ! surface boundary condition: ocean 21 23 USE traadv_cen ! centered scheme (tra_adv_cen routine) 22 24 USE traadv_fct ! FCT scheme (tra_adv_fct routine) … … 27 29 USE ldftra ! lateral diffusion: eddy diffusivity & EIV coeff. 28 30 USE ldfslp ! Lateral diffusion: slopes of neutral surfaces 29 USE trd_oce ! trends: ocean variables 30 USE trdtra ! trends manager: tracers 31 USE trd_oce ! trends: ocean variables 32 USE trdtra ! trends manager: tracers 33 USE diaptr ! Poleward heat transport 31 34 ! 32 35 USE in_out_manager ! I/O manager … … 34 37 USE prtctl ! Print control 35 38 USE lib_mpp ! MPP library 36 USE wrk_nemo ! Memory Allocation37 39 USE timing ! Timing 38 USE sbcwave ! wave module39 USE sbc_oce ! surface boundary condition: ocean40 USE diaptr ! Poleward heat transport41 40 42 41 IMPLICIT NONE 43 42 PRIVATE 44 43 45 PUBLIC tra_adv ! routine called by step module46 PUBLIC tra_adv_init ! routine called by opa module44 PUBLIC tra_adv ! called by step.F90 45 PUBLIC tra_adv_init ! called by nemogcm.F90 47 46 48 47 ! !!* Namelist namtra_adv * 48 LOGICAL :: ln_traadv_NONE ! no advection on T and S 49 49 LOGICAL :: ln_traadv_cen ! centered scheme flag 50 50 INTEGER :: nn_cen_h, nn_cen_v ! =2/4 : horizontal and vertical choices of the order of CEN scheme 51 51 LOGICAL :: ln_traadv_fct ! FCT scheme flag 52 52 INTEGER :: nn_fct_h, nn_fct_v ! =2/4 : horizontal and vertical choices of the order of FCT scheme 53 INTEGER :: nn_fct_zts ! >=1 : 2nd order FCT with vertical sub-timestepping54 53 LOGICAL :: ln_traadv_mus ! MUSCL scheme flag 55 54 LOGICAL :: ln_mus_ups ! use upstream scheme in vivcinity of river mouths … … 58 57 LOGICAL :: ln_traadv_qck ! QUICKEST scheme flag 59 58 60 INTEGER :: nadv ! choice of the type of advection scheme 61 ! 62 ! ! associated indices: 59 INTEGER :: nadv ! choice of the type of advection scheme 60 ! ! associated indices: 63 61 INTEGER, PARAMETER :: np_NO_adv = 0 ! no T-S advection 64 62 INTEGER, PARAMETER :: np_CEN = 1 ! 2nd/4th order centered scheme 65 63 INTEGER, PARAMETER :: np_FCT = 2 ! 2nd/4th order Flux Corrected Transport scheme 66 INTEGER, PARAMETER :: np_FCT_zts = 3 ! 2nd order FCT scheme with vertical sub-timestepping 67 INTEGER, PARAMETER :: np_MUS = 4 ! MUSCL scheme 68 INTEGER, PARAMETER :: np_UBS = 5 ! 3rd order Upstream Biased Scheme 69 INTEGER, PARAMETER :: np_QCK = 6 ! QUICK scheme 64 INTEGER, PARAMETER :: np_MUS = 3 ! MUSCL scheme 65 INTEGER, PARAMETER :: np_UBS = 4 ! 3rd order Upstream Biased Scheme 66 INTEGER, PARAMETER :: np_QCK = 5 ! QUICK scheme 70 67 71 68 !! * Substitutions 72 69 # include "vectopt_loop_substitute.h90" 73 70 !!---------------------------------------------------------------------- 74 !! NEMO/OPA 3.7 , NEMO Consortium (2014)71 !! NEMO/OPA 4.0 , NEMO Consortium (2017) 75 72 !! $Id$ 76 73 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 86 83 !! ** Method : - Update (ua,va) with the advection term following nadv 87 84 !!---------------------------------------------------------------------- 88 INTEGER, INTENT( in) :: kt ! ocean time-step index85 INTEGER, INTENT(in) :: kt ! ocean time-step index 89 86 ! 90 87 INTEGER :: jk ! dummy loop index 91 REAL(wp), POINTER, DIMENSION(:,:,:) :: zun, zvn, zwn 92 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdt, ztrds ! 3D workspace 93 !!---------------------------------------------------------------------- 94 ! 95 IF( nn_timing == 1 ) CALL timing_start('tra_adv') 96 ! 97 CALL wrk_alloc( jpi,jpj,jpk, zun, zvn, zwn ) 88 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zun, zvn, zwn ! 3D workspace 89 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdt, ztrds 90 !!---------------------------------------------------------------------- 91 ! 92 IF( ln_timing ) CALL timing_start('tra_adv') 98 93 ! 99 94 ! ! set time step 100 zun(:,:,:) = 0.0 101 zvn(:,:,:) = 0.0 102 zwn(:,:,:) = 0.0 103 ! 104 IF( neuler == 0 .AND. kt == nit000 ) THEN ! at nit000 105 r2dt = rdt ! = rdt (restarting with Euler time stepping) 106 ELSEIF( kt <= nit000 + 1) THEN ! at nit000 or nit000+1 107 r2dt = 2._wp * rdt ! = 2 rdt (leapfrog) 95 IF( neuler == 0 .AND. kt == nit000 ) THEN ; r2dt = rdt ! at nit000 (Euler) 96 ELSEIF( kt <= nit000 + 1 ) THEN ; r2dt = 2._wp* rdt ! at nit000 or nit000+1 (Leapfrog) 108 97 ENDIF 109 98 ! 110 99 ! !== effective transport ==! 100 zun(:,:,jpk) = 0._wp 101 zvn(:,:,jpk) = 0._wp 102 zwn(:,:,jpk) = 0._wp 111 103 IF( ln_wave .AND. ln_sdw ) THEN 112 104 DO jk = 1, jpkm1 ! eulerian transport + Stokes Drift … … 146 138 ! 147 139 IF( l_trdtra ) THEN !* Save ta and sa trends 148 CALL wrk_alloc( jpi, jpj, jpk, ztrdt, ztrds)140 ALLOCATE( ztrdt(jpi,jpj,jpk), ztrds(jpi,jpj,jpk) ) 149 141 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 150 142 ztrds(:,:,:) = tsa(:,:,:,jp_sal) … … 153 145 SELECT CASE ( nadv ) !== compute advection trend and add it to general trend ==! 154 146 ! 155 CASE ( np_CEN ) 147 CASE ( np_CEN ) ! Centered scheme : 2nd / 4th order 156 148 CALL tra_adv_cen ( kt, nit000, 'TRA', zun, zvn, zwn , tsn, tsa, jpts, nn_cen_h, nn_cen_v ) 157 CASE ( np_FCT ) 149 CASE ( np_FCT ) ! FCT scheme : 2nd / 4th order 158 150 CALL tra_adv_fct ( kt, nit000, 'TRA', r2dt, zun, zvn, zwn, tsb, tsn, tsa, jpts, nn_fct_h, nn_fct_v ) 159 CASE ( np_FCT_zts ) ! 2nd order FCT with vertical time-splitting 160 CALL tra_adv_fct_zts( kt, nit000, 'TRA', r2dt, zun, zvn, zwn, tsb, tsn, tsa, jpts , nn_fct_zts ) 161 CASE ( np_MUS ) ! MUSCL 151 CASE ( np_MUS ) ! MUSCL 162 152 CALL tra_adv_mus ( kt, nit000, 'TRA', r2dt, zun, zvn, zwn, tsb, tsa, jpts , ln_mus_ups ) 163 CASE ( np_UBS ) 153 CASE ( np_UBS ) ! UBS 164 154 CALL tra_adv_ubs ( kt, nit000, 'TRA', r2dt, zun, zvn, zwn, tsb, tsn, tsa, jpts , nn_ubs_v ) 165 CASE ( np_QCK ) 155 CASE ( np_QCK ) ! QUICKEST 166 156 CALL tra_adv_qck ( kt, nit000, 'TRA', r2dt, zun, zvn, zwn, tsb, tsn, tsa, jpts ) 167 157 ! … … 175 165 CALL trd_tra( kt, 'TRA', jp_tem, jptra_totad, ztrdt ) 176 166 CALL trd_tra( kt, 'TRA', jp_sal, jptra_totad, ztrds ) 177 CALL wrk_dealloc( jpi, jpj, jpk,ztrdt, ztrds )167 DEALLOCATE( ztrdt, ztrds ) 178 168 ENDIF 179 169 ! ! print mean trends (used for debugging) … … 181 171 & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 182 172 ! 183 IF( nn_timing == 1 ) CALL timing_stop( 'tra_adv' ) 184 ! 185 CALL wrk_dealloc( jpi,jpj,jpk, zun, zvn, zwn ) 186 ! 173 IF( ln_timing ) CALL timing_stop( 'tra_adv' ) 174 ! 187 175 END SUBROUTINE tra_adv 188 176 … … 197 185 INTEGER :: ioptio, ios ! Local integers 198 186 ! 199 NAMELIST/namtra_adv/ ln_traadv_cen, nn_cen_h, nn_cen_v, & ! CEN 200 & ln_traadv_fct, nn_fct_h, nn_fct_v, nn_fct_zts, & ! FCT 201 & ln_traadv_mus, ln_mus_ups, & ! MUSCL 202 & ln_traadv_ubs, nn_ubs_v, & ! UBS 203 & ln_traadv_qck ! QCK 187 NAMELIST/namtra_adv/ ln_traadv_NONE, & ! No advection 188 & ln_traadv_cen , nn_cen_h, nn_cen_v, & ! CEN 189 & ln_traadv_fct , nn_fct_h, nn_fct_v, & ! FCT 190 & ln_traadv_mus , ln_mus_ups, & ! MUSCL 191 & ln_traadv_ubs , nn_ubs_v, & ! UBS 192 & ln_traadv_qck ! QCK 204 193 !!---------------------------------------------------------------------- 205 194 ! … … 217 206 WRITE(numout,*) 218 207 WRITE(numout,*) 'tra_adv_init : choice/control of the tracer advection scheme' 219 WRITE(numout,*) '~~~~~~~~~~~ '208 WRITE(numout,*) '~~~~~~~~~~~~' 220 209 WRITE(numout,*) ' Namelist namtra_adv : chose a advection scheme for tracers' 210 WRITE(numout,*) ' No advection on T & S ln_traadv_NONE= ', ln_traadv_NONE 221 211 WRITE(numout,*) ' centered scheme ln_traadv_cen = ', ln_traadv_cen 222 212 WRITE(numout,*) ' horizontal 2nd/4th order nn_cen_h = ', nn_fct_h … … 225 215 WRITE(numout,*) ' horizontal 2nd/4th order nn_fct_h = ', nn_fct_h 226 216 WRITE(numout,*) ' vertical 2nd/4th order nn_fct_v = ', nn_fct_v 227 WRITE(numout,*) ' 2nd order + vertical sub-timestepping nn_fct_zts = ', nn_fct_zts228 217 WRITE(numout,*) ' MUSCL scheme ln_traadv_mus = ', ln_traadv_mus 229 218 WRITE(numout,*) ' + upstream scheme near river mouths ln_mus_ups = ', ln_mus_ups … … 233 222 ENDIF 234 223 ! 235 ioptio = 0 !== Parameter control ==! 236 IF( ln_traadv_cen ) ioptio = ioptio + 1 237 IF( ln_traadv_fct ) ioptio = ioptio + 1 238 IF( ln_traadv_mus ) ioptio = ioptio + 1 239 IF( ln_traadv_ubs ) ioptio = ioptio + 1 240 IF( ln_traadv_qck ) ioptio = ioptio + 1 241 ! 242 IF( ioptio == 0 ) THEN 243 nadv = np_NO_adv 244 CALL ctl_warn( 'tra_adv_init: You are running without tracer advection.' ) 245 ENDIF 246 IF( ioptio /= 1 ) CALL ctl_stop( 'tra_adv_init: Choose ONE advection scheme in namelist namtra_adv' ) 224 ! !== Parameter control & set nadv ==! 225 ioptio = 0 226 IF( ln_traadv_NONE ) THEN ; ioptio = ioptio + 1 ; nadv = np_NO_adv ; ENDIF 227 IF( ln_traadv_cen ) THEN ; ioptio = ioptio + 1 ; nadv = np_CEN ; ENDIF 228 IF( ln_traadv_fct ) THEN ; ioptio = ioptio + 1 ; nadv = np_FCT ; ENDIF 229 IF( ln_traadv_mus ) THEN ; ioptio = ioptio + 1 ; nadv = np_MUS ; ENDIF 230 IF( ln_traadv_ubs ) THEN ; ioptio = ioptio + 1 ; nadv = np_UBS ; ENDIF 231 IF( ln_traadv_qck ) THEN ; ioptio = ioptio + 1 ; nadv = np_QCK ; ENDIF 232 ! 233 IF( ioptio /= 1 ) CALL ctl_stop( 'tra_adv_init: Choose ONE advection option in namelist namtra_adv' ) 247 234 ! 248 235 IF( ln_traadv_cen .AND. ( nn_cen_h /= 2 .AND. nn_cen_h /= 4 ) & ! Centered … … 254 241 CALL ctl_stop( 'tra_adv_init: FCT scheme, choose 2nd or 4th order' ) 255 242 ENDIF 256 IF( ln_traadv_fct .AND. nn_fct_zts > 0 ) THEN257 IF( nn_fct_h == 4 ) THEN258 nn_fct_h = 2259 CALL ctl_stop( 'tra_adv_init: force 2nd order FCT scheme, 4th order does not exist with sub-timestepping' )260 ENDIF261 IF( .NOT.ln_linssh ) THEN262 CALL ctl_stop( 'tra_adv_init: vertical sub-timestepping not allow in non-linear free surface' )263 ENDIF264 IF( nn_fct_zts == 1 ) CALL ctl_warn( 'tra_adv_init: FCT with ONE sub-timestep = FCT without sub-timestep' )265 ENDIF266 243 IF( ln_traadv_ubs .AND. ( nn_ubs_v /= 2 .AND. nn_ubs_v /= 4 ) ) THEN ! UBS 267 244 CALL ctl_stop( 'tra_adv_init: UBS scheme, choose 2nd or 4th order' ) … … 275 252 ENDIF 276 253 ! 277 ! !== used advection scheme ==! 278 ! ! set nadv 279 IF( ln_traadv_cen ) nadv = np_CEN 280 IF( ln_traadv_fct ) nadv = np_FCT 281 IF( ln_traadv_fct .AND. nn_fct_zts > 0 ) nadv = np_FCT_zts 282 IF( ln_traadv_mus ) nadv = np_MUS 283 IF( ln_traadv_ubs ) nadv = np_UBS 284 IF( ln_traadv_qck ) nadv = np_QCK 285 ! 286 IF(lwp) THEN ! Print the choice 254 ! !== Print the choice ==! 255 IF(lwp) THEN 287 256 WRITE(numout,*) 288 257 SELECT CASE ( nadv ) … … 292 261 CASE( np_FCT ) ; WRITE(numout,*) ' ===>> FCT scheme is used. Horizontal order: ', nn_fct_h, & 293 262 & ' Vertical order: ', nn_fct_v 294 CASE( np_FCT_zts ) ; WRITE(numout,*) ' ===>> use 2nd order FCT with ', nn_fct_zts,'vertical sub-timestepping'295 263 CASE( np_MUS ) ; WRITE(numout,*) ' ===>> MUSCL scheme is used' 296 264 CASE( np_UBS ) ; WRITE(numout,*) ' ===>> UBS scheme is used' -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_cen.F90
r7646 r8568 11 11 !! NB: on the vertical it is actually a 4th order COMPACT scheme which is used 12 12 !!---------------------------------------------------------------------- 13 USE oce , ONLY: tsn ! now ocean temperature and salinity14 13 USE dom_oce ! ocean space and time domain 15 14 USE eosbn2 ! equation of state … … 24 23 USE trc_oce ! share passive tracers/Ocean variables 25 24 USE lib_mpp ! MPP library 26 USE wrk_nemo ! Memory Allocation27 25 USE timing ! Timing 28 26 … … 30 28 PRIVATE 31 29 32 PUBLIC tra_adv_cen ! routine called by step.F9030 PUBLIC tra_adv_cen ! called by traadv.F90 33 31 34 32 REAL(wp) :: r1_6 = 1._wp / 6._wp ! =1/6 35 33 36 LOGICAL :: l_trd ! flag to compute trends37 LOGICAL :: l_ptr ! flag to compute poleward transport38 LOGICAL :: l_hst ! flag to compute heat/salt transport34 LOGICAL :: l_trd ! flag to compute trends 35 LOGICAL :: l_ptr ! flag to compute poleward transport 36 LOGICAL :: l_hst ! flag to compute heat/salt transport 39 37 40 38 !! * Substitutions 41 39 # include "vectopt_loop_substitute.h90" 42 40 !!---------------------------------------------------------------------- 43 !! NEMO/OPA 3.7 , NEMO Consortium (2014)44 !! $Id $41 !! NEMO/OPA 4.0, NEMO Consortium (2017) 42 !! $Id:$ 45 43 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 46 44 !!---------------------------------------------------------------------- … … 48 46 49 47 SUBROUTINE tra_adv_cen( kt, kit000, cdtype, pun, pvn, pwn, & 50 & 48 & ptn, pta, kjpt, kn_cen_h, kn_cen_v ) 51 49 !!---------------------------------------------------------------------- 52 50 !! *** ROUTINE tra_adv_cen *** … … 80 78 REAL(wp) :: zC2t_u, zC4t_u ! local scalars 81 79 REAL(wp) :: zC2t_v, zC4t_v ! - - 82 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwx, zwy, zwz, ztu, ztv, ztw80 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwx, zwy, zwz, ztu, ztv, ztw 83 81 !!---------------------------------------------------------------------- 84 82 ! 85 IF( nn_timing == 1 ) CALL timing_start('tra_adv_cen') 86 ! 87 CALL wrk_alloc( jpi,jpj,jpk, zwx, zwy, zwz, ztu, ztv, ztw ) 83 IF( ln_timing ) CALL timing_start('tra_adv_cen') 88 84 ! 89 85 IF( kt == kit000 ) THEN … … 92 88 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~ ' 93 89 ENDIF 94 ! 90 ! ! set local switches 95 91 l_trd = .FALSE. 96 92 l_hst = .FALSE. … … 130 126 END DO 131 127 END DO 132 CALL lbc_lnk( ztu, 'U', -1. ) ; CALL lbc_lnk( ztv, 'V', -1. ) ! Lateral boundary cond. (unchanged sgn)128 CALL lbc_lnk( ztu, 'U', -1. ) ; CALL lbc_lnk( ztv, 'V', -1. ) ! Lateral boundary cond. 133 129 ! 134 130 DO jk = 1, jpkm1 ! Horizontal advective fluxes … … 203 199 END IF 204 200 ! ! "Poleward" heat and salt transports 205 IF( l_ptr ) CALL dia_ptr_hst( jn, 'adv', zwy(:,:,:) )201 IF( l_ptr ) CALL dia_ptr_hst( jn, 'adv', zwy(:,:,:) ) 206 202 ! ! heat and salt transport 207 IF( l_hst ) CALL dia_ar5_hst( jn, 'adv', zwx(:,:,:), zwy(:,:,:) )203 IF( l_hst ) CALL dia_ar5_hst( jn, 'adv', zwx(:,:,:), zwy(:,:,:) ) 208 204 ! 209 205 END DO 210 206 ! 211 CALL wrk_dealloc( jpi,jpj,jpk, zwx, zwy, zwz, ztu, ztv, ztw ) 212 ! 213 IF( nn_timing == 1 ) CALL timing_stop('tra_adv_cen') 207 IF( ln_timing ) CALL timing_stop('tra_adv_cen') 214 208 ! 215 209 END SUBROUTINE tra_adv_cen -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_fct.F90
r7753 r8568 9 9 !!---------------------------------------------------------------------- 10 10 !! tra_adv_fct : update the tracer trend with a 3D advective trends using a 2nd or 4th order FCT scheme 11 !! tra_adv_fct_zts: update the tracer trend with a 3D advective trends using a 2nd order FCT scheme12 11 !! with sub-time-stepping in the vertical direction 13 12 !! nonosc : compute monotonic tracer fluxes by a non-oscillatory algorithm … … 21 20 USE diaptr ! poleward transport diagnostics 22 21 USE diaar5 ! AR5 diagnostics 23 USE phycst , ONLY: rau0_rcp22 USE phycst , ONLY : rau0_rcp 24 23 ! 25 24 USE in_out_manager ! I/O manager 26 USE iom 25 USE iom ! 27 26 USE lib_mpp ! MPP library 28 27 USE lbclnk ! ocean lateral boundary condition (or mpp link) 29 28 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 30 USE wrk_nemo ! Memory Allocation31 29 USE timing ! Timing 32 30 … … 34 32 PRIVATE 35 33 36 PUBLIC tra_adv_fct ! routine called by traadv.F90 37 PUBLIC tra_adv_fct_zts ! routine called by traadv.F90 38 PUBLIC interp_4th_cpt ! routine called by traadv_cen.F90 34 PUBLIC tra_adv_fct ! called by traadv.F90 35 PUBLIC interp_4th_cpt ! called by traadv_cen.F90 39 36 40 37 LOGICAL :: l_trd ! flag to compute trends … … 50 47 # include "vectopt_loop_substitute.h90" 51 48 !!---------------------------------------------------------------------- 52 !! NEMO/OPA 3.7 , NEMO Consortium (2014)49 !! NEMO/OPA 4.0 , NEMO Consortium (2017) 53 50 !! $Id$ 54 51 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 70 67 !! 71 68 !! ** Action : - update pta with the now advective tracer trends 72 !! - send trends to trdtra module for further diagnost cs (l_trdtra=T)69 !! - send trends to trdtra module for further diagnostics (l_trdtra=T) 73 70 !! - htr_adv, str_adv : poleward advective heat and salt transport (ln_diaptr=T) 74 71 !!---------------------------------------------------------------------- … … 88 85 REAL(wp) :: zfp_ui, zfp_vj, zfp_wk, zC2t_u, zC4t_u ! - - 89 86 REAL(wp) :: zfm_ui, zfm_vj, zfm_wk, zC2t_v, zC4t_v ! - - 90 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwi, zwx, zwy, zwz, ztu, ztv, zltu, zltv, ztw 91 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdx, ztrdy, ztrdz, zptry 92 REAL(wp), POINTER, DIMENSION(:,:) :: z2d 93 !!---------------------------------------------------------------------- 94 ! 95 IF( nn_timing == 1 ) CALL timing_start('tra_adv_fct') 96 ! 97 CALL wrk_alloc( jpi,jpj,jpk, zwi, zwx, zwy, zwz, ztu, ztv, zltu, zltv, ztw ) 87 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwi, zwx, zwy, zwz, ztu, ztv, zltu, zltv, ztw 88 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdx, ztrdy, ztrdz, zptry 89 !!---------------------------------------------------------------------- 90 ! 91 IF( ln_timing ) CALL timing_start('tra_adv_fct') 98 92 ! 99 93 IF( kt == kit000 ) THEN … … 103 97 ENDIF 104 98 ! 105 l_trd = .FALSE. 99 l_trd = .FALSE. ! set local switches 106 100 l_hst = .FALSE. 107 101 l_ptr = .FALSE. 108 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) )l_trd = .TRUE.109 IF( cdtype == 'TRA' .AND. ln_diaptr )l_ptr = .TRUE.110 IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR.&111 & 102 IF( ( cdtype =='TRA' .AND. l_trdtra ) .OR. ( cdtype =='TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 103 IF( cdtype =='TRA' .AND. ln_diaptr ) l_ptr = .TRUE. 104 IF( cdtype =='TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 105 & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. 112 106 ! 113 107 IF( l_trd .OR. l_hst ) THEN 114 CALL wrk_alloc( jpi, jpj, jpk, ztrdx, ztrdy, ztrdz)108 ALLOCATE( ztrdx(jpi,jpj,jpk), ztrdy(jpi,jpj,jpk), ztrdz(jpi,jpj,jpk) ) 115 109 ztrdx(:,:,:) = 0._wp ; ztrdy(:,:,:) = 0._wp ; ztrdz(:,:,:) = 0._wp 116 110 ENDIF 117 111 ! 118 112 IF( l_ptr ) THEN 119 CALL wrk_alloc( jpi, jpj, jpk, zptry)113 ALLOCATE( zptry(jpi,jpj,jpk) ) 120 114 zptry(:,:,:) = 0._wp 121 115 ENDIF … … 184 178 END IF 185 179 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 186 IF( l_ptr ) zptry(:,:,:) = zwy(:,:,:)180 IF( l_ptr ) zptry(:,:,:) = zwy(:,:,:) 187 181 ! 188 182 ! !== anti-diffusive flux : high order minus low order ==! … … 308 302 END DO 309 303 ! 310 IF( l_trd .OR. l_hst ) THEN ! trend diagnostics (contribution of upstream fluxes) 311 ztrdx(:,:,:) = ztrdx(:,:,:) + zwx(:,:,:) ! <<< Add to previously computed 312 ztrdy(:,:,:) = ztrdy(:,:,:) + zwy(:,:,:) ! <<< Add to previously computed 313 ztrdz(:,:,:) = ztrdz(:,:,:) + zwz(:,:,:) ! <<< Add to previously computed 304 IF( l_trd .OR. l_hst ) THEN ! trend diagnostics // heat/salt transport 305 ztrdx(:,:,:) = ztrdx(:,:,:) + zwx(:,:,:) ! <<< add anti-diffusive fluxes 306 ztrdy(:,:,:) = ztrdy(:,:,:) + zwy(:,:,:) ! to upstream fluxes 307 ztrdz(:,:,:) = ztrdz(:,:,:) + zwz(:,:,:) ! 308 ! 309 IF( l_trd ) THEN ! trend diagnostics 310 CALL trd_tra( kt, cdtype, jn, jptra_xad, ztrdx, pun, ptn(:,:,:,jn) ) 311 CALL trd_tra( kt, cdtype, jn, jptra_yad, ztrdy, pvn, ptn(:,:,:,jn) ) 312 CALL trd_tra( kt, cdtype, jn, jptra_zad, ztrdz, pwn, ptn(:,:,:,jn) ) 313 ENDIF 314 ! ! heat/salt transport 315 IF( l_hst ) CALL dia_ar5_hst( jn, 'adv', ztrdx(:,:,:), ztrdy(:,:,:) ) 316 ! 317 DEALLOCATE( ztrdx, ztrdy, ztrdz ) 314 318 ENDIF 315 ! 316 IF( l_trd ) THEN 317 CALL trd_tra( kt, cdtype, jn, jptra_xad, ztrdx, pun, ptn(:,:,:,jn) ) 318 CALL trd_tra( kt, cdtype, jn, jptra_yad, ztrdy, pvn, ptn(:,:,:,jn) ) 319 CALL trd_tra( kt, cdtype, jn, jptra_zad, ztrdz, pwn, ptn(:,:,:,jn) ) 320 ! 321 END IF 322 ! ! heat/salt transport 323 IF( l_hst ) CALL dia_ar5_hst( jn, 'adv', ztrdx(:,:,:), ztrdy(:,:,:) ) 324 325 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 326 IF( l_ptr ) THEN 327 zptry(:,:,:) = zptry(:,:,:) + zwy(:,:,:) ! <<< Add to previously computed 319 IF( l_ptr ) THEN ! "Poleward" transports 320 zptry(:,:,:) = zptry(:,:,:) + zwy(:,:,:) ! <<< add anti-diffusive fluxes 328 321 CALL dia_ptr_hst( jn, 'adv', zptry(:,:,:) ) 322 DEALLOCATE( zptry ) 329 323 ENDIF 330 324 ! 331 325 END DO ! end of tracer loop 332 326 ! 333 CALL wrk_dealloc( jpi,jpj,jpk, zwi, zwx, zwy, zwz, ztu, ztv, zltu, zltv, ztw ) 334 IF( l_trd .OR. l_hst ) CALL wrk_dealloc( jpi, jpj, jpk, ztrdx, ztrdy, ztrdz ) 335 IF( l_ptr ) CALL wrk_dealloc( jpi, jpj, jpk, zptry ) 336 ! 337 IF( nn_timing == 1 ) CALL timing_stop('tra_adv_fct') 327 IF( ln_timing ) CALL timing_stop('tra_adv_fct') 338 328 ! 339 329 END SUBROUTINE tra_adv_fct 340 341 342 SUBROUTINE tra_adv_fct_zts( kt, kit000, cdtype, p2dt, pun, pvn, pwn, &343 & ptb, ptn, pta, kjpt, kn_fct_zts )344 !!----------------------------------------------------------------------345 !! *** ROUTINE tra_adv_fct_zts ***346 !!347 !! ** Purpose : Compute the now trend due to total advection of348 !! tracers and add it to the general trend of tracer equations349 !!350 !! ** Method : TVD ZTS scheme, i.e. 2nd order centered scheme with351 !! corrected flux (monotonic correction). This version use sub-352 !! timestepping for the vertical advection which increases stability353 !! when vertical metrics are small.354 !! note: - this advection scheme needs a leap-frog time scheme355 !!356 !! ** Action : - update (pta) with the now advective tracer trends357 !! - save the trends358 !!----------------------------------------------------------------------359 INTEGER , INTENT(in ) :: kt ! ocean time-step index360 INTEGER , INTENT(in ) :: kit000 ! first time step index361 CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator)362 INTEGER , INTENT(in ) :: kjpt ! number of tracers363 INTEGER , INTENT(in ) :: kn_fct_zts ! number of number of vertical sub-timesteps364 REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step365 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pun, pvn, pwn ! 3 ocean velocity components366 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb, ptn ! before and now tracer fields367 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend368 !369 REAL(wp), DIMENSION( jpk ) :: zts ! length of sub-timestep for vertical advection370 REAL(wp) :: zr_p2dt ! reciprocal of tracer timestep371 INTEGER :: ji, jj, jk, jl, jn ! dummy loop indices372 INTEGER :: jtb, jtn, jta ! sub timestep pointers for leap-frog/euler forward steps373 INTEGER :: jtaken ! toggle for collecting appropriate fluxes from sub timesteps374 REAL(wp) :: z_rzts ! Fractional length of Euler forward sub-timestep for vertical advection375 REAL(wp) :: ztra ! local scalar376 REAL(wp) :: zfp_ui, zfp_vj, zfp_wk ! - -377 REAL(wp) :: zfm_ui, zfm_vj, zfm_wk ! - -378 REAL(wp), POINTER, DIMENSION(:,: ) :: zwx_sav , zwy_sav379 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwi, zwx, zwy, zwz, zhdiv, zwzts, zwz_sav380 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdx, ztrdy, ztrdz381 REAL(wp), POINTER, DIMENSION(:,:,:) :: zptry382 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztrs383 !!----------------------------------------------------------------------384 !385 IF( nn_timing == 1 ) CALL timing_start('tra_adv_fct_zts')386 !387 CALL wrk_alloc( jpi,jpj, zwx_sav, zwy_sav )388 CALL wrk_alloc( jpi,jpj,jpk, zwx, zwy, zwz, zwi, zhdiv, zwzts, zwz_sav )389 CALL wrk_alloc( jpi,jpj,jpk,kjpt+1, ztrs )390 !391 IF( kt == kit000 ) THEN392 IF(lwp) WRITE(numout,*)393 IF(lwp) WRITE(numout,*) 'tra_adv_fct_zts : 2nd order FCT scheme with ', kn_fct_zts, ' vertical sub-timestep on ', cdtype394 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~'395 ENDIF396 !397 l_trd = .FALSE.398 l_hst = .FALSE.399 l_ptr = .FALSE.400 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE.401 IF( cdtype == 'TRA' .AND. ln_diaptr ) l_ptr = .TRUE.402 IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. &403 & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE.404 !405 IF( l_trd .OR. l_hst ) THEN406 CALL wrk_alloc( jpi,jpj,jpk, ztrdx, ztrdy, ztrdz )407 ztrdx(:,:,:) = 0._wp ; ztrdy(:,:,:) = 0._wp ; ztrdz(:,:,:) = 0._wp408 ENDIF409 !410 IF( l_ptr ) THEN411 CALL wrk_alloc( jpi, jpj,jpk, zptry )412 zptry(:,:,:) = 0._wp413 ENDIF414 zwi(:,:,:) = 0._wp415 z_rzts = 1._wp / REAL( kn_fct_zts, wp )416 zr_p2dt = 1._wp / p2dt417 !418 ! surface & Bottom value : flux set to zero for all tracers419 zwz(:,:, 1 ) = 0._wp420 zwx(:,:,jpk) = 0._wp ; zwz(:,:,jpk) = 0._wp421 zwy(:,:,jpk) = 0._wp ; zwi(:,:,jpk) = 0._wp422 !423 ! ! ===========424 DO jn = 1, kjpt ! tracer loop425 ! ! ===========426 !427 ! Upstream advection with initial mass fluxes & intermediate update428 DO jk = 1, jpkm1 ! upstream tracer flux in the i and j direction429 DO jj = 1, jpjm1430 DO ji = 1, fs_jpim1 ! vector opt.431 ! upstream scheme432 zfp_ui = pun(ji,jj,jk) + ABS( pun(ji,jj,jk) )433 zfm_ui = pun(ji,jj,jk) - ABS( pun(ji,jj,jk) )434 zfp_vj = pvn(ji,jj,jk) + ABS( pvn(ji,jj,jk) )435 zfm_vj = pvn(ji,jj,jk) - ABS( pvn(ji,jj,jk) )436 zwx(ji,jj,jk) = 0.5_wp * ( zfp_ui * ptb(ji,jj,jk,jn) + zfm_ui * ptb(ji+1,jj ,jk,jn) )437 zwy(ji,jj,jk) = 0.5_wp * ( zfp_vj * ptb(ji,jj,jk,jn) + zfm_vj * ptb(ji ,jj+1,jk,jn) )438 END DO439 END DO440 END DO441 ! ! upstream tracer flux in the k direction442 DO jk = 2, jpkm1 ! Interior value443 DO jj = 1, jpj444 DO ji = 1, jpi445 zfp_wk = pwn(ji,jj,jk) + ABS( pwn(ji,jj,jk) )446 zfm_wk = pwn(ji,jj,jk) - ABS( pwn(ji,jj,jk) )447 zwz(ji,jj,jk) = 0.5_wp * ( zfp_wk * ptb(ji,jj,jk,jn) + zfm_wk * ptb(ji,jj,jk-1,jn) ) * wmask(ji,jj,jk)448 END DO449 END DO450 END DO451 IF( ln_linssh ) THEN ! top value : linear free surface case only (as zwz is multiplied by wmask)452 IF( ln_isfcav ) THEN ! ice-shelf cavities: top value453 DO jj = 1, jpj454 DO ji = 1, jpi455 zwz(ji,jj, mikt(ji,jj) ) = pwn(ji,jj,mikt(ji,jj)) * ptb(ji,jj,mikt(ji,jj),jn)456 END DO457 END DO458 ELSE ! no cavities, surface value459 zwz(:,:,1) = pwn(:,:,1) * ptb(:,:,1,jn)460 ENDIF461 ENDIF462 !463 DO jk = 1, jpkm1 ! total advective trend464 DO jj = 2, jpjm1465 DO ji = fs_2, fs_jpim1 ! vector opt.466 ! ! total intermediate advective trends467 ztra = - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) &468 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) &469 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) * r1_e1e2t(ji,jj)470 ! ! update and guess with monotonic sheme471 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra / e3t_n(ji,jj,jk) * tmask(ji,jj,jk)472 zwi(ji,jj,jk) = ( e3t_b(ji,jj,jk) * ptb(ji,jj,jk,jn) + p2dt * ztra ) / e3t_a(ji,jj,jk) * tmask(ji,jj,jk)473 END DO474 END DO475 END DO476 !477 CALL lbc_lnk( zwi, 'T', 1. ) ! Lateral boundary conditions on zwi (unchanged sign)478 !479 IF( l_trd .OR. l_hst ) THEN ! trend diagnostics (contribution of upstream fluxes)480 ztrdx(:,:,:) = zwx(:,:,:) ; ztrdy(:,:,:) = zwy(:,:,:) ; ztrdz(:,:,:) = zwz(:,:,:)481 END IF482 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes)483 IF( l_ptr ) zptry(:,:,:) = zwy(:,:,:)484 485 ! 3. anti-diffusive flux : high order minus low order486 ! ---------------------------------------------------487 488 DO jk = 1, jpkm1 !* horizontal anti-diffusive fluxes489 !490 DO jj = 1, jpjm1491 DO ji = 1, fs_jpim1 ! vector opt.492 zwx_sav(ji,jj) = zwx(ji,jj,jk)493 zwy_sav(ji,jj) = zwy(ji,jj,jk)494 !495 zwx(ji,jj,jk) = 0.5_wp * pun(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji+1,jj,jk,jn) )496 zwy(ji,jj,jk) = 0.5_wp * pvn(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji,jj+1,jk,jn) )497 END DO498 END DO499 !500 DO jj = 2, jpjm1 ! partial horizontal divergence501 DO ji = fs_2, fs_jpim1502 zhdiv(ji,jj,jk) = ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk) &503 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk) )504 END DO505 END DO506 !507 DO jj = 1, jpjm1508 DO ji = 1, fs_jpim1 ! vector opt.509 zwx(ji,jj,jk) = zwx(ji,jj,jk) - zwx_sav(ji,jj)510 zwy(ji,jj,jk) = zwy(ji,jj,jk) - zwy_sav(ji,jj)511 END DO512 END DO513 END DO514 !515 ! !* vertical anti-diffusive flux516 zwz_sav(:,:,:) = zwz(:,:,:)517 ztrs (:,:,:,1) = ptb(:,:,:,jn)518 ztrs (:,:,1,2) = ptb(:,:,1,jn)519 ztrs (:,:,1,3) = ptb(:,:,1,jn)520 zwzts (:,:,:) = 0._wp521 !522 DO jl = 1, kn_fct_zts ! Start of sub timestepping loop523 !524 IF( jl == 1 ) THEN ! Euler forward to kick things off525 jtb = 1 ; jtn = 1 ; jta = 2526 zts(:) = p2dt * z_rzts527 jtaken = MOD( kn_fct_zts + 1 , 2) ! Toggle to collect every second flux528 ! ! starting at jl =1 if kn_fct_zts is odd;529 ! ! starting at jl =2 otherwise530 ELSEIF( jl == 2 ) THEN ! First leapfrog step531 jtb = 1 ; jtn = 2 ; jta = 3532 zts(:) = 2._wp * p2dt * z_rzts533 ELSE ! Shuffle pointers for subsequent leapfrog steps534 jtb = MOD(jtb,3) + 1535 jtn = MOD(jtn,3) + 1536 jta = MOD(jta,3) + 1537 ENDIF538 DO jk = 2, jpkm1 ! interior value539 DO jj = 2, jpjm1540 DO ji = fs_2, fs_jpim1541 zwz(ji,jj,jk) = 0.5_wp * pwn(ji,jj,jk) * ( ztrs(ji,jj,jk,jtn) + ztrs(ji,jj,jk-1,jtn) ) * wmask(ji,jj,jk)542 IF( jtaken == 0 ) zwzts(ji,jj,jk) = zwzts(ji,jj,jk) + zwz(ji,jj,jk) * zts(jk) ! Accumulate time-weighted vertcal flux543 END DO544 END DO545 END DO546 IF( ln_linssh ) THEN ! top value (only in linear free surface case)547 IF( ln_isfcav ) THEN ! ice-shelf cavities548 DO jj = 1, jpj549 DO ji = 1, jpi550 zwz(ji,jj, mikt(ji,jj) ) = pwn(ji,jj,mikt(ji,jj)) * ptb(ji,jj,mikt(ji,jj),jn) ! linear free surface551 END DO552 END DO553 ELSE ! no ocean cavities554 zwz(:,:,1) = pwn(:,:,1) * ptb(:,:,1,jn)555 ENDIF556 ENDIF557 !558 jtaken = MOD( jtaken + 1 , 2 )559 !560 DO jk = 2, jpkm1 ! total advective trends561 DO jj = 2, jpjm1562 DO ji = fs_2, fs_jpim1563 ztrs(ji,jj,jk,jta) = ztrs(ji,jj,jk,jtb) &564 & - zts(jk) * ( zhdiv(ji,jj,jk) + zwz(ji,jj,jk) - zwz(ji,jj,jk+1) ) &565 & * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk)566 END DO567 END DO568 END DO569 !570 END DO571 572 DO jk = 2, jpkm1 ! Anti-diffusive vertical flux using average flux from the sub-timestepping573 DO jj = 2, jpjm1574 DO ji = fs_2, fs_jpim1575 zwz(ji,jj,jk) = ( zwzts(ji,jj,jk) * zr_p2dt - zwz_sav(ji,jj,jk) ) * wmask(ji,jj,jk)576 END DO577 END DO578 END DO579 CALL lbc_lnk( zwx, 'U', -1. ) ; CALL lbc_lnk( zwy, 'V', -1. ) ! Lateral bondary conditions580 CALL lbc_lnk( zwz, 'W', 1. )581 582 ! 4. monotonicity algorithm583 ! -------------------------584 CALL nonosc( ptb(:,:,:,jn), zwx, zwy, zwz, zwi, p2dt )585 586 587 ! 5. final trend with corrected fluxes588 ! ------------------------------------589 DO jk = 1, jpkm1590 DO jj = 2, jpjm1591 DO ji = fs_2, fs_jpim1 ! vector opt.592 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ( zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) &593 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) &594 & * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk)595 END DO596 END DO597 END DO598 599 !600 IF( l_trd .OR. l_hst ) THEN ! trend diagnostics (contribution of upstream fluxes)601 ztrdx(:,:,:) = ztrdx(:,:,:) + zwx(:,:,:) ! <<< Add to previously computed602 ztrdy(:,:,:) = ztrdy(:,:,:) + zwy(:,:,:) ! <<< Add to previously computed603 ztrdz(:,:,:) = ztrdz(:,:,:) + zwz(:,:,:) ! <<< Add to previously computed604 ENDIF605 !606 IF( l_trd ) THEN607 CALL trd_tra( kt, cdtype, jn, jptra_xad, ztrdx, pun, ptn(:,:,:,jn) )608 CALL trd_tra( kt, cdtype, jn, jptra_yad, ztrdy, pvn, ptn(:,:,:,jn) )609 CALL trd_tra( kt, cdtype, jn, jptra_zad, ztrdz, pwn, ptn(:,:,:,jn) )610 !611 END IF612 ! ! heat/salt transport613 IF( l_hst ) CALL dia_ar5_hst( jn, 'adv', ztrdx(:,:,:), ztrdy(:,:,:) )614 615 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes)616 IF( l_ptr ) THEN617 zptry(:,:,:) = zptry(:,:,:) + zwy(:,:,:) ! <<< Add to previously computed618 CALL dia_ptr_hst( jn, 'adv', zptry(:,:,:) )619 ENDIF620 !621 END DO622 !623 CALL wrk_alloc( jpi,jpj, zwx_sav, zwy_sav )624 CALL wrk_alloc( jpi,jpj, jpk, zwx, zwy, zwz, zwi, zhdiv, zwzts, zwz_sav )625 CALL wrk_alloc( jpi,jpj,jpk,kjpt+1, ztrs )626 IF( l_trd .OR. l_hst ) CALL wrk_dealloc( jpi, jpj, jpk, ztrdx, ztrdy, ztrdz )627 IF( l_ptr ) CALL wrk_dealloc( jpi, jpj, jpk, zptry )628 !629 IF( nn_timing == 1 ) CALL timing_stop('tra_adv_fct_zts')630 !631 END SUBROUTINE tra_adv_fct_zts632 330 633 331 … … 653 351 REAL(wp) :: zpos, zneg, zbt, za, zb, zc, zbig, zrtrn ! local scalars 654 352 REAL(wp) :: zau, zbu, zcu, zav, zbv, zcv, zup, zdo ! - - 655 REAL(wp), POINTER, DIMENSION(:,:,:) :: zbetup, zbetdo, zbup, zbdo 656 !!---------------------------------------------------------------------- 657 ! 658 IF( nn_timing == 1 ) CALL timing_start('nonosc') 659 ! 660 CALL wrk_alloc( jpi, jpj, jpk, zbetup, zbetdo, zbup, zbdo ) 353 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zbetup, zbetdo, zbup, zbdo 354 !!---------------------------------------------------------------------- 355 ! 356 IF( ln_timing ) CALL timing_start('nonosc') 661 357 ! 662 358 zbig = 1.e+40_wp … … 734 430 CALL lbc_lnk( paa, 'U', -1. ) ; CALL lbc_lnk( pbb, 'V', -1. ) ! lateral boundary condition (changed sign) 735 431 ! 736 CALL wrk_dealloc( jpi, jpj, jpk, zbetup, zbetdo, zbup, zbdo ) 737 ! 738 IF( nn_timing == 1 ) CALL timing_stop('nonosc') 432 IF( ln_timing ) CALL timing_stop('nonosc') 739 433 ! 740 434 END SUBROUTINE nonosc -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_mle.F90
r7753 r8568 15 15 USE phycst ! physical constant 16 16 USE zdfmxl ! mixed layer depth 17 ! 17 18 USE lbclnk ! lateral boundary condition / mpp link 18 19 USE in_out_manager ! I/O manager 19 20 USE iom ! IOM library 20 21 USE lib_mpp ! MPP library 21 USE wrk_nemo ! work arrays22 22 USE timing ! Timing 23 23 … … 86 86 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pw ! increased by the MLE induced transport 87 87 ! 88 INTEGER :: ji, jj, jk ! dummy loop indices 89 INTEGER :: ikmax ! temporary integer 90 REAL(wp) :: zcuw, zmuw ! local scalar 91 REAL(wp) :: zcvw, zmvw ! - - 92 REAL(wp) :: zc ! - - 93 ! 94 INTEGER :: ii, ij, ik ! local integers 95 INTEGER, DIMENSION(3) :: ilocu ! 96 INTEGER, DIMENSION(2) :: ilocs ! 97 REAL(wp), POINTER, DIMENSION(:,: ) :: zpsim_u, zpsim_v, zmld, zbm, zhu, zhv, zn2, zLf_NH, zLf_MH 98 REAL(wp), POINTER, DIMENSION(:,:,:) :: zpsi_uw, zpsi_vw 99 INTEGER, POINTER, DIMENSION(:,:) :: inml_mle 100 !!---------------------------------------------------------------------- 101 ! 102 IF( nn_timing == 1 ) CALL timing_start('tra_adv_mle') 103 CALL wrk_alloc( jpi, jpj, zpsim_u, zpsim_v, zmld, zbm, zhu, zhv, zn2, zLf_NH, zLf_MH) 104 CALL wrk_alloc( jpi, jpj, jpk, zpsi_uw, zpsi_vw) 105 CALL wrk_alloc( jpi, jpj, inml_mle) 88 INTEGER :: ji, jj, jk ! dummy loop indices 89 INTEGER :: ii, ij, ik, ikmax ! local integers 90 REAL(wp) :: zcuw, zmuw, zc ! local scalar 91 REAL(wp) :: zcvw, zmvw ! - - 92 INTEGER , DIMENSION(jpi,jpj) :: inml_mle 93 REAL(wp), DIMENSION(jpi,jpj) :: zpsim_u, zpsim_v, zmld, zbm, zhu, zhv, zn2, zLf_NH, zLf_MH 94 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zpsi_uw, zpsi_vw 95 !!---------------------------------------------------------------------- 96 ! 97 IF( ln_timing ) CALL timing_start('tra_adv_mle') 106 98 ! 107 99 ! !== MLD used for MLE ==! … … 256 248 CALL iom_put( "psiv_mle", zpsi_vw ) ! j-mle streamfunction 257 249 ENDIF 258 CALL wrk_dealloc( jpi, jpj, zpsim_u, zpsim_v, zmld, zbm, zhu, zhv, zn2, zLf_NH, zLf_MH) 259 CALL wrk_dealloc( jpi, jpj, jpk, zpsi_uw, zpsi_vw) 260 CALL wrk_dealloc( jpi, jpj, inml_mle) 261 262 IF( nn_timing == 1 ) CALL timing_stop('tra_adv_mle') 250 ! 251 IF( ln_timing ) CALL timing_stop('tra_adv_mle') 263 252 ! 264 253 END SUBROUTINE tra_adv_mle -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_mus.F90
r7753 r8568 26 26 27 27 ! 28 USE iom 29 USE wrk_nemo ! Memory Allocation 28 USE iom ! XIOS library 30 29 USE timing ! Timing 31 30 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) … … 85 84 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend 86 85 ! 87 INTEGER :: ji, jj, jk, jn ! dummy loop indices 88 INTEGER :: ierr ! local integer 89 REAL(wp) :: zu, z0u, zzwx, zw ! local scalars 90 REAL(wp) :: zv, z0v, zzwy, z0w ! - - 91 REAL(wp) :: zalpha ! - - 92 REAL(wp), POINTER, DIMENSION(:,:,:) :: zslpx, zslpy ! 3D workspace 93 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwx , zwy ! - - 86 INTEGER :: ji, jj, jk, jn ! dummy loop indices 87 INTEGER :: ierr ! local integer 88 REAL(wp) :: zu, z0u, zzwx, zw , zalpha ! local scalars 89 REAL(wp) :: zv, z0v, zzwy, z0w ! - - 90 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwx, zslpx ! 3D workspace 91 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwy, zslpy ! - - 94 92 !!---------------------------------------------------------------------- 95 93 ! 96 IF( nn_timing == 1 ) CALL timing_start('tra_adv_mus') 97 ! 98 CALL wrk_alloc( jpi,jpj,jpk, zslpx, zslpy, zwx, zwy ) 94 IF( ln_timing ) CALL timing_start('tra_adv_mus') 99 95 ! 100 96 IF( kt == kit000 ) THEN … … 279 275 END DO ! end of tracer loop 280 276 ! 281 CALL wrk_dealloc( jpi,jpj,jpk, zslpx, zslpy, zwx, zwy ) 282 ! 283 IF( nn_timing == 1 ) CALL timing_stop('tra_adv_mus') 277 IF( ln_timing ) CALL timing_stop('tra_adv_mus') 284 278 ! 285 279 END SUBROUTINE tra_adv_mus -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_qck.F90
r7646 r8568 25 25 USE lbclnk ! ocean lateral boundary condition (or mpp link) 26 26 USE in_out_manager ! I/O manager 27 USE wrk_nemo ! Memory Allocation28 27 USE timing ! Timing 29 28 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) … … 43 42 # include "vectopt_loop_substitute.h90" 44 43 !!---------------------------------------------------------------------- 45 !! NEMO/OPA 3.3 , NEMO Consortium (2010)44 !! NEMO/OPA 4.0 , NEMO Consortium (2017) 46 45 !! $Id$ 47 46 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 96 95 !!---------------------------------------------------------------------- 97 96 ! 98 IF( nn_timing == 1 )CALL timing_start('tra_adv_qck')97 IF( ln_timing ) CALL timing_start('tra_adv_qck') 99 98 ! 100 99 IF( kt == kit000 ) THEN … … 118 117 CALL tra_adv_cen2_k( kt, cdtype, pwn, ptn, pta, kjpt ) 119 118 ! 120 IF( nn_timing == 1 )CALL timing_stop('tra_adv_qck')119 IF( ln_timing ) CALL timing_stop('tra_adv_qck') 121 120 ! 122 121 END SUBROUTINE tra_adv_qck … … 138 137 INTEGER :: ji, jj, jk, jn ! dummy loop indices 139 138 REAL(wp) :: ztra, zbtr, zdir, zdx, zmsk ! local scalars 140 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwx, zfu, zfc, zfd139 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwx, zfu, zfc, zfd 141 140 !---------------------------------------------------------------------- 142 141 ! 143 CALL wrk_alloc( jpi, jpj, jpk, zwx, zfu, zfc, zfd )144 142 ! ! =========== 145 143 DO jn = 1, kjpt ! tracer loop … … 230 228 END DO 231 229 ! ! trend diagnostics 232 IF( l_trd ) 230 IF( l_trd ) CALL trd_tra( kt, cdtype, jn, jptra_xad, zwx, pun, ptn(:,:,:,jn) ) 233 231 ! 234 232 END DO 235 !236 CALL wrk_dealloc( jpi, jpj, jpk, zwx, zfu, zfc, zfd )237 233 ! 238 234 END SUBROUTINE tra_adv_qck_i … … 252 248 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend 253 249 !! 254 INTEGER :: ji, jj, jk, jn ! dummy loop indices250 INTEGER :: ji, jj, jk, jn ! dummy loop indices 255 251 REAL(wp) :: ztra, zbtr, zdir, zdx, zmsk ! local scalars 256 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwy, zfu, zfc, zfd252 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwy, zfu, zfc, zfd ! 3D workspace 257 253 !---------------------------------------------------------------------- 258 !259 CALL wrk_alloc( jpi, jpj, jpk, zwy, zfu, zfc, zfd )260 254 ! 261 255 ! ! =========== … … 320 314 END DO 321 315 END DO 322 !--- Lateral boundary conditions 323 CALL lbc_lnk( zfu(:,:,:), 'T', 1. ) 316 CALL lbc_lnk( zfu(:,:,:), 'T', 1. ) !--- Lateral boundary conditions 324 317 ! 325 318 ! Tracer flux on the x-direction … … 359 352 END DO 360 353 ! 361 CALL wrk_dealloc( jpi, jpj, jpk, zwy, zfu, zfc, zfd )362 !363 354 END SUBROUTINE tra_adv_qck_j 364 355 … … 377 368 ! 378 369 INTEGER :: ji, jj, jk, jn ! dummy loop indices 379 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwz 380 !!---------------------------------------------------------------------- 381 ! 382 CALL wrk_alloc( jpi,jpj,jpk, zwz ) 370 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwz ! 3D workspace 371 !!---------------------------------------------------------------------- 383 372 ! 384 373 zwz(:,:, 1 ) = 0._wp ! surface & bottom values set to zero for all tracers … … 421 410 END DO 422 411 ! 423 CALL wrk_dealloc( jpi,jpj,jpk, zwz )424 !425 412 END SUBROUTINE tra_adv_cen2_k 426 413 … … 443 430 !---------------------------------------------------------------------- 444 431 ! 445 IF( nn_timing == 1 )CALL timing_start('quickest')432 IF( ln_timing ) CALL timing_start('quickest') 446 433 ! 447 434 DO jk = 1, jpkm1 … … 475 462 END DO 476 463 ! 477 IF( nn_timing == 1 )CALL timing_stop('quickest')464 IF( ln_timing ) CALL timing_stop('quickest') 478 465 ! 479 466 END SUBROUTINE quickest -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_ubs.F90
r7646 r8568 22 22 23 23 ! 24 USE iom 25 USE lib_mpp ! I/Olibrary24 USE iom ! XIOS library 25 USE lib_mpp ! massively parallel library 26 26 USE lbclnk ! ocean lateral boundary condition (or mpp link) 27 27 USE in_out_manager ! I/O manager 28 USE wrk_nemo ! Memory Allocation29 28 USE timing ! Timing 30 29 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) … … 101 100 REAL(wp) :: zfp_ui, zfm_ui, zcenut, ztak, zfp_wk, zfm_wk ! - - 102 101 REAL(wp) :: zfp_vj, zfm_vj, zcenvt, zeeu, zeev, z_hdivn ! - - 103 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztu, ztv, zltu, zltv, zti, ztw 104 !!---------------------------------------------------------------------- 105 ! 106 IF( nn_timing == 1 ) CALL timing_start('tra_adv_ubs') 107 ! 108 CALL wrk_alloc( jpi,jpj,jpk, ztu, ztv, zltu, zltv, zti, ztw ) 102 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztu, ztv, zltu, zltv, zti, ztw ! 3D workspace 103 !!---------------------------------------------------------------------- 104 ! 105 IF( ln_timing ) CALL timing_start('tra_adv_ubs') 109 106 ! 110 107 IF( kt == kit000 ) THEN … … 285 282 END DO 286 283 ! 287 CALL wrk_dealloc( jpi,jpj,jpk, ztu, ztv, zltu, zltv, zti, ztw ) 288 ! 289 IF( nn_timing == 1 ) CALL timing_stop('tra_adv_ubs') 284 IF( ln_timing ) CALL timing_stop('tra_adv_ubs') 290 285 ! 291 286 END SUBROUTINE tra_adv_ubs … … 313 308 INTEGER :: ikm1 ! local integer 314 309 REAL(wp) :: zpos, zneg, zbt, za, zb, zc, zbig, zrtrn ! local scalars 315 REAL(wp), POINTER, DIMENSION(:,:,:) :: zbetup, zbetdo 316 !!---------------------------------------------------------------------- 317 ! 318 IF( nn_timing == 1 ) CALL timing_start('nonosc_z') 319 ! 320 CALL wrk_alloc( jpi,jpj,jpk, zbetup, zbetdo ) 310 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zbetup, zbetdo ! 3D workspace 311 !!---------------------------------------------------------------------- 312 ! 313 IF( ln_timing ) CALL timing_start('nonosc_z') 321 314 ! 322 315 zbig = 1.e+40_wp … … 387 380 END DO 388 381 ! 389 CALL wrk_dealloc( jpi,jpj,jpk, zbetup, zbetdo ) 390 ! 391 IF( nn_timing == 1 ) CALL timing_stop('nonosc_z') 382 IF( ln_timing ) CALL timing_stop('nonosc_z') 392 383 ! 393 384 END SUBROUTINE nonosc_z -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/TRA/trabbc.F90
r7753 r8568 27 27 USE lib_mpp ! distributed memory computing library 28 28 USE prtctl ! Print control 29 USE wrk_nemo ! Memory Allocation30 29 USE timing ! Timing 31 30 … … 77 76 ! 78 77 INTEGER :: ji, jj ! dummy loop indices 79 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdt78 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt ! 3D workspace 80 79 !!---------------------------------------------------------------------- 81 80 ! 82 IF( nn_timing == 1 )CALL timing_start('tra_bbc')81 IF( ln_timing ) CALL timing_start('tra_bbc') 83 82 ! 84 83 IF( l_trdtra ) THEN ! Save the input temperature trend 85 CALL wrk_alloc( jpi,jpj,jpk, ztrdt)84 ALLOCATE( ztrdt(jpi,jpj,jpk) ) 86 85 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 87 86 ENDIF … … 98 97 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 99 98 CALL trd_tra( kt, 'TRA', jp_tem, jptra_bbc, ztrdt ) 100 CALL wrk_dealloc( jpi,jpj,jpk,ztrdt )99 DEALLOCATE( ztrdt ) 101 100 ENDIF 102 101 ! 103 102 IF(ln_ctl) CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' bbc - Ta: ', mask1=tmask, clinfo3='tra-ta' ) 104 103 ! 105 IF( nn_timing == 1 )CALL timing_stop('tra_bbc')104 IF( ln_timing ) CALL timing_stop('tra_bbc') 106 105 ! 107 106 END SUBROUTINE tra_bbc … … 130 129 TYPE(FLD_N) :: sn_qgh ! informations about the geotherm. field to be read 131 130 CHARACTER(len=256) :: cn_dir ! Root directory for location of ssr files 132 ! 131 !! 133 132 NAMELIST/nambbc/ln_trabbc, nn_geoflx, rn_geoflx_cst, sn_qgh, cn_dir 134 133 !!---------------------------------------------------------------------- -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/TRA/trabbl.F90
r8215 r8568 35 35 USE lbclnk ! ocean lateral boundary conditions 36 36 USE prtctl ! Print control 37 USE wrk_nemo ! Memory Allocation38 37 USE timing ! Timing 39 38 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) … … 104 103 INTEGER, INTENT( in ) :: kt ! ocean time-step 105 104 ! 106 REAL(wp), POINTER, DIMENSION(:,:,:) ::ztrdt, ztrds107 !!---------------------------------------------------------------------- 108 ! 109 IF( nn_timing == 1 )CALL timing_start( 'tra_bbl')105 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds 106 !!---------------------------------------------------------------------- 107 ! 108 IF( ln_timing ) CALL timing_start( 'tra_bbl') 110 109 ! 111 110 IF( l_trdtra ) THEN !* Save the T-S input trends 112 CALL wrk_alloc( jpi, jpj, jpk, ztrdt, ztrds)111 ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) 113 112 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 114 113 ztrds(:,:,:) = tsa(:,:,:,jp_sal) … … 148 147 CALL trd_tra( kt, 'TRA', jp_tem, jptra_bbl, ztrdt ) 149 148 CALL trd_tra( kt, 'TRA', jp_sal, jptra_bbl, ztrds ) 150 CALL wrk_dealloc( jpi, jpj, jpk,ztrdt, ztrds )151 ENDIF 152 ! 153 IF( nn_timing == 1) CALL timing_stop( 'tra_bbl')149 DEALLOCATE( ztrdt, ztrds ) 150 ENDIF 151 ! 152 IF( ln_timing ) CALL timing_stop( 'tra_bbl') 154 153 ! 155 154 END SUBROUTINE tra_bbl … … 184 183 INTEGER :: ik ! local integers 185 184 REAL(wp) :: zbtr ! local scalars 186 REAL(wp), POINTER, DIMENSION(:,:) :: zptb 187 !!---------------------------------------------------------------------- 188 ! 189 IF( nn_timing == 1 ) CALL timing_start('tra_bbl_dif') 190 ! 191 CALL wrk_alloc( jpi, jpj, zptb ) 185 REAL(wp), DIMENSION(jpi,jpj) :: zptb ! workspace 186 !!---------------------------------------------------------------------- 187 ! 188 IF( ln_timing ) CALL timing_start('tra_bbl_dif') 192 189 ! 193 190 DO jn = 1, kjpt ! tracer loop … … 214 211 END DO ! end tracer 215 212 ! ! =========== 216 CALL wrk_dealloc( jpi, jpj, zptb ) 217 ! 218 IF( nn_timing == 1 ) CALL timing_stop('tra_bbl_dif') 213 ! 214 IF( ln_timing ) CALL timing_stop('tra_bbl_dif') 219 215 ! 220 216 END SUBROUTINE tra_bbl_dif … … 247 243 !!---------------------------------------------------------------------- 248 244 ! 249 IF( nn_timing == 1 )CALL timing_start( 'tra_bbl_adv')245 IF( ln_timing ) CALL timing_start( 'tra_bbl_adv') 250 246 ! ! =========== 251 247 DO jn = 1, kjpt ! tracer loop … … 303 299 ! ! =========== 304 300 ! 305 IF( nn_timing == 1 )CALL timing_stop( 'tra_bbl_adv')301 IF( ln_timing ) CALL timing_stop( 'tra_bbl_adv') 306 302 ! 307 303 END SUBROUTINE tra_bbl_adv … … 348 344 !!---------------------------------------------------------------------- 349 345 ! 350 IF( nn_timing == 1 )CALL timing_start( 'bbl')346 IF( ln_timing ) CALL timing_start( 'bbl') 351 347 ! 352 348 IF( kt == kit000 ) THEN … … 479 475 ENDIF 480 476 ! 481 IF( nn_timing == 1 )CALL timing_stop( 'bbl')477 IF( ln_timing ) CALL timing_stop( 'bbl') 482 478 ! 483 479 END SUBROUTINE bbl … … 493 489 !! called by nemo_init at the first timestep (kit000) 494 490 !!---------------------------------------------------------------------- 495 INTEGER :: ji, jj ! dummy loop indices 496 INTEGER :: ii0, ii1, ij0, ij1 ! local integer 497 INTEGER :: ios ! - - 498 REAL(wp), POINTER, DIMENSION(:,:) :: zmbk 491 INTEGER :: ji, jj ! dummy loop indices 492 INTEGER :: ii0, ii1, ij0, ij1, ios ! local integer 493 REAL(wp), DIMENSION(jpi,jpj) :: zmbk ! workspace 499 494 !! 500 495 NAMELIST/nambbl/ ln_trabbl, nn_bbl_ldf, nn_bbl_adv, rn_ahtbbl, rn_gambbl 501 496 !!---------------------------------------------------------------------- 502 497 ! 503 IF( nn_timing == 1 )CALL timing_start( 'tra_bbl_init')498 IF( ln_timing ) CALL timing_start( 'tra_bbl_init') 504 499 ! 505 500 REWIND( numnam_ref ) ! Namelist nambbl in reference namelist : Bottom boundary layer scheme … … 544 539 END DO 545 540 ! converte into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk 546 CALL wrk_alloc( jpi, jpj, zmbk )547 541 zmbk(:,:) = REAL( mbku_d(:,:), wp ) ; CALL lbc_lnk(zmbk,'U',1.) ; mbku_d(:,:) = MAX( INT( zmbk(:,:) ), 1 ) 548 542 zmbk(:,:) = REAL( mbkv_d(:,:), wp ) ; CALL lbc_lnk(zmbk,'V',1.) ; mbkv_d(:,:) = MAX( INT( zmbk(:,:) ), 1 ) 549 CALL wrk_dealloc( jpi, jpj, zmbk )550 543 ! 551 544 ! !* sign of grad(H) at u- and v-points … … 570 563 ahv_bbl_0(:,:) = rn_ahtbbl * e1_e2v(:,:) * e3v_bbl_0(:,:) * vmask(:,:,1) 571 564 ! 572 IF( nn_timing == 1 )CALL timing_stop( 'tra_bbl_init')565 IF( ln_timing ) CALL timing_stop( 'tra_bbl_init') 573 566 ! 574 567 END SUBROUTINE tra_bbl_init -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/TRA/tradmp.F90
r7753 r8568 33 33 ! 34 34 USE in_out_manager ! I/O manager 35 USE iom ! XIOS 35 36 USE lib_mpp ! MPP library 36 37 USE prtctl ! Print control 37 USE wrk_nemo ! Memory allocation38 38 USE timing ! Timing 39 USE iom40 39 41 40 IMPLICIT NONE … … 94 93 ! 95 94 INTEGER :: ji, jj, jk, jn ! dummy loop indices 96 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: zts_dta, ztrdts97 !!----------------------------------------------------------------------98 ! 99 IF( nn_timing == 1 ) CALL timing_start('tra_dmp')100 !101 CALL wrk_alloc( jpi,jpj,jpk,jpts, zts_dta )95 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) :: zts_dta 96 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: ztrdts 97 !!---------------------------------------------------------------------- 98 ! 99 IF( ln_timing ) CALL timing_start('tra_dmp') 100 ! 102 101 IF( l_trdtra ) THEN !* Save ta and sa trends 103 CALL wrk_alloc( jpi,jpj,jpk,jpts, ztrdts)102 ALLOCATE( ztrdts(jpi,jpj,jpk,jpts) ) 104 103 ztrdts(:,:,:,:) = tsa(:,:,:,:) 105 104 ENDIF … … 154 153 CALL trd_tra( kt, 'TRA', jp_tem, jptra_dmp, ztrdts(:,:,:,jp_tem) ) 155 154 CALL trd_tra( kt, 'TRA', jp_sal, jptra_dmp, ztrdts(:,:,:,jp_sal) ) 156 CALL wrk_dealloc( jpi,jpj,jpk,jpts,ztrdts )155 DEALLOCATE( ztrdts ) 157 156 ENDIF 158 157 ! ! Control print … … 160 159 & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 161 160 ! 162 CALL wrk_dealloc( jpi,jpj,jpk,jpts, zts_dta ) 163 ! 164 IF( nn_timing == 1 ) CALL timing_stop('tra_dmp') 161 IF( ln_timing ) CALL timing_stop('tra_dmp') 165 162 ! 166 163 END SUBROUTINE tra_dmp -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/TRA/traldf.F90
r7765 r8568 30 30 USE lib_mpp ! distribued memory computing library 31 31 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 32 USE wrk_nemo ! Memory allocation33 32 USE timing ! Timing 34 33 … … 58 57 INTEGER, INTENT( in ) :: kt ! ocean time-step index 59 58 !! 60 REAL(wp), POINTER, DIMENSION(:,:,:) ::ztrdt, ztrds61 !!---------------------------------------------------------------------- 62 ! 63 IF( nn_timing == 1) CALL timing_start('tra_ldf')59 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds 60 !!---------------------------------------------------------------------- 61 ! 62 IF( ln_timing ) CALL timing_start('tra_ldf') 64 63 ! 65 64 IF( l_trdtra ) THEN !* Save ta and sa trends 66 CALL wrk_alloc( jpi,jpj,jpk, ztrdt, ztrds)65 ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) 67 66 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 68 67 ztrds(:,:,:) = tsa(:,:,:,jp_sal) … … 85 84 CALL trd_tra( kt, 'TRA', jp_tem, jptra_ldf, ztrdt ) 86 85 CALL trd_tra( kt, 'TRA', jp_sal, jptra_ldf, ztrds ) 87 CALL wrk_dealloc( jpi,jpj,jpk,ztrdt, ztrds )86 DEALLOCATE( ztrdt, ztrds ) 88 87 ENDIF 89 88 ! !* print mean trends (used for debugging) … … 91 90 & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 92 91 ! 93 IF( nn_timing == 1) CALL timing_stop('tra_ldf')92 IF( ln_timing ) CALL timing_stop('tra_ldf') 94 93 ! 95 94 END SUBROUTINE tra_ldf … … 107 106 !!---------------------------------------------------------------------- 108 107 ! 109 IF(lwp) THEN ! Namelist print108 IF(lwp) THEN !== Namelist print ==! 110 109 WRITE(numout,*) 111 110 WRITE(numout,*) 'tra_ldf_init : lateral tracer diffusive operator' … … 114 113 WRITE(numout,*) ' see ldf_tra_init report for lateral mixing parameters' 115 114 ENDIF 116 ! ! use of lateral operator or not115 ! !== use of lateral operator or not ==! 117 116 nldf = np_ERROR 118 117 ioptio = 0 119 IF( ln_traldf_ lap ) ioptio = ioptio + 1120 IF( ln_traldf_ blp ) ioptio = ioptio + 1121 IF( ioptio > 1 ) CALL ctl_stop( 'tra_ldf_init: use ONE or NONE of the 2 lap/bilap operator type on tracer' )122 IF( ioptio == 0 ) nldf = np_no_ldf ! No lateral diffusion123 ! 124 IF( nldf /= np_no_ldf ) THEN ! direction ==>> type of operator118 IF( ln_traldf_NONE ) THEN ; nldf = np_no_ldf ; ioptio = ioptio + 1 ; ENDIF 119 IF( ln_traldf_lap ) THEN ; ioptio = ioptio + 1 ; ENDIF 120 IF( ln_traldf_blp ) THEN ; ioptio = ioptio + 1 ; ENDIF 121 IF( ioptio /= 1 ) CALL ctl_stop( 'tra_ldf_init: use ONE of the 3 operator options (NONE/lap/blp)' ) 122 ! 123 IF( .NOT.ln_traldf_NONE ) THEN !== direction ==>> type of operator ==! 125 124 ioptio = 0 126 125 IF( ln_traldf_lev ) ioptio = ioptio + 1 127 126 IF( ln_traldf_hor ) ioptio = ioptio + 1 128 127 IF( ln_traldf_iso ) ioptio = ioptio + 1 129 IF( ioptio > 1 ) CALL ctl_stop( 'tra_ldf_init: use onlyONE direction (level/hor/iso)' )128 IF( ioptio /= 1 ) CALL ctl_stop( 'tra_ldf_init: use ONE direction (level/hor/iso)' ) 130 129 ! 131 130 ! ! defined the type of lateral diffusion from ln_traldf_... logicals -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_iso.F90
r7753 r8568 30 30 USE phycst ! physical constants 31 31 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 32 USE wrk_nemo ! Memory Allocation33 32 USE timing ! Timing 34 33 … … 111 110 REAL(wp) :: zmskv, zahv_w, zabe2, zcof2, zcoef4 ! - - 112 111 REAL(wp) :: zcoef0, ze3w_2, zsign, z2dt, z1_2dt ! - - 113 REAL(wp), POINTER, DIMENSION(:,:) :: zdkt, zdk1t, z2d 114 REAL(wp), POINTER, DIMENSION(:,:,:) :: zdit, zdjt, zftu, zftv, ztfw 115 !!---------------------------------------------------------------------- 116 ! 117 IF( nn_timing == 1 ) CALL timing_start('tra_ldf_iso') 118 ! 119 CALL wrk_alloc( jpi,jpj, zdkt, zdk1t, z2d ) 120 CALL wrk_alloc( jpi,jpj,jpk, zdit, zdjt , zftu, zftv, ztfw ) 112 REAL(wp), DIMENSION(jpi,jpj) :: zdkt, zdk1t, z2d 113 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdit, zdjt, zftu, zftv, ztfw 114 !!---------------------------------------------------------------------- 115 ! 116 IF( ln_timing ) CALL timing_start('tra_ldf_iso') 121 117 ! 122 118 IF( kt == kit000 ) THEN … … 386 382 ! ! =============== 387 383 END DO ! end tracer loop 388 ! ! =============== 389 ! 390 CALL wrk_dealloc( jpi, jpj, zdkt, zdk1t, z2d ) 391 CALL wrk_dealloc( jpi, jpj, jpk, zdit, zdjt , zftu, zftv, ztfw ) 392 ! 393 IF( nn_timing == 1 ) CALL timing_stop('tra_ldf_iso') 384 ! 385 IF( ln_timing ) CALL timing_stop('tra_ldf_iso') 394 386 ! 395 387 END SUBROUTINE tra_ldf_iso -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_lap_blp.F90
r7646 r8568 22 22 ! 23 23 USE in_out_manager ! I/O manager 24 USE iom ! I/O library 24 25 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 25 26 USE lib_mpp ! distribued memory computing library 26 27 USE timing ! Timing 27 USE wrk_nemo ! Memory allocation28 USE iom29 28 30 29 IMPLICIT NONE … … 87 86 INTEGER :: ji, jj, jk, jn ! dummy loop indices 88 87 REAL(wp) :: zsign ! local scalars 89 REAL(wp), POINTER, DIMENSION(:,:,:) ::ztu, ztv, zaheeu, zaheev90 !!---------------------------------------------------------------------- 91 ! 92 IF( nn_timing == 1) CALL timing_start('tra_ldf_lap')88 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztu, ztv, zaheeu, zaheev 89 !!---------------------------------------------------------------------- 90 ! 91 IF( ln_timing ) CALL timing_start('tra_ldf_lap') 93 92 ! 94 93 IF( kt == nit000 .AND. lwp ) THEN … … 97 96 WRITE(numout,*) '~~~~~~~~~~~ ' 98 97 ENDIF 99 !100 CALL wrk_alloc( jpi,jpj,jpk, ztu, ztv, zaheeu, zaheev )101 98 ! 102 99 l_hst = .FALSE. … … 169 166 ! ! ================== 170 167 ! 171 CALL wrk_dealloc( jpi,jpj,jpk, ztu, ztv, zaheeu, zaheev ) 172 ! 173 IF( nn_timing == 1 ) CALL timing_stop('tra_ldf_lap') 168 IF( ln_timing ) CALL timing_stop('tra_ldf_lap') 174 169 ! 175 170 END SUBROUTINE tra_ldf_lap … … 203 198 ! 204 199 INTEGER :: ji, jj, jk, jn ! dummy loop indices 205 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: zlap ! laplacian at t-point206 REAL(wp), POINTER, DIMENSION(:,:,:):: zglu, zglv ! bottom GRADh of the laplacian (u- and v-points)207 REAL(wp), POINTER, DIMENSION(:,:,:):: zgui, zgvi ! top GRADh of the laplacian (u- and v-points)200 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt) :: zlap ! laplacian at t-point 201 REAL(wp), DIMENSION(jpi,jpj, kjpt) :: zglu, zglv ! bottom GRADh of the laplacian (u- and v-points) 202 REAL(wp), DIMENSION(jpi,jpj, kjpt) :: zgui, zgvi ! top GRADh of the laplacian (u- and v-points) 208 203 !!--------------------------------------------------------------------- 209 204 ! 210 IF( nn_timing == 1 ) CALL timing_start('tra_ldf_blp') 211 ! 212 CALL wrk_alloc( jpi,jpj,jpk,kjpt, zlap ) 213 CALL wrk_alloc( jpi,jpj, kjpt, zglu, zglv, zgui, zgvi ) 205 IF( ln_timing ) CALL timing_start('tra_ldf_blp') 214 206 ! 215 207 IF( kt == kit000 .AND. lwp ) THEN … … 253 245 END SELECT 254 246 ! 255 CALL wrk_dealloc( jpi,jpj,jpk,kjpt, zlap ) 256 CALL wrk_dealloc( jpi,jpj ,kjpt, zglu, zglv, zgui, zgvi ) 257 ! 258 IF( nn_timing == 1 ) CALL timing_stop('tra_ldf_blp') 247 IF( ln_timing ) CALL timing_stop('tra_ldf_blp') 259 248 ! 260 249 END SUBROUTINE tra_ldf_blp -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_triad.F90
r7646 r8568 27 27 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 28 28 USE lib_mpp ! MPP library 29 USE wrk_nemo ! Memory Allocation30 29 USE timing ! Timing 31 30 … … 94 93 REAL(wp) :: ze1ur, ze2vr, ze3wr, zdxt, zdyt, zdzt 95 94 REAL(wp) :: zah, zah_slp, zaei_slp 96 REAL(wp), POINTER, DIMENSION(:,: ) :: z2d! 2D workspace97 REAL(wp), POINTER, DIMENSION(:,:,:) ::zdit, zdjt, zftu, zftv, ztfw, zpsi_uw, zpsi_vw ! 3D -95 REAL(wp), DIMENSION(jpi,jpj ) :: z2d ! 2D workspace 96 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdit, zdjt, zftu, zftv, ztfw, zpsi_uw, zpsi_vw ! 3D - 98 97 !!---------------------------------------------------------------------- 99 98 ! 100 IF( nn_timing == 1 ) CALL timing_start('tra_ldf_triad') 101 ! 102 CALL wrk_alloc( jpi,jpj, z2d ) 103 CALL wrk_alloc( jpi,jpj,jpk, zdit, zdjt, zftu, zftv, ztfw, zpsi_uw, zpsi_vw ) 99 IF( ln_timing ) CALL timing_start('tra_ldf_triad') 104 100 ! 105 101 IF( .NOT.ALLOCATED(zdkt3d) ) THEN … … 434 430 END DO ! end tracer loop 435 431 ! ! =============== 436 ! 437 CALL wrk_dealloc( jpi,jpj, z2d ) 438 CALL wrk_dealloc( jpi,jpj,jpk, zdit, zdjt, zftu, zftv, ztfw, zpsi_uw, zpsi_vw ) 439 ! 440 IF( nn_timing == 1 ) CALL timing_stop('tra_ldf_triad') 432 IF( ln_timing ) CALL timing_stop('tra_ldf_triad') 441 433 ! 442 434 END SUBROUTINE tra_ldf_triad -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/TRA/tranpc.F90
r6140 r8568 26 26 USE in_out_manager ! I/O manager 27 27 USE lib_mpp ! MPP library 28 USE wrk_nemo ! Memory Allocation29 28 USE timing ! Timing 30 29 … … 67 66 REAL(wp) :: zta, zalfa, zsum_temp, zsum_alfa, zaw, zdz, zsum_z 68 67 REAL(wp) :: zsa, zbeta, zsum_sali, zsum_beta, zbw, zrw, z1_r2dt 69 REAL(wp), PARAMETER :: zn2_zero = 1.e-14_wp ! acceptance criteria for neutrality (N2==0) 70 REAL(wp), POINTER, DIMENSION(:) :: zvn2 ! vertical profile of N2 at 1 given point... 71 REAL(wp), POINTER, DIMENSION(:,:) :: zvts ! vertical profile of T and S at 1 given point... 72 REAL(wp), POINTER, DIMENSION(:,:) :: zvab ! vertical profile of alpha and beta 73 REAL(wp), POINTER, DIMENSION(:,:,:) :: zn2 ! N^2 74 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: zab ! alpha and beta 75 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdt, ztrds ! 3D workspace 68 REAL(wp), PARAMETER :: zn2_zero = 1.e-14_wp ! acceptance criteria for neutrality (N2==0) 69 REAL(wp), DIMENSION( jpk ) :: zvn2 ! vertical profile of N2 at 1 given point... 70 REAL(wp), DIMENSION( jpk,jpts) :: zvts, zvab ! vertical profile of T & S , and alpha & betaat 1 given point 71 REAL(wp), DIMENSION(jpi,jpj,jpk ) :: zn2 ! N^2 72 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) :: zab ! alpha and beta 73 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds ! 3D workspace 76 74 ! 77 75 LOGICAL, PARAMETER :: l_LB_debug = .FALSE. ! set to true if you want to follow what is … … 80 78 !!---------------------------------------------------------------------- 81 79 ! 82 IF( nn_timing == 1 )CALL timing_start('tra_npc')80 IF( ln_timing ) CALL timing_start('tra_npc') 83 81 ! 84 82 IF( MOD( kt, nn_npc ) == 0 ) THEN 85 83 ! 86 CALL wrk_alloc( jpi, jpj, jpk, zn2 ) ! N287 CALL wrk_alloc( jpi, jpj, jpk, 2, zab ) ! Alpha and Beta88 CALL wrk_alloc( jpk, 2, zvts, zvab ) ! 1D column vector at point ji,jj89 CALL wrk_alloc( jpk, zvn2 ) ! 1D column vector at point ji,jj90 91 84 IF( l_trdtra ) THEN !* Save initial after fields 92 CALL wrk_alloc( jpi, jpj, jpk, ztrdt, ztrds)85 ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) 93 86 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 94 87 ztrds(:,:,:) = tsa(:,:,:,jp_sal) 95 88 ENDIF 96 89 ! 97 90 IF( l_LB_debug ) THEN 98 91 ! Location of 1 known convection site to follow what's happening in the water column … … 101 94 klc1 = mbkt(ilc1,jlc1) ! bottom of the ocean for debug point... 102 95 ENDIF 103 96 ! 104 97 CALL eos_rab( tsa, zab ) ! after alpha and beta (given on T-points) 105 98 CALL bn2 ( tsa, zab, zn2 ) ! after Brunt-Vaisala (given on W-points) 106 99 ! 107 100 inpcc = 0 108 101 ! 109 102 DO jj = 2, jpjm1 ! interior column only 110 103 DO ji = fs_2, fs_jpim1 … … 313 306 CALL trd_tra( kt, 'TRA', jp_tem, jptra_npc, ztrdt ) 314 307 CALL trd_tra( kt, 'TRA', jp_sal, jptra_npc, ztrds ) 315 CALL wrk_dealloc( jpi, jpj, jpk,ztrdt, ztrds )308 DEALLOCATE( ztrdt, ztrds ) 316 309 ENDIF 317 310 ! … … 323 316 ENDIF 324 317 ! 325 CALL wrk_dealloc(jpi, jpj, jpk, zn2 )326 CALL wrk_dealloc(jpi, jpj, jpk, 2, zab )327 CALL wrk_dealloc(jpk, zvn2 )328 CALL wrk_dealloc(jpk, 2, zvts, zvab )329 !330 318 ENDIF ! IF( MOD( kt, nn_npc ) == 0 ) THEN 331 319 ! 332 IF( nn_timing == 1 )CALL timing_stop('tra_npc')320 IF( ln_timing ) CALL timing_stop('tra_npc') 333 321 ! 334 322 END SUBROUTINE tra_npc -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/TRA/tranxt.F90
r7753 r8568 35 35 USE traqsr ! penetrative solar radiation (needed for nksr) 36 36 USE phycst ! physical constant 37 USE ldftra ! lateral physics ontracers38 USE ldfslp 39 USE bdy_oce , ONLY: ln_bdy37 USE ldftra ! lateral physics : tracers 38 USE ldfslp ! lateral physics : slopes 39 USE bdy_oce , ONLY : ln_bdy 40 40 USE bdytra ! open boundary condition (bdy_tra routine) 41 41 ! … … 43 43 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 44 44 USE prtctl ! Print control 45 USE wrk_nemo ! Memory allocation46 45 USE timing ! Timing 47 46 #if defined key_agrif … … 91 90 INTEGER :: ji, jj, jk, jn ! dummy loop indices 92 91 REAL(wp) :: zfact ! local scalars 93 REAL(wp), POINTER, DIMENSION(:,:,:) ::ztrdt, ztrds94 !!---------------------------------------------------------------------- 95 ! 96 IF( nn_timing == 1 )CALL timing_start( 'tra_nxt')92 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds 93 !!---------------------------------------------------------------------- 94 ! 95 IF( ln_timing ) CALL timing_start( 'tra_nxt') 97 96 ! 98 97 IF( kt == nit000 ) THEN … … 120 119 ! trends computation initialisation 121 120 IF( l_trdtra ) THEN 122 CALL wrk_alloc( jpi, jpj, jpk, ztrdt, ztrds)121 ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) 123 122 ztrdt(:,:,jk) = 0._wp 124 123 ztrds(:,:,jk) = 0._wp … … 170 169 CALL trd_tra( kt, 'TRA', jp_tem, jptra_atf, ztrdt ) 171 170 CALL trd_tra( kt, 'TRA', jp_sal, jptra_atf, ztrds ) 172 CALL wrk_dealloc( jpi, jpj, jpk, ztrdt, ztrds )171 DEALLOCATE( ztrdt , ztrds ) 173 172 END IF 174 173 ! … … 177 176 & tab3d_2=tsn(:,:,:,jp_sal), clinfo2= ' Sn: ', mask2=tmask ) 178 177 ! 179 IF( nn_timing == 1) CALL timing_stop('tra_nxt')178 IF( ln_timing ) CALL timing_stop('tra_nxt') 180 179 ! 181 180 END SUBROUTINE tra_nxt -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/TRA/traqsr.F90
r7753 r8568 29 29 USE in_out_manager ! I/O manager 30 30 USE prtctl ! Print control 31 USE iom ! I/O manager31 USE iom ! I/O library 32 32 USE fldread ! read input fields 33 33 USE restart ! ocean restart 34 34 USE lib_mpp ! MPP library 35 35 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 36 USE wrk_nemo ! Memory Allocation37 36 USE timing ! Timing 38 37 … … 113 112 REAL(wp) :: zCb, zCmax, zze, zpsi, zpsimax, zdelpsi, zCtot, zCze 114 113 REAL(wp) :: zlogc, zlogc2, zlogc3 115 REAL(wp), POINTER, DIMENSION(:,:) :: zekb, zekg, zekr116 REAL(wp), POINTER, DIMENSION(:,:,:) :: ze0, ze1, ze2, ze3, zea, ztrdt117 REAL(wp), POINTER, DIMENSION(:,:,:) :: zetot, zchl3d118 !!---------------------------------------------------------------------- 119 ! 120 IF( nn_timing == 1 )CALL timing_start('tra_qsr')114 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zekb, zekg, zekr 115 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ze0, ze1, ze2, ze3, zea, ztrdt 116 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zetot, zchl3d 117 !!---------------------------------------------------------------------- 118 ! 119 IF( ln_timing ) CALL timing_start('tra_qsr') 121 120 ! 122 121 IF( kt == nit000 ) THEN … … 127 126 ! 128 127 IF( l_trdtra ) THEN ! trends diagnostic: save the input temperature trend 129 CALL wrk_alloc( jpi,jpj,jpk, ztrdt)128 ALLOCATE( ztrdt(jpi,jpj,jpk) ) 130 129 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 131 130 ENDIF … … 161 160 CASE( np_RGB , np_RGBc ) !== R-G-B fluxes ==! 162 161 ! 163 CALL wrk_alloc( jpi,jpj, zekb, zekg, zekr ) 164 CALL wrk_alloc( jpi,jpj,jpk, ze0, ze1, ze2, ze3, zea, zchl3d ) 162 ALLOCATE( zekb(jpi,jpj) , zekg(jpi,jpj) , zekr (jpi,jpj) , & 163 & ze0 (jpi,jpj,jpk) , ze1 (jpi,jpj,jpk) , ze2 (jpi,jpj,jpk) , & 164 & ze3 (jpi,jpj,jpk) , zea (jpi,jpj,jpk) , zchl3d(jpi,jpj,jpk) ) 165 165 ! 166 166 IF( nqsr == np_RGBc ) THEN !* Variable Chlorophyll … … 240 240 END DO 241 241 ! 242 CALL wrk_dealloc( jpi,jpj, zekb, zekg, zekr ) 243 CALL wrk_dealloc( jpi,jpj,jpk, ze0, ze1, ze2, ze3, zea, zchl3d ) 242 DEALLOCATE( zekb , zekg , zekr , ze0 , ze1 , ze2 , ze3 , zea , zchl3d ) 244 243 ! 245 244 CASE( np_2BD ) !== 2-bands fluxes ==! … … 282 281 ! 283 282 IF( iom_use('qsr3d') ) THEN ! output the shortwave Radiation distribution 284 CALL wrk_alloc( jpi,jpj,jpk, zetot ) 285 ! 283 ALLOCATE( zetot(jpi,jpj,jpk) ) 286 284 zetot(:,:,nksr+1:jpk) = 0._wp ! below ~400m set to zero 287 285 DO jk = nksr, 1, -1 288 zetot(:,:,jk) = zetot(:,:,jk+1) + qsr_hc(:,:,jk) / r1_rau0_rcp286 zetot(:,:,jk) = zetot(:,:,jk+1) + qsr_hc(:,:,jk) * rau0_rcp 289 287 END DO 290 288 CALL iom_put( 'qsr3d', zetot ) ! 3D distribution of shortwave Radiation 291 ! 292 CALL wrk_dealloc( jpi,jpj,jpk, zetot ) 289 DEALLOCATE( zetot ) 293 290 ENDIF 294 291 ! … … 301 298 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 302 299 CALL trd_tra( kt, 'TRA', jp_tem, jptra_qsr, ztrdt ) 303 CALL wrk_dealloc( jpi,jpj,jpk,ztrdt )300 DEALLOCATE( ztrdt ) 304 301 ENDIF 305 302 ! ! print mean trends (used for debugging) 306 303 IF(ln_ctl) CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' qsr - Ta: ', mask1=tmask, clinfo3='tra-ta' ) 307 304 ! 308 IF( nn_timing == 1 )CALL timing_stop('tra_qsr')305 IF( ln_timing ) CALL timing_stop('tra_qsr') 309 306 ! 310 307 END SUBROUTINE tra_qsr … … 340 337 !!---------------------------------------------------------------------- 341 338 ! 342 IF( nn_timing == 1) CALL timing_start('tra_qsr_init')339 IF( ln_timing ) CALL timing_start('tra_qsr_init') 343 340 ! 344 341 REWIND( numnam_ref ) ! Namelist namtra_qsr in reference namelist … … 435 432 ENDIF 436 433 ! 437 IF( nn_timing == 1) CALL timing_stop('tra_qsr_init')434 IF( ln_timing ) CALL timing_stop('tra_qsr_init') 438 435 ! 439 436 END SUBROUTINE tra_qsr_init -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/TRA/trasbc.F90
r7788 r8568 32 32 USE iom ! xIOS server 33 33 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 34 USE wrk_nemo ! Memory Allocation35 34 USE timing ! Timing 36 35 … … 75 74 INTEGER :: ikt, ikb ! local integers 76 75 REAL(wp) :: zfact, z1_e3t, zdep ! local scalar 77 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdt, ztrds76 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds 78 77 !!---------------------------------------------------------------------- 79 78 ! 80 IF( nn_timing == 1 )CALL timing_start('tra_sbc')79 IF( ln_timing ) CALL timing_start('tra_sbc') 81 80 ! 82 81 IF( kt == nit000 ) THEN … … 87 86 ! 88 87 IF( l_trdtra ) THEN !* Save ta and sa trends 89 CALL wrk_alloc( jpi, jpj, jpk, ztrdt, ztrds)88 ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) 90 89 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 91 90 ztrds(:,:,:) = tsa(:,:,:,jp_sal) … … 232 231 CALL trd_tra( kt, 'TRA', jp_tem, jptra_nsr, ztrdt ) 233 232 CALL trd_tra( kt, 'TRA', jp_sal, jptra_nsr, ztrds ) 234 CALL wrk_dealloc( jpi, jpj, jpk, ztrdt, ztrds )233 DEALLOCATE( ztrdt , ztrds ) 235 234 ENDIF 236 235 ! … … 238 237 & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 239 238 ! 240 IF( nn_timing == 1 )CALL timing_stop('tra_sbc')239 IF( ln_timing ) CALL timing_stop('tra_sbc') 241 240 ! 242 241 END SUBROUTINE tra_sbc -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/TRA/trazdf.F90
r8215 r8568 56 56 !!--------------------------------------------------------------------- 57 57 ! 58 IF( nn_timing == 1 )CALL timing_start('tra_zdf')58 IF( ln_timing ) CALL timing_start('tra_zdf') 59 59 ! 60 60 IF( neuler == 0 .AND. kt == nit000 ) THEN ! at nit000 … … 97 97 & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 98 98 ! 99 IF( nn_timing == 1 )CALL timing_stop('tra_zdf')99 IF( ln_timing ) CALL timing_stop('tra_zdf') 100 100 ! 101 101 END SUBROUTINE tra_zdf … … 135 135 !!--------------------------------------------------------------------- 136 136 ! 137 IF( nn_timing == 1 )CALL timing_start('tra_zdf_imp')137 IF( ln_timing ) CALL timing_start('tra_zdf_imp') 138 138 ! 139 139 IF( kt == kit000 ) THEN … … 255 255 ! ! ================= ! 256 256 ! 257 IF( nn_timing == 1 )CALL timing_stop('tra_zdf_imp')257 IF( ln_timing ) CALL timing_stop('tra_zdf_imp') 258 258 ! 259 259 END SUBROUTINE tra_zdf_imp -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/TRA/zpshde.F90
r7753 r8568 22 22 USE lbclnk ! lateral boundary conditions (or mpp link) 23 23 USE lib_mpp ! MPP library 24 USE wrk_nemo ! Memory allocation25 24 USE timing ! Timing 26 25 … … 99 98 !!---------------------------------------------------------------------- 100 99 ! 101 IF( nn_timing == 1) CALL timing_start( 'zps_hde')102 ! 103 pgtu(:,:,:) =0._wp ; zti (:,:,:)=0._wp ; zhi (:,: )=0._wp104 pgtv(:,:,:) =0._wp ; ztj (:,:,:)=0._wp ; zhj (:,: )=0._wp100 IF( ln_timing ) CALL timing_start( 'zps_hde') 101 ! 102 pgtu(:,:,:) = 0._wp ; zti (:,:,:) = 0._wp ; zhi (:,:) = 0._wp 103 pgtv(:,:,:) = 0._wp ; ztj (:,:,:) = 0._wp ; zhj (:,:) = 0._wp 105 104 ! 106 105 DO jn = 1, kjpt !== Interpolation of tracers at the last ocean level ==! … … 188 187 END IF 189 188 ! 190 IF( nn_timing == 1) CALL timing_stop( 'zps_hde')189 IF( ln_timing ) CALL timing_stop( 'zps_hde') 191 190 ! 192 191 END SUBROUTINE zps_hde 193 ! 192 193 194 194 SUBROUTINE zps_hde_isf( kt, kjpt, pta, pgtu, pgtv, pgtui, pgtvi, & 195 195 & prd, pgru, pgrv, pgrui, pgrvi ) … … 256 256 !!---------------------------------------------------------------------- 257 257 ! 258 IF( nn_timing == 1 )CALL timing_start( 'zps_hde_isf')258 IF( ln_timing ) CALL timing_start( 'zps_hde_isf') 259 259 ! 260 260 pgtu (:,:,:) = 0._wp ; pgtv (:,:,:) =0._wp … … 453 453 END IF 454 454 ! 455 IF( nn_timing == 1) CALL timing_stop( 'zps_hde_isf')455 IF( ln_timing ) CALL timing_stop( 'zps_hde_isf') 456 456 ! 457 457 END SUBROUTINE zps_hde_isf 458 458 459 !!====================================================================== 459 460 END MODULE zpshde -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfddm.F90
r8215 r8568 83 83 !!---------------------------------------------------------------------- 84 84 ! 85 IF( nn_timing == 1) CALL timing_start('zdf_ddm')85 IF( ln_timing ) CALL timing_start('zdf_ddm') 86 86 ! 87 87 ! ! =============== … … 170 170 ENDIF 171 171 ! 172 IF( nn_timing == 1 )CALL timing_stop('zdf_ddm')172 IF( ln_timing ) CALL timing_stop('zdf_ddm') 173 173 ! 174 174 END SUBROUTINE zdf_ddm -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfdrg.F90
r8215 r8568 20 20 !!---------------------------------------------------------------------- 21 21 USE oce ! ocean dynamics and tracers variables 22 USE phycst , ONLY: vkarmn22 USE phycst , ONLY : vkarmn 23 23 USE dom_oce ! ocean space and time domain variables 24 24 USE zdf_oce ! ocean vertical physics variables … … 109 109 !!---------------------------------------------------------------------- 110 110 ! 111 IF( nn_timing == 1 )CALL timing_start('zdf_drg')111 IF( ln_timing ) CALL timing_start('zdf_drg') 112 112 ! 113 113 ! … … 140 140 IF(ln_ctl) CALL prt_ctl( tab2d_1=pCdU, clinfo1=' Cd*U ') 141 141 ! 142 IF( nn_timing == 1 )CALL timing_stop('zdf_drg')142 IF( ln_timing ) CALL timing_stop('zdf_drg') 143 143 ! 144 144 END SUBROUTINE zdf_drg -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfevd.F90
r8215 r8568 62 62 !!---------------------------------------------------------------------- 63 63 ! 64 IF( nn_timing == 1 )CALL timing_start('zdf_evd')64 IF( ln_timing ) CALL timing_start('zdf_evd') 65 65 ! 66 66 IF( kt == nit000 ) THEN … … 121 121 IF( l_trdtra ) CALL trd_tra( kt, 'TRA', jp_tem, jptra_evd, zavt_evd ) 122 122 ! 123 IF( nn_timing == 1 )CALL timing_stop('zdf_evd')123 IF( ln_timing ) CALL timing_stop('zdf_evd') 124 124 ! 125 125 END SUBROUTINE zdf_evd -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfgls.F90
r8215 r8568 159 159 !!-------------------------------------------------------------------- 160 160 ! 161 IF( nn_timing == 1) CALL timing_start('zdf_gls')161 IF( ln_timing ) CALL timing_start('zdf_gls') 162 162 ! 163 163 ! Preliminary computing … … 822 822 ENDIF 823 823 ! 824 IF( nn_timing == 1) CALL timing_stop('zdf_gls')824 IF( ln_timing ) CALL timing_stop('zdf_gls') 825 825 ! 826 826 END SUBROUTINE zdf_gls … … 852 852 !!---------------------------------------------------------- 853 853 ! 854 IF( nn_timing == 1 )CALL timing_start('zdf_gls_init')854 IF( ln_timing ) CALL timing_start('zdf_gls_init') 855 855 ! 856 856 REWIND( numnam_ref ) ! Namelist namzdf_gls in reference namelist : Vertical eddy diffivity and viscosity using gls turbulent closure scheme … … 1077 1077 rl_sf = vkarmn 1078 1078 ELSE 1079 rl_sf = rc0 * SQRT(rc0/rcm_sf) * SQRT( ( (1._wp + 4._wp*rmm + 8._wp*rmm**2_wp)*rsc_tke & 1080 & + 12._wp * rsc_psi0*rpsi2 - (1._wp + 4._wp*rmm) & 1081 & *SQRT(rsc_tke*(rsc_tke & 1082 & + 24._wp*rsc_psi0*rpsi2)) ) & 1083 & /(12._wp*rnn**2.) & 1084 & ) 1079 rl_sf = rc0 * SQRT(rc0/rcm_sf) * SQRT( ( (1._wp + 4._wp*rmm + 8._wp*rmm**2_wp) * rsc_tke & 1080 & + 12._wp*rsc_psi0*rpsi2 - (1._wp + 4._wp*rmm) & 1081 & *SQRT(rsc_tke*(rsc_tke & 1082 & + 24._wp*rsc_psi0*rpsi2)) ) & 1083 & /(12._wp*rnn**2.) ) 1085 1084 ENDIF 1086 1085 … … 1130 1129 CALL gls_rst( nit000, 'READ' ) ! (en, avt_k, avm_k, hmxl_n) 1131 1130 ! 1132 IF( nn_timing == 1 )CALL timing_stop('zdf_gls_init')1131 IF( ln_timing ) CALL timing_stop('zdf_gls_init') 1133 1132 ! 1134 1133 END SUBROUTINE zdf_gls_init -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfiwm.F90
r8215 r8568 141 141 !!---------------------------------------------------------------------- 142 142 ! 143 IF( nn_timing == 1) CALL timing_start('zdf_iwm')143 IF( ln_timing ) CALL timing_start('zdf_iwm') 144 144 ! 145 145 ! ! ----------------------------- ! … … 366 366 IF(ln_ctl) CALL prt_ctl(tab3d_1=zav_wave , clinfo1=' iwm - av_wave: ', tab3d_2=avt, clinfo2=' avt: ', ovlap=1, kdim=jpk) 367 367 ! 368 IF( nn_timing == 1) CALL timing_stop('zdf_iwm')368 IF( ln_timing ) CALL timing_stop('zdf_iwm') 369 369 ! 370 370 END SUBROUTINE zdf_iwm … … 405 405 !!---------------------------------------------------------------------- 406 406 ! 407 IF( nn_timing == 1 )CALL timing_start('zdf_iwm_init')407 IF( ln_timing ) CALL timing_start('zdf_iwm_init') 408 408 ! 409 409 REWIND( numnam_ref ) ! Namelist namzdf_iwm in reference namelist : Wave-driven mixing … … 483 483 ENDIF 484 484 ! 485 IF( nn_timing == 1 )CALL timing_stop('zdf_iwm_init')485 IF( ln_timing ) CALL timing_stop('zdf_iwm_init') 486 486 ! 487 487 END SUBROUTINE zdf_iwm_init -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfmxl.F90
r8215 r8568 82 82 !!---------------------------------------------------------------------- 83 83 ! 84 IF( nn_timing == 1 )CALL timing_start('zdf_mxl')84 IF( ln_timing ) CALL timing_start('zdf_mxl') 85 85 ! 86 86 IF( kt == nit000 ) THEN … … 141 141 IF(ln_ctl) CALL prt_ctl( tab2d_1=REAL(nmln,wp), clinfo1=' nmln : ', tab2d_2=hmlp, clinfo2=' hmlp : ', ovlap=1 ) 142 142 ! 143 IF( nn_timing == 1 )CALL timing_stop('zdf_mxl')143 IF( ln_timing ) CALL timing_stop('zdf_mxl') 144 144 ! 145 145 END SUBROUTINE zdf_mxl -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfphy.F90
r8215 r8568 32 32 USE lbclnk ! lateral boundary conditions 33 33 USE lib_mpp ! distribued memory computing 34 USE timing ! Timing 34 35 35 36 IMPLICIT NONE … … 75 76 & rn_avm0, rn_avt0, nn_avb, nn_havtb ! coefficients 76 77 !!---------------------------------------------------------------------- 78 ! 79 IF( ln_timing ) CALL timing_start('zdf_phy_init') 77 80 ! 78 81 ! !== Namelist ==! … … 193 196 !!gm move it here ? 194 197 ! 198 IF( ln_timing ) CALL timing_stop('zdf_phy_init') 199 ! 195 200 END SUBROUTINE zdf_phy_init 196 201 … … 213 218 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zsh2 ! shear production 214 219 !! --------------------------------------------------------------------- 220 ! 221 IF( ln_timing ) CALL timing_start('zdf_phy') 215 222 ! 216 223 IF( l_zdfdrg ) THEN !== update top/bottom drag ==! (non-linear cases) … … 289 296 ENDIF 290 297 ! 298 IF( ln_timing ) CALL timing_stop('zdf_phy') 299 ! 291 300 END SUBROUTINE zdf_phy 292 301 -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfric.F90
r8215 r8568 158 158 !!---------------------------------------------------------------------- 159 159 ! 160 IF( nn_timing == 1) CALL timing_start('zdf_ric')160 IF( ln_timing ) CALL timing_start('zdf_ric') 161 161 ! 162 162 ! !== avm and avt = F(Richardson number) ==! … … 197 197 ENDIF 198 198 ! 199 IF( nn_timing == 1) CALL timing_stop('zdf_ric')199 IF( ln_timing ) CALL timing_stop('zdf_ric') 200 200 ! 201 201 END SUBROUTINE zdf_ric -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfsh2.F90
r8215 r8568 56 56 !!-------------------------------------------------------------------- 57 57 ! 58 IF( nn_timing == 1 )CALL timing_start('zdf_sh2')58 IF( ln_timing ) CALL timing_start('zdf_sh2') 59 59 ! 60 60 DO jk = 2, jpkm1 … … 77 77 END DO 78 78 ! 79 IF( nn_timing == 1 )CALL timing_stop('zdf_sh2')79 IF( ln_timing ) CALL timing_stop('zdf_sh2') 80 80 ! 81 81 END SUBROUTINE zdf_sh2 -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftke.F90
r8215 r8568 159 159 !! Bruchard OM 2002 160 160 !!---------------------------------------------------------------------- 161 INTEGER 161 INTEGER , INTENT(in ) :: kt ! ocean time step 162 162 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: p_sh2 ! shear production term 163 REAL(wp), DIMENSION(:,:,:) 163 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: p_avm, p_avt ! momentum and tracer Kz (w-points) 164 164 !!---------------------------------------------------------------------- 165 165 ! … … 194 194 !! a tridiagonal linear system by a "methode de chasse" 195 195 !! - increase TKE due to surface and internal wave breaking 196 !! NB: when sea-ice is present, both LC parameterization 197 !! and TKE penetration are turned off when the ice fraction 198 !! is smaller than 0.25 196 199 !! 197 200 !! ** Action : - en : now turbulent kinetic energy) … … 217 220 !!-------------------------------------------------------------------- 218 221 ! 219 IF( nn_timing == 1 )CALL timing_start('tke_tke')222 IF( ln_timing ) CALL timing_start('tke_tke') 220 223 ! 221 224 zbbrau = rn_ebb / rau0 ! Local constant initialisation … … 312 315 zwlc = zind * rn_lc * zus * SIN( rpi * pdepw(ji,jj,jk) / zhlc(ji,jj) ) 313 316 ! ! TKE Langmuir circulation source term 314 en(ji,jj,jk) = en(ji,jj,jk) + rdt * MAX(0.,1._wp - 2.*fr_i(ji,jj) ) * ( zwlc * zwlc * zwlc ) &317 en(ji,jj,jk) = en(ji,jj,jk) + rdt * MAX(0.,1._wp - 4.*fr_i(ji,jj) ) * ( zwlc * zwlc * zwlc ) & 315 318 & / zhlc(ji,jj) * wmask(ji,jj,jk) * tmask(ji,jj,1) 316 319 END DO … … 415 418 DO ji = fs_2, fs_jpim1 ! vector opt. 416 419 en(ji,jj,jk) = en(ji,jj,jk) + rn_efr * en(ji,jj,1) * EXP( -pdepw(ji,jj,jk) / htau(ji,jj) ) & 417 & * MAX(0.,1._wp - 2.*fr_i(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1)420 & * MAX(0.,1._wp - 4.*fr_i(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) 418 421 END DO 419 422 END DO … … 424 427 jk = nmln(ji,jj) 425 428 en(ji,jj,jk) = en(ji,jj,jk) + rn_efr * en(ji,jj,1) * EXP( -pdepw(ji,jj,jk) / htau(ji,jj) ) & 426 & * MAX(0.,1._wp - 2.*fr_i(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1)429 & * MAX(0.,1._wp - 4.*fr_i(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) 427 430 END DO 428 431 END DO … … 437 440 zdif = rhftau_scl * MAX( 0._wp, zdif + rhftau_add ) ! apply some modifications... 438 441 en(ji,jj,jk) = en(ji,jj,jk) + zbbrau * zdif * EXP( -pdepw(ji,jj,jk) / htau(ji,jj) ) & 439 & * MAX(0.,1._wp - 2.*fr_i(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1)440 END DO 441 END DO 442 END DO 443 ENDIF 444 ! 445 IF( nn_timing == 1 )CALL timing_stop('tke_tke')442 & * MAX(0.,1._wp - 4.*fr_i(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) 443 END DO 444 END DO 445 END DO 446 ENDIF 447 ! 448 IF( ln_timing ) CALL timing_stop('tke_tke') 446 449 ! 447 450 END SUBROUTINE tke_tke … … 493 496 !!-------------------------------------------------------------------- 494 497 ! 495 IF( nn_timing == 1 )CALL timing_start('tke_avn')498 IF( ln_timing ) CALL timing_start('tke_avn') 496 499 497 500 ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< … … 636 639 ENDIF 637 640 ! 638 IF( nn_timing == 1 )CALL timing_stop('tke_avn')641 IF( ln_timing ) CALL timing_stop('tke_avn') 639 642 ! 640 643 END SUBROUTINE tke_avn -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90
r8215 r8568 206 206 #if defined key_agrif 207 207 IF( .NOT. Agrif_Root() ) THEN 208 CALL Agrif_ParentGrid_To_ChildGrid()209 IF( ln_diaobs ) CALL dia_obs_wri210 IF( nn_timing == 1) CALL timing_finalize211 212 ENDIF 213 #endif 214 IF( nn_timing == 1) CALL timing_finalize208 CALL Agrif_ParentGrid_To_ChildGrid() 209 IF( ln_diaobs ) CALL dia_obs_wri 210 IF( ln_timing ) CALL timing_finalize 211 CALL Agrif_ChildGrid_To_ParentGrid() 212 ENDIF 213 #endif 214 IF( ln_timing ) CALL timing_finalize 215 215 ! 216 216 CALL nemo_closefile … … 242 242 NAMELIST/namctl/ ln_ctl , nn_print, nn_ictls, nn_ictle, & 243 243 & nn_isplt , nn_jsplt, nn_jctls, nn_jctle, & 244 & nn_timing, nn_diacfl244 & ln_timing, ln_diacfl 245 245 NAMELIST/namcfg/ ln_read_cfg, cn_domcfg, ln_write_cfg, cn_domcfg_out, ln_use_jattr 246 246 !!---------------------------------------------------------------------- … … 416 416 ENDIF 417 417 ! 418 IF( nn_timing == 1 )CALL timing_init418 IF( ln_timing ) CALL timing_init 419 419 ! 420 420 ! ! General initialization 421 422 423 IF( lk_c1d 424 425 426 IF( ln_crs 427 IF( ln_nnogather ) 428 IF( ln_ctl 421 CALL phy_cst ! Physical constants 422 CALL eos_init ! Equation of state 423 IF( lk_c1d ) CALL c1d_init ! 1D column configuration 424 CALL wad_init ! Wetting and drying options 425 CALL dom_init ! Domain 426 IF( ln_crs ) CALL crs_init ! coarsened grid: domain initialization 427 IF( ln_nnogather ) CALL nemo_northcomms! northfold neighbour lists (must be done after the masks are defined) 428 IF( ln_ctl ) CALL prt_ctl_init ! Print control 429 429 430 430 CALL diurnal_sst_bulk_init ! diurnal sst … … 432 432 433 433 ! IF ln_diurnal_only, then we only want a subset of the initialisation routines 434 IF 434 IF( ln_diurnal_only ) THEN 435 435 CALL istate_init ! ocean initial state (Dynamics and tracers) 436 436 CALL sbc_init ! Forcings : surface module 437 437 CALL tra_qsr_init ! penetrative solar radiation qsr 438 IF( ln_diaobs ) THEN! Observation & model comparison439 CALL dia_obs_init ! Initialize observational data440 CALL dia_obs( nit000 - 1 ) ! Observation operator for restart438 IF( ln_diaobs ) THEN ! Observation & model comparison 439 CALL dia_obs_init ! Initialize observational data 440 CALL dia_obs( nit000 - 1 ) ! Observation operator for restart 441 441 ENDIF 442 442 ! ! Assimilation increments 443 IF( lk_asminc 443 IF( lk_asminc ) CALL asm_inc_init ! Initialize assimilation increments 444 444 445 445 IF(lwp) WRITE(numout,*) 'Euler time step switch is ', neuler … … 447 447 ENDIF 448 448 449 449 CALL istate_init ! ocean initial state (Dynamics and tracers) 450 450 451 451 ! ! external forcing 452 452 !!gm to be added : creation and call of sbc_apr_init 453 454 455 453 CALL tide_init ! tidal harmonics 454 CALL sbc_init ! surface boundary conditions (including sea-ice) 455 CALL bdy_init ! Open boundaries initialisation 456 456 457 457 ! ! Ocean physics 458 CALL zdf_phy_init! Vertical physics458 CALL zdf_phy_init ! Vertical physics 459 459 460 460 ! ! Lateral physics 461 462 463 461 CALL ldf_tra_init ! Lateral ocean tracer physics 462 CALL ldf_eiv_init ! eddy induced velocity param. 463 CALL ldf_dyn_init ! Lateral ocean momentum physics 464 464 465 465 ! ! Active tracers 466 467 468 IF( ln_trabbl 469 470 471 466 CALL tra_qsr_init ! penetrative solar radiation qsr 467 CALL tra_bbc_init ! bottom heat flux 468 IF( ln_trabbl ) CALL tra_bbl_init ! advective (and/or diffusive) bottom boundary layer scheme 469 CALL tra_dmp_init ! internal tracer damping 470 CALL tra_adv_init ! horizontal & vertical advection 471 CALL tra_ldf_init ! lateral mixing 472 472 473 473 ! ! Dynamics 474 IF( lk_c1d 475 476 477 478 479 474 IF( lk_c1d ) CALL dyn_dmp_init ! internal momentum damping 475 CALL dyn_adv_init ! advection (vector or flux form) 476 CALL dyn_vor_init ! vorticity term including Coriolis 477 CALL dyn_ldf_init ! lateral mixing 478 CALL dyn_hpg_init ! horizontal gradient of Hydrostatic pressure 479 CALL dyn_spg_init ! surface pressure gradient 480 480 481 481 #if defined key_top 482 482 ! ! Passive tracers 483 484 #endif 485 IF( l_ldfslp ) CALL ldf_slp_init! slope of lateral mixing483 CALL trc_init 484 #endif 485 IF( l_ldfslp ) CALL ldf_slp_init ! slope of lateral mixing 486 486 487 487 ! ! Icebergs 488 488 CALL icb_init( rdt, nit000) ! initialise icebergs instance 489 489 490 490 ! ! Misc. options 491 CALL sto_par_init! Stochastic parametrization492 IF( ln_sto_eos ) CALL sto_pts_init! RRandom T/S fluctuations491 CALL sto_par_init ! Stochastic parametrization 492 IF( ln_sto_eos ) CALL sto_pts_init ! RRandom T/S fluctuations 493 493 494 494 ! ! Diagnostics 495 IF( lk_floats ) CALL flo_init! drifting Floats496 CALL dia_cfl_init! Initialise CFL diagnostics497 CALL dia_ptr_init! Poleward TRansports initialization498 IF( lk_diadct ) CALL dia_dct_init! Sections tranports499 CALL dia_hsb_init! heat content, salt content and volume budgets500 CALL trd_init! Mixed-layer/Vorticity/Integral constraints trends501 CALL dia_obs_init! Initialize observational data502 IF( ln_diaobs 495 IF( lk_floats ) CALL flo_init ! drifting Floats 496 IF( ln_diacfl ) CALL dia_cfl_init ! Initialise CFL diagnostics 497 CALL dia_ptr_init ! Poleward TRansports initialization 498 IF( lk_diadct ) CALL dia_dct_init ! Sections tranports 499 CALL dia_hsb_init ! heat content, salt content and volume budgets 500 CALL trd_init ! Mixed-layer/Vorticity/Integral constraints trends 501 CALL dia_obs_init ! Initialize observational data 502 IF( ln_diaobs ) CALL dia_obs( nit000 - 1 ) ! Observation operator for restart 503 503 504 504 ! ! Assimilation increments 505 IF( lk_asminc ) CALL asm_inc_init! Initialize assimilation increments505 IF( lk_asminc ) CALL asm_inc_init ! Initialize assimilation increments 506 506 IF(lwp) WRITE(numout,*) 'Euler time step switch is ', neuler 507 CALL dia_tmb_init! TMB outputs508 CALL dia_25h_init! 25h mean outputs507 CALL dia_tmb_init ! TMB outputs 508 CALL dia_25h_init ! 25h mean outputs 509 509 ! 510 510 END SUBROUTINE nemo_init … … 533 533 WRITE(numout,*) ' number of proc. following i nn_isplt = ', nn_isplt 534 534 WRITE(numout,*) ' number of proc. following j nn_jsplt = ', nn_jsplt 535 WRITE(numout,*) ' timing activated (0/1) nn_timing = ', nn_timing 535 WRITE(numout,*) ' timing by routine ln_timing = ', ln_timing 536 WRITE(numout,*) ' CFL diagnostics ln_diacfl = ', ln_diacfl 536 537 ENDIF 537 538 ! … … 543 544 isplt = nn_isplt 544 545 jsplt = nn_jsplt 546 !!gm to be remove at the end of the 2017 merge party 547 if( ln_timing ) then ; nn_timing = 1 548 else ; nn_timing = 0 549 endif 550 !!gm end 551 545 552 546 553 IF(lwp) THEN ! control print -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/step.F90
r8215 r8568 208 208 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 209 209 IF( lk_floats ) CALL flo_stp( kstp ) ! drifting Floats 210 IF( nn_diacfl == 1) CALL dia_cfl( kstp ) ! Courant number diagnostics210 IF( ln_diacfl ) CALL dia_cfl( kstp ) ! Courant number diagnostics 211 211 IF( lk_diahth ) CALL dia_hth( kstp ) ! Thermocline depth (20 degres isotherm depth) 212 212 IF( lk_diadct ) CALL dia_dct( kstp ) ! Transports … … 324 324 #endif 325 325 ! 326 IF( nn_timing == 1.AND. kstp == nit000 ) CALL timing_reset326 IF( ln_timing .AND. kstp == nit000 ) CALL timing_reset 327 327 ! 328 328 END SUBROUTINE stp -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/stpctl.F90
r8215 r8568 96 96 IF( lk_mpp ) THEN 97 97 CALL mpp_maxloc( ABS(sshn) , tmask(:,:,1), zzz, iih, ijh ) 98 CALL mpp_maxloc( ABS(un) , umask 98 CALL mpp_maxloc( ABS(un) , umask(:,:,:), zzz, iiu, iju, iku ) 99 99 CALL mpp_minloc( tsn(:,:,1,jp_sal), tmask(:,:,1), zzz, iis, ijs ) 100 100 ELSE -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/DIA/diacfl.F90
r7753 r8568 1 1 MODULE diacfl 2 !!====================================================================== ========2 !!====================================================================== 3 3 !! *** MODULE diacfl *** 4 4 !! Output CFL diagnostics to ascii file 5 !!====================================================================== ========6 !! History : 1.0! 2010-03 (E. Blockley) Original code7 !! ! 2014-06 (T Graham)Removed CPP key & Updated to vn3.68 !! 5 !!====================================================================== 6 !! History : 3.4 ! 2010-03 (E. Blockley) Original code 7 !! 3.6 ! 2014-06 (T. Graham) Removed CPP key & Updated to vn3.6 8 !! 4.0 ! 2017-09 (G. Madec) style + comments 9 9 !!---------------------------------------------------------------------- 10 10 !! dia_cfl : Compute and output Courant numbers at each timestep … … 12 12 USE oce ! ocean dynamics and active tracers 13 13 USE dom_oce ! ocean space and time domain 14 USE domvvl ! 15 ! 14 16 USE lib_mpp ! distribued memory computing 15 17 USE lbclnk ! ocean lateral boundary condition (or mpp link) 16 18 USE in_out_manager ! I/O manager 17 USE domvvl18 19 USE timing ! Performance output 19 20 … … 21 22 PRIVATE 22 23 23 REAL(wp) :: cu_max, cv_max, cw_max ! Run max U Courant number24 INTEGER , DIMENSION(3) :: cu_loc, cv_loc, cw_loc ! Run max locations25 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: zcu_cfl ! Courant number arrays26 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: zcv_cfl ! Courant number arrays27 REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: zcw_cfl ! Courant number arrays24 CHARACTER(LEN=50) :: clname="cfl_diagnostics.ascii" ! ascii filename 25 INTEGER :: numcfl ! outfile unit 26 ! 27 INTEGER, DIMENSION(3) :: nCu_loc, nCv_loc, nCw_loc ! U, V, and W run max locations in the global domain 28 REAL(wp) :: rCu_max, rCv_max, rCw_max ! associated run max Courant number 28 29 29 INTEGER :: numcfl ! outfile unit 30 CHARACTER(LEN=50) :: clname="cfl_diagnostics.ascii" ! ascii filename 30 !!gm CAUTION: need to declare these arrays here, otherwise the calculation fails in multi-proc ! 31 !!gm 8 don't understand why. 32 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zCu_cfl, zCv_cfl, zCw_cfl ! workspace 33 !!gm end 31 34 32 35 PUBLIC dia_cfl ! routine called by step.F90 … … 40 43 !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 41 44 !!---------------------------------------------------------------------- 42 43 44 45 CONTAINS 45 46 46 47 47 SUBROUTINE dia_cfl ( kt ) … … 52 52 !! and output to ascii file 'cfl_diagnostics.ascii' 53 53 !!---------------------------------------------------------------------- 54 INTEGER, INTENT(in) :: kt ! ocean time-step index 55 ! 56 INTEGER :: ji, jj, jk ! dummy loop indices 57 REAL(wp):: z2dt, zCu_max, zCv_max, zCw_max ! local scalars 58 INTEGER , DIMENSION(3) :: iloc_u , iloc_v , iloc_w , iloc ! workspace 59 !!gm this does not work REAL(wp), DIMENSION(jpi,jpj,jpk) :: zCu_cfl, zCv_cfl, zCw_cfl ! workspace 60 !!---------------------------------------------------------------------- 61 ! 62 IF( nn_timing == 1 ) CALL timing_start('dia_cfl') 63 ! 64 ! ! setup timestep multiplier to account for initial Eulerian timestep 65 IF( neuler == 0 .AND. kt == nit000 ) THEN ; z2dt = rdt 66 ELSE ; z2dt = rdt * 2._wp 67 ENDIF 68 ! 69 ! 70 DO jk = 1, jpk ! calculate Courant numbers 71 DO jj = 1, jpj 72 DO ji = 1, fs_jpim1 ! vector opt. 73 zCu_cfl(ji,jj,jk) = ABS( un(ji,jj,jk) ) * z2dt / e1u (ji,jj) ! for i-direction 74 zCv_cfl(ji,jj,jk) = ABS( vn(ji,jj,jk) ) * z2dt / e2v (ji,jj) ! for j-direction 75 zCw_cfl(ji,jj,jk) = ABS( wn(ji,jj,jk) ) * z2dt / e3w_n(ji,jj,jk) ! for k-direction 76 END DO 77 END DO 78 END DO 79 ! 80 ! ! calculate maximum values and locations 81 IF( lk_mpp ) THEN 82 CALL mpp_maxloc( zCu_cfl, umask, zCu_max, iloc_u(1), iloc_u(2), iloc_u(3) ) 83 CALL mpp_maxloc( zCv_cfl, vmask, zCv_max, iloc_v(1), iloc_v(2), iloc_v(3) ) 84 CALL mpp_maxloc( zCw_cfl, wmask, zCw_max, iloc_w(1), iloc_w(2), iloc_w(3) ) 85 ELSE 86 iloc = MAXLOC( ABS( zcu_cfl(:,:,:) ) ) 87 iloc_u(1) = iloc(1) + nimpp - 1 88 iloc_u(2) = iloc(2) + njmpp - 1 89 iloc_u(3) = iloc(3) 90 zCu_max = zCu_cfl(iloc(1),iloc(2),iloc(3)) 91 ! 92 iloc = MAXLOC( ABS( zcv_cfl(:,:,:) ) ) 93 iloc_v(1) = iloc(1) + nimpp - 1 94 iloc_v(2) = iloc(2) + njmpp - 1 95 iloc_v(3) = iloc(3) 96 zCv_max = zCv_cfl(iloc(1),iloc(2),iloc(3)) 97 ! 98 iloc = MAXLOC( ABS( zcw_cfl(:,:,:) ) ) 99 iloc_w(1) = iloc(1) + nimpp - 1 100 iloc_w(2) = iloc(2) + njmpp - 1 101 iloc_w(3) = iloc(3) 102 zCw_max = zCw_cfl(iloc(1),iloc(2),iloc(3)) 103 ENDIF 104 ! 105 ! ! write out to file 106 IF( lwp ) THEN 107 WRITE(numcfl,FMT='(2x,i4,5x,a6,5x,f6.4,1x,i4,1x,i4,1x,i4)') kt, 'Max Cu', zCu_max, iloc_u(1), iloc_u(2), iloc_u(3) 108 WRITE(numcfl,FMT='(11x, a6,5x,f6.4,1x,i4,1x,i4,1x,i4)') 'Max Cv', zCv_max, iloc_v(1), iloc_v(2), iloc_v(3) 109 WRITE(numcfl,FMT='(11x, a6,5x,f6.4,1x,i4,1x,i4,1x,i4)') 'Max Cw', zCw_max, iloc_w(1), iloc_w(2), iloc_w(3) 110 ENDIF 111 ! 112 ! ! update maximum Courant numbers from whole run if applicable 113 IF( zCu_max > rCu_max ) THEN ; rCu_max = zCu_max ; nCu_loc(:) = iloc_u(:) ; ENDIF 114 IF( zCv_max > rCv_max ) THEN ; rCv_max = zCv_max ; nCv_loc(:) = iloc_v(:) ; ENDIF 115 IF( zCw_max > rCw_max ) THEN ; rCw_max = zCw_max ; nCw_loc(:) = iloc_w(:) ; ENDIF 54 116 55 INTEGER, INTENT(in) :: kt ! ocean time-step index 117 ! ! at end of run output max Cu and Cv and close ascii file 118 IF( kt == nitend .AND. lwp ) THEN 119 ! to ascii file 120 WRITE(numcfl,*) '******************************************' 121 WRITE(numcfl,FMT='(3x,a12,7x,f6.4,1x,i4,1x,i4,1x,i4)') 'Run Max Cu', rCu_max, nCu_loc(1), nCu_loc(2), nCu_loc(3) 122 WRITE(numcfl,FMT='(3x,a8,11x,f15.1)') ' => dt/C', z2dt/rCu_max 123 WRITE(numcfl,*) '******************************************' 124 WRITE(numcfl,FMT='(3x,a12,7x,f6.4,1x,i4,1x,i4,1x,i4)') 'Run Max Cv', rCv_max, nCv_loc(1), nCv_loc(2), nCv_loc(3) 125 WRITE(numcfl,FMT='(3x,a8,11x,f15.1)') ' => dt/C', z2dt/rCv_max 126 WRITE(numcfl,*) '******************************************' 127 WRITE(numcfl,FMT='(3x,a12,7x,f6.4,1x,i4,1x,i4,1x,i4)') 'Run Max Cw', rCw_max, nCw_loc(1), nCw_loc(2), nCw_loc(3) 128 WRITE(numcfl,FMT='(3x,a8,11x,f15.1)') ' => dt/C', z2dt/rCw_max 129 CLOSE( numcfl ) 130 ! 131 ! to ocean output 132 WRITE(numout,*) 133 WRITE(numout,*) 'dia_cfl : Maximum Courant number information for the run ' 134 WRITE(numout,*) '~~~~~~~' 135 WRITE(numout,*) ' Max Cu = ', rCu_max, ' at (i,j,k) = (',nCu_loc(1),nCu_loc(2),nCu_loc(3),') => dt/C = ', z2dt/rCu_max 136 WRITE(numout,*) ' Max Cv = ', rCv_max, ' at (i,j,k) = (',nCv_loc(1),nCv_loc(2),nCv_loc(3),') => dt/C = ', z2dt/rCv_max 137 WRITE(numout,*) ' Max Cw = ', rCw_max, ' at (i,j,k) = (',nCw_loc(1),nCw_loc(2),nCw_loc(3),') => dt/C = ', z2dt/rCw_max 138 ENDIF 139 ! 140 IF( nn_timing == 1 ) CALL timing_stop('dia_cfl') 141 ! 142 END SUBROUTINE dia_cfl 56 143 57 REAL(wp) :: zcu_max, zcv_max, zcw_max ! max Courant numbers per timestep58 INTEGER, DIMENSION(3) :: zcu_loc, zcv_loc, zcw_loc ! max Courant number locations59 60 REAL(wp) :: dt ! temporary scalars61 INTEGER, DIMENSION(3) :: zlocu, zlocv, zlocw ! temporary arrays62 INTEGER :: ji, jj, jk ! dummy loop indices63 64 65 IF( nn_diacfl == 1) THEN66 IF( nn_timing == 1 ) CALL timing_start('dia_cfl')67 ! setup timestep multiplier to account for initial Eulerian timestep68 IF( neuler == 0 .AND. kt == nit000 ) THEN ; dt = rdt69 ELSE ; dt = rdt * 2.070 ENDIF71 72 ! calculate Courant numbers73 DO jk = 1, jpk74 DO jj = 1, jpj75 DO ji = 1, fs_jpim1 ! vector opt.76 77 ! Courant number for x-direction (zonal current)78 zcu_cfl(ji,jj,jk) = ABS(un(ji,jj,jk))*dt/e1u(ji,jj)79 80 ! Courant number for y-direction (meridional current)81 zcv_cfl(ji,jj,jk) = ABS(vn(ji,jj,jk))*dt/e2v(ji,jj)82 83 ! Courant number for z-direction (vertical current)84 zcw_cfl(ji,jj,jk) = ABS(wn(ji,jj,jk))*dt/e3w_n(ji,jj,jk)85 END DO86 END DO87 END DO88 89 ! calculate maximum values and locations90 IF( lk_mpp ) THEN91 CALL mpp_maxloc(zcu_cfl,umask,zcu_max, zcu_loc(1), zcu_loc(2), zcu_loc(3))92 CALL mpp_maxloc(zcv_cfl,vmask,zcv_max, zcv_loc(1), zcv_loc(2), zcv_loc(3))93 CALL mpp_maxloc(zcw_cfl,tmask,zcw_max, zcw_loc(1), zcw_loc(2), zcw_loc(3))94 ELSE95 zlocu = MAXLOC( ABS( zcu_cfl(:,:,:) ) )96 zcu_loc(1) = zlocu(1) + nimpp - 197 zcu_loc(2) = zlocu(2) + njmpp - 198 zcu_loc(3) = zlocu(3)99 zcu_max = zcu_cfl(zcu_loc(1),zcu_loc(2),zcu_loc(3))100 101 zlocv = MAXLOC( ABS( zcv_cfl(:,:,:) ) )102 zcv_loc(1) = zlocv(1) + nimpp - 1103 zcv_loc(2) = zlocv(2) + njmpp - 1104 zcv_loc(3) = zlocv(3)105 zcv_max = zcv_cfl(zcv_loc(1),zcv_loc(2),zcv_loc(3))106 107 zlocw = MAXLOC( ABS( zcw_cfl(:,:,:) ) )108 zcw_loc(1) = zlocw(1) + nimpp - 1109 zcw_loc(2) = zlocw(2) + njmpp - 1110 zcw_loc(3) = zlocw(3)111 zcw_max = zcw_cfl(zcw_loc(1),zcw_loc(2),zcw_loc(3))112 ENDIF113 114 ! write out to file115 IF( lwp ) THEN116 WRITE(numcfl,FMT='(2x,i4,5x,a6,5x,f6.4,1x,i4,1x,i4,1x,i4)') kt, 'Max Cu', zcu_max, zcu_loc(1), zcu_loc(2), zcu_loc(3)117 WRITE(numcfl,FMT='(11x,a6,5x,f6.4,1x,i4,1x,i4,1x,i4)') 'Max Cv', zcv_max, zcv_loc(1), zcv_loc(2), zcv_loc(3)118 WRITE(numcfl,FMT='(11x,a6,5x,f6.4,1x,i4,1x,i4,1x,i4)') 'Max Cw', zcw_max, zcw_loc(1), zcw_loc(2), zcw_loc(3)119 ENDIF120 121 ! update maximum Courant numbers from whole run if applicable122 IF( zcu_max > cu_max ) THEN123 cu_max = zcu_max124 cu_loc = zcu_loc125 ENDIF126 IF( zcv_max > cv_max ) THEN127 cv_max = zcv_max128 cv_loc = zcv_loc129 ENDIF130 IF( zcw_max > cw_max ) THEN131 cw_max = zcw_max132 cw_loc = zcw_loc133 ENDIF134 135 ! at end of run output max Cu and Cv and close ascii file136 IF( kt == nitend .AND. lwp ) THEN137 ! to ascii file138 WRITE(numcfl,*) '******************************************'139 WRITE(numcfl,FMT='(3x,a12,7x,f6.4,1x,i4,1x,i4,1x,i4)') 'Run Max Cu', cu_max, cu_loc(1), cu_loc(2), cu_loc(3)140 WRITE(numcfl,FMT='(3x,a8,11x,f7.1)') ' => dt/C', dt*(1.0/cu_max)141 WRITE(numcfl,*) '******************************************'142 WRITE(numcfl,FMT='(3x,a12,7x,f6.4,1x,i4,1x,i4,1x,i4)') 'Run Max Cv', cv_max, cv_loc(1), cv_loc(2), cv_loc(3)143 WRITE(numcfl,FMT='(3x,a8,11x,f7.1)') ' => dt/C', dt*(1.0/cv_max)144 WRITE(numcfl,*) '******************************************'145 WRITE(numcfl,FMT='(3x,a12,7x,f6.4,1x,i4,1x,i4,1x,i4)') 'Run Max Cw', cw_max, cw_loc(1), cw_loc(2), cw_loc(3)146 WRITE(numcfl,FMT='(3x,a8,11x,f7.1)') ' => dt/C', dt*(1.0/cw_max)147 CLOSE( numcfl )148 149 ! to ocean output150 WRITE(numout,*)151 WRITE(numout,*) 'dia_cfl : Maximum Courant number information for the run:'152 WRITE(numout,*) '~~~~~~~~~~~~'153 WRITE(numout,FMT='(12x,a12,7x,f6.4,5x,a16,i4,1x,i4,1x,i4,a1)') 'Run Max Cu', cu_max, 'at (i, j, k) = (', cu_loc(1), cu_loc(2), cu_loc(3), ')'154 WRITE(numout,FMT='(12x,a8,11x,f7.1)') ' => dt/C', dt*(1.0/cu_max)155 WRITE(numout,FMT='(12x,a12,7x,f6.4,5x,a16,i4,1x,i4,1x,i4,a1)') 'Run Max Cv', cv_max, 'at (i, j, k) = (', cv_loc(1), cv_loc(2), cv_loc(3), ')'156 WRITE(numout,FMT='(12x,a8,11x,f7.1)') ' => dt/C', dt*(1.0/cv_max)157 WRITE(numout,FMT='(12x,a12,7x,f6.4,5x,a16,i4,1x,i4,1x,i4,a1)') 'Run Max Cw', cw_max, 'at (i, j, k) = (', cw_loc(1), cw_loc(2), cw_loc(3), ')'158 WRITE(numout,FMT='(12x,a8,11x,f7.1)') ' => dt/C', dt*(1.0/cw_max)159 160 ENDIF161 162 IF( nn_timing == 1 ) CALL timing_stop('dia_cfl')163 ENDIF164 165 END SUBROUTINE dia_cfl166 144 167 145 SUBROUTINE dia_cfl_init … … 171 149 !! ** Purpose : create output file, initialise arrays 172 150 !!---------------------------------------------------------------------- 173 174 175 IF( nn_diacfl == 1 ) THEN 176 IF( nn_timing == 1 ) CALL timing_start('dia_cfl_init') 177 178 cu_max=0.0 179 cv_max=0.0 180 cw_max=0.0 181 182 ALLOCATE( zcu_cfl(jpi, jpj, jpk), zcv_cfl(jpi, jpj, jpk), zcw_cfl(jpi, jpj, jpk) ) 183 184 zcu_cfl(:,:,:)=0.0 185 zcv_cfl(:,:,:)=0.0 186 zcw_cfl(:,:,:)=0.0 187 188 IF( lwp ) THEN 189 WRITE(numout,*) 190 WRITE(numout,*) 'dia_cfl : Outputting CFL diagnostics to '//TRIM(clname) 191 WRITE(numout,*) '~~~~~~~~~~~~' 192 WRITE(numout,*) 193 194 ! create output ascii file 195 CALL ctl_opn( numcfl, clname, 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', 1, numout, lwp, 1 ) 196 WRITE(numcfl,*) 'Timestep Direction Max C i j k' 197 WRITE(numcfl,*) '******************************************' 198 ENDIF 199 200 IF( nn_timing == 1 ) CALL timing_stop('dia_cfl_init') 201 151 ! 152 IF(lwp) THEN 153 WRITE(numout,*) 154 WRITE(numout,*) 'dia_cfl : Outputting CFL diagnostics to ',TRIM(clname), ' file' 155 WRITE(numout,*) '~~~~~~~' 156 WRITE(numout,*) 157 ! 158 ! create output ascii file 159 CALL ctl_opn( numcfl, clname, 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', 1, numout, lwp, 1 ) 160 WRITE(numcfl,*) 'Timestep Direction Max C i j k' 161 WRITE(numcfl,*) '******************************************' 202 162 ENDIF 203 163 ! 164 rCu_max = 0._wp 165 rCv_max = 0._wp 166 rCw_max = 0._wp 167 ! 168 !!gm required to work 169 ALLOCATE ( zCu_cfl(jpi,jpj,jpk), zCv_cfl(jpi,jpj,jpk), zCw_cfl(jpi,jpj,jpk) ) 170 !!gm end 171 ! 204 172 END SUBROUTINE dia_cfl_init 205 173 174 !!====================================================================== 206 175 END MODULE diacfl -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/DOM/daymod.F90
r7646 r8568 222 222 !!---------------------------------------------------------------------- 223 223 ! 224 IF( nn_timing == 1 )CALL timing_start('day')224 IF( ln_timing ) CALL timing_start('day') 225 225 ! 226 226 zprec = 0.1 / rday … … 276 276 IF( lrst_oce ) CALL day_rst( kt, 'WRITE' ) ! write day restart information 277 277 ! 278 IF( nn_timing == 1 )CALL timing_stop('day')278 IF( ln_timing ) CALL timing_stop('day') 279 279 ! 280 280 END SUBROUTINE day … … 402 402 CALL iom_rstput( kt, nitrst, numrow, 'adatrj' , adatrj ) ! number of elapsed days since 403 403 ! ! the begining of the run [s] 404 CALL iom_rstput( kt, nitrst, numrow, 'ntime' , REAL( nn_time0, wp) ) ! time404 CALL iom_rstput( kt, nitrst, numrow, 'ntime' , REAL( nn_time0, wp) ) ! time 405 405 ENDIF 406 406 ! -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/DOM/depth_e3.F90
r7753 r8568 20 20 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 21 21 USE lib_mpp ! distributed memory computing library 22 USE wrk_nemo ! Memory allocation23 22 USE timing ! Timing 24 23 -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/DOM/domain.F90
r7822 r8568 45 45 USE lbclnk ! ocean lateral boundary condition (or mpp link) 46 46 USE lib_mpp ! distributed memory computing library 47 USE wrk_nemo ! Memory Allocation48 47 USE timing ! Timing 49 48 … … 83 82 !!---------------------------------------------------------------------- 84 83 ! 85 IF( nn_timing == 1) CALL timing_start('dom_init')84 IF( ln_timing ) CALL timing_start('dom_init') 86 85 ! 87 86 IF(lwp) THEN ! Ocean domain Parameters (control print) … … 199 198 IF( ln_write_cfg ) CALL cfg_write ! create the configuration file 200 199 ! 201 IF( nn_timing == 1) CALL timing_stop('dom_init')200 IF( ln_timing ) CALL timing_stop('dom_init') 202 201 ! 203 202 END SUBROUTINE dom_init -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/DOM/domhgr.F90
r7753 r8568 79 79 !!---------------------------------------------------------------------- 80 80 ! 81 IF( nn_timing == 1 )CALL timing_start('dom_hgr')81 IF( ln_timing ) CALL timing_start('dom_hgr') 82 82 ! 83 83 IF(lwp) THEN … … 152 152 ! 153 153 ! 154 IF( nn_timing == 1 )CALL timing_stop('dom_hgr')154 IF( ln_timing ) CALL timing_stop('dom_hgr') 155 155 ! 156 156 END SUBROUTINE dom_hgr -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/DOM/dommsk.F90
r7753 r8568 30 30 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 31 31 USE lib_mpp ! Massively Parallel Processing library 32 USE wrk_nemo ! Memory allocation33 32 USE timing ! Timing 34 33 … … 92 91 INTEGER :: iktop, ikbot ! - - 93 92 INTEGER :: ios, inum 94 REAL(wp), POINTER, DIMENSION(:,:) :: zwf ! 2D workspace93 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zwf ! 2D workspace 95 94 !! 96 95 NAMELIST/namlbc/ rn_shlat, ln_vorlat … … 104 103 !!--------------------------------------------------------------------- 105 104 ! 106 IF( nn_timing == 1 )CALL timing_start('dom_msk')105 IF( ln_timing ) CALL timing_start('dom_msk') 107 106 ! 108 107 REWIND( numnam_ref ) ! Namelist namlbc in reference namelist : Lateral momentum boundary condition … … 248 247 IF( rn_shlat /= 0 ) THEN ! Not free-slip lateral boundary condition 249 248 ! 250 CALL wrk_alloc( jpi,jpj, zwf)249 ALLOCATE( zwf(jpi,jpj) ) 251 250 ! 252 251 DO jk = 1, jpk … … 278 277 END DO 279 278 ! 280 CALL wrk_dealloc( jpi,jpj,zwf )279 DEALLOCATE( zwf ) 281 280 ! 282 281 CALL lbc_lnk( fmask, 'F', 1._wp ) ! Lateral boundary conditions on fmask … … 292 291 ! 293 292 ! 294 IF( nn_timing == 1 )CALL timing_stop('dom_msk')293 IF( ln_timing ) CALL timing_stop('dom_msk') 295 294 ! 296 295 END SUBROUTINE dom_msk -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/DOM/domngb.F90
r7646 r8568 11 11 !!---------------------------------------------------------------------- 12 12 USE dom_oce ! ocean space and time domain 13 ! 13 14 USE in_out_manager ! I/O manager 14 15 USE lib_mpp ! for mppsum 15 USE wrk_nemo ! Memory allocation16 16 USE timing ! Timing 17 17 … … 45 45 INTEGER , DIMENSION(2) :: iloc 46 46 REAL(wp) :: zlon, zmini 47 REAL(wp), POINTER, DIMENSION(:,:) ::zglam, zgphi, zmask, zdist47 REAL(wp), DIMENSION(jpi,jpj) :: zglam, zgphi, zmask, zdist 48 48 !!-------------------------------------------------------------------- 49 49 ! 50 IF( nn_timing == 1 ) CALL timing_start('dom_ngb') 51 ! 52 CALL wrk_alloc( jpi,jpj, zglam, zgphi, zmask, zdist ) 50 IF( ln_timing ) CALL timing_start('dom_ngb') 53 51 ! 54 52 zmask(:,:) = 0._wp … … 79 77 ENDIF 80 78 ! 81 CALL wrk_dealloc( jpi,jpj, zglam, zgphi, zmask, zdist ) 82 ! 83 IF( nn_timing == 1 ) CALL timing_stop('dom_ngb') 79 IF( ln_timing ) CALL timing_stop('dom_ngb') 84 80 ! 85 81 END SUBROUTINE dom_ngb -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/DOM/domvvl.F90
r7753 r8568 6 6 !! History : 2.0 ! 2006-06 (B. Levier, L. Marie) original code 7 7 !! 3.1 ! 2009-02 (G. Madec, M. Leclair, R. Benshila) pure z* coordinate 8 !! 3.3 ! 2011-10 (M. Leclair) totally rewrote domvvl: 9 !! vvl option includes z_star and z_tilde coordinates 8 !! 3.3 ! 2011-10 (M. Leclair) totally rewrote domvvl: vvl option includes z_star and z_tilde coordinates 10 9 !! 3.6 ! 2014-11 (P. Mathiot) add ice shelf capability 11 10 !!---------------------------------------------------------------------- … … 31 30 USE lib_mpp ! distributed memory computing library 32 31 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 33 USE wrk_nemo ! Memory allocation34 32 USE timing ! Timing 35 33 … … 122 120 !!---------------------------------------------------------------------- 123 121 ! 124 IF( nn_timing == 1) CALL timing_start('dom_vvl_init')122 IF( ln_timing ) CALL timing_start('dom_vvl_init') 125 123 ! 126 124 IF(lwp) WRITE(numout,*) … … 242 240 ENDIF 243 241 ! 244 IF( nn_timing == 1 )CALL timing_stop('dom_vvl_init')242 IF( ln_timing ) CALL timing_stop('dom_vvl_init') 245 243 ! 246 244 END SUBROUTINE dom_vvl_init … … 276 274 REAL(wp) :: z2dt, z_tmin, z_tmax ! local scalars 277 275 LOGICAL :: ll_do_bclinic ! local logical 278 REAL(wp), POINTER, DIMENSION(:,:,:) :: ze3t279 REAL(wp), POINTER, DIMENSION(:,: ) :: zht, z_scale, zwu, zwv, zhdiv276 REAL(wp), DIMENSION(jpi,jpj) :: zht, z_scale, zwu, zwv, zhdiv 277 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t 280 278 !!---------------------------------------------------------------------- 281 279 ! 282 280 IF( ln_linssh ) RETURN ! No calculation in linear free surface 283 281 ! 284 IF( nn_timing == 1 ) CALL timing_start('dom_vvl_sf_nxt') 285 ! 286 CALL wrk_alloc( jpi,jpj,zht, z_scale, zwu, zwv, zhdiv ) 287 CALL wrk_alloc( jpi,jpj,jpk, ze3t ) 288 282 IF( ln_timing ) CALL timing_start('dom_vvl_sf_nxt') 283 ! 289 284 IF( kt == nit000 ) THEN 290 285 IF(lwp) WRITE(numout,*) … … 543 538 r1_hv_a(:,:) = ssvmask(:,:) / ( hv_a(:,:) + 1._wp - ssvmask(:,:) ) 544 539 ! 545 CALL wrk_dealloc( jpi,jpj, zht, z_scale, zwu, zwv, zhdiv ) 546 CALL wrk_dealloc( jpi,jpj,jpk, ze3t ) 547 ! 548 IF( nn_timing == 1 ) CALL timing_stop('dom_vvl_sf_nxt') 540 IF( ln_timing ) CALL timing_stop('dom_vvl_sf_nxt') 549 541 ! 550 542 END SUBROUTINE dom_vvl_sf_nxt … … 583 575 IF( ln_linssh ) RETURN ! No calculation in linear free surface 584 576 ! 585 IF( nn_timing == 1 )CALL timing_start('dom_vvl_sf_swp')577 IF( ln_timing ) CALL timing_start('dom_vvl_sf_swp') 586 578 ! 587 579 IF( kt == nit000 ) THEN … … 657 649 ! write restart file 658 650 ! ================== 659 IF( lrst_oce ) CALL dom_vvl_rst( kt, 'WRITE' )660 ! 661 IF( nn_timing == 1) CALL timing_stop('dom_vvl_sf_swp')651 IF( lrst_oce ) CALL dom_vvl_rst( kt, 'WRITE' ) 652 ! 653 IF( ln_timing ) CALL timing_stop('dom_vvl_sf_swp') 662 654 ! 663 655 END SUBROUTINE dom_vvl_sf_swp … … 683 675 !!---------------------------------------------------------------------- 684 676 ! 685 IF( nn_timing == 1) CALL timing_start('dom_vvl_interpol')677 IF( ln_timing ) CALL timing_start('dom_vvl_interpol') 686 678 ! 687 679 IF(ln_wd) THEN … … 770 762 END SELECT 771 763 ! 772 IF( nn_timing == 1) CALL timing_stop('dom_vvl_interpol')764 IF( ln_timing ) CALL timing_stop('dom_vvl_interpol') 773 765 ! 774 766 END SUBROUTINE dom_vvl_interpol … … 794 786 !!---------------------------------------------------------------------- 795 787 ! 796 IF( nn_timing == 1 ) CALL timing_start('dom_vvl_rst') 788 IF( ln_timing ) CALL timing_start('dom_vvl_rst') 789 ! 797 790 IF( TRIM(cdrw) == 'READ' ) THEN ! Read/initialise 798 791 ! ! =============== … … 947 940 ENDIF 948 941 ! 949 IF( nn_timing == 1 )CALL timing_stop('dom_vvl_rst')942 IF( ln_timing ) CALL timing_stop('dom_vvl_rst') 950 943 ! 951 944 END SUBROUTINE dom_vvl_rst -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/DOM/domwri.F90
r7646 r8568 24 24 USE lbclnk ! lateral boundary conditions - mpp exchanges 25 25 USE lib_mpp ! MPP library 26 USE wrk_nemo ! Memory allocation27 26 USE timing ! Timing 28 27 … … 75 74 INTEGER :: izco, izps, isco, icav 76 75 ! 77 REAL(wp), POINTER, DIMENSION(:,:) :: zprt, zprw ! 2D workspace 78 REAL(wp), POINTER, DIMENSION(:,:,:) :: zdepu, zdepv ! 3D workspace 79 !!---------------------------------------------------------------------- 80 ! 81 IF( nn_timing == 1 ) CALL timing_start('dom_wri') 82 ! 83 CALL wrk_alloc( jpi,jpj, zprt , zprw ) 84 CALL wrk_alloc( jpi,jpj,jpk, zdepu, zdepv ) 76 REAL(wp), DIMENSION(jpi,jpj) :: zprt, zprw ! 2D workspace 77 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdepu, zdepv ! 3D workspace 78 !!---------------------------------------------------------------------- 79 ! 80 IF( ln_timing ) CALL timing_start('dom_wri') 85 81 ! 86 82 IF(lwp) WRITE(numout,*) … … 206 202 ! ! ============================ 207 203 ! 208 CALL wrk_dealloc( jpi, jpj, zprt, zprw ) 209 CALL wrk_dealloc( jpi, jpj, jpk, zdepu, zdepv ) 210 ! 211 IF( nn_timing == 1 ) CALL timing_stop('dom_wri') 204 IF( ln_timing ) CALL timing_stop('dom_wri') 212 205 ! 213 206 END SUBROUTINE dom_wri … … 229 222 INTEGER :: ji ! dummy loop indices 230 223 LOGICAL, DIMENSION(SIZE(puniq,1),SIZE(puniq,2),1) :: lldbl ! store whether each point is unique or not 231 REAL(wp), POINTER, DIMENSION(:,:) :: ztstref 232 !!---------------------------------------------------------------------- 233 ! 234 IF( nn_timing == 1 ) CALL timing_start('dom_uniq') 235 ! 236 CALL wrk_alloc( jpi, jpj, ztstref ) 224 REAL(wp), DIMENSION(jpi,jpj) :: ztstref 225 !!---------------------------------------------------------------------- 226 ! 227 IF( ln_timing ) CALL timing_start('dom_uniq') 237 228 ! 238 229 ! build an array with different values for each element … … 250 241 puniq(nldi:nlei,nldj:nlej) = REAL( COUNT( lldbl(nldi:nlei,nldj:nlej,:), dim = 3 ) , wp ) 251 242 ! 252 CALL wrk_dealloc( jpi, jpj, ztstref ) 253 ! 254 IF( nn_timing == 1 ) CALL timing_stop('dom_uniq') 243 IF( ln_timing ) CALL timing_stop('dom_uniq') 255 244 ! 256 245 END SUBROUTINE dom_uniq -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/DOM/domzgr.F90
r7753 r8568 36 36 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 37 37 USE lib_mpp ! distributed memory computing library 38 USE wrk_nemo ! Memory allocation39 38 USE timing ! Timing 40 39 … … 77 76 !!---------------------------------------------------------------------- 78 77 ! 79 IF( nn_timing == 1) CALL timing_start('dom_zgr')78 IF( ln_timing ) CALL timing_start('dom_zgr') 80 79 ! 81 80 IF(lwp) THEN ! Control print … … 164 163 ENDIF 165 164 ! 166 IF( nn_timing == 1 )CALL timing_stop('dom_zgr')165 IF( ln_timing ) CALL timing_stop('dom_zgr') 167 166 ! 168 167 END SUBROUTINE dom_zgr … … 284 283 ! 285 284 INTEGER :: ji, jj ! dummy loop indices 286 REAL(wp), POINTER, DIMENSION(:,:) :: zk 287 !!---------------------------------------------------------------------- 288 ! 289 IF( nn_timing == 1 ) CALL timing_start('zgr_top_bot') 290 ! 291 CALL wrk_alloc( jpi,jpj, zk ) 285 REAL(wp), DIMENSION(jpi,jpj) :: zk ! workspace 286 !!---------------------------------------------------------------------- 287 ! 288 IF( ln_timing ) CALL timing_start('zgr_top_bot') 292 289 ! 293 290 IF(lwp) WRITE(numout,*) … … 319 316 zk(:,:) = REAL( mbkv(:,:), wp ) ; CALL lbc_lnk( zk, 'V', 1. ) ; mbkv(:,:) = MAX( INT( zk(:,:) ), 1 ) 320 317 ! 321 CALL wrk_dealloc( jpi,jpj, zk ) 322 ! 323 IF( nn_timing == 1 ) CALL timing_stop('zgr_top_bot') 318 IF( ln_timing ) CALL timing_stop('zgr_top_bot') 324 319 ! 325 320 END SUBROUTINE zgr_top_bot -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/DOM/dtatsd.F90
r7753 r8568 16 16 !!---------------------------------------------------------------------- 17 17 USE oce ! ocean dynamics and tracers 18 USE phycst ! physical constants 18 19 USE dom_oce ! ocean space and time domain 19 20 USE fldread ! read input fields 21 ! 20 22 USE in_out_manager ! I/O manager 21 USE phycst ! physical constants22 23 USE lib_mpp ! MPP library 23 USE wrk_nemo ! Memory allocation24 24 USE timing ! Timing 25 25 … … 62 62 !!---------------------------------------------------------------------- 63 63 ! 64 IF( nn_timing == 1 )CALL timing_start('dta_tsd_init')64 IF( ln_timing ) CALL timing_start('dta_tsd_init') 65 65 ! 66 66 ! Initialisation … … 120 120 ENDIF 121 121 ! 122 IF( nn_timing == 1 )CALL timing_stop('dta_tsd_init')122 IF( ln_timing ) CALL timing_stop('dta_tsd_init') 123 123 ! 124 124 END SUBROUTINE dta_tsd_init … … 145 145 INTEGER :: ji, jj, jk, jl, jkk ! dummy loop indicies 146 146 INTEGER :: ik, il0, il1, ii0, ii1, ij0, ij1 ! local integers 147 REAL(wp):: zl, zi 148 REAL(wp), POINTER, DIMENSION(:) :: ztp, zsp ! 1D workspace149 !!---------------------------------------------------------------------- 150 ! 151 IF( nn_timing == 1 )CALL timing_start('dta_tsd')147 REAL(wp):: zl, zi ! local scalars 148 REAL(wp), DIMENSION(jpk) :: ztp, zsp ! 1D workspace 149 !!---------------------------------------------------------------------- 150 ! 151 IF( ln_timing ) CALL timing_start('dta_tsd') 152 152 ! 153 153 CALL fld_read( kt, 1, sf_tsd ) !== read T & S data at kt time step ==! … … 185 185 ! 186 186 IF( ln_sco ) THEN !== s- or mixed s-zps-coordinate ==! 187 !188 CALL wrk_alloc( jpk, ztp, zsp )189 187 ! 190 188 IF( kt == nit000 .AND. lwp )THEN … … 222 220 END DO 223 221 ! 224 CALL wrk_dealloc( jpk, ztp, zsp )225 !226 222 ELSE !== z- or zps- coordinate ==! 227 223 ! … … 260 256 ENDIF 261 257 ! 262 IF( nn_timing == 1 )CALL timing_stop('dta_tsd')258 IF( ln_timing ) CALL timing_stop('dta_tsd') 263 259 ! 264 260 END SUBROUTINE dta_tsd -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/DOM/iscplhsb.F90
r7646 r8568 13 13 !! iscpl_div : correction of divergence to keep volume conservation 14 14 !!---------------------------------------------------------------------- 15 USE oce ! global tra/dyn variable 15 16 USE dom_oce ! ocean space and time domain 16 17 USE domwri ! ocean space and time domain 18 USE domngb ! 17 19 USE phycst ! physical constants 18 20 USE sbc_oce ! surface boundary condition variables 19 USE oce ! global tra/dyn variable 21 USE iscplini ! 22 ! 20 23 USE in_out_manager ! I/O manager 21 24 USE lib_mpp ! MPP library 22 25 USE lib_fortran ! MPP library 23 USE wrk_nemo ! Memory allocation24 26 USE lbclnk ! 25 USE domngb !26 USE iscplini27 27 28 28 IMPLICIT NONE … … 56 56 REAL(wp), DIMENSION(:,:,: ), INTENT(out) :: pvol_flx !! corrective flux to have volume conservation 57 57 REAL(wp), INTENT(in ) :: prdt_iscpl !! coupling period 58 !! 59 INTEGER :: ji, jj, jk !! loop index 60 INTEGER :: jip1, jim1, jjp1, jjm1 61 !! 62 REAL(wp):: summsk, zsum, zsum1, zarea, zsumn, zsumb 63 REAL(wp):: r1_rdtiscpl 64 REAL(wp):: zjip1_ratio , zjim1_ratio , zjjp1_ratio , zjjm1_ratio 65 !! 66 REAL(wp):: zde3t, zdtem, zdsal 67 REAL(wp), DIMENSION(:,:), POINTER :: zdssh 68 !! 69 REAL(wp), DIMENSION(:), ALLOCATABLE :: zlon, zlat 70 REAL(wp), DIMENSION(:), ALLOCATABLE :: zcorr_vol, zcorr_tem, zcorr_sal 71 INTEGER , DIMENSION(:), ALLOCATABLE :: ixpts, iypts, izpts, inpts 58 ! 59 INTEGER :: ji , jj , jk ! loop index 60 INTEGER :: jip1, jim1, jjp1, jjm1 61 REAL(wp) :: summsk, zsum , zsumn, zjip1_ratio , zjim1_ratio, zdtem, zde3t, z1_rdtiscpl 62 REAL(wp) :: zarea , zsum1, zsumb, zjjp1_ratio , zjjm1_ratio, zdsal 63 REAL(wp), DIMENSION(jpi,jpj) :: zdssh ! workspace 64 REAL(wp), DIMENSION(:), ALLOCATABLE :: zlon, zlat 65 REAL(wp), DIMENSION(:), ALLOCATABLE :: zcorr_vol, zcorr_tem, zcorr_sal 66 INTEGER , DIMENSION(:), ALLOCATABLE :: ixpts, iypts, izpts, inpts 72 67 INTEGER :: jpts, npts 73 74 CALL wrk_alloc(jpi,jpj, zdssh ) 68 !!---------------------------------------------------------------------- 75 69 76 70 ! get imbalance (volume heat and salt) 77 71 ! initialisation difference 78 zde3t = 0. 0_wp; zdsal = 0.0_wp ; zdtem = 0.0_wp72 zde3t = 0._wp ; zdsal = 0._wp ; zdtem = 0._wp 79 73 80 74 ! initialisation correction term 81 pvol_flx(:,:,: ) = 0. 0_wp82 pts_flx (:,:,:,:) = 0. 0_wp75 pvol_flx(:,:,: ) = 0._wp 76 pts_flx (:,:,:,:) = 0._wp 83 77 84 r1_rdtiscpl = 1._wp / prdt_iscpl78 z1_rdtiscpl = 1._wp / prdt_iscpl 85 79 86 80 ! mask tsn and tsb 87 tsb(:,:,:,jp_tem)=tsb(:,:,:,jp_tem)*ptmask_b(:,:,:); tsn(:,:,:,jp_tem)=tsn(:,:,:,jp_tem)*tmask(:,:,:); 88 tsb(:,:,:,jp_sal)=tsb(:,:,:,jp_sal)*ptmask_b(:,:,:); tsn(:,:,:,jp_sal)=tsn(:,:,:,jp_sal)*tmask(:,:,:); 81 tsb(:,:,:,jp_tem) = tsb(:,:,:,jp_tem) * ptmask_b(:,:,:) 82 tsn(:,:,:,jp_tem) = tsn(:,:,:,jp_tem) * tmask (:,:,:) 83 tsb(:,:,:,jp_sal) = tsb(:,:,:,jp_sal) * ptmask_b(:,:,:) 84 tsn(:,:,:,jp_sal) = tsn(:,:,:,jp_sal) * tmask (:,:,:) 89 85 90 86 !============================================================================== … … 118 114 119 115 ! volume, heat and salt differences in each cell 120 pvol_flx(ji,jj,jk) = pvol_flx(ji,jj,jk) + zde3t * r1_rdtiscpl121 pts_flx (ji,jj,jk,jp_sal)= pts_flx (ji,jj,jk,jp_sal) + zdsal * r1_rdtiscpl122 pts_flx (ji,jj,jk,jp_tem)= pts_flx (ji,jj,jk,jp_tem) + zdtem * r1_rdtiscpl116 pvol_flx(ji,jj,jk) = pvol_flx(ji,jj,jk) + zde3t * z1_rdtiscpl 117 pts_flx (ji,jj,jk,jp_sal)= pts_flx (ji,jj,jk,jp_sal) + zdsal * z1_rdtiscpl 118 pts_flx (ji,jj,jk,jp_tem)= pts_flx (ji,jj,jk,jp_tem) + zdtem * z1_rdtiscpl 123 119 124 120 ! case where we close a cell: check if the neighbour cells are wet … … 190 186 ! if no neighbour wet cell in case of 2close a cell", need to find the nearest wet point 191 187 ! allocation and initialisation of the list of problematic point 192 ALLOCATE( inpts(jpnij))193 inpts(:) =0188 ALLOCATE( inpts(jpnij) ) 189 inpts(:) = 0 194 190 195 191 ! fill narea location with the number of problematic point … … 287 283 CALL lbc_sum(pts_flx (:,:,:,jp_sal),'T',1._wp) 288 284 CALL lbc_sum(pts_flx (:,:,:,jp_tem),'T',1._wp) 289 290 ! deallocate variables 291 CALL wrk_dealloc(jpi,jpj, zdssh ) 292 285 ! 293 286 END SUBROUTINE iscpl_cons 287 294 288 295 289 SUBROUTINE iscpl_div( phdivn ) -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/DOM/iscplini.F90
r7646 r8568 11 11 !! iscpl_alloc : allocation of correction variables 12 12 !!---------------------------------------------------------------------- 13 USE oce ! global tra/dyn variable 13 14 USE dom_oce ! ocean space and time domain 14 USE oce ! global tra/dyn variable15 ! 15 16 USE lib_mpp ! MPP library 16 17 USE lib_fortran ! MPP library … … 47 48 END FUNCTION iscpl_alloc 48 49 50 49 51 SUBROUTINE iscpl_init() 52 !!---------------------------------------------------------------------- 50 53 INTEGER :: ios ! Local integer output status for namelist read 51 NAMELIST/namsbc_iscpl/ nn_fiscpl,ln_hsb,nn_drown54 NAMELIST/namsbc_iscpl/ nn_fiscpl, ln_hsb, nn_drown 52 55 !!---------------------------------------------------------------------- 53 ! ! ============54 ! ! Namelist55 ! ! ============56 56 ! 57 57 nn_fiscpl = 0 … … 79 79 WRITE(numout,*) ' coupling time step = ', rdt_iscpl 80 80 WRITE(numout,*) ' number of call of the extrapolation loop = ', nn_drown 81 END 82 81 ENDIF 82 ! 83 83 END SUBROUTINE iscpl_init 84 84 85 !!====================================================================== 85 86 END MODULE iscplini -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/DOM/iscplrst.F90
r7646 r8568 11 11 !! iscpl_rst_interpol : restart interpolation in case of coupling with ice sheet 12 12 !!---------------------------------------------------------------------- 13 USE oce ! global tra/dyn variable 13 14 USE dom_oce ! ocean space and time domain 14 15 USE domwri ! ocean space and time domain 15 USE domvvl , ONLY : dom_vvl_interpol16 USE domvvl , ONLY : dom_vvl_interpol 16 17 USE phycst ! physical constants 17 18 USE sbc_oce ! surface boundary condition variables 18 USE oce ! global tra/dyn variable 19 USE iscplini ! ice sheet coupling: initialisation 20 USE iscplhsb ! ice sheet coupling: conservation 21 ! 19 22 USE in_out_manager ! I/O manager 20 23 USE iom ! I/O module 21 24 USE lib_mpp ! MPP library 22 25 USE lib_fortran ! MPP library 23 USE wrk_nemo ! Memory allocation24 26 USE lbclnk ! communication 25 USE iscplini ! ice sheet coupling: initialisation26 USE iscplhsb ! ice sheet coupling: conservation27 27 28 28 IMPLICIT NONE … … 50 50 !!---------------------------------------------------------------------- 51 51 INTEGER :: inum0 52 REAL(wp), DIMENSION( :,: ), POINTER:: zsmask_b53 REAL(wp), DIMENSION( :,:,:), POINTER:: ztmask_b, zumask_b, zvmask_b54 REAL(wp), DIMENSION( :,:,:), POINTER:: ze3t_b , ze3u_b , ze3v_b55 REAL(wp), DIMENSION( :,:,:), POINTER:: zdepw_b52 REAL(wp), DIMENSION(jpi,jpj) :: zsmask_b 53 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztmask_b, zumask_b, zvmask_b 54 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t_b , ze3u_b , ze3v_b 55 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdepw_b 56 56 CHARACTER(20) :: cfile 57 57 !!---------------------------------------------------------------------- 58 59 CALL wrk_alloc(jpi,jpj,jpk, ztmask_b, zumask_b, zvmask_b) ! mask before 60 CALL wrk_alloc(jpi,jpj,jpk, ze3t_b , ze3u_b , ze3v_b ) ! e3 before 61 CALL wrk_alloc(jpi,jpj,jpk, zdepw_b ) 62 CALL wrk_alloc(jpi,jpj, zsmask_b ) 63 64 65 !! get restart variable 58 ! 59 ! ! get restart variable 66 60 CALL iom_get( numror, jpdom_autoglo, 'tmask' , ztmask_b ) ! need to extrapolate T/S 67 61 CALL iom_get( numror, jpdom_autoglo, 'umask' , zumask_b ) ! need to correct barotropic velocity … … 72 66 CALL iom_get( numror, jpdom_autoglo, 'e3v_n' , ze3v_b(:,:,:) ) ! need to correct barotropic velocity 73 67 CALL iom_get( numror, jpdom_autoglo, 'gdepw_n', zdepw_b(:,:,:) ) ! need to interpol vertical profile (vvl) 74 75 !! read namelist 76 CALL iscpl_init() 77 78 !! ! Extrapolation/interpolation of modify cell and new cells ... (maybe do it later after domvvl) 68 ! 69 CALL iscpl_init() ! read namelist 70 ! ! Extrapolation/interpolation of modify cell and new cells ... (maybe do it later after domvvl) 79 71 CALL iscpl_rst_interpol( ztmask_b, zumask_b, zvmask_b, zsmask_b, ze3t_b, ze3u_b, ze3v_b, zdepw_b ) 80 81 !! compute correction if conservation needed 82 IF ( ln_hsb ) THEN 72 ! 73 IF ( ln_hsb ) THEN ! compute correction if conservation needed 83 74 IF( iscpl_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'rst_iscpl : unable to allocate rst_iscpl arrays' ) 84 75 CALL iscpl_cons(ztmask_b, zsmask_b, ze3t_b, htsc_iscpl, hdiv_iscpl, rdt_iscpl) 85 76 END IF 86 77 87 ! ! print mesh/mask88 IF( nn_msh /= 0 .AND. ln_iscpl ) CALL dom_wri ! Create a domain file89 78 ! ! create a domain file 79 IF( nn_msh /= 0 .AND. ln_iscpl ) CALL dom_wri 80 ! 90 81 IF ( ln_hsb ) THEN 91 82 cfile='correction' … … 97 88 CALL iom_close ( inum0 ) 98 89 END IF 99 100 CALL wrk_dealloc(jpi,jpj,jpk, ztmask_b,zumask_b,zvmask_b ) 101 CALL wrk_dealloc(jpi,jpj,jpk, ze3t_b ,ze3u_b ,ze3v_b ) 102 CALL wrk_dealloc(jpi,jpj,jpk, zdepw_b ) 103 CALL wrk_dealloc(jpi,jpj, zsmask_b ) 104 105 !! next step is an euler time step 106 neuler = 0 107 108 !! set _b and _n variables equal 90 ! 91 neuler = 0 ! next step is an euler time step 92 ! 93 ! ! set _b and _n variables equal 109 94 tsb (:,:,:,:) = tsn (:,:,:,:) 110 95 ub (:,:,:) = un (:,:,:) 111 96 vb (:,:,:) = vn (:,:,:) 112 97 sshb(:,:) = sshn(:,:) 113 114 ! ! set _b and _n vertical scale factor equal98 ! 99 ! ! set _b and _n vertical scale factor equal 115 100 e3t_b (:,:,:) = e3t_n (:,:,:) 116 101 e3u_b (:,:,:) = e3u_n (:,:,:) 117 102 e3v_b (:,:,:) = e3v_n (:,:,:) 118 103 ! 119 104 e3uw_b (:,:,:) = e3uw_n (:,:,:) 120 105 e3vw_b (:,:,:) = e3vw_n (:,:,:) … … 150 135 REAL(wp):: zdz, zdzm1, zdzp1 151 136 !! 152 REAL(wp), DIMENSION(:,: ), POINTER :: zdmask , zdsmask, zvcorr, zucorr, zde3t 153 REAL(wp), DIMENSION(:,: ), POINTER :: zbub , zbvb , zbun , zbvn 154 REAL(wp), DIMENSION(:,: ), POINTER :: zssh0 , zssh1, zhu1, zhv1 155 REAL(wp), DIMENSION(:,: ), POINTER :: zsmask0, zsmask1 156 REAL(wp), DIMENSION(:,:,: ), POINTER :: ztmask0, ztmask1, ztrp 157 REAL(wp), DIMENSION(:,:,: ), POINTER :: zwmaskn, zwmaskb, ztmp3d 158 REAL(wp), DIMENSION(:,:,:,:), POINTER :: zts0 137 REAL(wp), DIMENSION(jpi,jpj) :: zdmask , zsmask0, zucorr, zbub, zbun, zssh0, zhu1, zde3t 138 REAL(wp), DIMENSION(jpi,jpj) :: zdsmask, zsmask1, zvcorr, zbvb, zbvn, zssh1, zhv1 139 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztmask0, zwmaskn, ztrp 140 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztmask1, zwmaskb, ztmp3d 141 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) :: zts0 159 142 !!---------------------------------------------------------------------- 160 161 !! allocate variables 162 CALL wrk_alloc(jpi,jpj,jpk,2, zts0 ) 163 CALL wrk_alloc(jpi,jpj,jpk, ztmask0, ztmask1 , ztrp, ztmp3d ) 164 CALL wrk_alloc(jpi,jpj,jpk, zwmaskn, zwmaskb ) 165 CALL wrk_alloc(jpi,jpj, zsmask0, zsmask1 ) 166 CALL wrk_alloc(jpi,jpj, zdmask , zdsmask, zvcorr, zucorr, zde3t) 167 CALL wrk_alloc(jpi,jpj, zbub , zbvb , zbun , zbvn ) 168 CALL wrk_alloc(jpi,jpj, zssh0 , zssh1, zhu1, zhv1 ) 169 170 !! mask value to be sure 143 ! 144 ! ! mask value to be sure 171 145 tsn(:,:,:,jp_tem) = tsn(:,:,:,jp_tem) * ptmask_b(:,:,:) 172 146 tsn(:,:,:,jp_sal) = tsn(:,:,:,jp_sal) * ptmask_b(:,:,:) 173 174 ! compute wmask147 ! 148 ! ! compute wmask 175 149 zwmaskn(:,:,1) = tmask (:,:,1) 176 150 zwmaskb(:,:,1) = ptmask_b(:,:,1) … … 179 153 zwmaskb(:,:,jk) = ptmask_b(:,:,jk) * ptmask_b(:,:,jk-1) 180 154 END DO 181 182 ! compute new ssh if we open a full water column (average of the closest neigbourgs)155 ! 156 ! ! compute new ssh if we open a full water column (average of the closest neigbourgs) 183 157 sshb (:,:)=sshn(:,:) 184 158 zssh0(:,:)=sshn(:,:) 185 159 zsmask0(:,:) = psmask_b(:,:) 186 160 zsmask1(:,:) = psmask_b(:,:) 187 DO iz = 1, 10! need to be tuned (configuration dependent) (OK for ISOMIP+)161 DO iz = 1, 10 ! need to be tuned (configuration dependent) (OK for ISOMIP+) 188 162 zdsmask(:,:) = ssmask(:,:)-zsmask0(:,:) 189 163 DO jj = 2,jpj-1 … … 198 172 & + zssh0(ji,jjm1)*zsmask0(ji,jjm1))/summsk 199 173 zsmask1(ji,jj)=1._wp 200 END 174 ENDIF 201 175 END DO 202 176 END DO 203 CALL lbc_lnk( sshn,'T',1._wp)204 CALL lbc_lnk( zsmask1,'T',1._wp)177 CALL lbc_lnk( sshn , 'T', 1._wp ) 178 CALL lbc_lnk( zsmask1, 'T', 1._wp ) 205 179 zssh0 = sshn 206 180 zsmask0 = zsmask1 … … 210 184 !============================================================================= 211 185 !PM: Is this needed since introduction of VVL by default? 212 IF ( .NOT.ln_linssh) THEN186 IF ( .NOT.ln_linssh ) THEN 213 187 ! Reconstruction of all vertical scale factors at now time steps 214 188 ! ============================================================================= … … 224 198 END DO 225 199 END DO 226 200 ! 227 201 CALL dom_vvl_interpol( e3t_n(:,:,:), e3u_n(:,:,:), 'U' ) 228 202 CALL dom_vvl_interpol( e3t_n(:,:,:), e3v_n(:,:,:), 'V' ) 229 203 CALL dom_vvl_interpol( e3u_n(:,:,:), e3f_n(:,:,:), 'F' ) 230 204 231 ! Vertical scale factor interpolations232 ! ------------------------------------205 ! Vertical scale factor interpolations 206 ! ------------------------------------ 233 207 CALL dom_vvl_interpol( e3t_n(:,:,:), e3w_n (:,:,:), 'W' ) 234 208 CALL dom_vvl_interpol( e3u_n(:,:,:), e3uw_n(:,:,:), 'UW' ) 235 209 CALL dom_vvl_interpol( e3v_n(:,:,:), e3vw_n(:,:,:), 'VW' ) 236 237 ! t- and w- points depth238 ! ----------------------210 211 ! t- and w- points depth 212 ! ---------------------- 239 213 gdept_n(:,:,1) = 0.5_wp * e3w_n(:,:,1) 240 214 gdepw_n(:,:,1) = 0.0_wp … … 429 403 ! nothing to do 430 404 ! 431 ! deallocation tmp arrays432 CALL wrk_dealloc(jpi,jpj,jpk,2, zts0 )433 CALL wrk_dealloc(jpi,jpj,jpk, ztmask0, ztmask1 , ztrp )434 CALL wrk_dealloc(jpi,jpj,jpk, zwmaskn, zwmaskb , ztmp3d )435 CALL wrk_dealloc(jpi,jpj, zsmask0, zsmask1 )436 CALL wrk_dealloc(jpi,jpj, zdmask , zdsmask, zvcorr, zucorr, zde3t)437 CALL wrk_dealloc(jpi,jpj, zbub , zbvb , zbun , zbvn )438 CALL wrk_dealloc(jpi,jpj, zssh0 , zssh1 , zhu1 , zhv1 )439 !440 405 END SUBROUTINE iscpl_rst_interpol 441 406 -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/DOM/istate.F90
r7753 r8568 36 36 USE lib_mpp ! MPP library 37 37 USE restart ! restart 38 USE wrk_nemo ! Memory allocation39 38 USE timing ! Timing 40 39 … … 60 59 !!---------------------------------------------------------------------- 61 60 INTEGER :: ji, jj, jk ! dummy loop indices 62 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: zuvd ! U & V data workspace 61 !!gm see comment further down 62 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: zuvd ! U & V data workspace 63 !!gm end 63 64 !!---------------------------------------------------------------------- 64 65 ! 65 IF( nn_timing == 1) CALL timing_start('istate_init')66 IF( ln_timing ) CALL timing_start('istate_init') 66 67 ! 67 68 IF(lwp) WRITE(numout,*) … … 121 122 !!gm to be moved in usrdef of C1D case 122 123 ! IF ( ln_uvd_init .AND. lk_c1d ) THEN ! read 3D U and V data at nit000 123 ! CALL wrk_alloc( jpi,jpj,jpk,2, zuvd)124 ! ALLOCATE( zuvd(jpi,jpj,jpk,2) ) 124 125 ! CALL dta_uvd( nit000, zuvd ) 125 126 ! ub(:,:,:) = zuvd(:,:,:,1) ; un(:,:,:) = ub(:,:,:) 126 127 ! vb(:,:,:) = zuvd(:,:,:,2) ; vn(:,:,:) = vb(:,:,:) 127 ! CALL wrk_dealloc( jpi,jpj,jpk,2,zuvd )128 ! DEALLOCATE( zuvd ) 128 129 ! ENDIF 129 130 ! … … 164 165 vb_b(:,:) = vb_b(:,:) * r1_hv_b(:,:) 165 166 ! 166 IF( nn_timing == 1) CALL timing_stop('istate_init')167 IF( ln_timing ) CALL timing_stop('istate_init') 167 168 ! 168 169 END SUBROUTINE istate_init -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/DYN/divhor.F90
r7753 r8568 29 29 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 30 30 USE lib_mpp ! MPP library 31 USE wrk_nemo ! Memory Allocation32 31 USE timing ! Timing 33 32 … … 40 39 # include "vectopt_loop_substitute.h90" 41 40 !!---------------------------------------------------------------------- 42 !! NEMO/OPA 3.7 , NEMO Consortium (2014)41 !! NEMO/OPA 4.0 , NEMO Consortium (2017) 43 42 !! $Id$ 44 43 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 64 63 !!---------------------------------------------------------------------- 65 64 ! 66 IF( nn_timing == 1) CALL timing_start('div_hor')65 IF( ln_timing ) CALL timing_start('div_hor') 67 66 ! 68 67 IF( kt == nit000 ) THEN … … 75 74 DO jj = 2, jpjm1 76 75 DO ji = fs_2, fs_jpim1 ! vector opt. 77 hdivn(ji,jj,jk) = ( e2u(ji ,jj) * e3u_n(ji ,jj,jk) * un(ji ,jj,jk) 78 & - e2u(ji-1,jj) * e3u_n(ji-1,jj,jk) * un(ji-1,jj,jk) 79 & + e1v(ji,jj ) * e3v_n(ji,jj ,jk) * vn(ji,jj ,jk) 80 & - e1v(ji,jj-1) * e3v_n(ji,jj-1,jk) * vn(ji,jj-1,jk) )&81 & / ( e1e2t(ji,jj) * e3t_n(ji,jj,jk))76 hdivn(ji,jj,jk) = ( e2u(ji ,jj) * e3u_n(ji ,jj,jk) * un(ji ,jj,jk) & 77 & - e2u(ji-1,jj) * e3u_n(ji-1,jj,jk) * un(ji-1,jj,jk) & 78 & + e1v(ji,jj ) * e3v_n(ji,jj ,jk) * vn(ji,jj ,jk) & 79 & - e1v(ji,jj-1) * e3v_n(ji,jj-1,jk) * vn(ji,jj-1,jk) ) & 80 & * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 82 81 END DO 83 82 END DO … … 90 89 END DO 91 90 ! 92 IF( ln_rnf ) CALL sbc_rnf_div( hdivn ) !== runoffs ==! (update hdivn field)91 IF( ln_rnf ) CALL sbc_rnf_div( hdivn ) !== runoffs ==! (update hdivn field) 93 92 ! 94 IF( ln_isf ) CALL sbc_isf_div( hdivn ) !== ice shelf ==! (update hdivn field)93 IF( ln_isf ) CALL sbc_isf_div( hdivn ) !== ice shelf ==! (update hdivn field) 95 94 ! 96 IF( ln_iscpl .AND. ln_hsb ) CALL iscpl_div( hdivn )!== ice sheet ==! (update hdivn field)95 IF( ln_iscpl .AND. ln_hsb ) CALL iscpl_div( hdivn ) !== ice sheet ==! (update hdivn field) 97 96 ! 98 CALL lbc_lnk( hdivn, 'T', 1. ) !== lateral boundary cond. ==! (no sign change)97 CALL lbc_lnk( hdivn, 'T', 1. ) ! (no sign change) 99 98 ! 100 IF( nn_timing == 1 )CALL timing_stop('div_hor')99 IF( ln_timing ) CALL timing_stop('div_hor') 101 100 ! 102 101 END SUBROUTINE div_hor -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/DYN/dynadv.F90
r7646 r8568 7 7 !! 3.3 ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase 8 8 !! 3.6 ! 2015-05 (N. Ducousso, G. Madec) add Hollingsworth scheme as an option 9 !! 4.0 ! 2017-07 (G. Madec) add a linear dynamics option 9 10 !!---------------------------------------------------------------------- 10 11 … … 30 31 31 32 ! !* namdyn_adv namelist * 32 LOGICAL, PUBLIC :: ln_dynadv_vec !: vector form flag 33 INTEGER, PUBLIC :: nn_dynkeg !: scheme of kinetic energy gradient: =0 C2 ; =1 Hollingsworth 33 LOGICAL, PUBLIC :: ln_dynadv_NONE !: linear dynamics (no momentum advection) 34 LOGICAL, PUBLIC :: ln_dynadv_vec !: vector form 35 INTEGER, PUBLIC :: nn_dynkeg !: scheme of grad(KE): =0 C2 ; =1 Hollingsworth 34 36 LOGICAL, PUBLIC :: ln_dynadv_cen2 !: flux form - 2nd order centered scheme flag 35 37 LOGICAL, PUBLIC :: ln_dynadv_ubs !: flux form - 3rd order UBS scheme flag 36 LOGICAL, PUBLIC :: ln_dynzad_zts !: vertical advection with sub-timestepping (requires vector form)37 38 38 INTEGER :: nadv ! choice of the formulation and scheme for the advection 39 INTEGER, PUBLIC :: n_dynadv !: choice of the formulation and scheme for momentum advection 40 ! ! associated indices: 41 INTEGER, PUBLIC, PARAMETER :: np_LIN_dyn = 0 ! no advection: linear dynamics 42 INTEGER, PUBLIC, PARAMETER :: np_VEC_c2 = 1 ! vector form : 2nd order centered scheme 43 INTEGER, PUBLIC, PARAMETER :: np_FLX_c2 = 2 ! flux form : 2nd order centered scheme 44 INTEGER, PUBLIC, PARAMETER :: np_FLX_ubs = 3 ! flux form : 3rd order Upstream Biased Scheme 39 45 40 46 !! * Substitutions 41 47 # include "vectopt_loop_substitute.h90" 42 48 !!---------------------------------------------------------------------- 43 !! NEMO/OPA 3.6 , NEMO Consortium (2015)49 !! NEMO/OPA 4.0 , NEMO Consortium (2017) 44 50 !! $Id$ 45 51 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 53 59 !! ** Purpose : compute the ocean momentum advection trend. 54 60 !! 55 !! ** Method : - Update (ua,va) with the advection term following nadv 61 !! ** Method : - Update (ua,va) with the advection term following n_dynadv 62 !! 56 63 !! NB: in flux form advection (ln_dynadv_cen2 or ln_dynadv_ubs=T) 57 64 !! a metric term is add to the coriolis term while in vector form … … 62 69 !!---------------------------------------------------------------------- 63 70 ! 64 IF( nn_timing == 1 ) CALL timing_start('dyn_adv')71 IF( ln_timing ) CALL timing_start( 'dyn_adv' ) 65 72 ! 66 SELECT CASE ( nadv ) ! compute advection trend and add it to general trend 67 CASE ( 0 ) 68 CALL dyn_keg ( kt, nn_dynkeg ) ! vector form : horizontal gradient of kinetic energy 69 CALL dyn_zad ( kt ) ! vector form : vertical advection 70 CASE ( 1 ) 71 CALL dyn_keg ( kt, nn_dynkeg ) ! vector form : horizontal gradient of kinetic energy 72 CALL dyn_zad_zts ( kt ) ! vector form : vertical advection with sub-timestepping 73 CASE ( 2 ) 74 CALL dyn_adv_cen2( kt ) ! 2nd order centered scheme 75 CASE ( 3 ) 76 CALL dyn_adv_ubs ( kt ) ! 3rd order UBS scheme 73 SELECT CASE( n_dynadv ) !== compute advection trend and add it to general trend ==! 74 CASE( np_VEC_c2 ) 75 CALL dyn_keg ( kt, nn_dynkeg ) ! vector form : horizontal gradient of kinetic energy 76 CALL dyn_zad ( kt ) ! vector form : vertical advection 77 CASE( np_FLX_c2 ) 78 CALL dyn_adv_cen2( kt ) ! 2nd order centered scheme 79 CASE( np_FLX_ubs ) 80 CALL dyn_adv_ubs ( kt ) ! 3rd order UBS scheme (UP3) 77 81 END SELECT 78 82 ! 79 IF( nn_timing == 1 ) CALL timing_stop('dyn_adv')83 IF( ln_timing ) CALL timing_stop( 'dyn_adv' ) 80 84 ! 81 85 END SUBROUTINE dyn_adv … … 87 91 !! 88 92 !! ** Purpose : Control the consistency between namelist options for 89 !! momentum advection formulation & scheme and set n adv93 !! momentum advection formulation & scheme and set n_dynadv 90 94 !!---------------------------------------------------------------------- 91 95 INTEGER :: ioptio, ios ! Local integer 92 96 ! 93 NAMELIST/namdyn_adv/ ln_dynadv_ vec, nn_dynkeg, ln_dynadv_cen2 , ln_dynadv_ubs, ln_dynzad_zts97 NAMELIST/namdyn_adv/ ln_dynadv_NONE, ln_dynadv_vec, nn_dynkeg, ln_dynadv_cen2, ln_dynadv_ubs 94 98 !!---------------------------------------------------------------------- 95 99 ! … … 108 112 WRITE(numout,*) '~~~~~~~~~~~~' 109 113 WRITE(numout,*) ' Namelist namdyn_adv : chose a advection formulation & scheme for momentum' 110 WRITE(numout,*) ' Vector/flux form (T/F) ln_dynadv_vec = ', ln_dynadv_vec111 WRITE(numout,*) ' = 0 standard scheme ; =1 Hollingsworth scheme nn_dynkeg = ', nn_dynkeg112 WRITE(numout,*) ' 2nd order centred advection scheme ln_dynadv_cen2 = ', ln_dynadv_cen2113 WRITE(numout,*) ' 3rd order UBS advection scheme ln_dynadv_ubs = ', ln_dynadv_ubs114 WRITE(numout,*) ' Sub timestepping of vertical advection ln_dynzad_zts = ', ln_dynzad_zts114 WRITE(numout,*) ' linear dynamics : no momentum advection ln_dynadv_NONE = ', ln_dynadv_NONE 115 WRITE(numout,*) ' Vector form: 2nd order centered scheme ln_dynadv_vec = ', ln_dynadv_vec 116 WRITE(numout,*) ' with Hollingsworth scheme (=1) or not (=0) nn_dynkeg = ', nn_dynkeg 117 WRITE(numout,*) ' flux form: 2nd order centred scheme ln_dynadv_cen2 = ', ln_dynadv_cen2 118 WRITE(numout,*) ' 3rd order UBS scheme ln_dynadv_ubs = ', ln_dynadv_ubs 115 119 ENDIF 116 120 117 ioptio = 0 ! Parameter control 118 IF( ln_dynadv_vec ) ioptio = ioptio + 1 119 IF( ln_dynadv_cen2 ) ioptio = ioptio + 1 120 IF( ln_dynadv_ubs ) ioptio = ioptio + 1 121 ioptio = 0 ! parameter control and set n_dynadv 122 IF( ln_dynadv_NONE ) THEN ; ioptio = ioptio + 1 ; n_dynadv = np_LIN_dyn ; ENDIF 123 IF( ln_dynadv_vec ) THEN ; ioptio = ioptio + 1 ; n_dynadv = np_VEC_c2 ; ENDIF 124 IF( ln_dynadv_cen2 ) THEN ; ioptio = ioptio + 1 ; n_dynadv = np_FLX_c2 ; ENDIF 125 IF( ln_dynadv_ubs ) THEN ; ioptio = ioptio + 1 ; n_dynadv = np_FLX_ubs ; ENDIF 121 126 122 IF( ioptio /= 1 ) CALL ctl_stop( 'Choose ONE advection scheme in namelist namdyn_adv' ) 123 IF( ln_dynzad_zts .AND. .NOT. ln_dynadv_vec ) & 124 CALL ctl_stop( 'Sub timestepping of vertical advection requires vector form; set ln_dynadv_vec = .TRUE.' ) 125 IF( nn_dynkeg /= nkeg_C2 .AND. nn_dynkeg /= nkeg_HW ) & 126 CALL ctl_stop( 'KEG scheme wrong value of nn_dynkeg' ) 127 IF( ioptio /= 1 ) CALL ctl_stop( 'choose ONE and only ONE advection scheme' ) 128 IF( nn_dynkeg /= nkeg_C2 .AND. nn_dynkeg /= nkeg_HW ) CALL ctl_stop( 'KEG scheme wrong value of nn_dynkeg' ) 127 129 128 ! ! Set nadv129 IF( ln_dynadv_vec ) nadv = 0130 IF( ln_dynzad_zts ) nadv = 1131 IF( ln_dynadv_cen2 ) nadv = 2132 IF( ln_dynadv_ubs ) nadv = 3133 130 134 131 IF(lwp) THEN ! Print the choice 135 132 WRITE(numout,*) 136 IF( nadv == 0 ) WRITE(numout,*) ' ===>> vector form : keg + zad + vor is used'137 IF( nadv == 1 ) WRITE(numout,*) ' ===>> vector form : keg + zad_zts + vor isused'138 IF( nadv == 0 .OR. nadv == 1 ) THEN133 SELECT CASE( n_dynadv ) 134 CASE( np_LIN_dyn ) ; WRITE(numout,*) ' ===>> linear dynamics : no momentum advection used' 135 CASE( np_VEC_c2 ) ; WRITE(numout,*) ' ===>> vector form : keg + zad + vor is used' 139 136 IF( nn_dynkeg == nkeg_C2 ) WRITE(numout,*) ' with Centered standard keg scheme' 140 137 IF( nn_dynkeg == nkeg_HW ) WRITE(numout,*) ' with Hollingsworth keg scheme' 141 ENDIF142 IF( nadv == 2 ) WRITE(numout,*) ' ===>> flux form : 2nd orderscheme is used'143 IF( nadv == 3 ) WRITE(numout,*) ' ===>> flux form : UBS scheme is used'138 CASE( np_FLX_c2 ) ; WRITE(numout,*) ' ===>> flux form : 2nd order scheme is used' 139 CASE( np_FLX_ubs ) ; WRITE(numout,*) ' ===>> flux form : UBS scheme is used' 140 END SELECT 144 141 ENDIF 145 142 ! -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/DYN/dynadv_cen2.F90
r6750 r8568 20 20 USE lib_mpp ! MPP library 21 21 USE prtctl ! Print control 22 USE wrk_nemo ! Memory Allocation23 22 USE timing ! Timing 24 23 … … 31 30 # include "vectopt_loop_substitute.h90" 32 31 !!---------------------------------------------------------------------- 33 !! NEMO/OPA 4.0 , NEMO Consortium (201 1)32 !! NEMO/OPA 4.0 , NEMO Consortium (2017) 34 33 !! $Id$ 35 34 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 51 50 ! 52 51 INTEGER :: ji, jj, jk ! dummy loop indices 53 REAL(wp), POINTER, DIMENSION(:,:,:) :: zfu_t, zfv_t, zfu_f, zfv_f, zfu_uw, zfv_vw, zfw54 REAL(wp), POINTER, DIMENSION(:,:,:) :: zfu, zfv52 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zfu_t, zfu_f, zfu_uw, zfu 53 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zfv_t, zfv_f, zfv_vw, zfv, zfw 55 54 !!---------------------------------------------------------------------- 56 55 ! 57 IF( nn_timing == 1 ) CALL timing_start('dyn_adv_cen2') 58 ! 59 CALL wrk_alloc( jpi,jpj,jpk, zfu_t, zfv_t, zfu_f, zfv_f, zfu_uw, zfv_vw, zfu, zfv, zfw ) 56 IF( ln_timing ) CALL timing_start('dyn_adv_cen2') 60 57 ! 61 58 IF( kt == nit000 .AND. lwp ) THEN … … 148 145 & tab3d_2=va, clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) 149 146 ! 150 CALL wrk_dealloc( jpi, jpj, jpk, zfu_t, zfv_t, zfu_f, zfv_f, zfu_uw, zfv_vw, zfu, zfv, zfw ) 151 ! 152 IF( nn_timing == 1 ) CALL timing_stop('dyn_adv_cen2') 147 IF( ln_timing ) CALL timing_stop('dyn_adv_cen2') 153 148 ! 154 149 END SUBROUTINE dyn_adv_cen2 -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/DYN/dynadv_ubs.F90
r6750 r8568 23 23 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 24 24 USE lib_mpp ! MPP library 25 USE wrk_nemo ! Memory Allocation26 25 USE timing ! Timing 27 26 … … 37 36 # include "vectopt_loop_substitute.h90" 38 37 !!---------------------------------------------------------------------- 39 !! NEMO/OPA 4.0 , NEMO Consortium (201 1)38 !! NEMO/OPA 4.0 , NEMO Consortium (2017) 40 39 !! $Id$ 41 40 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 74 73 INTEGER :: ji, jj, jk ! dummy loop indices 75 74 REAL(wp) :: zui, zvj, zfuj, zfvi, zl_u, zl_v ! local scalars 76 REAL(wp), POINTER, DIMENSION(:,:,: ) :: zfu, zfv 77 REAL(wp), POINTER, DIMENSION(:,:,: ) :: zfu_t, zfv_t, zfu_f, zfv_f, zfu_uw, zfv_vw, zfw 78 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: zlu_uu, zlv_vv, zlu_uv, zlv_vu 75 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zfu_t, zfu_f, zfu_uw, zfu 76 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zfv_t, zfv_f, zfv_vw, zfv, zfw 77 REAL(wp), DIMENSION(jpi,jpj,jpk,2) :: zlu_uu, zlu_uv 78 REAL(wp), DIMENSION(jpi,jpj,jpk,2) :: zlv_vv, zlv_vu 79 79 !!---------------------------------------------------------------------- 80 80 ! 81 IF( nn_timing == 1 ) CALL timing_start('dyn_adv_ubs') 82 ! 83 CALL wrk_alloc( jpi,jpj,jpk, zfu_t , zfv_t , zfu_f , zfv_f, zfu_uw, zfv_vw, zfu, zfv, zfw ) 84 CALL wrk_alloc( jpi,jpj,jpk,jpts, zlu_uu, zlv_vv, zlu_uv, zlv_vu ) 81 IF( ln_timing ) CALL timing_start('dyn_adv_ubs') 85 82 ! 86 83 IF( kt == nit000 ) THEN … … 241 238 & tab3d_2=va, clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) 242 239 ! 243 CALL wrk_dealloc( jpi,jpj,jpk, zfu_t , zfv_t , zfu_f , zfv_f, zfu_uw, zfv_vw, zfu, zfv, zfw ) 244 CALL wrk_dealloc( jpi,jpj,jpk,jpts, zlu_uu, zlv_vv, zlu_uv, zlv_vu ) 245 ! 246 IF( nn_timing == 1 ) CALL timing_stop('dyn_adv_ubs') 240 IF( ln_timing ) CALL timing_stop('dyn_adv_ubs') 247 241 ! 248 242 END SUBROUTINE dyn_adv_ubs -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/DYN/dynbfr.F90
r8367 r8568 57 57 !!--------------------------------------------------------------------- 58 58 ! 59 IF( nn_timing == 1 )CALL timing_start('dyn_bfr')59 IF( ln_timing ) CALL timing_start('dyn_bfr') 60 60 ! 61 61 !!gm bug : time step is only rdt (not 2 rdt if euler start !) … … 109 109 & tab3d_2=va, clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) 110 110 ! 111 IF( nn_timing == 1 )CALL timing_stop('dyn_bfr')111 IF( ln_timing ) CALL timing_stop('dyn_bfr') 112 112 ! 113 113 END SUBROUTINE dyn_bfr -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/DYN/dynhpg.F90
r8367 r8568 44 44 USE lib_mpp ! MPP library 45 45 USE eosbn2 ! compute density 46 USE wrk_nemo ! Memory Allocation47 46 USE timing ! Timing 48 47 USE iom … … 84 83 !!---------------------------------------------------------------------- 85 84 INTEGER, INTENT(in) :: kt ! ocean time-step index 86 REAL(wp), POINTER, DIMENSION(:,:,:) ::ztrdu, ztrdv87 !!---------------------------------------------------------------------- 88 ! 89 IF( nn_timing == 1 )CALL timing_start('dyn_hpg')85 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdu, ztrdv 86 !!---------------------------------------------------------------------- 87 ! 88 IF( ln_timing ) CALL timing_start('dyn_hpg') 90 89 ! 91 90 IF( l_trddyn ) THEN ! Temporary saving of ua and va trends (l_trddyn) 92 CALL wrk_alloc( jpi,jpj,jpk, ztrdu, ztrdv)91 ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) ) 93 92 ztrdu(:,:,:) = ua(:,:,:) 94 93 ztrdv(:,:,:) = va(:,:,:) … … 108 107 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 109 108 CALL trd_dyn( ztrdu, ztrdv, jpdyn_hpg, kt ) 110 CALL wrk_dealloc( jpi,jpj,jpk, ztrdu, ztrdv )109 DEALLOCATE( ztrdu , ztrdv ) 111 110 ENDIF 112 111 ! … … 114 113 & tab3d_2=va, clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) 115 114 ! 116 IF( nn_timing == 1 )CALL timing_stop('dyn_hpg')115 IF( ln_timing ) CALL timing_stop('dyn_hpg') 117 116 ! 118 117 END SUBROUTINE dyn_hpg … … 134 133 INTEGER :: ji, jj, jk, ikt ! dummy loop indices ISF 135 134 REAL(wp) :: znad 136 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztstop, zrhd! hypothesys on isf density137 REAL(wp), POINTER, DIMENSION(:,:) :: zrhdtop_isf! density at bottom of ISF138 REAL(wp), POINTER, DIMENSION(:,:) :: ziceload! density at bottom of ISF135 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zts_top, zrhd ! hypothesys on isf density 136 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zrhdtop_isf ! density at bottom of ISF 137 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: ziceload ! density at bottom of ISF 139 138 !! 140 139 NAMELIST/namdyn_hpg/ ln_hpg_zco, ln_hpg_zps, ln_hpg_sco, & … … 165 164 ! 166 165 IF( ln_hpg_djc ) & 167 & CALL ctl_stop('dyn_hpg_init : Density Jacobian: Cubic polynominal method & 168 & currently disabled (bugs under investigation). Please select & 169 & either ln_hpg_sco or ln_hpg_prj instead') 170 ! 171 IF( .NOT.ln_linssh .AND. .NOT.(ln_hpg_sco.OR.ln_hpg_prj.OR.ln_hpg_isf) ) & 172 & CALL ctl_stop('dyn_hpg_init : non-linear free surface requires either ', & 173 & ' the standard jacobian formulation hpg_sco or ' , & 174 & ' the pressure jacobian formulation hpg_prj' ) 175 176 IF( ln_hpg_isf .AND. .NOT. ln_isfcav ) & 177 & CALL ctl_stop( ' hpg_isf not available if ln_isfcav = false ' ) 178 IF( .NOT. ln_hpg_isf .AND. ln_isfcav ) & 179 & CALL ctl_stop( 'Only hpg_isf has been corrected to work with ice shelf cavity.' ) 166 & CALL ctl_stop('dyn_hpg_init : Density Jacobian: Cubic polynominal method', & 167 & ' currently disabled (bugs under investigation).' , & 168 & ' Please select either ln_hpg_sco or ln_hpg_prj instead' ) 169 ! 170 IF( .NOT.ln_linssh .AND. .NOT.(ln_hpg_sco.OR.ln_hpg_prj.OR.ln_hpg_isf) ) & 171 & CALL ctl_stop('dyn_hpg_init : non-linear free surface requires either ', & 172 & ' the standard jacobian formulation hpg_sco or ' , & 173 & ' the pressure jacobian formulation hpg_prj' ) 174 ! 175 IF( ln_hpg_isf ) THEN 176 IF( .NOT. ln_isfcav ) CALL ctl_stop( ' hpg_isf not available if ln_isfcav = false ' ) 177 ELSE 178 IF( ln_isfcav ) CALL ctl_stop( 'Only hpg_isf has been corrected to work with ice shelf cavity.' ) 179 ENDIF 180 180 ! 181 181 ! ! Set nhpg from ln_hpg_... flags … … 197 197 IF( ioptio /= 1 ) CALL ctl_stop( 'NO or several hydrostatic pressure gradient options used' ) 198 198 ! 199 ! initialisation of ice shelf load 200 IF ( .NOT. ln_isfcav ) riceload(:,:)=0.0 201 IF ( ln_isfcav ) THEN 202 CALL wrk_alloc( jpi,jpj, 2, ztstop) 203 CALL wrk_alloc( jpi,jpj,jpk, zrhd ) 204 CALL wrk_alloc( jpi,jpj, zrhdtop_isf, ziceload) 199 ! 200 IF ( .NOT. ln_isfcav ) THEN !--- no ice shelf load 201 riceload(:,:) = 0._wp 202 ! 203 ELSE !--- set an ice shelf load 205 204 ! 206 205 IF(lwp) WRITE(numout,*) 207 IF(lwp) WRITE(numout,*) 'dyn:hpg_isf : hydrostatic pressure gradient trend for ice shelf' 208 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 209 210 ! To use density and not density anomaly 211 znad=1._wp 212 213 ! assume water displaced by the ice shelf is at T=-1.9 and S=34.4 (rude) 214 ztstop(:,:,1)=-1.9_wp ; ztstop(:,:,2)=34.4_wp 215 216 ! compute density of the water displaced by the ice shelf 217 DO jk = 1, jpk 218 CALL eos(ztstop(:,:,:),gdept_n(:,:,jk),zrhd(:,:,jk)) 219 END DO 220 221 ! compute rhd at the ice/oce interface (ice shelf side) 222 CALL eos(ztstop,risfdep,zrhdtop_isf) 223 224 ! Surface value + ice shelf gradient 225 ! compute pressure due to ice shelf load (used to compute hpgi/j for all the level from 1 to miku/v) 226 ! divided by 2 later 227 ziceload = 0._wp 228 DO jj = 1, jpj 229 DO ji = 1, jpi 230 ikt=mikt(ji,jj) 206 IF(lwp) WRITE(numout,*) ' ice shelf case: set the ice-shelf load' 207 ALLOCATE( zts_top(jpi,jpj,jpts) , zrhd(jpi,jpj,jpk) , zrhdtop_isf(jpi,jpj) , ziceload(jpi,jpj) ) 208 ! 209 znad = 1._wp !- To use density and not density anomaly 210 ! 211 ! !- assume water displaced by the ice shelf is at T=-1.9 and S=34.4 (rude) 212 zts_top(:,:,jp_tem) = -1.9_wp ; zts_top(:,:,jp_sal) = 34.4_wp 213 ! 214 DO jk = 1, jpk !- compute density of the water displaced by the ice shelf 215 CALL eos( zts_top(:,:,:), gdept_n(:,:,jk), zrhd(:,:,jk) ) 216 END DO 217 ! 218 ! !- compute rhd at the ice/oce interface (ice shelf side) 219 CALL eos( zts_top , risfdep, zrhdtop_isf ) 220 ! 221 ! !- Surface value + ice shelf gradient 222 ziceload = 0._wp ! compute pressure due to ice shelf load 223 DO jj = 1, jpj ! (used to compute hpgi/j for all the level from 1 to miku/v) 224 DO ji = 1, jpi ! divided by 2 later 225 ikt = mikt(ji,jj) 231 226 ziceload(ji,jj) = ziceload(ji,jj) + (znad + zrhd(ji,jj,1) ) * e3w_n(ji,jj,1) * (1._wp - tmask(ji,jj,1)) 232 DO jk =2,ikt-1227 DO jk = 2, ikt-1 233 228 ziceload(ji,jj) = ziceload(ji,jj) + (2._wp * znad + zrhd(ji,jj,jk-1) + zrhd(ji,jj,jk)) * e3w_n(ji,jj,jk) & 234 229 & * (1._wp - tmask(ji,jj,jk)) 235 230 END DO 236 231 IF (ikt >= 2) ziceload(ji,jj) = ziceload(ji,jj) + (2._wp * znad + zrhdtop_isf(ji,jj) + zrhd(ji,jj,ikt-1)) & 237 & * ( risfdep(ji,jj) - gdept_1d(ikt-1) ) 238 END DO 239 END DO 240 riceload(:,:)=ziceload(:,:) ! need to be saved for diaar5 241 242 CALL wrk_dealloc( jpi,jpj, 2, ztstop) 243 CALL wrk_dealloc( jpi,jpj,jpk, zrhd ) 244 CALL wrk_dealloc( jpi,jpj, zrhdtop_isf, ziceload) 245 END IF 232 & * ( risfdep(ji,jj) - gdept_1d(ikt-1) ) 233 END DO 234 END DO 235 riceload(:,:) = ziceload(:,:) ! need to be saved for diaar5 236 ! 237 DEALLOCATE( zts_top , zrhd , zrhdtop_isf , ziceload ) 238 ENDIF 246 239 ! 247 240 END SUBROUTINE dyn_hpg_init … … 268 261 INTEGER :: ji, jj, jk ! dummy loop indices 269 262 REAL(wp) :: zcoef0, zcoef1 ! temporary scalars 270 REAL(wp), POINTER, DIMENSION(:,:,:) :: zhpi, zhpj 271 !!---------------------------------------------------------------------- 272 ! 273 CALL wrk_alloc( jpi,jpj,jpk, zhpi, zhpj ) 263 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zhpi, zhpj 264 !!---------------------------------------------------------------------- 274 265 ! 275 266 IF( kt == nit000 ) THEN … … 315 306 END DO 316 307 ! 317 CALL wrk_dealloc( jpi,jpj,jpk, zhpi, zhpj )318 !319 308 END SUBROUTINE hpg_zco 320 309 … … 333 322 INTEGER :: iku, ikv ! temporary integers 334 323 REAL(wp) :: zcoef0, zcoef1, zcoef2, zcoef3 ! temporary scalars 335 REAL(wp), POINTER, DIMENSION(:,:,:) :: zhpi, zhpj 336 !!---------------------------------------------------------------------- 337 ! 338 CALL wrk_alloc( jpi,jpj,jpk, zhpi, zhpj ) 324 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zhpi, zhpj 325 !!---------------------------------------------------------------------- 339 326 ! 340 327 IF( kt == nit000 ) THEN … … 405 392 END DO 406 393 ! 407 CALL wrk_dealloc( jpi,jpj,jpk, zhpi, zhpj )408 !409 394 END SUBROUTINE hpg_zps 410 395 … … 433 418 REAL(wp) :: zcoef0, zuap, zvap, znad, ztmp ! temporary scalars 434 419 LOGICAL :: ll_tmp1, ll_tmp2 ! local logical variables 435 REAL(wp), POINTER, DIMENSION(:,:,:) :: zhpi, zhpj 436 REAL(wp), POINTER, DIMENSION(:,:) :: zcpx, zcpy !W/D pressure filter 437 !!---------------------------------------------------------------------- 438 ! 439 CALL wrk_alloc( jpi,jpj,jpk, zhpi, zhpj ) 440 IF( ln_wd ) CALL wrk_alloc( jpi,jpj, zcpx, zcpy ) 420 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zhpi, zhpj 421 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zcpx, zcpy !W/D pressure filter 422 !!---------------------------------------------------------------------- 441 423 ! 442 424 IF( kt == nit000 ) THEN … … 452 434 ! 453 435 IF( ln_wd ) THEN 454 DO jj = 2, jpjm1 455 DO ji = 2, jpim1 456 ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji+1,jj) ) > & 436 ALLOCATE( zcpx(jpi,jpj) , zcpy(jpi,jpj) ) 437 DO jj = 2, jpjm1 438 DO ji = 2, jpim1 439 ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji+1,jj) ) > & 457 440 & MAX( -ht_wd(ji,jj) , -ht_wd(ji+1,jj) ) .AND. & 458 441 & MAX( sshn(ji,jj) + ht_wd(ji,jj), sshn(ji+1,jj) + ht_wd(ji+1,jj) ) & 459 442 & > rn_wdmin1 + rn_wdmin2 460 ll_tmp2 = ( ABS( sshn(ji,jj) - sshn(ji+1,jj) ) > 1.E-12 ) .AND. ( &443 ll_tmp2 = ( ABS( sshn(ji,jj) - sshn(ji+1,jj) ) > 1.E-12 ) .AND. ( & 461 444 & MAX( sshn(ji,jj) , sshn(ji+1,jj) ) > & 462 445 & MAX( -ht_wd(ji,jj) , -ht_wd(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 ) 463 446 464 IF(ll_tmp1) THEN465 zcpx(ji,jj) = 1.0_wp466 ELSE IF(ll_tmp2) THEN467 ! no worries about sshn(ji+1,jj) - sshn(ji ,jj) = 0, it won't happen ! here468 zcpx(ji,jj) = ABS( (sshn(ji+1,jj) + ht_wd(ji+1,jj) - sshn(ji,jj) - ht_wd(ji,jj))&469 & / (sshn(ji+1,jj) - sshn(ji ,jj)))470 ELSE471 zcpx(ji,jj) = 0._wp472 ENDIF473 474 ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji,jj+1) ) > &447 IF(ll_tmp1) THEN 448 zcpx(ji,jj) = 1.0_wp 449 ELSE IF(ll_tmp2) THEN 450 ! no worries about sshn(ji+1,jj) - sshn(ji ,jj) = 0, it won't happen ! here 451 zcpx(ji,jj) = ABS( ( sshn(ji+1,jj)+ht_wd(ji+1,jj) - sshn(ji,jj)-ht_wd(ji,jj) ) & 452 & / ( sshn(ji+1,jj) - sshn(ji,jj) ) ) 453 ELSE 454 zcpx(ji,jj) = 0._wp 455 ENDIF 456 ! 457 ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji,jj+1) ) > & 475 458 & MAX( -ht_wd(ji,jj) , -ht_wd(ji,jj+1) ) .AND. & 476 459 & MAX( sshn(ji,jj) + ht_wd(ji,jj), sshn(ji,jj+1) + ht_wd(ji,jj+1) ) & 477 460 & > rn_wdmin1 + rn_wdmin2 478 ll_tmp2 = ( ABS( sshn(ji,jj) - sshn(ji,jj+1) ) > 1.E-12 ) .AND. ( &461 ll_tmp2 = ( ABS( sshn(ji,jj) - sshn(ji,jj+1) ) > 1.E-12 ) .AND. ( & 479 462 & MAX( sshn(ji,jj) , sshn(ji,jj+1) ) > & 480 463 & MAX( -ht_wd(ji,jj) , -ht_wd(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 ) 481 482 IF(ll_tmp1) THEN483 zcpy(ji,jj) = 1.0_wp484 ELSE IF(ll_tmp2) THEN485 ! no worries about sshn(ji,jj+1) - sshn(ji,jj ) = 0, it won't happen ! here486 zcpy(ji,jj) = ABS( (sshn(ji,jj+1) + ht_wd(ji,jj+1) - sshn(ji,jj) - ht_wd(ji,jj))&487 & / (sshn(ji,jj+1) - sshn(ji,jj )))488 ELSE489 zcpy(ji,jj) = 0._wp490 ENDIF491 END DO492 END DO493 CALL lbc_lnk( zcpx, 'U', 1._wp ) ; CALL lbc_lnk( zcpy, 'V', 1._wp )494 END 464 ! 465 IF(ll_tmp1) THEN 466 zcpy(ji,jj) = 1.0_wp 467 ELSE IF(ll_tmp2) THEN 468 ! no worries about sshn(ji,jj+1) - sshn(ji,jj ) = 0, it won't happen ! here 469 zcpy(ji,jj) = ABS( ( sshn(ji,jj+1)+ht_wd(ji,jj+1) - sshn(ji,jj) - ht_wd(ji,jj) ) & 470 & / ( sshn(ji,jj+1) - sshn(ji,jj) ) ) 471 ELSE 472 zcpy(ji,jj) = 0._wp 473 ENDIF 474 END DO 475 END DO 476 CALL lbc_lnk( zcpx, 'U', 1._wp ) ; CALL lbc_lnk( zcpy, 'V', 1._wp ) 477 ENDIF 495 478 496 479 ! Surface value … … 507 490 zvap = -zcoef0 * ( rhd (ji,jj+1,1) + rhd (ji,jj,1) + 2._wp * znad ) & 508 491 & * ( gde3w_n(ji,jj+1,1) - gde3w_n(ji,jj,1) ) * r1_e2v(ji,jj) 509 510 492 ! 511 493 IF( ln_wd ) THEN 512 513 zhpi(ji,jj,1) = zhpi(ji,jj,1) * zcpx(ji,jj) 514 zhpj(ji,jj,1) = zhpj(ji,jj,1) * zcpy(ji,jj) 515 zuap = zuap * zcpx(ji,jj) 516 zvap = zvap * zcpy(ji,jj) 494 zhpi(ji,jj,1) = zhpi(ji,jj,1) * zcpx(ji,jj) 495 zhpj(ji,jj,1) = zhpj(ji,jj,1) * zcpy(ji,jj) 496 zuap = zuap * zcpx(ji,jj) 497 zvap = zvap * zcpy(ji,jj) 517 498 ENDIF 518 499 ! 519 500 ! add to the general momentum trend 520 501 ua(ji,jj,1) = ua(ji,jj,1) + zhpi(ji,jj,1) + zuap … … 539 520 zvap = -zcoef0 * ( rhd (ji ,jj+1,jk) + rhd (ji,jj,jk) + 2._wp * znad ) & 540 521 & * ( gde3w_n(ji ,jj+1,jk) - gde3w_n(ji,jj,jk) ) * r1_e2v(ji,jj) 541 522 ! 542 523 IF( ln_wd ) THEN 543 zhpi(ji,jj,jk) = zhpi(ji,jj,jk) * zcpx(ji,jj)544 zhpj(ji,jj,jk) = zhpj(ji,jj,jk) * zcpy(ji,jj)545 zuap = zuap * zcpx(ji,jj)546 zvap = zvap * zcpy(ji,jj)547 ENDIF 548 524 zhpi(ji,jj,jk) = zhpi(ji,jj,jk) * zcpx(ji,jj) 525 zhpj(ji,jj,jk) = zhpj(ji,jj,jk) * zcpy(ji,jj) 526 zuap = zuap * zcpx(ji,jj) 527 zvap = zvap * zcpy(ji,jj) 528 ENDIF 529 ! 549 530 ! add to the general momentum trend 550 531 ua(ji,jj,jk) = ua(ji,jj,jk) + zhpi(ji,jj,jk) + zuap … … 554 535 END DO 555 536 ! 556 CALL wrk_dealloc( jpi,jpj,jpk, zhpi, zhpj ) 557 IF( ln_wd ) CALL wrk_dealloc( jpi,jpj, zcpx, zcpy ) 537 IF( ln_wd ) DEALLOCATE( zcpx , zcpy ) 558 538 ! 559 539 END SUBROUTINE hpg_sco … … 583 563 INTEGER :: ji, jj, jk, ikt, iktp1i, iktp1j ! dummy loop indices 584 564 REAL(wp) :: zcoef0, zuap, zvap, znad ! temporary scalars 585 REAL(wp), POINTER, DIMENSION(:,:,:) :: zhpi, zhpj 586 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztstop 587 REAL(wp), POINTER, DIMENSION(:,:) :: zrhdtop_oce 588 !!---------------------------------------------------------------------- 589 ! 590 CALL wrk_alloc( jpi,jpj, 2, ztstop) 591 CALL wrk_alloc( jpi,jpj,jpk, zhpi, zhpj) 592 CALL wrk_alloc( jpi,jpj, zrhdtop_oce ) 593 ! 594 ! Local constant initialization 595 zcoef0 = - grav * 0.5_wp 596 597 ! To use density and not density anomaly 598 znad=1._wp 599 600 ! iniitialised to 0. zhpi zhpi 601 zhpi(:,:,:)=0._wp ; zhpj(:,:,:)=0._wp 565 REAL(wp), DIMENSION(jpi,jpj,jpk ) :: zhpi, zhpj 566 REAL(wp), DIMENSION(jpi,jpj,jpts) :: zts_top 567 REAL(wp), DIMENSION(jpi,jpj) :: zrhdtop_oce 568 !!---------------------------------------------------------------------- 569 ! 570 zcoef0 = - grav * 0.5_wp ! Local constant initialization 571 ! 572 znad=1._wp ! To use density and not density anomaly 573 ! 574 ! ! iniitialised to 0. zhpi zhpi 575 zhpi(:,:,:) = 0._wp ; zhpj(:,:,:) = 0._wp 602 576 603 577 ! compute rhd at the ice/oce interface (ocean side) 604 578 ! usefull to reduce residual current in the test case ISOMIP with no melting 605 DO ji =1,jpi606 DO jj =1,jpj607 ikt =mikt(ji,jj)608 zts top(ji,jj,1)=tsn(ji,jj,ikt,1)609 zts top(ji,jj,2)=tsn(ji,jj,ikt,2)579 DO ji = 1, jpi 580 DO jj = 1, jpj 581 ikt = mikt(ji,jj) 582 zts_top(ji,jj,1) = tsn(ji,jj,ikt,1) 583 zts_top(ji,jj,2) = tsn(ji,jj,ikt,2) 610 584 END DO 611 585 END DO 612 CALL eos( zts top, risfdep, zrhdtop_oce )586 CALL eos( zts_top, risfdep, zrhdtop_oce ) 613 587 614 588 !================================================================================== … … 667 641 END DO 668 642 END DO 669 !670 CALL wrk_dealloc( jpi,jpj,2 , ztstop)671 CALL wrk_dealloc( jpi,jpj,jpk, zhpi, zhpj)672 CALL wrk_dealloc( jpi,jpj , zrhdtop_oce )673 643 ! 674 644 END SUBROUTINE hpg_isf … … 690 660 REAL(wp) :: z1_12, cffv, cffy ! " " 691 661 LOGICAL :: ll_tmp1, ll_tmp2 ! local logical variables 692 REAL(wp), POINTER, DIMENSION(:,:,:) :: zhpi, zhpj 693 REAL(wp), POINTER, DIMENSION(:,:,:) :: dzx, dzy, dzz, dzu, dzv, dzw 694 REAL(wp), POINTER, DIMENSION(:,:,:) :: drhox, drhoy, drhoz, drhou, drhov, drhow 695 REAL(wp), POINTER, DIMENSION(:,:,:) :: rho_i, rho_j, rho_k 696 REAL(wp), POINTER, DIMENSION(:,:) :: zcpx, zcpy !W/D pressure filter 697 !!---------------------------------------------------------------------- 698 ! 699 CALL wrk_alloc( jpi, jpj, jpk, dzx , dzy , dzz , dzu , dzv , dzw ) 700 CALL wrk_alloc( jpi, jpj, jpk, drhox, drhoy, drhoz, drhou, drhov, drhow ) 701 CALL wrk_alloc( jpi, jpj, jpk, rho_i, rho_j, rho_k, zhpi, zhpj ) 702 IF( ln_wd ) CALL wrk_alloc( jpi,jpj, zcpx, zcpy ) 703 ! 662 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zhpi, zhpj 663 REAL(wp), DIMENSION(jpi,jpj,jpk) :: dzx, dzy, dzz, dzu, dzv, dzw 664 REAL(wp), DIMENSION(jpi,jpj,jpk) :: drhox, drhoy, drhoz, drhou, drhov, drhow 665 REAL(wp), DIMENSION(jpi,jpj,jpk) :: rho_i, rho_j, rho_k 666 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zcpx, zcpy !W/D pressure filter 667 !!---------------------------------------------------------------------- 704 668 ! 705 669 IF( ln_wd ) THEN 706 DO jj = 2, jpjm1 707 DO ji = 2, jpim1 708 ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji+1,jj) ) > & 670 ALLOCATE( zcpx(jpi,jpj) , zcpy(jpi,jpj) ) 671 DO jj = 2, jpjm1 672 DO ji = 2, jpim1 673 ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji+1,jj) ) > & 709 674 & MAX( -ht_wd(ji,jj) , -ht_wd(ji+1,jj) ) .AND. & 710 675 & MAX( sshn(ji,jj) + ht_wd(ji,jj), sshn(ji+1,jj) + ht_wd(ji+1,jj) ) & 711 676 & > rn_wdmin1 + rn_wdmin2 712 ll_tmp2 = ( ABS( sshn(ji,jj) - sshn(ji+1,jj) ) > 1.E-12 ) .AND. ( &677 ll_tmp2 = ( ABS( sshn(ji,jj) - sshn(ji+1,jj) ) > 1.E-12 ) .AND. ( & 713 678 & MAX( sshn(ji,jj) , sshn(ji+1,jj) ) > & 714 679 & MAX( -ht_wd(ji,jj) , -ht_wd(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 ) 715 680 716 IF(ll_tmp1) THEN717 zcpx(ji,jj) = 1.0_wp718 ELSE IF(ll_tmp2) THEN719 ! no worries about sshn(ji+1,jj) - sshn(ji ,jj) = 0, it won't happen ! here720 zcpx(ji,jj) = ABS( (sshn(ji+1,jj) + ht_wd(ji+1,jj) - sshn(ji,jj) - ht_wd(ji,jj)) &721 & / (sshn(ji+1,jj) - sshn(ji ,jj)) )722 ELSE723 zcpx(ji,jj) = 0._wp724 ENDIF681 IF(ll_tmp1) THEN 682 zcpx(ji,jj) = 1.0_wp 683 ELSE IF(ll_tmp2) THEN 684 ! no worries about sshn(ji+1,jj) - sshn(ji ,jj) = 0, it won't happen ! here 685 zcpx(ji,jj) = ABS( (sshn(ji+1,jj) + ht_wd(ji+1,jj) - sshn(ji,jj) - ht_wd(ji,jj)) & 686 & / (sshn(ji+1,jj) - sshn(ji ,jj)) ) 687 ELSE 688 zcpx(ji,jj) = 0._wp 689 ENDIF 725 690 726 ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji,jj+1) ) > &691 ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji,jj+1) ) > & 727 692 & MAX( -ht_wd(ji,jj) , -ht_wd(ji,jj+1) ) .AND. & 728 693 & MAX( sshn(ji,jj) + ht_wd(ji,jj), sshn(ji,jj+1) + ht_wd(ji,jj+1) ) & 729 694 & > rn_wdmin1 + rn_wdmin2 730 ll_tmp2 = ( ABS( sshn(ji,jj) - sshn(ji,jj+1) ) > 1.E-12 ) .AND. ( &695 ll_tmp2 = ( ABS( sshn(ji,jj) - sshn(ji,jj+1) ) > 1.E-12 ) .AND. ( & 731 696 & MAX( sshn(ji,jj) , sshn(ji,jj+1) ) > & 732 697 & MAX( -ht_wd(ji,jj) , -ht_wd(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 ) 733 698 734 IF(ll_tmp1) THEN735 zcpy(ji,jj) = 1.0_wp736 ELSE IF(ll_tmp2) THEN737 ! no worries about sshn(ji,jj+1) - sshn(ji,jj ) = 0, it won't happen ! here738 zcpy(ji,jj) = ABS( (sshn(ji,jj+1) + ht_wd(ji,jj+1) - sshn(ji,jj) - ht_wd(ji,jj)) &739 & / (sshn(ji,jj+1) - sshn(ji,jj )) )740 ELSE741 zcpy(ji,jj) = 0._wp742 ENDIF743 END DO744 END DO745 CALL lbc_lnk( zcpx, 'U', 1._wp ) ; CALL lbc_lnk( zcpy, 'V', 1._wp )746 END 699 IF(ll_tmp1) THEN 700 zcpy(ji,jj) = 1.0_wp 701 ELSE IF(ll_tmp2) THEN 702 ! no worries about sshn(ji,jj+1) - sshn(ji,jj ) = 0, it won't happen ! here 703 zcpy(ji,jj) = ABS( (sshn(ji,jj+1) + ht_wd(ji,jj+1) - sshn(ji,jj) - ht_wd(ji,jj)) & 704 & / (sshn(ji,jj+1) - sshn(ji,jj )) ) 705 ELSE 706 zcpy(ji,jj) = 0._wp 707 ENDIF 708 END DO 709 END DO 710 CALL lbc_lnk( zcpx, 'U', 1._wp ) ; CALL lbc_lnk( zcpy, 'V', 1._wp ) 711 ENDIF 747 712 748 713 IF( kt == nit000 ) THEN … … 903 868 END DO 904 869 END DO 905 CALL lbc_lnk( rho_k,'W',1.)906 CALL lbc_lnk( rho_i,'U',1.)907 CALL lbc_lnk( rho_j,'V',1.)870 CALL lbc_lnk( rho_k, 'W', 1. ) 871 CALL lbc_lnk( rho_i, 'U', 1. ) 872 CALL lbc_lnk( rho_j, 'V', 1. ) 908 873 909 874 … … 949 914 END DO 950 915 ! 951 CALL wrk_dealloc( jpi, jpj, jpk, dzx , dzy , dzz , dzu , dzv , dzw ) 952 CALL wrk_dealloc( jpi, jpj, jpk, drhox, drhoy, drhoz, drhou, drhov, drhow ) 953 CALL wrk_dealloc( jpi, jpj, jpk, rho_i, rho_j, rho_k, zhpi, zhpj ) 954 IF( ln_wd ) CALL wrk_dealloc( jpi,jpj, zcpx, zcpy ) 916 IF( ln_wd ) DEALLOCATE( zcpx, zcpy ) 955 917 ! 956 918 END SUBROUTINE hpg_djc … … 980 942 REAL(wp) :: zrhdt1 981 943 REAL(wp) :: zdpdx1, zdpdx2, zdpdy1, zdpdy2 982 REAL(wp), POINTER, DIMENSION(:,:,:) :: zdept, zrhh 983 REAL(wp), POINTER, DIMENSION(:,:,:) :: zhpi, zu, zv, fsp, xsp, asp, bsp, csp, dsp 984 REAL(wp), POINTER, DIMENSION(:,:) :: zsshu_n, zsshv_n 985 REAL(wp), POINTER, DIMENSION(:,:) :: zcpx, zcpy !W/D pressure filter 986 !!---------------------------------------------------------------------- 987 ! 988 CALL wrk_alloc( jpi,jpj,jpk, zhpi, zu, zv, fsp, xsp, asp, bsp, csp, dsp ) 989 CALL wrk_alloc( jpi,jpj,jpk, zdept, zrhh ) 990 CALL wrk_alloc( jpi,jpj, zsshu_n, zsshv_n ) 991 IF( ln_wd ) CALL wrk_alloc( jpi,jpj, zcpx, zcpy ) 944 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdept, zrhh 945 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zhpi, zu, zv, fsp, xsp, asp, bsp, csp, dsp 946 REAL(wp), DIMENSION(jpi,jpj) :: zsshu_n, zsshv_n 947 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zcpx, zcpy !W/D pressure filter 948 !!---------------------------------------------------------------------- 992 949 ! 993 950 IF( kt == nit000 ) THEN … … 1003 960 1004 961 IF( ln_wd ) THEN 1005 DO jj = 2, jpjm1 1006 DO ji = 2, jpim1 1007 ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji+1,jj) ) > & 962 ALLOCATE( zcpx(jpi,jpj) , zcpy(jpi,jpj) ) 963 DO jj = 2, jpjm1 964 DO ji = 2, jpim1 965 ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji+1,jj) ) > & 1008 966 & MAX( -ht_wd(ji,jj) , -ht_wd(ji+1,jj) ) .AND. & 1009 967 & MAX( sshn(ji,jj) + ht_wd(ji,jj), sshn(ji+1,jj) + ht_wd(ji+1,jj) ) & 1010 968 & > rn_wdmin1 + rn_wdmin2 1011 ll_tmp2 = ( ABS( sshn(ji,jj) - sshn(ji+1,jj) ) > 1.E-12 ) .AND. ( &969 ll_tmp2 = ( ABS( sshn(ji,jj) - sshn(ji+1,jj) ) > 1.E-12 ) .AND. ( & 1012 970 & MAX( sshn(ji,jj) , sshn(ji+1,jj) ) > & 1013 971 & MAX( -ht_wd(ji,jj) , -ht_wd(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 ) 1014 972 1015 IF(ll_tmp1) THEN1016 zcpx(ji,jj) = 1.0_wp1017 ELSE IF(ll_tmp2) THEN1018 ! no worries about sshn(ji+1,jj) - sshn(ji ,jj) = 0, it won't happen ! here1019 zcpx(ji,jj) = ABS( (sshn(ji+1,jj) + ht_wd(ji+1,jj) - sshn(ji,jj) - ht_wd(ji,jj)) &1020 & / (sshn(ji+1,jj) - sshn(ji ,jj)) )1021 ELSE1022 zcpx(ji,jj) = 0._wp1023 ENDIF973 IF(ll_tmp1) THEN 974 zcpx(ji,jj) = 1.0_wp 975 ELSE IF(ll_tmp2) THEN 976 ! no worries about sshn(ji+1,jj) - sshn(ji ,jj) = 0, it won't happen ! here 977 zcpx(ji,jj) = ABS( (sshn(ji+1,jj) + ht_wd(ji+1,jj) - sshn(ji,jj) - ht_wd(ji,jj)) & 978 & / (sshn(ji+1,jj) - sshn(ji ,jj)) ) 979 ELSE 980 zcpx(ji,jj) = 0._wp 981 ENDIF 1024 982 1025 ll_tmp1 = MIN( sshn(ji,jj), sshn(ji,jj+1) ) > &983 ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji,jj+1) ) > & 1026 984 & MAX( -ht_wd(ji,jj) , -ht_wd(ji,jj+1) ) .AND. & 1027 985 & MAX( sshn(ji,jj) + ht_wd(ji,jj), sshn(ji,jj+1) + ht_wd(ji,jj+1) ) & 1028 986 & > rn_wdmin1 + rn_wdmin2 1029 ll_tmp2 = ( ABS( sshn(ji,jj)- sshn(ji,jj+1) ) > 1.E-12 ) .AND. ( &987 ll_tmp2 = ( ABS( sshn(ji,jj) - sshn(ji,jj+1) ) > 1.E-12 ) .AND. ( & 1030 988 & MAX( sshn(ji,jj) , sshn(ji,jj+1) ) > & 1031 989 & MAX( -ht_wd(ji,jj) , -ht_wd(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 ) 1032 990 1033 IF(ll_tmp1) THEN1034 zcpy(ji,jj) = 1.0_wp1035 ELSE IF(ll_tmp2) THEN1036 ! no worries about sshn(ji,jj+1) - sshn(ji,jj ) = 0, it won't happen ! here1037 zcpy(ji,jj) = ABS( (sshn(ji,jj+1) + ht_wd(ji,jj+1) - sshn(ji,jj) - ht_wd(ji,jj)) &991 IF(ll_tmp1) THEN 992 zcpy(ji,jj) = 1.0_wp 993 ELSE IF(ll_tmp2) THEN 994 ! no worries about sshn(ji,jj+1) - sshn(ji,jj ) = 0, it won't happen ! here 995 zcpy(ji,jj) = ABS( (sshn(ji,jj+1) + ht_wd(ji,jj+1) - sshn(ji,jj) - ht_wd(ji,jj)) & 1038 996 & / (sshn(ji,jj+1) - sshn(ji,jj )) ) 1039 ELSE1040 zcpy(ji,jj) = 0._wp1041 ENDIF1042 END DO1043 END DO1044 CALL lbc_lnk( zcpx, 'U', 1._wp ) ; CALL lbc_lnk( zcpy, 'V', 1._wp )1045 END 997 ELSE 998 zcpy(ji,jj) = 0._wp 999 ENDIF 1000 END DO 1001 END DO 1002 CALL lbc_lnk( zcpx, 'U', 1._wp ) ; CALL lbc_lnk( zcpy, 'V', 1._wp ) 1003 ENDIF 1046 1004 1047 1005 ! Clean 3-D work arrays … … 1298 1256 END DO 1299 1257 ! 1300 CALL wrk_dealloc( jpi,jpj,jpk, zhpi, zu, zv, fsp, xsp, asp, bsp, csp, dsp ) 1301 CALL wrk_dealloc( jpi,jpj,jpk, zdept, zrhh ) 1302 CALL wrk_dealloc( jpi,jpj, zsshu_n, zsshv_n ) 1303 IF( ln_wd ) CALL wrk_dealloc( jpi,jpj, zcpx, zcpy ) 1258 IF( ln_wd ) DEALLOCATE( zcpx, zcpy ) 1304 1259 ! 1305 1260 END SUBROUTINE hpg_prj … … 1353 1308 !!Simply geometric average 1354 1309 DO jk = 2, jpkm1-1 1355 zdf1 = (fsp(ji,jj,jk ) - fsp(ji,jj,jk-1)) / (xsp(ji,jj,jk) - xsp(ji,jj,jk-1))1356 zdf2 = (fsp(ji,jj,jk+1) - fsp(ji,jj,jk )) / (xsp(ji,jj,jk+1) - xsp(ji,jj,jk))1310 zdf1 = (fsp(ji,jj,jk ) - fsp(ji,jj,jk-1)) / (xsp(ji,jj,jk ) - xsp(ji,jj,jk-1)) 1311 zdf2 = (fsp(ji,jj,jk+1) - fsp(ji,jj,jk )) / (xsp(ji,jj,jk+1) - xsp(ji,jj,jk )) 1357 1312 1358 1313 IF(zdf1 * zdf2 <= 0._wp) THEN … … 1403 1358 END DO 1404 1359 END DO 1405 1360 ! 1406 1361 ELSE 1407 1408 ENDIF 1409 1362 CALL ctl_stop( 'invalid polynomial type in cspline' ) 1363 ENDIF 1364 ! 1410 1365 END SUBROUTINE cspline 1411 1366 -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/DYN/dynkeg.F90
r7753 r8568 22 22 USE lib_mpp ! MPP library 23 23 USE prtctl ! Print control 24 USE wrk_nemo ! Memory Allocation25 24 USE timing ! Timing 26 25 USE bdy_oce ! ocean open boundary conditions … … 39 38 # include "vectopt_loop_substitute.h90" 40 39 !!---------------------------------------------------------------------- 41 !! NEMO/OPA 3.6 , NEMO Consortium (2015)40 !! NEMO/OPA 4.0 , NEMO Consortium (2017) 42 41 !! $Id$ 43 42 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 75 74 INTEGER, INTENT( in ) :: kscheme ! =0/1 type of KEG scheme 76 75 ! 77 INTEGER :: ji, jj, jk ! dummy loop indices 78 REAL(wp) :: zu, zv ! temporary scalars 79 REAL(wp), POINTER, DIMENSION(:,:,:) :: zhke 80 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdu, ztrdv 81 INTEGER :: jb ! dummy loop indices 82 INTEGER :: ii, ij, igrd, ib_bdy ! local integers 83 INTEGER :: fu, fv 76 INTEGER :: ji, jj, jk, jb ! dummy loop indices 77 INTEGER :: ii, ifu, ib_bdy ! local integers 78 INTEGER :: ij, ifv, igrd ! - - 79 REAL(wp) :: zu, zv ! local scalars 80 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zhke 81 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdu, ztrdv 84 82 !!---------------------------------------------------------------------- 85 83 ! 86 IF( nn_timing == 1 ) CALL timing_start('dyn_keg') 87 ! 88 CALL wrk_alloc( jpi,jpj,jpk, zhke ) 84 IF( ln_timing ) CALL timing_start('dyn_keg') 89 85 ! 90 86 IF( kt == nit000 ) THEN … … 94 90 ENDIF 95 91 96 IF( l_trddyn ) THEN ! Save ua and vatrends97 CALL wrk_alloc( jpi,jpj,jpk, ztrdu, ztrdv)92 IF( l_trddyn ) THEN ! Save the input trends 93 ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) ) 98 94 ztrdu(:,:,:) = ua(:,:,:) 99 95 ztrdv(:,:,:) = va(:,:,:) … … 112 108 ii = idx_bdy(ib_bdy)%nbi(jb,igrd) 113 109 ij = idx_bdy(ib_bdy)%nbj(jb,igrd) 114 fu = NINT( idx_bdy(ib_bdy)%flagu(jb,igrd) )115 un(ii- fu,ij,jk) = un(ii,ij,jk) * umask(ii,ij,jk)110 ifu = NINT( idx_bdy(ib_bdy)%flagu(jb,igrd) ) 111 un(ii-ifu,ij,jk) = un(ii,ij,jk) * umask(ii,ij,jk) 116 112 END DO 117 113 END DO … … 122 118 ii = idx_bdy(ib_bdy)%nbi(jb,igrd) 123 119 ij = idx_bdy(ib_bdy)%nbj(jb,igrd) 124 fv = NINT( idx_bdy(ib_bdy)%flagv(jb,igrd) )125 vn(ii,ij- fv,jk) = vn(ii,ij,jk) * vmask(ii,ij,jk)120 ifv = NINT( idx_bdy(ib_bdy)%flagv(jb,igrd) ) 121 vn(ii,ij-ifv,jk) = vn(ii,ij,jk) * vmask(ii,ij,jk) 126 122 END DO 127 123 END DO … … 172 168 ENDIF 173 169 174 175 170 ! 176 171 DO jk = 1, jpkm1 !== grad( KE ) added to the general momentum trends ==! … … 187 182 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 188 183 CALL trd_dyn( ztrdu, ztrdv, jpdyn_keg, kt ) 189 CALL wrk_dealloc( jpi,jpj,jpk, ztrdu, ztrdv )184 DEALLOCATE( ztrdu , ztrdv ) 190 185 ENDIF 191 186 ! … … 193 188 & tab3d_2=va, clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) 194 189 ! 195 CALL wrk_dealloc( jpi,jpj,jpk, zhke ) 196 ! 197 IF( nn_timing == 1 ) CALL timing_stop('dyn_keg') 190 IF( ln_timing ) CALL timing_stop('dyn_keg') 198 191 ! 199 192 END SUBROUTINE dyn_keg -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/DYN/dynldf.F90
r8367 r8568 27 27 USE lib_mpp ! distribued memory computing library 28 28 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 29 USE wrk_nemo ! Memory Allocation30 29 USE timing ! Timing 31 30 … … 48 47 # include "vectopt_loop_substitute.h90" 49 48 !!---------------------------------------------------------------------- 50 !! NEMO/OPA 3.7 , NEMO Consortium (2015)49 !! NEMO/OPA 4.0 , NEMO Consortium (2017) 51 50 !! $Id$ 52 51 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 62 61 INTEGER, INTENT(in) :: kt ! ocean time-step index 63 62 ! 64 REAL(wp), POINTER, DIMENSION(:,:,:) ::ztrdu, ztrdv63 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdu, ztrdv 65 64 !!---------------------------------------------------------------------- 66 65 ! 67 IF( nn_timing == 1 )CALL timing_start('dyn_ldf')66 IF( ln_timing ) CALL timing_start('dyn_ldf') 68 67 ! 69 68 IF( l_trddyn ) THEN ! temporary save of momentum trends 70 CALL wrk_alloc( jpi,jpj,jpk, ztrdu, ztrdv)69 ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) ) 71 70 ztrdu(:,:,:) = ua(:,:,:) 72 71 ztrdv(:,:,:) = va(:,:,:) … … 85 84 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 86 85 CALL trd_dyn( ztrdu, ztrdv, jpdyn_ldf, kt ) 87 CALL wrk_dealloc( jpi,jpj,jpk, ztrdu, ztrdv )86 DEALLOCATE ( ztrdu , ztrdv ) 88 87 ENDIF 89 88 ! ! print sum trends (used for debugging) … … 91 90 & tab3d_2=va, clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) 92 91 ! 93 IF( nn_timing == 1 )CALL timing_stop('dyn_ldf')92 IF( ln_timing ) CALL timing_stop('dyn_ldf') 94 93 ! 95 94 END SUBROUTINE dyn_ldf … … 102 101 !! ** Purpose : initializations of the horizontal ocean dynamics physics 103 102 !!---------------------------------------------------------------------- 104 INTEGER :: ioptio, ierr 103 INTEGER :: ioptio, ierr ! temporary integers 105 104 !!---------------------------------------------------------------------- 106 105 ! 107 ! ! Namelist nam_dynldf:already read in ldfdyn module106 ! !== Namelist nam_dynldf ==! already read in ldfdyn module 108 107 ! 109 IF(lwp) THEN ! Namelist print108 IF(lwp) THEN !== Namelist print ==! 110 109 WRITE(numout,*) 111 110 WRITE(numout,*) 'dyn_ldf_init : Choice of the lateral diffusive operator on dynamics' 112 111 WRITE(numout,*) '~~~~~~~~~~~~' 113 112 WRITE(numout,*) ' Namelist nam_dynldf : set lateral mixing parameters (type, direction, coefficients)' 114 WRITE(numout,*) ' laplacian operator ln_dynldf_lap = ', ln_dynldf_lap 115 WRITE(numout,*) ' bilaplacian operator ln_dynldf_blp = ', ln_dynldf_blp 116 WRITE(numout,*) ' iso-level ln_dynldf_lev = ', ln_dynldf_lev 117 WRITE(numout,*) ' horizontal (geopotential) ln_dynldf_hor = ', ln_dynldf_hor 118 WRITE(numout,*) ' iso-neutral ln_dynldf_iso = ', ln_dynldf_iso 113 WRITE(numout,*) ' Type of operator' 114 WRITE(numout,*) ' no explicit diffusion ln_dynldf_NONE = ', ln_dynldf_NONE 115 WRITE(numout,*) ' laplacian operator ln_dynldf_lap = ', ln_dynldf_lap 116 WRITE(numout,*) ' bilaplacian operator ln_dynldf_blp = ', ln_dynldf_blp 117 WRITE(numout,*) ' Direction of action' 118 WRITE(numout,*) ' iso-level ln_dynldf_lev = ', ln_dynldf_lev 119 WRITE(numout,*) ' horizontal (geopotential) ln_dynldf_hor = ', ln_dynldf_hor 120 WRITE(numout,*) ' iso-neutral ln_dynldf_iso = ', ln_dynldf_iso 119 121 ENDIF 120 ! ! use of lateral operator or not122 ! !== use of lateral operator or not ==! 121 123 nldf = np_ERROR 122 124 ioptio = 0 123 IF( ln_dynldf_ lap ) ioptio = ioptio + 1124 IF( ln_dynldf_ blp ) ioptio = ioptio + 1125 IF( ioptio > 1 ) CALL ctl_stop( 'dyn_ldf_init: use ONE or NONE of the 2 lap/bilap operator type on momentum' )126 IF( ioptio == 0 ) nldf = np_no_ldf ! No lateral mixing operator125 IF( ln_dynldf_NONE ) THEN ; nldf = np_no_ldf ; ioptio = ioptio + 1 ; ENDIF 126 IF( ln_dynldf_lap ) THEN ; ioptio = ioptio + 1 ; ENDIF 127 IF( ln_dynldf_blp ) THEN ; ioptio = ioptio + 1 ; ENDIF 128 IF( ioptio /= 1 ) CALL ctl_stop( 'dyn_ldf_init: use ONE of the 3 operator options (NONE/lap/blp)' ) 127 129 ! 128 IF( nldf /= np_no_ldf ) THEN ! direction ==>> type of operator130 IF(.NOT.ln_dynldf_NONE ) THEN !== direction ==>> type of operator ==! 129 131 ioptio = 0 130 132 IF( ln_dynldf_lev ) ioptio = ioptio + 1 131 133 IF( ln_dynldf_hor ) ioptio = ioptio + 1 132 134 IF( ln_dynldf_iso ) ioptio = ioptio + 1 133 IF( ioptio > 1 ) CALL ctl_stop( ' use only ONE direction (level/hor/iso)' ) 134 IF( ioptio == 0 ) CALL ctl_stop( ' use at least ONE direction (level/hor/iso)' ) 135 IF( ioptio /= 1 ) CALL ctl_stop( 'dyn_ldf_init: use ONE of the 3 direction options (level/hor/iso)' ) 135 136 ! 136 ! 137 ! ! Set nldf, the type of lateral diffusion, from ln_dynldf_... logicals 137 138 ierr = 0 138 IF ( ln_dynldf_lap ) THEN! laplacian operator139 IF 139 IF( ln_dynldf_lap ) THEN ! laplacian operator 140 IF( ln_zco ) THEN ! z-coordinate 140 141 IF ( ln_dynldf_lev ) nldf = np_lap ! iso-level = horizontal (no rotation) 141 142 IF ( ln_dynldf_hor ) nldf = np_lap ! iso-level = horizontal (no rotation) 142 143 IF ( ln_dynldf_iso ) nldf = np_lap_i ! iso-neutral ( rotation) 143 144 ENDIF 144 IF ( ln_zps ) THEN! z-coordinate with partial step145 IF( ln_zps ) THEN ! z-coordinate with partial step 145 146 IF ( ln_dynldf_lev ) nldf = np_lap ! iso-level (no rotation) 146 147 IF ( ln_dynldf_hor ) nldf = np_lap ! iso-level (no rotation) 147 148 IF ( ln_dynldf_iso ) nldf = np_lap_i ! iso-neutral ( rotation) 148 149 ENDIF 149 IF ( ln_sco ) THEN! s-coordinate150 IF( ln_sco ) THEN ! s-coordinate 150 151 IF ( ln_dynldf_lev ) nldf = np_lap ! iso-level = horizontal (no rotation) 151 152 IF ( ln_dynldf_hor ) nldf = np_lap_i ! horizontal ( rotation) … … 154 155 ENDIF 155 156 ! 156 IF( ln_dynldf_blp ) THEN 157 IF 158 IF 159 IF 160 IF 157 IF( ln_dynldf_blp ) THEN ! bilaplacian operator 158 IF( ln_zco ) THEN ! z-coordinate 159 IF( ln_dynldf_lev ) nldf = np_blp ! iso-level = horizontal (no rotation) 160 IF( ln_dynldf_hor ) nldf = np_blp ! iso-level = horizontal (no rotation) 161 IF( ln_dynldf_iso ) ierr = 2 ! iso-neutral ( rotation) 161 162 ENDIF 162 IF ( ln_zps ) THEN! z-coordinate with partial step163 IF 164 IF 165 IF 163 IF( ln_zps ) THEN ! z-coordinate with partial step 164 IF( ln_dynldf_lev ) nldf = np_blp ! iso-level (no rotation) 165 IF( ln_dynldf_hor ) nldf = np_blp ! iso-level (no rotation) 166 IF( ln_dynldf_iso ) ierr = 2 ! iso-neutral ( rotation) 166 167 ENDIF 167 IF ( ln_sco ) THEN! s-coordinate168 IF 169 IF 170 IF 168 IF( ln_sco ) THEN ! s-coordinate 169 IF( ln_dynldf_lev ) nldf = np_blp ! iso-level (no rotation) 170 IF( ln_dynldf_hor ) ierr = 2 ! horizontal ( rotation) 171 IF( ln_dynldf_iso ) ierr = 2 ! iso-neutral ( rotation) 171 172 ENDIF 172 173 ENDIF -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/DYN/dynldf_iso.F90
r8367 r8568 28 28 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 29 29 USE prtctl ! Print control 30 USE wrk_nemo ! Memory Allocation31 30 USE timing ! Timing 32 31 … … 45 44 # include "vectopt_loop_substitute.h90" 46 45 !!---------------------------------------------------------------------- 47 !! NEMO/OPA 3.3 , NEMO Consortium (2011)46 !! NEMO/OPA 4.0 , NEMO Consortium (2017) 48 47 !! $Id$ 49 48 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 108 107 ! 109 108 INTEGER :: ji, jj, jk ! dummy loop indices 110 REAL(wp) :: zabe1, zabe2, zcof1, zcof2 ! local scalars 111 REAL(wp) :: zmskt, zmskf ! - - 112 REAL(wp) :: zcoef0, zcoef3, zcoef4, zmkt, zmkf ! - - 113 REAL(wp) :: zuav, zvav, zuwslpi, zuwslpj, zvwslpi, zvwslpj ! - - 114 ! 115 REAL(wp), POINTER, DIMENSION(:,:) :: ziut, zjuf, zjvt, zivf, zdku, zdk1u, zdkv, zdk1v 109 REAL(wp) :: zabe1, zmskt, zmkt, zuav, zuwslpi, zuwslpj ! local scalars 110 REAL(wp) :: zabe2, zmskf, zmkf, zvav, zvwslpi, zvwslpj ! - - 111 REAL(wp) :: zcof0, zcof1, zcof2, zcof3, zcof4 ! - - 112 REAL(wp), DIMENSION(jpi,jpj) :: ziut, zivf, zdku, zdk1u ! 2D workspace 113 REAL(wp), DIMENSION(jpi,jpj) :: zjuf, zjvt, zdkv, zdk1v ! - - 116 114 !!---------------------------------------------------------------------- 117 115 ! 118 IF( nn_timing == 1 ) CALL timing_start('dyn_ldf_iso') 119 ! 120 CALL wrk_alloc( jpi, jpj, ziut, zjuf, zjvt, zivf, zdku, zdk1u, zdkv, zdk1v ) 116 IF( ln_timing ) CALL timing_start('dyn_ldf_iso') 121 117 ! 122 118 IF( kt == nit000 ) THEN … … 343 339 DO jk = 2, jpkm1 344 340 DO ji = 2, jpim1 345 zco ef0= 0.5* rn_aht_0 * umask(ji,jj,jk)341 zcof0 = 0.5_wp * rn_aht_0 * umask(ji,jj,jk) 346 342 ! 347 zuwslpi = zco ef0 * ( wslpi(ji+1,jj,jk) + wslpi(ji,jj,jk) )348 zuwslpj = zco ef0 * ( wslpj(ji+1,jj,jk) + wslpj(ji,jj,jk) )343 zuwslpi = zcof0 * ( wslpi(ji+1,jj,jk) + wslpi(ji,jj,jk) ) 344 zuwslpj = zcof0 * ( wslpj(ji+1,jj,jk) + wslpj(ji,jj,jk) ) 349 345 ! 350 zmkt = 1./MAX( tmask(ji,jj,jk-1)+tmask(ji+1,jj,jk-1) &351 + tmask(ji,jj,jk )+tmask(ji+1,jj,jk ) , 1. )352 zmkf = 1./MAX( fmask(ji,jj-1,jk-1) + fmask(ji,jj,jk-1) &353 + fmask(ji,jj-1,jk ) + fmask(ji,jj,jk ) , 1. )354 355 zco ef3 = - e2u(ji,jj) * zmkt * zuwslpi356 zco ef4 = - e1u(ji,jj) * zmkf * zuwslpj346 zmkt = 1./MAX( tmask(ji,jj,jk-1)+tmask(ji+1,jj,jk-1) & 347 + tmask(ji,jj,jk )+tmask(ji+1,jj,jk ) , 1. ) 348 zmkf = 1./MAX( fmask(ji,jj-1,jk-1) + fmask(ji,jj,jk-1) & 349 + fmask(ji,jj-1,jk ) + fmask(ji,jj,jk ) , 1. ) 350 351 zcof3 = - e2u(ji,jj) * zmkt * zuwslpi 352 zcof4 = - e1u(ji,jj) * zmkf * zuwslpj 357 353 ! vertical flux on u field 358 zfuw(ji,jk) = zco ef3 * ( zdiu (ji,jk-1) + zdiu (ji+1,jk-1)&359 +zdiu (ji,jk ) + zdiu (ji+1,jk )) &360 + zcoef4 * ( zdj1u(ji,jk-1) + zdju (ji ,jk-1)&361 +zdj1u(ji,jk ) + zdju (ji ,jk ))354 zfuw(ji,jk) = zcof3 * ( zdiu (ji,jk-1) + zdiu (ji+1,jk-1) & 355 & + zdiu (ji,jk ) + zdiu (ji+1,jk ) ) & 356 & + zcof4 * ( zdj1u(ji,jk-1) + zdju (ji ,jk-1) & 357 & + zdj1u(ji,jk ) + zdju (ji ,jk ) ) 362 358 ! vertical mixing coefficient (akzu) 363 ! Note: zco ef0 include rn_aht_0, so divided by rn_aht_0 to obtain slp^2 * rn_aht_0359 ! Note: zcof0 include rn_aht_0, so divided by rn_aht_0 to obtain slp^2 * rn_aht_0 364 360 akzu(ji,jj,jk) = ( zuwslpi * zuwslpi + zuwslpj * zuwslpj ) / rn_aht_0 365 361 END DO … … 369 365 DO jk = 2, jpkm1 370 366 DO ji = 2, jpim1 371 zco ef0 = 0.5* rn_aht_0 * vmask(ji,jj,jk)372 373 zvwslpi = zco ef0 * ( wslpi(ji,jj+1,jk) + wslpi(ji,jj,jk) )374 zvwslpj = zco ef0 * ( wslpj(ji,jj+1,jk) + wslpj(ji,jj,jk) )375 376 zmkf = 1./MAX( fmask(ji-1,jj,jk-1)+fmask(ji,jj,jk-1) &377 + fmask(ji-1,jj,jk )+fmask(ji,jj,jk ), 1. )378 zmkt = 1./MAX( tmask(ji,jj,jk-1)+tmask(ji,jj+1,jk-1) &379 + tmask(ji,jj,jk )+tmask(ji,jj+1,jk ), 1. )380 381 zco ef3 = - e2v(ji,jj) * zmkf * zvwslpi382 zco ef4 = - e1v(ji,jj) * zmkt * zvwslpj367 zcof0 = 0.5_wp * rn_aht_0 * vmask(ji,jj,jk) 368 ! 369 zvwslpi = zcof0 * ( wslpi(ji,jj+1,jk) + wslpi(ji,jj,jk) ) 370 zvwslpj = zcof0 * ( wslpj(ji,jj+1,jk) + wslpj(ji,jj,jk) ) 371 ! 372 zmkf = 1./MAX( fmask(ji-1,jj,jk-1)+fmask(ji,jj,jk-1) & 373 & + fmask(ji-1,jj,jk )+fmask(ji,jj,jk ) , 1. ) 374 zmkt = 1./MAX( tmask(ji,jj,jk-1)+tmask(ji,jj+1,jk-1) & 375 & + tmask(ji,jj,jk )+tmask(ji,jj+1,jk ) , 1. ) 376 377 zcof3 = - e2v(ji,jj) * zmkf * zvwslpi 378 zcof4 = - e1v(ji,jj) * zmkt * zvwslpj 383 379 ! vertical flux on v field 384 zfvw(ji,jk) = zco ef3 * ( zdiv (ji,jk-1) + zdiv (ji-1,jk-1)&385 & +zdiv (ji,jk ) + zdiv (ji-1,jk )) &386 & + zco ef4 * ( zdjv (ji,jk-1) + zdj1v(ji ,jk-1)&387 & +zdjv (ji,jk ) + zdj1v(ji ,jk ))380 zfvw(ji,jk) = zcof3 * ( zdiv (ji,jk-1) + zdiv (ji-1,jk-1) & 381 & + zdiv (ji,jk ) + zdiv (ji-1,jk ) ) & 382 & + zcof4 * ( zdjv (ji,jk-1) + zdj1v(ji ,jk-1) & 383 & + zdjv (ji,jk ) + zdj1v(ji ,jk ) ) 388 384 ! vertical mixing coefficient (akzv) 389 ! Note: zco ef0 include rn_aht_0, so divided by rn_aht_0 to obtain slp^2 * rn_aht_0385 ! Note: zcof0 include rn_aht_0, so divided by rn_aht_0 to obtain slp^2 * rn_aht_0 390 386 akzv(ji,jj,jk) = ( zvwslpi * zvwslpi + zvwslpj * zvwslpj ) / rn_aht_0 391 387 END DO … … 404 400 END DO ! End of slab 405 401 ! ! =============== 406 CALL wrk_dealloc( jpi, jpj, ziut, zjuf, zjvt, zivf, zdku, zdk1u, zdkv, zdk1v )407 402 ! 408 IF( nn_timing == 1 )CALL timing_stop('dyn_ldf_iso')403 IF( ln_timing ) CALL timing_stop('dyn_ldf_iso') 409 404 ! 410 405 END SUBROUTINE dyn_ldf_iso -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/DYN/dynldf_lap_blp.F90
r7753 r8568 19 19 USE in_out_manager ! I/O manager 20 20 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 21 USE wrk_nemo ! Memory Allocation22 21 USE timing ! Timing 23 22 … … 31 30 # include "vectopt_loop_substitute.h90" 32 31 !!---------------------------------------------------------------------- 33 !! NEMO/OPA 3.7 , NEMO Consortium (2014)32 !! NEMO/OPA 4.0 , NEMO Consortium (2017) 34 33 !! $Id$ 35 34 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 57 56 REAL(wp) :: zsign ! local scalars 58 57 REAL(wp) :: zua, zva ! local scalars 59 REAL(wp), POINTER, DIMENSION(:,:) ::zcur, zdiv58 REAL(wp), DIMENSION(jpi,jpj) :: zcur, zdiv 60 59 !!---------------------------------------------------------------------- 61 60 ! … … 66 65 ENDIF 67 66 ! 68 IF( nn_timing == 1 ) CALL timing_start('dyn_ldf_lap') 69 ! 70 CALL wrk_alloc( jpi, jpj, zcur, zdiv ) 67 IF( ln_timing ) CALL timing_start('dyn_ldf_lap') 71 68 ! 72 69 IF( kpass == 1 ) THEN ; zsign = 1._wp ! bilaplacian operator require a minus sign … … 107 104 END DO ! End of slab 108 105 ! ! =============== 109 CALL wrk_dealloc( jpi, jpj, zcur, zdiv )110 106 ! 111 IF( nn_timing == 1 )CALL timing_stop('dyn_ldf_lap')107 IF( ln_timing ) CALL timing_stop('dyn_ldf_lap') 112 108 ! 113 109 END SUBROUTINE dyn_ldf_lap … … 131 127 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pua, pva ! momentum trend 132 128 ! 133 REAL(wp), POINTER, DIMENSION(:,:,:) :: zulap, zvlap ! laplacian at u- and v-point129 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zulap, zvlap ! laplacian at u- and v-point 134 130 !!---------------------------------------------------------------------- 135 131 ! 136 IF( nn_timing == 1 ) CALL timing_start('dyn_ldf_blp') 137 ! 138 CALL wrk_alloc( jpi, jpj, jpk, zulap, zvlap ) 132 IF( ln_timing ) CALL timing_start('dyn_ldf_blp') 139 133 ! 140 134 IF( kt == nit000 ) THEN … … 154 148 CALL dyn_ldf_lap( kt, zulap, zvlap, pua, pva, 2 ) ! rotated laplacian applied to zlap (output in pta) 155 149 ! 156 CALL wrk_dealloc( jpi, jpj, jpk, zulap, zvlap ) 157 ! 158 IF( nn_timing == 1 ) CALL timing_stop('dyn_ldf_blp') 150 IF( ln_timing ) CALL timing_stop('dyn_ldf_blp') 159 151 ! 160 152 END SUBROUTINE dyn_ldf_blp -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/DYN/dynnxt.F90
r7753 r8568 44 44 USE lbclnk ! lateral boundary condition (or mpp link) 45 45 USE lib_mpp ! MPP library 46 USE wrk_nemo ! Memory Allocation47 46 USE prtctl ! Print control 48 47 USE timing ! Timing … … 57 56 58 57 !!---------------------------------------------------------------------- 59 !! NEMO/OPA 3.3 , NEMO Consortium (2010)58 !! NEMO/OPA 4.0 , NEMO Consortium (2017) 60 59 !! $Id$ 61 60 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 97 96 REAL(wp) :: zue3a, zue3n, zue3b, zuf, zcoef ! local scalars 98 97 REAL(wp) :: zve3a, zve3n, zve3b, zvf, z1_2dt ! - - 99 REAL(wp), POINTER, DIMENSION(:,:) ::zue, zve100 REAL(wp), POINTER, DIMENSION(:,:,:) ::ze3u_f, ze3v_f, zua, zva98 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zue, zve 99 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ze3u_f, ze3v_f, zua, zva 101 100 !!---------------------------------------------------------------------- 102 101 ! 103 IF( nn_timing == 1 ) CALL timing_start('dyn_nxt') 104 ! 105 IF( ln_dynspg_ts ) CALL wrk_alloc( jpi,jpj, zue, zve) 106 IF( l_trddyn ) CALL wrk_alloc( jpi,jpj,jpk, zua, zva) 102 IF( ln_timing ) CALL timing_start('dyn_nxt') 103 IF( ln_dynspg_ts ) ALLOCATE( zue(jpi,jpj) , zve(jpi,jpj) ) 104 IF( l_trddyn ) ALLOCATE( zua(jpi,jpj,jpk) , zva(jpi,jpj,jpk) ) 107 105 ! 108 106 IF( kt == nit000 ) THEN … … 253 251 ELSE ! Asselin filter applied on thickness weighted velocity 254 252 ! 255 CALL wrk_alloc( jpi,jpj,jpk, ze3u_f, ze3v_f)253 ALLOCATE( ze3u_f(jpi,jpj,jpk) , ze3v_f(jpi,jpj,jpk) ) 256 254 ! Before filtered scale factor at (u/v)-points stored in ze3u_f, ze3v_f 257 255 CALL dom_vvl_interpol( e3t_b(:,:,:), ze3u_f, 'U' ) … … 280 278 e3v_b(:,:,1:jpkm1) = ze3v_f(:,:,1:jpkm1) 281 279 ! 282 CALL wrk_dealloc( jpi,jpj,jpk, ze3u_f, ze3v_f )280 DEALLOCATE( ze3u_f , ze3v_f ) 283 281 ENDIF 284 282 ! … … 346 344 & tab3d_2=vn, clinfo2=' Vn: ' , mask2=vmask ) 347 345 ! 348 IF( ln_dynspg_ts ) CALL wrk_dealloc( jpi,jpj, zue, zve ) 349 IF( l_trddyn ) CALL wrk_dealloc( jpi,jpj,jpk, zua, zva ) 350 ! 351 IF( nn_timing == 1 ) CALL timing_stop('dyn_nxt') 346 IF( ln_dynspg_ts ) DEALLOCATE( zue, zve ) 347 IF( l_trddyn ) DEALLOCATE( zua, zva ) 348 IF( ln_timing ) CALL timing_stop('dyn_nxt') 352 349 ! 353 350 END SUBROUTINE dyn_nxt -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/DYN/dynspg.F90
r7753 r8568 28 28 USE in_out_manager ! I/O manager 29 29 USE lib_mpp ! MPP library 30 USE wrk_nemo ! Memory Allocation31 30 USE timing ! Timing 32 31 … … 47 46 # include "vectopt_loop_substitute.h90" 48 47 !!---------------------------------------------------------------------- 49 !! NEMO/OPA 3.2 , LODYC-IPSL (2009)48 !! NEMO/OPA 4.0 , LODYC-IPSL (2017) 50 49 !! $Id$ 51 50 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 71 70 !! period is used to prevent the divergence of odd and even time step. 72 71 !!---------------------------------------------------------------------- 73 INTEGER, INTENT(in ) :: kt 74 ! 75 INTEGER :: ji, jj, jk 76 REAL(wp) :: z2dt, zg_2, zintp, zgrau0r ! temporary scalar77 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdu, ztrdv78 REAL(wp), POINTER, DIMENSION(:,:) :: zpice79 !!---------------------------------------------------------------------- 80 ! 81 IF( nn_timing == 1 )CALL timing_start('dyn_spg')72 INTEGER, INTENT(in ) :: kt ! ocean time-step index 73 ! 74 INTEGER :: ji, jj, jk ! dummy loop indices 75 REAL(wp) :: z2dt, zg_2, zintp, zgrau0r ! local scalars 76 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zpice 77 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdu, ztrdv 78 !!---------------------------------------------------------------------- 79 ! 80 IF( ln_timing ) CALL timing_start('dyn_spg') 82 81 ! 83 82 IF( l_trddyn ) THEN ! temporary save of ta and sa trends 84 CALL wrk_alloc( jpi,jpj,jpk, ztrdu, ztrdv)83 ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) ) 85 84 ztrdu(:,:,:) = ua(:,:,:) 86 85 ztrdv(:,:,:) = va(:,:,:) … … 124 123 ! 125 124 IF( nn_ice_embd == 2 ) THEN !== embedded sea ice: Pressure gradient due to snow-ice mass ==! 126 CALL wrk_alloc( jpi,jpj, zpice ) 127 ! 125 ALLOCATE( zpice(jpi,jpj) ) 128 126 zintp = REAL( MOD( kt-1, nn_fsbc ) ) / REAL( nn_fsbc ) 129 127 zgrau0r = - grav * r1_rau0 … … 135 133 END DO 136 134 END DO 137 ! 138 CALL wrk_dealloc( jpi,jpj, zpice ) 135 DEALLOCATE( zpice ) 139 136 ENDIF 140 137 ! … … 161 158 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 162 159 CALL trd_dyn( ztrdu, ztrdv, jpdyn_spg, kt ) 163 CALL wrk_dealloc( jpi,jpj,jpk, ztrdu, ztrdv )160 DEALLOCATE( ztrdu , ztrdv ) 164 161 ENDIF 165 162 ! ! print mean trends (used for debugging) … … 167 164 & tab3d_2=va, clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) 168 165 ! 169 IF( nn_timing == 1 )CALL timing_stop('dyn_spg')166 IF( ln_timing ) CALL timing_stop('dyn_spg') 170 167 ! 171 168 END SUBROUTINE dyn_spg … … 186 183 !!---------------------------------------------------------------------- 187 184 ! 188 IF( nn_timing == 1 )CALL timing_start('dyn_spg_init')185 IF( ln_timing ) CALL timing_start('dyn_spg_init') 189 186 ! 190 187 REWIND( numnam_ref ) ! Namelist namdyn_spg in reference namelist : Free surface … … 227 224 ENDIF 228 225 ! 229 IF( nn_timing == 1 )CALL timing_stop('dyn_spg_init')226 IF( ln_timing ) CALL timing_stop('dyn_spg_init') 230 227 ! 231 228 END SUBROUTINE dyn_spg_init -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/DYN/dynspg_exp.F90
r6140 r8568 61 61 !!---------------------------------------------------------------------- 62 62 ! 63 IF( nn_timing == 1 )CALL timing_start('dyn_spg_exp')63 IF( ln_timing ) CALL timing_start('dyn_spg_exp') 64 64 ! 65 65 IF( kt == nit000 ) THEN … … 93 93 ENDIF 94 94 ! 95 IF( nn_timing == 1 )CALL timing_stop('dyn_spg_exp')95 IF( ln_timing ) CALL timing_stop('dyn_spg_exp') 96 96 ! 97 97 END SUBROUTINE dyn_spg_exp -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/DYN/dynspg_ts.F90
r8367 r8568 162 162 !!---------------------------------------------------------------------- 163 163 ! 164 IF( nn_timing == 1) CALL timing_start('dyn_spg_ts')164 IF( ln_timing ) CALL timing_start('dyn_spg_ts') 165 165 ! 166 166 IF( ln_wd ) ALLOCATE( zcpx(jpi,jpj), zcpy(jpi,jpj) ) … … 1125 1125 IF( ln_wd ) DEALLOCATE( zcpx, zcpy ) 1126 1126 ! 1127 IF 1127 IF( ln_diatmb ) THEN 1128 1128 CALL iom_put( "baro_u" , un_b*umask(:,:,1)+zmdi*(1-umask(:,:,1 ) ) ) ! Barotropic U Velocity 1129 1129 CALL iom_put( "baro_v" , vn_b*vmask(:,:,1)+zmdi*(1-vmask(:,:,1 ) ) ) ! Barotropic V Velocity 1130 1130 ENDIF 1131 IF( nn_timing == 1 )CALL timing_stop('dyn_spg_ts')1131 IF( ln_timing ) CALL timing_stop('dyn_spg_ts') 1132 1132 ! 1133 1133 END SUBROUTINE dyn_spg_ts -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/DYN/dynvor.F90
r7753 r8568 14 14 !! 2.0 ! 2006-11 (G. Madec) flux form advection: add metric term 15 15 !! 3.2 ! 2009-04 (R. Benshila) vvl: correction of een scheme 16 !! 3.3 ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase17 !! 3.7 ! 2014-04 (G. Madec) trend simplification: suppress jpdyn_trd_dat vorticity18 !! - ! 2014-06 (G. Madec) suppression of velocity curl from in-core memory16 !! 3.3 ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase 17 !! 3.7 ! 2014-04 (G. Madec) trend simplification: suppress jpdyn_trd_dat vorticity 18 !! - ! 2014-06 (G. Madec) suppression of velocity curl from in-core memory 19 19 !! - ! 2016-12 (G. Madec, E. Clementi) add Stokes-Coriolis trends (ln_stcor=T) 20 !! 4.0 ! 2017-07 (G. Madec) linear dynamics + trends diag. with Stokes-Coriolis 20 21 !!---------------------------------------------------------------------- 21 22 22 23 !!---------------------------------------------------------------------- 23 !! dyn_vor : Update the momentum trend with the vorticity trend24 !! vor_ens : enstrophy conserving scheme (ln_dynvor_ens=T)25 !! vor_ene : energy conserving scheme (ln_dynvor_ene=T)26 !! vor_een : energy and enstrophy conserving (ln_dynvor_een=T)27 !! dyn_vor_init : set and control of the different vorticity option24 !! dyn_vor : Update the momentum trend with the vorticity trend 25 !! vor_ens : enstrophy conserving scheme (ln_dynvor_ens=T) 26 !! vor_ene : energy conserving scheme (ln_dynvor_ene=T) 27 !! vor_een : energy and enstrophy conserving (ln_dynvor_een=T) 28 !! dyn_vor_init : set and control of the different vorticity option 28 29 !!---------------------------------------------------------------------- 29 30 USE oce ! ocean dynamics and tracers 30 31 USE dom_oce ! ocean space and time domain 31 32 USE dommsk ! ocean mask 32 USE dynadv ! momentum advection (use ln_dynadv_vec value)33 USE dynadv ! momentum advection 33 34 USE trd_oce ! trends: ocean variables 34 35 USE trddyn ! trend manager: dynamics … … 40 41 USE in_out_manager ! I/O manager 41 42 USE lib_mpp ! MPP library 42 USE wrk_nemo ! Memory Allocation43 43 USE timing ! Timing 44 45 44 46 45 IMPLICIT NONE … … 80 79 # include "vectopt_loop_substitute.h90" 81 80 !!---------------------------------------------------------------------- 82 !! NEMO/OPA 3.7 , NEMO Consortium (2016)81 !! NEMO/OPA 4.0 , NEMO Consortium (2017) 83 82 !! $Id$ 84 83 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 98 97 INTEGER, INTENT( in ) :: kt ! ocean time-step index 99 98 ! 100 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdu, ztrdv 101 !!---------------------------------------------------------------------- 102 ! 103 IF( nn_timing == 1 ) CALL timing_start('dyn_vor') 104 ! 105 IF( l_trddyn ) CALL wrk_alloc( jpi,jpj,jpk, ztrdu, ztrdv ) 106 ! 107 SELECT CASE ( nvor_scheme ) !== vorticity trend added to the general trend ==! 108 ! 109 CASE ( np_ENE ) !* energy conserving scheme 110 IF( l_trddyn ) THEN ! trend diagnostics: split the trend in two 99 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdu, ztrdv 100 !!---------------------------------------------------------------------- 101 ! 102 IF( ln_timing ) CALL timing_start('dyn_vor') 103 ! 104 IF( l_trddyn ) THEN !== trend diagnostics case : split the added trend in two parts ==! 105 ! 106 ALLOCATE( ztrdu(jpi,jpj,jpk), ztrdv(jpi,jpj,jpk) ) 107 ! 108 ztrdu(:,:,:) = ua(:,:,:) !* planetary vorticity trend (including Stokes-Coriolis force) 109 ztrdv(:,:,:) = va(:,:,:) 110 SELECT CASE( nvor_scheme ) 111 CASE( np_ENE, np_MIX ) ; CALL vor_ene( kt, ncor, un , vn , ua, va ) ! energy conserving scheme 112 IF( ln_stcor ) CALL vor_ene( kt, ncor, usd, vsd, ua, va ) ! add the Stokes-Coriolis trend 113 CASE( np_ENS ) ; CALL vor_ens( kt, ncor, un , vn , ua, va ) ! enstrophy conserving scheme 114 IF( ln_stcor ) CALL vor_ens( kt, ncor, usd, vsd, ua, va ) ! add the Stokes-Coriolis trend 115 CASE( np_EEN ) ; CALL vor_een( kt, ncor, un , vn , ua, va ) ! energy & enstrophy scheme 116 IF( ln_stcor ) CALL vor_een( kt, ncor, usd, vsd, ua, va ) ! add the Stokes-Coriolis trend 117 END SELECT 118 ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) 119 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 120 CALL trd_dyn( ztrdu, ztrdv, jpdyn_pvo, kt ) 121 ! 122 IF( n_dynadv /= np_LIN_dyn ) THEN !* relative vorticity or metric trend (only in non-linear case) 111 123 ztrdu(:,:,:) = ua(:,:,:) 112 124 ztrdv(:,:,:) = va(:,:,:) 113 CALL vor_ene( kt, nrvm, un , vn , ua, va ) ! relative vorticity or metric trend 125 SELECT CASE( nvor_scheme ) 126 CASE( np_ENE ) ; CALL vor_ene( kt, nrvm, un , vn , ua, va ) ! energy conserving scheme 127 CASE( np_ENS, np_MIX ) ; CALL vor_ens( kt, nrvm, un , vn , ua, va ) ! enstrophy conserving scheme 128 CASE( np_EEN ) ; CALL vor_een( kt, nrvm, un , vn , ua, va ) ! energy & enstrophy scheme 129 END SELECT 114 130 ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) 115 131 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 116 132 CALL trd_dyn( ztrdu, ztrdv, jpdyn_rvo, kt ) 117 ztrdu(:,:,:) = ua(:,:,:) 118 ztrdv(:,:,:) = va(:,:,:) 119 CALL vor_ene( kt, ncor, un , vn , ua, va ) ! planetary vorticity trend 120 ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) 121 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 122 CALL trd_dyn( ztrdu, ztrdv, jpdyn_pvo, kt ) 123 ELSE ! total vorticity trend 133 ENDIF 134 ! 135 DEALLOCATE( ztrdu, ztrdv ) 136 ! 137 ELSE !== total vorticity trend added to the general trend ==! 138 ! 139 SELECT CASE ( nvor_scheme ) !== vorticity trend added to the general trend ==! 140 CASE( np_ENE ) !* energy conserving scheme 124 141 CALL vor_ene( kt, ntot, un , vn , ua, va ) ! total vorticity trend 125 142 IF( ln_stcor ) CALL vor_ene( kt, ncor, usd, vsd, ua, va ) ! add the Stokes-Coriolis trend 126 ENDIF 127 ! 128 CASE ( np_ENS ) !* enstrophy conserving scheme 129 IF( l_trddyn ) THEN ! trend diagnostics: splitthe trend in two 130 ztrdu(:,:,:) = ua(:,:,:) 131 ztrdv(:,:,:) = va(:,:,:) 132 CALL vor_ens( kt, nrvm, un , vn , ua, va ) ! relative vorticity or metric trend 133 ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) 134 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 135 CALL trd_dyn( ztrdu, ztrdv, jpdyn_rvo, kt ) 136 ztrdu(:,:,:) = ua(:,:,:) 137 ztrdv(:,:,:) = va(:,:,:) 138 CALL vor_ens( kt, ncor, un , vn , ua, va ) ! planetary vorticity trend 139 ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) 140 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 141 CALL trd_dyn( ztrdu, ztrdv, jpdyn_pvo, kt ) 142 ELSE ! total vorticity trend 143 CASE( np_ENS ) !* enstrophy conserving scheme 143 144 CALL vor_ens( kt, ntot, un , vn , ua, va ) ! total vorticity trend 144 145 IF( ln_stcor ) CALL vor_ens( kt, ncor, usd, vsd, ua, va ) ! add the Stokes-Coriolis trend 145 ENDIF 146 ! 147 CASE ( np_MIX ) !* mixed ene-ens scheme 148 IF( l_trddyn ) THEN ! trend diagnostics: split the trend in two 149 ztrdu(:,:,:) = ua(:,:,:) 150 ztrdv(:,:,:) = va(:,:,:) 151 CALL vor_ens( kt, nrvm, un , vn , ua, va ) ! relative vorticity or metric trend (ens) 152 ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) 153 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 154 CALL trd_dyn( ztrdu, ztrdv, jpdyn_rvo, kt ) 155 ztrdu(:,:,:) = ua(:,:,:) 156 ztrdv(:,:,:) = va(:,:,:) 157 CALL vor_ene( kt, ncor, un , vn , ua, va ) ! planetary vorticity trend (ene) 158 ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) 159 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 160 CALL trd_dyn( ztrdu, ztrdv, jpdyn_pvo, kt ) 161 ELSE ! total vorticity trend 146 CASE( np_MIX ) !* mixed ene-ens scheme 162 147 CALL vor_ens( kt, nrvm, un , vn , ua, va ) ! relative vorticity or metric trend (ens) 163 148 CALL vor_ene( kt, ncor, un , vn , ua, va ) ! planetary vorticity trend (ene) 164 149 IF( ln_stcor ) CALL vor_ene( kt, ncor, usd, vsd, ua, va ) ! add the Stokes-Coriolis trend 165 ENDIF 166 ! 167 CASE ( np_EEN ) !* energy and enstrophy conserving scheme 168 IF( l_trddyn ) THEN ! trend diagnostics: split the trend in two 169 ztrdu(:,:,:) = ua(:,:,:) 170 ztrdv(:,:,:) = va(:,:,:) 171 CALL vor_een( kt, nrvm, un , vn , ua, va ) ! relative vorticity or metric trend 172 ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) 173 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 174 CALL trd_dyn( ztrdu, ztrdv, jpdyn_rvo, kt ) 175 ztrdu(:,:,:) = ua(:,:,:) 176 ztrdv(:,:,:) = va(:,:,:) 177 CALL vor_een( kt, ncor, un , vn , ua, va ) ! planetary vorticity trend 178 ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) 179 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 180 CALL trd_dyn( ztrdu, ztrdv, jpdyn_pvo, kt ) 181 ELSE ! total vorticity trend 150 CASE( np_EEN ) !* energy and enstrophy conserving scheme 182 151 CALL vor_een( kt, ntot, un , vn , ua, va ) ! total vorticity trend 183 152 IF( ln_stcor ) CALL vor_ene( kt, ncor, usd, vsd, ua, va ) ! add the Stokes-Coriolis trend 184 END IF185 ! 186 END SELECT153 END SELECT 154 ! 155 ENDIF 187 156 ! 188 157 ! ! print sum trends (used for debugging) … … 190 159 & tab3d_2=va, clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) 191 160 ! 192 IF( l_trddyn ) CALL wrk_dealloc( jpi,jpj,jpk, ztrdu, ztrdv ) 193 ! 194 IF( nn_timing == 1 ) CALL timing_stop('dyn_vor') 161 IF( ln_timing ) CALL timing_stop('dyn_vor') 195 162 ! 196 163 END SUBROUTINE dyn_vor … … 217 184 !! References : Sadourny, r., 1975, j. atmos. sciences, 32, 680-689. 218 185 !!---------------------------------------------------------------------- 219 INTEGER , INTENT(in ) :: kt ! ocean time-step index 220 INTEGER , INTENT(in ) :: kvor ! =ncor (planetary) ; =ntot (total) ; 221 ! ! =nrvm (relative vorticity or metric) 222 REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) :: pun, pvn ! now velocities 223 REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) :: pua, pva ! total v-trend 186 INTEGER , INTENT(in ):: kt ! ocean time-step index 187 INTEGER , INTENT(in ):: kvor ! total, planetary, relative, or metric 188 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pun, pvn ! now velocities 189 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pua, pva ! total v-trend 224 190 ! 225 191 INTEGER :: ji, jj, jk ! dummy loop indices 226 192 REAL(wp) :: zx1, zy1, zx2, zy2 ! local scalars 227 REAL(wp), POINTER, DIMENSION(:,:) :: zwx, zwy, zwz ! 2D workspace 228 !!---------------------------------------------------------------------- 229 ! 230 IF( nn_timing == 1 ) CALL timing_start('vor_ene') 231 ! 232 CALL wrk_alloc( jpi,jpj, zwx, zwy, zwz ) 193 REAL(wp), DIMENSION(jpi,jpj) :: zwx, zwy, zwz ! 2D workspace 194 !!---------------------------------------------------------------------- 195 ! 196 IF( ln_timing ) CALL timing_start('vor_ene') 233 197 ! 234 198 IF( kt == nit000 ) THEN … … 264 228 DO ji = 1, fs_jpim1 ! vector opt. 265 229 zwz(ji,jj) = ff_f(ji,jj) + ( e2v(ji+1,jj ) * pvn(ji+1,jj ,jk) - e2v(ji,jj) * pvn(ji,jj,jk) & 266 & - e1u(ji ,jj+1) * pun(ji ,jj+1,jk) + e1u(ji,jj) * pun(ji,jj,jk) ) &230 & - e1u(ji ,jj+1) * pun(ji ,jj+1,jk) + e1u(ji,jj) * pun(ji,jj,jk) ) & 267 231 & * r1_e1e2f(ji,jj) 268 232 END DO … … 311 275 END DO ! End of slab 312 276 ! ! =============== 313 CALL wrk_dealloc( jpi, jpj, zwx, zwy, zwz ) 314 ! 315 IF( nn_timing == 1 ) CALL timing_stop('vor_ene') 277 ! 278 IF( ln_timing ) CALL timing_stop('vor_ene') 316 279 ! 317 280 END SUBROUTINE vor_ene … … 338 301 !! References : Sadourny, r., 1975, j. atmos. sciences, 32, 680-689. 339 302 !!---------------------------------------------------------------------- 340 INTEGER , INTENT(in ) :: kt ! ocean time-step index 341 INTEGER , INTENT(in ) :: kvor ! =ncor (planetary) ; =ntot (total) ; 342 ! ! =nrvm (relative vorticity or metric) 343 REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) :: pun, pvn ! now velocities 344 REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) :: pua, pva ! total v-trend 303 INTEGER , INTENT(in ):: kt ! ocean time-step index 304 INTEGER , INTENT(in ):: kvor ! total, planetary, relative, or metric 305 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pun, pvn ! now velocities 306 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pua, pva ! total v-trend 345 307 ! 346 308 INTEGER :: ji, jj, jk ! dummy loop indices 347 309 REAL(wp) :: zuav, zvau ! local scalars 348 REAL(wp), POINTER, DIMENSION(:,:) :: zwx, zwy, zwz, zww ! 2D workspace 349 !!---------------------------------------------------------------------- 350 ! 351 IF( nn_timing == 1 ) CALL timing_start('vor_ens') 352 ! 353 CALL wrk_alloc( jpi,jpj, zwx, zwy, zwz ) 310 REAL(wp), DIMENSION(jpi,jpj) :: zwx, zwy, zwz, zww ! 2D workspace 311 !!---------------------------------------------------------------------- 312 ! 313 IF( ln_timing ) CALL timing_start('vor_ens') 354 314 ! 355 315 IF( kt == nit000 ) THEN … … 431 391 END DO ! End of slab 432 392 ! ! =============== 433 CALL wrk_dealloc( jpi, jpj, zwx, zwy, zwz ) 434 ! 435 IF( nn_timing == 1 ) CALL timing_stop('vor_ens') 393 ! 394 IF( ln_timing ) CALL timing_stop('vor_ens') 436 395 ! 437 396 END SUBROUTINE vor_ens … … 455 414 !! References : Arakawa and Lamb 1980, Mon. Wea. Rev., 109, 18-36 456 415 !!---------------------------------------------------------------------- 457 INTEGER , INTENT(in ) :: kt ! ocean time-step index 458 INTEGER , INTENT(in ) :: kvor ! =ncor (planetary) ; =ntot (total) ; 459 ! ! =nrvm (relative vorticity or metric) 460 REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) :: pun, pvn ! now velocities 461 REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) :: pua, pva ! total v-trend 416 INTEGER , INTENT(in ):: kt ! ocean time-step index 417 INTEGER , INTENT(in ):: kvor ! total, planetary, relative, or metric 418 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pun, pvn ! now velocities 419 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pua, pva ! total v-trend 462 420 ! 463 421 INTEGER :: ji, jj, jk ! dummy loop indices … … 465 423 REAL(wp) :: zua, zva ! local scalars 466 424 REAL(wp) :: zmsk, ze3 ! local scalars 467 ! 468 REAL(wp), POINTER, DIMENSION(:,:) :: zwx, zwy, zwz, z1_e3f 469 REAL(wp), POINTER, DIMENSION(:,:) :: ztnw, ztne, ztsw, ztse 470 !!---------------------------------------------------------------------- 471 ! 472 IF( nn_timing == 1 ) CALL timing_start('vor_een') 473 ! 474 CALL wrk_alloc( jpi,jpj, zwx , zwy , zwz , z1_e3f ) 475 CALL wrk_alloc( jpi,jpj, ztnw, ztne, ztsw, ztse ) 425 REAL(wp), DIMENSION(jpi,jpj) :: zwx , zwy , zwz , z1_e3f 426 REAL(wp), DIMENSION(jpi,jpj) :: ztnw, ztne, ztsw, ztse 427 !!---------------------------------------------------------------------- 428 ! 429 IF( ln_timing ) CALL timing_start('vor_een') 476 430 ! 477 431 IF( kt == nit000 ) THEN … … 599 553 ! ! =============== 600 554 ! 601 CALL wrk_dealloc( jpi,jpj, zwx , zwy , zwz , z1_e3f ) 602 CALL wrk_dealloc( jpi,jpj, ztnw, ztne, ztsw, ztse ) 603 ! 604 IF( nn_timing == 1 ) CALL timing_stop('vor_een') 555 IF( ln_timing ) CALL timing_stop('vor_een') 605 556 ! 606 557 END SUBROUTINE vor_een … … 618 569 INTEGER :: ios ! Local integer output status for namelist read 619 570 !! 620 NAMELIST/namdyn_vor/ ln_dynvor_ens, ln_dynvor_ene, ln_dynvor_mix, ln_dynvor_een, nn_een_e3f, ln_dynvor_msk 571 NAMELIST/namdyn_vor/ ln_dynvor_ens, ln_dynvor_ene, ln_dynvor_mix, & 572 & ln_dynvor_een, nn_een_e3f , ln_dynvor_msk 621 573 !!---------------------------------------------------------------------- 622 574 … … 672 624 ! 673 625 IF(lwp) WRITE(numout,*) ! type of calculated vorticity (set ncor, nrvm, ntot) 674 ncor = np_COR 675 IF( ln_dynadv_vec ) THEN 676 IF(lwp) WRITE(numout,*) ' ===>> Vector form advection : vorticity = Coriolis + relative vorticity' 626 ncor = np_COR ! planetary vorticity 627 SELECT CASE( n_dynadv ) 628 CASE( np_LIN_dyn ) 629 IF(lwp) WRITE(numout,*) ' ===>> linear dynamics : total vorticity = Coriolis' 630 nrvm = np_COR ! planetary vorticity 631 ntot = np_COR ! - - 632 CASE( np_VEC_c2 ) 633 IF(lwp) WRITE(numout,*) ' ===>> vector form dynamics : total vorticity = Coriolis + relative vorticity' 677 634 nrvm = np_RVO ! relative vorticity 678 ntot = np_CRV ! relative + planetary vorticity 679 ELSE680 IF(lwp) WRITE(numout,*) ' ===>> Flux form advection :vorticity = Coriolis + metric term'635 ntot = np_CRV ! relative + planetary vorticity 636 CASE( np_FLX_c2 , np_FLX_ubs ) 637 IF(lwp) WRITE(numout,*) ' ===>> flux form dynamics : total vorticity = Coriolis + metric term' 681 638 nrvm = np_MET ! metric term 682 639 ntot = np_CME ! Coriolis + metric term 683 END IF640 END SELECT 684 641 685 642 IF(lwp) THEN ! Print the choice 686 643 WRITE(numout,*) 687 IF( nvor_scheme == np_ENE ) WRITE(numout,*) ' ===>> energy conserving scheme' 688 IF( nvor_scheme == np_ENS ) WRITE(numout,*) ' ===>> enstrophy conserving scheme' 689 IF( nvor_scheme == np_MIX ) WRITE(numout,*) ' ===>> mixed enstrophy/energy conserving scheme' 690 IF( nvor_scheme == np_EEN ) WRITE(numout,*) ' ===>> energy and enstrophy conserving scheme' 644 SELECT CASE( nvor_scheme ) 645 CASE( np_ENE ) ; WRITE(numout,*) ' ===>> energy conserving scheme' 646 CASE( np_ENS ) ; WRITE(numout,*) ' ===>> enstrophy conserving scheme' 647 CASE( np_MIX ) ; WRITE(numout,*) ' ===>> mixed enstrophy/energy conserving scheme' 648 CASE( np_EEN ) ; WRITE(numout,*) ' ===>> energy and enstrophy conserving scheme' 649 END SELECT 691 650 ENDIF 692 651 ! -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/DYN/dynzad.F90
r7753 r8568 5 5 !!====================================================================== 6 6 !! History : OPA ! 1991-01 (G. Madec) Original code 7 !! 7.0 ! 1991-11 (G. Madec)8 !! 7.5 ! 1996-01 (G. Madec) statement function for e39 7 !! NEMO 0.5 ! 2002-07 (G. Madec) Free form, F90 10 8 !!---------------------------------------------------------------------- … … 22 20 USE lib_mpp ! MPP library 23 21 USE prtctl ! Print control 24 USE wrk_nemo ! Memory Allocation25 22 USE timing ! Timing 26 23 … … 29 26 30 27 PUBLIC dyn_zad ! routine called by dynadv.F90 31 PUBLIC dyn_zad_zts ! routine called by dynadv.F9032 28 33 29 !! * Substitutions 34 30 # include "vectopt_loop_substitute.h90" 35 31 !!---------------------------------------------------------------------- 36 !! NEMO/OPA 3.3 , NEMO Consortium (2010)32 !! NEMO/OPA 4.0 , NEMO Consortium (2017) 37 33 !! $Id$ 38 34 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 58 54 INTEGER, INTENT(in) :: kt ! ocean time-step inedx 59 55 ! 60 INTEGER :: ji, jj, jk 61 REAL(wp) :: zua, zva ! temporaryscalars62 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwuw , zwvw63 REAL(wp), POINTER, DIMENSION(:,: ) :: zww64 REAL(wp), POINTER, DIMENSION(:,:,:) ::ztrdu, ztrdv56 INTEGER :: ji, jj, jk ! dummy loop indices 57 REAL(wp) :: zua, zva ! local scalars 58 REAL(wp), DIMENSION(jpi,jpj) :: zww 59 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwuw, zwvw 60 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdu, ztrdv 65 61 !!---------------------------------------------------------------------- 66 62 ! 67 IF( nn_timing == 1 ) CALL timing_start('dyn_zad') 68 ! 69 CALL wrk_alloc( jpi,jpj, zww ) 70 CALL wrk_alloc( jpi,jpj,jpk, zwuw , zwvw ) 63 IF( ln_timing ) CALL timing_start('dyn_zad') 71 64 ! 72 65 IF( kt == nit000 ) THEN 73 IF(lwp) WRITE(numout,*)74 IF(lwp) WRITE(numout,*) 'dyn_zad : arakawaadvection scheme'66 IF(lwp) WRITE(numout,*) 67 IF(lwp) WRITE(numout,*) 'dyn_zad : 2nd order vertical advection scheme' 75 68 ENDIF 76 69 77 70 IF( l_trddyn ) THEN ! Save ua and va trends 78 CALL wrk_alloc( jpi, jpj, jpk, ztrdu, ztrdv)71 ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) ) 79 72 ztrdu(:,:,:) = ua(:,:,:) 80 73 ztrdv(:,:,:) = va(:,:,:) … … 96 89 ! 97 90 ! Surface and bottom advective fluxes set to zero 98 IF 91 IF( ln_isfcav ) THEN 99 92 DO jj = 2, jpjm1 100 93 DO ji = fs_2, fs_jpim1 ! vector opt. … … 119 112 DO jj = 2, jpjm1 120 113 DO ji = fs_2, fs_jpim1 ! vector opt. 121 ! ! vertical momentum advective trends 122 zua = - ( zwuw(ji,jj,jk) + zwuw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj) / e3u_n(ji,jj,jk) 123 zva = - ( zwvw(ji,jj,jk) + zwvw(ji,jj,jk+1) ) * r1_e1e2v(ji,jj) / e3v_n(ji,jj,jk) 124 ! ! add the trends to the general momentum trends 125 ua(ji,jj,jk) = ua(ji,jj,jk) + zua 126 va(ji,jj,jk) = va(ji,jj,jk) + zva 114 ua(ji,jj,jk) = ua(ji,jj,jk) - ( zwuw(ji,jj,jk) + zwuw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj) / e3u_n(ji,jj,jk) 115 va(ji,jj,jk) = va(ji,jj,jk) - ( zwvw(ji,jj,jk) + zwvw(ji,jj,jk+1) ) * r1_e1e2v(ji,jj) / e3v_n(ji,jj,jk) 127 116 END DO 128 117 END DO … … 133 122 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 134 123 CALL trd_dyn( ztrdu, ztrdv, jpdyn_zad, kt ) 135 CALL wrk_dealloc( jpi, jpj, jpk,ztrdu, ztrdv )124 DEALLOCATE( ztrdu, ztrdv ) 136 125 ENDIF 137 126 ! ! Control print … … 139 128 & tab3d_2=va, clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) 140 129 ! 141 CALL wrk_dealloc( jpi,jpj, zww ) 142 CALL wrk_dealloc( jpi,jpj,jpk, zwuw , zwvw ) 143 ! 144 IF( nn_timing == 1 ) CALL timing_stop('dyn_zad') 130 IF( ln_timing ) CALL timing_stop('dyn_zad') 145 131 ! 146 132 END SUBROUTINE dyn_zad 147 133 148 149 SUBROUTINE dyn_zad_zts ( kt )150 !!----------------------------------------------------------------------151 !! *** ROUTINE dynzad_zts ***152 !!153 !! ** Purpose : Compute the now vertical momentum advection trend and154 !! add it to the general trend of momentum equation. This version155 !! uses sub-timesteps for improved numerical stability with small156 !! vertical grid sizes. This is especially relevant when using157 !! embedded ice with thin surface boxes.158 !!159 !! ** Method : The now vertical advection of momentum is given by:160 !! w dz(u) = ua + 1/(e1u*e2u*e3u) mk+1[ mi(e1t*e2t*wn) dk(un) ]161 !! w dz(v) = va + 1/(e1v*e2v*e3v) mk+1[ mj(e1t*e2t*wn) dk(vn) ]162 !! Add this trend to the general trend (ua,va):163 !! (ua,va) = (ua,va) + w dz(u,v)164 !!165 !! ** Action : - Update (ua,va) with the vert. momentum adv. trends166 !! - Save the trends in (ztrdu,ztrdv) ('key_trddyn')167 !!----------------------------------------------------------------------168 INTEGER, INTENT(in) :: kt ! ocean time-step inedx169 !170 INTEGER :: ji, jj, jk, jl ! dummy loop indices171 INTEGER :: jnzts = 5 ! number of sub-timesteps for vertical advection172 INTEGER :: jtb, jtn, jta ! sub timestep pointers for leap-frog/euler forward steps173 REAL(wp) :: zua, zva ! temporary scalars174 REAL(wp) :: zr_rdt ! temporary scalar175 REAL(wp) :: z2dtzts ! length of Euler forward sub-timestep for vertical advection176 REAL(wp) :: zts ! length of sub-timestep for vertical advection177 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwuw , zwvw, zww178 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdu, ztrdv179 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: zus , zvs180 !!----------------------------------------------------------------------181 !182 IF( nn_timing == 1 ) CALL timing_start('dyn_zad_zts')183 !184 CALL wrk_alloc( jpi,jpj,jpk, zwuw, zwvw, zww )185 CALL wrk_alloc( jpi,jpj,jpk,3, zus , zvs )186 !187 IF( kt == nit000 ) THEN188 IF(lwp)WRITE(numout,*)189 IF(lwp)WRITE(numout,*) 'dyn_zad_zts : arakawa advection scheme with sub-timesteps'190 ENDIF191 192 IF( l_trddyn ) THEN ! Save ua and va trends193 CALL wrk_alloc( jpi, jpj, jpk, ztrdu, ztrdv )194 ztrdu(:,:,:) = ua(:,:,:)195 ztrdv(:,:,:) = va(:,:,:)196 ENDIF197 198 IF( neuler == 0 .AND. kt == nit000 ) THEN199 z2dtzts = rdt / REAL( jnzts, wp ) ! = rdt (restart with Euler time stepping)200 ELSE201 z2dtzts = 2._wp * rdt / REAL( jnzts, wp ) ! = 2 rdt (leapfrog)202 ENDIF203 204 DO jk = 2, jpkm1 ! Calculate and store vertical fluxes205 DO jj = 2, jpj206 DO ji = fs_2, jpi ! vector opt.207 zww(ji,jj,jk) = 0.25_wp * e1e2t(ji,jj) * wn(ji,jj,jk)208 END DO209 END DO210 END DO211 212 DO jj = 2, jpjm1 ! Surface and bottom advective fluxes set to zero213 DO ji = fs_2, fs_jpim1 ! vector opt.214 !!gm missing ISF boundary condition215 zwuw(ji,jj, 1 ) = 0._wp216 zwvw(ji,jj, 1 ) = 0._wp217 zwuw(ji,jj,jpk) = 0._wp218 zwvw(ji,jj,jpk) = 0._wp219 END DO220 END DO221 222 ! Start with before values and use sub timestepping to reach after values223 224 zus(:,:,:,1) = ub(:,:,:)225 zvs(:,:,:,1) = vb(:,:,:)226 227 DO jl = 1, jnzts ! Start of sub timestepping loop228 229 IF( jl == 1 ) THEN ! Euler forward to kick things off230 jtb = 1 ; jtn = 1 ; jta = 2231 zts = z2dtzts232 ELSEIF( jl == 2 ) THEN ! First leapfrog step233 jtb = 1 ; jtn = 2 ; jta = 3234 zts = 2._wp * z2dtzts235 ELSE ! Shuffle pointers for subsequent leapfrog steps236 jtb = MOD(jtb,3) + 1237 jtn = MOD(jtn,3) + 1238 jta = MOD(jta,3) + 1239 ENDIF240 241 DO jk = 2, jpkm1 ! Vertical momentum advection at level w and u- and v- vertical242 DO jj = 2, jpjm1 ! vertical momentum advection at w-point243 DO ji = fs_2, fs_jpim1 ! vector opt.244 zwuw(ji,jj,jk) = ( zww(ji+1,jj ,jk) + zww(ji,jj,jk) ) * ( zus(ji,jj,jk-1,jtn)-zus(ji,jj,jk,jtn) ) !* wumask(ji,jj,jk)245 zwvw(ji,jj,jk) = ( zww(ji ,jj+1,jk) + zww(ji,jj,jk) ) * ( zvs(ji,jj,jk-1,jtn)-zvs(ji,jj,jk,jtn) ) !* wvmask(ji,jj,jk)246 END DO247 END DO248 END DO249 DO jk = 1, jpkm1 ! Vertical momentum advection at u- and v-points250 DO jj = 2, jpjm1251 DO ji = fs_2, fs_jpim1 ! vector opt.252 ! ! vertical momentum advective trends253 zua = - ( zwuw(ji,jj,jk) + zwuw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj) / e3u_n(ji,jj,jk)254 zva = - ( zwvw(ji,jj,jk) + zwvw(ji,jj,jk+1) ) * r1_e1e2v(ji,jj) / e3v_n(ji,jj,jk)255 zus(ji,jj,jk,jta) = zus(ji,jj,jk,jtb) + zua * zts256 zvs(ji,jj,jk,jta) = zvs(ji,jj,jk,jtb) + zva * zts257 END DO258 END DO259 END DO260 261 END DO ! End of sub timestepping loop262 263 zr_rdt = 1._wp / ( REAL( jnzts, wp ) * z2dtzts )264 DO jk = 1, jpkm1 ! Recover trends over the outer timestep265 DO jj = 2, jpjm1266 DO ji = fs_2, fs_jpim1 ! vector opt.267 ! ! vertical momentum advective trends268 ! ! add the trends to the general momentum trends269 ua(ji,jj,jk) = ua(ji,jj,jk) + ( zus(ji,jj,jk,jta) - ub(ji,jj,jk)) * zr_rdt270 va(ji,jj,jk) = va(ji,jj,jk) + ( zvs(ji,jj,jk,jta) - vb(ji,jj,jk)) * zr_rdt271 END DO272 END DO273 END DO274 275 IF( l_trddyn ) THEN ! save the vertical advection trends for diagnostic276 ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:)277 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:)278 CALL trd_dyn( ztrdu, ztrdv, jpdyn_zad, kt )279 CALL wrk_dealloc( jpi, jpj, jpk, ztrdu, ztrdv )280 ENDIF281 ! ! Control print282 IF(ln_ctl) CALL prt_ctl( tab3d_1=ua, clinfo1=' zad - Ua: ', mask1=umask, &283 & tab3d_2=va, clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' )284 !285 CALL wrk_dealloc( jpi,jpj,jpk, zwuw, zwvw, zww )286 CALL wrk_dealloc( jpi,jpj,jpk,3, zus , zvs )287 !288 IF( nn_timing == 1 ) CALL timing_stop('dyn_zad_zts')289 !290 END SUBROUTINE dyn_zad_zts291 292 134 !!====================================================================== 293 135 END MODULE dynzad -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/DYN/dynzdf.F90
r8367 r8568 76 76 !!--------------------------------------------------------------------- 77 77 ! 78 IF( nn_timing == 1) CALL timing_start('dyn_zdf')78 IF( ln_timing ) CALL timing_start('dyn_zdf') 79 79 ! 80 80 IF( kt == nit000 ) THEN !* initialization … … 392 392 & tab3d_2=va, clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) 393 393 ! 394 IF( nn_timing == 1) CALL timing_stop('dyn_zdf')394 IF( ln_timing ) CALL timing_stop('dyn_zdf') 395 395 ! 396 396 END SUBROUTINE dyn_zdf -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/DYN/sshwzv.F90
r7753 r8568 22 22 USE divhor ! horizontal divergence 23 23 USE phycst ! physical constants 24 USE bdy_oce , ONLY: ln_bdy, bdytmask24 USE bdy_oce , ONLY : ln_bdy, bdytmask ! Open BounDarY 25 25 USE bdydyn2d ! bdy_ssh routine 26 26 #if defined key_agrif … … 36 36 USE lbclnk ! ocean lateral boundary condition (or mpp link) 37 37 USE lib_mpp ! MPP library 38 USE wrk_nemo ! Memory Allocation39 38 USE timing ! Timing 40 USE wet_dry 39 USE wet_dry ! Wetting/Drying flux limting 41 40 42 41 IMPLICIT NONE … … 74 73 INTEGER :: jk ! dummy loop indice 75 74 REAL(wp) :: z2dt, zcoef ! local scalars 76 REAL(wp), POINTER, DIMENSION(:,: ) :: zhdiv ! 2D workspace 77 !!---------------------------------------------------------------------- 78 ! 79 IF( nn_timing == 1 ) CALL timing_start('ssh_nxt') 80 ! 81 CALL wrk_alloc( jpi,jpj, zhdiv ) 75 REAL(wp), DIMENSION(jpi,jpj) :: zhdiv ! 2D workspace 76 !!---------------------------------------------------------------------- 77 ! 78 IF( ln_timing ) CALL timing_start('ssh_nxt') 82 79 ! 83 80 IF( kt == nit000 ) THEN … … 134 131 IF(ln_ctl) CALL prt_ctl( tab2d_1=ssha, clinfo1=' ssha - : ', mask1=tmask, ovlap=1 ) 135 132 ! 136 CALL wrk_dealloc( jpi, jpj, zhdiv ) 137 ! 138 IF( nn_timing == 1 ) CALL timing_stop('ssh_nxt') 133 IF( ln_timing ) CALL timing_stop('ssh_nxt') 139 134 ! 140 135 END SUBROUTINE ssh_nxt … … 160 155 INTEGER :: ji, jj, jk ! dummy loop indices 161 156 REAL(wp) :: z1_2dt ! local scalars 162 REAL(wp), POINTER, DIMENSION(:,: ) :: z2d 163 REAL(wp), POINTER, DIMENSION(:,:,:) :: z3d, zhdiv 164 !!---------------------------------------------------------------------- 165 ! 166 IF( nn_timing == 1 ) CALL timing_start('wzv') 157 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zhdiv 158 !!---------------------------------------------------------------------- 159 ! 160 IF( ln_timing ) CALL timing_start('wzv') 167 161 ! 168 162 IF( kt == nit000 ) THEN … … 180 174 ! 181 175 IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! z_tilde and layer cases 182 CALL wrk_alloc( jpi, jpj, jpk, zhdiv)176 ALLOCATE( zhdiv(jpi,jpj,jpk) ) 183 177 ! 184 178 DO jk = 1, jpkm1 … … 200 194 END DO 201 195 ! IF( ln_vvl_layer ) wn(:,:,:) = 0.e0 202 CALL wrk_dealloc( jpi, jpj, jpk,zhdiv )196 DEALLOCATE( zhdiv ) 203 197 ELSE ! z_star and linear free surface cases 204 198 DO jk = jpkm1, 1, -1 ! integrate from the bottom the hor. divergence … … 215 209 ENDIF 216 210 ! 217 IF( nn_timing == 1 )CALL timing_stop('wzv')211 IF( ln_timing ) CALL timing_stop('wzv') 218 212 ! 219 213 END SUBROUTINE wzv … … 244 238 !!---------------------------------------------------------------------- 245 239 ! 246 IF( nn_timing == 1) CALL timing_start('ssh_swp')240 IF( ln_timing ) CALL timing_start('ssh_swp') 247 241 ! 248 242 IF( kt == nit000 ) THEN … … 271 265 IF(ln_ctl) CALL prt_ctl( tab2d_1=sshb, clinfo1=' sshb - : ', mask1=tmask, ovlap=1 ) 272 266 ! 273 IF( nn_timing == 1) CALL timing_stop('ssh_swp')267 IF( ln_timing ) CALL timing_stop('ssh_swp') 274 268 ! 275 269 END SUBROUTINE ssh_swp -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/DYN/wet_dry.F90
r7646 r8568 11 11 12 12 !!---------------------------------------------------------------------- 13 !! wad_lmt : Compute the horizontal flux limiter and the limited velocity 14 !! when wetting and drying happens 15 !!---------------------------------------------------------------------- 16 USE oce ! ocean dynamics and tracers 17 USE dom_oce ! ocean space and time domain 18 USE sbc_oce, ONLY : ln_rnf ! surface boundary condition: ocean 19 USE sbcrnf ! river runoff 20 USE in_out_manager ! I/O manager 21 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 22 USE lib_mpp ! MPP library 23 USE wrk_nemo ! Memory Allocation 24 USE timing ! Timing 13 !! wad_init : initialisation of wetting and drying 14 !! wad_lmt : horizontal flux limiter and limited velocity when wetting and drying happens 15 !! wad_lmt_bt : same as wad_lmt for the barotropic stepping (dynspg_ts) 16 !!---------------------------------------------------------------------- 17 USE oce ! ocean dynamics and tracers 18 USE dom_oce ! ocean space and time domain 19 USE sbc_oce , ONLY: ln_rnf ! surface boundary condition: ocean 20 USE sbcrnf ! river runoff 21 ! 22 USE in_out_manager ! I/O manager 23 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 24 USE lib_mpp ! MPP library 25 USE timing ! Timing 25 26 26 27 IMPLICIT NONE … … 31 32 !! --------------------------------------------------------------------- 32 33 33 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: wdmask 34 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: ht_wd 35 34 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: wdmask !: u- and v- limiter 35 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: ht_wd !: wetting and drying t-pt depths 36 ! ! (can include negative depths) 36 37 37 38 LOGICAL, PUBLIC :: ln_wd !: Wetting/drying activation switch (T:on,F:off) 38 39 REAL(wp), PUBLIC :: rn_wdmin1 !: minimum water depth on dried cells 39 40 REAL(wp), PUBLIC :: rn_wdmin2 !: tolerrance of minimum water depth on dried cells 40 REAL(wp), PUBLIC :: rn_wdld !: land elevation below which wetting/drying 41 !: will be considered 41 REAL(wp), PUBLIC :: rn_wdld !: land elevation below which wetting/drying will be considered 42 42 INTEGER , PUBLIC :: nn_wdit !: maximum number of iteration for W/D limiter 43 43 … … 48 48 !! * Substitutions 49 49 # include "vectopt_loop_substitute.h90" 50 !!---------------------------------------------------------------------- 50 51 CONTAINS 51 52 … … 58 59 !! ** input : - namwad namelist 59 60 !!---------------------------------------------------------------------- 61 INTEGER :: ios, ierr ! Local integer 62 !! 60 63 NAMELIST/namwad/ ln_wd, rn_wdmin1, rn_wdmin2, rn_wdld, nn_wdit 61 INTEGER :: ios ! Local integer output status for namelist read 62 INTEGER :: ierr ! Local integer status array allocation 63 !!---------------------------------------------------------------------- 64 65 REWIND( numnam_ref ) ! Namelist namwad in reference namelist 66 ! : Parameters for Wetting/Drying 64 !!---------------------------------------------------------------------- 65 ! 66 REWIND( numnam_ref ) ! Namelist namwad in reference namelist : Parameters for Wetting/Drying 67 67 READ ( numnam_ref, namwad, IOSTAT = ios, ERR = 905) 68 68 905 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namwad in reference namelist', .TRUE.) 69 REWIND( numnam_cfg ) ! Namelist namwad in configuration namelist 70 ! : Parameters for Wetting/Drying 69 REWIND( numnam_cfg ) ! Namelist namwad in configuration namelist : Parameters for Wetting/Drying 71 70 READ ( numnam_cfg, namwad, IOSTAT = ios, ERR = 906) 72 71 906 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namwad in configuration namelist', .TRUE. ) 73 72 IF(lwm) WRITE ( numond, namwad ) 74 73 ! 75 74 IF(lwp) THEN ! control print 76 75 WRITE(numout,*) … … 103 102 !! ** Action : - calculate flux limiter and W/D flag 104 103 !!---------------------------------------------------------------------- 105 REAL(wp), DIMENSION(:,:), INTENT(inout) :: sshb1 106 REAL(wp), DIMENSION(:,:), INTENT(in ):: sshemp107 REAL(wp) , INTENT(in) ::z2dt104 REAL(wp), DIMENSION(:,:), INTENT(inout) :: sshb1 !!gm DOCTOR names: should start with p ! 105 REAL(wp), DIMENSION(:,:), INTENT(in ) :: sshemp 106 REAL(wp) , INTENT(in ) :: z2dt 108 107 ! 109 108 INTEGER :: ji, jj, jk, jk1 ! dummy loop indices … … 113 112 REAL(wp) :: zdepwd ! local scalar, always wet cell depth 114 113 REAL(wp) :: ztmp ! local scalars 115 REAL(wp), POINTER, DIMENSION(:,:) :: zwdlmtu, zwdlmtv !: W/D flux limiters 116 REAL(wp), POINTER, DIMENSION(:,:) :: zflxp, zflxn ! local 2D workspace 117 REAL(wp), POINTER, DIMENSION(:,:) :: zflxu, zflxv ! local 2D workspace 118 REAL(wp), POINTER, DIMENSION(:,:) :: zflxu1, zflxv1 ! local 2D workspace 119 !!---------------------------------------------------------------------- 120 ! 121 122 IF( nn_timing == 1 ) CALL timing_start('wad_lmt') 123 124 IF(ln_wd) THEN 125 126 CALL wrk_alloc( jpi, jpj, zflxp, zflxn, zflxu, zflxv, zflxu1, zflxv1 ) 127 CALL wrk_alloc( jpi, jpj, zwdlmtu, zwdlmtv) 128 ! 129 130 !IF(lwp) WRITE(numout,*) 131 !IF(lwp) WRITE(numout,*) 'wad_lmt : wetting/drying limiters and velocity limiting' 132 133 jflag = 0 134 zdepwd = 50._wp !maximum depth on which that W/D could possibly happen 135 136 137 zflxp(:,:) = 0._wp 138 zflxn(:,:) = 0._wp 139 zflxu(:,:) = 0._wp 140 zflxv(:,:) = 0._wp 141 142 zwdlmtu(:,:) = 1._wp 143 zwdlmtv(:,:) = 1._wp 144 145 ! Horizontal Flux in u and v direction 146 DO jk = 1, jpkm1 147 DO jj = 1, jpj 148 DO ji = 1, jpi 149 zflxu(ji,jj) = zflxu(ji,jj) + e3u_n(ji,jj,jk) * un(ji,jj,jk) * umask(ji,jj,jk) 150 zflxv(ji,jj) = zflxv(ji,jj) + e3v_n(ji,jj,jk) * vn(ji,jj,jk) * vmask(ji,jj,jk) 151 END DO 152 END DO 153 END DO 154 155 zflxu(:,:) = zflxu(:,:) * e2u(:,:) 156 zflxv(:,:) = zflxv(:,:) * e1v(:,:) 157 158 wdmask(:,:) = 1 159 DO jj = 2, jpj 160 DO ji = 2, jpi 161 162 IF( tmask(ji, jj, 1) < 0.5_wp ) CYCLE ! we don't care about land cells 163 IF( ht_wd(ji,jj) > zdepwd ) CYCLE ! and cells which are unlikely to dry 164 165 zflxp(ji,jj) = max(zflxu(ji,jj), 0._wp) - min(zflxu(ji-1,jj), 0._wp) + & 166 & max(zflxv(ji,jj), 0._wp) - min(zflxv(ji, jj-1), 0._wp) 167 zflxn(ji,jj) = min(zflxu(ji,jj), 0._wp) - max(zflxu(ji-1,jj), 0._wp) + & 168 & min(zflxv(ji,jj), 0._wp) - max(zflxv(ji, jj-1), 0._wp) 169 170 zdep2 = ht_wd(ji,jj) + sshb1(ji,jj) - rn_wdmin1 171 IF(zdep2 .le. 0._wp) THEN !add more safty, but not necessary 172 sshb1(ji,jj) = rn_wdmin1 - ht_wd(ji,jj) 173 IF(zflxu(ji, jj) > 0._wp) zwdlmtu(ji ,jj) = 0._wp 174 IF(zflxu(ji-1,jj) < 0._wp) zwdlmtu(ji-1,jj) = 0._wp 175 IF(zflxv(ji, jj) > 0._wp) zwdlmtv(ji ,jj) = 0._wp 176 IF(zflxv(ji,jj-1) < 0._wp) zwdlmtv(ji,jj-1) = 0._wp 177 wdmask(ji,jj) = 0._wp 178 END IF 179 ENDDO 180 END DO 181 182 183 !! start limiter iterations 184 DO jk1 = 1, nn_wdit + 1 185 186 187 zflxu1(:,:) = zflxu(:,:) * zwdlmtu(:,:) 188 zflxv1(:,:) = zflxv(:,:) * zwdlmtv(:,:) 189 jflag = 0 ! flag indicating if any further iterations are needed 190 191 DO jj = 2, jpj 192 DO ji = 2, jpi 193 194 IF( tmask(ji, jj, 1) < 0.5_wp ) CYCLE 195 IF( ht_wd(ji,jj) > zdepwd ) CYCLE 196 197 ztmp = e1e2t(ji,jj) 198 199 zzflxp = max(zflxu1(ji,jj), 0._wp) - min(zflxu1(ji-1,jj), 0._wp) + & 200 & max(zflxv1(ji,jj), 0._wp) - min(zflxv1(ji, jj-1), 0._wp) 201 zzflxn = min(zflxu1(ji,jj), 0._wp) - max(zflxu1(ji-1,jj), 0._wp) + & 202 & min(zflxv1(ji,jj), 0._wp) - max(zflxv1(ji, jj-1), 0._wp) 203 204 zdep1 = (zzflxp + zzflxn) * z2dt / ztmp 205 zdep2 = ht_wd(ji,jj) + sshb1(ji,jj) - rn_wdmin1 - z2dt * sshemp(ji,jj) 206 207 IF( zdep1 > zdep2 ) THEN 208 wdmask(ji, jj) = 0 209 zcoef = ( ( zdep2 - rn_wdmin2 ) * ztmp - zzflxn * z2dt ) / ( zflxp(ji,jj) * z2dt ) 210 !zcoef = ( ( zdep2 - rn_wdmin2 ) * ztmp - zzflxn * z2dt ) / ( zzflxp * z2dt ) 211 ! flag if the limiter has been used but stop flagging if the only 212 ! changes have zeroed the coefficient since further iterations will 213 ! not change anything 214 IF( zcoef > 0._wp ) THEN 215 jflag = 1 216 ELSE 217 zcoef = 0._wp 218 ENDIF 219 IF(jk1 > nn_wdit) zcoef = 0._wp 220 IF(zflxu1(ji, jj) > 0._wp) zwdlmtu(ji ,jj) = zcoef 221 IF(zflxu1(ji-1,jj) < 0._wp) zwdlmtu(ji-1,jj) = zcoef 222 IF(zflxv1(ji, jj) > 0._wp) zwdlmtv(ji ,jj) = zcoef 223 IF(zflxv1(ji,jj-1) < 0._wp) zwdlmtv(ji,jj-1) = zcoef 224 END IF 225 END DO ! ji loop 226 END DO ! jj loop 227 228 CALL lbc_lnk( zwdlmtu, 'U', 1. ) 229 CALL lbc_lnk( zwdlmtv, 'V', 1. ) 230 231 IF(lk_mpp) CALL mpp_max(jflag) !max over the global domain 232 233 IF(jflag == 0) EXIT 234 235 END DO ! jk1 loop 236 237 DO jk = 1, jpkm1 238 un(:,:,jk) = un(:,:,jk) * zwdlmtu(:, :) 239 vn(:,:,jk) = vn(:,:,jk) * zwdlmtv(:, :) 240 END DO 241 242 CALL lbc_lnk( un, 'U', -1. ) 243 CALL lbc_lnk( vn, 'V', -1. ) 244 ! 245 un_b(:,:) = un_b(:,:) * zwdlmtu(:, :) 246 vn_b(:,:) = vn_b(:,:) * zwdlmtv(:, :) 247 CALL lbc_lnk( un_b, 'U', -1. ) 248 CALL lbc_lnk( vn_b, 'V', -1. ) 249 250 IF(jflag == 1 .AND. lwp) WRITE(numout,*) 'Need more iterations in wad_lmt!!!' 251 252 !IF( ln_rnf ) CALL sbc_rnf_div( hdivn ) ! runoffs (update hdivn field) 253 !IF( nn_cla == 1 ) CALL cla_div ( kt ) ! Cross Land Advection (update hdivn field) 254 ! 255 ! 256 CALL wrk_dealloc( jpi, jpj, zflxp, zflxn, zflxu, zflxv, zflxu1, zflxv1 ) 257 CALL wrk_dealloc( jpi, jpj, zwdlmtu, zwdlmtv) 258 ! 259 ENDIF 260 ! 261 IF( nn_timing == 1 ) CALL timing_stop('wad_lmt') 114 REAL(wp), DIMENSION(jpi,jpj) :: zwdlmtu, zwdlmtv ! W/D flux limiters 115 REAL(wp), DIMENSION(jpi,jpj) :: zflxp , zflxn ! local 2D workspace 116 REAL(wp), DIMENSION(jpi,jpj) :: zflxu , zflxv ! local 2D workspace 117 REAL(wp), DIMENSION(jpi,jpj) :: zflxu1 , zflxv1 ! local 2D workspace 118 !!---------------------------------------------------------------------- 119 ! 120 IF( ln_timing ) CALL timing_start('wad_lmt') 121 ! 122 !IF(lwp) WRITE(numout,*) 123 !IF(lwp) WRITE(numout,*) 'wad_lmt : wetting/drying limiters and velocity limiting' 124 ! 125 jflag = 0 126 zdepwd = 50._wp !maximum depth on which that W/D could possibly happen 127 ! 128 zflxp(:,:) = 0._wp 129 zflxn(:,:) = 0._wp 130 zflxu(:,:) = 0._wp 131 zflxv(:,:) = 0._wp 132 ! 133 zwdlmtu(:,:) = 1._wp 134 zwdlmtv(:,:) = 1._wp 135 ! 136 ! Horizontal Flux in u and v direction 137 DO jk = 1, jpkm1 138 DO jj = 1, jpj 139 DO ji = 1, jpi 140 zflxu(ji,jj) = zflxu(ji,jj) + e3u_n(ji,jj,jk) * un(ji,jj,jk) * umask(ji,jj,jk) 141 zflxv(ji,jj) = zflxv(ji,jj) + e3v_n(ji,jj,jk) * vn(ji,jj,jk) * vmask(ji,jj,jk) 142 END DO 143 END DO 144 END DO 145 ! 146 zflxu(:,:) = zflxu(:,:) * e2u(:,:) 147 zflxv(:,:) = zflxv(:,:) * e1v(:,:) 148 ! 149 wdmask(:,:) = 1 150 DO jj = 2, jpj 151 DO ji = 2, jpi 152 ! 153 IF( tmask(ji, jj, 1) < 0.5_wp ) CYCLE ! we don't care about land cells 154 IF( ht_wd(ji,jj) > zdepwd ) CYCLE ! and cells which are unlikely to dry 155 ! 156 zflxp(ji,jj) = MAX( zflxu(ji,jj) , 0._wp ) - MIN( zflxu(ji-1,jj) , 0._wp ) & 157 & + MAX( zflxv(ji,jj) , 0._wp ) - MIN( zflxv(ji,jj-1) , 0._wp ) 158 zflxn(ji,jj) = MIN( zflxu(ji,jj) , 0._wp ) - MAX( zflxu(ji-1,jj) , 0._wp ) & 159 & + MIN( zflxv(ji,jj) , 0._wp ) - MAX( zflxv(ji,jj-1) , 0._wp ) 160 ! 161 zdep2 = ht_wd(ji,jj) + sshb1(ji,jj) - rn_wdmin1 162 IF( zdep2 .le. 0._wp) THEN !add more safty, but not necessary 163 sshb1(ji,jj) = rn_wdmin1 - ht_wd(ji,jj) 164 IF( zflxu(ji, jj) > 0._wp ) zwdlmtu(ji ,jj) = 0._wp 165 IF( zflxu(ji-1,jj) < 0._wp ) zwdlmtu(ji-1,jj) = 0._wp 166 IF( zflxv(ji, jj) > 0._wp ) zwdlmtv(ji ,jj) = 0._wp 167 IF( zflxv(ji,jj-1) < 0._wp ) zwdlmtv(ji,jj-1) = 0._wp 168 wdmask(ji,jj) = 0._wp 169 ENDIF 170 END DO 171 END DO 172 !! 173 !! start limiter iterations 174 DO jk1 = 1, nn_wdit + 1 175 ! 176 zflxu1(:,:) = zflxu(:,:) * zwdlmtu(:,:) 177 zflxv1(:,:) = zflxv(:,:) * zwdlmtv(:,:) 178 jflag = 0 ! flag indicating if any further iterations are needed 179 ! 180 DO jj = 2, jpj 181 DO ji = 2, jpi 182 ! 183 IF( tmask(ji,jj,1) < 0.5_wp ) CYCLE 184 IF( ht_wd(ji,jj) > zdepwd ) CYCLE 185 ! 186 ztmp = e1e2t(ji,jj) 187 ! 188 zzflxp = MAX( zflxu1(ji,jj) , 0._wp ) - MIN( zflxu1(ji-1,jj) , 0._wp ) & 189 & + MAX( zflxv1(ji,jj) , 0._wp ) - MIN( zflxv1(ji,jj-1) , 0._wp ) 190 zzflxn = MIN( zflxu1(ji,jj) , 0._wp ) - MAX( zflxu1(ji-1,jj) , 0._wp ) & 191 & + MIN( zflxv1(ji,jj) , 0._wp ) - MAX( zflxv1(ji,jj-1) , 0._wp ) 192 ! 193 zdep1 = (zzflxp + zzflxn) * z2dt / ztmp 194 zdep2 = ht_wd(ji,jj) + sshb1(ji,jj) - rn_wdmin1 - z2dt * sshemp(ji,jj) 195 ! 196 IF( zdep1 > zdep2 ) THEN 197 wdmask(ji, jj) = 0 198 zcoef = ( ( zdep2 - rn_wdmin2 ) * ztmp - zzflxn * z2dt ) / ( zflxp(ji,jj) * z2dt ) 199 !zcoef = ( ( zdep2 - rn_wdmin2 ) * ztmp - zzflxn * z2dt ) / ( zzflxp * z2dt ) 200 ! flag if the limiter has been used but stop flagging if the only 201 ! changes have zeroed the coefficient since further iterations will 202 ! not change anything 203 IF( zcoef > 0._wp ) THEN ; jflag = 1 204 ELSE ; zcoef = 0._wp 205 ENDIF 206 IF( jk1 > nn_wdit ) zcoef = 0._wp 207 IF( zflxu1(ji, jj) > 0._wp ) zwdlmtu(ji ,jj) = zcoef 208 IF( zflxu1(ji-1,jj) < 0._wp ) zwdlmtu(ji-1,jj) = zcoef 209 IF( zflxv1(ji, jj) > 0._wp ) zwdlmtv(ji ,jj) = zcoef 210 IF( zflxv1(ji,jj-1) < 0._wp ) zwdlmtv(ji,jj-1) = zcoef 211 ENDIF 212 END DO ! ji loop 213 END DO ! jj loop 214 ! 215 CALL lbc_lnk( zwdlmtu, 'U', 1. ) 216 CALL lbc_lnk( zwdlmtv, 'V', 1. ) 217 ! 218 IF(lk_mpp) CALL mpp_max(jflag) !max over the global domain 219 ! 220 IF(jflag == 0) EXIT 221 ! 222 END DO ! jk1 loop 223 224 DO jk = 1, jpkm1 225 un(:,:,jk) = un(:,:,jk) * zwdlmtu(:,:) 226 vn(:,:,jk) = vn(:,:,jk) * zwdlmtv(:,:) 227 END DO 228 229 !!gm ==> Andrew : the lbclnk below is useless since above lbclnk is applied on zwdlmtu/v 230 !! and un, vn always with lbclnk 231 CALL lbc_lnk( un, 'U', -1. ) 232 CALL lbc_lnk( vn, 'V', -1. ) 233 !!gm end 234 ! 235 un_b(:,:) = un_b(:,:) * zwdlmtu(:,:) 236 vn_b(:,:) = vn_b(:,:) * zwdlmtv(:,:) 237 !!gm ==> Andrew : probably same as above 238 CALL lbc_lnk( un_b, 'U', -1. ) 239 CALL lbc_lnk( vn_b, 'V', -1. ) 240 !!gm end 241 242 IF(jflag == 1 .AND. lwp) WRITE(numout,*) 'Need more iterations in wad_lmt!!!' 243 244 !IF( ln_rnf ) CALL sbc_rnf_div( hdivn ) ! runoffs (update hdivn field) 245 !IF( nn_cla == 1 ) CALL cla_div ( kt ) ! Cross Land Advection (update hdivn field) 246 ! 247 ! 248 ! 249 IF( ln_timing ) CALL timing_stop('wad_lmt') 262 250 ! 263 251 END SUBROUTINE wad_lmt … … 284 272 REAL(wp) :: zdepwd ! local scalar, always wet cell depth 285 273 REAL(wp) :: ztmp ! local scalars 286 REAL(wp), POINTER, DIMENSION(:,:) :: zwdlmtu, zwdlmtv !: W/D flux limiters 287 REAL(wp), POINTER, DIMENSION(:,:) :: zflxp, zflxn ! local 2D workspace 288 REAL(wp), POINTER, DIMENSION(:,:) :: zflxu1, zflxv1 ! local 2D workspace 289 !!---------------------------------------------------------------------- 290 ! 291 IF( nn_timing == 1 ) CALL timing_start('wad_lmt_bt') 292 293 IF(ln_wd) THEN 294 295 CALL wrk_alloc( jpi, jpj, zflxp, zflxn, zflxu1, zflxv1 ) 296 CALL wrk_alloc( jpi, jpj, zwdlmtu, zwdlmtv) 297 ! 298 299 !IF(lwp) WRITE(numout,*) 300 !IF(lwp) WRITE(numout,*) 'wad_lmt_bt : wetting/drying limiters and velocity limiting' 301 302 jflag = 0 303 zdepwd = 50._wp !maximum depth that ocean cells can have W/D processes 304 305 z2dt = rdtbt 306 307 zflxp(:,:) = 0._wp 308 zflxn(:,:) = 0._wp 309 310 zwdlmtu(:,:) = 1._wp 311 zwdlmtv(:,:) = 1._wp 312 313 ! Horizontal Flux in u and v direction 314 315 DO jj = 2, jpj 316 DO ji = 2, jpi 317 318 IF( tmask(ji, jj, 1 ) < 0.5_wp) CYCLE ! we don't care about land cells 319 IF( ht_wd(ji,jj) > zdepwd ) CYCLE ! and cells which are unlikely to dry 320 321 zflxp(ji,jj) = max(zflxu(ji,jj), 0._wp) - min(zflxu(ji-1,jj), 0._wp) + & 322 & max(zflxv(ji,jj), 0._wp) - min(zflxv(ji, jj-1), 0._wp) 323 zflxn(ji,jj) = min(zflxu(ji,jj), 0._wp) - max(zflxu(ji-1,jj), 0._wp) + & 324 & min(zflxv(ji,jj), 0._wp) - max(zflxv(ji, jj-1), 0._wp) 325 326 zdep2 = ht_wd(ji,jj) + sshn_e(ji,jj) - rn_wdmin1 327 IF(zdep2 .le. 0._wp) THEN !add more safety, but not necessary 328 sshn_e(ji,jj) = rn_wdmin1 - ht_wd(ji,jj) 329 IF(zflxu(ji, jj) > 0._wp) zwdlmtu(ji ,jj) = 0._wp 330 IF(zflxu(ji-1,jj) < 0._wp) zwdlmtu(ji-1,jj) = 0._wp 331 IF(zflxv(ji, jj) > 0._wp) zwdlmtv(ji ,jj) = 0._wp 332 IF(zflxv(ji,jj-1) < 0._wp) zwdlmtv(ji,jj-1) = 0._wp 333 END IF 334 ENDDO 335 END DO 274 REAL(wp), DIMENSION(jpi,jpj) :: zwdlmtu, zwdlmtv !: W/D flux limiters 275 REAL(wp), DIMENSION(jpi,jpj) :: zflxp, zflxn ! local 2D workspace 276 REAL(wp), DIMENSION(jpi,jpj) :: zflxu1, zflxv1 ! local 2D workspace 277 !!---------------------------------------------------------------------- 278 ! 279 IF( ln_timing ) CALL timing_start('wad_lmt_bt') 280 ! 281 !IF(lwp) WRITE(numout,*) 282 !IF(lwp) WRITE(numout,*) 'wad_lmt_bt : wetting/drying limiters and velocity limiting' 283 284 jflag = 0 285 zdepwd = 50._wp !maximum depth that ocean cells can have W/D processes 286 287 z2dt = rdtbt 288 289 zflxp(:,:) = 0._wp 290 zflxn(:,:) = 0._wp 291 292 zwdlmtu(:,:) = 1._wp 293 zwdlmtv(:,:) = 1._wp 294 295 ! Horizontal Flux in u and v direction 296 297 DO jj = 2, jpj 298 DO ji = 2, jpi 299 ! 300 IF( tmask(ji,jj,1) < 0.5_wp ) CYCLE ! we don't care about land cells 301 IF( ht_wd(ji,jj) > zdepwd ) CYCLE ! and cells which are unlikely to dry 302 ! 303 zflxp(ji,jj) = MAX( zflxu(ji,jj) , 0._wp ) - MIN( zflxu(ji-1,jj) , 0._wp ) & 304 & + MAX( zflxv(ji,jj) , 0._wp ) - MIN( zflxv(ji,jj-1) , 0._wp ) 305 zflxn(ji,jj) = MIN( zflxu(ji,jj) , 0._wp ) - MAX( zflxu(ji-1,jj) , 0._wp ) & 306 & + MIN( zflxv(ji,jj) , 0._wp ) - MAX( zflxv(ji,jj-1) , 0._wp ) 307 308 zdep2 = ht_wd(ji,jj) + sshn_e(ji,jj) - rn_wdmin1 309 IF(zdep2 .le. 0._wp) THEN !add more safety, but not necessary 310 sshn_e(ji,jj) = rn_wdmin1 - ht_wd(ji,jj) 311 IF( zflxu(ji, jj) > 0._wp ) zwdlmtu(ji ,jj) = 0._wp 312 IF( zflxu(ji-1,jj) < 0._wp ) zwdlmtu(ji-1,jj) = 0._wp 313 IF( zflxv(ji, jj) > 0._wp ) zwdlmtv(ji ,jj) = 0._wp 314 IF( zflxv(ji,jj-1) < 0._wp ) zwdlmtv(ji,jj-1) = 0._wp 315 ENDIF 316 END DO 317 END DO 336 318 337 319 338 !! start limiter iterations 339 DO jk1 = 1, nn_wdit + 1 340 320 !! start limiter iterations 321 DO jk1 = 1, nn_wdit + 1 322 ! 323 zflxu1(:,:) = zflxu(:,:) * zwdlmtu(:,:) 324 zflxv1(:,:) = zflxv(:,:) * zwdlmtv(:,:) 325 jflag = 0 ! flag indicating if any further iterations are needed 326 ! 327 DO jj = 2, jpj 328 DO ji = 2, jpi 329 ! 330 IF( tmask(ji,jj, 1 ) < 0.5_wp ) CYCLE 331 IF( ht_wd(ji,jj) > zdepwd ) CYCLE 332 ! 333 ztmp = e1e2t(ji,jj) 334 ! 335 zzflxp = MAX( zflxu1(ji,jj) , 0._wp ) - MIN( zflxu1(ji-1,jj) , 0._wp ) & 336 & + MAX( zflxv1(ji,jj) , 0._wp ) - MIN( zflxv1(ji,jj-1) , 0._wp ) 337 zzflxn = MIN( zflxu1(ji,jj) , 0._wp ) - MAX( zflxu1(ji-1,jj) , 0._wp ) & 338 & + MIN( zflxv1(ji,jj) , 0._wp ) - MAX( zflxv1(ji,jj-1) , 0._wp ) 341 339 342 zflxu1(:,:) = zflxu(:,:) * zwdlmtu(:,:) 343 zflxv1(:,:) = zflxv(:,:) * zwdlmtv(:,:) 344 jflag = 0 ! flag indicating if any further iterations are needed 340 zdep1 = (zzflxp + zzflxn) * z2dt / ztmp 341 zdep2 = ht_wd(ji,jj) + sshn_e(ji,jj) - rn_wdmin1 - z2dt * zssh_frc(ji,jj) 345 342 346 DO jj = 2, jpj 347 DO ji = 2, jpi 348 349 IF( tmask(ji, jj, 1 ) < 0.5_wp) CYCLE 350 IF( ht_wd(ji,jj) > zdepwd ) CYCLE 351 352 ztmp = e1e2t(ji,jj) 353 354 zzflxp = max(zflxu1(ji,jj), 0._wp) - min(zflxu1(ji-1,jj), 0._wp) + & 355 & max(zflxv1(ji,jj), 0._wp) - min(zflxv1(ji, jj-1), 0._wp) 356 zzflxn = min(zflxu1(ji,jj), 0._wp) - max(zflxu1(ji-1,jj), 0._wp) + & 357 & min(zflxv1(ji,jj), 0._wp) - max(zflxv1(ji, jj-1), 0._wp) 358 359 zdep1 = (zzflxp + zzflxn) * z2dt / ztmp 360 zdep2 = ht_wd(ji,jj) + sshn_e(ji,jj) - rn_wdmin1 - z2dt * zssh_frc(ji,jj) 361 362 IF(zdep1 > zdep2) THEN 363 zcoef = ( ( zdep2 - rn_wdmin2 ) * ztmp - zzflxn * z2dt ) / ( zflxp(ji,jj) * z2dt ) 364 !zcoef = ( ( zdep2 - rn_wdmin2 ) * ztmp - zzflxn * z2dt ) / ( zzflxp * z2dt ) 365 ! flag if the limiter has been used but stop flagging if the only 366 ! changes have zeroed the coefficient since further iterations will 367 ! not change anything 368 IF( zcoef > 0._wp ) THEN 343 IF(zdep1 > zdep2) THEN 344 zcoef = ( ( zdep2 - rn_wdmin2 ) * ztmp - zzflxn * z2dt ) / ( zflxp(ji,jj) * z2dt ) 345 !zcoef = ( ( zdep2 - rn_wdmin2 ) * ztmp - zzflxn * z2dt ) / ( zzflxp * z2dt ) 346 ! flag if the limiter has been used but stop flagging if the only 347 ! changes have zeroed the coefficient since further iterations will 348 ! not change anything 349 IF( zcoef > 0._wp ) THEN 369 350 jflag = 1 370 351 ELSE 371 352 zcoef = 0._wp 372 ENDIF 373 IF(jk1 > nn_wdit) zcoef = 0._wp 374 IF(zflxu1(ji, jj) > 0._wp) zwdlmtu(ji ,jj) = zcoef 375 IF(zflxu1(ji-1,jj) < 0._wp) zwdlmtu(ji-1,jj) = zcoef 376 IF(zflxv1(ji, jj) > 0._wp) zwdlmtv(ji ,jj) = zcoef 377 IF(zflxv1(ji,jj-1) < 0._wp) zwdlmtv(ji,jj-1) = zcoef 378 END IF 379 END DO ! ji loop 380 END DO ! jj loop 381 382 CALL lbc_lnk( zwdlmtu, 'U', 1. ) 383 CALL lbc_lnk( zwdlmtv, 'V', 1. ) 384 385 IF(lk_mpp) CALL mpp_max(jflag) !max over the global domain 386 387 IF(jflag == 0) EXIT 388 389 END DO ! jk1 loop 390 391 zflxu(:,:) = zflxu(:,:) * zwdlmtu(:, :) 392 zflxv(:,:) = zflxv(:,:) * zwdlmtv(:, :) 393 394 CALL lbc_lnk( zflxu, 'U', -1. ) 395 CALL lbc_lnk( zflxv, 'V', -1. ) 396 397 IF(jflag == 1 .AND. lwp) WRITE(numout,*) 'Need more iterations in wad_lmt_bt!!!' 398 399 !IF( ln_rnf ) CALL sbc_rnf_div( hdivn ) ! runoffs (update hdivn field) 400 !IF( nn_cla == 1 ) CALL cla_div ( kt ) ! Cross Land Advection (update hdivn field) 401 ! 402 ! 403 CALL wrk_dealloc( jpi, jpj, zflxp, zflxn, zflxu1, zflxv1 ) 404 CALL wrk_dealloc( jpi, jpj, zwdlmtu, zwdlmtv) 405 ! 406 END IF 407 408 IF( nn_timing == 1 ) CALL timing_stop('wad_lmt') 353 ENDIF 354 IF( jk1 > nn_wdit ) zcoef = 0._wp 355 IF( zflxu1(ji, jj) > 0._wp ) zwdlmtu(ji ,jj) = zcoef 356 IF( zflxu1(ji-1,jj) < 0._wp ) zwdlmtu(ji-1,jj) = zcoef 357 IF( zflxv1(ji, jj) > 0._wp ) zwdlmtv(ji ,jj) = zcoef 358 IF( zflxv1(ji,jj-1) < 0._wp ) zwdlmtv(ji,jj-1) = zcoef 359 ENDIF 360 END DO ! ji loop 361 END DO ! jj loop 362 ! 363 CALL lbc_lnk( zwdlmtu, 'U', 1. ) 364 CALL lbc_lnk( zwdlmtv, 'V', 1. ) 365 ! 366 IF(lk_mpp) CALL mpp_max(jflag) !max over the global domain 367 ! 368 IF( jflag == 0 ) EXIT 369 ! 370 END DO ! jk1 loop 371 ! 372 zflxu(:,:) = zflxu(:,:) * zwdlmtu(:, :) 373 zflxv(:,:) = zflxv(:,:) * zwdlmtv(:, :) 374 ! 375 CALL lbc_lnk( zflxu, 'U', -1. ) 376 CALL lbc_lnk( zflxv, 'V', -1. ) 377 ! 378 IF(jflag == 1 .AND. lwp) WRITE(numout,*) 'Need more iterations in wad_lmt_bt!!!' 379 380 !IF( ln_rnf ) CALL sbc_rnf_div( hdivn ) ! runoffs (update hdivn field) 381 !IF( nn_cla == 1 ) CALL cla_div ( kt ) ! Cross Land Advection (update hdivn field) 382 ! 383 IF( ln_timing ) CALL timing_stop('wad_lmt') 384 ! 409 385 END SUBROUTINE wad_lmt_bt 410 386 -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/IOM/in_out_manager.F90
r8367 r8568 96 96 !!---------------------------------------------------------------------- 97 97 LOGICAL :: ln_ctl !: run control for debugging 98 LOGICAL :: ln_timing !: run control for timing 99 !!gm to be removed at the end of the 2017 merge party 98 100 INTEGER :: nn_timing !: run control for timing 99 INTEGER :: nn_diacfl !: flag whether to create CFL diagnostics 101 !!gm end 102 LOGICAL :: ln_diacfl !: flag whether to create CFL diagnostics 100 103 INTEGER :: nn_print !: level of print (0 no print) 101 104 INTEGER :: nn_ictls !: Start i indice for the SUM control -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/LBC/lib_mpp.F90
r8367 r8568 2350 2350 zain(2,:) = ki + 10000.*kj + 100000000.*kk 2351 2351 ! 2352 CALL MPI_ALLREDUCE( zain, zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror)2352 CALL MPI_ALLREDUCE( zain, zaout, 1, MPI_2DOUBLE_PRECISION, MPI_MAXLOC, MPI_COMM_OPA, ierror ) 2353 2353 ! 2354 2354 pmax = zaout(1,1) -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/LDF/ldfdyn.F90
r7753 r8568 24 24 USE lib_mpp ! distribued memory computing library 25 25 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 26 USE wrk_nemo ! Memory Allocation27 26 28 27 IMPLICIT NONE … … 33 32 34 33 ! !!* Namelist namdyn_ldf : lateral mixing on momentum * 34 LOGICAL , PUBLIC :: ln_dynldf_NONE !: No operator (i.e. no explicit diffusion) 35 35 LOGICAL , PUBLIC :: ln_dynldf_lap !: laplacian operator 36 36 LOGICAL , PUBLIC :: ln_dynldf_blp !: bilaplacian operator … … 96 96 REAL(wp) :: zah0 ! local scalar 97 97 ! 98 NAMELIST/namdyn_ldf/ ln_dynldf_ lap, ln_dynldf_blp, &99 & ln_dynldf_lev, ln_dynldf_hor, ln_dynldf_iso , &100 & nn_ahm_ijk_t , rn_ahm_0, rn_ahm_b, rn_bhm_0 , &101 & rn_csmc , rn_minfac, rn_maxfac 98 NAMELIST/namdyn_ldf/ ln_dynldf_NONE, ln_dynldf_lap, ln_dynldf_blp, & ! type of operator 99 & ln_dynldf_lev, ln_dynldf_hor, ln_dynldf_iso , & ! acting direction of the operator 100 & nn_ahm_ijk_t , rn_ahm_0, rn_ahm_b, rn_bhm_0 , & ! lateral eddy coefficient 101 & rn_csmc , rn_minfac, rn_maxfac ! Smagorinsky settings 102 102 !!---------------------------------------------------------------------- 103 103 ! … … 118 118 ! 119 119 WRITE(numout,*) ' type :' 120 WRITE(numout,*) ' no explicit diffusion ln_dynldf_NONE= ', ln_dynldf_NONE 120 121 WRITE(numout,*) ' laplacian operator ln_dynldf_lap = ', ln_dynldf_lap 121 122 WRITE(numout,*) ' bilaplacian operator ln_dynldf_blp = ', ln_dynldf_blp … … 131 132 WRITE(numout,*) ' background viscosity (iso case) rn_ahm_b = ', rn_ahm_b, ' m2/s' 132 133 WRITE(numout,*) ' lateral bilaplacian eddy viscosity rn_bhm_0 = ', rn_bhm_0, ' m4/s' 133 WRITE(numout,*) ' smagorinsky settings (nn_ahm_ijk_t = 32) :'134 WRITE(numout,*) ' Smagorinsky settings (nn_ahm_ijk_t = 32) :' 134 135 WRITE(numout,*) ' Smagorinsky coefficient rn_csmc = ', rn_csmc 135 136 WRITE(numout,*) ' factor multiplier for theorectical lower limit for ' … … 140 141 141 142 ! ! Parameter control 142 IF( .NOT.ln_dynldf_lap .AND. .NOT.ln_dynldf_blp) THEN143 IF( ln_dynldf_NONE ) THEN 143 144 IF(lwp) WRITE(numout,*) ' No viscous operator selected. ahmt and ahmf are not allocated' 144 145 l_ldfdyn_time = .FALSE. … … 284 285 !!---------------------------------------------------------------------- 285 286 ! 286 IF( nn_timing == 1 )CALL timing_start('ldf_dyn')287 IF( ln_timing ) CALL timing_start('ldf_dyn') 287 288 ! 288 289 SELECT CASE( nn_ahm_ijk_t ) !== Eddy vicosity coefficients ==! … … 411 412 CALL iom_put( "ahmf_3d", ahmf(:,:,:) ) ! 3D v-eddy diffusivity coeff. 412 413 ! 413 IF( nn_timing == 1 )CALL timing_stop('ldf_dyn')414 IF( ln_timing ) CALL timing_stop('ldf_dyn') 414 415 ! 415 416 END SUBROUTINE ldf_dyn -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/LDF/ldfslp.F90
r7753 r8568 32 32 USE lib_mpp ! distribued memory computing library 33 33 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 34 USE wrk_nemo ! work arrays35 34 USE timing ! Timing 36 35 … … 118 117 REAL(wp) :: zck, zfk, zbw ! - - 119 118 REAL(wp) :: zdepu, zdepv ! - - 120 REAL(wp), POINTER, DIMENSION(:,: ) :: zslpml_hmlpu, zslpml_hmlpv 121 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwz, zww 122 REAL(wp), POINTER, DIMENSION(:,:,:) :: zdzr 123 REAL(wp), POINTER, DIMENSION(:,:,:) :: zgru, zgrv 124 !!---------------------------------------------------------------------- 125 ! 126 IF( nn_timing == 1 ) CALL timing_start('ldf_slp') 127 ! 128 CALL wrk_alloc( jpi,jpj,jpk, zwz, zww, zdzr, zgru, zgrv ) 129 CALL wrk_alloc( jpi,jpj, zslpml_hmlpu, zslpml_hmlpv ) 130 119 REAL(wp), DIMENSION(jpi,jpj) :: zslpml_hmlpu, zslpml_hmlpv 120 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zgru, zwz, zdzr 121 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zgrv, zww 122 !!---------------------------------------------------------------------- 123 ! 124 IF( ln_timing ) CALL timing_start('ldf_slp') 125 ! 131 126 zeps = 1.e-20_wp !== Local constant initialization ==! 132 127 z1_16 = 1.0_wp / 16._wp … … 157 152 DO jj = 1, jpjm1 158 153 DO ji = 1, jpim1 159 IF ( miku(ji,jj) > 1 )zgru(ji,jj,miku(ji,jj)) = grui(ji,jj)160 IF ( mikv(ji,jj) > 1 )zgrv(ji,jj,mikv(ji,jj)) = grvi(ji,jj)154 IF( miku(ji,jj) > 1 ) zgru(ji,jj,miku(ji,jj)) = grui(ji,jj) 155 IF( mikv(ji,jj) > 1 ) zgrv(ji,jj,mikv(ji,jj)) = grvi(ji,jj) 161 156 END DO 162 157 END DO … … 375 370 ENDIF 376 371 ! 377 CALL wrk_dealloc( jpi,jpj,jpk, zwz, zww, zdzr, zgru, zgrv ) 378 CALL wrk_dealloc( jpi,jpj, zslpml_hmlpu, zslpml_hmlpv ) 379 ! 380 IF( nn_timing == 1 ) CALL timing_stop('ldf_slp') 372 IF( ln_timing ) CALL timing_stop('ldf_slp') 381 373 ! 382 374 END SUBROUTINE ldf_slp … … 409 401 REAL(wp) :: zdzrho_raw 410 402 REAL(wp) :: zbeta0, ze3_e1, ze3_e2 411 REAL(wp), POINTER, DIMENSION(:,:) :: z1_mlbw 412 REAL(wp), POINTER, DIMENSION(:,:,:) :: zalbet 413 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: zdxrho , zdyrho, zdzrho ! Horizontal and vertical density gradients 414 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: zti_mlb, ztj_mlb ! for Griffies operator only 415 !!---------------------------------------------------------------------- 416 ! 417 IF( nn_timing == 1 ) CALL timing_start('ldf_slp_triad') 418 ! 419 CALL wrk_alloc( jpi,jpj, z1_mlbw ) 420 CALL wrk_alloc( jpi,jpj,jpk, zalbet ) 421 CALL wrk_alloc( jpi,jpj,jpk,2, zdxrho , zdyrho, zdzrho, klstart = 0 ) 422 CALL wrk_alloc( jpi,jpj, 2,2, zti_mlb, ztj_mlb, kkstart = 0, klstart = 0 ) 403 REAL(wp), DIMENSION(jpi,jpj) :: z1_mlbw 404 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zalbet 405 REAL(wp), DIMENSION(jpi,jpj,jpk,0:1) :: zdxrho , zdyrho, zdzrho ! Horizontal and vertical density gradients 406 REAL(wp), DIMENSION(jpi,jpj,0:1,0:1) :: zti_mlb, ztj_mlb ! for Griffies operator only 407 !!---------------------------------------------------------------------- 408 ! 409 IF( ln_timing ) CALL timing_start('ldf_slp_triad') 410 ! 423 411 ! 424 412 !--------------------------------! … … 624 612 CALL lbc_lnk( wslp2, 'W', 1. ) ! lateral boundary confition on wslp2 only ==>>> gm : necessary ? to be checked 625 613 ! 626 CALL wrk_dealloc( jpi,jpj, z1_mlbw ) 627 CALL wrk_dealloc( jpi,jpj,jpk, zalbet ) 628 CALL wrk_dealloc( jpi,jpj,jpk,2, zdxrho , zdyrho, zdzrho, klstart = 0 ) 629 CALL wrk_dealloc( jpi,jpj, 2,2, zti_mlb, ztj_mlb, kkstart = 0, klstart = 0 ) 630 ! 631 IF( nn_timing == 1 ) CALL timing_stop('ldf_slp_triad') 614 IF( ln_timing ) CALL timing_stop('ldf_slp_triad') 632 615 ! 633 616 END SUBROUTINE ldf_slp_triad … … 663 646 !!---------------------------------------------------------------------- 664 647 ! 665 IF( nn_timing == 1 )CALL timing_start('ldf_slp_mxl')648 IF( ln_timing ) CALL timing_start('ldf_slp_mxl') 666 649 ! 667 650 zeps = 1.e-20_wp !== Local constant initialization ==! … … 746 729 CALL lbc_lnk( wslpiml, 'W', -1. ) ; CALL lbc_lnk( wslpjml, 'W', -1. ) ! lateral boundary conditions 747 730 ! 748 IF( nn_timing == 1 )CALL timing_stop('ldf_slp_mxl')731 IF( ln_timing ) CALL timing_stop('ldf_slp_mxl') 749 732 ! 750 733 END SUBROUTINE ldf_slp_mxl … … 763 746 !!---------------------------------------------------------------------- 764 747 ! 765 IF( nn_timing == 1 )CALL timing_start('ldf_slp_init')748 IF( ln_timing ) CALL timing_start('ldf_slp_init') 766 749 ! 767 750 IF(lwp) THEN … … 821 804 ENDIF 822 805 ! 823 IF( nn_timing == 1 )CALL timing_stop('ldf_slp_init')806 IF( ln_timing ) CALL timing_stop('ldf_slp_init') 824 807 ! 825 808 END SUBROUTINE ldf_slp_init -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/LDF/ldftra.F90
r7753 r8568 30 30 USE lib_mpp ! distribued memory computing library 31 31 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 32 USE wrk_nemo ! work arrays33 32 USE timing ! timing 34 33 … … 45 44 ! !!* Namelist namtra_ldf : lateral mixing on tracers * 46 45 ! != Operator type =! 46 LOGICAL , PUBLIC :: ln_traldf_NONE !: no operator: No explicit diffusion 47 47 LOGICAL , PUBLIC :: ln_traldf_lap !: laplacian operator 48 48 LOGICAL , PUBLIC :: ln_traldf_blp !: bilaplacian operator … … 119 119 INTEGER :: ierr, inum, ios ! local integer 120 120 REAL(wp) :: zah0 ! local scalar 121 ! 122 NAMELIST/namtra_ldf/ ln_traldf_ lap, ln_traldf_blp ,& ! type of operator123 & ln_traldf_lev , ln_traldf_hor , ln_traldf_triad, & ! acting direction of the operator124 & ln_traldf_iso , ln_traldf_msc , rn_slpmax , & ! option for iso-neutral operator125 & ln_triad_iso , ln_botmix_triad, rn_sw_triad , & ! option for triad operator126 & rn_aht_0 , rn_bht_0 , nn_aht_ijk_t ! lateral eddy coefficient121 !! 122 NAMELIST/namtra_ldf/ ln_traldf_NONE, ln_traldf_lap , ln_traldf_blp , & ! type of operator 123 & ln_traldf_lev , ln_traldf_hor , ln_traldf_triad, & ! acting direction of the operator 124 & ln_traldf_iso , ln_traldf_msc , rn_slpmax , & ! option for iso-neutral operator 125 & ln_triad_iso , ln_botmix_triad, rn_sw_triad , & ! option for triad operator 126 & rn_aht_0 , rn_bht_0 , nn_aht_ijk_t ! lateral eddy coefficient 127 127 !!---------------------------------------------------------------------- 128 128 ! … … 144 144 WRITE(numout,*) '~~~~~~~~~~~~ ' 145 145 WRITE(numout,*) ' Namelist namtra_ldf : lateral mixing parameters (type, direction, coefficients)' 146 !147 146 WRITE(numout,*) ' type :' 147 WRITE(numout,*) ' no explicit diffusion ln_traldf_NONE = ', ln_traldf_NONE 148 148 WRITE(numout,*) ' laplacian operator ln_traldf_lap = ', ln_traldf_lap 149 149 WRITE(numout,*) ' bilaplacian operator ln_traldf_blp = ', ln_traldf_blp 150 !151 150 WRITE(numout,*) ' direction of action :' 152 151 WRITE(numout,*) ' iso-level ln_traldf_lev = ', ln_traldf_lev … … 159 158 WRITE(numout,*) ' switching triad or not rn_sw_triad = ', rn_sw_triad 160 159 WRITE(numout,*) ' lateral mixing on bottom ln_botmix_triad = ', ln_botmix_triad 161 !162 160 WRITE(numout,*) ' coefficients :' 163 161 WRITE(numout,*) ' lateral eddy diffusivity (lap case) rn_aht_0 = ', rn_aht_0 … … 168 166 ! ! Parameter control 169 167 ! 170 IF( .NOT.ln_traldf_lap .AND. .NOT.ln_traldf_blp) THEN168 IF( ln_traldf_NONE ) THEN 171 169 IF(lwp) WRITE(numout,*) ' No diffusive operator selected. ahtu and ahtv are not allocated' 172 170 l_ldftra_time = .FALSE. … … 490 488 ! 491 489 INTEGER :: ji, jj, jk ! dummy loop indices 492 REAL(wp) :: zfw, ze3w, zn2, z1_f20, zaht, zaht_min, zzaei ! local scalars 493 REAL(wp), DIMENSION(:,:), POINTER :: zn, zah, zhw, zross, zaeiw ! 2D workspace 494 !!---------------------------------------------------------------------- 495 ! 496 IF( nn_timing == 1 ) CALL timing_start('ldf_eiv') 497 ! 498 CALL wrk_alloc( jpi,jpj, zn, zah, zhw, zross, zaeiw ) 499 ! 490 REAL(wp) :: zfw, ze3w, zn2, z1_f20, zaht, zaht_min, zzaei ! local scalars 491 REAL(wp), DIMENSION(jpi,jpj) :: zn, zah, zhw, zross, zaeiw ! 2D workspace 492 !!---------------------------------------------------------------------- 493 ! 494 IF( ln_timing ) CALL timing_start('ldf_eiv') 495 ! 500 496 zn (:,:) = 0._wp ! Local initialization 501 497 zhw (:,:) = 5._wp … … 575 571 END DO 576 572 ! 577 CALL wrk_dealloc( jpi,jpj, zn, zah, zhw, zross, zaeiw ) 578 ! 579 IF( nn_timing == 1 ) CALL timing_stop('ldf_eiv') 573 IF( ln_timing ) CALL timing_stop('ldf_eiv') 580 574 ! 581 575 END SUBROUTINE ldf_eiv … … 610 604 REAL(wp) :: zuwk, zuwk1, zuwi, zuwi1 ! local scalars 611 605 REAL(wp) :: zvwk, zvwk1, zvwj, zvwj1 ! - - 612 REAL(wp), POINTER, DIMENSION(:,:,:) :: zpsi_uw, zpsi_vw 613 !!---------------------------------------------------------------------- 614 ! 615 IF( nn_timing == 1 ) CALL timing_start( 'ldf_eiv_trp') 616 ! 617 CALL wrk_alloc( jpi,jpj,jpk, zpsi_uw, zpsi_vw ) 618 606 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zpsi_uw, zpsi_vw 607 !!---------------------------------------------------------------------- 608 ! 609 IF( ln_timing ) CALL timing_start( 'ldf_eiv_trp') 610 ! 619 611 IF( kt == kit000 ) THEN 620 612 IF(lwp) WRITE(numout,*) … … 658 650 IF( ln_ldfeiv_dia .AND. cdtype == 'TRA' ) CALL ldf_eiv_dia( zpsi_uw, zpsi_vw ) 659 651 ! 660 CALL wrk_dealloc( jpi,jpj,jpk, zpsi_uw, zpsi_vw ) 661 ! 662 IF( nn_timing == 1 ) CALL timing_stop( 'ldf_eiv_trp') 652 IF( ln_timing ) CALL timing_stop( 'ldf_eiv_trp') 663 653 ! 664 654 END SUBROUTINE ldf_eiv_trp … … 679 669 INTEGER :: ji, jj, jk ! dummy loop indices 680 670 REAL(wp) :: zztmp ! local scalar 681 REAL(wp), DIMENSION(:,:) , POINTER :: zw2d ! 2D workspace 682 REAL(wp), DIMENSION(:,:,:), POINTER :: zw3d ! 3D workspace 683 !!---------------------------------------------------------------------- 684 ! 685 IF( nn_timing == 1 ) CALL timing_start( 'ldf_eiv_dia') 671 REAL(wp), DIMENSION(jpi,jpj) :: zw2d ! 2D workspace 672 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zw3d ! 3D workspace 673 !!---------------------------------------------------------------------- 674 ! 675 !!gm I don't like this routine.... Crazy way of doing things, not optimal at all... 676 !!gm to be redesigned.... 677 IF( ln_timing ) CALL timing_start( 'ldf_eiv_dia') 686 678 ! 687 679 ! !== eiv stream function: output ==! … … 693 685 ! 694 686 ! !== eiv velocities: calculate and output ==! 695 CALL wrk_alloc( jpi,jpj,jpk, zw3d )696 687 ! 697 688 zw3d(:,:,jpk) = 0._wp ! bottom value always 0 … … 718 709 CALL iom_put( "woce_eiv", zw3d ) 719 710 ! 720 !721 !722 CALL wrk_alloc( jpi,jpj, zw2d )723 711 ! 724 712 zztmp = 0.5_wp * rau0 * rcp … … 792 780 IF( ln_diaptr ) CALL dia_ptr_hst( jp_sal, 'eiv', 0.5 * zw3d ) 793 781 ! 794 CALL wrk_dealloc( jpi,jpj, zw2d ) 795 CALL wrk_dealloc( jpi,jpj,jpk, zw3d ) 796 ! 797 IF( nn_timing == 1 ) CALL timing_stop( 'ldf_eiv_dia') 782 ! 783 IF( ln_timing ) CALL timing_stop( 'ldf_eiv_dia') 798 784 ! 799 785 END SUBROUTINE ldf_eiv_dia -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/TRA/eosbn2.F90
r8367 r8568 46 46 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 47 47 USE prtctl ! Print control 48 USE wrk_nemo ! Memory Allocation49 48 USE lbclnk ! ocean lateral boundary conditions 50 49 USE timing ! Timing … … 231 230 !!---------------------------------------------------------------------- 232 231 ! 233 IF( nn_timing == 1) CALL timing_start('eos-insitu')232 IF( ln_timing ) CALL timing_start('eos-insitu') 234 233 ! 235 234 SELECT CASE( neos ) … … 298 297 IF(ln_ctl) CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-insitu : ', ovlap=1, kdim=jpk ) 299 298 ! 300 IF( nn_timing == 1) CALL timing_stop('eos-insitu')299 IF( ln_timing ) CALL timing_stop('eos-insitu') 301 300 ! 302 301 END SUBROUTINE eos_insitu … … 329 328 !!---------------------------------------------------------------------- 330 329 ! 331 IF( nn_timing == 1) CALL timing_start('eos-pot')330 IF( ln_timing ) CALL timing_start('eos-pot') 332 331 ! 333 332 SELECT CASE ( neos ) … … 465 464 IF(ln_ctl) CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-pot: ', tab3d_2=prhop, clinfo2=' pot : ', ovlap=1, kdim=jpk ) 466 465 ! 467 IF( nn_timing == 1) CALL timing_stop('eos-pot')466 IF( ln_timing ) CALL timing_stop('eos-pot') 468 467 ! 469 468 END SUBROUTINE eos_insitu_pot … … 491 490 !!---------------------------------------------------------------------- 492 491 ! 493 IF( nn_timing == 1) CALL timing_start('eos2d')492 IF( ln_timing ) CALL timing_start('eos2d') 494 493 ! 495 494 prd(:,:) = 0._wp … … 560 559 IF(ln_ctl) CALL prt_ctl( tab2d_1=prd, clinfo1=' eos2d: ' ) 561 560 ! 562 IF( nn_timing == 1) CALL timing_stop('eos2d')561 IF( ln_timing ) CALL timing_stop('eos2d') 563 562 ! 564 563 END SUBROUTINE eos_insitu_2d … … 583 582 !!---------------------------------------------------------------------- 584 583 ! 585 IF( nn_timing == 1) CALL timing_start('rab_3d')584 IF( ln_timing ) CALL timing_start('rab_3d') 586 585 ! 587 586 SELECT CASE ( neos ) … … 674 673 & tab3d_2=pab(:,:,:,jp_sal), clinfo2=' rab_3d_s : ', ovlap=1, kdim=jpk ) 675 674 ! 676 IF( nn_timing == 1) CALL timing_stop('rab_3d')675 IF( ln_timing ) CALL timing_stop('rab_3d') 677 676 ! 678 677 END SUBROUTINE rab_3d … … 696 695 !!---------------------------------------------------------------------- 697 696 ! 698 IF( nn_timing == 1 )CALL timing_start('rab_2d')697 IF( ln_timing ) CALL timing_start('rab_2d') 699 698 ! 700 699 pab(:,:,:) = 0._wp … … 791 790 & tab2d_2=pab(:,:,jp_sal), clinfo2=' rab_2d_s : ' ) 792 791 ! 793 IF( nn_timing == 1) CALL timing_stop('rab_2d')792 IF( ln_timing ) CALL timing_stop('rab_2d') 794 793 ! 795 794 END SUBROUTINE rab_2d … … 812 811 !!---------------------------------------------------------------------- 813 812 ! 814 IF( nn_timing == 1 )CALL timing_start('rab_2d')813 IF( ln_timing ) CALL timing_start('rab_2d') 815 814 ! 816 815 pab(:) = 0._wp … … 888 887 END SELECT 889 888 ! 890 IF( nn_timing == 1) CALL timing_stop('rab_2d')889 IF( ln_timing ) CALL timing_stop('rab_2d') 891 890 ! 892 891 END SUBROUTINE rab_0d … … 915 914 !!---------------------------------------------------------------------- 916 915 ! 917 IF( nn_timing == 1 )CALL timing_start('bn2')916 IF( ln_timing ) CALL timing_start('bn2') 918 917 ! 919 918 DO jk = 2, jpkm1 ! interior points only (2=< jk =< jpkm1 ) … … 935 934 IF(ln_ctl) CALL prt_ctl( tab3d_1=pn2, clinfo1=' bn2 : ', ovlap=1, kdim=jpk ) 936 935 ! 937 IF( nn_timing == 1) CALL timing_stop('bn2')936 IF( ln_timing ) CALL timing_stop('bn2') 938 937 ! 939 938 END SUBROUTINE bn2 … … 963 962 !!---------------------------------------------------------------------- 964 963 ! 965 IF ( nn_timing == 1) CALL timing_start('eos_pt_from_ct')964 IF( ln_timing ) CALL timing_start('eos_pt_from_ct') 966 965 ! 967 966 zdeltaS = 5._wp … … 994 993 END DO 995 994 ! 996 IF( nn_timing == 1) CALL timing_stop('eos_pt_from_ct')995 IF( ln_timing ) CALL timing_stop('eos_pt_from_ct') 997 996 ! 998 997 END FUNCTION eos_pt_from_ct … … 1128 1127 !!---------------------------------------------------------------------- 1129 1128 ! 1130 IF( nn_timing == 1) CALL timing_start('eos_pen')1129 IF( ln_timing ) CALL timing_start('eos_pen') 1131 1130 ! 1132 1131 SELECT CASE ( neos ) … … 1222 1221 END SELECT 1223 1222 ! 1224 IF( nn_timing == 1) CALL timing_stop('eos_pen')1223 IF( ln_timing ) CALL timing_stop('eos_pen') 1225 1224 ! 1226 1225 END SUBROUTINE eos_pen -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/TRA/traadv.F90
r7753 r8568 14 14 !!---------------------------------------------------------------------- 15 15 !! tra_adv : compute ocean tracer advection trend 16 !! tra_adv_ ctl: control the different options of advection scheme16 !! tra_adv_init : control the different options of advection scheme 17 17 !!---------------------------------------------------------------------- 18 18 USE oce ! ocean dynamics and active tracers 19 19 USE dom_oce ! ocean space and time domain 20 20 USE domvvl ! variable vertical scale factors 21 USE sbcwave ! wave module 22 USE sbc_oce ! surface boundary condition: ocean 21 23 USE traadv_cen ! centered scheme (tra_adv_cen routine) 22 24 USE traadv_fct ! FCT scheme (tra_adv_fct routine) … … 27 29 USE ldftra ! lateral diffusion: eddy diffusivity & EIV coeff. 28 30 USE ldfslp ! Lateral diffusion: slopes of neutral surfaces 29 USE trd_oce ! trends: ocean variables 30 USE trdtra ! trends manager: tracers 31 USE trd_oce ! trends: ocean variables 32 USE trdtra ! trends manager: tracers 33 USE diaptr ! Poleward heat transport 31 34 ! 32 35 USE in_out_manager ! I/O manager … … 34 37 USE prtctl ! Print control 35 38 USE lib_mpp ! MPP library 36 USE wrk_nemo ! Memory Allocation37 39 USE timing ! Timing 38 USE sbcwave ! wave module39 USE sbc_oce ! surface boundary condition: ocean40 USE diaptr ! Poleward heat transport41 40 42 41 IMPLICIT NONE 43 42 PRIVATE 44 43 45 PUBLIC tra_adv ! routine called by step module46 PUBLIC tra_adv_init ! routine called by opa module44 PUBLIC tra_adv ! called by step.F90 45 PUBLIC tra_adv_init ! called by nemogcm.F90 47 46 48 47 ! !!* Namelist namtra_adv * 48 LOGICAL :: ln_traadv_NONE ! no advection on T and S 49 49 LOGICAL :: ln_traadv_cen ! centered scheme flag 50 50 INTEGER :: nn_cen_h, nn_cen_v ! =2/4 : horizontal and vertical choices of the order of CEN scheme 51 51 LOGICAL :: ln_traadv_fct ! FCT scheme flag 52 52 INTEGER :: nn_fct_h, nn_fct_v ! =2/4 : horizontal and vertical choices of the order of FCT scheme 53 INTEGER :: nn_fct_zts ! >=1 : 2nd order FCT with vertical sub-timestepping54 53 LOGICAL :: ln_traadv_mus ! MUSCL scheme flag 55 54 LOGICAL :: ln_mus_ups ! use upstream scheme in vivcinity of river mouths … … 58 57 LOGICAL :: ln_traadv_qck ! QUICKEST scheme flag 59 58 60 INTEGER :: nadv ! choice of the type of advection scheme 61 ! 62 ! ! associated indices: 59 INTEGER :: nadv ! choice of the type of advection scheme 60 ! ! associated indices: 63 61 INTEGER, PARAMETER :: np_NO_adv = 0 ! no T-S advection 64 62 INTEGER, PARAMETER :: np_CEN = 1 ! 2nd/4th order centered scheme 65 63 INTEGER, PARAMETER :: np_FCT = 2 ! 2nd/4th order Flux Corrected Transport scheme 66 INTEGER, PARAMETER :: np_FCT_zts = 3 ! 2nd order FCT scheme with vertical sub-timestepping 67 INTEGER, PARAMETER :: np_MUS = 4 ! MUSCL scheme 68 INTEGER, PARAMETER :: np_UBS = 5 ! 3rd order Upstream Biased Scheme 69 INTEGER, PARAMETER :: np_QCK = 6 ! QUICK scheme 64 INTEGER, PARAMETER :: np_MUS = 3 ! MUSCL scheme 65 INTEGER, PARAMETER :: np_UBS = 4 ! 3rd order Upstream Biased Scheme 66 INTEGER, PARAMETER :: np_QCK = 5 ! QUICK scheme 70 67 71 68 !! * Substitutions 72 69 # include "vectopt_loop_substitute.h90" 73 70 !!---------------------------------------------------------------------- 74 !! NEMO/OPA 3.7 , NEMO Consortium (2014)71 !! NEMO/OPA 4.0 , NEMO Consortium (2017) 75 72 !! $Id$ 76 73 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 86 83 !! ** Method : - Update (ua,va) with the advection term following nadv 87 84 !!---------------------------------------------------------------------- 88 INTEGER, INTENT( in) :: kt ! ocean time-step index85 INTEGER, INTENT(in) :: kt ! ocean time-step index 89 86 ! 90 87 INTEGER :: jk ! dummy loop index 91 REAL(wp), POINTER, DIMENSION(:,:,:) :: zun, zvn, zwn 92 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdt, ztrds ! 3D workspace 93 !!---------------------------------------------------------------------- 94 ! 95 IF( nn_timing == 1 ) CALL timing_start('tra_adv') 96 ! 97 CALL wrk_alloc( jpi,jpj,jpk, zun, zvn, zwn ) 88 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zun, zvn, zwn ! 3D workspace 89 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdt, ztrds 90 !!---------------------------------------------------------------------- 91 ! 92 IF( ln_timing ) CALL timing_start('tra_adv') 98 93 ! 99 94 ! ! set time step 100 zun(:,:,:) = 0.0 101 zvn(:,:,:) = 0.0 102 zwn(:,:,:) = 0.0 103 ! 104 IF( neuler == 0 .AND. kt == nit000 ) THEN ! at nit000 105 r2dt = rdt ! = rdt (restarting with Euler time stepping) 106 ELSEIF( kt <= nit000 + 1) THEN ! at nit000 or nit000+1 107 r2dt = 2._wp * rdt ! = 2 rdt (leapfrog) 95 IF( neuler == 0 .AND. kt == nit000 ) THEN ; r2dt = rdt ! at nit000 (Euler) 96 ELSEIF( kt <= nit000 + 1 ) THEN ; r2dt = 2._wp* rdt ! at nit000 or nit000+1 (Leapfrog) 108 97 ENDIF 109 98 ! 110 99 ! !== effective transport ==! 100 zun(:,:,jpk) = 0._wp 101 zvn(:,:,jpk) = 0._wp 102 zwn(:,:,jpk) = 0._wp 111 103 IF( ln_wave .AND. ln_sdw ) THEN 112 104 DO jk = 1, jpkm1 ! eulerian transport + Stokes Drift … … 146 138 ! 147 139 IF( l_trdtra ) THEN !* Save ta and sa trends 148 CALL wrk_alloc( jpi, jpj, jpk, ztrdt, ztrds)140 ALLOCATE( ztrdt(jpi,jpj,jpk), ztrds(jpi,jpj,jpk) ) 149 141 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 150 142 ztrds(:,:,:) = tsa(:,:,:,jp_sal) … … 153 145 SELECT CASE ( nadv ) !== compute advection trend and add it to general trend ==! 154 146 ! 155 CASE ( np_CEN ) 147 CASE ( np_CEN ) ! Centered scheme : 2nd / 4th order 156 148 CALL tra_adv_cen ( kt, nit000, 'TRA', zun, zvn, zwn , tsn, tsa, jpts, nn_cen_h, nn_cen_v ) 157 CASE ( np_FCT ) 149 CASE ( np_FCT ) ! FCT scheme : 2nd / 4th order 158 150 CALL tra_adv_fct ( kt, nit000, 'TRA', r2dt, zun, zvn, zwn, tsb, tsn, tsa, jpts, nn_fct_h, nn_fct_v ) 159 CASE ( np_FCT_zts ) ! 2nd order FCT with vertical time-splitting 160 CALL tra_adv_fct_zts( kt, nit000, 'TRA', r2dt, zun, zvn, zwn, tsb, tsn, tsa, jpts , nn_fct_zts ) 161 CASE ( np_MUS ) ! MUSCL 151 CASE ( np_MUS ) ! MUSCL 162 152 CALL tra_adv_mus ( kt, nit000, 'TRA', r2dt, zun, zvn, zwn, tsb, tsa, jpts , ln_mus_ups ) 163 CASE ( np_UBS ) 153 CASE ( np_UBS ) ! UBS 164 154 CALL tra_adv_ubs ( kt, nit000, 'TRA', r2dt, zun, zvn, zwn, tsb, tsn, tsa, jpts , nn_ubs_v ) 165 CASE ( np_QCK ) 155 CASE ( np_QCK ) ! QUICKEST 166 156 CALL tra_adv_qck ( kt, nit000, 'TRA', r2dt, zun, zvn, zwn, tsb, tsn, tsa, jpts ) 167 157 ! … … 175 165 CALL trd_tra( kt, 'TRA', jp_tem, jptra_totad, ztrdt ) 176 166 CALL trd_tra( kt, 'TRA', jp_sal, jptra_totad, ztrds ) 177 CALL wrk_dealloc( jpi, jpj, jpk,ztrdt, ztrds )167 DEALLOCATE( ztrdt, ztrds ) 178 168 ENDIF 179 169 ! ! print mean trends (used for debugging) … … 181 171 & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 182 172 ! 183 IF( nn_timing == 1 ) CALL timing_stop( 'tra_adv' ) 184 ! 185 CALL wrk_dealloc( jpi,jpj,jpk, zun, zvn, zwn ) 186 ! 173 IF( ln_timing ) CALL timing_stop( 'tra_adv' ) 174 ! 187 175 END SUBROUTINE tra_adv 188 176 … … 197 185 INTEGER :: ioptio, ios ! Local integers 198 186 ! 199 NAMELIST/namtra_adv/ ln_traadv_cen, nn_cen_h, nn_cen_v, & ! CEN 200 & ln_traadv_fct, nn_fct_h, nn_fct_v, nn_fct_zts, & ! FCT 201 & ln_traadv_mus, ln_mus_ups, & ! MUSCL 202 & ln_traadv_ubs, nn_ubs_v, & ! UBS 203 & ln_traadv_qck ! QCK 187 NAMELIST/namtra_adv/ ln_traadv_NONE, & ! No advection 188 & ln_traadv_cen , nn_cen_h, nn_cen_v, & ! CEN 189 & ln_traadv_fct , nn_fct_h, nn_fct_v, & ! FCT 190 & ln_traadv_mus , ln_mus_ups, & ! MUSCL 191 & ln_traadv_ubs , nn_ubs_v, & ! UBS 192 & ln_traadv_qck ! QCK 204 193 !!---------------------------------------------------------------------- 205 194 ! … … 217 206 WRITE(numout,*) 218 207 WRITE(numout,*) 'tra_adv_init : choice/control of the tracer advection scheme' 219 WRITE(numout,*) '~~~~~~~~~~~ '208 WRITE(numout,*) '~~~~~~~~~~~~' 220 209 WRITE(numout,*) ' Namelist namtra_adv : chose a advection scheme for tracers' 210 WRITE(numout,*) ' No advection on T & S ln_traadv_NONE= ', ln_traadv_NONE 221 211 WRITE(numout,*) ' centered scheme ln_traadv_cen = ', ln_traadv_cen 222 212 WRITE(numout,*) ' horizontal 2nd/4th order nn_cen_h = ', nn_fct_h … … 225 215 WRITE(numout,*) ' horizontal 2nd/4th order nn_fct_h = ', nn_fct_h 226 216 WRITE(numout,*) ' vertical 2nd/4th order nn_fct_v = ', nn_fct_v 227 WRITE(numout,*) ' 2nd order + vertical sub-timestepping nn_fct_zts = ', nn_fct_zts228 217 WRITE(numout,*) ' MUSCL scheme ln_traadv_mus = ', ln_traadv_mus 229 218 WRITE(numout,*) ' + upstream scheme near river mouths ln_mus_ups = ', ln_mus_ups … … 233 222 ENDIF 234 223 ! 235 ioptio = 0 !== Parameter control ==! 236 IF( ln_traadv_cen ) ioptio = ioptio + 1 237 IF( ln_traadv_fct ) ioptio = ioptio + 1 238 IF( ln_traadv_mus ) ioptio = ioptio + 1 239 IF( ln_traadv_ubs ) ioptio = ioptio + 1 240 IF( ln_traadv_qck ) ioptio = ioptio + 1 241 ! 242 IF( ioptio == 0 ) THEN 243 nadv = np_NO_adv 244 CALL ctl_warn( 'tra_adv_init: You are running without tracer advection.' ) 245 ENDIF 246 IF( ioptio /= 1 ) CALL ctl_stop( 'tra_adv_init: Choose ONE advection scheme in namelist namtra_adv' ) 224 ! !== Parameter control & set nadv ==! 225 ioptio = 0 226 IF( ln_traadv_NONE ) THEN ; ioptio = ioptio + 1 ; nadv = np_NO_adv ; ENDIF 227 IF( ln_traadv_cen ) THEN ; ioptio = ioptio + 1 ; nadv = np_CEN ; ENDIF 228 IF( ln_traadv_fct ) THEN ; ioptio = ioptio + 1 ; nadv = np_FCT ; ENDIF 229 IF( ln_traadv_mus ) THEN ; ioptio = ioptio + 1 ; nadv = np_MUS ; ENDIF 230 IF( ln_traadv_ubs ) THEN ; ioptio = ioptio + 1 ; nadv = np_UBS ; ENDIF 231 IF( ln_traadv_qck ) THEN ; ioptio = ioptio + 1 ; nadv = np_QCK ; ENDIF 232 ! 233 IF( ioptio /= 1 ) CALL ctl_stop( 'tra_adv_init: Choose ONE advection option in namelist namtra_adv' ) 247 234 ! 248 235 IF( ln_traadv_cen .AND. ( nn_cen_h /= 2 .AND. nn_cen_h /= 4 ) & ! Centered … … 254 241 CALL ctl_stop( 'tra_adv_init: FCT scheme, choose 2nd or 4th order' ) 255 242 ENDIF 256 IF( ln_traadv_fct .AND. nn_fct_zts > 0 ) THEN257 IF( nn_fct_h == 4 ) THEN258 nn_fct_h = 2259 CALL ctl_stop( 'tra_adv_init: force 2nd order FCT scheme, 4th order does not exist with sub-timestepping' )260 ENDIF261 IF( .NOT.ln_linssh ) THEN262 CALL ctl_stop( 'tra_adv_init: vertical sub-timestepping not allow in non-linear free surface' )263 ENDIF264 IF( nn_fct_zts == 1 ) CALL ctl_warn( 'tra_adv_init: FCT with ONE sub-timestep = FCT without sub-timestep' )265 ENDIF266 243 IF( ln_traadv_ubs .AND. ( nn_ubs_v /= 2 .AND. nn_ubs_v /= 4 ) ) THEN ! UBS 267 244 CALL ctl_stop( 'tra_adv_init: UBS scheme, choose 2nd or 4th order' ) … … 275 252 ENDIF 276 253 ! 277 ! !== used advection scheme ==! 278 ! ! set nadv 279 IF( ln_traadv_cen ) nadv = np_CEN 280 IF( ln_traadv_fct ) nadv = np_FCT 281 IF( ln_traadv_fct .AND. nn_fct_zts > 0 ) nadv = np_FCT_zts 282 IF( ln_traadv_mus ) nadv = np_MUS 283 IF( ln_traadv_ubs ) nadv = np_UBS 284 IF( ln_traadv_qck ) nadv = np_QCK 285 ! 286 IF(lwp) THEN ! Print the choice 254 ! !== Print the choice ==! 255 IF(lwp) THEN 287 256 WRITE(numout,*) 288 257 SELECT CASE ( nadv ) … … 292 261 CASE( np_FCT ) ; WRITE(numout,*) ' ===>> FCT scheme is used. Horizontal order: ', nn_fct_h, & 293 262 & ' Vertical order: ', nn_fct_v 294 CASE( np_FCT_zts ) ; WRITE(numout,*) ' ===>> use 2nd order FCT with ', nn_fct_zts,'vertical sub-timestepping'295 263 CASE( np_MUS ) ; WRITE(numout,*) ' ===>> MUSCL scheme is used' 296 264 CASE( np_UBS ) ; WRITE(numout,*) ' ===>> UBS scheme is used' -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/TRA/traadv_cen.F90
r7646 r8568 11 11 !! NB: on the vertical it is actually a 4th order COMPACT scheme which is used 12 12 !!---------------------------------------------------------------------- 13 USE oce , ONLY: tsn ! now ocean temperature and salinity14 13 USE dom_oce ! ocean space and time domain 15 14 USE eosbn2 ! equation of state … … 24 23 USE trc_oce ! share passive tracers/Ocean variables 25 24 USE lib_mpp ! MPP library 26 USE wrk_nemo ! Memory Allocation27 25 USE timing ! Timing 28 26 … … 30 28 PRIVATE 31 29 32 PUBLIC tra_adv_cen ! routine called by step.F9030 PUBLIC tra_adv_cen ! called by traadv.F90 33 31 34 32 REAL(wp) :: r1_6 = 1._wp / 6._wp ! =1/6 35 33 36 LOGICAL :: l_trd ! flag to compute trends37 LOGICAL :: l_ptr ! flag to compute poleward transport38 LOGICAL :: l_hst ! flag to compute heat/salt transport34 LOGICAL :: l_trd ! flag to compute trends 35 LOGICAL :: l_ptr ! flag to compute poleward transport 36 LOGICAL :: l_hst ! flag to compute heat/salt transport 39 37 40 38 !! * Substitutions 41 39 # include "vectopt_loop_substitute.h90" 42 40 !!---------------------------------------------------------------------- 43 !! NEMO/OPA 3.7 , NEMO Consortium (2014)44 !! $Id $41 !! NEMO/OPA 4.0, NEMO Consortium (2017) 42 !! $Id:$ 45 43 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 46 44 !!---------------------------------------------------------------------- … … 48 46 49 47 SUBROUTINE tra_adv_cen( kt, kit000, cdtype, pun, pvn, pwn, & 50 & 48 & ptn, pta, kjpt, kn_cen_h, kn_cen_v ) 51 49 !!---------------------------------------------------------------------- 52 50 !! *** ROUTINE tra_adv_cen *** … … 80 78 REAL(wp) :: zC2t_u, zC4t_u ! local scalars 81 79 REAL(wp) :: zC2t_v, zC4t_v ! - - 82 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwx, zwy, zwz, ztu, ztv, ztw80 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwx, zwy, zwz, ztu, ztv, ztw 83 81 !!---------------------------------------------------------------------- 84 82 ! 85 IF( nn_timing == 1 ) CALL timing_start('tra_adv_cen') 86 ! 87 CALL wrk_alloc( jpi,jpj,jpk, zwx, zwy, zwz, ztu, ztv, ztw ) 83 IF( ln_timing ) CALL timing_start('tra_adv_cen') 88 84 ! 89 85 IF( kt == kit000 ) THEN … … 92 88 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~ ' 93 89 ENDIF 94 ! 90 ! ! set local switches 95 91 l_trd = .FALSE. 96 92 l_hst = .FALSE. … … 130 126 END DO 131 127 END DO 132 CALL lbc_lnk( ztu, 'U', -1. ) ; CALL lbc_lnk( ztv, 'V', -1. ) ! Lateral boundary cond. (unchanged sgn)128 CALL lbc_lnk( ztu, 'U', -1. ) ; CALL lbc_lnk( ztv, 'V', -1. ) ! Lateral boundary cond. 133 129 ! 134 130 DO jk = 1, jpkm1 ! Horizontal advective fluxes … … 203 199 END IF 204 200 ! ! "Poleward" heat and salt transports 205 IF( l_ptr ) CALL dia_ptr_hst( jn, 'adv', zwy(:,:,:) )201 IF( l_ptr ) CALL dia_ptr_hst( jn, 'adv', zwy(:,:,:) ) 206 202 ! ! heat and salt transport 207 IF( l_hst ) CALL dia_ar5_hst( jn, 'adv', zwx(:,:,:), zwy(:,:,:) )203 IF( l_hst ) CALL dia_ar5_hst( jn, 'adv', zwx(:,:,:), zwy(:,:,:) ) 208 204 ! 209 205 END DO 210 206 ! 211 CALL wrk_dealloc( jpi,jpj,jpk, zwx, zwy, zwz, ztu, ztv, ztw ) 212 ! 213 IF( nn_timing == 1 ) CALL timing_stop('tra_adv_cen') 207 IF( ln_timing ) CALL timing_stop('tra_adv_cen') 214 208 ! 215 209 END SUBROUTINE tra_adv_cen -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/TRA/traadv_fct.F90
r7753 r8568 9 9 !!---------------------------------------------------------------------- 10 10 !! tra_adv_fct : update the tracer trend with a 3D advective trends using a 2nd or 4th order FCT scheme 11 !! tra_adv_fct_zts: update the tracer trend with a 3D advective trends using a 2nd order FCT scheme12 11 !! with sub-time-stepping in the vertical direction 13 12 !! nonosc : compute monotonic tracer fluxes by a non-oscillatory algorithm … … 21 20 USE diaptr ! poleward transport diagnostics 22 21 USE diaar5 ! AR5 diagnostics 23 USE phycst , ONLY: rau0_rcp22 USE phycst , ONLY : rau0_rcp 24 23 ! 25 24 USE in_out_manager ! I/O manager 26 USE iom 25 USE iom ! 27 26 USE lib_mpp ! MPP library 28 27 USE lbclnk ! ocean lateral boundary condition (or mpp link) 29 28 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 30 USE wrk_nemo ! Memory Allocation31 29 USE timing ! Timing 32 30 … … 34 32 PRIVATE 35 33 36 PUBLIC tra_adv_fct ! routine called by traadv.F90 37 PUBLIC tra_adv_fct_zts ! routine called by traadv.F90 38 PUBLIC interp_4th_cpt ! routine called by traadv_cen.F90 34 PUBLIC tra_adv_fct ! called by traadv.F90 35 PUBLIC interp_4th_cpt ! called by traadv_cen.F90 39 36 40 37 LOGICAL :: l_trd ! flag to compute trends … … 50 47 # include "vectopt_loop_substitute.h90" 51 48 !!---------------------------------------------------------------------- 52 !! NEMO/OPA 3.7 , NEMO Consortium (2014)49 !! NEMO/OPA 4.0 , NEMO Consortium (2017) 53 50 !! $Id$ 54 51 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 70 67 !! 71 68 !! ** Action : - update pta with the now advective tracer trends 72 !! - send trends to trdtra module for further diagnost cs (l_trdtra=T)69 !! - send trends to trdtra module for further diagnostics (l_trdtra=T) 73 70 !! - htr_adv, str_adv : poleward advective heat and salt transport (ln_diaptr=T) 74 71 !!---------------------------------------------------------------------- … … 88 85 REAL(wp) :: zfp_ui, zfp_vj, zfp_wk, zC2t_u, zC4t_u ! - - 89 86 REAL(wp) :: zfm_ui, zfm_vj, zfm_wk, zC2t_v, zC4t_v ! - - 90 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwi, zwx, zwy, zwz, ztu, ztv, zltu, zltv, ztw 91 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdx, ztrdy, ztrdz, zptry 92 REAL(wp), POINTER, DIMENSION(:,:) :: z2d 93 !!---------------------------------------------------------------------- 94 ! 95 IF( nn_timing == 1 ) CALL timing_start('tra_adv_fct') 96 ! 97 CALL wrk_alloc( jpi,jpj,jpk, zwi, zwx, zwy, zwz, ztu, ztv, zltu, zltv, ztw ) 87 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwi, zwx, zwy, zwz, ztu, ztv, zltu, zltv, ztw 88 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdx, ztrdy, ztrdz, zptry 89 !!---------------------------------------------------------------------- 90 ! 91 IF( ln_timing ) CALL timing_start('tra_adv_fct') 98 92 ! 99 93 IF( kt == kit000 ) THEN … … 103 97 ENDIF 104 98 ! 105 l_trd = .FALSE. 99 l_trd = .FALSE. ! set local switches 106 100 l_hst = .FALSE. 107 101 l_ptr = .FALSE. 108 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) )l_trd = .TRUE.109 IF( cdtype == 'TRA' .AND. ln_diaptr )l_ptr = .TRUE.110 IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR.&111 & 102 IF( ( cdtype =='TRA' .AND. l_trdtra ) .OR. ( cdtype =='TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 103 IF( cdtype =='TRA' .AND. ln_diaptr ) l_ptr = .TRUE. 104 IF( cdtype =='TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 105 & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. 112 106 ! 113 107 IF( l_trd .OR. l_hst ) THEN 114 CALL wrk_alloc( jpi, jpj, jpk, ztrdx, ztrdy, ztrdz)108 ALLOCATE( ztrdx(jpi,jpj,jpk), ztrdy(jpi,jpj,jpk), ztrdz(jpi,jpj,jpk) ) 115 109 ztrdx(:,:,:) = 0._wp ; ztrdy(:,:,:) = 0._wp ; ztrdz(:,:,:) = 0._wp 116 110 ENDIF 117 111 ! 118 112 IF( l_ptr ) THEN 119 CALL wrk_alloc( jpi, jpj, jpk, zptry)113 ALLOCATE( zptry(jpi,jpj,jpk) ) 120 114 zptry(:,:,:) = 0._wp 121 115 ENDIF … … 184 178 END IF 185 179 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 186 IF( l_ptr ) zptry(:,:,:) = zwy(:,:,:)180 IF( l_ptr ) zptry(:,:,:) = zwy(:,:,:) 187 181 ! 188 182 ! !== anti-diffusive flux : high order minus low order ==! … … 308 302 END DO 309 303 ! 310 IF( l_trd .OR. l_hst ) THEN ! trend diagnostics (contribution of upstream fluxes) 311 ztrdx(:,:,:) = ztrdx(:,:,:) + zwx(:,:,:) ! <<< Add to previously computed 312 ztrdy(:,:,:) = ztrdy(:,:,:) + zwy(:,:,:) ! <<< Add to previously computed 313 ztrdz(:,:,:) = ztrdz(:,:,:) + zwz(:,:,:) ! <<< Add to previously computed 304 IF( l_trd .OR. l_hst ) THEN ! trend diagnostics // heat/salt transport 305 ztrdx(:,:,:) = ztrdx(:,:,:) + zwx(:,:,:) ! <<< add anti-diffusive fluxes 306 ztrdy(:,:,:) = ztrdy(:,:,:) + zwy(:,:,:) ! to upstream fluxes 307 ztrdz(:,:,:) = ztrdz(:,:,:) + zwz(:,:,:) ! 308 ! 309 IF( l_trd ) THEN ! trend diagnostics 310 CALL trd_tra( kt, cdtype, jn, jptra_xad, ztrdx, pun, ptn(:,:,:,jn) ) 311 CALL trd_tra( kt, cdtype, jn, jptra_yad, ztrdy, pvn, ptn(:,:,:,jn) ) 312 CALL trd_tra( kt, cdtype, jn, jptra_zad, ztrdz, pwn, ptn(:,:,:,jn) ) 313 ENDIF 314 ! ! heat/salt transport 315 IF( l_hst ) CALL dia_ar5_hst( jn, 'adv', ztrdx(:,:,:), ztrdy(:,:,:) ) 316 ! 317 DEALLOCATE( ztrdx, ztrdy, ztrdz ) 314 318 ENDIF 315 ! 316 IF( l_trd ) THEN 317 CALL trd_tra( kt, cdtype, jn, jptra_xad, ztrdx, pun, ptn(:,:,:,jn) ) 318 CALL trd_tra( kt, cdtype, jn, jptra_yad, ztrdy, pvn, ptn(:,:,:,jn) ) 319 CALL trd_tra( kt, cdtype, jn, jptra_zad, ztrdz, pwn, ptn(:,:,:,jn) ) 320 ! 321 END IF 322 ! ! heat/salt transport 323 IF( l_hst ) CALL dia_ar5_hst( jn, 'adv', ztrdx(:,:,:), ztrdy(:,:,:) ) 324 325 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 326 IF( l_ptr ) THEN 327 zptry(:,:,:) = zptry(:,:,:) + zwy(:,:,:) ! <<< Add to previously computed 319 IF( l_ptr ) THEN ! "Poleward" transports 320 zptry(:,:,:) = zptry(:,:,:) + zwy(:,:,:) ! <<< add anti-diffusive fluxes 328 321 CALL dia_ptr_hst( jn, 'adv', zptry(:,:,:) ) 322 DEALLOCATE( zptry ) 329 323 ENDIF 330 324 ! 331 325 END DO ! end of tracer loop 332 326 ! 333 CALL wrk_dealloc( jpi,jpj,jpk, zwi, zwx, zwy, zwz, ztu, ztv, zltu, zltv, ztw ) 334 IF( l_trd .OR. l_hst ) CALL wrk_dealloc( jpi, jpj, jpk, ztrdx, ztrdy, ztrdz ) 335 IF( l_ptr ) CALL wrk_dealloc( jpi, jpj, jpk, zptry ) 336 ! 337 IF( nn_timing == 1 ) CALL timing_stop('tra_adv_fct') 327 IF( ln_timing ) CALL timing_stop('tra_adv_fct') 338 328 ! 339 329 END SUBROUTINE tra_adv_fct 340 341 342 SUBROUTINE tra_adv_fct_zts( kt, kit000, cdtype, p2dt, pun, pvn, pwn, &343 & ptb, ptn, pta, kjpt, kn_fct_zts )344 !!----------------------------------------------------------------------345 !! *** ROUTINE tra_adv_fct_zts ***346 !!347 !! ** Purpose : Compute the now trend due to total advection of348 !! tracers and add it to the general trend of tracer equations349 !!350 !! ** Method : TVD ZTS scheme, i.e. 2nd order centered scheme with351 !! corrected flux (monotonic correction). This version use sub-352 !! timestepping for the vertical advection which increases stability353 !! when vertical metrics are small.354 !! note: - this advection scheme needs a leap-frog time scheme355 !!356 !! ** Action : - update (pta) with the now advective tracer trends357 !! - save the trends358 !!----------------------------------------------------------------------359 INTEGER , INTENT(in ) :: kt ! ocean time-step index360 INTEGER , INTENT(in ) :: kit000 ! first time step index361 CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator)362 INTEGER , INTENT(in ) :: kjpt ! number of tracers363 INTEGER , INTENT(in ) :: kn_fct_zts ! number of number of vertical sub-timesteps364 REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step365 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pun, pvn, pwn ! 3 ocean velocity components366 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb, ptn ! before and now tracer fields367 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend368 !369 REAL(wp), DIMENSION( jpk ) :: zts ! length of sub-timestep for vertical advection370 REAL(wp) :: zr_p2dt ! reciprocal of tracer timestep371 INTEGER :: ji, jj, jk, jl, jn ! dummy loop indices372 INTEGER :: jtb, jtn, jta ! sub timestep pointers for leap-frog/euler forward steps373 INTEGER :: jtaken ! toggle for collecting appropriate fluxes from sub timesteps374 REAL(wp) :: z_rzts ! Fractional length of Euler forward sub-timestep for vertical advection375 REAL(wp) :: ztra ! local scalar376 REAL(wp) :: zfp_ui, zfp_vj, zfp_wk ! - -377 REAL(wp) :: zfm_ui, zfm_vj, zfm_wk ! - -378 REAL(wp), POINTER, DIMENSION(:,: ) :: zwx_sav , zwy_sav379 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwi, zwx, zwy, zwz, zhdiv, zwzts, zwz_sav380 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdx, ztrdy, ztrdz381 REAL(wp), POINTER, DIMENSION(:,:,:) :: zptry382 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztrs383 !!----------------------------------------------------------------------384 !385 IF( nn_timing == 1 ) CALL timing_start('tra_adv_fct_zts')386 !387 CALL wrk_alloc( jpi,jpj, zwx_sav, zwy_sav )388 CALL wrk_alloc( jpi,jpj,jpk, zwx, zwy, zwz, zwi, zhdiv, zwzts, zwz_sav )389 CALL wrk_alloc( jpi,jpj,jpk,kjpt+1, ztrs )390 !391 IF( kt == kit000 ) THEN392 IF(lwp) WRITE(numout,*)393 IF(lwp) WRITE(numout,*) 'tra_adv_fct_zts : 2nd order FCT scheme with ', kn_fct_zts, ' vertical sub-timestep on ', cdtype394 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~'395 ENDIF396 !397 l_trd = .FALSE.398 l_hst = .FALSE.399 l_ptr = .FALSE.400 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE.401 IF( cdtype == 'TRA' .AND. ln_diaptr ) l_ptr = .TRUE.402 IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. &403 & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE.404 !405 IF( l_trd .OR. l_hst ) THEN406 CALL wrk_alloc( jpi,jpj,jpk, ztrdx, ztrdy, ztrdz )407 ztrdx(:,:,:) = 0._wp ; ztrdy(:,:,:) = 0._wp ; ztrdz(:,:,:) = 0._wp408 ENDIF409 !410 IF( l_ptr ) THEN411 CALL wrk_alloc( jpi, jpj,jpk, zptry )412 zptry(:,:,:) = 0._wp413 ENDIF414 zwi(:,:,:) = 0._wp415 z_rzts = 1._wp / REAL( kn_fct_zts, wp )416 zr_p2dt = 1._wp / p2dt417 !418 ! surface & Bottom value : flux set to zero for all tracers419 zwz(:,:, 1 ) = 0._wp420 zwx(:,:,jpk) = 0._wp ; zwz(:,:,jpk) = 0._wp421 zwy(:,:,jpk) = 0._wp ; zwi(:,:,jpk) = 0._wp422 !423 ! ! ===========424 DO jn = 1, kjpt ! tracer loop425 ! ! ===========426 !427 ! Upstream advection with initial mass fluxes & intermediate update428 DO jk = 1, jpkm1 ! upstream tracer flux in the i and j direction429 DO jj = 1, jpjm1430 DO ji = 1, fs_jpim1 ! vector opt.431 ! upstream scheme432 zfp_ui = pun(ji,jj,jk) + ABS( pun(ji,jj,jk) )433 zfm_ui = pun(ji,jj,jk) - ABS( pun(ji,jj,jk) )434 zfp_vj = pvn(ji,jj,jk) + ABS( pvn(ji,jj,jk) )435 zfm_vj = pvn(ji,jj,jk) - ABS( pvn(ji,jj,jk) )436 zwx(ji,jj,jk) = 0.5_wp * ( zfp_ui * ptb(ji,jj,jk,jn) + zfm_ui * ptb(ji+1,jj ,jk,jn) )437 zwy(ji,jj,jk) = 0.5_wp * ( zfp_vj * ptb(ji,jj,jk,jn) + zfm_vj * ptb(ji ,jj+1,jk,jn) )438 END DO439 END DO440 END DO441 ! ! upstream tracer flux in the k direction442 DO jk = 2, jpkm1 ! Interior value443 DO jj = 1, jpj444 DO ji = 1, jpi445 zfp_wk = pwn(ji,jj,jk) + ABS( pwn(ji,jj,jk) )446 zfm_wk = pwn(ji,jj,jk) - ABS( pwn(ji,jj,jk) )447 zwz(ji,jj,jk) = 0.5_wp * ( zfp_wk * ptb(ji,jj,jk,jn) + zfm_wk * ptb(ji,jj,jk-1,jn) ) * wmask(ji,jj,jk)448 END DO449 END DO450 END DO451 IF( ln_linssh ) THEN ! top value : linear free surface case only (as zwz is multiplied by wmask)452 IF( ln_isfcav ) THEN ! ice-shelf cavities: top value453 DO jj = 1, jpj454 DO ji = 1, jpi455 zwz(ji,jj, mikt(ji,jj) ) = pwn(ji,jj,mikt(ji,jj)) * ptb(ji,jj,mikt(ji,jj),jn)456 END DO457 END DO458 ELSE ! no cavities, surface value459 zwz(:,:,1) = pwn(:,:,1) * ptb(:,:,1,jn)460 ENDIF461 ENDIF462 !463 DO jk = 1, jpkm1 ! total advective trend464 DO jj = 2, jpjm1465 DO ji = fs_2, fs_jpim1 ! vector opt.466 ! ! total intermediate advective trends467 ztra = - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) &468 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) &469 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) * r1_e1e2t(ji,jj)470 ! ! update and guess with monotonic sheme471 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra / e3t_n(ji,jj,jk) * tmask(ji,jj,jk)472 zwi(ji,jj,jk) = ( e3t_b(ji,jj,jk) * ptb(ji,jj,jk,jn) + p2dt * ztra ) / e3t_a(ji,jj,jk) * tmask(ji,jj,jk)473 END DO474 END DO475 END DO476 !477 CALL lbc_lnk( zwi, 'T', 1. ) ! Lateral boundary conditions on zwi (unchanged sign)478 !479 IF( l_trd .OR. l_hst ) THEN ! trend diagnostics (contribution of upstream fluxes)480 ztrdx(:,:,:) = zwx(:,:,:) ; ztrdy(:,:,:) = zwy(:,:,:) ; ztrdz(:,:,:) = zwz(:,:,:)481 END IF482 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes)483 IF( l_ptr ) zptry(:,:,:) = zwy(:,:,:)484 485 ! 3. anti-diffusive flux : high order minus low order486 ! ---------------------------------------------------487 488 DO jk = 1, jpkm1 !* horizontal anti-diffusive fluxes489 !490 DO jj = 1, jpjm1491 DO ji = 1, fs_jpim1 ! vector opt.492 zwx_sav(ji,jj) = zwx(ji,jj,jk)493 zwy_sav(ji,jj) = zwy(ji,jj,jk)494 !495 zwx(ji,jj,jk) = 0.5_wp * pun(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji+1,jj,jk,jn) )496 zwy(ji,jj,jk) = 0.5_wp * pvn(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji,jj+1,jk,jn) )497 END DO498 END DO499 !500 DO jj = 2, jpjm1 ! partial horizontal divergence501 DO ji = fs_2, fs_jpim1502 zhdiv(ji,jj,jk) = ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk) &503 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk) )504 END DO505 END DO506 !507 DO jj = 1, jpjm1508 DO ji = 1, fs_jpim1 ! vector opt.509 zwx(ji,jj,jk) = zwx(ji,jj,jk) - zwx_sav(ji,jj)510 zwy(ji,jj,jk) = zwy(ji,jj,jk) - zwy_sav(ji,jj)511 END DO512 END DO513 END DO514 !515 ! !* vertical anti-diffusive flux516 zwz_sav(:,:,:) = zwz(:,:,:)517 ztrs (:,:,:,1) = ptb(:,:,:,jn)518 ztrs (:,:,1,2) = ptb(:,:,1,jn)519 ztrs (:,:,1,3) = ptb(:,:,1,jn)520 zwzts (:,:,:) = 0._wp521 !522 DO jl = 1, kn_fct_zts ! Start of sub timestepping loop523 !524 IF( jl == 1 ) THEN ! Euler forward to kick things off525 jtb = 1 ; jtn = 1 ; jta = 2526 zts(:) = p2dt * z_rzts527 jtaken = MOD( kn_fct_zts + 1 , 2) ! Toggle to collect every second flux528 ! ! starting at jl =1 if kn_fct_zts is odd;529 ! ! starting at jl =2 otherwise530 ELSEIF( jl == 2 ) THEN ! First leapfrog step531 jtb = 1 ; jtn = 2 ; jta = 3532 zts(:) = 2._wp * p2dt * z_rzts533 ELSE ! Shuffle pointers for subsequent leapfrog steps534 jtb = MOD(jtb,3) + 1535 jtn = MOD(jtn,3) + 1536 jta = MOD(jta,3) + 1537 ENDIF538 DO jk = 2, jpkm1 ! interior value539 DO jj = 2, jpjm1540 DO ji = fs_2, fs_jpim1541 zwz(ji,jj,jk) = 0.5_wp * pwn(ji,jj,jk) * ( ztrs(ji,jj,jk,jtn) + ztrs(ji,jj,jk-1,jtn) ) * wmask(ji,jj,jk)542 IF( jtaken == 0 ) zwzts(ji,jj,jk) = zwzts(ji,jj,jk) + zwz(ji,jj,jk) * zts(jk) ! Accumulate time-weighted vertcal flux543 END DO544 END DO545 END DO546 IF( ln_linssh ) THEN ! top value (only in linear free surface case)547 IF( ln_isfcav ) THEN ! ice-shelf cavities548 DO jj = 1, jpj549 DO ji = 1, jpi550 zwz(ji,jj, mikt(ji,jj) ) = pwn(ji,jj,mikt(ji,jj)) * ptb(ji,jj,mikt(ji,jj),jn) ! linear free surface551 END DO552 END DO553 ELSE ! no ocean cavities554 zwz(:,:,1) = pwn(:,:,1) * ptb(:,:,1,jn)555 ENDIF556 ENDIF557 !558 jtaken = MOD( jtaken + 1 , 2 )559 !560 DO jk = 2, jpkm1 ! total advective trends561 DO jj = 2, jpjm1562 DO ji = fs_2, fs_jpim1563 ztrs(ji,jj,jk,jta) = ztrs(ji,jj,jk,jtb) &564 & - zts(jk) * ( zhdiv(ji,jj,jk) + zwz(ji,jj,jk) - zwz(ji,jj,jk+1) ) &565 & * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk)566 END DO567 END DO568 END DO569 !570 END DO571 572 DO jk = 2, jpkm1 ! Anti-diffusive vertical flux using average flux from the sub-timestepping573 DO jj = 2, jpjm1574 DO ji = fs_2, fs_jpim1575 zwz(ji,jj,jk) = ( zwzts(ji,jj,jk) * zr_p2dt - zwz_sav(ji,jj,jk) ) * wmask(ji,jj,jk)576 END DO577 END DO578 END DO579 CALL lbc_lnk( zwx, 'U', -1. ) ; CALL lbc_lnk( zwy, 'V', -1. ) ! Lateral bondary conditions580 CALL lbc_lnk( zwz, 'W', 1. )581 582 ! 4. monotonicity algorithm583 ! -------------------------584 CALL nonosc( ptb(:,:,:,jn), zwx, zwy, zwz, zwi, p2dt )585 586 587 ! 5. final trend with corrected fluxes588 ! ------------------------------------589 DO jk = 1, jpkm1590 DO jj = 2, jpjm1591 DO ji = fs_2, fs_jpim1 ! vector opt.592 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ( zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) &593 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) &594 & * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk)595 END DO596 END DO597 END DO598 599 !600 IF( l_trd .OR. l_hst ) THEN ! trend diagnostics (contribution of upstream fluxes)601 ztrdx(:,:,:) = ztrdx(:,:,:) + zwx(:,:,:) ! <<< Add to previously computed602 ztrdy(:,:,:) = ztrdy(:,:,:) + zwy(:,:,:) ! <<< Add to previously computed603 ztrdz(:,:,:) = ztrdz(:,:,:) + zwz(:,:,:) ! <<< Add to previously computed604 ENDIF605 !606 IF( l_trd ) THEN607 CALL trd_tra( kt, cdtype, jn, jptra_xad, ztrdx, pun, ptn(:,:,:,jn) )608 CALL trd_tra( kt, cdtype, jn, jptra_yad, ztrdy, pvn, ptn(:,:,:,jn) )609 CALL trd_tra( kt, cdtype, jn, jptra_zad, ztrdz, pwn, ptn(:,:,:,jn) )610 !611 END IF612 ! ! heat/salt transport613 IF( l_hst ) CALL dia_ar5_hst( jn, 'adv', ztrdx(:,:,:), ztrdy(:,:,:) )614 615 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes)616 IF( l_ptr ) THEN617 zptry(:,:,:) = zptry(:,:,:) + zwy(:,:,:) ! <<< Add to previously computed618 CALL dia_ptr_hst( jn, 'adv', zptry(:,:,:) )619 ENDIF620 !621 END DO622 !623 CALL wrk_alloc( jpi,jpj, zwx_sav, zwy_sav )624 CALL wrk_alloc( jpi,jpj, jpk, zwx, zwy, zwz, zwi, zhdiv, zwzts, zwz_sav )625 CALL wrk_alloc( jpi,jpj,jpk,kjpt+1, ztrs )626 IF( l_trd .OR. l_hst ) CALL wrk_dealloc( jpi, jpj, jpk, ztrdx, ztrdy, ztrdz )627 IF( l_ptr ) CALL wrk_dealloc( jpi, jpj, jpk, zptry )628 !629 IF( nn_timing == 1 ) CALL timing_stop('tra_adv_fct_zts')630 !631 END SUBROUTINE tra_adv_fct_zts632 330 633 331 … … 653 351 REAL(wp) :: zpos, zneg, zbt, za, zb, zc, zbig, zrtrn ! local scalars 654 352 REAL(wp) :: zau, zbu, zcu, zav, zbv, zcv, zup, zdo ! - - 655 REAL(wp), POINTER, DIMENSION(:,:,:) :: zbetup, zbetdo, zbup, zbdo 656 !!---------------------------------------------------------------------- 657 ! 658 IF( nn_timing == 1 ) CALL timing_start('nonosc') 659 ! 660 CALL wrk_alloc( jpi, jpj, jpk, zbetup, zbetdo, zbup, zbdo ) 353 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zbetup, zbetdo, zbup, zbdo 354 !!---------------------------------------------------------------------- 355 ! 356 IF( ln_timing ) CALL timing_start('nonosc') 661 357 ! 662 358 zbig = 1.e+40_wp … … 734 430 CALL lbc_lnk( paa, 'U', -1. ) ; CALL lbc_lnk( pbb, 'V', -1. ) ! lateral boundary condition (changed sign) 735 431 ! 736 CALL wrk_dealloc( jpi, jpj, jpk, zbetup, zbetdo, zbup, zbdo ) 737 ! 738 IF( nn_timing == 1 ) CALL timing_stop('nonosc') 432 IF( ln_timing ) CALL timing_stop('nonosc') 739 433 ! 740 434 END SUBROUTINE nonosc -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/TRA/traadv_mle.F90
r7753 r8568 15 15 USE phycst ! physical constant 16 16 USE zdfmxl ! mixed layer depth 17 ! 17 18 USE lbclnk ! lateral boundary condition / mpp link 18 19 USE in_out_manager ! I/O manager 19 20 USE iom ! IOM library 20 21 USE lib_mpp ! MPP library 21 USE wrk_nemo ! work arrays22 22 USE timing ! Timing 23 23 … … 86 86 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pw ! increased by the MLE induced transport 87 87 ! 88 INTEGER :: ji, jj, jk ! dummy loop indices 89 INTEGER :: ikmax ! temporary integer 90 REAL(wp) :: zcuw, zmuw ! local scalar 91 REAL(wp) :: zcvw, zmvw ! - - 92 REAL(wp) :: zc ! - - 93 ! 94 INTEGER :: ii, ij, ik ! local integers 95 INTEGER, DIMENSION(3) :: ilocu ! 96 INTEGER, DIMENSION(2) :: ilocs ! 97 REAL(wp), POINTER, DIMENSION(:,: ) :: zpsim_u, zpsim_v, zmld, zbm, zhu, zhv, zn2, zLf_NH, zLf_MH 98 REAL(wp), POINTER, DIMENSION(:,:,:) :: zpsi_uw, zpsi_vw 99 INTEGER, POINTER, DIMENSION(:,:) :: inml_mle 100 !!---------------------------------------------------------------------- 101 ! 102 IF( nn_timing == 1 ) CALL timing_start('tra_adv_mle') 103 CALL wrk_alloc( jpi, jpj, zpsim_u, zpsim_v, zmld, zbm, zhu, zhv, zn2, zLf_NH, zLf_MH) 104 CALL wrk_alloc( jpi, jpj, jpk, zpsi_uw, zpsi_vw) 105 CALL wrk_alloc( jpi, jpj, inml_mle) 88 INTEGER :: ji, jj, jk ! dummy loop indices 89 INTEGER :: ii, ij, ik, ikmax ! local integers 90 REAL(wp) :: zcuw, zmuw, zc ! local scalar 91 REAL(wp) :: zcvw, zmvw ! - - 92 INTEGER , DIMENSION(jpi,jpj) :: inml_mle 93 REAL(wp), DIMENSION(jpi,jpj) :: zpsim_u, zpsim_v, zmld, zbm, zhu, zhv, zn2, zLf_NH, zLf_MH 94 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zpsi_uw, zpsi_vw 95 !!---------------------------------------------------------------------- 96 ! 97 IF( ln_timing ) CALL timing_start('tra_adv_mle') 106 98 ! 107 99 ! !== MLD used for MLE ==! … … 256 248 CALL iom_put( "psiv_mle", zpsi_vw ) ! j-mle streamfunction 257 249 ENDIF 258 CALL wrk_dealloc( jpi, jpj, zpsim_u, zpsim_v, zmld, zbm, zhu, zhv, zn2, zLf_NH, zLf_MH) 259 CALL wrk_dealloc( jpi, jpj, jpk, zpsi_uw, zpsi_vw) 260 CALL wrk_dealloc( jpi, jpj, inml_mle) 261 262 IF( nn_timing == 1 ) CALL timing_stop('tra_adv_mle') 250 ! 251 IF( ln_timing ) CALL timing_stop('tra_adv_mle') 263 252 ! 264 253 END SUBROUTINE tra_adv_mle -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/TRA/traadv_mus.F90
r7753 r8568 26 26 27 27 ! 28 USE iom 29 USE wrk_nemo ! Memory Allocation 28 USE iom ! XIOS library 30 29 USE timing ! Timing 31 30 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) … … 85 84 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend 86 85 ! 87 INTEGER :: ji, jj, jk, jn ! dummy loop indices 88 INTEGER :: ierr ! local integer 89 REAL(wp) :: zu, z0u, zzwx, zw ! local scalars 90 REAL(wp) :: zv, z0v, zzwy, z0w ! - - 91 REAL(wp) :: zalpha ! - - 92 REAL(wp), POINTER, DIMENSION(:,:,:) :: zslpx, zslpy ! 3D workspace 93 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwx , zwy ! - - 86 INTEGER :: ji, jj, jk, jn ! dummy loop indices 87 INTEGER :: ierr ! local integer 88 REAL(wp) :: zu, z0u, zzwx, zw , zalpha ! local scalars 89 REAL(wp) :: zv, z0v, zzwy, z0w ! - - 90 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwx, zslpx ! 3D workspace 91 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwy, zslpy ! - - 94 92 !!---------------------------------------------------------------------- 95 93 ! 96 IF( nn_timing == 1 ) CALL timing_start('tra_adv_mus') 97 ! 98 CALL wrk_alloc( jpi,jpj,jpk, zslpx, zslpy, zwx, zwy ) 94 IF( ln_timing ) CALL timing_start('tra_adv_mus') 99 95 ! 100 96 IF( kt == kit000 ) THEN … … 279 275 END DO ! end of tracer loop 280 276 ! 281 CALL wrk_dealloc( jpi,jpj,jpk, zslpx, zslpy, zwx, zwy ) 282 ! 283 IF( nn_timing == 1 ) CALL timing_stop('tra_adv_mus') 277 IF( ln_timing ) CALL timing_stop('tra_adv_mus') 284 278 ! 285 279 END SUBROUTINE tra_adv_mus -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/TRA/traadv_qck.F90
r7646 r8568 25 25 USE lbclnk ! ocean lateral boundary condition (or mpp link) 26 26 USE in_out_manager ! I/O manager 27 USE wrk_nemo ! Memory Allocation28 27 USE timing ! Timing 29 28 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) … … 43 42 # include "vectopt_loop_substitute.h90" 44 43 !!---------------------------------------------------------------------- 45 !! NEMO/OPA 3.3 , NEMO Consortium (2010)44 !! NEMO/OPA 4.0 , NEMO Consortium (2017) 46 45 !! $Id$ 47 46 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 96 95 !!---------------------------------------------------------------------- 97 96 ! 98 IF( nn_timing == 1 )CALL timing_start('tra_adv_qck')97 IF( ln_timing ) CALL timing_start('tra_adv_qck') 99 98 ! 100 99 IF( kt == kit000 ) THEN … … 118 117 CALL tra_adv_cen2_k( kt, cdtype, pwn, ptn, pta, kjpt ) 119 118 ! 120 IF( nn_timing == 1 )CALL timing_stop('tra_adv_qck')119 IF( ln_timing ) CALL timing_stop('tra_adv_qck') 121 120 ! 122 121 END SUBROUTINE tra_adv_qck … … 138 137 INTEGER :: ji, jj, jk, jn ! dummy loop indices 139 138 REAL(wp) :: ztra, zbtr, zdir, zdx, zmsk ! local scalars 140 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwx, zfu, zfc, zfd139 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwx, zfu, zfc, zfd 141 140 !---------------------------------------------------------------------- 142 141 ! 143 CALL wrk_alloc( jpi, jpj, jpk, zwx, zfu, zfc, zfd )144 142 ! ! =========== 145 143 DO jn = 1, kjpt ! tracer loop … … 230 228 END DO 231 229 ! ! trend diagnostics 232 IF( l_trd ) 230 IF( l_trd ) CALL trd_tra( kt, cdtype, jn, jptra_xad, zwx, pun, ptn(:,:,:,jn) ) 233 231 ! 234 232 END DO 235 !236 CALL wrk_dealloc( jpi, jpj, jpk, zwx, zfu, zfc, zfd )237 233 ! 238 234 END SUBROUTINE tra_adv_qck_i … … 252 248 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend 253 249 !! 254 INTEGER :: ji, jj, jk, jn ! dummy loop indices250 INTEGER :: ji, jj, jk, jn ! dummy loop indices 255 251 REAL(wp) :: ztra, zbtr, zdir, zdx, zmsk ! local scalars 256 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwy, zfu, zfc, zfd252 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwy, zfu, zfc, zfd ! 3D workspace 257 253 !---------------------------------------------------------------------- 258 !259 CALL wrk_alloc( jpi, jpj, jpk, zwy, zfu, zfc, zfd )260 254 ! 261 255 ! ! =========== … … 320 314 END DO 321 315 END DO 322 !--- Lateral boundary conditions 323 CALL lbc_lnk( zfu(:,:,:), 'T', 1. ) 316 CALL lbc_lnk( zfu(:,:,:), 'T', 1. ) !--- Lateral boundary conditions 324 317 ! 325 318 ! Tracer flux on the x-direction … … 359 352 END DO 360 353 ! 361 CALL wrk_dealloc( jpi, jpj, jpk, zwy, zfu, zfc, zfd )362 !363 354 END SUBROUTINE tra_adv_qck_j 364 355 … … 377 368 ! 378 369 INTEGER :: ji, jj, jk, jn ! dummy loop indices 379 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwz 380 !!---------------------------------------------------------------------- 381 ! 382 CALL wrk_alloc( jpi,jpj,jpk, zwz ) 370 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwz ! 3D workspace 371 !!---------------------------------------------------------------------- 383 372 ! 384 373 zwz(:,:, 1 ) = 0._wp ! surface & bottom values set to zero for all tracers … … 421 410 END DO 422 411 ! 423 CALL wrk_dealloc( jpi,jpj,jpk, zwz )424 !425 412 END SUBROUTINE tra_adv_cen2_k 426 413 … … 443 430 !---------------------------------------------------------------------- 444 431 ! 445 IF( nn_timing == 1 )CALL timing_start('quickest')432 IF( ln_timing ) CALL timing_start('quickest') 446 433 ! 447 434 DO jk = 1, jpkm1 … … 475 462 END DO 476 463 ! 477 IF( nn_timing == 1 )CALL timing_stop('quickest')464 IF( ln_timing ) CALL timing_stop('quickest') 478 465 ! 479 466 END SUBROUTINE quickest -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/TRA/traadv_ubs.F90
r7646 r8568 22 22 23 23 ! 24 USE iom 25 USE lib_mpp ! I/Olibrary24 USE iom ! XIOS library 25 USE lib_mpp ! massively parallel library 26 26 USE lbclnk ! ocean lateral boundary condition (or mpp link) 27 27 USE in_out_manager ! I/O manager 28 USE wrk_nemo ! Memory Allocation29 28 USE timing ! Timing 30 29 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) … … 101 100 REAL(wp) :: zfp_ui, zfm_ui, zcenut, ztak, zfp_wk, zfm_wk ! - - 102 101 REAL(wp) :: zfp_vj, zfm_vj, zcenvt, zeeu, zeev, z_hdivn ! - - 103 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztu, ztv, zltu, zltv, zti, ztw 104 !!---------------------------------------------------------------------- 105 ! 106 IF( nn_timing == 1 ) CALL timing_start('tra_adv_ubs') 107 ! 108 CALL wrk_alloc( jpi,jpj,jpk, ztu, ztv, zltu, zltv, zti, ztw ) 102 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztu, ztv, zltu, zltv, zti, ztw ! 3D workspace 103 !!---------------------------------------------------------------------- 104 ! 105 IF( ln_timing ) CALL timing_start('tra_adv_ubs') 109 106 ! 110 107 IF( kt == kit000 ) THEN … … 285 282 END DO 286 283 ! 287 CALL wrk_dealloc( jpi,jpj,jpk, ztu, ztv, zltu, zltv, zti, ztw ) 288 ! 289 IF( nn_timing == 1 ) CALL timing_stop('tra_adv_ubs') 284 IF( ln_timing ) CALL timing_stop('tra_adv_ubs') 290 285 ! 291 286 END SUBROUTINE tra_adv_ubs … … 313 308 INTEGER :: ikm1 ! local integer 314 309 REAL(wp) :: zpos, zneg, zbt, za, zb, zc, zbig, zrtrn ! local scalars 315 REAL(wp), POINTER, DIMENSION(:,:,:) :: zbetup, zbetdo 316 !!---------------------------------------------------------------------- 317 ! 318 IF( nn_timing == 1 ) CALL timing_start('nonosc_z') 319 ! 320 CALL wrk_alloc( jpi,jpj,jpk, zbetup, zbetdo ) 310 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zbetup, zbetdo ! 3D workspace 311 !!---------------------------------------------------------------------- 312 ! 313 IF( ln_timing ) CALL timing_start('nonosc_z') 321 314 ! 322 315 zbig = 1.e+40_wp … … 387 380 END DO 388 381 ! 389 CALL wrk_dealloc( jpi,jpj,jpk, zbetup, zbetdo ) 390 ! 391 IF( nn_timing == 1 ) CALL timing_stop('nonosc_z') 382 IF( ln_timing ) CALL timing_stop('nonosc_z') 392 383 ! 393 384 END SUBROUTINE nonosc_z -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/TRA/trabbc.F90
r7753 r8568 27 27 USE lib_mpp ! distributed memory computing library 28 28 USE prtctl ! Print control 29 USE wrk_nemo ! Memory Allocation30 29 USE timing ! Timing 31 30 … … 77 76 ! 78 77 INTEGER :: ji, jj ! dummy loop indices 79 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdt78 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt ! 3D workspace 80 79 !!---------------------------------------------------------------------- 81 80 ! 82 IF( nn_timing == 1 )CALL timing_start('tra_bbc')81 IF( ln_timing ) CALL timing_start('tra_bbc') 83 82 ! 84 83 IF( l_trdtra ) THEN ! Save the input temperature trend 85 CALL wrk_alloc( jpi,jpj,jpk, ztrdt)84 ALLOCATE( ztrdt(jpi,jpj,jpk) ) 86 85 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 87 86 ENDIF … … 98 97 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 99 98 CALL trd_tra( kt, 'TRA', jp_tem, jptra_bbc, ztrdt ) 100 CALL wrk_dealloc( jpi,jpj,jpk,ztrdt )99 DEALLOCATE( ztrdt ) 101 100 ENDIF 102 101 ! 103 102 IF(ln_ctl) CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' bbc - Ta: ', mask1=tmask, clinfo3='tra-ta' ) 104 103 ! 105 IF( nn_timing == 1 )CALL timing_stop('tra_bbc')104 IF( ln_timing ) CALL timing_stop('tra_bbc') 106 105 ! 107 106 END SUBROUTINE tra_bbc … … 130 129 TYPE(FLD_N) :: sn_qgh ! informations about the geotherm. field to be read 131 130 CHARACTER(len=256) :: cn_dir ! Root directory for location of ssr files 132 ! 131 !! 133 132 NAMELIST/nambbc/ln_trabbc, nn_geoflx, rn_geoflx_cst, sn_qgh, cn_dir 134 133 !!---------------------------------------------------------------------- -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/TRA/trabbl.F90
r8367 r8568 35 35 USE lbclnk ! ocean lateral boundary conditions 36 36 USE prtctl ! Print control 37 USE wrk_nemo ! Memory Allocation38 37 USE timing ! Timing 39 38 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) … … 104 103 INTEGER, INTENT( in ) :: kt ! ocean time-step 105 104 ! 106 REAL(wp), POINTER, DIMENSION(:,:,:) ::ztrdt, ztrds107 !!---------------------------------------------------------------------- 108 ! 109 IF( nn_timing == 1 )CALL timing_start( 'tra_bbl')105 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds 106 !!---------------------------------------------------------------------- 107 ! 108 IF( ln_timing ) CALL timing_start( 'tra_bbl') 110 109 ! 111 110 IF( l_trdtra ) THEN !* Save the T-S input trends 112 CALL wrk_alloc( jpi, jpj, jpk, ztrdt, ztrds)111 ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) 113 112 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 114 113 ztrds(:,:,:) = tsa(:,:,:,jp_sal) … … 148 147 CALL trd_tra( kt, 'TRA', jp_tem, jptra_bbl, ztrdt ) 149 148 CALL trd_tra( kt, 'TRA', jp_sal, jptra_bbl, ztrds ) 150 CALL wrk_dealloc( jpi, jpj, jpk,ztrdt, ztrds )151 ENDIF 152 ! 153 IF( nn_timing == 1) CALL timing_stop( 'tra_bbl')149 DEALLOCATE( ztrdt, ztrds ) 150 ENDIF 151 ! 152 IF( ln_timing ) CALL timing_stop( 'tra_bbl') 154 153 ! 155 154 END SUBROUTINE tra_bbl … … 184 183 INTEGER :: ik ! local integers 185 184 REAL(wp) :: zbtr ! local scalars 186 REAL(wp), POINTER, DIMENSION(:,:) :: zptb 187 !!---------------------------------------------------------------------- 188 ! 189 IF( nn_timing == 1 ) CALL timing_start('tra_bbl_dif') 190 ! 191 CALL wrk_alloc( jpi, jpj, zptb ) 185 REAL(wp), DIMENSION(jpi,jpj) :: zptb ! workspace 186 !!---------------------------------------------------------------------- 187 ! 188 IF( ln_timing ) CALL timing_start('tra_bbl_dif') 192 189 ! 193 190 DO jn = 1, kjpt ! tracer loop … … 214 211 END DO ! end tracer 215 212 ! ! =========== 216 CALL wrk_dealloc( jpi, jpj, zptb ) 217 ! 218 IF( nn_timing == 1 ) CALL timing_stop('tra_bbl_dif') 213 ! 214 IF( ln_timing ) CALL timing_stop('tra_bbl_dif') 219 215 ! 220 216 END SUBROUTINE tra_bbl_dif … … 247 243 !!---------------------------------------------------------------------- 248 244 ! 249 IF( nn_timing == 1 )CALL timing_start( 'tra_bbl_adv')245 IF( ln_timing ) CALL timing_start( 'tra_bbl_adv') 250 246 ! ! =========== 251 247 DO jn = 1, kjpt ! tracer loop … … 303 299 ! ! =========== 304 300 ! 305 IF( nn_timing == 1 )CALL timing_stop( 'tra_bbl_adv')301 IF( ln_timing ) CALL timing_stop( 'tra_bbl_adv') 306 302 ! 307 303 END SUBROUTINE tra_bbl_adv … … 348 344 !!---------------------------------------------------------------------- 349 345 ! 350 IF( nn_timing == 1 )CALL timing_start( 'bbl')346 IF( ln_timing ) CALL timing_start( 'bbl') 351 347 ! 352 348 IF( kt == kit000 ) THEN … … 479 475 ENDIF 480 476 ! 481 IF( nn_timing == 1 )CALL timing_stop( 'bbl')477 IF( ln_timing ) CALL timing_stop( 'bbl') 482 478 ! 483 479 END SUBROUTINE bbl … … 493 489 !! called by nemo_init at the first timestep (kit000) 494 490 !!---------------------------------------------------------------------- 495 INTEGER :: ji, jj ! dummy loop indices 496 INTEGER :: ii0, ii1, ij0, ij1 ! local integer 497 INTEGER :: ios ! - - 498 REAL(wp), POINTER, DIMENSION(:,:) :: zmbk 491 INTEGER :: ji, jj ! dummy loop indices 492 INTEGER :: ii0, ii1, ij0, ij1, ios ! local integer 493 REAL(wp), DIMENSION(jpi,jpj) :: zmbk ! workspace 499 494 !! 500 495 NAMELIST/nambbl/ ln_trabbl, nn_bbl_ldf, nn_bbl_adv, rn_ahtbbl, rn_gambbl 501 496 !!---------------------------------------------------------------------- 502 497 ! 503 IF( nn_timing == 1 )CALL timing_start( 'tra_bbl_init')498 IF( ln_timing ) CALL timing_start( 'tra_bbl_init') 504 499 ! 505 500 REWIND( numnam_ref ) ! Namelist nambbl in reference namelist : Bottom boundary layer scheme … … 544 539 END DO 545 540 ! converte into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk 546 CALL wrk_alloc( jpi, jpj, zmbk )547 541 zmbk(:,:) = REAL( mbku_d(:,:), wp ) ; CALL lbc_lnk(zmbk,'U',1.) ; mbku_d(:,:) = MAX( INT( zmbk(:,:) ), 1 ) 548 542 zmbk(:,:) = REAL( mbkv_d(:,:), wp ) ; CALL lbc_lnk(zmbk,'V',1.) ; mbkv_d(:,:) = MAX( INT( zmbk(:,:) ), 1 ) 549 CALL wrk_dealloc( jpi, jpj, zmbk )550 543 ! 551 544 ! !* sign of grad(H) at u- and v-points … … 570 563 ahv_bbl_0(:,:) = rn_ahtbbl * e1_e2v(:,:) * e3v_bbl_0(:,:) * vmask(:,:,1) 571 564 ! 572 IF( nn_timing == 1 )CALL timing_stop( 'tra_bbl_init')565 IF( ln_timing ) CALL timing_stop( 'tra_bbl_init') 573 566 ! 574 567 END SUBROUTINE tra_bbl_init -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/TRA/tradmp.F90
r7753 r8568 33 33 ! 34 34 USE in_out_manager ! I/O manager 35 USE iom ! XIOS 35 36 USE lib_mpp ! MPP library 36 37 USE prtctl ! Print control 37 USE wrk_nemo ! Memory allocation38 38 USE timing ! Timing 39 USE iom40 39 41 40 IMPLICIT NONE … … 94 93 ! 95 94 INTEGER :: ji, jj, jk, jn ! dummy loop indices 96 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: zts_dta, ztrdts97 !!----------------------------------------------------------------------98 ! 99 IF( nn_timing == 1 ) CALL timing_start('tra_dmp')100 !101 CALL wrk_alloc( jpi,jpj,jpk,jpts, zts_dta )95 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) :: zts_dta 96 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: ztrdts 97 !!---------------------------------------------------------------------- 98 ! 99 IF( ln_timing ) CALL timing_start('tra_dmp') 100 ! 102 101 IF( l_trdtra ) THEN !* Save ta and sa trends 103 CALL wrk_alloc( jpi,jpj,jpk,jpts, ztrdts)102 ALLOCATE( ztrdts(jpi,jpj,jpk,jpts) ) 104 103 ztrdts(:,:,:,:) = tsa(:,:,:,:) 105 104 ENDIF … … 154 153 CALL trd_tra( kt, 'TRA', jp_tem, jptra_dmp, ztrdts(:,:,:,jp_tem) ) 155 154 CALL trd_tra( kt, 'TRA', jp_sal, jptra_dmp, ztrdts(:,:,:,jp_sal) ) 156 CALL wrk_dealloc( jpi,jpj,jpk,jpts,ztrdts )155 DEALLOCATE( ztrdts ) 157 156 ENDIF 158 157 ! ! Control print … … 160 159 & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 161 160 ! 162 CALL wrk_dealloc( jpi,jpj,jpk,jpts, zts_dta ) 163 ! 164 IF( nn_timing == 1 ) CALL timing_stop('tra_dmp') 161 IF( ln_timing ) CALL timing_stop('tra_dmp') 165 162 ! 166 163 END SUBROUTINE tra_dmp -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/TRA/traldf.F90
r7765 r8568 30 30 USE lib_mpp ! distribued memory computing library 31 31 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 32 USE wrk_nemo ! Memory allocation33 32 USE timing ! Timing 34 33 … … 58 57 INTEGER, INTENT( in ) :: kt ! ocean time-step index 59 58 !! 60 REAL(wp), POINTER, DIMENSION(:,:,:) ::ztrdt, ztrds61 !!---------------------------------------------------------------------- 62 ! 63 IF( nn_timing == 1) CALL timing_start('tra_ldf')59 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds 60 !!---------------------------------------------------------------------- 61 ! 62 IF( ln_timing ) CALL timing_start('tra_ldf') 64 63 ! 65 64 IF( l_trdtra ) THEN !* Save ta and sa trends 66 CALL wrk_alloc( jpi,jpj,jpk, ztrdt, ztrds)65 ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) 67 66 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 68 67 ztrds(:,:,:) = tsa(:,:,:,jp_sal) … … 85 84 CALL trd_tra( kt, 'TRA', jp_tem, jptra_ldf, ztrdt ) 86 85 CALL trd_tra( kt, 'TRA', jp_sal, jptra_ldf, ztrds ) 87 CALL wrk_dealloc( jpi,jpj,jpk,ztrdt, ztrds )86 DEALLOCATE( ztrdt, ztrds ) 88 87 ENDIF 89 88 ! !* print mean trends (used for debugging) … … 91 90 & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 92 91 ! 93 IF( nn_timing == 1) CALL timing_stop('tra_ldf')92 IF( ln_timing ) CALL timing_stop('tra_ldf') 94 93 ! 95 94 END SUBROUTINE tra_ldf … … 107 106 !!---------------------------------------------------------------------- 108 107 ! 109 IF(lwp) THEN ! Namelist print108 IF(lwp) THEN !== Namelist print ==! 110 109 WRITE(numout,*) 111 110 WRITE(numout,*) 'tra_ldf_init : lateral tracer diffusive operator' … … 114 113 WRITE(numout,*) ' see ldf_tra_init report for lateral mixing parameters' 115 114 ENDIF 116 ! ! use of lateral operator or not115 ! !== use of lateral operator or not ==! 117 116 nldf = np_ERROR 118 117 ioptio = 0 119 IF( ln_traldf_ lap ) ioptio = ioptio + 1120 IF( ln_traldf_ blp ) ioptio = ioptio + 1121 IF( ioptio > 1 ) CALL ctl_stop( 'tra_ldf_init: use ONE or NONE of the 2 lap/bilap operator type on tracer' )122 IF( ioptio == 0 ) nldf = np_no_ldf ! No lateral diffusion123 ! 124 IF( nldf /= np_no_ldf ) THEN ! direction ==>> type of operator118 IF( ln_traldf_NONE ) THEN ; nldf = np_no_ldf ; ioptio = ioptio + 1 ; ENDIF 119 IF( ln_traldf_lap ) THEN ; ioptio = ioptio + 1 ; ENDIF 120 IF( ln_traldf_blp ) THEN ; ioptio = ioptio + 1 ; ENDIF 121 IF( ioptio /= 1 ) CALL ctl_stop( 'tra_ldf_init: use ONE of the 3 operator options (NONE/lap/blp)' ) 122 ! 123 IF( .NOT.ln_traldf_NONE ) THEN !== direction ==>> type of operator ==! 125 124 ioptio = 0 126 125 IF( ln_traldf_lev ) ioptio = ioptio + 1 127 126 IF( ln_traldf_hor ) ioptio = ioptio + 1 128 127 IF( ln_traldf_iso ) ioptio = ioptio + 1 129 IF( ioptio > 1 ) CALL ctl_stop( 'tra_ldf_init: use onlyONE direction (level/hor/iso)' )128 IF( ioptio /= 1 ) CALL ctl_stop( 'tra_ldf_init: use ONE direction (level/hor/iso)' ) 130 129 ! 131 130 ! ! defined the type of lateral diffusion from ln_traldf_... logicals -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/TRA/traldf_iso.F90
r7753 r8568 30 30 USE phycst ! physical constants 31 31 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 32 USE wrk_nemo ! Memory Allocation33 32 USE timing ! Timing 34 33 … … 111 110 REAL(wp) :: zmskv, zahv_w, zabe2, zcof2, zcoef4 ! - - 112 111 REAL(wp) :: zcoef0, ze3w_2, zsign, z2dt, z1_2dt ! - - 113 REAL(wp), POINTER, DIMENSION(:,:) :: zdkt, zdk1t, z2d 114 REAL(wp), POINTER, DIMENSION(:,:,:) :: zdit, zdjt, zftu, zftv, ztfw 115 !!---------------------------------------------------------------------- 116 ! 117 IF( nn_timing == 1 ) CALL timing_start('tra_ldf_iso') 118 ! 119 CALL wrk_alloc( jpi,jpj, zdkt, zdk1t, z2d ) 120 CALL wrk_alloc( jpi,jpj,jpk, zdit, zdjt , zftu, zftv, ztfw ) 112 REAL(wp), DIMENSION(jpi,jpj) :: zdkt, zdk1t, z2d 113 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdit, zdjt, zftu, zftv, ztfw 114 !!---------------------------------------------------------------------- 115 ! 116 IF( ln_timing ) CALL timing_start('tra_ldf_iso') 121 117 ! 122 118 IF( kt == kit000 ) THEN … … 386 382 ! ! =============== 387 383 END DO ! end tracer loop 388 ! ! =============== 389 ! 390 CALL wrk_dealloc( jpi, jpj, zdkt, zdk1t, z2d ) 391 CALL wrk_dealloc( jpi, jpj, jpk, zdit, zdjt , zftu, zftv, ztfw ) 392 ! 393 IF( nn_timing == 1 ) CALL timing_stop('tra_ldf_iso') 384 ! 385 IF( ln_timing ) CALL timing_stop('tra_ldf_iso') 394 386 ! 395 387 END SUBROUTINE tra_ldf_iso -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/TRA/traldf_lap_blp.F90
r7646 r8568 22 22 ! 23 23 USE in_out_manager ! I/O manager 24 USE iom ! I/O library 24 25 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 25 26 USE lib_mpp ! distribued memory computing library 26 27 USE timing ! Timing 27 USE wrk_nemo ! Memory allocation28 USE iom29 28 30 29 IMPLICIT NONE … … 87 86 INTEGER :: ji, jj, jk, jn ! dummy loop indices 88 87 REAL(wp) :: zsign ! local scalars 89 REAL(wp), POINTER, DIMENSION(:,:,:) ::ztu, ztv, zaheeu, zaheev90 !!---------------------------------------------------------------------- 91 ! 92 IF( nn_timing == 1) CALL timing_start('tra_ldf_lap')88 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztu, ztv, zaheeu, zaheev 89 !!---------------------------------------------------------------------- 90 ! 91 IF( ln_timing ) CALL timing_start('tra_ldf_lap') 93 92 ! 94 93 IF( kt == nit000 .AND. lwp ) THEN … … 97 96 WRITE(numout,*) '~~~~~~~~~~~ ' 98 97 ENDIF 99 !100 CALL wrk_alloc( jpi,jpj,jpk, ztu, ztv, zaheeu, zaheev )101 98 ! 102 99 l_hst = .FALSE. … … 169 166 ! ! ================== 170 167 ! 171 CALL wrk_dealloc( jpi,jpj,jpk, ztu, ztv, zaheeu, zaheev ) 172 ! 173 IF( nn_timing == 1 ) CALL timing_stop('tra_ldf_lap') 168 IF( ln_timing ) CALL timing_stop('tra_ldf_lap') 174 169 ! 175 170 END SUBROUTINE tra_ldf_lap … … 203 198 ! 204 199 INTEGER :: ji, jj, jk, jn ! dummy loop indices 205 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: zlap ! laplacian at t-point206 REAL(wp), POINTER, DIMENSION(:,:,:):: zglu, zglv ! bottom GRADh of the laplacian (u- and v-points)207 REAL(wp), POINTER, DIMENSION(:,:,:):: zgui, zgvi ! top GRADh of the laplacian (u- and v-points)200 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt) :: zlap ! laplacian at t-point 201 REAL(wp), DIMENSION(jpi,jpj, kjpt) :: zglu, zglv ! bottom GRADh of the laplacian (u- and v-points) 202 REAL(wp), DIMENSION(jpi,jpj, kjpt) :: zgui, zgvi ! top GRADh of the laplacian (u- and v-points) 208 203 !!--------------------------------------------------------------------- 209 204 ! 210 IF( nn_timing == 1 ) CALL timing_start('tra_ldf_blp') 211 ! 212 CALL wrk_alloc( jpi,jpj,jpk,kjpt, zlap ) 213 CALL wrk_alloc( jpi,jpj, kjpt, zglu, zglv, zgui, zgvi ) 205 IF( ln_timing ) CALL timing_start('tra_ldf_blp') 214 206 ! 215 207 IF( kt == kit000 .AND. lwp ) THEN … … 253 245 END SELECT 254 246 ! 255 CALL wrk_dealloc( jpi,jpj,jpk,kjpt, zlap ) 256 CALL wrk_dealloc( jpi,jpj ,kjpt, zglu, zglv, zgui, zgvi ) 257 ! 258 IF( nn_timing == 1 ) CALL timing_stop('tra_ldf_blp') 247 IF( ln_timing ) CALL timing_stop('tra_ldf_blp') 259 248 ! 260 249 END SUBROUTINE tra_ldf_blp -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/TRA/traldf_triad.F90
r7646 r8568 27 27 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 28 28 USE lib_mpp ! MPP library 29 USE wrk_nemo ! Memory Allocation30 29 USE timing ! Timing 31 30 … … 94 93 REAL(wp) :: ze1ur, ze2vr, ze3wr, zdxt, zdyt, zdzt 95 94 REAL(wp) :: zah, zah_slp, zaei_slp 96 REAL(wp), POINTER, DIMENSION(:,: ) :: z2d! 2D workspace97 REAL(wp), POINTER, DIMENSION(:,:,:) ::zdit, zdjt, zftu, zftv, ztfw, zpsi_uw, zpsi_vw ! 3D -95 REAL(wp), DIMENSION(jpi,jpj ) :: z2d ! 2D workspace 96 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdit, zdjt, zftu, zftv, ztfw, zpsi_uw, zpsi_vw ! 3D - 98 97 !!---------------------------------------------------------------------- 99 98 ! 100 IF( nn_timing == 1 ) CALL timing_start('tra_ldf_triad') 101 ! 102 CALL wrk_alloc( jpi,jpj, z2d ) 103 CALL wrk_alloc( jpi,jpj,jpk, zdit, zdjt, zftu, zftv, ztfw, zpsi_uw, zpsi_vw ) 99 IF( ln_timing ) CALL timing_start('tra_ldf_triad') 104 100 ! 105 101 IF( .NOT.ALLOCATED(zdkt3d) ) THEN … … 434 430 END DO ! end tracer loop 435 431 ! ! =============== 436 ! 437 CALL wrk_dealloc( jpi,jpj, z2d ) 438 CALL wrk_dealloc( jpi,jpj,jpk, zdit, zdjt, zftu, zftv, ztfw, zpsi_uw, zpsi_vw ) 439 ! 440 IF( nn_timing == 1 ) CALL timing_stop('tra_ldf_triad') 432 IF( ln_timing ) CALL timing_stop('tra_ldf_triad') 441 433 ! 442 434 END SUBROUTINE tra_ldf_triad -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/TRA/tranpc.F90
r6140 r8568 26 26 USE in_out_manager ! I/O manager 27 27 USE lib_mpp ! MPP library 28 USE wrk_nemo ! Memory Allocation29 28 USE timing ! Timing 30 29 … … 67 66 REAL(wp) :: zta, zalfa, zsum_temp, zsum_alfa, zaw, zdz, zsum_z 68 67 REAL(wp) :: zsa, zbeta, zsum_sali, zsum_beta, zbw, zrw, z1_r2dt 69 REAL(wp), PARAMETER :: zn2_zero = 1.e-14_wp ! acceptance criteria for neutrality (N2==0) 70 REAL(wp), POINTER, DIMENSION(:) :: zvn2 ! vertical profile of N2 at 1 given point... 71 REAL(wp), POINTER, DIMENSION(:,:) :: zvts ! vertical profile of T and S at 1 given point... 72 REAL(wp), POINTER, DIMENSION(:,:) :: zvab ! vertical profile of alpha and beta 73 REAL(wp), POINTER, DIMENSION(:,:,:) :: zn2 ! N^2 74 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: zab ! alpha and beta 75 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdt, ztrds ! 3D workspace 68 REAL(wp), PARAMETER :: zn2_zero = 1.e-14_wp ! acceptance criteria for neutrality (N2==0) 69 REAL(wp), DIMENSION( jpk ) :: zvn2 ! vertical profile of N2 at 1 given point... 70 REAL(wp), DIMENSION( jpk,jpts) :: zvts, zvab ! vertical profile of T & S , and alpha & betaat 1 given point 71 REAL(wp), DIMENSION(jpi,jpj,jpk ) :: zn2 ! N^2 72 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) :: zab ! alpha and beta 73 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds ! 3D workspace 76 74 ! 77 75 LOGICAL, PARAMETER :: l_LB_debug = .FALSE. ! set to true if you want to follow what is … … 80 78 !!---------------------------------------------------------------------- 81 79 ! 82 IF( nn_timing == 1 )CALL timing_start('tra_npc')80 IF( ln_timing ) CALL timing_start('tra_npc') 83 81 ! 84 82 IF( MOD( kt, nn_npc ) == 0 ) THEN 85 83 ! 86 CALL wrk_alloc( jpi, jpj, jpk, zn2 ) ! N287 CALL wrk_alloc( jpi, jpj, jpk, 2, zab ) ! Alpha and Beta88 CALL wrk_alloc( jpk, 2, zvts, zvab ) ! 1D column vector at point ji,jj89 CALL wrk_alloc( jpk, zvn2 ) ! 1D column vector at point ji,jj90 91 84 IF( l_trdtra ) THEN !* Save initial after fields 92 CALL wrk_alloc( jpi, jpj, jpk, ztrdt, ztrds)85 ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) 93 86 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 94 87 ztrds(:,:,:) = tsa(:,:,:,jp_sal) 95 88 ENDIF 96 89 ! 97 90 IF( l_LB_debug ) THEN 98 91 ! Location of 1 known convection site to follow what's happening in the water column … … 101 94 klc1 = mbkt(ilc1,jlc1) ! bottom of the ocean for debug point... 102 95 ENDIF 103 96 ! 104 97 CALL eos_rab( tsa, zab ) ! after alpha and beta (given on T-points) 105 98 CALL bn2 ( tsa, zab, zn2 ) ! after Brunt-Vaisala (given on W-points) 106 99 ! 107 100 inpcc = 0 108 101 ! 109 102 DO jj = 2, jpjm1 ! interior column only 110 103 DO ji = fs_2, fs_jpim1 … … 313 306 CALL trd_tra( kt, 'TRA', jp_tem, jptra_npc, ztrdt ) 314 307 CALL trd_tra( kt, 'TRA', jp_sal, jptra_npc, ztrds ) 315 CALL wrk_dealloc( jpi, jpj, jpk,ztrdt, ztrds )308 DEALLOCATE( ztrdt, ztrds ) 316 309 ENDIF 317 310 ! … … 323 316 ENDIF 324 317 ! 325 CALL wrk_dealloc(jpi, jpj, jpk, zn2 )326 CALL wrk_dealloc(jpi, jpj, jpk, 2, zab )327 CALL wrk_dealloc(jpk, zvn2 )328 CALL wrk_dealloc(jpk, 2, zvts, zvab )329 !330 318 ENDIF ! IF( MOD( kt, nn_npc ) == 0 ) THEN 331 319 ! 332 IF( nn_timing == 1 )CALL timing_stop('tra_npc')320 IF( ln_timing ) CALL timing_stop('tra_npc') 333 321 ! 334 322 END SUBROUTINE tra_npc -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/TRA/tranxt.F90
r7753 r8568 35 35 USE traqsr ! penetrative solar radiation (needed for nksr) 36 36 USE phycst ! physical constant 37 USE ldftra ! lateral physics ontracers38 USE ldfslp 39 USE bdy_oce , ONLY: ln_bdy37 USE ldftra ! lateral physics : tracers 38 USE ldfslp ! lateral physics : slopes 39 USE bdy_oce , ONLY : ln_bdy 40 40 USE bdytra ! open boundary condition (bdy_tra routine) 41 41 ! … … 43 43 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 44 44 USE prtctl ! Print control 45 USE wrk_nemo ! Memory allocation46 45 USE timing ! Timing 47 46 #if defined key_agrif … … 91 90 INTEGER :: ji, jj, jk, jn ! dummy loop indices 92 91 REAL(wp) :: zfact ! local scalars 93 REAL(wp), POINTER, DIMENSION(:,:,:) ::ztrdt, ztrds94 !!---------------------------------------------------------------------- 95 ! 96 IF( nn_timing == 1 )CALL timing_start( 'tra_nxt')92 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds 93 !!---------------------------------------------------------------------- 94 ! 95 IF( ln_timing ) CALL timing_start( 'tra_nxt') 97 96 ! 98 97 IF( kt == nit000 ) THEN … … 120 119 ! trends computation initialisation 121 120 IF( l_trdtra ) THEN 122 CALL wrk_alloc( jpi, jpj, jpk, ztrdt, ztrds)121 ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) 123 122 ztrdt(:,:,jk) = 0._wp 124 123 ztrds(:,:,jk) = 0._wp … … 170 169 CALL trd_tra( kt, 'TRA', jp_tem, jptra_atf, ztrdt ) 171 170 CALL trd_tra( kt, 'TRA', jp_sal, jptra_atf, ztrds ) 172 CALL wrk_dealloc( jpi, jpj, jpk, ztrdt, ztrds )171 DEALLOCATE( ztrdt , ztrds ) 173 172 END IF 174 173 ! … … 177 176 & tab3d_2=tsn(:,:,:,jp_sal), clinfo2= ' Sn: ', mask2=tmask ) 178 177 ! 179 IF( nn_timing == 1) CALL timing_stop('tra_nxt')178 IF( ln_timing ) CALL timing_stop('tra_nxt') 180 179 ! 181 180 END SUBROUTINE tra_nxt -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/TRA/traqsr.F90
r7753 r8568 29 29 USE in_out_manager ! I/O manager 30 30 USE prtctl ! Print control 31 USE iom ! I/O manager31 USE iom ! I/O library 32 32 USE fldread ! read input fields 33 33 USE restart ! ocean restart 34 34 USE lib_mpp ! MPP library 35 35 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 36 USE wrk_nemo ! Memory Allocation37 36 USE timing ! Timing 38 37 … … 113 112 REAL(wp) :: zCb, zCmax, zze, zpsi, zpsimax, zdelpsi, zCtot, zCze 114 113 REAL(wp) :: zlogc, zlogc2, zlogc3 115 REAL(wp), POINTER, DIMENSION(:,:) :: zekb, zekg, zekr116 REAL(wp), POINTER, DIMENSION(:,:,:) :: ze0, ze1, ze2, ze3, zea, ztrdt117 REAL(wp), POINTER, DIMENSION(:,:,:) :: zetot, zchl3d118 !!---------------------------------------------------------------------- 119 ! 120 IF( nn_timing == 1 )CALL timing_start('tra_qsr')114 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zekb, zekg, zekr 115 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ze0, ze1, ze2, ze3, zea, ztrdt 116 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zetot, zchl3d 117 !!---------------------------------------------------------------------- 118 ! 119 IF( ln_timing ) CALL timing_start('tra_qsr') 121 120 ! 122 121 IF( kt == nit000 ) THEN … … 127 126 ! 128 127 IF( l_trdtra ) THEN ! trends diagnostic: save the input temperature trend 129 CALL wrk_alloc( jpi,jpj,jpk, ztrdt)128 ALLOCATE( ztrdt(jpi,jpj,jpk) ) 130 129 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 131 130 ENDIF … … 161 160 CASE( np_RGB , np_RGBc ) !== R-G-B fluxes ==! 162 161 ! 163 CALL wrk_alloc( jpi,jpj, zekb, zekg, zekr ) 164 CALL wrk_alloc( jpi,jpj,jpk, ze0, ze1, ze2, ze3, zea, zchl3d ) 162 ALLOCATE( zekb(jpi,jpj) , zekg(jpi,jpj) , zekr (jpi,jpj) , & 163 & ze0 (jpi,jpj,jpk) , ze1 (jpi,jpj,jpk) , ze2 (jpi,jpj,jpk) , & 164 & ze3 (jpi,jpj,jpk) , zea (jpi,jpj,jpk) , zchl3d(jpi,jpj,jpk) ) 165 165 ! 166 166 IF( nqsr == np_RGBc ) THEN !* Variable Chlorophyll … … 240 240 END DO 241 241 ! 242 CALL wrk_dealloc( jpi,jpj, zekb, zekg, zekr ) 243 CALL wrk_dealloc( jpi,jpj,jpk, ze0, ze1, ze2, ze3, zea, zchl3d ) 242 DEALLOCATE( zekb , zekg , zekr , ze0 , ze1 , ze2 , ze3 , zea , zchl3d ) 244 243 ! 245 244 CASE( np_2BD ) !== 2-bands fluxes ==! … … 282 281 ! 283 282 IF( iom_use('qsr3d') ) THEN ! output the shortwave Radiation distribution 284 CALL wrk_alloc( jpi,jpj,jpk, zetot ) 285 ! 283 ALLOCATE( zetot(jpi,jpj,jpk) ) 286 284 zetot(:,:,nksr+1:jpk) = 0._wp ! below ~400m set to zero 287 285 DO jk = nksr, 1, -1 288 zetot(:,:,jk) = zetot(:,:,jk+1) + qsr_hc(:,:,jk) / r1_rau0_rcp286 zetot(:,:,jk) = zetot(:,:,jk+1) + qsr_hc(:,:,jk) * rau0_rcp 289 287 END DO 290 288 CALL iom_put( 'qsr3d', zetot ) ! 3D distribution of shortwave Radiation 291 ! 292 CALL wrk_dealloc( jpi,jpj,jpk, zetot ) 289 DEALLOCATE( zetot ) 293 290 ENDIF 294 291 ! … … 301 298 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 302 299 CALL trd_tra( kt, 'TRA', jp_tem, jptra_qsr, ztrdt ) 303 CALL wrk_dealloc( jpi,jpj,jpk,ztrdt )300 DEALLOCATE( ztrdt ) 304 301 ENDIF 305 302 ! ! print mean trends (used for debugging) 306 303 IF(ln_ctl) CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' qsr - Ta: ', mask1=tmask, clinfo3='tra-ta' ) 307 304 ! 308 IF( nn_timing == 1 )CALL timing_stop('tra_qsr')305 IF( ln_timing ) CALL timing_stop('tra_qsr') 309 306 ! 310 307 END SUBROUTINE tra_qsr … … 340 337 !!---------------------------------------------------------------------- 341 338 ! 342 IF( nn_timing == 1) CALL timing_start('tra_qsr_init')339 IF( ln_timing ) CALL timing_start('tra_qsr_init') 343 340 ! 344 341 REWIND( numnam_ref ) ! Namelist namtra_qsr in reference namelist … … 435 432 ENDIF 436 433 ! 437 IF( nn_timing == 1) CALL timing_stop('tra_qsr_init')434 IF( ln_timing ) CALL timing_stop('tra_qsr_init') 438 435 ! 439 436 END SUBROUTINE tra_qsr_init -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/TRA/trasbc.F90
r7788 r8568 32 32 USE iom ! xIOS server 33 33 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 34 USE wrk_nemo ! Memory Allocation35 34 USE timing ! Timing 36 35 … … 75 74 INTEGER :: ikt, ikb ! local integers 76 75 REAL(wp) :: zfact, z1_e3t, zdep ! local scalar 77 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdt, ztrds76 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds 78 77 !!---------------------------------------------------------------------- 79 78 ! 80 IF( nn_timing == 1 )CALL timing_start('tra_sbc')79 IF( ln_timing ) CALL timing_start('tra_sbc') 81 80 ! 82 81 IF( kt == nit000 ) THEN … … 87 86 ! 88 87 IF( l_trdtra ) THEN !* Save ta and sa trends 89 CALL wrk_alloc( jpi, jpj, jpk, ztrdt, ztrds)88 ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) 90 89 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 91 90 ztrds(:,:,:) = tsa(:,:,:,jp_sal) … … 232 231 CALL trd_tra( kt, 'TRA', jp_tem, jptra_nsr, ztrdt ) 233 232 CALL trd_tra( kt, 'TRA', jp_sal, jptra_nsr, ztrds ) 234 CALL wrk_dealloc( jpi, jpj, jpk, ztrdt, ztrds )233 DEALLOCATE( ztrdt , ztrds ) 235 234 ENDIF 236 235 ! … … 238 237 & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 239 238 ! 240 IF( nn_timing == 1 )CALL timing_stop('tra_sbc')239 IF( ln_timing ) CALL timing_stop('tra_sbc') 241 240 ! 242 241 END SUBROUTINE tra_sbc -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/TRA/trazdf.F90
r8367 r8568 56 56 !!--------------------------------------------------------------------- 57 57 ! 58 IF( nn_timing == 1 )CALL timing_start('tra_zdf')58 IF( ln_timing ) CALL timing_start('tra_zdf') 59 59 ! 60 60 IF( neuler == 0 .AND. kt == nit000 ) THEN ! at nit000 … … 97 97 & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 98 98 ! 99 IF( nn_timing == 1 )CALL timing_stop('tra_zdf')99 IF( ln_timing ) CALL timing_stop('tra_zdf') 100 100 ! 101 101 END SUBROUTINE tra_zdf … … 135 135 !!--------------------------------------------------------------------- 136 136 ! 137 IF( nn_timing == 1 )CALL timing_start('tra_zdf_imp')137 IF( ln_timing ) CALL timing_start('tra_zdf_imp') 138 138 ! 139 139 IF( kt == kit000 ) THEN … … 255 255 ! ! ================= ! 256 256 ! 257 IF( nn_timing == 1 )CALL timing_stop('tra_zdf_imp')257 IF( ln_timing ) CALL timing_stop('tra_zdf_imp') 258 258 ! 259 259 END SUBROUTINE tra_zdf_imp -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/TRA/zpshde.F90
r7753 r8568 22 22 USE lbclnk ! lateral boundary conditions (or mpp link) 23 23 USE lib_mpp ! MPP library 24 USE wrk_nemo ! Memory allocation25 24 USE timing ! Timing 26 25 … … 99 98 !!---------------------------------------------------------------------- 100 99 ! 101 IF( nn_timing == 1) CALL timing_start( 'zps_hde')102 ! 103 pgtu(:,:,:) =0._wp ; zti (:,:,:)=0._wp ; zhi (:,: )=0._wp104 pgtv(:,:,:) =0._wp ; ztj (:,:,:)=0._wp ; zhj (:,: )=0._wp100 IF( ln_timing ) CALL timing_start( 'zps_hde') 101 ! 102 pgtu(:,:,:) = 0._wp ; zti (:,:,:) = 0._wp ; zhi (:,:) = 0._wp 103 pgtv(:,:,:) = 0._wp ; ztj (:,:,:) = 0._wp ; zhj (:,:) = 0._wp 105 104 ! 106 105 DO jn = 1, kjpt !== Interpolation of tracers at the last ocean level ==! … … 188 187 END IF 189 188 ! 190 IF( nn_timing == 1) CALL timing_stop( 'zps_hde')189 IF( ln_timing ) CALL timing_stop( 'zps_hde') 191 190 ! 192 191 END SUBROUTINE zps_hde 193 ! 192 193 194 194 SUBROUTINE zps_hde_isf( kt, kjpt, pta, pgtu, pgtv, pgtui, pgtvi, & 195 195 & prd, pgru, pgrv, pgrui, pgrvi ) … … 256 256 !!---------------------------------------------------------------------- 257 257 ! 258 IF( nn_timing == 1 )CALL timing_start( 'zps_hde_isf')258 IF( ln_timing ) CALL timing_start( 'zps_hde_isf') 259 259 ! 260 260 pgtu (:,:,:) = 0._wp ; pgtv (:,:,:) =0._wp … … 453 453 END IF 454 454 ! 455 IF( nn_timing == 1) CALL timing_stop( 'zps_hde_isf')455 IF( ln_timing ) CALL timing_stop( 'zps_hde_isf') 456 456 ! 457 457 END SUBROUTINE zps_hde_isf 458 458 459 !!====================================================================== 459 460 END MODULE zpshde -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/ZDF/zdfddm.F90
r8367 r8568 83 83 !!---------------------------------------------------------------------- 84 84 ! 85 IF( nn_timing == 1) CALL timing_start('zdf_ddm')85 IF( ln_timing ) CALL timing_start('zdf_ddm') 86 86 ! 87 87 ! ! =============== … … 170 170 ENDIF 171 171 ! 172 IF( nn_timing == 1 )CALL timing_stop('zdf_ddm')172 IF( ln_timing ) CALL timing_stop('zdf_ddm') 173 173 ! 174 174 END SUBROUTINE zdf_ddm -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/ZDF/zdfdrg.F90
r8367 r8568 20 20 !!---------------------------------------------------------------------- 21 21 USE oce ! ocean dynamics and tracers variables 22 USE phycst , ONLY: vkarmn22 USE phycst , ONLY : vkarmn 23 23 USE dom_oce ! ocean space and time domain variables 24 24 USE zdf_oce ! ocean vertical physics variables … … 109 109 !!---------------------------------------------------------------------- 110 110 ! 111 IF( nn_timing == 1 )CALL timing_start('zdf_drg')111 IF( ln_timing ) CALL timing_start('zdf_drg') 112 112 ! 113 113 ! … … 140 140 IF(ln_ctl) CALL prt_ctl( tab2d_1=pCdU, clinfo1=' Cd*U ') 141 141 ! 142 IF( nn_timing == 1 )CALL timing_stop('zdf_drg')142 IF( ln_timing ) CALL timing_stop('zdf_drg') 143 143 ! 144 144 END SUBROUTINE zdf_drg -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/ZDF/zdfevd.F90
r8367 r8568 62 62 !!---------------------------------------------------------------------- 63 63 ! 64 IF( nn_timing == 1 )CALL timing_start('zdf_evd')64 IF( ln_timing ) CALL timing_start('zdf_evd') 65 65 ! 66 66 IF( kt == nit000 ) THEN … … 121 121 IF( l_trdtra ) CALL trd_tra( kt, 'TRA', jp_tem, jptra_evd, zavt_evd ) 122 122 ! 123 IF( nn_timing == 1 )CALL timing_stop('zdf_evd')123 IF( ln_timing ) CALL timing_stop('zdf_evd') 124 124 ! 125 125 END SUBROUTINE zdf_evd -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/ZDF/zdfgls.F90
r8367 r8568 159 159 !!-------------------------------------------------------------------- 160 160 ! 161 IF( nn_timing == 1) CALL timing_start('zdf_gls')161 IF( ln_timing ) CALL timing_start('zdf_gls') 162 162 ! 163 163 ! Preliminary computing … … 822 822 ENDIF 823 823 ! 824 IF( nn_timing == 1) CALL timing_stop('zdf_gls')824 IF( ln_timing ) CALL timing_stop('zdf_gls') 825 825 ! 826 826 END SUBROUTINE zdf_gls … … 852 852 !!---------------------------------------------------------- 853 853 ! 854 IF( nn_timing == 1 )CALL timing_start('zdf_gls_init')854 IF( ln_timing ) CALL timing_start('zdf_gls_init') 855 855 ! 856 856 REWIND( numnam_ref ) ! Namelist namzdf_gls in reference namelist : Vertical eddy diffivity and viscosity using gls turbulent closure scheme … … 1077 1077 rl_sf = vkarmn 1078 1078 ELSE 1079 rl_sf = rc0 * SQRT(rc0/rcm_sf) * SQRT( ( (1._wp + 4._wp*rmm + 8._wp*rmm**2_wp)*rsc_tke & 1080 & + 12._wp * rsc_psi0*rpsi2 - (1._wp + 4._wp*rmm) & 1081 & *SQRT(rsc_tke*(rsc_tke & 1082 & + 24._wp*rsc_psi0*rpsi2)) ) & 1083 & /(12._wp*rnn**2.) & 1084 & ) 1079 rl_sf = rc0 * SQRT(rc0/rcm_sf) * SQRT( ( (1._wp + 4._wp*rmm + 8._wp*rmm**2_wp) * rsc_tke & 1080 & + 12._wp*rsc_psi0*rpsi2 - (1._wp + 4._wp*rmm) & 1081 & *SQRT(rsc_tke*(rsc_tke & 1082 & + 24._wp*rsc_psi0*rpsi2)) ) & 1083 & /(12._wp*rnn**2.) ) 1085 1084 ENDIF 1086 1085 … … 1130 1129 CALL gls_rst( nit000, 'READ' ) ! (en, avt_k, avm_k, hmxl_n) 1131 1130 ! 1132 IF( nn_timing == 1 )CALL timing_stop('zdf_gls_init')1131 IF( ln_timing ) CALL timing_stop('zdf_gls_init') 1133 1132 ! 1134 1133 END SUBROUTINE zdf_gls_init -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/ZDF/zdfiwm.F90
r8367 r8568 141 141 !!---------------------------------------------------------------------- 142 142 ! 143 IF( nn_timing == 1) CALL timing_start('zdf_iwm')143 IF( ln_timing ) CALL timing_start('zdf_iwm') 144 144 ! 145 145 ! ! ----------------------------- ! … … 366 366 IF(ln_ctl) CALL prt_ctl(tab3d_1=zav_wave , clinfo1=' iwm - av_wave: ', tab3d_2=avt, clinfo2=' avt: ', ovlap=1, kdim=jpk) 367 367 ! 368 IF( nn_timing == 1) CALL timing_stop('zdf_iwm')368 IF( ln_timing ) CALL timing_stop('zdf_iwm') 369 369 ! 370 370 END SUBROUTINE zdf_iwm … … 405 405 !!---------------------------------------------------------------------- 406 406 ! 407 IF( nn_timing == 1 )CALL timing_start('zdf_iwm_init')407 IF( ln_timing ) CALL timing_start('zdf_iwm_init') 408 408 ! 409 409 REWIND( numnam_ref ) ! Namelist namzdf_iwm in reference namelist : Wave-driven mixing … … 483 483 ENDIF 484 484 ! 485 IF( nn_timing == 1 )CALL timing_stop('zdf_iwm_init')485 IF( ln_timing ) CALL timing_stop('zdf_iwm_init') 486 486 ! 487 487 END SUBROUTINE zdf_iwm_init -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/ZDF/zdfmxl.F90
r8367 r8568 82 82 !!---------------------------------------------------------------------- 83 83 ! 84 IF( nn_timing == 1 )CALL timing_start('zdf_mxl')84 IF( ln_timing ) CALL timing_start('zdf_mxl') 85 85 ! 86 86 IF( kt == nit000 ) THEN … … 141 141 IF(ln_ctl) CALL prt_ctl( tab2d_1=REAL(nmln,wp), clinfo1=' nmln : ', tab2d_2=hmlp, clinfo2=' hmlp : ', ovlap=1 ) 142 142 ! 143 IF( nn_timing == 1 )CALL timing_stop('zdf_mxl')143 IF( ln_timing ) CALL timing_stop('zdf_mxl') 144 144 ! 145 145 END SUBROUTINE zdf_mxl -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/ZDF/zdfphy.F90
r8367 r8568 32 32 USE lbclnk ! lateral boundary conditions 33 33 USE lib_mpp ! distribued memory computing 34 USE timing ! Timing 34 35 35 36 IMPLICIT NONE … … 75 76 & rn_avm0, rn_avt0, nn_avb, nn_havtb ! coefficients 76 77 !!---------------------------------------------------------------------- 78 ! 79 IF( ln_timing ) CALL timing_start('zdf_phy_init') 77 80 ! 78 81 ! !== Namelist ==! … … 193 196 !!gm move it here ? 194 197 ! 198 IF( ln_timing ) CALL timing_stop('zdf_phy_init') 199 ! 195 200 END SUBROUTINE zdf_phy_init 196 201 … … 213 218 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zsh2 ! shear production 214 219 !! --------------------------------------------------------------------- 220 ! 221 IF( ln_timing ) CALL timing_start('zdf_phy') 215 222 ! 216 223 IF( l_zdfdrg ) THEN !== update top/bottom drag ==! (non-linear cases) … … 289 296 ENDIF 290 297 ! 298 IF( ln_timing ) CALL timing_stop('zdf_phy') 299 ! 291 300 END SUBROUTINE zdf_phy 292 301 -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/ZDF/zdfric.F90
r8367 r8568 158 158 !!---------------------------------------------------------------------- 159 159 ! 160 IF( nn_timing == 1) CALL timing_start('zdf_ric')160 IF( ln_timing ) CALL timing_start('zdf_ric') 161 161 ! 162 162 ! !== avm and avt = F(Richardson number) ==! … … 197 197 ENDIF 198 198 ! 199 IF( nn_timing == 1) CALL timing_stop('zdf_ric')199 IF( ln_timing ) CALL timing_stop('zdf_ric') 200 200 ! 201 201 END SUBROUTINE zdf_ric -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/ZDF/zdfsh2.F90
r8367 r8568 56 56 !!-------------------------------------------------------------------- 57 57 ! 58 IF( nn_timing == 1 )CALL timing_start('zdf_sh2')58 IF( ln_timing ) CALL timing_start('zdf_sh2') 59 59 ! 60 60 DO jk = 2, jpkm1 … … 77 77 END DO 78 78 ! 79 IF( nn_timing == 1 )CALL timing_stop('zdf_sh2')79 IF( ln_timing ) CALL timing_stop('zdf_sh2') 80 80 ! 81 81 END SUBROUTINE zdf_sh2 -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/ZDF/zdftke.F90
r8367 r8568 159 159 !! Bruchard OM 2002 160 160 !!---------------------------------------------------------------------- 161 INTEGER 161 INTEGER , INTENT(in ) :: kt ! ocean time step 162 162 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: p_sh2 ! shear production term 163 REAL(wp), DIMENSION(:,:,:) 163 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: p_avm, p_avt ! momentum and tracer Kz (w-points) 164 164 !!---------------------------------------------------------------------- 165 165 ! … … 194 194 !! a tridiagonal linear system by a "methode de chasse" 195 195 !! - increase TKE due to surface and internal wave breaking 196 !! NB: when sea-ice is present, both LC parameterization 197 !! and TKE penetration are turned off when the ice fraction 198 !! is smaller than 0.25 196 199 !! 197 200 !! ** Action : - en : now turbulent kinetic energy) … … 217 220 !!-------------------------------------------------------------------- 218 221 ! 219 IF( nn_timing == 1 )CALL timing_start('tke_tke')222 IF( ln_timing ) CALL timing_start('tke_tke') 220 223 ! 221 224 zbbrau = rn_ebb / rau0 ! Local constant initialisation … … 312 315 zwlc = zind * rn_lc * zus * SIN( rpi * pdepw(ji,jj,jk) / zhlc(ji,jj) ) 313 316 ! ! TKE Langmuir circulation source term 314 en(ji,jj,jk) = en(ji,jj,jk) + rdt * MAX(0.,1._wp - 2.*fr_i(ji,jj) ) * ( zwlc * zwlc * zwlc ) &317 en(ji,jj,jk) = en(ji,jj,jk) + rdt * MAX(0.,1._wp - 4.*fr_i(ji,jj) ) * ( zwlc * zwlc * zwlc ) & 315 318 & / zhlc(ji,jj) * wmask(ji,jj,jk) * tmask(ji,jj,1) 316 319 END DO … … 415 418 DO ji = fs_2, fs_jpim1 ! vector opt. 416 419 en(ji,jj,jk) = en(ji,jj,jk) + rn_efr * en(ji,jj,1) * EXP( -pdepw(ji,jj,jk) / htau(ji,jj) ) & 417 & * MAX(0.,1._wp - 2.*fr_i(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1)420 & * MAX(0.,1._wp - 4.*fr_i(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) 418 421 END DO 419 422 END DO … … 424 427 jk = nmln(ji,jj) 425 428 en(ji,jj,jk) = en(ji,jj,jk) + rn_efr * en(ji,jj,1) * EXP( -pdepw(ji,jj,jk) / htau(ji,jj) ) & 426 & * MAX(0.,1._wp - 2.*fr_i(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1)429 & * MAX(0.,1._wp - 4.*fr_i(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) 427 430 END DO 428 431 END DO … … 437 440 zdif = rhftau_scl * MAX( 0._wp, zdif + rhftau_add ) ! apply some modifications... 438 441 en(ji,jj,jk) = en(ji,jj,jk) + zbbrau * zdif * EXP( -pdepw(ji,jj,jk) / htau(ji,jj) ) & 439 & * MAX(0.,1._wp - 2.*fr_i(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1)440 END DO 441 END DO 442 END DO 443 ENDIF 444 ! 445 IF( nn_timing == 1 )CALL timing_stop('tke_tke')442 & * MAX(0.,1._wp - 4.*fr_i(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) 443 END DO 444 END DO 445 END DO 446 ENDIF 447 ! 448 IF( ln_timing ) CALL timing_stop('tke_tke') 446 449 ! 447 450 END SUBROUTINE tke_tke … … 493 496 !!-------------------------------------------------------------------- 494 497 ! 495 IF( nn_timing == 1 )CALL timing_start('tke_avn')498 IF( ln_timing ) CALL timing_start('tke_avn') 496 499 497 500 ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< … … 636 639 ENDIF 637 640 ! 638 IF( nn_timing == 1 )CALL timing_stop('tke_avn')641 IF( ln_timing ) CALL timing_stop('tke_avn') 639 642 ! 640 643 END SUBROUTINE tke_avn -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/nemogcm.F90
r8367 r8568 206 206 #if defined key_agrif 207 207 IF( .NOT. Agrif_Root() ) THEN 208 CALL Agrif_ParentGrid_To_ChildGrid()209 IF( ln_diaobs ) CALL dia_obs_wri210 IF( nn_timing == 1) CALL timing_finalize211 212 ENDIF 213 #endif 214 IF( nn_timing == 1) CALL timing_finalize208 CALL Agrif_ParentGrid_To_ChildGrid() 209 IF( ln_diaobs ) CALL dia_obs_wri 210 IF( ln_timing ) CALL timing_finalize 211 CALL Agrif_ChildGrid_To_ParentGrid() 212 ENDIF 213 #endif 214 IF( ln_timing ) CALL timing_finalize 215 215 ! 216 216 CALL nemo_closefile … … 242 242 NAMELIST/namctl/ ln_ctl , nn_print, nn_ictls, nn_ictle, & 243 243 & nn_isplt , nn_jsplt, nn_jctls, nn_jctle, & 244 & nn_timing, nn_diacfl244 & ln_timing, ln_diacfl 245 245 NAMELIST/namcfg/ ln_read_cfg, cn_domcfg, ln_write_cfg, cn_domcfg_out, ln_use_jattr 246 246 !!---------------------------------------------------------------------- … … 416 416 ENDIF 417 417 ! 418 IF( nn_timing == 1 )CALL timing_init418 IF( ln_timing ) CALL timing_init 419 419 ! 420 420 ! ! General initialization 421 422 423 IF( lk_c1d 424 425 426 IF( ln_crs 427 IF( ln_nnogather ) 428 IF( ln_ctl 421 CALL phy_cst ! Physical constants 422 CALL eos_init ! Equation of state 423 IF( lk_c1d ) CALL c1d_init ! 1D column configuration 424 CALL wad_init ! Wetting and drying options 425 CALL dom_init ! Domain 426 IF( ln_crs ) CALL crs_init ! coarsened grid: domain initialization 427 IF( ln_nnogather ) CALL nemo_northcomms! northfold neighbour lists (must be done after the masks are defined) 428 IF( ln_ctl ) CALL prt_ctl_init ! Print control 429 429 430 430 CALL diurnal_sst_bulk_init ! diurnal sst … … 432 432 433 433 ! IF ln_diurnal_only, then we only want a subset of the initialisation routines 434 IF 434 IF( ln_diurnal_only ) THEN 435 435 CALL istate_init ! ocean initial state (Dynamics and tracers) 436 436 CALL sbc_init ! Forcings : surface module 437 437 CALL tra_qsr_init ! penetrative solar radiation qsr 438 IF( ln_diaobs ) THEN! Observation & model comparison439 CALL dia_obs_init ! Initialize observational data440 CALL dia_obs( nit000 - 1 ) ! Observation operator for restart438 IF( ln_diaobs ) THEN ! Observation & model comparison 439 CALL dia_obs_init ! Initialize observational data 440 CALL dia_obs( nit000 - 1 ) ! Observation operator for restart 441 441 ENDIF 442 442 ! ! Assimilation increments 443 IF( lk_asminc 443 IF( lk_asminc ) CALL asm_inc_init ! Initialize assimilation increments 444 444 445 445 IF(lwp) WRITE(numout,*) 'Euler time step switch is ', neuler … … 447 447 ENDIF 448 448 449 449 CALL istate_init ! ocean initial state (Dynamics and tracers) 450 450 451 451 ! ! external forcing 452 452 !!gm to be added : creation and call of sbc_apr_init 453 454 455 453 CALL tide_init ! tidal harmonics 454 CALL sbc_init ! surface boundary conditions (including sea-ice) 455 CALL bdy_init ! Open boundaries initialisation 456 456 457 457 ! ! Ocean physics 458 CALL zdf_phy_init! Vertical physics458 CALL zdf_phy_init ! Vertical physics 459 459 460 460 ! ! Lateral physics 461 462 463 461 CALL ldf_tra_init ! Lateral ocean tracer physics 462 CALL ldf_eiv_init ! eddy induced velocity param. 463 CALL ldf_dyn_init ! Lateral ocean momentum physics 464 464 465 465 ! ! Active tracers 466 467 468 IF( ln_trabbl 469 470 471 466 CALL tra_qsr_init ! penetrative solar radiation qsr 467 CALL tra_bbc_init ! bottom heat flux 468 IF( ln_trabbl ) CALL tra_bbl_init ! advective (and/or diffusive) bottom boundary layer scheme 469 CALL tra_dmp_init ! internal tracer damping 470 CALL tra_adv_init ! horizontal & vertical advection 471 CALL tra_ldf_init ! lateral mixing 472 472 473 473 ! ! Dynamics 474 IF( lk_c1d 475 476 477 478 479 474 IF( lk_c1d ) CALL dyn_dmp_init ! internal momentum damping 475 CALL dyn_adv_init ! advection (vector or flux form) 476 CALL dyn_vor_init ! vorticity term including Coriolis 477 CALL dyn_ldf_init ! lateral mixing 478 CALL dyn_hpg_init ! horizontal gradient of Hydrostatic pressure 479 CALL dyn_spg_init ! surface pressure gradient 480 480 481 481 #if defined key_top 482 482 ! ! Passive tracers 483 484 #endif 485 IF( l_ldfslp ) CALL ldf_slp_init! slope of lateral mixing483 CALL trc_init 484 #endif 485 IF( l_ldfslp ) CALL ldf_slp_init ! slope of lateral mixing 486 486 487 487 ! ! Icebergs 488 488 CALL icb_init( rdt, nit000) ! initialise icebergs instance 489 489 490 490 ! ! Misc. options 491 CALL sto_par_init! Stochastic parametrization492 IF( ln_sto_eos ) CALL sto_pts_init! RRandom T/S fluctuations491 CALL sto_par_init ! Stochastic parametrization 492 IF( ln_sto_eos ) CALL sto_pts_init ! RRandom T/S fluctuations 493 493 494 494 ! ! Diagnostics 495 IF( lk_floats ) CALL flo_init! drifting Floats496 CALL dia_cfl_init! Initialise CFL diagnostics497 CALL dia_ptr_init! Poleward TRansports initialization498 IF( lk_diadct ) CALL dia_dct_init! Sections tranports499 CALL dia_hsb_init! heat content, salt content and volume budgets500 CALL trd_init! Mixed-layer/Vorticity/Integral constraints trends501 CALL dia_obs_init! Initialize observational data502 IF( ln_diaobs 495 IF( lk_floats ) CALL flo_init ! drifting Floats 496 IF( ln_diacfl ) CALL dia_cfl_init ! Initialise CFL diagnostics 497 CALL dia_ptr_init ! Poleward TRansports initialization 498 IF( lk_diadct ) CALL dia_dct_init ! Sections tranports 499 CALL dia_hsb_init ! heat content, salt content and volume budgets 500 CALL trd_init ! Mixed-layer/Vorticity/Integral constraints trends 501 CALL dia_obs_init ! Initialize observational data 502 IF( ln_diaobs ) CALL dia_obs( nit000 - 1 ) ! Observation operator for restart 503 503 504 504 ! ! Assimilation increments 505 IF( lk_asminc ) CALL asm_inc_init! Initialize assimilation increments505 IF( lk_asminc ) CALL asm_inc_init ! Initialize assimilation increments 506 506 IF(lwp) WRITE(numout,*) 'Euler time step switch is ', neuler 507 CALL dia_tmb_init! TMB outputs508 CALL dia_25h_init! 25h mean outputs507 CALL dia_tmb_init ! TMB outputs 508 CALL dia_25h_init ! 25h mean outputs 509 509 ! 510 510 END SUBROUTINE nemo_init … … 533 533 WRITE(numout,*) ' number of proc. following i nn_isplt = ', nn_isplt 534 534 WRITE(numout,*) ' number of proc. following j nn_jsplt = ', nn_jsplt 535 WRITE(numout,*) ' timing activated (0/1) nn_timing = ', nn_timing 535 WRITE(numout,*) ' timing by routine ln_timing = ', ln_timing 536 WRITE(numout,*) ' CFL diagnostics ln_diacfl = ', ln_diacfl 536 537 ENDIF 537 538 ! … … 543 544 isplt = nn_isplt 544 545 jsplt = nn_jsplt 546 !!gm to be remove at the end of the 2017 merge party 547 if( ln_timing ) then ; nn_timing = 1 548 else ; nn_timing = 0 549 endif 550 !!gm end 551 545 552 546 553 IF(lwp) THEN ! control print -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/step.F90
r8367 r8568 208 208 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 209 209 IF( lk_floats ) CALL flo_stp( kstp ) ! drifting Floats 210 IF( nn_diacfl == 1) CALL dia_cfl( kstp ) ! Courant number diagnostics210 IF( ln_diacfl ) CALL dia_cfl( kstp ) ! Courant number diagnostics 211 211 IF( lk_diahth ) CALL dia_hth( kstp ) ! Thermocline depth (20 degres isotherm depth) 212 212 IF( lk_diadct ) CALL dia_dct( kstp ) ! Transports … … 324 324 #endif 325 325 ! 326 IF( nn_timing == 1.AND. kstp == nit000 ) CALL timing_reset326 IF( ln_timing .AND. kstp == nit000 ) CALL timing_reset 327 327 ! 328 328 END SUBROUTINE stp -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/stpctl.F90
r8367 r8568 96 96 IF( lk_mpp ) THEN 97 97 CALL mpp_maxloc( ABS(sshn) , tmask(:,:,1), zzz, iih, ijh ) 98 CALL mpp_maxloc( ABS(un) , umask 98 CALL mpp_maxloc( ABS(un) , umask(:,:,:), zzz, iiu, iju, iku ) 99 99 CALL mpp_minloc( tsn(:,:,1,jp_sal), tmask(:,:,1), zzz, iis, ijs ) 100 100 ELSE -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/SAO_SRC/nemogcm.F90
r7646 r8568 97 97 NAMELIST/namctl/ ln_ctl , nn_print, nn_ictls, nn_ictle, & 98 98 & nn_isplt , nn_jsplt, nn_jctls, nn_jctle, & 99 & nn_timing, nn_diacfl99 & ln_timing, ln_diacfl 100 100 NAMELIST/namcfg/ ln_read_cfg, cn_domcfg, ln_write_cfg, cn_domcfg_out, ln_use_jattr 101 101 !!---------------------------------------------------------------------- … … 259 259 ! !-------------------------------! 260 260 261 CALL nemo_ctl ! Control prints & Benchmark262 263 ! ! Domain decomposition261 CALL nemo_ctl ! Control prints & Benchmark 262 263 ! ! Domain decomposition 264 264 IF( jpni*jpnj == jpnij ) THEN ; CALL mpp_init ! standard cutting out 265 265 ELSE ; CALL mpp_init2 ! eliminate land processors 266 266 ENDIF 267 267 ! 268 IF( nn_timing == 1 ) CALL timing_init269 ! 270 ! ! General initialization271 CALL phy_cst! Physical constants272 CALL eos_init! Equation of state273 CALL dom_init! Domain274 275 IF( ln_nnogather ) CALL nemo_northcomms! Initialise the northfold neighbour lists (must be done after the masks are defined)276 277 IF( ln_ctl ) CALL prt_ctl_init! Print control278 279 CALL istate_init! ocean initial state (Dynamics and tracers)268 IF( ln_timing ) CALL timing_init ! timing by routine 269 ! 270 ! ! General initialization 271 CALL phy_cst ! Physical constants 272 CALL eos_init ! Equation of state 273 CALL dom_init ! Domain 274 275 IF( ln_nnogather ) CALL nemo_northcomms ! Initialise the northfold neighbour lists (must be done after the masks are defined) 276 277 IF( ln_ctl ) CALL prt_ctl_init ! Print control 278 279 CALL istate_init ! ocean initial state (Dynamics and tracers) 280 280 END SUBROUTINE nemo_init 281 281 … … 303 303 WRITE(numout,*) ' number of proc. following i nn_isplt = ', nn_isplt 304 304 WRITE(numout,*) ' number of proc. following j nn_jsplt = ', nn_jsplt 305 WRITE(numout,*) ' timing activated (0/1) nn_timing = ', nn_timing 305 WRITE(numout,*) ' timing by routine ln_timing = ', ln_timing 306 WRITE(numout,*) ' CFL diagnostics ln_diacfl = ', ln_diacfl 306 307 ENDIF 307 308 ! -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/SAS_SRC/nemogcm.F90
r7761 r8568 136 136 IF( .NOT. Agrif_Root() ) THEN 137 137 CALL Agrif_ParentGrid_To_ChildGrid() 138 IF( nn_timing == 1) CALL timing_finalize138 IF( ln_timing ) CALL timing_finalize 139 139 CALL Agrif_ChildGrid_To_ParentGrid() 140 140 ENDIF 141 141 #endif 142 IF( nn_timing == 1) CALL timing_finalize142 IF( ln_timing ) CALL timing_finalize 143 143 ! 144 144 CALL nemo_closefile … … 172 172 NAMELIST/namctl/ ln_ctl , nn_print, nn_ictls, nn_ictle, & 173 173 & nn_isplt , nn_jsplt, nn_jctls, nn_jctle, & 174 & nn_timing, nn_diacfl174 & ln_timing, ln_diacfl 175 175 NAMELIST/namcfg/ ln_read_cfg, cn_domcfg, ln_write_cfg, cn_domcfg_out, ln_use_jattr 176 176 !!---------------------------------------------------------------------- … … 353 353 ENDIF 354 354 ! 355 IF( nn_timing == 1 )CALL timing_init355 IF( ln_timing ) CALL timing_init 356 356 ! 357 357 ! ! General initialization 358 359 360 361 362 IF( ln_nnogather ) 363 364 IF( ln_ctl ) 365 366 367 358 CALL phy_cst ! Physical constants 359 CALL eos_init ! Equation of state 360 CALL dom_init ! Domain 361 362 IF( ln_nnogather ) CALL nemo_northcomms ! Initialise the northfold neighbour lists (must be done after the masks are defined) 363 364 IF( ln_ctl ) CALL prt_ctl_init ! Print control 365 CALL day_init ! model calendar (using both namelist and restart infos) 366 367 CALL sbc_init ! Forcings : surface module 368 368 369 369 ! ==> clem: open boundaries init. is mandatory for LIM3 because ice BDY is not decoupled from 370 370 ! the environment of ocean BDY. Therefore bdy is called in both OPA and SAS modules. 371 371 ! This is not clean and should be changed in the future. 372 372 CALL bdy_init 373 373 ! ==> 374 374 CALL icb_init( rdt, nit000) ! initialise icebergs instance 375 375 376 376 IF(lwp) WRITE(numout,*) 'Euler time step switch is ', neuler … … 401 401 WRITE(numout,*) ' number of proc. following i nn_isplt = ', nn_isplt 402 402 WRITE(numout,*) ' number of proc. following j nn_jsplt = ', nn_jsplt 403 WRITE(numout,*) ' timing activated (0/1) nn_timing = ', nn_timing 403 WRITE(numout,*) ' timing by routine ln_timing = ', ln_timing 404 WRITE(numout,*) ' CFL diagnostics ln_diacfl = ', ln_diacfl 404 405 ENDIF 405 406 ! … … 411 412 isplt = nn_isplt 412 413 jsplt = nn_jsplt 414 !!gm to be remove at the end of the 2017 merge party 415 if( ln_timing ) then ; nn_timing = 1 416 else ; nn_timing = 0 417 endif 418 !!gm end 413 419 414 420 IF(lwp) THEN ! control print -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/SAS_SRC/step.F90
r7761 r8568 127 127 #endif 128 128 ! 129 IF( nn_timing == 1.AND. kstp == nit000 ) CALL timing_reset129 IF( ln_timing .AND. kstp == nit000 ) CALL timing_reset 130 130 ! 131 131 END SUBROUTINE stp -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/TOP_SRC/TRP/trcadv.F90
r7753 r8568 7 7 !! 3.0 ! 2010-06 (C. Ethe) Adapted to passive tracers 8 8 !! 3.7 ! 2014-05 (G. Madec, C. Ethe) Add 2nd/4th order cases for CEN and FCT schemes 9 !! 4.0 ! 2017-09 (G. Madec) remove vertical time-splitting option 9 10 !!---------------------------------------------------------------------- 10 11 #if defined key_top … … 17 18 USE oce_trc ! ocean dynamics and active tracers 18 19 USE trc ! ocean passive tracers variables 20 USE sbcwave ! wave module 21 USE sbc_oce ! surface boundary condition: ocean 19 22 USE traadv_cen ! centered scheme (tra_adv_cen routine) 20 23 USE traadv_fct ! FCT scheme (tra_adv_fct routine) … … 23 26 USE traadv_qck ! QUICKEST scheme (tra_adv_qck routine) 24 27 USE traadv_mle ! ML eddy induced velocity (tra_adv_mle routine) 25 USE ldftra ! lateral diffusion coefficient on tracers28 USE ldftra ! lateral diffusion: eddy diffusivity & EIV coeff. 26 29 USE ldfslp ! Lateral diffusion: slopes of neutral surfaces 27 30 ! 28 USE prtctl_trc ! Print control 31 USE prtctl_trc ! control print 32 USE timing ! Timing 29 33 30 34 IMPLICIT NONE 31 35 PRIVATE 32 36 33 PUBLIC trc_adv 34 PUBLIC trc_adv_ini 37 PUBLIC trc_adv ! called by trctrp.F90 38 PUBLIC trc_adv_ini ! called by trcini.F90 35 39 36 40 ! !!* Namelist namtrc_adv * 41 LOGICAL :: ln_trcadv_NONE ! no advection on passive tracers 37 42 LOGICAL :: ln_trcadv_cen ! centered scheme flag 38 43 INTEGER :: nn_cen_h, nn_cen_v ! =2/4 : horizontal and vertical choices of the order of CEN scheme 39 44 LOGICAL :: ln_trcadv_fct ! FCT scheme flag 40 45 INTEGER :: nn_fct_h, nn_fct_v ! =2/4 : horizontal and vertical choices of the order of FCT scheme 41 INTEGER :: nn_fct_zts ! >=1 : 2nd order FCT with vertical sub-timestepping42 46 LOGICAL :: ln_trcadv_mus ! MUSCL scheme flag 43 47 LOGICAL :: ln_mus_ups ! use upstream scheme in vivcinity of river mouths … … 46 50 LOGICAL :: ln_trcadv_qck ! QUICKEST scheme flag 47 51 48 ! ! choices of advection scheme: 52 INTEGER :: nadv ! choice of the type of advection scheme 53 ! ! associated indices: 49 54 INTEGER, PARAMETER :: np_NO_adv = 0 ! no T-S advection 50 55 INTEGER, PARAMETER :: np_CEN = 1 ! 2nd/4th order centered scheme 51 56 INTEGER, PARAMETER :: np_FCT = 2 ! 2nd/4th order Flux Corrected Transport scheme 52 INTEGER, PARAMETER :: np_FCT_zts = 3 ! 2nd order FCT scheme with vertical sub-timestepping 53 INTEGER, PARAMETER :: np_MUS = 4 ! MUSCL scheme 54 INTEGER, PARAMETER :: np_UBS = 5 ! 3rd order Upstream Biased Scheme 55 INTEGER, PARAMETER :: np_QCK = 6 ! QUICK scheme 56 57 INTEGER :: nadv ! chosen advection scheme 58 ! 57 INTEGER, PARAMETER :: np_MUS = 3 ! MUSCL scheme 58 INTEGER, PARAMETER :: np_UBS = 4 ! 3rd order Upstream Biased Scheme 59 INTEGER, PARAMETER :: np_QCK = 5 ! QUICK scheme 60 59 61 !! * Substitutions 60 62 # include "vectopt_loop_substitute.h90" 61 63 !!---------------------------------------------------------------------- 62 !! NEMO/TOP 3.7 , NEMO Consortium (2015)64 !! NEMO/TOP 4.0 , NEMO Consortium (2017) 63 65 !! $Id$ 64 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)66 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 65 67 !!---------------------------------------------------------------------- 66 68 CONTAINS … … 72 74 !! ** Purpose : compute the ocean tracer advection trend. 73 75 !! 74 !! ** Method : - Update the tracerwith the advection term following nadv76 !! ** Method : - Update after tracers (tra) with the advection term following nadv 75 77 !!---------------------------------------------------------------------- 76 78 INTEGER, INTENT(in) :: kt ! ocean time-step index … … 78 80 INTEGER :: jk ! dummy loop index 79 81 CHARACTER (len=22) :: charout 80 REAL(wp), POINTER, DIMENSION(:,:,:) :: zun, zvn, zwn ! effective velocity 81 !!---------------------------------------------------------------------- 82 ! 83 IF( nn_timing == 1 ) CALL timing_start('trc_adv') 84 ! 85 CALL wrk_alloc( jpi,jpj,jpk, zun, zvn, zwn ) 86 ! !== effective transport ==! 82 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zun, zvn, zwn ! effective velocity 83 !!---------------------------------------------------------------------- 84 ! 85 IF( ln_timing ) CALL timing_start('trc_adv') 86 ! 87 ! !== effective transport ==! 87 88 IF( l_offline ) THEN 88 zun(:,:,:) = un(:,:,:) ! effective transport already in un/vn/wn89 zun(:,:,:) = un(:,:,:) ! already in (un,vn,wn) 89 90 zvn(:,:,:) = vn(:,:,:) 90 91 zwn(:,:,:) = wn(:,:,:) 91 ELSE 92 ! 93 DO jk = 1, jpkm1 94 zun(:,:,jk) = e2u (:,:) * e3u_n(:,:,jk) * un(:,:,jk) ! eulerian transport 95 zvn(:,:,jk) = e1v (:,:) * e3v_n(:,:,jk) * vn(:,:,jk) 96 zwn(:,:,jk) = e1e2t(:,:) * wn(:,:,jk) 97 END DO 92 ELSE ! build the effective transport 93 zun(:,:,jpk) = 0._wp 94 zvn(:,:,jpk) = 0._wp 95 zwn(:,:,jpk) = 0._wp 96 IF( ln_wave .AND. ln_sdw ) THEN 97 DO jk = 1, jpkm1 ! eulerian transport + Stokes Drift 98 zun(:,:,jk) = e2u (:,:) * e3u_n(:,:,jk) * ( un(:,:,jk) + usd(:,:,jk) ) 99 zvn(:,:,jk) = e1v (:,:) * e3v_n(:,:,jk) * ( vn(:,:,jk) + vsd(:,:,jk) ) 100 zwn(:,:,jk) = e1e2t(:,:) * ( wn(:,:,jk) + wsd(:,:,jk) ) 101 END DO 102 ELSE 103 DO jk = 1, jpkm1 104 zun(:,:,jk) = e2u (:,:) * e3u_n(:,:,jk) * un(:,:,jk) ! eulerian transport 105 zvn(:,:,jk) = e1v (:,:) * e3v_n(:,:,jk) * vn(:,:,jk) 106 zwn(:,:,jk) = e1e2t(:,:) * wn(:,:,jk) 107 END DO 108 ENDIF 98 109 ! 99 110 IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! add z-tilde and/or vvl corrections … … 107 118 IF( ln_mle ) CALL tra_adv_mle( kt, nittrc000, zun, zvn, zwn, 'TRC' ) ! add the mle transport 108 119 ! 109 zun(:,:,jpk) = 0._wp ! no transport trough the bottom110 zvn(:,:,jpk) = 0._wp111 zwn(:,:,jpk) = 0._wp112 !113 120 ENDIF 114 121 ! 115 122 SELECT CASE ( nadv ) !== compute advection trend and add it to general trend ==! 116 123 ! 117 CASE ( np_CEN ) ! Centered : 2nd / 4th order 118 CALL tra_adv_cen ( kt, nittrc000,'TRC', zun, zvn, zwn , trn, tra, jptra, nn_cen_h, nn_cen_v ) 119 CASE ( np_FCT ) ! FCT : 2nd / 4th order 120 CALL tra_adv_fct ( kt, nittrc000,'TRC', r2dttrc, zun, zvn, zwn, trb, trn, tra, jptra, nn_fct_h, nn_fct_v ) 121 CASE ( np_FCT_zts ) ! 2nd order FCT with vertical time-splitting 122 CALL tra_adv_fct_zts( kt, nittrc000,'TRC', r2dttrc, zun, zvn, zwn, trb, trn, tra, jptra , nn_fct_zts ) 123 CASE ( np_MUS ) ! MUSCL 124 CALL tra_adv_mus ( kt, nittrc000,'TRC', r2dttrc, zun, zvn, zwn, trb, tra, jptra , ln_mus_ups ) 125 CASE ( np_UBS ) ! UBS 126 CALL tra_adv_ubs ( kt, nittrc000,'TRC', r2dttrc, zun, zvn, zwn, trb, trn, tra, jptra , nn_ubs_v ) 127 CASE ( np_QCK ) ! QUICKEST 128 CALL tra_adv_qck ( kt, nittrc000,'TRC', r2dttrc, zun, zvn, zwn, trb, trn, tra, jptra ) 124 CASE ( np_CEN ) ! Centered : 2nd / 4th order 125 CALL tra_adv_cen( kt, nittrc000,'TRC', zun, zvn, zwn , trn, tra, jptra, nn_cen_h, nn_cen_v ) 126 CASE ( np_FCT ) ! FCT : 2nd / 4th order 127 CALL tra_adv_fct( kt, nittrc000,'TRC', r2dttrc, zun, zvn, zwn, trb, trn, tra, jptra, nn_fct_h, nn_fct_v ) 128 CASE ( np_MUS ) ! MUSCL 129 CALL tra_adv_mus( kt, nittrc000,'TRC', r2dttrc, zun, zvn, zwn, trb, tra, jptra , ln_mus_ups ) 130 CASE ( np_UBS ) ! UBS 131 CALL tra_adv_ubs( kt, nittrc000,'TRC', r2dttrc, zun, zvn, zwn, trb, trn, tra, jptra , nn_ubs_v ) 132 CASE ( np_QCK ) ! QUICKEST 133 CALL tra_adv_qck( kt, nittrc000,'TRC', r2dttrc, zun, zvn, zwn, trb, trn, tra, jptra ) 129 134 ! 130 135 END SELECT 131 136 ! 132 IF( ln_ctl ) THEN !== print mean trends (used for debugging) 133 WRITE(charout, FMT="('adv ')") ; CALL prt_ctl_trc_info(charout) 134 CALL prt_ctl_trc( tab4d=tra, mask=tmask, clinfo=ctrcnm, clinfo2='trd' ) 137 IF( ln_ctl ) THEN !== print mean trends (used for debugging) 138 WRITE(charout, FMT="('adv ')") 139 CALL prt_ctl_trc_info(charout) 140 CALL prt_ctl_trc( tab4d=tra, mask=tmask, clinfo=ctrcnm, clinfo2='trd' ) 135 141 END IF 136 142 ! 137 CALL wrk_dealloc( jpi,jpj,jpk, zun, zvn, zwn ) 138 ! 139 IF( nn_timing == 1 ) CALL timing_stop('trc_adv') 143 IF( ln_timing ) CALL timing_stop('trc_adv') 140 144 ! 141 145 END SUBROUTINE trc_adv … … 146 150 !! *** ROUTINE trc_adv_ini *** 147 151 !! 148 !! ** Purpose : Control the consistency between namelist options for152 !! ** Purpose : Control the consistency between namelist options for 149 153 !! passive tracer advection schemes and set nadv 150 154 !!---------------------------------------------------------------------- … … 152 156 INTEGER :: ios ! Local integer output status for namelist read 153 157 !! 154 NAMELIST/namtrc_adv/ ln_trcadv_cen, nn_cen_h, nn_cen_v, & ! CEN 155 & ln_trcadv_fct, nn_fct_h, nn_fct_v, nn_fct_zts, & ! FCT 156 & ln_trcadv_mus, ln_mus_ups, & ! MUSCL 157 & ln_trcadv_ubs, nn_ubs_v, & ! UBS 158 & ln_trcadv_qck ! QCK 159 !!---------------------------------------------------------------------- 160 ! 161 REWIND( numnat_ref ) ! namtrc_adv in reference namelist 158 NAMELIST/namtrc_adv/ ln_trcadv_NONE, & ! No advection 159 & ln_trcadv_cen, nn_cen_h, nn_cen_v, & ! CEN 160 & ln_trcadv_fct, nn_fct_h, nn_fct_v, & ! FCT 161 & ln_trcadv_mus, ln_mus_ups, & ! MUSCL 162 & ln_trcadv_ubs, nn_ubs_v, & ! UBS 163 & ln_trcadv_qck ! QCK 164 !!---------------------------------------------------------------------- 165 ! 166 ! !== Namelist ==! 167 REWIND( numnat_ref ) ! namtrc_adv in reference namelist 162 168 READ ( numnat_ref, namtrc_adv, IOSTAT = ios, ERR = 901) 163 169 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtrc_adv in reference namelist', lwp ) 164 165 REWIND( numnat_cfg ) ! namtrc_adv in configuration namelist170 ! 171 REWIND( numnat_cfg ) ! namtrc_adv in configuration namelist 166 172 READ ( numnat_cfg, namtrc_adv, IOSTAT = ios, ERR = 902 ) 167 173 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtrc_adv in configuration namelist', lwp ) 168 174 IF(lwm) WRITE ( numont, namtrc_adv ) 169 170 IF(lwp) THEN ! Namelist print175 ! 176 IF(lwp) THEN ! Namelist print 171 177 WRITE(numout,*) 172 178 WRITE(numout,*) 'trc_adv_ini : choice/control of the tracer advection scheme' 173 179 WRITE(numout,*) '~~~~~~~~~~~' 174 180 WRITE(numout,*) ' Namelist namtrc_adv : chose a advection scheme for tracers' 181 WRITE(numout,*) ' No advection on passive tracers ln_trcadv_NONE= ', ln_trcadv_NONE 175 182 WRITE(numout,*) ' centered scheme ln_trcadv_cen = ', ln_trcadv_cen 176 183 WRITE(numout,*) ' horizontal 2nd/4th order nn_cen_h = ', nn_fct_h … … 179 186 WRITE(numout,*) ' horizontal 2nd/4th order nn_fct_h = ', nn_fct_h 180 187 WRITE(numout,*) ' vertical 2nd/4th order nn_fct_v = ', nn_fct_v 181 WRITE(numout,*) ' 2nd order + vertical sub-timestepping nn_fct_zts = ', nn_fct_zts182 188 WRITE(numout,*) ' MUSCL scheme ln_trcadv_mus = ', ln_trcadv_mus 183 189 WRITE(numout,*) ' + upstream scheme near river mouths ln_mus_ups = ', ln_mus_ups … … 187 193 ENDIF 188 194 ! 189 190 ioptio = 0 !== Parameter control ==! 191 IF( ln_trcadv_cen ) ioptio = ioptio + 1 192 IF( ln_trcadv_fct ) ioptio = ioptio + 1 193 IF( ln_trcadv_mus ) ioptio = ioptio + 1 194 IF( ln_trcadv_ubs ) ioptio = ioptio + 1 195 IF( ln_trcadv_qck ) ioptio = ioptio + 1 196 197 ! 198 IF( ioptio == 0 ) THEN 199 nadv = np_NO_adv 200 CALL ctl_warn( 'trc_adv_init: You are running without tracer advection.' ) 201 ENDIF 202 IF( ioptio /= 1 ) CALL ctl_stop( 'Choose ONE advection scheme in namelist namtrc_adv' ) 195 ! !== Parameter control & set nadv ==! 196 ioptio = 0 197 IF( ln_trcadv_NONE ) THEN ; ioptio = ioptio + 1 ; nadv = np_NO_adv ; ENDIF 198 IF( ln_trcadv_cen ) THEN ; ioptio = ioptio + 1 ; nadv = np_CEN ; ENDIF 199 IF( ln_trcadv_fct ) THEN ; ioptio = ioptio + 1 ; nadv = np_FCT ; ENDIF 200 IF( ln_trcadv_mus ) THEN ; ioptio = ioptio + 1 ; nadv = np_MUS ; ENDIF 201 IF( ln_trcadv_ubs ) THEN ; ioptio = ioptio + 1 ; nadv = np_UBS ; ENDIF 202 IF( ln_trcadv_qck ) THEN ; ioptio = ioptio + 1 ; nadv = np_QCK ; ENDIF 203 ! 204 IF( ioptio /= 1 ) CALL ctl_stop( 'trc_adv_ini: Choose ONE advection option in namelist namtrc_adv' ) 203 205 ! 204 206 IF( ln_trcadv_cen .AND. ( nn_cen_h /= 2 .AND. nn_cen_h /= 4 ) & 205 207 .AND. ( nn_cen_v /= 2 .AND. nn_cen_v /= 4 ) ) THEN 206 CALL ctl_stop( 'trc_adv_ini t: CEN scheme, choose 2nd or 4th order' )208 CALL ctl_stop( 'trc_adv_ini: CEN scheme, choose 2nd or 4th order' ) 207 209 ENDIF 208 210 IF( ln_trcadv_fct .AND. ( nn_fct_h /= 2 .AND. nn_fct_h /= 4 ) & 209 211 .AND. ( nn_fct_v /= 2 .AND. nn_fct_v /= 4 ) ) THEN 210 CALL ctl_stop( 'trc_adv_init: FCT scheme, choose 2nd or 4th order' ) 211 ENDIF 212 IF( ln_trcadv_fct .AND. nn_fct_zts > 0 ) THEN 213 IF( nn_fct_h == 4 ) THEN 214 nn_fct_h = 2 215 CALL ctl_stop( 'trc_adv_init: force 2nd order FCT scheme, 4th order does not exist with sub-timestepping' ) 216 ENDIF 217 IF( .NOT.ln_linssh ) THEN 218 CALL ctl_stop( 'trc_adv_init: vertical sub-timestepping not allow in non-linear free surface' ) 219 ENDIF 220 IF( nn_fct_zts == 1 ) CALL ctl_warn( 'trc_adv_init: FCT with ONE sub-timestep = FCT without sub-timestep' ) 212 CALL ctl_stop( 'trc_adv_ini: FCT scheme, choose 2nd or 4th order' ) 221 213 ENDIF 222 214 IF( ln_trcadv_ubs .AND. ( nn_ubs_v /= 2 .AND. nn_ubs_v /= 4 ) ) THEN 223 CALL ctl_stop( 'trc_adv_ini t: UBS scheme, choose 2nd or 4th order' )215 CALL ctl_stop( 'trc_adv_ini: UBS scheme, choose 2nd or 4th order' ) 224 216 ENDIF 225 217 IF( ln_trcadv_ubs .AND. nn_ubs_v == 4 ) THEN 226 CALL ctl_warn( 'trc_adv_ini t: UBS scheme, only 2nd FCT scheme available on the vertical. It will be used' )218 CALL ctl_warn( 'trc_adv_ini: UBS scheme, only 2nd FCT scheme available on the vertical. It will be used' ) 227 219 ENDIF 228 220 IF( ln_isfcav ) THEN ! ice-shelf cavities 229 IF( ln_trcadv_cen .AND. nn_cen_v /= 4 .OR. & ! NO 4th order with ISF 230 & ln_trcadv_fct .AND. nn_fct_v /= 4 ) CALL ctl_stop( 'tra_adv_init: 4th order COMPACT scheme not allowed with ISF' ) 231 ENDIF 232 ! 233 ! !== used advection scheme ==! 234 ! ! set nadv 235 IF( ln_trcadv_cen ) nadv = np_CEN 236 IF( ln_trcadv_fct ) nadv = np_FCT 237 IF( ln_trcadv_fct .AND. nn_fct_zts > 0 ) nadv = np_FCT_zts 238 IF( ln_trcadv_mus ) nadv = np_MUS 239 IF( ln_trcadv_ubs ) nadv = np_UBS 240 IF( ln_trcadv_qck ) nadv = np_QCK 241 ! 242 IF(lwp) THEN ! Print the choice 221 IF( ln_trcadv_cen .AND. nn_cen_v == 4 .OR. & ! NO 4th order with ISF 222 & ln_trcadv_fct .AND. nn_fct_v == 4 ) CALL ctl_stop( 'tra_adv_ini: 4th order COMPACT scheme not allowed with ISF' ) 223 ENDIF 224 ! 225 ! !== Print the choice ==! 226 IF(lwp) THEN 243 227 WRITE(numout,*) 244 IF( nadv == np_NO_adv ) WRITE(numout,*) ' NO passive tracer advection' 245 IF( nadv == np_CEN ) WRITE(numout,*) ' CEN scheme is used. Horizontal order: ', nn_cen_h, & 246 & ' Vertical order: ', nn_cen_v 247 IF( nadv == np_FCT ) WRITE(numout,*) ' FCT scheme is used. Horizontal order: ', nn_fct_h, & 248 & ' Vertical order: ', nn_fct_v 249 IF( nadv == np_FCT_zts ) WRITE(numout,*) ' use 2nd order FCT with ', nn_fct_zts,'vertical sub-timestepping' 250 IF( nadv == np_MUS ) WRITE(numout,*) ' MUSCL scheme is used' 251 IF( nadv == np_UBS ) WRITE(numout,*) ' UBS scheme is used' 252 IF( nadv == np_QCK ) WRITE(numout,*) ' QUICKEST scheme is used' 228 SELECT CASE ( nadv ) 229 CASE( np_NO_adv ) ; WRITE(numout,*) ' ===>> NO passive tracer advection' 230 CASE( np_CEN ) ; WRITE(numout,*) ' ===>> CEN scheme is used. Horizontal order: ', nn_cen_h, & 231 & ' Vertical order: ', nn_cen_v 232 CASE( np_FCT ) ; WRITE(numout,*) ' ===>> FCT scheme is used. Horizontal order: ', nn_fct_h, & 233 & ' Vertical order: ', nn_fct_v 234 CASE( np_MUS ) ; WRITE(numout,*) ' ===>> MUSCL scheme is used' 235 CASE( np_UBS ) ; WRITE(numout,*) ' ===>> UBS scheme is used' 236 CASE( np_QCK ) ; WRITE(numout,*) ' ===>> QUICKEST scheme is used' 237 END SELECT 253 238 ENDIF 254 239 ! 255 240 END SUBROUTINE trc_adv_ini 256 241 257 #else258 !!----------------------------------------------------------------------259 !! Default option Empty module260 !!----------------------------------------------------------------------261 CONTAINS262 SUBROUTINE trc_adv( kt )263 INTEGER, INTENT(in) :: kt264 WRITE(*,*) 'trc_adv: You should not have seen this print! error?', kt265 END SUBROUTINE trc_adv266 242 #endif 267 243 -
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/TOP_SRC/TRP/trcldf.F90
r7753 r8568 17 17 USE trc ! ocean passive tracers variables 18 18 USE oce_trc ! ocean dynamics and active tracers 19 USE ldfslp ! lateral diffusion: iso-neutral slope 19 USE ldftra ! lateral diffusion: eddy diffusivity & EIV coeff. 20 USE ldfslp ! Lateral diffusion: slopes of neutral surfaces 20 21 USE traldf_lap_blp ! lateral diffusion: lap/bilaplacian iso-level operator (tra_ldf_lap/_blp routine) 21 22 USE traldf_iso ! lateral diffusion: laplacian iso-neutral standard operator (tra_ldf_iso routine) … … 32 33 PUBLIC trc_ldf_ini 33 34 ! 35 LOGICAL , PUBLIC :: ln_trcldf_NONE !: No operator (no explicit lateral diffusion) 34 36 LOGICAL , PUBLIC :: ln_trcldf_lap !: laplacian operator 35 37 LOGICAL , PUBLIC :: ln_trcldf_blp !: bilaplacian operator … … 45 47 REAL(wp) :: rldf ! ratio between active and passive tracers diffusive coefficient 46 48 47 INTEGER :: nldf = 0! type of lateral diffusion used defined from ln_trcldf_... namlist logicals)49 INTEGER :: nldf ! type of lateral diffusion used defined from ln_trcldf_... namlist logicals) 48 50 49 51 !! * Substitutions … … 98 100 CASE ( np_lap ) ! iso-level laplacian 99 101 CALL tra_ldf_lap ( kt, nittrc000,'TRC', zahu, zahv, gtru, gtrv, gtrui, gtrvi, trb, tra, jptra, 1 ) 100 !101 102 CASE ( np_lap_i ) ! laplacian : standard iso-neutral operator (Madec) 102 103 CALL tra_ldf_iso ( kt, nittrc000,'TRC', zahu, zahv, gtru, gtrv, gtrui, gtrvi, trb, trb, tra, jptra, 1 ) 103 !104 104 CASE ( np_lap_it ) ! laplacian : triad iso-neutral operator (griffies) 105 105 CALL tra_ldf_triad( kt, nittrc000,'TRC', zahu, zahv, gtru, gtrv, gtrui, gtrvi, trb, trb, tra, jptra, 1 ) 106 !107 106 CASE ( np_blp , np_blp_i , np_blp_it ) ! bilaplacian: all operator (iso-level, -neutral) 108 107 CALL tra_ldf_blp ( kt, nittrc000,'TRC', zahu, zahv, gtru, gtrv, gtrui, gtrvi, trb , tra, jptra, nldf ) 109 !110 108 END SELECT 111 109 ! … … 148 146 NAMELIST/namtrc_ldf/ ln_trcldf_lap, ln_trcldf_blp, & 149 147 & ln_trcldf_lev, ln_trcldf_hor, ln_trcldf_iso, ln_trcldf_triad, & 150 & rn_ahtrc_0 , rn_bhtrc_0 , rn_fact_lap148 & rn_ahtrc_0 , rn_bhtrc_0 , rn_fact_lap 151 149 !!---------------------------------------------------------------------- 152 150 ! … … 166 164 WRITE(numout,*) ' Namelist namtrc_ldf : set lateral mixing parameters (type, direction, coefficients)' 167 165 WRITE(numout,*) ' operator' 166 WRITE(numout,*) ' no explicit diffusion ln_trcldf_NONE = ', ln_trcldf_NONE 168 167 WRITE(numout,*) ' laplacian ln_trcldf_lap = ', ln_trcldf_lap 169 168 WRITE(numout,*) ' bilaplacian ln_trcldf_blp = ', ln_trcldf_blp … … 182 181 ! ! control the namelist parameters 183 182 ioptio = 0 184 IF( ln_trcldf_ lap ) ioptio = ioptio + 1185 IF( ln_trcldf_ blp ) ioptio = ioptio + 1186 IF( ioptio > 1 ) CALL ctl_stop( 'trc_ldf_ctl: use ONE or NONE of the 2 lap/bilap operator type on tracer' )187 IF( ioptio == 0 ) nldf = np_no_ldf ! No lateral diffusion183 IF( ln_trcldf_NONE ) THEN ; nldf = np_no_ldf ; ioptio = ioptio + 1 ; ENDIF 184 IF( ln_trcldf_lap ) THEN ; ioptio = ioptio + 1 ; ENDIF 185 IF( ln_trcldf_blp ) THEN ; ioptio = ioptio + 1 ; ENDIF 186 IF( ioptio /= 1 ) CALL ctl_stop( 'trc_ldf_ini: use ONE of the 3 operator options (NONE/lap/blp)' ) 188 187 189 IF( ln_trcldf_lap .AND. ln_trcldf_blp ) CALL ctl_stop( 'trc_ldf_ctl: bilaplacian should be used on both TRC and TRA' ) 190 IF( ln_trcldf_blp .AND. ln_trcldf_lap ) CALL ctl_stop( 'trc_ldf_ctl: laplacian should be used on both TRC and TRA' ) 191 ! 192 ioptio = 0 193 IF( ln_trcldf_lev ) ioptio = ioptio + 1 194 IF( ln_trcldf_hor ) ioptio = ioptio + 1 195 IF( ln_trcldf_iso ) ioptio = ioptio + 1 196 IF( ioptio /= 1 ) CALL ctl_stop( 'trc_ldf_ctl: use only ONE direction (level/hor/iso)' ) 197 ! 198 ! defined the type of lateral diffusion from ln_trcldf_... logicals 199 ! CAUTION : nldf = 1 is used in trazdf_imp, change it carefully 200 ierr = 0 201 IF( ln_trcldf_lap ) THEN !== laplacian operator ==! 202 IF ( ln_zco ) THEN ! z-coordinate 203 IF ( ln_trcldf_lev ) nldf = np_lap ! iso-level = horizontal (no rotation) 204 IF ( ln_trcldf_hor ) nldf = np_lap ! iso-level = horizontal (no rotation) 205 IF ( ln_trcldf_iso ) nldf = np_lap_i ! iso-neutral: standard ( rotation) 206 IF ( ln_trcldf_triad ) nldf = np_lap_it ! iso-neutral: triad ( rotation) 188 IF( ln_trcldf_lap .AND. .NOT.ln_traldf_lap ) CALL ctl_stop( 'trc_ldf_ini: laplacian should be used on both TRC and TRA' ) 189 IF( ln_trcldf_blp .AND. .NOT.ln_traldf_blp ) CALL ctl_stop( 'trc_ldf_ini: bilaplacian should be used on both TRC and TRA' ) 190 ! 191 IF( .NOT.ln_trcldf_NONE ) THEN ! direction ==>> type of operator 192 ioptio = 0 193 IF( ln_trcldf_lev ) ioptio = ioptio + 1 194 IF( ln_trcldf_hor ) ioptio = ioptio + 1 195 IF( ln_trcldf_iso ) ioptio = ioptio + 1 196 IF( ioptio /= 1 ) CALL ctl_stop( 'trc_ldf_ini: use ONE direction (level/hor/iso)' ) 197 ! 198 ! defined the type of lateral diffusion from ln_trcldf_... logicals 199 ! CAUTION : nldf = 1 is used in trazdf_imp, change it carefully 200 ierr = 0 201 IF( ln_trcldf_lap ) THEN !== laplacian operator ==! 202 IF( ln_zco ) THEN ! z-coordinate 203 IF( ln_trcldf_lev ) nldf = np_lap ! iso-level = horizontal (no rotation) 204 IF( ln_trcldf_hor ) nldf = np_lap ! iso-level = horizontal (no rotation) 205 IF( ln_trcldf_iso ) nldf = np_lap_i ! iso-neutral: standard ( rotation) 206 IF( ln_trcldf_triad ) nldf = np_lap_it ! iso-neutral: triad ( rotation) 207 ENDIF 208 IF( ln_zps ) THEN ! z-coordinate with partial step 209 IF( ln_trcldf_lev ) ierr = 1 ! iso-level not allowed 210 IF( ln_trcldf_hor ) nldf = np_lap ! horizontal (no rotation) 211 IF( ln_trcldf_iso ) nldf = np_lap_i ! iso-neutral: standard (rotation) 212 IF( ln_trcldf_triad ) nldf = np_lap_it ! iso-neutral: triad (rotation) 213 ENDIF 214 IF( ln_sco ) THEN ! s-coordinate 215 IF( ln_trcldf_lev ) nldf = np_lap ! iso-level (no rotation) 216 IF( ln_trcldf_hor ) nldf = np_lap_it ! horizontal ( rotation) !!gm a checker.... 217 IF( ln_trcldf_iso ) nldf = np_lap_i ! iso-neutral: standard (rotation) 218 IF( ln_trcldf_triad ) nldf = np_lap_it ! iso-neutral: triad (rotation) 219 ENDIF 220 ! ! diffusivity ratio: passive / active tracers 221 IF( ABS(rn_aht_0) < 2._wp*TINY(1._wp) ) THEN 222 IF( ABS(rn_ahtrc_0) < 2._wp*TINY(1._wp) ) THEN 223 rldf = 1.0_wp 224 ELSE 225 CALL ctl_stop( 'trc_ldf_ctl : cannot define rldf, rn_aht_0==0, rn_ahtrc_0 /=0' ) 226 ENDIF 227 ELSE 228 rldf = rn_ahtrc_0 / rn_aht_0 229 ENDIF 207 230 ENDIF 208 IF ( ln_zps ) THEN ! z-coordinate with partial step 209 IF ( ln_trcldf_lev ) ierr = 1 ! iso-level not allowed 210 IF ( ln_trcldf_hor ) nldf = np_lap ! horizontal (no rotation) 211 IF ( ln_trcldf_iso ) nldf = np_lap_i ! iso-neutral: standard (rotation) 212 IF ( ln_trcldf_triad ) nldf = np_lap_it ! iso-neutral: triad (rotation) 231 ! 232 IF( ln_trcldf_blp ) THEN !== bilaplacian operator ==! 233 IF ( ln_zco ) THEN ! z-coordinate 234 IF ( ln_trcldf_lev ) nldf = np_blp ! iso-level = horizontal (no rotation) 235 IF ( ln_trcldf_hor ) nldf = np_blp ! iso-level = horizontal (no rotation) 236 IF ( ln_trcldf_iso ) nldf = np_blp_i ! iso-neutral: standard (rotation) 237 IF ( ln_trcldf_triad ) nldf = np_blp_it ! iso-neutral: triad (rotation) 238 ENDIF 239 IF ( ln_zps ) THEN ! z-coordinate with partial step 240 IF ( ln_trcldf_lev ) ierr = 1 ! iso-level not allowed 241 IF ( ln_trcldf_hor ) nldf = np_blp ! horizontal (no rotation) 242 IF ( ln_trcldf_iso ) nldf = np_blp_i ! iso-neutral: standard (rotation) 243 IF ( ln_trcldf_triad ) nldf = np_blp_it ! iso-neutral: triad (rotation) 244 ENDIF 245 IF ( ln_sco ) THEN ! s-coordinate 246 IF ( ln_trcldf_lev ) nldf = np_blp ! iso-level (no rotation) 247 IF ( ln_trcldf_hor ) nldf = np_blp_it ! horizontal ( rotation) !!gm a checker.... 248 IF ( ln_trcldf_iso ) nldf = np_blp_i ! iso-neutral: standard (rotation) 249 IF ( ln_trcldf_triad ) nldf = np_blp_it ! iso-neutral: triad (rotation) 250 ENDIF 251 ! ! diffusivity ratio: passive / active tracers 252 IF( ABS(rn_bht_0) < 2._wp*TINY(1._wp) ) THEN 253 IF( ABS(rn_bhtrc_0) < 2._wp*TINY(1._wp) ) THEN 254 rldf = 1.0_wp 255 ELSE 256 CALL ctl_stop( 'trc_ldf_ctl : cannot define rldf, rn_aht_0==0, rn_ahtrc_0 /=0' ) 257 ENDIF 258 ELSE 259 rldf = SQRT( ABS( rn_bhtrc_0 / rn_bht_0 ) ) 260 ENDIF 213 261 ENDIF 214 IF ( ln_sco ) THEN ! s-coordinate 215 IF ( ln_trcldf_lev ) nldf = np_lap ! iso-level (no rotation) 216 IF ( ln_trcldf_hor ) nldf = np_lap_it ! horizontal ( rotation) !!gm a checker.... 217 IF ( ln_trcldf_iso ) nldf = np_lap_i ! iso-neutral: standard (rotation) 218 IF ( ln_trcldf_triad ) nldf = np_lap_it ! iso-neutral: triad (rotation) 219 ENDIF 220 ! ! diffusivity ratio: passive / active tracers 221 IF( ABS(rn_aht_0) < 2._wp*TINY(1._wp) ) THEN 222 IF( ABS(rn_ahtrc_0) < 2._wp*TINY(1._wp) ) THEN 223 rldf = 1.0_wp 224 ELSE 225 CALL ctl_stop( 'trc_ldf_ctl : cannot define rldf, rn_aht_0==0, rn_ahtrc_0 /=0' ) 226 ENDIF 227 ELSE 228 rldf = rn_ahtrc_0 / rn_aht_0 229 ENDIF 230 ENDIF 231 ! 232 IF( ln_trcldf_blp ) THEN !== bilaplacian operator ==! 233 IF ( ln_zco ) THEN ! z-coordinate 234 IF ( ln_trcldf_lev ) nldf = np_blp ! iso-level = horizontal (no rotation) 235 IF ( ln_trcldf_hor ) nldf = np_blp ! iso-level = horizontal (no rotation) 236 IF ( ln_trcldf_iso ) nldf = np_blp_i ! iso-neutral: standard (rotation) 237 IF ( ln_trcldf_triad ) nldf = np_blp_it ! iso-neutral: triad (rotation) 238 ENDIF 239 IF ( ln_zps ) THEN ! z-coordinate with partial step 240 IF ( ln_trcldf_lev ) ierr = 1 ! iso-level not allowed 241 IF ( ln_trcldf_hor ) nldf = np_blp ! horizontal (no rotation) 242 IF ( ln_trcldf_iso ) nldf = np_blp_i ! iso-neutral: standard (rotation) 243 IF ( ln_trcldf_triad ) nldf = np_blp_it ! iso-neutral: triad (rotation) 244 ENDIF 245 IF ( ln_sco ) THEN ! s-coordinate 246 IF ( ln_trcldf_lev ) nldf = np_blp ! iso-level (no rotation) 247 IF ( ln_trcldf_hor ) nldf = np_blp_it ! horizontal ( rotation) !!gm a checker.... 248 IF ( ln_trcldf_iso ) nldf = np_blp_i ! iso-neutral: standard (rotation) 249 IF ( ln_trcldf_triad ) nldf = np_blp_it ! iso-neutral: triad (rotation) 250 ENDIF 251 ! ! diffusivity ratio: passive / active tracers 252 IF( ABS(rn_bht_0) < 2._wp*TINY(1._wp) ) THEN 253 IF( ABS(rn_bhtrc_0) < 2._wp*TINY(1._wp) ) THEN 254 rldf = 1.0_wp 255 ELSE 256 CALL ctl_stop( 'trc_ldf_ctl : cannot define rldf, rn_aht_0==0, rn_ahtrc_0 /=0' ) 257 ENDIF 258 ELSE 259 rldf = SQRT( ABS( rn_bhtrc_0 / rn_bht_0 ) ) 260 ENDIF 261 ENDIF 262 ! 263 IF( ierr == 1 ) CALL ctl_stop( 'trc_ldf_ctl: iso-level in z-partial step, not allowed' ) 264 IF( ln_ldfeiv .AND. .NOT.ln_trcldf_iso ) CALL ctl_stop( 'trc_ldf_ctl: eiv requires isopycnal laplacian diffusion' ) 262 ! 263 IF( ierr == 1 ) CALL ctl_stop( 'trc_ldf_ini: iso-level in z-partial step, not allowed' ) 264 ENDIF 265 ! 266 IF( ln_ldfeiv .AND. .NOT.ln_trcldf_iso ) CALL ctl_stop( 'trc_ldf_ini: eiv requires isopycnal laplacian diffusion' ) 265 267 IF( nldf == 1 .OR. nldf == 3 ) l_ldfslp = .TRUE. ! slope of neutral surfaces required 266 268 ! … … 268 270 WRITE(numout,*) 269 271 SELECT CASE( nldf ) 270 CASE( np_no_ldf ) ; WRITE(numout,*) ' 271 CASE( np_lap ) ; WRITE(numout,*) ' 272 CASE( np_lap_i ) ; WRITE(numout,*) ' 273 CASE( np_lap_it ) ; WRITE(numout,*) ' 274 CASE( np_blp ) ; WRITE(numout,*) ' 275 CASE( np_blp_i ) ; WRITE(numout,*) ' 276 CASE( np_blp_it ) ; WRITE(numout,*) ' 272 CASE( np_no_ldf ) ; WRITE(numout,*) ' ===>> NO lateral diffusion' 273 CASE( np_lap ) ; WRITE(numout,*) ' ===>> laplacian iso-level operator' 274 CASE( np_lap_i ) ; WRITE(numout,*) ' ===>> Rotated laplacian operator (standard)' 275 CASE( np_lap_it ) ; WRITE(numout,*) ' ===>> Rotated laplacian operator (triad)' 276 CASE( np_blp ) ; WRITE(numout,*) ' ===>> bilaplacian iso-level operator' 277 CASE( np_blp_i ) ; WRITE(numout,*) ' ===>> Rotated bilaplacian operator (standard)' 278 CASE( np_blp_it ) ; WRITE(numout,*) ' ===>> Rotated bilaplacian operator (triad)' 277 279 END SELECT 278 280 ENDIF 279 281 ! 280 282 END SUBROUTINE trc_ldf_ini 281 #else 282 !!---------------------------------------------------------------------- 283 !! Default option Empty module 284 !!---------------------------------------------------------------------- 285 CONTAINS 286 SUBROUTINE trc_ldf( kt ) 287 INTEGER, INTENT(in) :: kt 288 WRITE(*,*) 'trc_ldf: You should not have seen this print! error?', kt 289 END SUBROUTINE trc_ldf 283 290 284 #endif 291 285 !!======================================================================
Note: See TracChangeset
for help on using the changeset viewer.