- Timestamp:
- 2015-02-11T11:50:34+01:00 (9 years ago)
- Location:
- branches/2014/dev_r4650_UKMO7_STARTHOUR/NEMOGCM/NEMO/OPA_SRC/TRA
- Files:
-
- 25 edited
-
eosbn2.F90 (modified) (11 diffs)
-
traadv.F90 (modified) (8 diffs)
-
traadv_cen2.F90 (modified) (15 diffs)
-
traadv_eiv.F90 (modified) (5 diffs)
-
traadv_mle.F90 (modified) (1 diff)
-
traadv_muscl.F90 (modified) (11 diffs)
-
traadv_muscl2.F90 (modified) (7 diffs)
-
traadv_qck.F90 (modified) (13 diffs)
-
traadv_tvd.F90 (modified) (14 diffs)
-
traadv_ubs.F90 (modified) (10 diffs)
-
trabbc.F90 (modified) (4 diffs)
-
trabbl.F90 (modified) (25 diffs)
-
tradmp.F90 (modified) (6 diffs)
-
traldf.F90 (modified) (7 diffs)
-
traldf_bilap.F90 (modified) (3 diffs)
-
traldf_iso.F90 (modified) (9 diffs)
-
traldf_iso_grif.F90 (modified) (1 diff)
-
traldf_lap.F90 (modified) (3 diffs)
-
tranpc.F90 (modified) (6 diffs)
-
tranxt.F90 (modified) (5 diffs)
-
traqsr.F90 (modified) (12 diffs)
-
trasbc.F90 (modified) (11 diffs)
-
trazdf.F90 (modified) (4 diffs)
-
trazdf_imp.F90 (modified) (4 diffs)
-
zpshde.F90 (modified) (6 diffs)
Legend:
- Unmodified
- Added
- Removed
-
branches/2014/dev_r4650_UKMO7_STARTHOUR/NEMOGCM/NEMO/OPA_SRC/TRA/eosbn2.F90
r4624 r5075 15 15 !! - ! 2002-11 (G. Madec, A. Bozec) partial step, eos_insitu_2d 16 16 !! - ! 2003-08 (G. Madec) F90, free form 17 !! 3.0 ! 2006-08 (G. Madec) add tfreez function 17 !! 3.0 ! 2006-08 (G. Madec) add tfreez function (now eos_fzp function) 18 18 !! 3.3 ! 2010-05 (C. Ethe, G. Madec) merge TRC-TRA 19 !! - ! 2010-10 (G. Nurser, G. Madec) add eos_alpbet used in ldfslp 19 !! - ! 2010-10 (G. Nurser, G. Madec) add alpha/beta used in ldfslp 20 !! 3.7 ! 2012-03 (F. Roquet, G. Madec) add primitive of alpha and beta used in PE computation 21 !! - ! 2012-05 (F. Roquet) add Vallis and original JM95 equation of state 22 !! - ! 2013-04 (F. Roquet, G. Madec) add eos_rab, change bn2 computation and reorganize the module 23 !! - ! 2014-09 (F. Roquet) add TEOS-10, S-EOS, and modify EOS-80 20 24 !!---------------------------------------------------------------------- 21 25 … … 23 27 !! eos : generic interface of the equation of state 24 28 !! eos_insitu : Compute the in situ density 25 !! eos_insitu_pot : Compute the insitu and surface referenced potential 26 !! volumic mass 29 !! eos_insitu_pot : Compute the insitu and surface referenced potential volumic mass 27 30 !! eos_insitu_2d : Compute the in situ density for 2d fields 28 !! eos_bn2 : Compute the Brunt-Vaisala frequency 29 !! eos_alpbet : calculates the in situ thermal/haline expansion ratio 30 !! tfreez : Compute the surface freezing temperature 31 !! bn2 : Compute the Brunt-Vaisala frequency 32 !! eos_rab : generic interface of in situ thermal/haline expansion ratio 33 !! eos_rab_3d : compute in situ thermal/haline expansion ratio 34 !! eos_rab_2d : compute in situ thermal/haline expansion ratio for 2d fields 35 !! eos_fzp_2d : freezing temperature for 2d fields 36 !! eos_fzp_0d : freezing temperature for scalar 31 37 !! eos_init : set eos parameters (namelist) 32 38 !!---------------------------------------------------------------------- 33 39 USE dom_oce ! ocean space and time domain 34 40 USE phycst ! physical constants 35 USE zdfddm ! vertical physics: double diffusion41 ! 36 42 USE in_out_manager ! I/O manager 37 43 USE lib_mpp ! MPP library 44 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 38 45 USE prtctl ! Print control 39 46 USE wrk_nemo ! Memory Allocation 47 USE lbclnk ! ocean lateral boundary conditions 40 48 USE timing ! Timing 41 49 … … 47 55 MODULE PROCEDURE eos_insitu, eos_insitu_pot, eos_insitu_2d 48 56 END INTERFACE 49 INTERFACE bn2 50 MODULE PROCEDURE eos_bn2 57 ! 58 INTERFACE eos_rab 59 MODULE PROCEDURE rab_3d, rab_2d, rab_0d 51 60 END INTERFACE 52 53 PUBLIC eos ! called by step, istate, tranpc and zpsgrd modules 54 PUBLIC eos_init ! called by istate module 55 PUBLIC bn2 ! called by step module 56 PUBLIC eos_alpbet ! called by ldfslp module 57 PUBLIC tfreez ! called by sbcice_... modules 58 59 ! !!* Namelist (nameos) * 60 INTEGER , PUBLIC :: nn_eos !: = 0/1/2 type of eq. of state and Brunt-Vaisala frequ. 61 REAL(wp), PUBLIC :: rn_alpha !: thermal expension coeff. (linear equation of state) 62 REAL(wp), PUBLIC :: rn_beta !: saline expension coeff. (linear equation of state) 63 64 REAL(wp), PUBLIC :: ralpbet !: alpha / beta ratio 61 ! 62 INTERFACE eos_fzp 63 MODULE PROCEDURE eos_fzp_2d, eos_fzp_0d 64 END INTERFACE 65 ! 66 PUBLIC eos ! called by step, istate, tranpc and zpsgrd modules 67 PUBLIC bn2 ! called by step module 68 PUBLIC eos_rab ! called by ldfslp, zdfddm, trabbl 69 PUBLIC eos_pt_from_ct ! called by sbcssm 70 PUBLIC eos_fzp ! called by traadv_cen2 and sbcice_... modules 71 PUBLIC eos_pen ! used for pe diagnostics in trdpen module 72 PUBLIC eos_init ! called by istate module 73 74 ! !!* Namelist (nameos) * 75 INTEGER , PUBLIC :: nn_eos = 0 !: = 0/1/2 type of eq. of state and Brunt-Vaisala frequ. 76 LOGICAL , PUBLIC :: ln_useCT = .FALSE. ! determine if eos_pt_from_ct is used to compute sst_m 77 78 ! !!! simplified eos coefficients 79 ! default value: Vallis 2006 80 REAL(wp) :: rn_a0 = 1.6550e-1_wp ! thermal expansion coeff. 81 REAL(wp) :: rn_b0 = 7.6554e-1_wp ! saline expansion coeff. 82 REAL(wp) :: rn_lambda1 = 5.9520e-2_wp ! cabbeling coeff. in T^2 83 REAL(wp) :: rn_lambda2 = 5.4914e-4_wp ! cabbeling coeff. in S^2 84 REAL(wp) :: rn_mu1 = 1.4970e-4_wp ! thermobaric coeff. in T 85 REAL(wp) :: rn_mu2 = 1.1090e-5_wp ! thermobaric coeff. in S 86 REAL(wp) :: rn_nu = 2.4341e-3_wp ! cabbeling coeff. in theta*salt 87 88 ! TEOS10/EOS80 parameters 89 REAL(wp) :: r1_S0, r1_T0, r1_Z0, rdeltaS 90 91 ! EOS parameters 92 REAL(wp) :: EOS000 , EOS100 , EOS200 , EOS300 , EOS400 , EOS500 , EOS600 93 REAL(wp) :: EOS010 , EOS110 , EOS210 , EOS310 , EOS410 , EOS510 94 REAL(wp) :: EOS020 , EOS120 , EOS220 , EOS320 , EOS420 95 REAL(wp) :: EOS030 , EOS130 , EOS230 , EOS330 96 REAL(wp) :: EOS040 , EOS140 , EOS240 97 REAL(wp) :: EOS050 , EOS150 98 REAL(wp) :: EOS060 99 REAL(wp) :: EOS001 , EOS101 , EOS201 , EOS301 , EOS401 100 REAL(wp) :: EOS011 , EOS111 , EOS211 , EOS311 101 REAL(wp) :: EOS021 , EOS121 , EOS221 102 REAL(wp) :: EOS031 , EOS131 103 REAL(wp) :: EOS041 104 REAL(wp) :: EOS002 , EOS102 , EOS202 105 REAL(wp) :: EOS012 , EOS112 106 REAL(wp) :: EOS022 107 REAL(wp) :: EOS003 , EOS103 108 REAL(wp) :: EOS013 109 110 ! ALPHA parameters 111 REAL(wp) :: ALP000 , ALP100 , ALP200 , ALP300 , ALP400 , ALP500 112 REAL(wp) :: ALP010 , ALP110 , ALP210 , ALP310 , ALP410 113 REAL(wp) :: ALP020 , ALP120 , ALP220 , ALP320 114 REAL(wp) :: ALP030 , ALP130 , ALP230 115 REAL(wp) :: ALP040 , ALP140 116 REAL(wp) :: ALP050 117 REAL(wp) :: ALP001 , ALP101 , ALP201 , ALP301 118 REAL(wp) :: ALP011 , ALP111 , ALP211 119 REAL(wp) :: ALP021 , ALP121 120 REAL(wp) :: ALP031 121 REAL(wp) :: ALP002 , ALP102 122 REAL(wp) :: ALP012 123 REAL(wp) :: ALP003 124 125 ! BETA parameters 126 REAL(wp) :: BET000 , BET100 , BET200 , BET300 , BET400 , BET500 127 REAL(wp) :: BET010 , BET110 , BET210 , BET310 , BET410 128 REAL(wp) :: BET020 , BET120 , BET220 , BET320 129 REAL(wp) :: BET030 , BET130 , BET230 130 REAL(wp) :: BET040 , BET140 131 REAL(wp) :: BET050 132 REAL(wp) :: BET001 , BET101 , BET201 , BET301 133 REAL(wp) :: BET011 , BET111 , BET211 134 REAL(wp) :: BET021 , BET121 135 REAL(wp) :: BET031 136 REAL(wp) :: BET002 , BET102 137 REAL(wp) :: BET012 138 REAL(wp) :: BET003 139 140 ! PEN parameters 141 REAL(wp) :: PEN000 , PEN100 , PEN200 , PEN300 , PEN400 142 REAL(wp) :: PEN010 , PEN110 , PEN210 , PEN310 143 REAL(wp) :: PEN020 , PEN120 , PEN220 144 REAL(wp) :: PEN030 , PEN130 145 REAL(wp) :: PEN040 146 REAL(wp) :: PEN001 , PEN101 , PEN201 147 REAL(wp) :: PEN011 , PEN111 148 REAL(wp) :: PEN021 149 REAL(wp) :: PEN002 , PEN102 150 REAL(wp) :: PEN012 151 152 ! ALPHA_PEN parameters 153 REAL(wp) :: APE000 , APE100 , APE200 , APE300 154 REAL(wp) :: APE010 , APE110 , APE210 155 REAL(wp) :: APE020 , APE120 156 REAL(wp) :: APE030 157 REAL(wp) :: APE001 , APE101 158 REAL(wp) :: APE011 159 REAL(wp) :: APE002 160 161 ! BETA_PEN parameters 162 REAL(wp) :: BPE000 , BPE100 , BPE200 , BPE300 163 REAL(wp) :: BPE010 , BPE110 , BPE210 164 REAL(wp) :: BPE020 , BPE120 165 REAL(wp) :: BPE030 166 REAL(wp) :: BPE001 , BPE101 167 REAL(wp) :: BPE011 168 REAL(wp) :: BPE002 65 169 66 170 !! * Substitutions … … 68 172 # include "vectopt_loop_substitute.h90" 69 173 !!---------------------------------------------------------------------- 70 !! NEMO/OPA 3. 3 , NEMO Consortium (2010)174 !! NEMO/OPA 3.7 , NEMO Consortium (2014) 71 175 !! $Id$ 72 176 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 82 186 !! defined through the namelist parameter nn_eos. 83 187 !! 84 !! ** Method : 3 cases: 85 !! nn_eos = 0 : Jackett and McDougall (1994) equation of state. 86 !! the in situ density is computed directly as a function of 87 !! potential temperature relative to the surface (the opa t 88 !! variable), salt and pressure (assuming no pressure variation 89 !! along geopotential surfaces, i.e. the pressure p in decibars 90 !! is approximated by the depth in meters. 91 !! prd(t,s,p) = ( rho(t,s,p) - rau0 ) / rau0 92 !! with pressure p decibars 93 !! potential temperature t deg celsius 94 !! salinity s psu 95 !! reference volumic mass rau0 kg/m**3 96 !! in situ volumic mass rho kg/m**3 97 !! in situ density anomalie prd no units 98 !! Check value: rho = 1060.93298 kg/m**3 for p=10000 dbar, 99 !! t = 40 deg celcius, s=40 psu 100 !! nn_eos = 1 : linear equation of state function of temperature only 101 !! prd(t) = 0.0285 - rn_alpha * t 102 !! nn_eos = 2 : linear equation of state function of temperature and 103 !! salinity 104 !! prd(t,s) = rn_beta * s - rn_alpha * tn - 1. 105 !! Note that no boundary condition problem occurs in this routine 106 !! as pts are defined over the whole domain. 188 !! ** Method : prd(t,s,z) = ( rho(t,s,z) - rau0 ) / rau0 189 !! with prd in situ density anomaly no units 190 !! t TEOS10: CT or EOS80: PT Celsius 191 !! s TEOS10: SA or EOS80: SP TEOS10: g/kg or EOS80: psu 192 !! z depth meters 193 !! rho in situ density kg/m^3 194 !! rau0 reference density kg/m^3 195 !! 196 !! nn_eos = -1 : polynomial TEOS-10 equation of state is used for rho(t,s,z). 197 !! Check value: rho = 1028.21993233072 kg/m^3 for z=3000 dbar, ct=3 Celcius, sa=35.5 g/kg 198 !! 199 !! nn_eos = 0 : polynomial EOS-80 equation of state is used for rho(t,s,z). 200 !! Check value: rho = 1028.35011066567 kg/m^3 for z=3000 dbar, pt=3 Celcius, sp=35.5 psu 201 !! 202 !! nn_eos = 1 : simplified equation of state 203 !! prd(t,s,z) = ( -a0*(1+lambda/2*(T-T0)+mu*z+nu*(S-S0))*(T-T0) + b0*(S-S0) ) / rau0 204 !! linear case function of T only: rn_alpha<>0, other coefficients = 0 205 !! linear eos function of T and S: rn_alpha and rn_beta<>0, other coefficients=0 206 !! Vallis like equation: use default values of coefficients 107 207 !! 108 208 !! ** Action : compute prd , the in situ density (no units) 109 209 !! 110 !! References : Jackett and McDougall, J. Atmos. Ocean. Tech., 1994 111 !!---------------------------------------------------------------------- 112 !! 113 REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pts ! 1 : potential temperature [Celcius] 114 ! ! 2 : salinity [psu] 115 REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: prd ! in situ density [-] 116 REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pdep ! depth [m] 117 !! 118 INTEGER :: ji, jj, jk ! dummy loop indices 119 REAL(wp) :: zt , zs , zh , zsr ! local scalars 120 REAL(wp) :: zr1, zr2, zr3, zr4 ! - - 121 REAL(wp) :: zrhop, ze, zbw, zb ! - - 122 REAL(wp) :: zd , zc , zaw, za ! - - 123 REAL(wp) :: zb1, za1, zkw, zk0 ! - - 124 REAL(wp), POINTER, DIMENSION(:,:,:) :: zws 125 !!---------------------------------------------------------------------- 126 127 ! 128 IF( nn_timing == 1 ) CALL timing_start('eos') 129 ! 130 CALL wrk_alloc( jpi, jpj, jpk, zws ) 210 !! References : Roquet et al, Ocean Modelling, in preparation (2014) 211 !! Vallis, Atmospheric and Oceanic Fluid Dynamics, 2006 212 !! TEOS-10 Manual, 2010 213 !!---------------------------------------------------------------------- 214 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! 1 : potential temperature [Celcius] 215 ! ! 2 : salinity [psu] 216 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT( out) :: prd ! in situ density [-] 217 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pdep ! depth [m] 218 ! 219 INTEGER :: ji, jj, jk ! dummy loop indices 220 REAL(wp) :: zt , zh , zs , ztm ! local scalars 221 REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - - 222 !!---------------------------------------------------------------------- 223 ! 224 IF( nn_timing == 1 ) CALL timing_start('eos-insitu') 131 225 ! 132 226 SELECT CASE( nn_eos ) 133 227 ! 134 CASE( 0 ) !== Jackett and McDougall (1994) formulation ==! 135 !CDIR NOVERRCHK 136 zws(:,:,:) = SQRT( ABS( pts(:,:,:,jp_sal) ) ) 228 CASE( -1, 0 ) !== polynomial TEOS-10 / EOS-80 ==! 137 229 ! 138 230 DO jk = 1, jpkm1 139 231 DO jj = 1, jpj 140 232 DO ji = 1, jpi 141 zt = pts (ji,jj,jk,jp_tem) 142 zs = pts (ji,jj,jk,jp_sal) 143 zh = pdep(ji,jj,jk) ! depth 144 zsr= zws (ji,jj,jk) ! square root salinity 145 ! 146 ! compute volumic mass pure water at atm pressure 147 zr1= ( ( ( ( 6.536332e-9_wp *zt - 1.120083e-6_wp )*zt + 1.001685e-4_wp )*zt & 148 & -9.095290e-3_wp )*zt + 6.793952e-2_wp )*zt + 999.842594_wp 149 ! seawater volumic mass atm pressure 150 zr2= ( ( ( 5.3875e-9_wp*zt-8.2467e-7_wp ) *zt+7.6438e-5_wp ) *zt & 151 & -4.0899e-3_wp ) *zt+0.824493_wp 152 zr3= ( -1.6546e-6_wp*zt+1.0227e-4_wp ) *zt-5.72466e-3_wp 153 zr4= 4.8314e-4_wp 154 ! 155 ! potential volumic mass (reference to the surface) 156 zrhop= ( zr4*zs + zr3*zsr + zr2 ) *zs + zr1 157 ! 158 ! add the compression terms 159 ze = ( -3.508914e-8_wp*zt-1.248266e-8_wp ) *zt-2.595994e-6_wp 160 zbw= ( 1.296821e-6_wp*zt-5.782165e-9_wp ) *zt+1.045941e-4_wp 161 zb = zbw + ze * zs 162 ! 163 zd = -2.042967e-2_wp 164 zc = (-7.267926e-5_wp*zt+2.598241e-3_wp ) *zt+0.1571896_wp 165 zaw= ( ( 5.939910e-6_wp*zt+2.512549e-3_wp ) *zt-0.1028859_wp ) *zt - 4.721788_wp 166 za = ( zd*zsr + zc ) *zs + zaw 167 ! 168 zb1= (-0.1909078_wp*zt+7.390729_wp ) *zt-55.87545_wp 169 za1= ( ( 2.326469e-3_wp*zt+1.553190_wp) *zt-65.00517_wp ) *zt+1044.077_wp 170 zkw= ( ( (-1.361629e-4_wp*zt-1.852732e-2_wp ) *zt-30.41638_wp ) *zt + 2098.925_wp ) *zt+190925.6_wp 171 zk0= ( zb1*zsr + za1 )*zs + zkw 172 ! 173 ! masked in situ density anomaly 174 prd(ji,jj,jk) = ( zrhop / ( 1.0_wp - zh / ( zk0 - zh * ( za - zh * zb ) ) ) & 175 & - rau0 ) * r1_rau0 * tmask(ji,jj,jk) 233 ! 234 zh = pdep(ji,jj,jk) * r1_Z0 ! depth 235 zt = pts (ji,jj,jk,jp_tem) * r1_T0 ! temperature 236 zs = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity 237 ztm = tmask(ji,jj,jk) ! tmask 238 ! 239 zn3 = EOS013*zt & 240 & + EOS103*zs+EOS003 241 ! 242 zn2 = (EOS022*zt & 243 & + EOS112*zs+EOS012)*zt & 244 & + (EOS202*zs+EOS102)*zs+EOS002 245 ! 246 zn1 = (((EOS041*zt & 247 & + EOS131*zs+EOS031)*zt & 248 & + (EOS221*zs+EOS121)*zs+EOS021)*zt & 249 & + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt & 250 & + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 251 ! 252 zn0 = (((((EOS060*zt & 253 & + EOS150*zs+EOS050)*zt & 254 & + (EOS240*zs+EOS140)*zs+EOS040)*zt & 255 & + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt & 256 & + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt & 257 & + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt & 258 & + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 259 ! 260 zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 261 ! 262 prd(ji,jj,jk) = ( zn * r1_rau0 - 1._wp ) * ztm ! density anomaly (masked) 263 ! 176 264 END DO 177 265 END DO 178 266 END DO 179 267 ! 180 CASE( 1 ) !== Linear formulation function of temperature only ==! 268 CASE( 1 ) !== simplified EOS ==! 269 ! 181 270 DO jk = 1, jpkm1 182 prd(:,:,jk) = ( 0.0285_wp - rn_alpha * pts(:,:,jk,jp_tem) ) * tmask(:,:,jk) 271 DO jj = 1, jpj 272 DO ji = 1, jpi 273 zt = pts (ji,jj,jk,jp_tem) - 10._wp 274 zs = pts (ji,jj,jk,jp_sal) - 35._wp 275 zh = pdep (ji,jj,jk) 276 ztm = tmask(ji,jj,jk) 277 ! 278 zn = - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt + rn_mu1*zh ) * zt & 279 & + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs - rn_mu2*zh ) * zs & 280 & - rn_nu * zt * zs 281 ! 282 prd(ji,jj,jk) = zn * r1_rau0 * ztm ! density anomaly (masked) 283 END DO 284 END DO 183 285 END DO 184 286 ! 185 CASE( 2 ) !== Linear formulation function of temperature and salinity ==!186 DO jk = 1, jpkm1187 prd(:,:,jk) = ( rn_beta * pts(:,:,jk,jp_sal) - rn_alpha * pts(:,:,jk,jp_tem) ) * tmask(:,:,jk)188 END DO189 !190 287 END SELECT 191 288 ! 192 IF(ln_ctl) CALL prt_ctl( tab3d_1=prd, clinfo1=' eos : ', ovlap=1, kdim=jpk ) 193 ! 194 CALL wrk_dealloc( jpi, jpj, jpk, zws ) 195 ! 196 IF( nn_timing == 1 ) CALL timing_stop('eos') 289 IF(ln_ctl) CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-insitu : ', ovlap=1, kdim=jpk ) 290 ! 291 IF( nn_timing == 1 ) CALL timing_stop('eos-insitu') 197 292 ! 198 293 END SUBROUTINE eos_insitu … … 208 303 !! namelist parameter nn_eos. 209 304 !! 210 !! ** Method :211 !! nn_eos = 0 : Jackett and McDougall (1994) equation of state.212 !! the in situ density is computed directly as a function of213 !! potential temperature relative to the surface (the opa t214 !! variable), salt and pressure (assuming no pressure variation215 !! along geopotential surfaces, i.e. the pressure p in decibars216 !! is approximated by the depth in meters.217 !! prd(t,s,p) = ( rho(t,s,p) - rau0 ) / rau0218 !! rhop(t,s) = rho(t,s,0)219 !! with pressure p decibars220 !! potential temperature t deg celsius221 !! salinity s psu222 !! reference volumic mass rau0 kg/m**3223 !! in situ volumic mass rho kg/m**3224 !! in situ density anomalie prd no units225 !!226 !! Check value: rho = 1060.93298 kg/m**3 for p=10000 dbar,227 !! t = 40 deg celcius, s=40 psu228 !!229 !! nn_eos = 1 : linear equation of state function of temperature only230 !! prd(t) = ( rho(t) - rau0 ) / rau0 = 0.028 - rn_alpha * t231 !! rhop(t,s) = rho(t,s)232 !!233 !! nn_eos = 2 : linear equation of state function of temperature and234 !! salinity235 !! prd(t,s) = ( rho(t,s) - rau0 ) / rau0236 !! = rn_beta * s - rn_alpha * tn - 1.237 !! rhop(t,s) = rho(t,s)238 !! Note that no boundary condition problem occurs in this routine239 !! as (tn,sn) or (ta,sa) are defined over the whole domain.240 !!241 305 !! ** Action : - prd , the in situ density (no units) 242 306 !! - prhop, the potential volumic mass (Kg/m3) 243 307 !! 244 !! References : Jackett and McDougall, J. Atmos. Ocean. Tech., 1994 245 !! Brown and Campana, Mon. Weather Rev., 1978 246 !!---------------------------------------------------------------------- 247 !! 308 !!---------------------------------------------------------------------- 248 309 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! 1 : potential temperature [Celcius] 249 310 ! ! 2 : salinity [psu] … … 252 313 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pdep ! depth [m] 253 314 ! 254 INTEGER :: ji, jj, jk ! dummy loop indices 255 REAL(wp) :: zt, zs, zh, zsr, zr1, zr2, zr3, zr4, zrhop, ze, zbw ! local scalars 256 REAL(wp) :: zb, zd, zc, zaw, za, zb1, za1, zkw, zk0 ! - - 257 REAL(wp), POINTER, DIMENSION(:,:,:) :: zws 258 !!---------------------------------------------------------------------- 259 ! 260 IF( nn_timing == 1 ) CALL timing_start('eos-p') 261 ! 262 CALL wrk_alloc( jpi, jpj, jpk, zws ) 315 INTEGER :: ji, jj, jk ! dummy loop indices 316 REAL(wp) :: zt , zh , zs , ztm ! local scalars 317 REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - - 318 !!---------------------------------------------------------------------- 319 ! 320 IF( nn_timing == 1 ) CALL timing_start('eos-pot') 263 321 ! 264 322 SELECT CASE ( nn_eos ) 265 323 ! 266 CASE( 0 ) !== Jackett and McDougall (1994) formulation ==! 267 !CDIR NOVERRCHK 268 zws(:,:,:) = SQRT( ABS( pts(:,:,:,jp_sal) ) ) 324 CASE( -1, 0 ) !== polynomial TEOS-10 / EOS-80 ==! 269 325 ! 270 326 DO jk = 1, jpkm1 271 327 DO jj = 1, jpj 272 328 DO ji = 1, jpi 273 zt = pts (ji,jj,jk,jp_tem) 274 zs = pts (ji,jj,jk,jp_sal) 275 zh = pdep(ji,jj,jk) ! depth 276 zsr= zws (ji,jj,jk) ! square root salinity 277 ! 278 ! compute volumic mass pure water at atm pressure 279 zr1= ( ( ( ( 6.536332e-9_wp*zt-1.120083e-6_wp )*zt+1.001685e-4_wp )*zt & 280 & -9.095290e-3_wp )*zt+6.793952e-2_wp )*zt+999.842594_wp 281 ! seawater volumic mass atm pressure 282 zr2= ( ( ( 5.3875e-9_wp*zt-8.2467e-7_wp ) *zt+7.6438e-5_wp ) *zt & 283 & -4.0899e-3_wp ) *zt+0.824493_wp 284 zr3= ( -1.6546e-6_wp*zt+1.0227e-4_wp ) *zt-5.72466e-3_wp 285 zr4= 4.8314e-4_wp 286 ! 287 ! potential volumic mass (reference to the surface) 288 zrhop= ( zr4*zs + zr3*zsr + zr2 ) *zs + zr1 289 ! 290 ! save potential volumic mass 291 prhop(ji,jj,jk) = zrhop * tmask(ji,jj,jk) 292 ! 293 ! add the compression terms 294 ze = ( -3.508914e-8_wp*zt-1.248266e-8_wp ) *zt-2.595994e-6_wp 295 zbw= ( 1.296821e-6_wp*zt-5.782165e-9_wp ) *zt+1.045941e-4_wp 296 zb = zbw + ze * zs 297 ! 298 zd = -2.042967e-2_wp 299 zc = (-7.267926e-5_wp*zt+2.598241e-3_wp ) *zt+0.1571896_wp 300 zaw= ( ( 5.939910e-6_wp*zt+2.512549e-3_wp ) *zt-0.1028859_wp ) *zt - 4.721788_wp 301 za = ( zd*zsr + zc ) *zs + zaw 302 ! 303 zb1= ( -0.1909078_wp *zt+7.390729_wp ) *zt-55.87545_wp 304 za1= ( ( 2.326469e-3_wp*zt+1.553190_wp ) *zt-65.00517_wp ) *zt + 1044.077_wp 305 zkw= ( ( (-1.361629e-4_wp*zt-1.852732e-2_wp ) *zt-30.41638_wp ) *zt + 2098.925_wp ) *zt+190925.6_wp 306 zk0= ( zb1*zsr + za1 )*zs + zkw 307 ! 308 ! masked in situ density anomaly 309 prd(ji,jj,jk) = ( zrhop / ( 1.0_wp - zh / ( zk0 - zh * ( za - zh * zb ) ) ) & 310 & - rau0 ) * r1_rau0 * tmask(ji,jj,jk) 329 ! 330 zh = pdep(ji,jj,jk) * r1_Z0 ! depth 331 zt = pts (ji,jj,jk,jp_tem) * r1_T0 ! temperature 332 zs = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity 333 ztm = tmask(ji,jj,jk) ! tmask 334 ! 335 zn3 = EOS013*zt & 336 & + EOS103*zs+EOS003 337 ! 338 zn2 = (EOS022*zt & 339 & + EOS112*zs+EOS012)*zt & 340 & + (EOS202*zs+EOS102)*zs+EOS002 341 ! 342 zn1 = (((EOS041*zt & 343 & + EOS131*zs+EOS031)*zt & 344 & + (EOS221*zs+EOS121)*zs+EOS021)*zt & 345 & + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt & 346 & + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 347 ! 348 zn0 = (((((EOS060*zt & 349 & + EOS150*zs+EOS050)*zt & 350 & + (EOS240*zs+EOS140)*zs+EOS040)*zt & 351 & + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt & 352 & + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt & 353 & + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt & 354 & + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 355 ! 356 zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 357 ! 358 prhop(ji,jj,jk) = zn0 * ztm ! potential density referenced at the surface 359 ! 360 prd(ji,jj,jk) = ( zn * r1_rau0 - 1._wp ) * ztm ! density anomaly (masked) 311 361 END DO 312 362 END DO 313 363 END DO 314 364 ! 315 CASE( 1 ) !== Linear formulation = F( temperature ) ==! 365 CASE( 1 ) !== simplified EOS ==! 366 ! 316 367 DO jk = 1, jpkm1 317 prd (:,:,jk) = ( 0.0285_wp - rn_alpha * pts(:,:,jk,jp_tem) ) * tmask(:,:,jk) 318 prhop(:,:,jk) = ( 1.e0_wp + prd (:,:,jk) ) * rau0 * tmask(:,:,jk) 368 DO jj = 1, jpj 369 DO ji = 1, jpi 370 zt = pts (ji,jj,jk,jp_tem) - 10._wp 371 zs = pts (ji,jj,jk,jp_sal) - 35._wp 372 zh = pdep (ji,jj,jk) 373 ztm = tmask(ji,jj,jk) 374 ! ! potential density referenced at the surface 375 zn = - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt ) * zt & 376 & + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs ) * zs & 377 & - rn_nu * zt * zs 378 prhop(ji,jj,jk) = ( rau0 + zn ) * ztm 379 ! ! density anomaly (masked) 380 zn = zn - ( rn_a0 * rn_mu1 * zt + rn_b0 * rn_mu2 * zs ) * zh 381 prd(ji,jj,jk) = zn * r1_rau0 * ztm 382 ! 383 END DO 384 END DO 319 385 END DO 320 386 ! 321 CASE( 2 ) !== Linear formulation = F( temperature , salinity ) ==!322 DO jk = 1, jpkm1323 prd (:,:,jk) = ( rn_beta * pts(:,:,jk,jp_sal) - rn_alpha * pts(:,:,jk,jp_tem) ) * tmask(:,:,jk)324 prhop(:,:,jk) = ( 1.e0_wp + prd (:,:,jk) ) * rau0 * tmask(:,:,jk)325 END DO326 !327 387 END SELECT 328 388 ! 329 IF(ln_ctl) CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-p: ', tab3d_2=prhop, clinfo2=' pot : ', ovlap=1, kdim=jpk ) 330 ! 331 CALL wrk_dealloc( jpi, jpj, jpk, zws ) 332 ! 333 IF( nn_timing == 1 ) CALL timing_stop('eos-p') 389 IF(ln_ctl) CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-pot: ', tab3d_2=prhop, clinfo2=' pot : ', ovlap=1, kdim=jpk ) 390 ! 391 IF( nn_timing == 1 ) CALL timing_stop('eos-pot') 334 392 ! 335 393 END SUBROUTINE eos_insitu_pot … … 344 402 !! defined through the namelist parameter nn_eos. * 2D field case 345 403 !! 346 !! ** Method : 347 !! nn_eos = 0 : Jackett and McDougall (1994) equation of state. 348 !! the in situ density is computed directly as a function of 349 !! potential temperature relative to the surface (the opa t 350 !! variable), salt and pressure (assuming no pressure variation 351 !! along geopotential surfaces, i.e. the pressure p in decibars 352 !! is approximated by the depth in meters. 353 !! prd(t,s,p) = ( rho(t,s,p) - rau0 ) / rau0 354 !! with pressure p decibars 355 !! potential temperature t deg celsius 356 !! salinity s psu 357 !! reference volumic mass rau0 kg/m**3 358 !! in situ volumic mass rho kg/m**3 359 !! in situ density anomalie prd no units 360 !! Check value: rho = 1060.93298 kg/m**3 for p=10000 dbar, 361 !! t = 40 deg celcius, s=40 psu 362 !! nn_eos = 1 : linear equation of state function of temperature only 363 !! prd(t) = 0.0285 - rn_alpha * t 364 !! nn_eos = 2 : linear equation of state function of temperature and 365 !! salinity 366 !! prd(t,s) = rn_beta * s - rn_alpha * tn - 1. 367 !! Note that no boundary condition problem occurs in this routine 368 !! as pts are defined over the whole domain. 369 !! 370 !! ** Action : - prd , the in situ density (no units) 371 !! 372 !! References : Jackett and McDougall, J. Atmos. Ocean. Tech., 1994 373 !!---------------------------------------------------------------------- 374 !! 404 !! ** Action : - prd , the in situ density (no units) (unmasked) 405 !! 406 !!---------------------------------------------------------------------- 375 407 REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT(in ) :: pts ! 1 : potential temperature [Celcius] 376 408 ! ! 2 : salinity [psu] 377 REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: pdep ! depth [m]409 REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: pdep ! depth [m] 378 410 REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: prd ! in situ density 379 !! 380 INTEGER :: ji, jj ! dummy loop indices 381 REAL(wp) :: zt, zs, zh, zsr, zr1, zr2, zr3, zr4, zrhop, ze, zbw ! temporary scalars 382 REAL(wp) :: zb, zd, zc, zaw, za, zb1, za1, zkw, zk0, zmask ! - - 383 REAL(wp), POINTER, DIMENSION(:,:) :: zws 384 !!---------------------------------------------------------------------- 385 ! 386 IF( nn_timing == 1 ) CALL timing_start('eos2d') 387 ! 388 CALL wrk_alloc( jpi, jpj, zws ) 389 ! 390 411 ! 412 INTEGER :: ji, jj, jk ! dummy loop indices 413 REAL(wp) :: zt , zh , zs ! local scalars 414 REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - - 415 !!---------------------------------------------------------------------- 416 ! 417 IF( nn_timing == 1 ) CALL timing_start('eos2d') 418 ! 391 419 prd(:,:) = 0._wp 392 420 ! 393 421 SELECT CASE( nn_eos ) 394 422 ! 395 CASE( 0 ) !== Jackett and McDougall (1994) formulation ==! 396 ! 397 !CDIR NOVERRCHK 423 CASE( -1, 0 ) !== polynomial TEOS-10 / EOS-80 ==! 424 ! 398 425 DO jj = 1, jpjm1 399 !CDIR NOVERRCHK400 426 DO ji = 1, fs_jpim1 ! vector opt. 401 zws(ji,jj) = SQRT( ABS( pts(ji,jj,jp_sal) ) ) 427 ! 428 zh = pdep(ji,jj) * r1_Z0 ! depth 429 zt = pts (ji,jj,jp_tem) * r1_T0 ! temperature 430 zs = SQRT( ABS( pts(ji,jj,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity 431 ! 432 zn3 = EOS013*zt & 433 & + EOS103*zs+EOS003 434 ! 435 zn2 = (EOS022*zt & 436 & + EOS112*zs+EOS012)*zt & 437 & + (EOS202*zs+EOS102)*zs+EOS002 438 ! 439 zn1 = (((EOS041*zt & 440 & + EOS131*zs+EOS031)*zt & 441 & + (EOS221*zs+EOS121)*zs+EOS021)*zt & 442 & + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt & 443 & + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 444 ! 445 zn0 = (((((EOS060*zt & 446 & + EOS150*zs+EOS050)*zt & 447 & + (EOS240*zs+EOS140)*zs+EOS040)*zt & 448 & + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt & 449 & + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt & 450 & + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt & 451 & + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 452 ! 453 zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 454 ! 455 prd(ji,jj) = zn * r1_rau0 - 1._wp ! unmasked in situ density anomaly 456 ! 402 457 END DO 403 458 END DO 459 ! 460 CALL lbc_lnk( prd, 'T', 1. ) ! Lateral boundary conditions 461 ! 462 CASE( 1 ) !== simplified EOS ==! 463 ! 404 464 DO jj = 1, jpjm1 405 465 DO ji = 1, fs_jpim1 ! vector opt. 406 zmask = tmask(ji,jj,1) ! land/sea bottom mask = surf. mask 407 zt = pts (ji,jj,jp_tem) ! interpolated T 408 zs = pts (ji,jj,jp_sal) ! interpolated S 409 zsr = zws (ji,jj) ! square root of interpolated S 410 zh = pdep (ji,jj) ! depth at the partial step level 411 ! 412 ! compute volumic mass pure water at atm pressure 413 zr1 = ( ( ( ( 6.536332e-9_wp*zt-1.120083e-6_wp )*zt+1.001685e-4_wp )*zt & 414 & -9.095290e-3_wp )*zt+6.793952e-2_wp )*zt+999.842594_wp 415 ! seawater volumic mass atm pressure 416 zr2 = ( ( ( 5.3875e-9_wp*zt-8.2467e-7_wp )*zt+7.6438e-5_wp ) *zt & 417 & -4.0899e-3_wp ) *zt+0.824493_wp 418 zr3 = ( -1.6546e-6_wp*zt+1.0227e-4_wp ) *zt-5.72466e-3_wp 419 zr4 = 4.8314e-4_wp 420 ! 421 ! potential volumic mass (reference to the surface) 422 zrhop= ( zr4*zs + zr3*zsr + zr2 ) *zs + zr1 423 ! 424 ! add the compression terms 425 ze = ( -3.508914e-8_wp*zt-1.248266e-8_wp ) *zt-2.595994e-6_wp 426 zbw= ( 1.296821e-6_wp*zt-5.782165e-9_wp ) *zt+1.045941e-4_wp 427 zb = zbw + ze * zs 428 ! 429 zd = -2.042967e-2_wp 430 zc = (-7.267926e-5_wp*zt+2.598241e-3_wp ) *zt+0.1571896_wp 431 zaw= ( ( 5.939910e-6_wp*zt+2.512549e-3_wp ) *zt-0.1028859_wp ) *zt -4.721788_wp 432 za = ( zd*zsr + zc ) *zs + zaw 433 ! 434 zb1= (-0.1909078_wp *zt+7.390729_wp ) *zt-55.87545_wp 435 za1= ( ( 2.326469e-3_wp*zt+1.553190_wp ) *zt-65.00517_wp ) *zt+1044.077_wp 436 zkw= ( ( (-1.361629e-4_wp*zt-1.852732e-2_wp ) *zt-30.41638_wp ) *zt & 437 & +2098.925_wp ) *zt+190925.6_wp 438 zk0= ( zb1*zsr + za1 )*zs + zkw 439 ! 440 ! masked in situ density anomaly 441 prd(ji,jj) = ( zrhop / ( 1.0_wp - zh / ( zk0 - zh * ( za - zh * zb ) ) ) - rau0 ) / rau0 * zmask 466 ! 467 zt = pts (ji,jj,jp_tem) - 10._wp 468 zs = pts (ji,jj,jp_sal) - 35._wp 469 zh = pdep (ji,jj) ! depth at the partial step level 470 ! 471 zn = - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt + rn_mu1*zh ) * zt & 472 & + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs - rn_mu2*zh ) * zs & 473 & - rn_nu * zt * zs 474 ! 475 prd(ji,jj) = zn * r1_rau0 ! unmasked in situ density anomaly 476 ! 442 477 END DO 443 478 END DO 444 479 ! 445 CASE( 1 ) !== Linear formulation = F( temperature ) ==! 446 DO jj = 1, jpjm1 447 DO ji = 1, fs_jpim1 ! vector opt. 448 prd(ji,jj) = ( 0.0285_wp - rn_alpha * pts(ji,jj,jp_tem) ) * tmask(ji,jj,1) 449 END DO 450 END DO 451 ! 452 CASE( 2 ) !== Linear formulation = F( temperature , salinity ) ==! 453 DO jj = 1, jpjm1 454 DO ji = 1, fs_jpim1 ! vector opt. 455 prd(ji,jj) = ( rn_beta * pts(ji,jj,jp_sal) - rn_alpha * pts(ji,jj,jp_tem) ) * tmask(ji,jj,1) 456 END DO 457 END DO 480 CALL lbc_lnk( prd, 'T', 1. ) ! Lateral boundary conditions 458 481 ! 459 482 END SELECT 460 483 ! 461 484 IF(ln_ctl) CALL prt_ctl( tab2d_1=prd, clinfo1=' eos2d: ' ) 462 485 ! 463 CALL wrk_dealloc( jpi, jpj, zws ) 464 ! 465 IF( nn_timing == 1 ) CALL timing_stop('eos2d') 486 IF( nn_timing == 1 ) CALL timing_stop('eos2d') 466 487 ! 467 488 END SUBROUTINE eos_insitu_2d 468 489 469 490 470 SUBROUTINE eos_bn2( pts, pn2 ) 471 !!---------------------------------------------------------------------- 472 !! *** ROUTINE eos_bn2 *** 473 !! 474 !! ** Purpose : Compute the local Brunt-Vaisala frequency at the time- 475 !! step of the input arguments 476 !! 477 !! ** Method : 478 !! * nn_eos = 0 : UNESCO sea water properties 479 !! The brunt-vaisala frequency is computed using the polynomial 480 !! polynomial expression of McDougall (1987): 481 !! N^2 = grav * beta * ( alpha/beta*dk[ t ] - dk[ s ] )/e3w 482 !! If lk_zdfddm=T, the heat/salt buoyancy flux ratio Rrau is 483 !! computed and used in zdfddm module : 484 !! Rrau = alpha/beta * ( dk[ t ] / dk[ s ] ) 485 !! * nn_eos = 1 : linear equation of state (temperature only) 486 !! N^2 = grav * rn_alpha * dk[ t ]/e3w 487 !! * nn_eos = 2 : linear equation of state (temperature & salinity) 488 !! N^2 = grav * (rn_alpha * dk[ t ] - rn_beta * dk[ s ] ) / e3w 489 !! The use of potential density to compute N^2 introduces e r r o r 490 !! in the sign of N^2 at great depths. We recommand the use of 491 !! nn_eos = 0, except for academical studies. 492 !! Macro-tasked on horizontal slab (jk-loop) 493 !! N.B. N^2 is set to zero at the first level (JK=1) in inidtr 494 !! and is never used at this level. 495 !! 496 !! ** Action : - pn2 : the brunt-vaisala frequency 497 !! 498 !! References : McDougall, J. Phys. Oceanogr., 17, 1950-1964, 1987. 499 !!---------------------------------------------------------------------- 500 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! 1 : potential temperature [Celcius] 501 ! ! 2 : salinity [psu] 502 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pn2 ! Brunt-Vaisala frequency [s-1] 503 !! 504 INTEGER :: ji, jj, jk ! dummy loop indices 505 REAL(wp) :: zgde3w, zt, zs, zh, zalbet, zbeta ! local scalars 506 #if defined key_zdfddm 507 REAL(wp) :: zds ! local scalars 508 #endif 509 !!---------------------------------------------------------------------- 510 511 ! 512 IF( nn_timing == 1 ) CALL timing_start('bn2') 513 ! 514 ! pn2 : interior points only (2=< jk =< jpkm1 ) 515 ! -------------------------- 516 ! 517 SELECT CASE( nn_eos ) 518 ! 519 CASE( 0 ) !== Jackett and McDougall (1994) formulation ==! 520 DO jk = 2, jpkm1 491 SUBROUTINE rab_3d( pts, pab ) 492 !!---------------------------------------------------------------------- 493 !! *** ROUTINE rab_3d *** 494 !! 495 !! ** Purpose : Calculates thermal/haline expansion ratio at T-points 496 !! 497 !! ** Method : calculates alpha / beta at T-points 498 !! 499 !! ** Action : - pab : thermal/haline expansion ratio at T-points 500 !!---------------------------------------------------------------------- 501 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! pot. temperature & salinity 502 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT( out) :: pab ! thermal/haline expansion ratio 503 ! 504 INTEGER :: ji, jj, jk ! dummy loop indices 505 REAL(wp) :: zt , zh , zs , ztm ! local scalars 506 REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - - 507 !!---------------------------------------------------------------------- 508 ! 509 IF( nn_timing == 1 ) CALL timing_start('rab_3d') 510 ! 511 SELECT CASE ( nn_eos ) 512 ! 513 CASE( -1, 0 ) !== polynomial TEOS-10 / EOS-80 ==! 514 ! 515 DO jk = 1, jpkm1 521 516 DO jj = 1, jpj 522 517 DO ji = 1, jpi 523 zgde3w = grav / fse3w(ji,jj,jk) 524 zt = 0.5 * ( pts(ji,jj,jk,jp_tem) + pts(ji,jj,jk-1,jp_tem) ) ! potential temperature at w-pt 525 zs = 0.5 * ( pts(ji,jj,jk,jp_sal) + pts(ji,jj,jk-1,jp_sal) ) - 35.0 ! salinity anomaly (s-35) at w-pt 526 zh = fsdepw(ji,jj,jk) ! depth in meters at w-point 527 ! 528 zalbet = ( ( ( - 0.255019e-07_wp * zt + 0.298357e-05_wp ) * zt & ! ratio alpha/beta 529 & - 0.203814e-03_wp ) * zt & 530 & + 0.170907e-01_wp ) * zt & 531 & + 0.665157e-01_wp & 532 & + ( - 0.678662e-05_wp * zs & 533 & - 0.846960e-04_wp * zt + 0.378110e-02_wp ) * zs & 534 & + ( ( - 0.302285e-13_wp * zh & 535 & - 0.251520e-11_wp * zs & 536 & + 0.512857e-12_wp * zt * zt ) * zh & 537 & - 0.164759e-06_wp * zs & 538 & +( 0.791325e-08_wp * zt - 0.933746e-06_wp ) * zt & 539 & + 0.380374e-04_wp ) * zh 540 ! 541 zbeta = ( ( -0.415613e-09_wp * zt + 0.555579e-07_wp ) * zt & ! beta 542 & - 0.301985e-05_wp ) * zt & 543 & + 0.785567e-03_wp & 544 & + ( 0.515032e-08_wp * zs & 545 & + 0.788212e-08_wp * zt - 0.356603e-06_wp ) * zs & 546 & + ( ( 0.121551e-17_wp * zh & 547 & - 0.602281e-15_wp * zs & 548 & - 0.175379e-14_wp * zt + 0.176621e-12_wp ) * zh & 549 & + 0.408195e-10_wp * zs & 550 & + ( - 0.213127e-11_wp * zt + 0.192867e-09_wp ) * zt & 551 & - 0.121555e-07_wp ) * zh 552 ! 553 pn2(ji,jj,jk) = zgde3w * zbeta * tmask(ji,jj,jk) & ! N^2 554 & * ( zalbet * ( pts(ji,jj,jk-1,jp_tem) - pts(ji,jj,jk,jp_tem) ) & 555 & - ( pts(ji,jj,jk-1,jp_sal) - pts(ji,jj,jk,jp_sal) ) ) 556 #if defined key_zdfddm 557 ! !!bug **** caution a traiter zds=dk[S]= 0 !!!! 558 zds = ( pts(ji,jj,jk-1,jp_sal) - pts(ji,jj,jk,jp_sal) ) ! Rrau = (alpha / beta) (dk[t] / dk[s]) 559 IF ( ABS( zds) <= 1.e-20_wp ) zds = 1.e-20_wp 560 rrau(ji,jj,jk) = zalbet * ( pts(ji,jj,jk-1,jp_tem) - pts(ji,jj,jk,jp_tem) ) / zds 561 #endif 518 ! 519 zh = fsdept(ji,jj,jk) * r1_Z0 ! depth 520 zt = pts (ji,jj,jk,jp_tem) * r1_T0 ! temperature 521 zs = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity 522 ztm = tmask(ji,jj,jk) ! tmask 523 ! 524 ! alpha 525 zn3 = ALP003 526 ! 527 zn2 = ALP012*zt + ALP102*zs+ALP002 528 ! 529 zn1 = ((ALP031*zt & 530 & + ALP121*zs+ALP021)*zt & 531 & + (ALP211*zs+ALP111)*zs+ALP011)*zt & 532 & + ((ALP301*zs+ALP201)*zs+ALP101)*zs+ALP001 533 ! 534 zn0 = ((((ALP050*zt & 535 & + ALP140*zs+ALP040)*zt & 536 & + (ALP230*zs+ALP130)*zs+ALP030)*zt & 537 & + ((ALP320*zs+ALP220)*zs+ALP120)*zs+ALP020)*zt & 538 & + (((ALP410*zs+ALP310)*zs+ALP210)*zs+ALP110)*zs+ALP010)*zt & 539 & + ((((ALP500*zs+ALP400)*zs+ALP300)*zs+ALP200)*zs+ALP100)*zs+ALP000 540 ! 541 zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 542 ! 543 pab(ji,jj,jk,jp_tem) = zn * r1_rau0 * ztm 544 ! 545 ! beta 546 zn3 = BET003 547 ! 548 zn2 = BET012*zt + BET102*zs+BET002 549 ! 550 zn1 = ((BET031*zt & 551 & + BET121*zs+BET021)*zt & 552 & + (BET211*zs+BET111)*zs+BET011)*zt & 553 & + ((BET301*zs+BET201)*zs+BET101)*zs+BET001 554 ! 555 zn0 = ((((BET050*zt & 556 & + BET140*zs+BET040)*zt & 557 & + (BET230*zs+BET130)*zs+BET030)*zt & 558 & + ((BET320*zs+BET220)*zs+BET120)*zs+BET020)*zt & 559 & + (((BET410*zs+BET310)*zs+BET210)*zs+BET110)*zs+BET010)*zt & 560 & + ((((BET500*zs+BET400)*zs+BET300)*zs+BET200)*zs+BET100)*zs+BET000 561 ! 562 zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 563 ! 564 pab(ji,jj,jk,jp_sal) = zn / zs * r1_rau0 * ztm 565 ! 562 566 END DO 563 567 END DO 564 568 END DO 565 569 ! 566 CASE( 1 ) !== Linear formulation = F( temperature ) ==! 567 DO jk = 2, jpkm1 568 pn2(:,:,jk) = grav * rn_alpha * ( pts(:,:,jk-1,jp_tem) - pts(:,:,jk,jp_tem) ) / fse3w(:,:,jk) * tmask(:,:,jk) 569 END DO 570 ! 571 CASE( 2 ) !== Linear formulation = F( temperature , salinity ) ==! 572 DO jk = 2, jpkm1 573 pn2(:,:,jk) = grav * ( rn_alpha * ( pts(:,:,jk-1,jp_tem) - pts(:,:,jk,jp_tem) ) & 574 & - rn_beta * ( pts(:,:,jk-1,jp_sal) - pts(:,:,jk,jp_sal) ) ) & 575 & / fse3w(:,:,jk) * tmask(:,:,jk) 576 END DO 577 #if defined key_zdfddm 578 DO jk = 2, jpkm1 ! Rrau = (alpha / beta) (dk[t] / dk[s]) 570 CASE( 1 ) !== simplified EOS ==! 571 ! 572 DO jk = 1, jpkm1 579 573 DO jj = 1, jpj 580 574 DO ji = 1, jpi 581 zds = ( pts(ji,jj,jk-1,jp_sal) - pts(ji,jj,jk,jp_sal) ) 582 IF ( ABS( zds ) <= 1.e-20_wp ) zds = 1.e-20_wp 583 rrau(ji,jj,jk) = ralpbet * ( pts(ji,jj,jk-1,jp_tem) - pts(ji,jj,jk,jp_tem) ) / zds 575 zt = pts (ji,jj,jk,jp_tem) - 10._wp ! pot. temperature anomaly (t-T0) 576 zs = pts (ji,jj,jk,jp_sal) - 35._wp ! abs. salinity anomaly (s-S0) 577 zh = fsdept(ji,jj,jk) ! depth in meters at t-point 578 ztm = tmask(ji,jj,jk) ! land/sea bottom mask = surf. mask 579 ! 580 zn = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs 581 pab(ji,jj,jk,jp_tem) = zn * r1_rau0 * ztm ! alpha 582 ! 583 zn = rn_b0 * ( 1._wp - rn_lambda2*zs - rn_mu2*zh ) - rn_nu*zt 584 pab(ji,jj,jk,jp_sal) = zn * r1_rau0 * ztm ! beta 585 ! 584 586 END DO 585 587 END DO 586 588 END DO 587 #endif588 END SELECT589 590 IF(ln_ctl) CALL prt_ctl( tab3d_1=pn2, clinfo1=' bn2 : ', ovlap=1, kdim=jpk )591 #if defined key_zdfddm592 IF(ln_ctl) CALL prt_ctl( tab3d_1=rrau, clinfo1=' rrau : ', ovlap=1, kdim=jpk )593 #endif594 !595 IF( nn_timing == 1 ) CALL timing_stop('bn2')596 !597 END SUBROUTINE eos_bn2598 599 600 SUBROUTINE eos_alpbet( pts, palpbet, beta0 )601 !!----------------------------------------------------------------------602 !! *** ROUTINE eos_alpbet ***603 !!604 !! ** Purpose : Calculates the in situ thermal/haline expansion ratio at T-points605 !!606 !! ** Method : calculates alpha / beta ratio at T-points607 !! * nn_eos = 0 : UNESCO sea water properties608 !! The alpha/beta ratio is returned as 3-D array palpbet using the polynomial609 !! polynomial expression of McDougall (1987).610 !! Scalar beta0 is returned = 1.611 !! * nn_eos = 1 : linear equation of state (temperature only)612 !! The ratio is undefined, so we return alpha as palpbet613 !! Scalar beta0 is returned = 0.614 !! * nn_eos = 2 : linear equation of state (temperature & salinity)615 !! The alpha/beta ratio is returned as ralpbet616 !! Scalar beta0 is returned = 1.617 !!618 !! ** Action : - palpbet : thermal/haline expansion ratio at T-points619 !! : beta0 : 1. or 0.620 !!----------------------------------------------------------------------621 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! pot. temperature & salinity622 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: palpbet ! thermal/haline expansion ratio623 REAL(wp), INTENT( out) :: beta0 ! set = 1 except with case 1 eos, rho=rho(T)624 !!625 INTEGER :: ji, jj, jk ! dummy loop indices626 REAL(wp) :: zt, zs, zh ! local scalars627 !!----------------------------------------------------------------------628 !629 IF( nn_timing == 1 ) CALL timing_start('eos_alpbet')630 !631 SELECT CASE ( nn_eos )632 !633 CASE ( 0 ) ! Jackett and McDougall (1994) formulation634 DO jk = 1, jpk635 DO jj = 1, jpj636 DO ji = 1, jpi637 zt = pts(ji,jj,jk,jp_tem) ! potential temperature638 zs = pts(ji,jj,jk,jp_sal) - 35._wp ! salinity anomaly (s-35)639 zh = fsdept(ji,jj,jk) ! depth in meters640 !641 palpbet(ji,jj,jk) = &642 & ( ( ( - 0.255019e-07_wp * zt + 0.298357e-05_wp ) * zt &643 & - 0.203814e-03_wp ) * zt &644 & + 0.170907e-01_wp ) * zt &645 & + 0.665157e-01_wp &646 & + ( - 0.678662e-05_wp * zs &647 & - 0.846960e-04_wp * zt + 0.378110e-02_wp ) * zs &648 & + ( ( - 0.302285e-13_wp * zh &649 & - 0.251520e-11_wp * zs &650 & + 0.512857e-12_wp * zt * zt ) * zh &651 & - 0.164759e-06_wp * zs &652 & +( 0.791325e-08_wp * zt - 0.933746e-06_wp ) * zt &653 & + 0.380374e-04_wp ) * zh654 END DO655 END DO656 END DO657 beta0 = 1._wp658 !659 CASE ( 1 ) !== Linear formulation = F( temperature ) ==!660 palpbet(:,:,:) = rn_alpha661 beta0 = 0._wp662 !663 CASE ( 2 ) !== Linear formulation = F( temperature , salinity ) ==!664 palpbet(:,:,:) = ralpbet665 beta0 = 1._wp666 589 ! 667 590 CASE DEFAULT … … 672 595 END SELECT 673 596 ! 674 IF( nn_timing == 1 ) CALL timing_stop('eos_alpbet') 675 ! 676 END SUBROUTINE eos_alpbet 677 678 679 FUNCTION tfreez( psal, pdep ) RESULT( ptf ) 597 IF(ln_ctl) CALL prt_ctl( tab3d_1=pab(:,:,:,jp_tem), clinfo1=' rab_3d_t: ', & 598 & tab3d_2=pab(:,:,:,jp_sal), clinfo2=' rab_3d_s : ', ovlap=1, kdim=jpk ) 599 ! 600 IF( nn_timing == 1 ) CALL timing_stop('rab_3d') 601 ! 602 END SUBROUTINE rab_3d 603 604 SUBROUTINE rab_2d( pts, pdep, pab ) 605 !!---------------------------------------------------------------------- 606 !! *** ROUTINE rab_2d *** 607 !! 608 !! ** Purpose : Calculates thermal/haline expansion ratio for a 2d field (unmasked) 609 !! 610 !! ** Action : - pab : thermal/haline expansion ratio at T-points 611 !!---------------------------------------------------------------------- 612 REAL(wp), DIMENSION(jpi,jpj,jpts) , INTENT(in ) :: pts ! pot. temperature & salinity 613 REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: pdep ! depth [m] 614 REAL(wp), DIMENSION(jpi,jpj,jpts) , INTENT( out) :: pab ! thermal/haline expansion ratio 615 ! 616 INTEGER :: ji, jj, jk ! dummy loop indices 617 REAL(wp) :: zt , zh , zs ! local scalars 618 REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - - 619 !!---------------------------------------------------------------------- 620 ! 621 IF( nn_timing == 1 ) CALL timing_start('rab_2d') 622 ! 623 pab(:,:,:) = 0._wp 624 ! 625 SELECT CASE ( nn_eos ) 626 ! 627 CASE( -1, 0 ) !== polynomial TEOS-10 / EOS-80 ==! 628 ! 629 DO jj = 1, jpjm1 630 DO ji = 1, fs_jpim1 ! vector opt. 631 ! 632 zh = pdep(ji,jj) * r1_Z0 ! depth 633 zt = pts (ji,jj,jp_tem) * r1_T0 ! temperature 634 zs = SQRT( ABS( pts(ji,jj,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity 635 ! 636 ! alpha 637 zn3 = ALP003 638 ! 639 zn2 = ALP012*zt + ALP102*zs+ALP002 640 ! 641 zn1 = ((ALP031*zt & 642 & + ALP121*zs+ALP021)*zt & 643 & + (ALP211*zs+ALP111)*zs+ALP011)*zt & 644 & + ((ALP301*zs+ALP201)*zs+ALP101)*zs+ALP001 645 ! 646 zn0 = ((((ALP050*zt & 647 & + ALP140*zs+ALP040)*zt & 648 & + (ALP230*zs+ALP130)*zs+ALP030)*zt & 649 & + ((ALP320*zs+ALP220)*zs+ALP120)*zs+ALP020)*zt & 650 & + (((ALP410*zs+ALP310)*zs+ALP210)*zs+ALP110)*zs+ALP010)*zt & 651 & + ((((ALP500*zs+ALP400)*zs+ALP300)*zs+ALP200)*zs+ALP100)*zs+ALP000 652 ! 653 zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 654 ! 655 pab(ji,jj,jp_tem) = zn * r1_rau0 656 ! 657 ! beta 658 zn3 = BET003 659 ! 660 zn2 = BET012*zt + BET102*zs+BET002 661 ! 662 zn1 = ((BET031*zt & 663 & + BET121*zs+BET021)*zt & 664 & + (BET211*zs+BET111)*zs+BET011)*zt & 665 & + ((BET301*zs+BET201)*zs+BET101)*zs+BET001 666 ! 667 zn0 = ((((BET050*zt & 668 & + BET140*zs+BET040)*zt & 669 & + (BET230*zs+BET130)*zs+BET030)*zt & 670 & + ((BET320*zs+BET220)*zs+BET120)*zs+BET020)*zt & 671 & + (((BET410*zs+BET310)*zs+BET210)*zs+BET110)*zs+BET010)*zt & 672 & + ((((BET500*zs+BET400)*zs+BET300)*zs+BET200)*zs+BET100)*zs+BET000 673 ! 674 zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 675 ! 676 pab(ji,jj,jp_sal) = zn / zs * r1_rau0 677 ! 678 ! 679 END DO 680 END DO 681 ! 682 CALL lbc_lnk( pab(:,:,jp_tem), 'T', 1. ) ! Lateral boundary conditions 683 CALL lbc_lnk( pab(:,:,jp_sal), 'T', 1. ) 684 ! 685 CASE( 1 ) !== simplified EOS ==! 686 ! 687 DO jj = 1, jpjm1 688 DO ji = 1, fs_jpim1 ! vector opt. 689 ! 690 zt = pts (ji,jj,jp_tem) - 10._wp ! pot. temperature anomaly (t-T0) 691 zs = pts (ji,jj,jp_sal) - 35._wp ! abs. salinity anomaly (s-S0) 692 zh = pdep (ji,jj) ! depth at the partial step level 693 ! 694 zn = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs 695 pab(ji,jj,jp_tem) = zn * r1_rau0 ! alpha 696 ! 697 zn = rn_b0 * ( 1._wp - rn_lambda2*zs - rn_mu2*zh ) - rn_nu*zt 698 pab(ji,jj,jp_sal) = zn * r1_rau0 ! beta 699 ! 700 END DO 701 END DO 702 ! 703 CALL lbc_lnk( pab(:,:,jp_tem), 'T', 1. ) ! Lateral boundary conditions 704 CALL lbc_lnk( pab(:,:,jp_sal), 'T', 1. ) 705 ! 706 CASE DEFAULT 707 IF(lwp) WRITE(numout,cform_err) 708 IF(lwp) WRITE(numout,*) ' bad flag value for nn_eos = ', nn_eos 709 nstop = nstop + 1 710 ! 711 END SELECT 712 ! 713 IF(ln_ctl) CALL prt_ctl( tab2d_1=pab(:,:,jp_tem), clinfo1=' rab_2d_t: ', & 714 & tab2d_2=pab(:,:,jp_sal), clinfo2=' rab_2d_s : ' ) 715 ! 716 IF( nn_timing == 1 ) CALL timing_stop('rab_2d') 717 ! 718 END SUBROUTINE rab_2d 719 720 721 SUBROUTINE rab_0d( pts, pdep, pab ) 722 !!---------------------------------------------------------------------- 723 !! *** ROUTINE rab_0d *** 724 !! 725 !! ** Purpose : Calculates thermal/haline expansion ratio for a 2d field (unmasked) 726 !! 727 !! ** Action : - pab : thermal/haline expansion ratio at T-points 728 !!---------------------------------------------------------------------- 729 REAL(wp), DIMENSION(jpts) , INTENT(in ) :: pts ! pot. temperature & salinity 730 REAL(wp), INTENT(in ) :: pdep ! depth [m] 731 REAL(wp), DIMENSION(jpts) , INTENT( out) :: pab ! thermal/haline expansion ratio 732 ! 733 REAL(wp) :: zt , zh , zs ! local scalars 734 REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - - 735 !!---------------------------------------------------------------------- 736 ! 737 IF( nn_timing == 1 ) CALL timing_start('rab_2d') 738 ! 739 pab(:) = 0._wp 740 ! 741 SELECT CASE ( nn_eos ) 742 ! 743 CASE( -1, 0 ) !== polynomial TEOS-10 / EOS-80 ==! 744 ! 745 ! 746 zh = pdep * r1_Z0 ! depth 747 zt = pts (jp_tem) * r1_T0 ! temperature 748 zs = SQRT( ABS( pts(jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity 749 ! 750 ! alpha 751 zn3 = ALP003 752 ! 753 zn2 = ALP012*zt + ALP102*zs+ALP002 754 ! 755 zn1 = ((ALP031*zt & 756 & + ALP121*zs+ALP021)*zt & 757 & + (ALP211*zs+ALP111)*zs+ALP011)*zt & 758 & + ((ALP301*zs+ALP201)*zs+ALP101)*zs+ALP001 759 ! 760 zn0 = ((((ALP050*zt & 761 & + ALP140*zs+ALP040)*zt & 762 & + (ALP230*zs+ALP130)*zs+ALP030)*zt & 763 & + ((ALP320*zs+ALP220)*zs+ALP120)*zs+ALP020)*zt & 764 & + (((ALP410*zs+ALP310)*zs+ALP210)*zs+ALP110)*zs+ALP010)*zt & 765 & + ((((ALP500*zs+ALP400)*zs+ALP300)*zs+ALP200)*zs+ALP100)*zs+ALP000 766 ! 767 zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 768 ! 769 pab(jp_tem) = zn * r1_rau0 770 ! 771 ! beta 772 zn3 = BET003 773 ! 774 zn2 = BET012*zt + BET102*zs+BET002 775 ! 776 zn1 = ((BET031*zt & 777 & + BET121*zs+BET021)*zt & 778 & + (BET211*zs+BET111)*zs+BET011)*zt & 779 & + ((BET301*zs+BET201)*zs+BET101)*zs+BET001 780 ! 781 zn0 = ((((BET050*zt & 782 & + BET140*zs+BET040)*zt & 783 & + (BET230*zs+BET130)*zs+BET030)*zt & 784 & + ((BET320*zs+BET220)*zs+BET120)*zs+BET020)*zt & 785 & + (((BET410*zs+BET310)*zs+BET210)*zs+BET110)*zs+BET010)*zt & 786 & + ((((BET500*zs+BET400)*zs+BET300)*zs+BET200)*zs+BET100)*zs+BET000 787 ! 788 zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 789 ! 790 pab(jp_sal) = zn / zs * r1_rau0 791 ! 792 ! 793 ! 794 CASE( 1 ) !== simplified EOS ==! 795 ! 796 zt = pts(jp_tem) - 10._wp ! pot. temperature anomaly (t-T0) 797 zs = pts(jp_sal) - 35._wp ! abs. salinity anomaly (s-S0) 798 zh = pdep ! depth at the partial step level 799 ! 800 zn = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs 801 pab(jp_tem) = zn * r1_rau0 ! alpha 802 ! 803 zn = rn_b0 * ( 1._wp - rn_lambda2*zs - rn_mu2*zh ) - rn_nu*zt 804 pab(jp_sal) = zn * r1_rau0 ! beta 805 ! 806 CASE DEFAULT 807 IF(lwp) WRITE(numout,cform_err) 808 IF(lwp) WRITE(numout,*) ' bad flag value for nn_eos = ', nn_eos 809 nstop = nstop + 1 810 ! 811 END SELECT 812 ! 813 IF( nn_timing == 1 ) CALL timing_stop('rab_2d') 814 ! 815 END SUBROUTINE rab_0d 816 817 818 SUBROUTINE bn2( pts, pab, pn2 ) 819 !!---------------------------------------------------------------------- 820 !! *** ROUTINE bn2 *** 821 !! 822 !! ** Purpose : Compute the local Brunt-Vaisala frequency at the 823 !! time-step of the input arguments 824 !! 825 !! ** Method : pn2 = grav * (alpha dk[T] + beta dk[S] ) / e3w 826 !! where alpha and beta are given in pab, and computed on T-points. 827 !! N.B. N^2 is set one for all to zero at jk=1 in istate module. 828 !! 829 !! ** Action : pn2 : square of the brunt-vaisala frequency at w-point 830 !! 831 !!---------------------------------------------------------------------- 832 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! pot. temperature and salinity [Celcius,psu] 833 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pab ! thermal/haline expansion coef. [Celcius-1,psu-1] 834 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT( out) :: pn2 ! Brunt-Vaisala frequency squared [1/s^2] 835 ! 836 INTEGER :: ji, jj, jk ! dummy loop indices 837 REAL(wp) :: zaw, zbw, zrw ! local scalars 838 !!---------------------------------------------------------------------- 839 ! 840 IF( nn_timing == 1 ) CALL timing_start('bn2') 841 ! 842 DO jk = 2, jpkm1 ! interior points only (2=< jk =< jpkm1 ) 843 DO jj = 1, jpj ! surface and bottom value set to zero one for all in istate.F90 844 DO ji = 1, jpi 845 zrw = ( fsdepw(ji,jj,jk ) - fsdept(ji,jj,jk) ) & 846 & / ( fsdept(ji,jj,jk-1) - fsdept(ji,jj,jk) ) 847 ! 848 zaw = pab(ji,jj,jk,jp_tem) * (1. - zrw) + pab(ji,jj,jk-1,jp_tem) * zrw 849 zbw = pab(ji,jj,jk,jp_sal) * (1. - zrw) + pab(ji,jj,jk-1,jp_sal) * zrw 850 ! 851 pn2(ji,jj,jk) = grav * ( zaw * ( pts(ji,jj,jk-1,jp_tem) - pts(ji,jj,jk,jp_tem) ) & 852 & - zbw * ( pts(ji,jj,jk-1,jp_sal) - pts(ji,jj,jk,jp_sal) ) ) & 853 & / fse3w(ji,jj,jk) * tmask(ji,jj,jk) 854 END DO 855 END DO 856 END DO 857 ! 858 IF(ln_ctl) CALL prt_ctl( tab3d_1=pn2, clinfo1=' bn2 : ', ovlap=1, kdim=jpk ) 859 ! 860 IF( nn_timing == 1 ) CALL timing_stop('bn2') 861 ! 862 END SUBROUTINE bn2 863 864 865 FUNCTION eos_pt_from_ct( ctmp, psal ) RESULT( ptmp ) 866 !!---------------------------------------------------------------------- 867 !! *** ROUTINE eos_pt_from_ct *** 868 !! 869 !! ** Purpose : Compute pot.temp. from cons. temp. [Celcius] 870 !! 871 !! ** Method : rational approximation (5/3th order) of TEOS-10 algorithm 872 !! checkvalue: pt=20.02391895 Celsius for sa=35.7g/kg, ct=20degC 873 !! 874 !! Reference : TEOS-10, UNESCO 875 !! Rational approximation to TEOS10 algorithm (rms error on WOA13 values: 4.0e-5 degC) 876 !!---------------------------------------------------------------------- 877 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: ctmp ! Cons. Temp [Celcius] 878 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: psal ! salinity [psu] 879 ! Leave result array automatic rather than making explicitly allocated 880 REAL(wp), DIMENSION(jpi,jpj) :: ptmp ! potential temperature [Celcius] 881 ! 882 INTEGER :: ji, jj ! dummy loop indices 883 REAL(wp) :: zt , zs , ztm ! local scalars 884 REAL(wp) :: zn , zd ! local scalars 885 REAL(wp) :: zdeltaS , z1_S0 , z1_T0 886 !!---------------------------------------------------------------------- 887 ! 888 IF ( nn_timing == 1 ) CALL timing_start('eos_pt_from_ct') 889 ! 890 zdeltaS = 5._wp 891 z1_S0 = 0.875_wp/35.16504_wp 892 z1_T0 = 1._wp/40._wp 893 ! 894 DO jj = 1, jpj 895 DO ji = 1, jpi 896 ! 897 zt = ctmp (ji,jj) * z1_T0 898 zs = SQRT( ABS( psal(ji,jj) + zdeltaS ) * r1_S0 ) 899 ztm = tmask(ji,jj,1) 900 ! 901 zn = ((((-2.1385727895e-01_wp*zt & 902 & - 2.7674419971e-01_wp*zs+1.0728094330_wp)*zt & 903 & + (2.6366564313_wp*zs+3.3546960647_wp)*zs-7.8012209473_wp)*zt & 904 & + ((1.8835586562_wp*zs+7.3949191679_wp)*zs-3.3937395875_wp)*zs-5.6414948432_wp)*zt & 905 & + (((3.5737370589_wp*zs-1.5512427389e+01_wp)*zs+2.4625741105e+01_wp)*zs & 906 & +1.9912291000e+01_wp)*zs-3.2191146312e+01_wp)*zt & 907 & + ((((5.7153204649e-01_wp*zs-3.0943149543_wp)*zs+9.3052495181_wp)*zs & 908 & -9.4528934807_wp)*zs+3.1066408996_wp)*zs-4.3504021262e-01_wp 909 ! 910 zd = (2.0035003456_wp*zt & 911 & -3.4570358592e-01_wp*zs+5.6471810638_wp)*zt & 912 & + (1.5393993508_wp*zs-6.9394762624_wp)*zs+1.2750522650e+01_wp 913 ! 914 ptmp(ji,jj) = ( zt / z1_T0 + zn / zd ) * ztm 915 ! 916 END DO 917 END DO 918 ! 919 IF( nn_timing == 1 ) CALL timing_stop('eos_pt_from_ct') 920 ! 921 END FUNCTION eos_pt_from_ct 922 923 924 FUNCTION eos_fzp_2d( psal, pdep ) RESULT( ptf ) 925 !!---------------------------------------------------------------------- 926 !! *** ROUTINE eos_fzp *** 927 !! 928 !! ** Purpose : Compute the freezing point temperature [Celcius] 929 !! 930 !! ** Method : UNESCO freezing point (ptf) in Celcius is given by 931 !! ptf(t,z) = (-.0575+1.710523e-3*sqrt(abs(s))-2.154996e-4*s)*s - 7.53e-4*z 932 !! checkvalue: tf=-2.588567 Celsius for s=40psu, z=500m 933 !! 934 !! Reference : UNESCO tech. papers in the marine science no. 28. 1978 935 !!---------------------------------------------------------------------- 936 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: psal ! salinity [psu] 937 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ), OPTIONAL :: pdep ! depth [m] 938 REAL(wp), DIMENSION(jpi,jpj) :: ptf ! freezing temperature [Celcius] 939 ! 940 INTEGER :: ji, jj ! dummy loop indices 941 REAL(wp) :: zt, zs ! local scalars 942 !!---------------------------------------------------------------------- 943 ! 944 SELECT CASE ( nn_eos ) 945 ! 946 CASE ( -1, 1 ) !== CT,SA (TEOS-10 formulation) ==! 947 ! 948 DO jj = 1, jpj 949 DO ji = 1, jpi 950 zs= SQRT( ABS( psal(ji,jj) ) * r1_S0 ) ! square root salinity 951 ptf(ji,jj) = ((((1.46873e-03_wp*zs-9.64972e-03_wp)*zs+2.28348e-02_wp)*zs & 952 & - 3.12775e-02_wp)*zs+2.07679e-02_wp)*zs-5.87701e-02_wp 953 END DO 954 END DO 955 ptf(:,:) = ptf(:,:) * psal(:,:) 956 ! 957 IF( PRESENT( pdep ) ) ptf(:,:) = ptf(:,:) - 7.53e-4 * pdep(:,:) 958 ! 959 CASE ( 0 ) !== PT,SP (UNESCO formulation) ==! 960 ! 961 ptf(:,:) = ( - 0.0575_wp + 1.710523e-3_wp * SQRT( psal(:,:) ) & 962 & - 2.154996e-4_wp * psal(:,:) ) * psal(:,:) 963 ! 964 IF( PRESENT( pdep ) ) ptf(:,:) = ptf(:,:) - 7.53e-4 * pdep(:,:) 965 ! 966 CASE DEFAULT 967 IF(lwp) WRITE(numout,cform_err) 968 IF(lwp) WRITE(numout,*) ' bad flag value for nn_eos = ', nn_eos 969 nstop = nstop + 1 970 ! 971 END SELECT 972 ! 973 END FUNCTION eos_fzp_2d 974 975 FUNCTION eos_fzp_0d( psal, pdep ) RESULT( ptf ) 976 !!---------------------------------------------------------------------- 977 !! *** ROUTINE eos_fzp *** 978 !! 979 !! ** Purpose : Compute the freezing point temperature [Celcius] 980 !! 981 !! ** Method : UNESCO freezing point (ptf) in Celcius is given by 982 !! ptf(t,z) = (-.0575+1.710523e-3*sqrt(abs(s))-2.154996e-4*s)*s - 7.53e-4*z 983 !! checkvalue: tf=-2.588567 Celsius for s=40psu, z=500m 984 !! 985 !! Reference : UNESCO tech. papers in the marine science no. 28. 1978 986 !!---------------------------------------------------------------------- 987 REAL(wp), INTENT(in) :: psal ! salinity [psu] 988 REAL(wp), INTENT(in), OPTIONAL :: pdep ! depth [m] 989 REAL(wp) :: ptf ! freezing temperature [Celcius] 990 ! 991 REAL(wp) :: zs ! local scalars 992 !!---------------------------------------------------------------------- 993 ! 994 SELECT CASE ( nn_eos ) 995 ! 996 CASE ( -1, 1 ) !== CT,SA (TEOS-10 formulation) ==! 997 ! 998 zs = SQRT( ABS( psal ) * r1_S0 ) ! square root salinity 999 ptf = ((((1.46873e-03_wp*zs-9.64972e-03_wp)*zs+2.28348e-02_wp)*zs & 1000 & - 3.12775e-02_wp)*zs+2.07679e-02_wp)*zs-5.87701e-02_wp 1001 ptf = ptf * psal 1002 ! 1003 IF( PRESENT( pdep ) ) ptf = ptf - 7.53e-4 * pdep 1004 ! 1005 CASE ( 0 ) !== PT,SP (UNESCO formulation) ==! 1006 ! 1007 ptf = ( - 0.0575_wp + 1.710523e-3_wp * SQRT( psal ) & 1008 & - 2.154996e-4_wp * psal ) * psal 1009 ! 1010 IF( PRESENT( pdep ) ) ptf = ptf - 7.53e-4 * pdep 1011 ! 1012 CASE DEFAULT 1013 IF(lwp) WRITE(numout,cform_err) 1014 IF(lwp) WRITE(numout,*) ' bad flag value for nn_eos = ', nn_eos 1015 nstop = nstop + 1 1016 ! 1017 END SELECT 1018 ! 1019 END FUNCTION eos_fzp_0d 1020 1021 1022 SUBROUTINE eos_pen( pts, pab_pe, ppen ) 1023 !!---------------------------------------------------------------------- 1024 !! *** ROUTINE eos_pen *** 1025 !! 1026 !! ** Purpose : Calculates nonlinear anomalies of alpha_PE, beta_PE and PE at T-points 1027 !! 1028 !! ** Method : PE is defined analytically as the vertical 1029 !! primitive of EOS times -g integrated between 0 and z>0. 1030 !! pen is the nonlinear bsq-PE anomaly: pen = ( PE - rau0 gz ) / rau0 gz - rd 1031 !! = 1/z * /int_0^z rd dz - rd 1032 !! where rd is the density anomaly (see eos_rhd function) 1033 !! ab_pe are partial derivatives of PE anomaly with respect to T and S: 1034 !! ab_pe(1) = - 1/(rau0 gz) * dPE/dT + drd/dT = - d(pen)/dT 1035 !! ab_pe(2) = 1/(rau0 gz) * dPE/dS + drd/dS = d(pen)/dS 1036 !! 1037 !! ** Action : - pen : PE anomaly given at T-points 1038 !! : - pab_pe : given at T-points 1039 !! pab_pe(:,:,:,jp_tem) is alpha_pe 1040 !! pab_pe(:,:,:,jp_sal) is beta_pe 1041 !!---------------------------------------------------------------------- 1042 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! pot. temperature & salinity 1043 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT( out) :: pab_pe ! alpha_pe and beta_pe 1044 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: ppen ! potential energy anomaly 1045 ! 1046 INTEGER :: ji, jj, jk ! dummy loop indices 1047 REAL(wp) :: zt , zh , zs , ztm ! local scalars 1048 REAL(wp) :: zn , zn0, zn1, zn2 ! - - 1049 !!---------------------------------------------------------------------- 1050 ! 1051 IF( nn_timing == 1 ) CALL timing_start('eos_pen') 1052 ! 1053 SELECT CASE ( nn_eos ) 1054 ! 1055 CASE( -1, 0 ) !== polynomial TEOS-10 / EOS-80 ==! 1056 ! 1057 DO jk = 1, jpkm1 1058 DO jj = 1, jpj 1059 DO ji = 1, jpi 1060 ! 1061 zh = fsdept(ji,jj,jk) * r1_Z0 ! depth 1062 zt = pts (ji,jj,jk,jp_tem) * r1_T0 ! temperature 1063 zs = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity 1064 ztm = tmask(ji,jj,jk) ! tmask 1065 ! 1066 ! potential energy non-linear anomaly 1067 zn2 = (PEN012)*zt & 1068 & + PEN102*zs+PEN002 1069 ! 1070 zn1 = ((PEN021)*zt & 1071 & + PEN111*zs+PEN011)*zt & 1072 & + (PEN201*zs+PEN101)*zs+PEN001 1073 ! 1074 zn0 = ((((PEN040)*zt & 1075 & + PEN130*zs+PEN030)*zt & 1076 & + (PEN220*zs+PEN120)*zs+PEN020)*zt & 1077 & + ((PEN310*zs+PEN210)*zs+PEN110)*zs+PEN010)*zt & 1078 & + (((PEN400*zs+PEN300)*zs+PEN200)*zs+PEN100)*zs+PEN000 1079 ! 1080 zn = ( zn2 * zh + zn1 ) * zh + zn0 1081 ! 1082 ppen(ji,jj,jk) = zn * zh * r1_rau0 * ztm 1083 ! 1084 ! alphaPE non-linear anomaly 1085 zn2 = APE002 1086 ! 1087 zn1 = (APE011)*zt & 1088 & + APE101*zs+APE001 1089 ! 1090 zn0 = (((APE030)*zt & 1091 & + APE120*zs+APE020)*zt & 1092 & + (APE210*zs+APE110)*zs+APE010)*zt & 1093 & + ((APE300*zs+APE200)*zs+APE100)*zs+APE000 1094 ! 1095 zn = ( zn2 * zh + zn1 ) * zh + zn0 1096 ! 1097 pab_pe(ji,jj,jk,jp_tem) = zn * zh * r1_rau0 * ztm 1098 ! 1099 ! betaPE non-linear anomaly 1100 zn2 = BPE002 1101 ! 1102 zn1 = (BPE011)*zt & 1103 & + BPE101*zs+BPE001 1104 ! 1105 zn0 = (((BPE030)*zt & 1106 & + BPE120*zs+BPE020)*zt & 1107 & + (BPE210*zs+BPE110)*zs+BPE010)*zt & 1108 & + ((BPE300*zs+BPE200)*zs+BPE100)*zs+BPE000 1109 ! 1110 zn = ( zn2 * zh + zn1 ) * zh + zn0 1111 ! 1112 pab_pe(ji,jj,jk,jp_sal) = zn / zs * zh * r1_rau0 * ztm 1113 ! 1114 END DO 1115 END DO 1116 END DO 1117 ! 1118 CASE( 1 ) !== Vallis (2006) simplified EOS ==! 1119 ! 1120 DO jk = 1, jpkm1 1121 DO jj = 1, jpj 1122 DO ji = 1, jpi 1123 zt = pts(ji,jj,jk,jp_tem) - 10._wp ! temperature anomaly (t-T0) 1124 zs = pts (ji,jj,jk,jp_sal) - 35._wp ! abs. salinity anomaly (s-S0) 1125 zh = fsdept(ji,jj,jk) ! depth in meters at t-point 1126 ztm = tmask(ji,jj,jk) ! tmask 1127 zn = 0.5_wp * zh * r1_rau0 * ztm 1128 ! ! Potential Energy 1129 ppen(ji,jj,jk) = ( rn_a0 * rn_mu1 * zt + rn_b0 * rn_mu2 * zs ) * zn 1130 ! ! alphaPE 1131 pab_pe(ji,jj,jk,jp_tem) = - rn_a0 * rn_mu1 * zn 1132 pab_pe(ji,jj,jk,jp_sal) = rn_b0 * rn_mu2 * zn 1133 ! 1134 END DO 1135 END DO 1136 END DO 1137 ! 1138 CASE DEFAULT 1139 IF(lwp) WRITE(numout,cform_err) 1140 IF(lwp) WRITE(numout,*) ' bad flag value for nn_eos = ', nn_eos 1141 nstop = nstop + 1 1142 ! 1143 END SELECT 1144 ! 1145 IF( nn_timing == 1 ) CALL timing_stop('eos_pen') 1146 ! 1147 END SUBROUTINE eos_pen 1148 1149 1150 SUBROUTINE eos_init 680 1151 !!---------------------------------------------------------------------- 681 1152 !! *** ROUTINE eos_init *** 682 1153 !! 683 !! ** Purpose : Compute the sea surface freezing temperature [Celcius]684 !!685 !! ** Method : UNESCO freezing point at the surface (pressure = 0???)686 !! freezing point [Celcius]=(-.0575+1.710523e-3*sqrt(abs(s))-2.154996e-4*s)*s-7.53e-4*p687 !! checkvalue: tf= -2.588567 Celsius for s=40.0psu, p=500. decibars688 !!689 !! Reference : UNESCO tech. papers in the marine science no. 28. 1978690 !!----------------------------------------------------------------------691 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: psal ! salinity [psu]692 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ), OPTIONAL :: pdep ! depth [decibars]693 ! Leave result array automatic rather than making explicitly allocated694 REAL(wp), DIMENSION(jpi,jpj) :: ptf ! freezing temperature [Celcius]695 !!----------------------------------------------------------------------696 !697 ptf(:,:) = ( - 0.0575_wp + 1.710523e-3_wp * SQRT( psal(:,:) ) &698 & - 2.154996e-4_wp * psal(:,:) ) * psal(:,:)699 IF ( PRESENT( pdep ) ) THEN700 ptf(:,:) = ptf(:,:) - 7.53e-4_wp * pdep(:,:)701 ENDIF702 !703 END FUNCTION tfreez704 705 706 SUBROUTINE eos_init707 !!----------------------------------------------------------------------708 !! *** ROUTINE eos_init ***709 !!710 1154 !! ** Purpose : initializations for the equation of state 711 1155 !! 712 1156 !! ** Method : Read the namelist nameos and control the parameters 713 1157 !!---------------------------------------------------------------------- 714 NAMELIST/nameos/ nn_eos, rn_alpha, rn_beta 715 !!---------------------------------------------------------------------- 716 INTEGER :: ios 1158 INTEGER :: ios ! local integer 1159 !! 1160 NAMELIST/nameos/ nn_eos, ln_useCT, rn_a0, rn_b0, rn_lambda1, rn_mu1, & 1161 & rn_lambda2, rn_mu2, rn_nu 1162 !!---------------------------------------------------------------------- 717 1163 ! 718 1164 REWIND( numnam_ref ) ! Namelist nameos in reference namelist : equation of state 719 1165 READ ( numnam_ref, nameos, IOSTAT = ios, ERR = 901 ) 720 1166 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nameos in reference namelist', lwp ) 721 1167 ! 722 1168 REWIND( numnam_cfg ) ! Namelist nameos in configuration namelist : equation of state 723 1169 READ ( numnam_cfg, nameos, IOSTAT = ios, ERR = 902 ) 724 1170 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nameos in configuration namelist', lwp ) 725 1171 IF(lwm) WRITE( numond, nameos ) 1172 ! 1173 rau0 = 1026._wp !: volumic mass of reference [kg/m3] 1174 rcp = 3991.86795711963_wp !: heat capacity [J/K] 726 1175 ! 727 1176 IF(lwp) THEN ! Control print … … 731 1180 WRITE(numout,*) ' Namelist nameos : set eos parameters' 732 1181 WRITE(numout,*) ' flag for eq. of state and N^2 nn_eos = ', nn_eos 733 WRITE(numout,*) ' thermal exp. coef. (linear) rn_alpha = ', rn_alpha 734 WRITE(numout,*) ' saline exp. coef. (linear) rn_beta = ', rn_beta 1182 IF( ln_useCT ) THEN 1183 WRITE(numout,*) ' model uses Conservative Temperature' 1184 WRITE(numout,*) ' Important: model must be initialized with CT and SA fields' 1185 ENDIF 735 1186 ENDIF 736 1187 ! 737 1188 SELECT CASE( nn_eos ) ! check option 738 1189 ! 739 CASE( 0 ) !== Jackett and McDougall (1994) formulation==!1190 CASE( -1 ) !== polynomial TEOS-10 ==! 740 1191 IF(lwp) WRITE(numout,*) 741 IF(lwp) WRITE(numout,*) ' use of Jackett & McDougall (1994) equation of state and' 742 IF(lwp) WRITE(numout,*) ' McDougall (1987) Brunt-Vaisala frequency' 743 ! 744 CASE( 1 ) !== Linear formulation = F( temperature ) ==! 1192 IF(lwp) WRITE(numout,*) ' use of TEOS-10 equation of state (cons. temp. and abs. salinity)' 1193 ! 1194 rdeltaS = 32._wp 1195 r1_S0 = 0.875_wp/35.16504_wp 1196 r1_T0 = 1._wp/40._wp 1197 r1_Z0 = 1.e-4_wp 1198 ! 1199 EOS000 = 8.0189615746e+02_wp 1200 EOS100 = 8.6672408165e+02_wp 1201 EOS200 = -1.7864682637e+03_wp 1202 EOS300 = 2.0375295546e+03_wp 1203 EOS400 = -1.2849161071e+03_wp 1204 EOS500 = 4.3227585684e+02_wp 1205 EOS600 = -6.0579916612e+01_wp 1206 EOS010 = 2.6010145068e+01_wp 1207 EOS110 = -6.5281885265e+01_wp 1208 EOS210 = 8.1770425108e+01_wp 1209 EOS310 = -5.6888046321e+01_wp 1210 EOS410 = 1.7681814114e+01_wp 1211 EOS510 = -1.9193502195_wp 1212 EOS020 = -3.7074170417e+01_wp 1213 EOS120 = 6.1548258127e+01_wp 1214 EOS220 = -6.0362551501e+01_wp 1215 EOS320 = 2.9130021253e+01_wp 1216 EOS420 = -5.4723692739_wp 1217 EOS030 = 2.1661789529e+01_wp 1218 EOS130 = -3.3449108469e+01_wp 1219 EOS230 = 1.9717078466e+01_wp 1220 EOS330 = -3.1742946532_wp 1221 EOS040 = -8.3627885467_wp 1222 EOS140 = 1.1311538584e+01_wp 1223 EOS240 = -5.3563304045_wp 1224 EOS050 = 5.4048723791e-01_wp 1225 EOS150 = 4.8169980163e-01_wp 1226 EOS060 = -1.9083568888e-01_wp 1227 EOS001 = 1.9681925209e+01_wp 1228 EOS101 = -4.2549998214e+01_wp 1229 EOS201 = 5.0774768218e+01_wp 1230 EOS301 = -3.0938076334e+01_wp 1231 EOS401 = 6.6051753097_wp 1232 EOS011 = -1.3336301113e+01_wp 1233 EOS111 = -4.4870114575_wp 1234 EOS211 = 5.0042598061_wp 1235 EOS311 = -6.5399043664e-01_wp 1236 EOS021 = 6.7080479603_wp 1237 EOS121 = 3.5063081279_wp 1238 EOS221 = -1.8795372996_wp 1239 EOS031 = -2.4649669534_wp 1240 EOS131 = -5.5077101279e-01_wp 1241 EOS041 = 5.5927935970e-01_wp 1242 EOS002 = 2.0660924175_wp 1243 EOS102 = -4.9527603989_wp 1244 EOS202 = 2.5019633244_wp 1245 EOS012 = 2.0564311499_wp 1246 EOS112 = -2.1311365518e-01_wp 1247 EOS022 = -1.2419983026_wp 1248 EOS003 = -2.3342758797e-02_wp 1249 EOS103 = -1.8507636718e-02_wp 1250 EOS013 = 3.7969820455e-01_wp 1251 ! 1252 ALP000 = -6.5025362670e-01_wp 1253 ALP100 = 1.6320471316_wp 1254 ALP200 = -2.0442606277_wp 1255 ALP300 = 1.4222011580_wp 1256 ALP400 = -4.4204535284e-01_wp 1257 ALP500 = 4.7983755487e-02_wp 1258 ALP010 = 1.8537085209_wp 1259 ALP110 = -3.0774129064_wp 1260 ALP210 = 3.0181275751_wp 1261 ALP310 = -1.4565010626_wp 1262 ALP410 = 2.7361846370e-01_wp 1263 ALP020 = -1.6246342147_wp 1264 ALP120 = 2.5086831352_wp 1265 ALP220 = -1.4787808849_wp 1266 ALP320 = 2.3807209899e-01_wp 1267 ALP030 = 8.3627885467e-01_wp 1268 ALP130 = -1.1311538584_wp 1269 ALP230 = 5.3563304045e-01_wp 1270 ALP040 = -6.7560904739e-02_wp 1271 ALP140 = -6.0212475204e-02_wp 1272 ALP050 = 2.8625353333e-02_wp 1273 ALP001 = 3.3340752782e-01_wp 1274 ALP101 = 1.1217528644e-01_wp 1275 ALP201 = -1.2510649515e-01_wp 1276 ALP301 = 1.6349760916e-02_wp 1277 ALP011 = -3.3540239802e-01_wp 1278 ALP111 = -1.7531540640e-01_wp 1279 ALP211 = 9.3976864981e-02_wp 1280 ALP021 = 1.8487252150e-01_wp 1281 ALP121 = 4.1307825959e-02_wp 1282 ALP031 = -5.5927935970e-02_wp 1283 ALP002 = -5.1410778748e-02_wp 1284 ALP102 = 5.3278413794e-03_wp 1285 ALP012 = 6.2099915132e-02_wp 1286 ALP003 = -9.4924551138e-03_wp 1287 ! 1288 BET000 = 1.0783203594e+01_wp 1289 BET100 = -4.4452095908e+01_wp 1290 BET200 = 7.6048755820e+01_wp 1291 BET300 = -6.3944280668e+01_wp 1292 BET400 = 2.6890441098e+01_wp 1293 BET500 = -4.5221697773_wp 1294 BET010 = -8.1219372432e-01_wp 1295 BET110 = 2.0346663041_wp 1296 BET210 = -2.1232895170_wp 1297 BET310 = 8.7994140485e-01_wp 1298 BET410 = -1.1939638360e-01_wp 1299 BET020 = 7.6574242289e-01_wp 1300 BET120 = -1.5019813020_wp 1301 BET220 = 1.0872489522_wp 1302 BET320 = -2.7233429080e-01_wp 1303 BET030 = -4.1615152308e-01_wp 1304 BET130 = 4.9061350869e-01_wp 1305 BET230 = -1.1847737788e-01_wp 1306 BET040 = 1.4073062708e-01_wp 1307 BET140 = -1.3327978879e-01_wp 1308 BET050 = 5.9929880134e-03_wp 1309 BET001 = -5.2937873009e-01_wp 1310 BET101 = 1.2634116779_wp 1311 BET201 = -1.1547328025_wp 1312 BET301 = 3.2870876279e-01_wp 1313 BET011 = -5.5824407214e-02_wp 1314 BET111 = 1.2451933313e-01_wp 1315 BET211 = -2.4409539932e-02_wp 1316 BET021 = 4.3623149752e-02_wp 1317 BET121 = -4.6767901790e-02_wp 1318 BET031 = -6.8523260060e-03_wp 1319 BET002 = -6.1618945251e-02_wp 1320 BET102 = 6.2255521644e-02_wp 1321 BET012 = -2.6514181169e-03_wp 1322 BET003 = -2.3025968587e-04_wp 1323 ! 1324 PEN000 = -9.8409626043_wp 1325 PEN100 = 2.1274999107e+01_wp 1326 PEN200 = -2.5387384109e+01_wp 1327 PEN300 = 1.5469038167e+01_wp 1328 PEN400 = -3.3025876549_wp 1329 PEN010 = 6.6681505563_wp 1330 PEN110 = 2.2435057288_wp 1331 PEN210 = -2.5021299030_wp 1332 PEN310 = 3.2699521832e-01_wp 1333 PEN020 = -3.3540239802_wp 1334 PEN120 = -1.7531540640_wp 1335 PEN220 = 9.3976864981e-01_wp 1336 PEN030 = 1.2324834767_wp 1337 PEN130 = 2.7538550639e-01_wp 1338 PEN040 = -2.7963967985e-01_wp 1339 PEN001 = -1.3773949450_wp 1340 PEN101 = 3.3018402659_wp 1341 PEN201 = -1.6679755496_wp 1342 PEN011 = -1.3709540999_wp 1343 PEN111 = 1.4207577012e-01_wp 1344 PEN021 = 8.2799886843e-01_wp 1345 PEN002 = 1.7507069098e-02_wp 1346 PEN102 = 1.3880727538e-02_wp 1347 PEN012 = -2.8477365341e-01_wp 1348 ! 1349 APE000 = -1.6670376391e-01_wp 1350 APE100 = -5.6087643219e-02_wp 1351 APE200 = 6.2553247576e-02_wp 1352 APE300 = -8.1748804580e-03_wp 1353 APE010 = 1.6770119901e-01_wp 1354 APE110 = 8.7657703198e-02_wp 1355 APE210 = -4.6988432490e-02_wp 1356 APE020 = -9.2436260751e-02_wp 1357 APE120 = -2.0653912979e-02_wp 1358 APE030 = 2.7963967985e-02_wp 1359 APE001 = 3.4273852498e-02_wp 1360 APE101 = -3.5518942529e-03_wp 1361 APE011 = -4.1399943421e-02_wp 1362 APE002 = 7.1193413354e-03_wp 1363 ! 1364 BPE000 = 2.6468936504e-01_wp 1365 BPE100 = -6.3170583896e-01_wp 1366 BPE200 = 5.7736640125e-01_wp 1367 BPE300 = -1.6435438140e-01_wp 1368 BPE010 = 2.7912203607e-02_wp 1369 BPE110 = -6.2259666565e-02_wp 1370 BPE210 = 1.2204769966e-02_wp 1371 BPE020 = -2.1811574876e-02_wp 1372 BPE120 = 2.3383950895e-02_wp 1373 BPE030 = 3.4261630030e-03_wp 1374 BPE001 = 4.1079296834e-02_wp 1375 BPE101 = -4.1503681096e-02_wp 1376 BPE011 = 1.7676120780e-03_wp 1377 BPE002 = 1.7269476440e-04_wp 1378 ! 1379 CASE( 0 ) !== polynomial EOS-80 formulation ==! 1380 ! 745 1381 IF(lwp) WRITE(numout,*) 746 IF(lwp) WRITE(numout,*) ' use of linear eos rho(T) = rau0 * ( 1.0285 - rn_alpha * T )' 747 IF( lk_zdfddm ) CALL ctl_stop( ' double diffusive mixing parameterization requires', & 748 & ' that T and S are used as state variables' ) 749 ! 750 CASE( 2 ) !== Linear formulation = F( temperature , salinity ) ==! 751 ralpbet = rn_alpha / rn_beta 752 IF(lwp) WRITE(numout,*) 753 IF(lwp) WRITE(numout,*) ' use of linear eos rho(T,S) = rau0 * ( rn_beta * S - rn_alpha * T )' 1382 IF(lwp) WRITE(numout,*) ' use of EOS-80 equation of state (pot. temp. and pract. salinity)' 1383 ! 1384 rdeltaS = 20._wp 1385 r1_S0 = 1._wp/40._wp 1386 r1_T0 = 1._wp/40._wp 1387 r1_Z0 = 1.e-4_wp 1388 ! 1389 EOS000 = 9.5356891948e+02_wp 1390 EOS100 = 1.7136499189e+02_wp 1391 EOS200 = -3.7501039454e+02_wp 1392 EOS300 = 5.1856810420e+02_wp 1393 EOS400 = -3.7264470465e+02_wp 1394 EOS500 = 1.4302533998e+02_wp 1395 EOS600 = -2.2856621162e+01_wp 1396 EOS010 = 1.0087518651e+01_wp 1397 EOS110 = -1.3647741861e+01_wp 1398 EOS210 = 8.8478359933_wp 1399 EOS310 = -7.2329388377_wp 1400 EOS410 = 1.4774410611_wp 1401 EOS510 = 2.0036720553e-01_wp 1402 EOS020 = -2.5579830599e+01_wp 1403 EOS120 = 2.4043512327e+01_wp 1404 EOS220 = -1.6807503990e+01_wp 1405 EOS320 = 8.3811577084_wp 1406 EOS420 = -1.9771060192_wp 1407 EOS030 = 1.6846451198e+01_wp 1408 EOS130 = -2.1482926901e+01_wp 1409 EOS230 = 1.0108954054e+01_wp 1410 EOS330 = -6.2675951440e-01_wp 1411 EOS040 = -8.0812310102_wp 1412 EOS140 = 1.0102374985e+01_wp 1413 EOS240 = -4.8340368631_wp 1414 EOS050 = 1.2079167803_wp 1415 EOS150 = 1.1515380987e-01_wp 1416 EOS060 = -2.4520288837e-01_wp 1417 EOS001 = 1.0748601068e+01_wp 1418 EOS101 = -1.7817043500e+01_wp 1419 EOS201 = 2.2181366768e+01_wp 1420 EOS301 = -1.6750916338e+01_wp 1421 EOS401 = 4.1202230403_wp 1422 EOS011 = -1.5852644587e+01_wp 1423 EOS111 = -7.6639383522e-01_wp 1424 EOS211 = 4.1144627302_wp 1425 EOS311 = -6.6955877448e-01_wp 1426 EOS021 = 9.9994861860_wp 1427 EOS121 = -1.9467067787e-01_wp 1428 EOS221 = -1.2177554330_wp 1429 EOS031 = -3.4866102017_wp 1430 EOS131 = 2.2229155620e-01_wp 1431 EOS041 = 5.9503008642e-01_wp 1432 EOS002 = 1.0375676547_wp 1433 EOS102 = -3.4249470629_wp 1434 EOS202 = 2.0542026429_wp 1435 EOS012 = 2.1836324814_wp 1436 EOS112 = -3.4453674320e-01_wp 1437 EOS022 = -1.2548163097_wp 1438 EOS003 = 1.8729078427e-02_wp 1439 EOS103 = -5.7238495240e-02_wp 1440 EOS013 = 3.8306136687e-01_wp 1441 ! 1442 ALP000 = -2.5218796628e-01_wp 1443 ALP100 = 3.4119354654e-01_wp 1444 ALP200 = -2.2119589983e-01_wp 1445 ALP300 = 1.8082347094e-01_wp 1446 ALP400 = -3.6936026529e-02_wp 1447 ALP500 = -5.0091801383e-03_wp 1448 ALP010 = 1.2789915300_wp 1449 ALP110 = -1.2021756164_wp 1450 ALP210 = 8.4037519952e-01_wp 1451 ALP310 = -4.1905788542e-01_wp 1452 ALP410 = 9.8855300959e-02_wp 1453 ALP020 = -1.2634838399_wp 1454 ALP120 = 1.6112195176_wp 1455 ALP220 = -7.5817155402e-01_wp 1456 ALP320 = 4.7006963580e-02_wp 1457 ALP030 = 8.0812310102e-01_wp 1458 ALP130 = -1.0102374985_wp 1459 ALP230 = 4.8340368631e-01_wp 1460 ALP040 = -1.5098959754e-01_wp 1461 ALP140 = -1.4394226233e-02_wp 1462 ALP050 = 3.6780433255e-02_wp 1463 ALP001 = 3.9631611467e-01_wp 1464 ALP101 = 1.9159845880e-02_wp 1465 ALP201 = -1.0286156825e-01_wp 1466 ALP301 = 1.6738969362e-02_wp 1467 ALP011 = -4.9997430930e-01_wp 1468 ALP111 = 9.7335338937e-03_wp 1469 ALP211 = 6.0887771651e-02_wp 1470 ALP021 = 2.6149576513e-01_wp 1471 ALP121 = -1.6671866715e-02_wp 1472 ALP031 = -5.9503008642e-02_wp 1473 ALP002 = -5.4590812035e-02_wp 1474 ALP102 = 8.6134185799e-03_wp 1475 ALP012 = 6.2740815484e-02_wp 1476 ALP003 = -9.5765341718e-03_wp 1477 ! 1478 BET000 = 2.1420623987_wp 1479 BET100 = -9.3752598635_wp 1480 BET200 = 1.9446303907e+01_wp 1481 BET300 = -1.8632235232e+01_wp 1482 BET400 = 8.9390837485_wp 1483 BET500 = -1.7142465871_wp 1484 BET010 = -1.7059677327e-01_wp 1485 BET110 = 2.2119589983e-01_wp 1486 BET210 = -2.7123520642e-01_wp 1487 BET310 = 7.3872053057e-02_wp 1488 BET410 = 1.2522950346e-02_wp 1489 BET020 = 3.0054390409e-01_wp 1490 BET120 = -4.2018759976e-01_wp 1491 BET220 = 3.1429341406e-01_wp 1492 BET320 = -9.8855300959e-02_wp 1493 BET030 = -2.6853658626e-01_wp 1494 BET130 = 2.5272385134e-01_wp 1495 BET230 = -2.3503481790e-02_wp 1496 BET040 = 1.2627968731e-01_wp 1497 BET140 = -1.2085092158e-01_wp 1498 BET050 = 1.4394226233e-03_wp 1499 BET001 = -2.2271304375e-01_wp 1500 BET101 = 5.5453416919e-01_wp 1501 BET201 = -6.2815936268e-01_wp 1502 BET301 = 2.0601115202e-01_wp 1503 BET011 = -9.5799229402e-03_wp 1504 BET111 = 1.0286156825e-01_wp 1505 BET211 = -2.5108454043e-02_wp 1506 BET021 = -2.4333834734e-03_wp 1507 BET121 = -3.0443885826e-02_wp 1508 BET031 = 2.7786444526e-03_wp 1509 BET002 = -4.2811838287e-02_wp 1510 BET102 = 5.1355066072e-02_wp 1511 BET012 = -4.3067092900e-03_wp 1512 BET003 = -7.1548119050e-04_wp 1513 ! 1514 PEN000 = -5.3743005340_wp 1515 PEN100 = 8.9085217499_wp 1516 PEN200 = -1.1090683384e+01_wp 1517 PEN300 = 8.3754581690_wp 1518 PEN400 = -2.0601115202_wp 1519 PEN010 = 7.9263222935_wp 1520 PEN110 = 3.8319691761e-01_wp 1521 PEN210 = -2.0572313651_wp 1522 PEN310 = 3.3477938724e-01_wp 1523 PEN020 = -4.9997430930_wp 1524 PEN120 = 9.7335338937e-02_wp 1525 PEN220 = 6.0887771651e-01_wp 1526 PEN030 = 1.7433051009_wp 1527 PEN130 = -1.1114577810e-01_wp 1528 PEN040 = -2.9751504321e-01_wp 1529 PEN001 = -6.9171176978e-01_wp 1530 PEN101 = 2.2832980419_wp 1531 PEN201 = -1.3694684286_wp 1532 PEN011 = -1.4557549876_wp 1533 PEN111 = 2.2969116213e-01_wp 1534 PEN021 = 8.3654420645e-01_wp 1535 PEN002 = -1.4046808820e-02_wp 1536 PEN102 = 4.2928871430e-02_wp 1537 PEN012 = -2.8729602515e-01_wp 1538 ! 1539 APE000 = -1.9815805734e-01_wp 1540 APE100 = -9.5799229402e-03_wp 1541 APE200 = 5.1430784127e-02_wp 1542 APE300 = -8.3694846809e-03_wp 1543 APE010 = 2.4998715465e-01_wp 1544 APE110 = -4.8667669469e-03_wp 1545 APE210 = -3.0443885826e-02_wp 1546 APE020 = -1.3074788257e-01_wp 1547 APE120 = 8.3359333577e-03_wp 1548 APE030 = 2.9751504321e-02_wp 1549 APE001 = 3.6393874690e-02_wp 1550 APE101 = -5.7422790533e-03_wp 1551 APE011 = -4.1827210323e-02_wp 1552 APE002 = 7.1824006288e-03_wp 1553 ! 1554 BPE000 = 1.1135652187e-01_wp 1555 BPE100 = -2.7726708459e-01_wp 1556 BPE200 = 3.1407968134e-01_wp 1557 BPE300 = -1.0300557601e-01_wp 1558 BPE010 = 4.7899614701e-03_wp 1559 BPE110 = -5.1430784127e-02_wp 1560 BPE210 = 1.2554227021e-02_wp 1561 BPE020 = 1.2166917367e-03_wp 1562 BPE120 = 1.5221942913e-02_wp 1563 BPE030 = -1.3893222263e-03_wp 1564 BPE001 = 2.8541225524e-02_wp 1565 BPE101 = -3.4236710714e-02_wp 1566 BPE011 = 2.8711395266e-03_wp 1567 BPE002 = 5.3661089288e-04_wp 1568 ! 1569 CASE( 1 ) !== Simplified EOS ==! 1570 IF(lwp) THEN 1571 WRITE(numout,*) 1572 WRITE(numout,*) ' use of simplified eos: rhd(dT=T-10,dS=S-35,Z) = ' 1573 WRITE(numout,*) ' [-a0*(1+lambda1/2*dT+mu1*Z)*dT + b0*(1+lambda2/2*dT+mu2*Z)*dS - nu*dT*dS]/rau0' 1574 WRITE(numout,*) 1575 WRITE(numout,*) ' thermal exp. coef. rn_a0 = ', rn_a0 1576 WRITE(numout,*) ' saline cont. coef. rn_b0 = ', rn_b0 1577 WRITE(numout,*) ' cabbeling coef. rn_lambda1 = ', rn_lambda1 1578 WRITE(numout,*) ' cabbeling coef. rn_lambda2 = ', rn_lambda2 1579 WRITE(numout,*) ' thermobar. coef. rn_mu1 = ', rn_mu1 1580 WRITE(numout,*) ' thermobar. coef. rn_mu2 = ', rn_mu2 1581 WRITE(numout,*) ' 2nd cabbel. coef. rn_nu = ', rn_nu 1582 WRITE(numout,*) ' Caution: rn_beta0=0 incompatible with ddm parameterization ' 1583 ENDIF 754 1584 ! 755 1585 CASE DEFAULT !== ERROR in nn_eos ==! … … 759 1589 END SELECT 760 1590 ! 1591 r1_rau0 = 1._wp / rau0 1592 r1_rcp = 1._wp / rcp 1593 r1_rau0_rcp = 1._wp / ( rau0 * rcp ) 1594 ! 1595 IF(lwp) WRITE(numout,*) 1596 IF(lwp) WRITE(numout,*) ' volumic mass of reference rau0 = ', rau0 , ' kg/m^3' 1597 IF(lwp) WRITE(numout,*) ' 1. / rau0 r1_rau0 = ', r1_rau0, ' m^3/kg' 1598 IF(lwp) WRITE(numout,*) ' ocean specific heat rcp = ', rcp , ' J/Kelvin' 1599 IF(lwp) WRITE(numout,*) ' 1. / ( rau0 * rcp ) r1_rau0_rcp = ', r1_rau0_rcp 1600 ! 761 1601 END SUBROUTINE eos_init 762 1602 -
branches/2014/dev_r4650_UKMO7_STARTHOUR/NEMOGCM/NEMO/OPA_SRC/TRA/traadv.F90
r4624 r5075 32 32 USE wrk_nemo ! Memory Allocation 33 33 USE timing ! Timing 34 USE sbc_oce 34 35 35 36 … … 43 44 LOGICAL :: ln_traadv_cen2 ! 2nd order centered scheme flag 44 45 LOGICAL :: ln_traadv_tvd ! TVD scheme flag 46 LOGICAL :: ln_traadv_tvd_zts ! TVD scheme flag with vertical sub time-stepping 45 47 LOGICAL :: ln_traadv_muscl ! MUSCL scheme flag 46 48 LOGICAL :: ln_traadv_muscl2 ! MUSCL2 scheme flag … … 120 122 CASE ( 5 ) ; CALL tra_adv_ubs ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts ) ! UBS 121 123 CASE ( 6 ) ; CALL tra_adv_qck ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts ) ! QUICKEST 124 CASE ( 7 ) ; CALL tra_adv_tvd_zts( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts ) ! TVD ZTS 122 125 ! 123 126 CASE (-1 ) !== esopa: test all possibility with control print ==! … … 166 169 & ln_traadv_muscl, ln_traadv_muscl2, & 167 170 & ln_traadv_ubs , ln_traadv_qck, & 168 & ln_traadv_msc_ups 171 & ln_traadv_msc_ups, ln_traadv_tvd_zts 169 172 !!---------------------------------------------------------------------- 170 173 … … 190 193 WRITE(numout,*) ' QUICKEST advection scheme ln_traadv_qck = ', ln_traadv_qck 191 194 WRITE(numout,*) ' upstream scheme within muscl ln_traadv_msc_ups = ', ln_traadv_msc_ups 195 WRITE(numout,*) ' TVD advection scheme with zts ln_traadv_tvd_zts = ', ln_traadv_tvd_zts 192 196 ENDIF 193 197 … … 199 203 IF( ln_traadv_ubs ) ioptio = ioptio + 1 200 204 IF( ln_traadv_qck ) ioptio = ioptio + 1 205 IF( ln_traadv_tvd_zts) ioptio = ioptio + 1 201 206 IF( lk_esopa ) ioptio = 1 207 208 IF( ( ln_traadv_muscl .OR. ln_traadv_muscl2 .OR. ln_traadv_ubs .OR. ln_traadv_qck ) .AND. nn_isf .NE. 0 ) & 209 & CALL ctl_stop( 'Only traadv_cen2 and traadv_tvd is compatible with ice shelf cavity') 202 210 203 211 IF( ioptio /= 1 ) CALL ctl_stop( 'Choose ONE advection scheme in namelist namtra_adv' ) … … 210 218 IF( ln_traadv_ubs ) nadv = 5 211 219 IF( ln_traadv_qck ) nadv = 6 220 IF( ln_traadv_tvd_zts) nadv = 7 212 221 IF( lk_esopa ) nadv = -1 213 222 … … 220 229 IF( nadv == 5 ) WRITE(numout,*) ' UBS scheme is used' 221 230 IF( nadv == 6 ) WRITE(numout,*) ' QUICKEST scheme is used' 231 IF( nadv == 7 ) WRITE(numout,*) ' TVD ZTS scheme is used' 222 232 IF( nadv == -1 ) WRITE(numout,*) ' esopa test: use all advection scheme' 223 233 ENDIF -
branches/2014/dev_r4650_UKMO7_STARTHOUR/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_cen2.F90
r4499 r5075 4 4 !! Ocean tracers: horizontal & vertical advective trend 5 5 !!====================================================================== 6 !! History : 8.2 ! 2001-08 (G. Madec, E. Durand)trahad+trazad=traadv7 !! 8 !! 9.0! 2004-08 (C. Talandier) New trends organization6 !! History : OPA ! 2001-08 (G. Madec, E. Durand) v8.2 trahad+trazad=traadv 7 !! NEMO 1.0 ! 2002-06 (G. Madec) F90: Free form and module 8 !! - ! 2004-08 (C. Talandier) New trends organization 9 9 !! - ! 2005-11 (V. Garnier) Surface pressure gradient organization 10 10 !! 2.0 ! 2006-04 (R. Benshila, G. Madec) Step reorganization … … 21 21 USE dom_oce ! ocean space and time domain 22 22 USE eosbn2 ! equation of state 23 USE trd mod_oce ! tracers trends24 USE trdtra ! tr acers trends23 USE trd_oce ! trends: ocean variables 24 USE trdtra ! trends manager: tracers 25 25 USE closea ! closed sea 26 26 USE sbcrnf ! river runoffs … … 33 33 USE wrk_nemo ! Memory Allocation 34 34 USE timing ! Timing 35 USE phycst 35 36 36 37 IMPLICIT NONE 37 38 PRIVATE 38 39 39 PUBLIC tra_adv_cen2 ! routine called by step.F90 40 PUBLIC ups_orca_set ! routine used by traadv_cen2_jki.F90 41 42 LOGICAL :: l_trd ! flag to compute trends 40 PUBLIC tra_adv_cen2 ! routine called by traadv.F90 43 41 44 42 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: upsmsk !: mixed upstream/centered scheme near some straits … … 55 53 56 54 SUBROUTINE tra_adv_cen2( kt, kit000, cdtype, pun, pvn, pwn, & 57 & ptb, ptn, pta, kjpt )55 & ptb, ptn, pta, kjpt ) 58 56 !!---------------------------------------------------------------------- 59 57 !! *** ROUTINE tra_adv_cen2 *** … … 85 83 !! * Add this trend now to the general trend of tracer (ta,sa): 86 84 !! pta = pta + ztra 87 !! * trend diagnostic ( 'key_trdtra' defined): the trend is85 !! * trend diagnostic (l_trdtra=T or l_trctra=T): the trend is 88 86 !! saved for diagnostics. The trends saved is expressed as 89 !! Uh.gradh(T), i.e. 90 !! save trend = ztra + ptn divn 87 !! Uh.gradh(T), i.e. save trend = ztra + ptn divn 91 88 !! 92 89 !! Part II : vertical advection … … 104 101 !! Add this trend now to the general trend of tracer (ta,sa): 105 102 !! pta = pta + ztra 106 !! Trend diagnostic ( 'key_trdtra' defined): the trend is103 !! Trend diagnostic (l_trdtra=T or l_trctra=T): the trend is 107 104 !! saved for diagnostics. The trends saved is expressed as : 108 105 !! save trend = w.gradz(T) = ztra - ptn divn. … … 111 108 !! - save trends if needed 112 109 !!---------------------------------------------------------------------- 113 USE oce , ONLY: zwx => ua , zwy => va ! (ua,va) used as 3D workspace114 !115 110 INTEGER , INTENT(in ) :: kt ! ocean time-step index 116 111 INTEGER , INTENT(in ) :: kit000 ! first time step index … … 121 116 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend 122 117 ! 123 INTEGER :: ji, jj, jk, jn ! dummy loop indices124 INTEGER :: ierr ! local integer118 INTEGER :: ji, jj, jk, jn, ikt ! dummy loop indices 119 INTEGER :: ierr ! local integer 125 120 REAL(wp) :: zbtr, ztra ! local scalars 126 121 REAL(wp) :: zfp_ui, zfp_vj, zfp_w, zcofi ! - - … … 128 123 REAL(wp) :: zupsut, zcenut, zupst ! - - 129 124 REAL(wp) :: zupsvt, zcenvt, zcent, zice ! - - 130 REAL(wp), POINTER, DIMENSION(:,: ) :: ztfreez 131 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwz, zind 125 REAL(wp), POINTER, DIMENSION(:,:) :: zfzp, zpres ! 2D workspace 126 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwx, zwy ! 3D - 127 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwz, zind ! - - 132 128 !!---------------------------------------------------------------------- 133 129 ! 134 130 IF( nn_timing == 1 ) CALL timing_start('tra_adv_cen2') 135 131 ! 136 CALL wrk_alloc( jpi, jpj, z tfreez)137 CALL wrk_alloc( jpi, jpj, jpk, zw z, zind )132 CALL wrk_alloc( jpi, jpj, zpres, zfzp ) 133 CALL wrk_alloc( jpi, jpj, jpk, zwx, zwy, zwz, zind ) 138 134 ! 139 135 … … 144 140 IF(lwp) WRITE(numout,*) 145 141 ! 146 IF 142 IF( .NOT. ALLOCATED( upsmsk ) ) THEN 147 143 ALLOCATE( upsmsk(jpi,jpj), STAT=ierr ) 148 144 IF( ierr /= 0 ) CALL ctl_stop('STOP', 'tra_adv_cen2: unable to allocate array') … … 162 158 ENDIF 163 159 ! 164 l_trd = .FALSE.165 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE.166 !167 160 ! Upstream / centered scheme indicator 168 161 ! ------------------------------------ 169 162 !!gm not strickly exact : the freezing point should be computed at each ocean levels... 170 163 !!gm not a big deal since cen2 is no more used in global ice-ocean simulations 171 ztfreez(:,:) = tfreez( tsn(:,:,1,jp_sal) ) 164 !!ch changes for ice shelf to retain standard behaviour elsewhere, even if not optimal 165 DO jj = 1, jpj 166 DO ji = 1, jpi 167 ikt = mikt(ji,jj) 168 IF (ikt > 1 ) THEN 169 zpres(ji,jj) = grav * rau0 * fsdept(ji,jj,ikt) * 1.e-04 170 ELSE 171 zpres(ji,jj) = 0.0 172 ENDIF 173 END DO 174 END DO 175 zfzp(:,:) = eos_fzp( tsn(:,:,1,jp_sal), zpres(:,:) ) 172 176 DO jk = 1, jpk 173 177 DO jj = 1, jpj 174 178 DO ji = 1, jpi 175 179 ! ! below ice covered area (if tn < "freezing"+0.1 ) 176 IF( tsn(ji,jj,jk,jp_tem) <= z tfreez(ji,jj) + 0.1 ) THEN ; zice = 1.e0177 ELSE ; zice = 0.e0180 IF( tsn(ji,jj,jk,jp_tem) <= zfzp(ji,jj) + 0.1 ) THEN ; zice = 1._wp 181 ELSE ; zice = 0._wp 178 182 ENDIF 179 183 zind(ji,jj,jk) = MAX ( & … … 224 228 ! ! Surface value : 225 229 IF( lk_vvl ) THEN ; zwz(:,:, 1 ) = 0.e0 ! volume variable 226 ELSE ; zwz(:,:, 1 ) = pwn(:,:,1) * ptn(:,:,1,jn) ! linear free surface 230 ELSE 231 DO jj = 1, jpj ! vector opt. 232 DO ji = 1, jpi ! vector opt. 233 ikt = mikt(ji,jj) 234 zwz(ji,jj,ikt ) = pwn(ji,jj,ikt) * ptn(ji,jj,ikt,jn) ! linear free surface 235 zwz(ji,jj,1:ikt-1) = 0.e0 236 END DO 237 END DO 227 238 ENDIF 228 239 ! … … 260 271 END DO 261 272 262 ! ! trend diagnostics (contribution of upstream fluxes) 263 IF( l_trd ) THEN 264 CALL trd_tra( kt, cdtype, jn, jptra_trd_xad, zwx, pun, ptn(:,:,:,jn) ) 265 CALL trd_tra( kt, cdtype, jn, jptra_trd_yad, zwy, pvn, ptn(:,:,:,jn) ) 266 CALL trd_tra( kt, cdtype, jn, jptra_trd_zad, zwz, pwn, ptn(:,:,:,jn) ) 273 ! ! trend diagnostics 274 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. & 275 &( cdtype == 'TRC' .AND. l_trdtrc ) ) THEN 276 CALL trd_tra( kt, cdtype, jn, jptra_xad, zwx, pun, ptn(:,:,:,jn) ) 277 CALL trd_tra( kt, cdtype, jn, jptra_yad, zwy, pvn, ptn(:,:,:,jn) ) 278 CALL trd_tra( kt, cdtype, jn, jptra_zad, zwz, pwn, ptn(:,:,:,jn) ) 267 279 END IF 268 280 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 269 281 IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN 270 IF( jn == jp_tem ) htr_adv(:) = ptr_vj( zwy(:,:,:) )271 IF( jn == jp_sal ) str_adv(:) = ptr_vj( zwy(:,:,:) )282 IF( jn == jp_tem ) htr_adv(:) = ptr_vj( zwy(:,:,:) ) 283 IF( jn == jp_sal ) str_adv(:) = ptr_vj( zwy(:,:,:) ) 272 284 ENDIF 273 285 ! 274 END DO286 END DO 275 287 276 288 ! --------------------------- required in restart file to ensure restartability) … … 281 293 ENDIF 282 294 ! 283 CALL wrk_dealloc( jpi, jpj, z tfreez)284 CALL wrk_dealloc( jpi, jpj, jpk, zw z, zind )295 CALL wrk_dealloc( jpi, jpj, zpres, zfzp ) 296 CALL wrk_dealloc( jpi, jpj, jpk, zwx, zwy, zwz, zind ) 285 297 ! 286 298 IF( nn_timing == 1 ) CALL timing_stop('tra_adv_cen2') … … 303 315 INTEGER :: ii0, ii1, ij0, ij1 ! temporary integers 304 316 !!---------------------------------------------------------------------- 305 306 317 ! 307 318 IF( nn_timing == 1 ) CALL timing_start('ups_orca_set') -
branches/2014/dev_r4650_UKMO7_STARTHOUR/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_eiv.F90
r3787 r5075 25 25 USE phycst ! physical constants 26 26 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 27 USE diaar5, ONLY: lk_diaar528 27 # endif 29 28 USE wrk_nemo ! Memory Allocation … … 161 160 CALL iom_put( "voce_eiv", v_eiv ) ! j-eiv current 162 161 CALL iom_put( "woce_eiv", w_eiv ) ! vert. eiv current 163 IF( lk_diaar5) THEN162 IF( iom_use('ueiv_heattr') ) THEN 164 163 zztmp = 0.5 * rau0 * rcp 165 164 z2d(:,:) = 0.e0 … … 167 166 DO jj = 2, jpjm1 168 167 DO ji = fs_2, fs_jpim1 ! vector opt. 169 z2d(ji,jj) = z2d(ji,jj) + zztmp *u_eiv(ji,jj,jk) &168 z2d(ji,jj) = z2d(ji,jj) + u_eiv(ji,jj,jk) & 170 169 & * (tsn(ji,jj,jk,jp_tem)+tsn(ji+1,jj,jk,jp_tem)) * e2u(ji,jj) * fse3u(ji,jj,jk) 171 170 END DO … … 173 172 END DO 174 173 CALL lbc_lnk( z2d, 'U', -1. ) 175 CALL iom_put( "ueiv_heattr", z2d ) ! heat transport in i-direction 174 CALL iom_put( "ueiv_heattr", zztmp * z2d ) ! heat transport in i-direction 175 ENDIF 176 177 IF( iom_use('veiv_heattr') ) THEN 178 zztmp = 0.5 * rau0 * rcp 176 179 z2d(:,:) = 0.e0 177 180 DO jk = 1, jpkm1 178 181 DO jj = 2, jpjm1 179 182 DO ji = fs_2, fs_jpim1 ! vector opt. 180 z2d(ji,jj) = z2d(ji,jj) + zztmp *v_eiv(ji,jj,jk) &183 z2d(ji,jj) = z2d(ji,jj) + v_eiv(ji,jj,jk) & 181 184 & * (tsn(ji,jj,jk,jp_tem)+tsn(ji,jj+1,jk,jp_tem)) * e1v(ji,jj) * fse3v(ji,jj,jk) 182 185 END DO … … 184 187 END DO 185 188 CALL lbc_lnk( z2d, 'V', -1. ) 186 CALL iom_put( "veiv_heattr", z 2d ) ! heat transport in i-direction189 CALL iom_put( "veiv_heattr", zztmp * z2d ) ! heat transport in i-direction 187 190 ENDIF 188 191 END IF -
branches/2014/dev_r4650_UKMO7_STARTHOUR/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_mle.F90
r4624 r5075 203 203 ! 204 204 ! !== structure function value at uw- and vw-points ==! 205 zhu(:,:) = 1._wp / zhu(:,:) ! hu --> 1/hu 206 zhv(:,:) = 1._wp / zhv(:,:) 205 DO jj = 1, jpjm1 206 DO ji = 1, fs_jpim1 ! vector opt. 207 zhu(ji,jj) = 1._wp / zhu(ji,jj) ! hu --> 1/hu 208 zhv(ji,jj) = 1._wp / zhv(ji,jj) 209 END DO 210 END DO 211 ! 207 212 zpsi_uw(:,:,:) = 0._wp 208 213 zpsi_vw(:,:,:) = 0._wp -
branches/2014/dev_r4650_UKMO7_STARTHOUR/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_muscl.F90
r4499 r5075 16 16 !!---------------------------------------------------------------------- 17 17 USE oce ! ocean dynamics and active tracers 18 USE trc_oce ! share passive tracers/Ocean variables 18 19 USE dom_oce ! ocean space and time domain 19 USE trdmod_oce ! tracers trends 20 USE trdtra ! tracers trends 21 USE in_out_manager ! I/O manager 20 USE trd_oce ! trends: ocean variables 21 USE trdtra ! tracers trends manager 22 22 USE dynspg_oce ! choice/control of key cpp for surface pressure gradient 23 USE trabbl ! tracers: bottom boundary layer 24 USE lib_mpp ! distribued memory computing 25 USE lbclnk ! ocean lateral boundary condition (or mpp link) 23 USE sbcrnf ! river runoffs 26 24 USE diaptr ! poleward transport diagnostics 27 USE trc_oce ! share passive tracers/Ocean variables25 ! 28 26 USE wrk_nemo ! Memory Allocation 29 27 USE timing ! Timing 30 28 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 31 USE eosbn2 ! equation of state 32 USE sbcrnf ! river runoffs 29 USE in_out_manager ! I/O manager 30 USE lib_mpp ! distribued memory computing 31 USE lbclnk ! ocean lateral boundary condition (or mpp link) 33 32 34 33 IMPLICIT NONE 35 34 PRIVATE 36 35 37 PUBLIC tra_adv_muscl ! routine called by step.F9038 39 LOGICAL :: l_trd ! flag to compute trends40 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: upsmsk !: mixed upstream/centered scheme near some straits41 ! ! and in closed seas (orca 2 and 4 configurations)42 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xind !: mixed upstream/centered index36 PUBLIC tra_adv_muscl ! routine called by traadv.F90 37 38 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: upsmsk !: mixed upstream/centered scheme near some straits 39 ! ! and in closed seas (orca 2 and 4 configurations) 40 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xind !: mixed upstream/centered index 41 43 42 !! * Substitutions 44 43 # include "domzgr_substitute.h90" … … 51 50 CONTAINS 52 51 53 SUBROUTINE tra_adv_muscl( kt, kit000, cdtype, p2dt, pun, pvn, pwn, &54 & ptb, pta, kjpt, ld_msc_ups )52 SUBROUTINE tra_adv_muscl( kt, kit000, cdtype, p2dt, pun, pvn, pwn, & 53 & ptb, pta, kjpt, ld_msc_ups ) 55 54 !!---------------------------------------------------------------------- 56 55 !! *** ROUTINE tra_adv_muscl *** … … 68 67 !! IPSL, Sept. 2000 (http://www.lodyc.jussieu.fr/opa) 69 68 !!---------------------------------------------------------------------- 70 USE oce , ONLY: zwx => ua , zwy => va ! (ua,va) used as workspace71 !72 69 INTEGER , INTENT(in ) :: kt ! ocean time-step index 73 70 INTEGER , INTENT(in ) :: kit000 ! first time step index … … 79 76 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb ! before tracer field 80 77 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend 81 82 !83 INTEGER :: ji, jj, jk, jn ! dummy loop indices78 ! 79 INTEGER :: ji, jj, jk, jn ! dummy loop indices 80 INTEGER :: ierr ! local integer 84 81 REAL(wp) :: zu, z0u, zzwx, zw ! local scalars 85 82 REAL(wp) :: zv, z0v, zzwy, z0w ! - - 86 83 REAL(wp) :: ztra, zbtr, zdt, zalpha ! - - 87 REAL(wp), POINTER, DIMENSION(:,:,:) :: zslpx, zslpy88 INTEGER :: ierr84 REAL(wp), POINTER, DIMENSION(:,:,:) :: zslpx, zslpy ! 3D workspace 85 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwx , zwy ! - - 89 86 !!---------------------------------------------------------------------- 90 87 ! 91 88 IF( nn_timing == 1 ) CALL timing_start('tra_adv_muscl') 92 89 ! 93 CALL wrk_alloc( jpi, jpj, jpk, zslpx, zslpy ) 94 ! 95 90 CALL wrk_alloc( jpi, jpj, jpk, zslpx, zslpy, zwx, zwy ) 91 ! 96 92 IF( kt == kit000 ) THEN 97 93 IF(lwp) WRITE(numout,*) … … 117 113 118 114 ! 119 ! Upstream / centeredscheme indicator115 ! Upstream / MUSCL scheme indicator 120 116 ! ------------------------------------ 117 !!gm useless 121 118 xind(:,:,:) = 1._wp ! set equal to 1 where up-stream is not needed 119 !!gm 122 120 ! 123 121 IF( ld_msc_ups ) THEN 124 DO jk = 1, jpk 125 DO jj = 1, jpj 126 DO ji = 1, jpi 127 xind(ji,jj,jk) = 1 - MAX ( & 128 rnfmsk(ji,jj) * rnfmsk_z(jk), & ! near runoff mouths (& closed sea outflows) 129 upsmsk(ji,jj) ) * tmask(ji,jj,jk) ! some of some straits 130 END DO 131 END DO 122 DO jk = 1, jpkm1 123 xind(:,:,jk) = 1._wp & ! =>1 where up-stream is not needed 124 & - MAX ( rnfmsk(:,:) * rnfmsk_z(jk), & ! =>0 near runoff mouths (& closed sea outflows) 125 & upsmsk(:,:) ) * tmask(:,:,jk) ! =>0 near some straits 132 126 END DO 133 127 ENDIF 134 128 ! 135 129 ENDIF 136 ! 137 l_trd = .FALSE. 138 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 139 130 ! 140 131 ! ! =========== 141 132 DO jn = 1, kjpt ! tracer loop … … 192 183 zalpha = 0.5 - z0u 193 184 zu = z0u - 0.5 * pun(ji,jj,jk) * zdt / ( e1u(ji,jj) * e2u(ji,jj) * fse3u(ji,jj,jk) ) 194 zzwx = ptb(ji+1,jj,jk,jn) + xind(ji,jj,jk) * (zu * zslpx(ji+1,jj,jk))195 zzwy = ptb(ji ,jj,jk,jn) + xind(ji,jj,jk) * (zu * zslpx(ji ,jj,jk))185 zzwx = ptb(ji+1,jj,jk,jn) + xind(ji,jj,jk) * zu * zslpx(ji+1,jj,jk) 186 zzwy = ptb(ji ,jj,jk,jn) + xind(ji,jj,jk) * zu * zslpx(ji ,jj,jk) 196 187 zwx(ji,jj,jk) = pun(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 197 188 ! … … 199 190 zalpha = 0.5 - z0v 200 191 zv = z0v - 0.5 * pvn(ji,jj,jk) * zdt / ( e1v(ji,jj) * e2v(ji,jj) * fse3v(ji,jj,jk) ) 201 zzwx = ptb(ji,jj+1,jk,jn) + xind(ji,jj,jk) * (zv * zslpy(ji,jj+1,jk))202 zzwy = ptb(ji,jj ,jk,jn) + xind(ji,jj,jk) * (zv * zslpy(ji,jj ,jk))192 zzwx = ptb(ji,jj+1,jk,jn) + xind(ji,jj,jk) * zv * zslpy(ji,jj+1,jk) 193 zzwy = ptb(ji,jj ,jk,jn) + xind(ji,jj,jk) * zv * zslpy(ji,jj ,jk) 203 194 zwy(ji,jj,jk) = pvn(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 204 195 END DO … … 222 213 END DO 223 214 ! ! trend diagnostics (contribution of upstream fluxes) 224 IF( l_trd ) THEN 225 CALL trd_tra( kt, cdtype, jn, jptra_trd_xad, zwx, pun, ptb(:,:,:,jn) ) 226 CALL trd_tra( kt, cdtype, jn, jptra_trd_yad, zwy, pvn, ptb(:,:,:,jn) ) 215 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. & 216 &( cdtype == 'TRC' .AND. l_trdtrc ) ) THEN 217 CALL trd_tra( kt, cdtype, jn, jptra_xad, zwx, pun, ptb(:,:,:,jn) ) 218 CALL trd_tra( kt, cdtype, jn, jptra_yad, zwy, pvn, ptb(:,:,:,jn) ) 227 219 END IF 228 220 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) … … 274 266 zalpha = 0.5 + z0w 275 267 zw = z0w - 0.5 * pwn(ji,jj,jk+1) * zdt * zbtr 276 zzwx = ptb(ji,jj,jk+1,jn) + xind(ji,jj,jk) * (zw * zslpx(ji,jj,jk+1))277 zzwy = ptb(ji,jj,jk ,jn) + xind(ji,jj,jk) * (zw * zslpx(ji,jj,jk ))268 zzwx = ptb(ji,jj,jk+1,jn) + xind(ji,jj,jk) * zw * zslpx(ji,jj,jk+1) 269 zzwy = ptb(ji,jj,jk ,jn) + xind(ji,jj,jk) * zw * zslpx(ji,jj,jk ) 278 270 zwx(ji,jj,jk+1) = pwn(ji,jj,jk+1) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 279 271 END DO … … 281 273 END DO 282 274 283 ! Compute & add the vertical advective trend 284 DO jk = 1, jpkm1 275 DO jk = 1, jpkm1 ! Compute & add the vertical advective trend 285 276 DO jj = 2, jpjm1 286 277 DO ji = fs_2, fs_jpim1 ! vector opt. 287 zbtr = 1. / ( e1 t(ji,jj) *e2t(ji,jj) * fse3t(ji,jj,jk) )278 zbtr = 1. / ( e1e2t(ji,jj) * fse3t(ji,jj,jk) ) 288 279 ! vertical advective trends 289 280 ztra = - zbtr * ( zwx(ji,jj,jk) - zwx(ji,jj,jk+1) ) … … 294 285 END DO 295 286 ! ! Save the vertical advective trends for diagnostic 296 IF( l_trd ) CALL trd_tra( kt, cdtype, jn, jptra_trd_zad, zwx, pwn, ptb(:,:,:,jn) ) 297 ! 298 ENDDO 299 ! 300 CALL wrk_dealloc( jpi, jpj, jpk, zslpx, zslpy ) 287 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. & 288 &( cdtype == 'TRC' .AND. l_trdtrc ) ) & 289 CALL trd_tra( kt, cdtype, jn, jptra_zad, zwx, pwn, ptb(:,:,:,jn) ) 290 ! 291 END DO 292 ! 293 CALL wrk_dealloc( jpi, jpj, jpk, zslpx, zslpy, zwx, zwy ) 301 294 ! 302 295 IF( nn_timing == 1 ) CALL timing_stop('tra_adv_muscl') -
branches/2014/dev_r4650_UKMO7_STARTHOUR/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_muscl2.F90
r4499 r5075 13 13 !!---------------------------------------------------------------------- 14 14 USE oce ! ocean dynamics and active tracers 15 USE trc_oce ! share passive tracers/Ocean variables 15 16 USE dom_oce ! ocean space and time domain 16 USE trd mod_oce ! tracers trends17 USE trdtra ! tr acers trends17 USE trd_oce ! trends: ocean variables 18 USE trdtra ! trends manager: tracers 18 19 USE in_out_manager ! I/O manager 19 20 USE dynspg_oce ! choice/control of key cpp for surface pressure gradient 20 USE trabbl ! tracers: bottom boundary layer 21 USE diaptr ! poleward transport diagnostics 22 ! 21 23 USE lib_mpp ! distribued memory computing 22 24 USE lbclnk ! ocean lateral boundary condition (or mpp link) 23 USE diaptr ! poleward transport diagnostics24 USE trc_oce ! share passive tracers/Ocean variables25 25 USE wrk_nemo ! Memory Allocation 26 26 USE timing ! Timing … … 31 31 32 32 PUBLIC tra_adv_muscl2 ! routine called by step.F90 33 34 LOGICAL :: l_trd ! flag to compute trends35 33 36 34 !! * Substitutions … … 61 59 !! IPSL, Sept. 2000 (http://www.lodyc.jussieu.fr/opa) 62 60 !!---------------------------------------------------------------------- 63 USE oce , ONLY: zwx => ua , zwy => va ! (ua,va) used as 3D workspace64 !!65 61 INTEGER , INTENT(in ) :: kt ! ocean time-step index 66 62 INTEGER , INTENT(in ) :: kit000 ! first time step index … … 76 72 REAL(wp) :: zv, z0v, zzwy, z0w ! - - 77 73 REAL(wp) :: ztra, zbtr, zdt, zalpha ! - - 78 REAL(wp), POINTER, DIMENSION(:,:,:) :: zslpx, zslpy 74 REAL(wp), POINTER, DIMENSION(:,:,:) :: zslpx, zslpy , zwx, zwy 79 75 !!---------------------------------------------------------------------- 80 76 ! 81 77 IF( nn_timing == 1 ) CALL timing_start('tra_adv_muscl2') 82 78 ! 83 CALL wrk_alloc( jpi, jpj, jpk, zslpx, zslpy )79 CALL wrk_alloc( jpi, jpj, jpk, zslpx, zslpy, zwx, zwy ) 84 80 ! 85 81 … … 90 86 ENDIF 91 87 ! 92 l_trd = .FALSE.93 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE.94 95 88 ! ! =========== 96 89 DO jn = 1, kjpt ! tracer loop … … 200 193 END DO 201 194 ! ! trend diagnostics (contribution of upstream fluxes) 202 IF( l_trd ) THEN 203 CALL trd_tra( kt, cdtype, jn, jptra_trd_xad, zwx, pun, ptb(:,:,:,jn) ) 204 CALL trd_tra( kt, cdtype, jn, jptra_trd_yad, zwy, pvn, ptb(:,:,:,jn) ) 195 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. & 196 &( cdtype == 'TRC' .AND. l_trdtrc ) ) THEN 197 CALL trd_tra( kt, cdtype, jn, jptra_xad, zwx, pun, ptb(:,:,:,jn) ) 198 CALL trd_tra( kt, cdtype, jn, jptra_yad, zwy, pvn, ptb(:,:,:,jn) ) 205 199 END IF 206 200 … … 284 278 END DO 285 279 ! ! trend diagnostics (contribution of upstream fluxes) 286 IF( l_trd ) CALL trd_tra( kt, cdtype, jn, jptra_trd_zad, zwx, pwn, ptb(:,:,:,jn) ) 280 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. & 281 &( cdtype == 'TRC' .AND. l_trdtrc ) ) & 282 CALL trd_tra( kt, cdtype, jn, jptra_zad, zwx, pwn, ptb(:,:,:,jn) ) 287 283 ! 288 284 END DO 289 285 ! 290 CALL wrk_dealloc( jpi, jpj, jpk, zslpx, zslpy )286 CALL wrk_dealloc( jpi, jpj, jpk, zslpx, zslpy, zwx, zwy ) 291 287 ! 292 288 IF( nn_timing == 1 ) CALL timing_stop('tra_adv_muscl2') -
branches/2014/dev_r4650_UKMO7_STARTHOUR/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_qck.F90
r4499 r5075 17 17 USE oce ! ocean dynamics and active tracers 18 18 USE dom_oce ! ocean space and time domain 19 USE trdmod_oce ! ocean space and time domain 20 USE trdtra ! ocean tracers trends 21 USE trabbl ! advective term in the BBL 19 USE trc_oce ! share passive tracers/Ocean variables 20 USE trd_oce ! trends: ocean variables 21 USE trdtra ! trends manager: tracers 22 USE dynspg_oce ! surface pressure gradient variables 23 USE diaptr ! poleward transport diagnostics 24 ! 22 25 USE lib_mpp ! distribued memory computing 23 26 USE lbclnk ! ocean lateral boundary condition (or mpp link) 24 USE dynspg_oce ! surface pressure gradient variables25 27 USE in_out_manager ! I/O manager 26 USE diaptr ! poleward transport diagnostics27 USE trc_oce ! share passive tracers/Ocean variables28 28 USE wrk_nemo ! Memory Allocation 29 29 USE timing ! Timing … … 93 93 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend 94 94 !!---------------------------------------------------------------------- 95 96 95 ! 97 96 IF( nn_timing == 1 ) CALL timing_start('tra_adv_qck') … … 103 102 IF(lwp) WRITE(numout,*) 104 103 ENDIF 105 !106 104 l_trd = .FALSE. 107 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE.108 105 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 106 ! 109 107 ! I. The horizontal fluxes are computed with the QUICKEST + ULTIMATE scheme 110 108 CALL tra_adv_qck_i( kt, cdtype, p2dt, pun, ptb, ptn, pta, kjpt ) … … 124 122 !! 125 123 !!---------------------------------------------------------------------- 126 USE oce , ONLY: zwx => ua ! ua used as workspace127 !128 124 INTEGER , INTENT(in ) :: kt ! ocean time-step index 129 125 CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) … … 136 132 INTEGER :: ji, jj, jk, jn ! dummy loop indices 137 133 REAL(wp) :: ztra, zbtr, zdir, zdx, zdt, zmsk ! local scalars 138 REAL(wp), POINTER, DIMENSION(:,:,:) :: z fu, zfc, zfd134 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwx, zfu, zfc, zfd 139 135 !---------------------------------------------------------------------- 140 136 ! 141 CALL wrk_alloc( jpi, jpj, jpk, z fu, zfc, zfd )137 CALL wrk_alloc( jpi, jpj, jpk, zwx, zfu, zfc, zfd ) 142 138 ! ! =========== 143 139 DO jn = 1, kjpt ! tracer loop … … 233 229 END DO 234 230 ! ! trend diagnostics (contribution of upstream fluxes) 235 IF( l_trd ) CALL trd_tra( kt, cdtype, jn, jptra_trd_xad, zwx, pun, ptn(:,:,:,jn) )231 IF( l_trd ) CALL trd_tra( kt, cdtype, jn, jptra_xad, zwx, pun, ptn(:,:,:,jn) ) 236 232 ! 237 233 END DO 238 234 ! 239 CALL wrk_dealloc( jpi, jpj, jpk, z fu, zfc, zfd )235 CALL wrk_dealloc( jpi, jpj, jpk, zwx, zfu, zfc, zfd ) 240 236 ! 241 237 END SUBROUTINE tra_adv_qck_i … … 247 243 !! 248 244 !!---------------------------------------------------------------------- 249 USE oce , ONLY: zwy => ua ! ua used as workspace250 !251 245 INTEGER , INTENT(in ) :: kt ! ocean time-step index 252 246 CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) … … 259 253 INTEGER :: ji, jj, jk, jn ! dummy loop indices 260 254 REAL(wp) :: ztra, zbtr, zdir, zdx, zdt, zmsk ! local scalars 261 REAL(wp), POINTER, DIMENSION(:,:,:) :: z fu, zfc, zfd255 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwy, zfu, zfc, zfd 262 256 !---------------------------------------------------------------------- 263 257 ! 264 CALL wrk_alloc( jpi, jpj, jpk, z fu, zfc, zfd )258 CALL wrk_alloc( jpi, jpj, jpk, zwy, zfu, zfc, zfd ) 265 259 ! 266 260 ! ! =========== … … 359 353 END DO 360 354 ! ! trend diagnostics (contribution of upstream fluxes) 361 IF( l_trd ) CALL trd_tra( kt, cdtype, jn, jptra_trd_yad, zwy, pvn, ptn(:,:,:,jn) )355 IF( l_trd ) CALL trd_tra( kt, cdtype, jn, jptra_yad, zwy, pvn, ptn(:,:,:,jn) ) 362 356 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 363 357 IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN … … 368 362 END DO 369 363 ! 370 CALL wrk_dealloc( jpi, jpj, jpk, z fu, zfc, zfd )364 CALL wrk_dealloc( jpi, jpj, jpk, zwy, zfu, zfc, zfd ) 371 365 ! 372 366 END SUBROUTINE tra_adv_qck_j … … 378 372 !! 379 373 !!---------------------------------------------------------------------- 380 USE oce, ONLY: zwz => ua ! ua used as workspace381 !382 374 INTEGER , INTENT(in ) :: kt ! ocean time-step index 383 375 CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) … … 389 381 INTEGER :: ji, jj, jk, jn ! dummy loop indices 390 382 REAL(wp) :: zbtr , ztra ! local scalars 391 !!---------------------------------------------------------------------- 392 383 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwz 384 !!---------------------------------------------------------------------- 385 ! 386 CALL wrk_alloc( jpi, jpj, jpk, zwz ) 393 387 ! ! =========== 394 388 DO jn = 1, kjpt ! tracer loop … … 422 416 END DO 423 417 ! ! Save the vertical advective trends for diagnostic 424 IF( l_trd ) CALL trd_tra( kt, cdtype, jn, jptra_ trd_zad, zwz, pwn, ptn(:,:,:,jn) )418 IF( l_trd ) CALL trd_tra( kt, cdtype, jn, jptra_zad, zwz, pwn, ptn(:,:,:,jn) ) 425 419 ! 426 420 END DO 421 ! 422 CALL wrk_dealloc( jpi, jpj, jpk, zwz ) 427 423 ! 428 424 END SUBROUTINE tra_adv_cen2_k -
branches/2014/dev_r4650_UKMO7_STARTHOUR/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_tvd.F90
r4499 r5075 22 22 USE oce ! ocean dynamics and active tracers 23 23 USE dom_oce ! ocean space and time domain 24 USE trdmod_oce ! tracers trends 24 USE trc_oce ! share passive tracers/Ocean variables 25 USE trd_oce ! trends: ocean variables 25 26 USE trdtra ! tracers trends 26 USE in_out_manager ! I/O manager27 27 USE dynspg_oce ! choice/control of key cpp for surface pressure gradient 28 USE diaptr ! poleward transport diagnostics 29 ! 28 30 USE lib_mpp ! MPP library 29 31 USE lbclnk ! ocean lateral boundary condition (or mpp link) 30 USE diaptr ! poleward transport diagnostics 31 USE trc_oce ! share passive tracers/Ocean variables 32 USE in_out_manager ! I/O manager 32 33 USE wrk_nemo ! Memory Allocation 33 34 USE timing ! Timing … … 37 38 PRIVATE 38 39 39 PUBLIC tra_adv_tvd ! routine called by step.F90 40 PUBLIC tra_adv_tvd ! routine called by traadv.F90 41 PUBLIC tra_adv_tvd_zts ! routine called by traadv.F90 40 42 41 43 LOGICAL :: l_trd ! flag to compute trends … … 77 79 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend 78 80 ! 79 INTEGER :: ji, jj, jk, jn ! dummy loop indices 81 INTEGER :: ji, jj, jk, jn ! dummy loop indices 82 INTEGER :: ik 80 83 REAL(wp) :: z2dtt, zbtr, ztra ! local scalar 81 84 REAL(wp) :: zfp_ui, zfp_vj, zfp_wk ! - - … … 93 96 IF(lwp) WRITE(numout,*) 'tra_adv_tvd : TVD advection scheme on ', cdtype 94 97 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 98 ! 99 l_trd = .FALSE. 100 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 95 101 ENDIF 96 !97 l_trd = .FALSE.98 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE.99 102 ! 100 103 IF( l_trd ) THEN … … 103 106 ENDIF 104 107 ! 105 zwi(:,:,:) = 0.e0 108 zwi(:,:,:) = 0.e0 ; zwz(:,:,:) = 0.e0 106 109 ! 107 110 ! ! =========== … … 132 135 ! upstream tracer flux in the k direction 133 136 ! Surface value 134 IF( lk_vvl ) THEN ; zwz(:,:, 1 ) = 0.e0 ! volume variable 135 ELSE ; zwz(:,:, 1 ) = pwn(:,:,1) * ptb(:,:,1,jn) ! linear free surface 137 IF( lk_vvl ) THEN 138 DO jj = 1, jpj 139 DO ji = 1, jpi 140 zwz(ji,jj, mikt(ji,jj) ) = 0.e0 ! volume variable 141 END DO 142 END DO 143 ELSE 144 DO jj = 1, jpj 145 DO ji = 1, jpi 146 zwz(ji,jj, mikt(ji,jj) ) = pwn(ji,jj,mikt(ji,jj)) * ptb(ji,jj,mikt(ji,jj),jn) ! linear free surface 147 END DO 148 END DO 136 149 ENDIF 137 150 ! Interior value 138 DO j k = 2, jpkm1139 DO j j = 1, jpj140 DO j i = 1, jpi151 DO jj = 1, jpj 152 DO ji = 1, jpi 153 DO jk = mikt(ji,jj)+1, jpkm1 141 154 zfp_wk = pwn(ji,jj,jk) + ABS( pwn(ji,jj,jk) ) 142 155 zfm_wk = pwn(ji,jj,jk) - ABS( pwn(ji,jj,jk) ) … … 157 170 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) 158 171 ! update and guess with monotonic sheme 159 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra 172 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra * tmask(ji,jj,jk) 160 173 zwi(ji,jj,jk) = ( ptb(ji,jj,jk,jn) + z2dtt * ztra ) * tmask(ji,jj,jk) 161 174 END DO … … 191 204 zwz(:,:,1) = 0.e0 ! Surface value 192 205 ! 193 DO jk = 2, jpkm1 ! Interior value 206 DO jj = 1, jpj 207 DO ji = 1, jpi 208 ik=mikt(ji,jj) 209 ! surface value 210 zwz(ji,jj,1:ik) = 0.e0 211 ! Interior value 212 DO jk = mikt(ji,jj)+1, jpkm1 213 zwz(ji,jj,jk) = 0.5 * pwn(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji,jj,jk-1,jn) ) - zwz(ji,jj,jk) 214 END DO 215 END DO 216 END DO 217 CALL lbc_lnk( zwx, 'U', -1. ) ; CALL lbc_lnk( zwy, 'V', -1. ) ! Lateral bondary conditions 218 CALL lbc_lnk( zwz, 'W', 1. ) 219 220 ! 4. monotonicity algorithm 221 ! ------------------------- 222 CALL nonosc( ptb(:,:,:,jn), zwx, zwy, zwz, zwi, p2dt ) 223 224 225 ! 5. final trend with corrected fluxes 226 ! ------------------------------------ 227 DO jk = 1, jpkm1 228 DO jj = 2, jpjm1 229 DO ji = fs_2, fs_jpim1 ! vector opt. 230 zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 231 ! total advective trends 232 ztra = - zbtr * ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & 233 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & 234 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) 235 ! add them to the general tracer trends 236 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra * tmask(ji,jj,jk) 237 END DO 238 END DO 239 END DO 240 241 ! ! trend diagnostics (contribution of upstream fluxes) 242 IF( l_trd ) THEN 243 ztrdx(:,:,:) = ztrdx(:,:,:) + zwx(:,:,:) ! <<< Add to previously computed 244 ztrdy(:,:,:) = ztrdy(:,:,:) + zwy(:,:,:) ! <<< Add to previously computed 245 ztrdz(:,:,:) = ztrdz(:,:,:) + zwz(:,:,:) ! <<< Add to previously computed 246 247 CALL trd_tra( kt, cdtype, jn, jptra_xad, ztrdx, pun, ptn(:,:,:,jn) ) 248 CALL trd_tra( kt, cdtype, jn, jptra_yad, ztrdy, pvn, ptn(:,:,:,jn) ) 249 CALL trd_tra( kt, cdtype, jn, jptra_zad, ztrdz, pwn, ptn(:,:,:,jn) ) 250 END IF 251 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 252 IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN 253 IF( jn == jp_tem ) htr_adv(:) = ptr_vj( zwy(:,:,:) ) + htr_adv(:) 254 IF( jn == jp_sal ) str_adv(:) = ptr_vj( zwy(:,:,:) ) + str_adv(:) 255 ENDIF 256 ! 257 END DO 258 ! 259 CALL wrk_dealloc( jpi, jpj, jpk, zwi, zwz ) 260 IF( l_trd ) CALL wrk_dealloc( jpi, jpj, jpk, ztrdx, ztrdy, ztrdz ) 261 ! 262 IF( nn_timing == 1 ) CALL timing_stop('tra_adv_tvd') 263 ! 264 END SUBROUTINE tra_adv_tvd 265 266 SUBROUTINE tra_adv_tvd_zts ( kt, kit000, cdtype, p2dt, pun, pvn, pwn, & 267 & ptb, ptn, pta, kjpt ) 268 !!---------------------------------------------------------------------- 269 !! *** ROUTINE tra_adv_tvd_zts *** 270 !! 271 !! ** Purpose : Compute the now trend due to total advection of 272 !! tracers and add it to the general trend of tracer equations 273 !! 274 !! ** Method : TVD ZTS scheme, i.e. 2nd order centered scheme with 275 !! corrected flux (monotonic correction). This version use sub- 276 !! timestepping for the vertical advection which increases stability 277 !! when vertical metrics are small. 278 !! note: - this advection scheme needs a leap-frog time scheme 279 !! 280 !! ** Action : - update (pta) with the now advective tracer trends 281 !! - save the trends 282 !!---------------------------------------------------------------------- 283 USE oce , ONLY: zwx => ua , zwy => va ! (ua,va) used as workspace 284 ! 285 INTEGER , INTENT(in ) :: kt ! ocean time-step index 286 INTEGER , INTENT(in ) :: kit000 ! first time step index 287 CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 288 INTEGER , INTENT(in ) :: kjpt ! number of tracers 289 REAL(wp), DIMENSION( jpk ), INTENT(in ) :: p2dt ! vertical profile of tracer time-step 290 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pun, pvn, pwn ! 3 ocean velocity components 291 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb, ptn ! before and now tracer fields 292 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend 293 ! 294 REAL(wp), DIMENSION( jpk ) :: zts ! length of sub-timestep for vertical advection 295 REAL(wp), DIMENSION( jpk ) :: zr_p2dt ! reciprocal of tracer timestep 296 INTEGER :: ji, jj, jk, jl, jn ! dummy loop indices 297 INTEGER :: jnzts = 5 ! number of sub-timesteps for vertical advection 298 INTEGER :: jtb, jtn, jta ! sub timestep pointers for leap-frog/euler forward steps 299 INTEGER :: jtaken ! toggle for collecting appropriate fluxes from sub timesteps 300 REAL(wp) :: z_rzts ! Fractional length of Euler forward sub-timestep for vertical advection 301 REAL(wp) :: z2dtt, zbtr, ztra ! local scalar 302 REAL(wp) :: zfp_ui, zfp_vj, zfp_wk ! - - 303 REAL(wp) :: zfm_ui, zfm_vj, zfm_wk ! - - 304 REAL(wp), POINTER, DIMENSION(:,: ) :: zwx_sav , zwy_sav 305 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwi, zwz, zhdiv, zwz_sav, zwzts 306 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdx, ztrdy, ztrdz 307 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztrs 308 !!---------------------------------------------------------------------- 309 ! 310 IF( nn_timing == 1 ) CALL timing_start('tra_adv_tvd_zts') 311 ! 312 CALL wrk_alloc( jpi, jpj, zwx_sav, zwy_sav ) 313 CALL wrk_alloc( jpi, jpj, jpk, zwi, zwz , zhdiv, zwz_sav, zwzts ) 314 CALL wrk_alloc( jpi, jpj, jpk, 3, ztrs ) 315 ! 316 IF( kt == kit000 ) THEN 317 IF(lwp) WRITE(numout,*) 318 IF(lwp) WRITE(numout,*) 'tra_adv_tvd_zts : TVD ZTS advection scheme on ', cdtype 319 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 320 ENDIF 321 ! 322 l_trd = .FALSE. 323 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 324 ! 325 IF( l_trd ) THEN 326 CALL wrk_alloc( jpi, jpj, jpk, ztrdx, ztrdy, ztrdz ) 327 ztrdx(:,:,:) = 0._wp ; ztrdy(:,:,:) = 0._wp ; ztrdz(:,:,:) = 0._wp 328 ENDIF 329 ! 330 zwi(:,:,:) = 0._wp 331 z_rzts = 1._wp / REAL( jnzts, wp ) 332 zr_p2dt(:) = 1._wp / p2dt(:) 333 ! 334 ! ! =========== 335 DO jn = 1, kjpt ! tracer loop 336 ! ! =========== 337 ! 1. Bottom value : flux set to zero 338 ! ---------------------------------- 339 zwx(:,:,jpk) = 0._wp ; zwz(:,:,jpk) = 0._wp 340 zwy(:,:,jpk) = 0._wp ; zwi(:,:,jpk) = 0._wp 341 342 ! 2. upstream advection with initial mass fluxes & intermediate update 343 ! -------------------------------------------------------------------- 344 ! upstream tracer flux in the i and j direction 345 DO jk = 1, jpkm1 346 DO jj = 1, jpjm1 347 DO ji = 1, fs_jpim1 ! vector opt. 348 ! upstream scheme 349 zfp_ui = pun(ji,jj,jk) + ABS( pun(ji,jj,jk) ) 350 zfm_ui = pun(ji,jj,jk) - ABS( pun(ji,jj,jk) ) 351 zfp_vj = pvn(ji,jj,jk) + ABS( pvn(ji,jj,jk) ) 352 zfm_vj = pvn(ji,jj,jk) - ABS( pvn(ji,jj,jk) ) 353 zwx(ji,jj,jk) = 0.5_wp * ( zfp_ui * ptb(ji,jj,jk,jn) + zfm_ui * ptb(ji+1,jj ,jk,jn) ) 354 zwy(ji,jj,jk) = 0.5_wp * ( zfp_vj * ptb(ji,jj,jk,jn) + zfm_vj * ptb(ji ,jj+1,jk,jn) ) 355 END DO 356 END DO 357 END DO 358 359 ! upstream tracer flux in the k direction 360 ! Surface value 361 IF( lk_vvl ) THEN ; zwz(:,:, 1 ) = 0._wp ! volume variable 362 ELSE ; zwz(:,:, 1 ) = pwn(:,:,1) * ptb(:,:,1,jn) ! linear free surface 363 ENDIF 364 ! Interior value 365 DO jk = 2, jpkm1 194 366 DO jj = 1, jpj 195 367 DO ji = 1, jpi 196 zwz(ji,jj,jk) = 0.5 * pwn(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji,jj,jk-1,jn) ) - zwz(ji,jj,jk) 368 zfp_wk = pwn(ji,jj,jk) + ABS( pwn(ji,jj,jk) ) 369 zfm_wk = pwn(ji,jj,jk) - ABS( pwn(ji,jj,jk) ) 370 zwz(ji,jj,jk) = 0.5_wp * ( zfp_wk * ptb(ji,jj,jk,jn) + zfm_wk * ptb(ji,jj,jk-1,jn) ) 371 END DO 372 END DO 373 END DO 374 375 ! total advective trend 376 DO jk = 1, jpkm1 377 z2dtt = p2dt(jk) 378 DO jj = 2, jpjm1 379 DO ji = fs_2, fs_jpim1 ! vector opt. 380 zbtr = 1._wp / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 381 ! total intermediate advective trends 382 ztra = - zbtr * ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & 383 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & 384 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) 385 ! update and guess with monotonic sheme 386 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra 387 zwi(ji,jj,jk) = ( ptb(ji,jj,jk,jn) + z2dtt * ztra ) * tmask(ji,jj,jk) 388 END DO 389 END DO 390 END DO 391 ! ! Lateral boundary conditions on zwi (unchanged sign) 392 CALL lbc_lnk( zwi, 'T', 1. ) 393 394 ! ! trend diagnostics (contribution of upstream fluxes) 395 IF( l_trd ) THEN 396 ! store intermediate advective trends 397 ztrdx(:,:,:) = zwx(:,:,:) ; ztrdy(:,:,:) = zwy(:,:,:) ; ztrdz(:,:,:) = zwz(:,:,:) 398 END IF 399 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 400 IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN 401 IF( jn == jp_tem ) htr_adv(:) = ptr_vj( zwy(:,:,:) ) 402 IF( jn == jp_sal ) str_adv(:) = ptr_vj( zwy(:,:,:) ) 403 ENDIF 404 405 ! 3. antidiffusive flux : high order minus low order 406 ! -------------------------------------------------- 407 ! antidiffusive flux on i and j 408 409 410 DO jk = 1, jpkm1 411 412 DO jj = 1, jpjm1 413 DO ji = 1, fs_jpim1 ! vector opt. 414 zwx_sav(ji,jj) = zwx(ji,jj,jk) 415 zwy_sav(ji,jj) = zwy(ji,jj,jk) 416 417 zwx(ji,jj,jk) = 0.5_wp * pun(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji+1,jj,jk,jn) ) 418 zwy(ji,jj,jk) = 0.5_wp * pvn(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji,jj+1,jk,jn) ) 419 END DO 420 END DO 421 422 DO jj = 2, jpjm1 ! partial horizontal divergence 423 DO ji = fs_2, fs_jpim1 424 zhdiv(ji,jj,jk) = ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk) & 425 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk) ) 426 END DO 427 END DO 428 429 DO jj = 1, jpjm1 430 DO ji = 1, fs_jpim1 ! vector opt. 431 zwx(ji,jj,jk) = zwx(ji,jj,jk) - zwx_sav(ji,jj) 432 zwy(ji,jj,jk) = zwy(ji,jj,jk) - zwy_sav(ji,jj) 433 END DO 434 END DO 435 END DO 436 437 ! antidiffusive flux on k 438 zwz(:,:,1) = 0._wp ! Surface value 439 zwz_sav(:,:,:) = zwz(:,:,:) 440 ! 441 ztrs(:,:,:,1) = ptb(:,:,:,jn) 442 zwzts(:,:,:) = 0._wp 443 444 DO jl = 1, jnzts ! Start of sub timestepping loop 445 446 IF( jl == 1 ) THEN ! Euler forward to kick things off 447 jtb = 1 ; jtn = 1 ; jta = 2 448 zts(:) = p2dt(:) * z_rzts 449 jtaken = MOD( jnzts + 1 , 2) ! Toggle to collect every second flux 450 ! starting at jl =1 if jnzts is odd; 451 ! starting at jl =2 otherwise 452 ELSEIF( jl == 2 ) THEN ! First leapfrog step 453 jtb = 1 ; jtn = 2 ; jta = 3 454 zts(:) = 2._wp * p2dt(:) * z_rzts 455 ELSE ! Shuffle pointers for subsequent leapfrog steps 456 jtb = MOD(jtb,3) + 1 457 jtn = MOD(jtn,3) + 1 458 jta = MOD(jta,3) + 1 459 ENDIF 460 DO jk = 2, jpkm1 ! Interior value 461 DO jj = 2, jpjm1 462 DO ji = fs_2, fs_jpim1 463 zwz(ji,jj,jk) = 0.5_wp * pwn(ji,jj,jk) * ( ztrs(ji,jj,jk,jtn) + ztrs(ji,jj,jk-1,jtn) ) 464 IF( jtaken == 0 ) zwzts(ji,jj,jk) = zwzts(ji,jj,jk) + zwz(ji,jj,jk)*zts(jk) ! Accumulate time-weighted vertcal flux 465 END DO 466 END DO 467 END DO 468 469 jtaken = MOD( jtaken + 1 , 2 ) 470 471 DO jk = 2, jpkm1 ! Interior value 472 DO jj = 2, jpjm1 473 DO ji = fs_2, fs_jpim1 474 zbtr = 1._wp / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 475 ! total advective trends 476 ztra = - zbtr * ( zhdiv(ji,jj,jk) + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) 477 ztrs(ji,jj,jk,jta) = ztrs(ji,jj,jk,jtb) + zts(jk) * ztra 478 END DO 479 END DO 480 END DO 481 482 END DO 483 484 DO jk = 2, jpkm1 ! Anti-diffusive vertical flux using average flux from the sub-timestepping 485 DO jj = 2, jpjm1 486 DO ji = fs_2, fs_jpim1 487 zwz(ji,jj,jk) = zwzts(ji,jj,jk) * zr_p2dt(jk) - zwz_sav(ji,jj,jk) 197 488 END DO 198 489 END DO … … 228 519 ztrdz(:,:,:) = ztrdz(:,:,:) + zwz(:,:,:) ! <<< Add to previously computed 229 520 230 CALL trd_tra( kt, cdtype, jn, jptra_ trd_xad, ztrdx, pun, ptn(:,:,:,jn) )231 CALL trd_tra( kt, cdtype, jn, jptra_ trd_yad, ztrdy, pvn, ptn(:,:,:,jn) )232 CALL trd_tra( kt, cdtype, jn, jptra_ trd_zad, ztrdz, pwn, ptn(:,:,:,jn) )521 CALL trd_tra( kt, cdtype, jn, jptra_xad, ztrdx, pun, ptn(:,:,:,jn) ) 522 CALL trd_tra( kt, cdtype, jn, jptra_yad, ztrdy, pvn, ptn(:,:,:,jn) ) 523 CALL trd_tra( kt, cdtype, jn, jptra_zad, ztrdz, pwn, ptn(:,:,:,jn) ) 233 524 END IF 234 525 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) … … 240 531 END DO 241 532 ! 242 CALL wrk_dealloc( jpi, jpj, jpk, zwi, zwz ) 533 CALL wrk_dealloc( jpi, jpj, jpk, zwi, zwz, zhdiv, zwz_sav, zwzts ) 534 CALL wrk_dealloc( jpi, jpj, jpk, 3, ztrs ) 535 CALL wrk_dealloc( jpi, jpj, zwx_sav, zwy_sav ) 243 536 IF( l_trd ) CALL wrk_dealloc( jpi, jpj, jpk, ztrdx, ztrdy, ztrdz ) 244 537 ! 245 IF( nn_timing == 1 ) CALL timing_stop('tra_adv_tvd') 246 ! 247 END SUBROUTINE tra_adv_tvd 248 538 IF( nn_timing == 1 ) CALL timing_stop('tra_adv_tvd_zts') 539 ! 540 END SUBROUTINE tra_adv_tvd_zts 249 541 250 542 SUBROUTINE nonosc( pbef, paa, pbb, pcc, paft, p2dt ) … … 261 553 !! in-space based differencing for fluid 262 554 !!---------------------------------------------------------------------- 263 !264 !!----------------------------------------------------------------------265 555 REAL(wp), DIMENSION(jpk) , INTENT(in ) :: p2dt ! vertical profile of tracer time-step 266 556 REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in ) :: pbef, paft ! before & after field 267 557 REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(inout) :: paa, pbb, pcc ! monotonic fluxes in the 3 directions 268 558 ! 269 INTEGER :: ji, jj, jk ! dummy loop indices270 INTEGER :: ikm1 ! local integer559 INTEGER :: ji, jj, jk ! dummy loop indices 560 INTEGER :: ikm1 ! local integer 271 561 REAL(wp) :: zpos, zneg, zbt, za, zb, zc, zbig, zrtrn, z2dtt ! local scalars 272 562 REAL(wp) :: zau, zbu, zcu, zav, zbv, zcv, zup, zdo ! - - … … 278 568 CALL wrk_alloc( jpi, jpj, jpk, zbetup, zbetdo, zbup, zbdo ) 279 569 ! 280 281 570 zbig = 1.e+40_wp 282 571 zrtrn = 1.e-15_wp 283 zbetup(:,:,jpk) = 0._wp ; zbetdo(:,:,jpk) = 0._wp 284 572 zbetup(:,:,:) = 0._wp ; zbetdo(:,:,:) = 0._wp 285 573 286 574 ! Search local extrema 287 575 ! -------------------- 288 576 ! max/min of pbef & paft with large negative/positive value (-/+zbig) inside land 289 zbup = MAX( pbef * tmask - zbig * ( 1. e0- tmask ), &290 & paft * tmask - zbig * ( 1. e0- tmask ) )291 zbdo = MIN( pbef * tmask + zbig * ( 1. e0- tmask ), &292 & paft * tmask + zbig * ( 1. e0- tmask ) )293 294 DO j k = 1, jpkm1295 ikm1 = MAX(jk-1,1)296 z2dtt = p2dt(jk)297 DO jj = 2, jpjm1298 DO ji = fs_2, fs_jpim1 ! vector opt.299 577 zbup = MAX( pbef * tmask - zbig * ( 1._wp - tmask ), & 578 & paft * tmask - zbig * ( 1._wp - tmask ) ) 579 zbdo = MIN( pbef * tmask + zbig * ( 1._wp - tmask ), & 580 & paft * tmask + zbig * ( 1._wp - tmask ) ) 581 582 DO jj = 2, jpjm1 583 DO ji = fs_2, fs_jpim1 ! vector opt. 584 DO jk = mikt(ji,jj), jpkm1 585 ikm1 = MAX(jk-1,mikt(ji,jj)) 586 z2dtt = p2dt(jk) 587 300 588 ! search maximum in neighbourhood 301 589 zup = MAX( zbup(ji ,jj ,jk ), & … … 334 622 DO jj = 2, jpjm1 335 623 DO ji = fs_2, fs_jpim1 ! vector opt. 336 zau = MIN( 1. e0, zbetdo(ji,jj,jk), zbetup(ji+1,jj,jk) )337 zbu = MIN( 1. e0, zbetup(ji,jj,jk), zbetdo(ji+1,jj,jk) )624 zau = MIN( 1._wp, zbetdo(ji,jj,jk), zbetup(ji+1,jj,jk) ) 625 zbu = MIN( 1._wp, zbetup(ji,jj,jk), zbetdo(ji+1,jj,jk) ) 338 626 zcu = ( 0.5 + SIGN( 0.5 , paa(ji,jj,jk) ) ) 339 paa(ji,jj,jk) = paa(ji,jj,jk) * ( zcu * zau + ( 1. e0- zcu) * zbu )340 341 zav = MIN( 1. e0, zbetdo(ji,jj,jk), zbetup(ji,jj+1,jk) )342 zbv = MIN( 1. e0, zbetup(ji,jj,jk), zbetdo(ji,jj+1,jk) )627 paa(ji,jj,jk) = paa(ji,jj,jk) * ( zcu * zau + ( 1._wp - zcu) * zbu ) 628 629 zav = MIN( 1._wp, zbetdo(ji,jj,jk), zbetup(ji,jj+1,jk) ) 630 zbv = MIN( 1._wp, zbetup(ji,jj,jk), zbetdo(ji,jj+1,jk) ) 343 631 zcv = ( 0.5 + SIGN( 0.5 , pbb(ji,jj,jk) ) ) 344 pbb(ji,jj,jk) = pbb(ji,jj,jk) * ( zcv * zav + ( 1. e0- zcv) * zbv )632 pbb(ji,jj,jk) = pbb(ji,jj,jk) * ( zcv * zav + ( 1._wp - zcv) * zbv ) 345 633 346 634 ! monotonic flux in the k direction, i.e. pcc … … 349 637 zb = MIN( 1., zbetup(ji,jj,jk+1), zbetdo(ji,jj,jk) ) 350 638 zc = ( 0.5 + SIGN( 0.5 , pcc(ji,jj,jk+1) ) ) 351 pcc(ji,jj,jk+1) = pcc(ji,jj,jk+1) * ( zc * za + ( 1. e0- zc) * zb )639 pcc(ji,jj,jk+1) = pcc(ji,jj,jk+1) * ( zc * za + ( 1._wp - zc) * zb ) 352 640 END DO 353 641 END DO -
branches/2014/dev_r4650_UKMO7_STARTHOUR/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_ubs.F90
r4499 r5075 14 14 USE oce ! ocean dynamics and active tracers 15 15 USE dom_oce ! ocean space and time domain 16 USE trdmod_oce ! ocean space and time domain 17 USE trdtra 18 USE lib_mpp 16 USE trc_oce ! share passive tracers/Ocean variables 17 USE trd_oce ! trends: ocean variables 18 USE trdtra ! trends manager: tracers 19 USE dynspg_oce ! choice/control of key cpp for surface pressure gradient 20 USE diaptr ! poleward transport diagnostics 21 ! 22 USE lib_mpp ! I/O library 19 23 USE lbclnk ! ocean lateral boundary condition (or mpp link) 20 24 USE in_out_manager ! I/O manager 21 USE diaptr ! poleward transport diagnostics22 USE dynspg_oce ! choice/control of key cpp for surface pressure gradient23 USE trc_oce ! share passive tracers/Ocean variables24 25 USE wrk_nemo ! Memory Allocation 25 26 USE timing ! Timing … … 51 52 !! and add it to the general trend of passive tracer equations. 52 53 !! 53 !! ** Method : The upstream biased 3rd order scheme (UBS) is based on an54 !! ** Method : The upstream biased scheme (UBS) is based on a 3rd order 54 55 !! upstream-biased parabolic interpolation (Shchepetkin and McWilliams 2005) 55 56 !! It is only used in the horizontal direction. 56 57 !! For example the i-component of the advective fluxes are given by : 57 58 !! ! e2u e3u un ( mi(Tn) - zltu(i ) ) if un(i) >= 0 58 !! z wx= ! or59 !! ztu = ! or 59 60 !! ! e2u e3u un ( mi(Tn) - zltu(i+1) ) if un(i) < 0 60 61 !! where zltu is the second derivative of the before temperature field: … … 76 77 !! Farrow, D.E., Stevens, D.P., 1995, J. Phys. Ocean. 25, 1731Ð1741. 77 78 !!---------------------------------------------------------------------- 78 USE oce , ONLY: zwx => ua , zwy => va ! (ua,va) used as workspace79 !80 79 INTEGER , INTENT(in ) :: kt ! ocean time-step index 81 80 INTEGER , INTENT(in ) :: kit000 ! first time step index … … 98 97 CALL wrk_alloc( jpi, jpj, jpk, ztu, ztv, zltu, zltv, zti, ztw ) 99 98 ! 100 101 99 IF( kt == kit000 ) THEN 102 100 IF(lwp) WRITE(numout,*) … … 151 149 zcenvt = pvn(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji ,jj+1,jk,jn) ) 152 150 ! UBS advective fluxes 153 z wx(ji,jj,jk) = 0.5 * ( zcenut - zfp_ui * zltu(ji,jj,jk) - zfm_ui * zltu(ji+1,jj,jk) )154 z wy(ji,jj,jk) = 0.5 * ( zcenvt - zfp_vj * zltv(ji,jj,jk) - zfm_vj * zltv(ji,jj+1,jk) )151 ztu(ji,jj,jk) = 0.5 * ( zcenut - zfp_ui * zltu(ji,jj,jk) - zfm_ui * zltu(ji+1,jj,jk) ) 152 ztv(ji,jj,jk) = 0.5 * ( zcenvt - zfp_vj * zltv(ji,jj,jk) - zfm_vj * zltv(ji,jj+1,jk) ) 155 153 END DO 156 154 END DO … … 159 157 zltu(:,:,:) = pta(:,:,:,jn) ! store pta trends 160 158 161 ! Horizontal advective trends 162 DO jk = 1, jpkm1 163 ! Tracer flux divergence at t-point added to the general trend 159 DO jk = 1, jpkm1 ! Horizontal advective trends 164 160 DO jj = 2, jpjm1 165 161 DO ji = fs_2, fs_jpim1 ! vector opt. 166 zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 167 ! horizontal advective 168 ztra = - zbtr * ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk) & 169 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk) ) 170 ! add it to the general tracer trends 171 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra 162 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) & 163 & - ( ztu(ji,jj,jk) - ztu(ji-1,jj ,jk) & 164 & + ztv(ji,jj,jk) - ztv(ji ,jj-1,jk) ) / ( e1e2t(ji,jj) * fse3t(ji,jj,jk) ) 172 165 END DO 173 166 END DO … … 178 171 zltu(:,:,:) = pta(:,:,:,jn) - zltu(:,:,:) 179 172 180 ! 3. Save the horizontal advective trends for diagnostic 181 ! ------------------------------------------------------ 182 ! ! trend diagnostics (contribution of upstream fluxes) 183 IF( l_trd ) THEN 184 CALL trd_tra( kt, cdtype, jn, jptra_trd_xad, zwx, pun, ptn(:,:,:,jn) ) 185 CALL trd_tra( kt, cdtype, jn, jptra_trd_yad, zwy, pvn, ptn(:,:,:,jn) ) 173 ! 174 IF( l_trd ) THEN ! trend diagnostics 175 CALL trd_tra( kt, cdtype, jn, jptra_xad, ztu, pun, ptn(:,:,:,jn) ) 176 CALL trd_tra( kt, cdtype, jn, jptra_yad, ztv, pvn, ptn(:,:,:,jn) ) 186 177 END IF 187 178 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 188 179 IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN 189 IF( jn == jp_tem ) htr_adv(:) = ptr_vj( z wy(:,:,:) )190 IF( jn == jp_sal ) str_adv(:) = ptr_vj( z wy(:,:,:) )180 IF( jn == jp_tem ) htr_adv(:) = ptr_vj( ztv(:,:,:) ) 181 IF( jn == jp_sal ) str_adv(:) = ptr_vj( ztv(:,:,:) ) 191 182 ENDIF 192 183 … … 265 256 END DO 266 257 END DO 267 CALL trd_tra( kt, cdtype, jn, jptra_ trd_zad, zltv )258 CALL trd_tra( kt, cdtype, jn, jptra_zad, zltv ) 268 259 ENDIF 269 260 ! 270 END DO261 END DO 271 262 ! 272 263 CALL wrk_dealloc( jpi, jpj, jpk, ztu, ztv, zltu, zltv, zti, ztw ) … … 290 281 !! in-space based differencing for fluid 291 282 !!---------------------------------------------------------------------- 292 !293 283 REAL(wp), INTENT(in ), DIMENSION(jpk) :: p2dt ! vertical profile of tracer time-step 294 284 REAL(wp), DIMENSION (jpi,jpj,jpk) :: pbef ! before field … … 306 296 CALL wrk_alloc( jpi, jpj, jpk, zbetup, zbetdo ) 307 297 ! 308 309 298 zbig = 1.e+40_wp 310 299 zrtrn = 1.e-15_wp -
branches/2014/dev_r4650_UKMO7_STARTHOUR/NEMOGCM/NEMO/OPA_SRC/TRA/trabbc.F90
r4624 r5075 18 18 USE dom_oce ! domain: ocean 19 19 USE phycst ! physical constants 20 USE trd mod_oce ! trends: ocean variables21 USE trdtra ! trends : activetracers20 USE trd_oce ! trends: ocean variables 21 USE trdtra ! trends manager: tracers 22 22 USE in_out_manager ! I/O manager 23 23 USE prtctl ! Print control … … 84 84 ! 85 85 ! ! Add the geothermal heat flux trend on temperature 86 #if defined key_vectopt_loop87 DO jj = 1, 188 DO ji = jpi+2, jpij-jpi-1 ! vector opt. (forced unrolling)89 #else90 86 DO jj = 2, jpjm1 91 87 DO ji = 2, jpim1 92 #endif93 88 ik = mbkt(ji,jj) 94 89 zqgh_trd = qgh_trd0(ji,jj) / fse3t(ji,jj,ik) … … 99 94 IF( l_trdtra ) THEN ! Save the geothermal heat flux trend for diagnostics 100 95 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 101 CALL trd_tra( kt, 'TRA', jp_tem, jptra_ trd_bbc, ztrdt )96 CALL trd_tra( kt, 'TRA', jp_tem, jptra_bbc, ztrdt ) 102 97 CALL wrk_dealloc( jpi, jpj, jpk, ztrdt ) 103 98 ENDIF … … 130 125 INTEGER :: inum ! temporary logical unit 131 126 INTEGER :: ios ! Local integer output status for namelist read 132 ! !127 ! 133 128 NAMELIST/nambbc/ln_trabbc, nn_geoflx, rn_geoflx_cst 134 129 !!---------------------------------------------------------------------- -
branches/2014/dev_r4650_UKMO7_STARTHOUR/NEMOGCM/NEMO/OPA_SRC/TRA/trabbl.F90
r4624 r5075 12 12 !! - ! 2010-06 (C. Ethe, G. Madec) merge TRA-TRC 13 13 !! - ! 2010-11 (G. Madec) add mbk. arrays associated to the deepest ocean level 14 !! - ! 2013-04 (F. Roquet, G. Madec) use of eosbn2 instead of local hard coded alpha and beta 14 15 !!---------------------------------------------------------------------- 15 16 #if defined key_trabbl || defined key_esopa … … 28 29 USE phycst ! physical constant 29 30 USE eosbn2 ! equation of state 30 USE trd mod_oce ! trends: ocean variables31 USE trd_oce ! trends: ocean variables 31 32 USE trdtra ! trends: active tracers 32 USE iom ! IOM server 33 ! 34 USE iom ! IOM library 33 35 USE in_out_manager ! I/O manager 34 36 USE lbclnk ! ocean lateral boundary conditions … … 36 38 USE wrk_nemo ! Memory Allocation 37 39 USE timing ! Timing 38 40 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 39 41 40 42 IMPLICIT NONE … … 57 59 REAL(wp), PUBLIC :: rn_gambbl !: lateral coeff. for bottom boundary layer scheme [s] 58 60 59 LOGICAL , PUBLIC :: l_bbl 61 LOGICAL , PUBLIC :: l_bbl !: flag to compute bbl diffu. flux coef and transport 60 62 61 63 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: utr_bbl , vtr_bbl ! u- (v-) transport in the bottom boundary layer … … 84 86 & vtr_bbl (jpi,jpj) , ahv_bbl (jpi,jpj) , mbkv_d (jpi,jpj) , mgrhv(jpi,jpj) , & 85 87 & ahu_bbl_0(jpi,jpj) , ahv_bbl_0(jpi,jpj) , & 86 & e3u_bbl_0(jpi,jpj) , e3v_bbl_0(jpi,jpj) , STAT= tra_bbl_alloc)88 & e3u_bbl_0(jpi,jpj) , e3v_bbl_0(jpi,jpj) , STAT=tra_bbl_alloc ) 87 89 ! 88 90 IF( lk_mpp ) CALL mpp_sum ( tra_bbl_alloc ) … … 104 106 !!---------------------------------------------------------------------- 105 107 INTEGER, INTENT( in ) :: kt ! ocean time-step 106 ! !108 ! 107 109 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdt, ztrds 108 110 !!---------------------------------------------------------------------- … … 110 112 IF( nn_timing == 1 ) CALL timing_start( 'tra_bbl') 111 113 ! 112 IF( l_trdtra ) THEN !* Save ta and sa trends114 IF( l_trdtra ) THEN !* Save ta and sa trends 113 115 CALL wrk_alloc( jpi, jpj, jpk, ztrdt, ztrds ) 114 116 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) … … 116 118 ENDIF 117 119 118 IF( l_bbl ) CALL bbl( kt, nit000, 'TRA' ) !* bbl coef. and transport (only if not already done in trcbbl)119 120 IF( nn_bbl_ldf == 1 ) THEN !* Diffusive bbl120 IF( l_bbl ) CALL bbl( kt, nit000, 'TRA' ) !* bbl coef. and transport (only if not already done in trcbbl) 121 122 IF( nn_bbl_ldf == 1 ) THEN !* Diffusive bbl 121 123 ! 122 124 CALL tra_bbl_dif( tsb, tsa, jpts ) 123 125 IF( ln_ctl ) & 124 126 CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' bbl_ldf - Ta: ', mask1=tmask, & 125 &tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' )127 & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 126 128 ! lateral boundary conditions ; just need for outputs 127 129 CALL lbc_lnk( ahu_bbl, 'U', 1. ) ; CALL lbc_lnk( ahv_bbl, 'V', 1. ) … … 131 133 END IF 132 134 133 IF( nn_bbl_adv /= 0 ) THEN !* Advective bbl135 IF( nn_bbl_adv /= 0 ) THEN !* Advective bbl 134 136 ! 135 137 CALL tra_bbl_adv( tsb, tsa, jpts ) 136 138 IF(ln_ctl) & 137 139 CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' bbl_adv - Ta: ', mask1=tmask, & 138 &tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' )140 & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 139 141 ! lateral boundary conditions ; just need for outputs 140 142 CALL lbc_lnk( utr_bbl, 'U', 1. ) ; CALL lbc_lnk( vtr_bbl, 'V', 1. ) … … 147 149 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 148 150 ztrds(:,:,:) = tsa(:,:,:,jp_sal) - ztrds(:,:,:) 149 CALL trd_tra( kt, 'TRA', jp_tem, jptra_ trd_bbl, ztrdt )150 CALL trd_tra( kt, 'TRA', jp_sal, jptra_ trd_bbl, ztrds )151 CALL trd_tra( kt, 'TRA', jp_tem, jptra_bbl, ztrdt ) 152 CALL trd_tra( kt, 'TRA', jp_sal, jptra_bbl, ztrds ) 151 153 CALL wrk_dealloc( jpi, jpj, jpk, ztrdt, ztrds ) 152 154 ENDIF … … 164 166 !! advection terms. 165 167 !! 166 !! ** Method : 167 !! * diffusive bbl (nn_bbl_ldf=1) : 168 !! ** Method : * diffusive bbl only (nn_bbl_ldf=1) : 168 169 !! When the product grad( rho) * grad(h) < 0 (where grad is an 169 170 !! along bottom slope gradient) an additional lateral 2nd order … … 179 180 !! Campin, J.-M., and H. Goosse, 1999, Tellus, 412-430. 180 181 !!---------------------------------------------------------------------- 181 !182 182 INTEGER , INTENT(in ) :: kjpt ! number of tracers 183 183 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb ! before and now tracer fields … … 196 196 DO jn = 1, kjpt ! tracer loop 197 197 ! ! =========== 198 # if defined key_vectopt_loop199 DO jj = 1, 1 ! vector opt. (forced unrolling)200 DO ji = 1, jpij201 #else202 198 DO jj = 1, jpj 203 199 DO ji = 1, jpi 204 #endif 205 ik = mbkt(ji,jj) ! bottom T-level index 206 zptb(ji,jj) = ptb(ji,jj,ik,jn) ! bottom before T and S 200 ik = mbkt(ji,jj) ! bottom T-level index 201 zptb(ji,jj) = ptb(ji,jj,ik,jn) ! bottom before T and S 207 202 END DO 208 203 END DO 209 ! ! Compute the trend 210 # if defined key_vectopt_loop 211 DO jj = 1, 1 ! vector opt. (forced unrolling) 212 DO ji = jpi+1, jpij-jpi-1 213 # else 214 DO jj = 2, jpjm1 204 ! 205 DO jj = 2, jpjm1 ! Compute the trend 215 206 DO ji = 2, jpim1 216 # endif 217 ik = mbkt(ji,jj) ! bottom T-level index 207 ik = mbkt(ji,jj) ! bottom T-level index 218 208 zbtr = r1_e12t(ji,jj) / fse3t(ji,jj,ik) 219 209 pta(ji,jj,ik,jn) = pta(ji,jj,ik,jn) & … … 264 254 DO jn = 1, kjpt ! tracer loop 265 255 ! ! =========== 266 # if defined key_vectopt_loop267 DO jj = 1, 1268 DO ji = 1, jpij-jpi-1 ! vector opt. (forced unrolling)269 # else270 256 DO jj = 1, jpjm1 271 257 DO ji = 1, jpim1 ! CAUTION start from i=1 to update i=2 when cyclic east-west 272 # endif273 258 IF( utr_bbl(ji,jj) /= 0.e0 ) THEN ! non-zero i-direction bbl advection 274 259 ! down-slope i/k-indices (deep) & up-slope i/k indices (shelf) … … 333 318 !! advection terms. 334 319 !! 335 !! ** Method : 336 !! * diffusive bbl (nn_bbl_ldf=1) : 320 !! ** Method : * diffusive bbl (nn_bbl_ldf=1) : 337 321 !! When the product grad( rho) * grad(h) < 0 (where grad is an 338 322 !! along bottom slope gradient) an additional lateral 2nd order … … 342 326 !! a downslope velocity of 20 cm/s if the condition for slope 343 327 !! convection is satified) 344 !! * advective bbl (nn_bbl_adv=1 or 2) :328 !! * advective bbl (nn_bbl_adv=1 or 2) : 345 329 !! nn_bbl_adv = 1 use of the ocean velocity as bbl velocity 346 330 !! nn_bbl_adv = 2 follow Campin and Goosse (1999) implentation … … 353 337 !! Campin, J.-M., and H. Goosse, 1999, Tellus, 412-430. 354 338 !!---------------------------------------------------------------------- 355 !356 339 INTEGER , INTENT(in ) :: kt ! ocean time-step index 357 INTEGER , INTENT(in ) :: kit000 340 INTEGER , INTENT(in ) :: kit000 ! first time step index 358 341 CHARACTER(len=3), INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 359 342 !! 360 343 INTEGER :: ji, jj ! dummy loop indices 361 344 INTEGER :: ik ! local integers 362 INTEGER :: iis , iid , ijs , ijd ! - - 363 INTEGER :: ikus, ikud, ikvs, ikvd ! - - 364 REAL(wp) :: zsign, zsigna, zgbbl ! local scalars 365 REAL(wp) :: zgdrho, zt, zs, zh ! - - 366 !! 367 REAL(wp) :: fsalbt, fsbeta, pft, pfs, pfh ! statement function 368 REAL(wp), POINTER, DIMENSION(:,:) :: zub, zvb, ztb, zsb, zdep 369 !!----------------------- zv_bbl----------------------------------------------- 370 ! ratio alpha/beta = fsalbt : ratio of thermal over saline expension coefficients 371 ! ================ pft : potential temperature in degrees celcius 372 ! pfs : salinity anomaly (s-35) in psu 373 ! pfh : depth in meters 374 ! nn_eos = 0 (Jackett and McDougall 1994 formulation) 375 fsalbt( pft, pfs, pfh ) = & ! alpha/beta 376 ( ( ( -0.255019e-07 * pft + 0.298357e-05 ) * pft & 377 - 0.203814e-03 ) * pft & 378 + 0.170907e-01 ) * pft & 379 + 0.665157e-01 & 380 +(-0.678662e-05 * pfs - 0.846960e-04 * pft + 0.378110e-02 ) * pfs & 381 + ( ( - 0.302285e-13 * pfh & 382 - 0.251520e-11 * pfs & 383 + 0.512857e-12 * pft * pft ) * pfh & 384 - 0.164759e-06 * pfs & 385 +( 0.791325e-08 * pft - 0.933746e-06 ) * pft & 386 + 0.380374e-04 ) * pfh 387 fsbeta( pft, pfs, pfh ) = & ! beta 388 ( ( -0.415613e-09 * pft + 0.555579e-07 ) * pft & 389 - 0.301985e-05 ) * pft & 390 + 0.785567e-03 & 391 + ( 0.515032e-08 * pfs & 392 + 0.788212e-08 * pft - 0.356603e-06 ) * pfs & 393 +( ( 0.121551e-17 * pfh & 394 - 0.602281e-15 * pfs & 395 - 0.175379e-14 * pft + 0.176621e-12 ) * pfh & 396 + 0.408195e-10 * pfs & 397 + ( - 0.213127e-11 * pft + 0.192867e-09 ) * pft & 398 - 0.121555e-07 ) * pfh 399 !!---------------------------------------------------------------------- 400 345 INTEGER :: iis, iid, ikus, ikud ! - - 346 INTEGER :: ijs, ijd, ikvs, ikvd ! - - 347 REAL(wp) :: za, zb, zgdrho ! local scalars 348 REAL(wp) :: zsign, zsigna, zgbbl ! - - 349 REAL(wp), DIMENSION(jpi,jpj,jpts) :: zts, zab ! 3D workspace 350 REAL(wp), DIMENSION(jpi,jpj) :: zub, zvb, zdep ! 2D workspace 351 !!---------------------------------------------------------------------- 401 352 ! 402 353 IF( nn_timing == 1 ) CALL timing_start( 'bbl') 403 354 ! 404 CALL wrk_alloc( jpi, jpj, zub, zvb, ztb, zsb, zdep )405 !406 407 355 IF( kt == kit000 ) THEN 408 356 IF(lwp) WRITE(numout,*) … … 410 358 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 411 359 ENDIF 412 413 ! !* bottom temperature, salinity, velocity and depth 414 #if defined key_vectopt_loop 415 DO jj = 1, 1 ! vector opt. (forced unrolling) 416 DO ji = 1, jpij 417 #else 360 ! !* bottom variables (T, S, alpha, beta, depth, velocity) 418 361 DO jj = 1, jpj 419 362 DO ji = 1, jpi 420 #endif 421 ik = mbkt(ji,jj) ! bottom T-level index 422 ztb (ji,jj) = tsb(ji,jj,ik,jp_tem) * tmask(ji,jj,1) ! bottom before T and S 423 zsb (ji,jj) = tsb(ji,jj,ik,jp_sal) * tmask(ji,jj,1) 424 zdep(ji,jj) = gdept_0(ji,jj,ik) ! bottom T-level reference depth 363 ik = mbkt(ji,jj) ! bottom T-level index 364 zts (ji,jj,jp_tem) = tsb(ji,jj,ik,jp_tem) ! bottom before T and S 365 zts (ji,jj,jp_sal) = tsb(ji,jj,ik,jp_sal) 425 366 ! 426 zub(ji,jj) = un(ji,jj,mbku(ji,jj)) ! bottom velocity 427 zvb(ji,jj) = vn(ji,jj,mbkv(ji,jj)) 367 zdep(ji,jj) = fsdept(ji,jj,ik) ! bottom T-level reference depth 368 zub (ji,jj) = un(ji,jj,mbku(ji,jj)) ! bottom velocity 369 zvb (ji,jj) = vn(ji,jj,mbkv(ji,jj)) 428 370 END DO 429 371 END DO 430 372 ! 373 CALL eos_rab( zts, zdep, zab ) 374 ! 431 375 ! !-------------------! 432 376 IF( nn_bbl_ldf == 1 ) THEN ! diffusive bbl ! 433 377 ! !-------------------! 434 378 DO jj = 1, jpjm1 ! (criteria for non zero flux: grad(rho).grad(h) < 0 ) 435 DO ji = 1, jpim1 436 ! ! i-direction 437 zt = 0.5 * ( ztb (ji,jj) + ztb (ji+1,jj) ) ! T, S anomalie, and depth 438 zs = 0.5 * ( zsb (ji,jj) + zsb (ji+1,jj) ) - 35.0 439 zh = 0.5 * ( zdep(ji,jj) + zdep(ji+1,jj) ) 440 ! ! masked bbl i-gradient of density 441 zgdrho = ( fsalbt( zt, zs, zh ) * ( ztb(ji+1,jj) - ztb(ji,jj) ) & 442 & - ( zsb(ji+1,jj) - zsb(ji,jj) ) ) * umask(ji,jj,1) 379 DO ji = 1, fs_jpim1 ! vector opt. 380 ! ! i-direction 381 za = zab(ji+1,jj,jp_tem) + zab(ji,jj,jp_tem) ! 2*(alpha,beta) at u-point 382 zb = zab(ji+1,jj,jp_sal) + zab(ji,jj,jp_sal) 383 ! ! 2*masked bottom density gradient 384 zgdrho = ( za * ( zts(ji+1,jj,jp_tem) - zts(ji,jj,jp_tem) ) & 385 & - zb * ( zts(ji+1,jj,jp_sal) - zts(ji,jj,jp_sal) ) ) * umask(ji,jj,1) 443 386 ! 444 zsign = SIGN( 0.5, -zgdrho * REAL( mgrhu(ji,jj) ) ) ! sign of ( i-gradient * i-slope )445 ahu_bbl(ji,jj) = ( 0.5 - zsign ) * ahu_bbl_0(ji,jj) 387 zsign = SIGN( 0.5, -zgdrho * REAL( mgrhu(ji,jj) ) ) ! sign of ( i-gradient * i-slope ) 388 ahu_bbl(ji,jj) = ( 0.5 - zsign ) * ahu_bbl_0(ji,jj) ! masked diffusive flux coeff. 446 389 ! 447 ! ! j-direction 448 zt = 0.5 * ( ztb (ji,jj+1) + ztb (ji,jj) ) ! T, S anomalie, and depth 449 zs = 0.5 * ( zsb (ji,jj+1) + zsb (ji,jj) ) - 35.0 450 zh = 0.5 * ( zdep(ji,jj+1) + zdep(ji,jj) ) 451 ! ! masked bbl j-gradient of density 452 zgdrho = ( fsalbt( zt, zs, zh ) * ( ztb(ji,jj+1) - ztb(ji,jj) ) & 453 & - ( zsb(ji,jj+1) - zsb(ji,jj) ) ) * vmask(ji,jj,1) 390 ! ! j-direction 391 za = zab(ji,jj+1,jp_tem) + zab(ji,jj,jp_tem) ! 2*(alpha,beta) at v-point 392 zb = zab(ji,jj+1,jp_sal) + zab(ji,jj,jp_sal) 393 ! ! 2*masked bottom density gradient 394 zgdrho = ( za * ( zts(ji,jj+1,jp_tem) - zts(ji,jj,jp_tem) ) & 395 & - zb * ( zts(ji,jj+1,jp_sal) - zts(ji,jj,jp_sal) ) ) * vmask(ji,jj,1) 454 396 ! 455 zsign 397 zsign = SIGN( 0.5, -zgdrho * REAL( mgrhv(ji,jj) ) ) ! sign of ( j-gradient * j-slope ) 456 398 ahv_bbl(ji,jj) = ( 0.5 - zsign ) * ahv_bbl_0(ji,jj) 457 !458 399 END DO 459 400 END DO … … 469 410 DO jj = 1, jpjm1 ! criteria: grad(rho).grad(h)<0 and grad(rho).grad(h)<0 470 411 DO ji = 1, fs_jpim1 ! vector opt. 471 ! ! i-direction 472 zt = 0.5 * ( ztb (ji,jj) + ztb (ji+1,jj) ) ! T, S anomalie, and depth 473 zs = 0.5 * ( zsb (ji,jj) + zsb (ji+1,jj) ) - 35.0 474 zh = 0.5 * ( zdep(ji,jj) + zdep(ji+1,jj) ) 475 ! ! masked bbl i-gradient of density 476 zgdrho = ( fsalbt( zt, zs, zh ) * ( ztb(ji+1,jj) - ztb(ji,jj) ) & 477 & - ( zsb(ji+1,jj) - zsb(ji,jj) ) ) * umask(ji,jj,1) 478 ! 479 zsign = SIGN( 0.5, - zgdrho * REAL( mgrhu(ji,jj) ) ) ! sign of i-gradient * i-slope 480 zsigna= SIGN( 0.5, zub(ji,jj) * REAL( mgrhu(ji,jj) ) ) ! sign of u * i-slope 481 ! 482 ! ! bbl velocity 412 ! ! i-direction 413 za = zab(ji+1,jj,jp_tem) + zab(ji,jj,jp_tem) ! 2*(alpha,beta) at u-point 414 zb = zab(ji+1,jj,jp_sal) + zab(ji,jj,jp_sal) 415 ! ! 2*masked bottom density gradient 416 zgdrho = ( za * ( zts(ji+1,jj,jp_tem) - zts(ji,jj,jp_tem) ) & 417 - zb * ( zts(ji+1,jj,jp_sal) - zts(ji,jj,jp_sal) ) ) * umask(ji,jj,1) 418 ! 419 zsign = SIGN( 0.5, - zgdrho * REAL( mgrhu(ji,jj) ) ) ! sign of i-gradient * i-slope 420 zsigna= SIGN( 0.5, zub(ji,jj) * REAL( mgrhu(ji,jj) ) ) ! sign of u * i-slope 421 ! 422 ! ! bbl velocity 483 423 utr_bbl(ji,jj) = ( 0.5 + zsigna ) * ( 0.5 - zsign ) * e2u(ji,jj) * e3u_bbl_0(ji,jj) * zub(ji,jj) 484 424 ! 485 ! ! j-direction 486 zt = 0.5 * ( ztb (ji,jj+1) + ztb (ji,jj) ) ! T, S anomalie, and depth 487 zs = 0.5 * ( zsb (ji,jj+1) + zsb (ji,jj) ) - 35.0 488 zh = 0.5 * ( zdep(ji,jj+1) + zdep(ji,jj) ) 489 ! ! masked bbl j-gradient of density 490 zgdrho = ( fsalbt( zt, zs, zh ) * ( ztb(ji,jj+1) - ztb(ji,jj) ) & 491 & - ( zsb(ji,jj+1) - zsb(ji,jj) ) ) * vmask(ji,jj,1) 492 zsign = SIGN( 0.5, - zgdrho * REAL( mgrhv(ji,jj) ) ) ! sign of j-gradient * j-slope 493 zsigna= SIGN( 0.5, zvb(ji,jj) * REAL( mgrhv(ji,jj) ) ) ! sign of u * i-slope 494 ! 495 ! ! bbl velocity 425 ! ! j-direction 426 za = zab(ji,jj+1,jp_tem) + zab(ji,jj,jp_tem) ! 2*(alpha,beta) at v-point 427 zb = zab(ji,jj+1,jp_sal) + zab(ji,jj,jp_sal) 428 ! ! 2*masked bottom density gradient 429 zgdrho = ( za * ( zts(ji,jj+1,jp_tem) - zts(ji,jj,jp_tem) ) & 430 & - zb * ( zts(ji,jj+1,jp_sal) - zts(ji,jj,jp_sal) ) ) * vmask(ji,jj,1) 431 zsign = SIGN( 0.5, - zgdrho * REAL( mgrhv(ji,jj) ) ) ! sign of j-gradient * j-slope 432 zsigna= SIGN( 0.5, zvb(ji,jj) * REAL( mgrhv(ji,jj) ) ) ! sign of u * i-slope 433 ! 434 ! ! bbl transport 496 435 vtr_bbl(ji,jj) = ( 0.5 + zsigna ) * ( 0.5 - zsign ) * e1v(ji,jj) * e3v_bbl_0(ji,jj) * zvb(ji,jj) 497 436 END DO … … 502 441 DO jj = 1, jpjm1 ! criteria: rho_up > rho_down 503 442 DO ji = 1, fs_jpim1 ! vector opt. 504 ! ! i-direction443 ! ! i-direction 505 444 ! down-slope T-point i/k-index (deep) & up-slope T-point i/k-index (shelf) 506 iid = ji + MAX( 0, mgrhu(ji,jj) ) ; iis = ji + 1 - MAX( 0, mgrhu(ji,jj) ) 507 ikud = mbku_d(ji,jj) ; ikus = mbku(ji,jj) 508 ! 509 ! ! mid-depth density anomalie (up-slope minus down-slope) 510 zt = 0.5 * ( ztb (ji,jj) + ztb (ji+1,jj) ) ! mid slope depth of T, S, and depth 511 zs = 0.5 * ( zsb (ji,jj) + zsb (ji+1,jj) ) - 35.0 512 zh = 0.5 * ( zdep(ji,jj) + zdep(ji+1,jj) ) 513 zgdrho = fsbeta( zt, zs, zh ) & 514 & * ( fsalbt( zt, zs, zh ) * ( ztb(iid,jj) - ztb(iis,jj) ) & 515 & - ( zsb(iid,jj) - zsb(iis,jj) ) ) * umask(ji,jj,1) 516 zgdrho = MAX( 0.e0, zgdrho ) ! only if shelf is denser than deep 517 ! 518 ! ! bbl transport (down-slope direction) 445 iid = ji + MAX( 0, mgrhu(ji,jj) ) 446 iis = ji + 1 - MAX( 0, mgrhu(ji,jj) ) 447 ! 448 ikud = mbku_d(ji,jj) 449 ikus = mbku(ji,jj) 450 ! 451 za = zab(ji+1,jj,jp_tem) + zab(ji,jj,jp_tem) ! 2*(alpha,beta) at u-point 452 zb = zab(ji+1,jj,jp_sal) + zab(ji,jj,jp_sal) 453 ! ! masked bottom density gradient 454 zgdrho = 0.5 * ( za * ( zts(iid,jj,jp_tem) - zts(iis,jj,jp_tem) ) & 455 & - zb * ( zts(iid,jj,jp_sal) - zts(iis,jj,jp_sal) ) ) * umask(ji,jj,1) 456 zgdrho = MAX( 0.e0, zgdrho ) ! only if shelf is denser than deep 457 ! 458 ! ! bbl transport (down-slope direction) 519 459 utr_bbl(ji,jj) = e2u(ji,jj) * e3u_bbl_0(ji,jj) * zgbbl * zgdrho * REAL( mgrhu(ji,jj) ) 520 460 ! 521 ! ! j-direction461 ! ! j-direction 522 462 ! down-slope T-point j/k-index (deep) & of the up -slope T-point j/k-index (shelf) 523 ijd = jj + MAX( 0, mgrhv(ji,jj) ) ; ijs = jj + 1 - MAX( 0, mgrhv(ji,jj) ) 524 ikvd = mbkv_d(ji,jj) ; ikvs = mbkv(ji,jj) 525 ! 526 ! ! mid-depth density anomalie (up-slope minus down-slope) 527 zt = 0.5 * ( ztb (ji,jj) + ztb (ji,jj+1) ) ! mid slope depth of T, S, and depth 528 zs = 0.5 * ( zsb (ji,jj) + zsb (ji,jj+1) ) - 35.0 529 zh = 0.5 * ( zdep(ji,jj) + zdep(ji,jj+1) ) 530 zgdrho = fsbeta( zt, zs, zh ) & 531 & * ( fsalbt( zt, zs, zh ) * ( ztb(ji,ijd) - ztb(ji,ijs) ) & 532 & - ( zsb(ji,ijd) - zsb(ji,ijs) ) ) * vmask(ji,jj,1) 533 zgdrho = MAX( 0.e0, zgdrho ) ! only if shelf is denser than deep 534 ! 535 ! ! bbl transport (down-slope direction) 463 ijd = jj + MAX( 0, mgrhv(ji,jj) ) 464 ijs = jj + 1 - MAX( 0, mgrhv(ji,jj) ) 465 ! 466 ikvd = mbkv_d(ji,jj) 467 ikvs = mbkv(ji,jj) 468 ! 469 za = zab(ji,jj+1,jp_tem) + zab(ji,jj,jp_tem) ! 2*(alpha,beta) at v-point 470 zb = zab(ji,jj+1,jp_sal) + zab(ji,jj,jp_sal) 471 ! ! masked bottom density gradient 472 zgdrho = 0.5 * ( za * ( zts(ji,ijd,jp_tem) - zts(ji,ijs,jp_tem) ) & 473 & - zb * ( zts(ji,ijd,jp_sal) - zts(ji,ijs,jp_sal) ) ) * vmask(ji,jj,1) 474 zgdrho = MAX( 0.e0, zgdrho ) ! only if shelf is denser than deep 475 ! 476 ! ! bbl transport (down-slope direction) 536 477 vtr_bbl(ji,jj) = e1v(ji,jj) * e3v_bbl_0(ji,jj) * zgbbl * zgdrho * REAL( mgrhv(ji,jj) ) 537 478 END DO … … 541 482 ENDIF 542 483 ! 543 CALL wrk_dealloc( jpi, jpj, zub, zvb, ztb, zsb, zdep )544 !545 484 IF( nn_timing == 1 ) CALL timing_stop( 'bbl') 546 485 ! … … 558 497 !!---------------------------------------------------------------------- 559 498 INTEGER :: ji, jj ! dummy loop indices 560 INTEGER :: ii0, ii1, ij0, ij1 ! temporaryinteger561 INTEGER :: ios ! Local integer output status for namelist read499 INTEGER :: ii0, ii1, ij0, ij1 ! local integer 500 INTEGER :: ios ! - - 562 501 REAL(wp), POINTER, DIMENSION(:,:) :: zmbk 563 502 !! … … 598 537 IF( nn_bbl_adv == 2 ) WRITE(numout,*) ' * Advective BBL using velocity = F( delta rho)' 599 538 600 IF( nn_eos /= 0 ) CALL ctl_stop ( ' bbl parameterisation requires eos = 0. We stop.' )601 602 539 ! !* vertical index of "deep" bottom u- and v-points 603 540 DO jj = 1, jpjm1 ! (the "shelf" bottom k-indices are mbku and mbkv) … … 607 544 END DO 608 545 END DO 609 ! convert into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk546 ! converte into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk 610 547 zmbk(:,:) = REAL( mbku_d(:,:), wp ) ; CALL lbc_lnk(zmbk,'U',1.) ; mbku_d(:,:) = MAX( INT( zmbk(:,:) ), 1 ) 611 548 zmbk(:,:) = REAL( mbkv_d(:,:), wp ) ; CALL lbc_lnk(zmbk,'V',1.) ; mbkv_d(:,:) = MAX( INT( zmbk(:,:) ), 1 ) 612 549 613 !* sign of grad(H) at u- and v-points614 mgrhu(jpi,:) = 0 . ; mgrhu(:,jpj) = 0. ; mgrhv(jpi,:) = 0. ; mgrhv(:,jpj) = 0.550 !* sign of grad(H) at u- and v-points 551 mgrhu(jpi,:) = 0 ; mgrhu(:,jpj) = 0 ; mgrhv(jpi,:) = 0 ; mgrhv(:,jpj) = 0 615 552 DO jj = 1, jpjm1 616 553 DO ji = 1, jpim1 … … 621 558 622 559 DO jj = 1, jpjm1 !* bbl thickness at u- (v-) point 623 DO ji = 1, jpim1 ! minimum of top & bottom e3u_0 (e3v_0)560 DO ji = 1, jpim1 ! minimum of top & bottom e3u_0 (e3v_0) 624 561 e3u_bbl_0(ji,jj) = MIN( e3u_0(ji,jj,mbkt(ji+1,jj )), e3u_0(ji,jj,mbkt(ji,jj)) ) 625 562 e3v_bbl_0(ji,jj) = MIN( e3v_0(ji,jj,mbkt(ji ,jj+1)), e3v_0(ji,jj,mbkt(ji,jj)) ) -
branches/2014/dev_r4650_UKMO7_STARTHOUR/NEMOGCM/NEMO/OPA_SRC/TRA/tradmp.F90
r4624 r5075 28 28 USE dom_oce ! ocean: domain variables 29 29 USE c1d ! 1D vertical configuration 30 USE trd mod_oce ! ocean: trendvariables31 USE trdtra ! active tracers: trends30 USE trd_oce ! trends: ocean variables 31 USE trdtra ! trends manager: tracers 32 32 USE zdf_oce ! ocean: vertical physics 33 33 USE phycst ! physical constants … … 48 48 PUBLIC dtacof_zoom ! routine called by tradmp.F90, trcdmp.F90 and dyndmp.F90 49 49 50 !!gm why all namelist variable public???? only ln_tradmp should be sufficient 51 50 52 ! !!* Namelist namtra_dmp : T & S newtonian damping * 51 53 LOGICAL , PUBLIC :: ln_tradmp !: internal damping flag … … 112 114 ! 113 115 CALL wrk_alloc( jpi, jpj, jpk, jpts, zts_dta ) 116 ! 114 117 ! !== input T-S data at kt ==! 115 118 CALL dta_tsd( kt, zts_dta ) ! read and interpolates T-S data at kt … … 172 175 ! 173 176 IF( l_trdtra ) THEN ! trend diagnostic 174 CALL trd_tra( kt, 'TRA', jp_tem, jptra_ trd_dmp, ttrdmp )175 CALL trd_tra( kt, 'TRA', jp_sal, jptra_ trd_dmp, strdmp )177 CALL trd_tra( kt, 'TRA', jp_tem, jptra_dmp, ttrdmp ) 178 CALL trd_tra( kt, 'TRA', jp_sal, jptra_dmp, strdmp ) 176 179 ENDIF 177 180 ! ! Control print … … 194 197 !! ** Method : read the namtra_dmp namelist and check the parameters 195 198 !!---------------------------------------------------------------------- 199 INTEGER :: ios ! Local integer output status for namelist read 200 !! 196 201 NAMELIST/namtra_dmp/ ln_tradmp, nn_hdmp, nn_zdmp, rn_surf, rn_bot, rn_dep, nn_file 197 INTEGER :: ios ! Local integer output status for namelist read 198 !!---------------------------------------------------------------------- 199 202 !!---------------------------------------------------------------------- 203 ! 200 204 REWIND( numnam_ref ) ! Namelist namtra_dmp in reference namelist : Temperature and salinity damping term 201 205 READ ( numnam_ref, namtra_dmp, IOSTAT = ios, ERR = 901) 202 206 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_dmp in reference namelist', lwp ) 203 207 ! 204 208 REWIND( numnam_cfg ) ! Namelist namtra_dmp in configuration namelist : Temperature and salinity damping term 205 209 READ ( numnam_cfg, namtra_dmp, IOSTAT = ios, ERR = 902 ) … … 228 232 IF( tra_dmp_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'tra_dmp_init: unable to allocate arrays' ) 229 233 ! 234 !!gm I don't understand the specificities of c1d case...... 235 !!gm to be check with the autor of these lines 236 230 237 #if ! defined key_c1d 231 238 SELECT CASE ( nn_hdmp ) -
branches/2014/dev_r4650_UKMO7_STARTHOUR/NEMOGCM/NEMO/OPA_SRC/TRA/traldf.F90
r4488 r5075 23 23 USE traldf_iso_grif ! lateral mixing (tra_ldf_iso_grif routine) 24 24 USE traldf_lap ! lateral mixing (tra_ldf_lap routine) 25 USE trdmod_oce ! ocean space and time domain 26 USE trdtra ! ocean active tracers trends 25 USE trd_oce ! trends: ocean variables 26 USE trdtra ! trends manager: tracers 27 ! 27 28 USE prtctl ! Print control 28 29 USE in_out_manager ! I/O manager … … 35 36 PRIVATE 36 37 37 PUBLIC tra_ldf 38 PUBLIC tra_ldf_init 38 PUBLIC tra_ldf ! called by step.F90 39 PUBLIC tra_ldf_init ! called by opa.F90 39 40 ! 40 41 INTEGER :: nldf = 0 ! type of lateral diffusion used defined from ln_traldf_... namlist logicals) … … 75 76 76 77 SELECT CASE ( nldf ) ! compute lateral mixing trend and add it to the general trend 77 CASE ( 0 ) ; CALL tra_ldf_lap ( kt, nit000, 'TRA', gtsu, gtsv, tsb, tsa, jpts ) ! iso-level laplacian 78 CASE ( 0 ) ; CALL tra_ldf_lap ( kt, nit000, 'TRA', gtsu, gtsv, gtui, gtvi, & 79 & tsb, tsa, jpts ) ! iso-level laplacian 78 80 CASE ( 1 ) ! rotated laplacian 79 81 IF( ln_traldf_grif ) THEN 80 82 CALL tra_ldf_iso_grif( kt, nit000,'TRA', gtsu, gtsv, tsb, tsa, jpts, ahtb0 ) ! Griffies operator 81 83 ELSE 82 CALL tra_ldf_iso ( kt, nit000, 'TRA', gtsu, gtsv, tsb, tsa, jpts, ahtb0 ) ! Madec operator 83 ENDIF 84 CASE ( 2 ) ; CALL tra_ldf_bilap ( kt, nit000, 'TRA', gtsu, gtsv, tsb, tsa, jpts ) ! iso-level bilaplacian 84 CALL tra_ldf_iso ( kt, nit000, 'TRA', gtsu, gtsv, gtui, gtvi, & 85 & tsb, tsa, jpts, ahtb0 ) ! Madec operator 86 ENDIF 87 CASE ( 2 ) ; CALL tra_ldf_bilap ( kt, nit000, 'TRA', gtsu, gtsv, gtui, gtvi, & 88 & tsb, tsa, jpts ) ! iso-level bilaplacian 85 89 CASE ( 3 ) ; CALL tra_ldf_bilapg ( kt, nit000, 'TRA', tsb, tsa, jpts ) ! s-coord. geopot. bilap. 86 90 ! 87 91 CASE ( -1 ) ! esopa: test all possibility with control print 88 CALL tra_ldf_lap ( kt, nit000, 'TRA', gtsu, gtsv, tsb, tsa, jpts ) 92 CALL tra_ldf_lap ( kt, nit000, 'TRA', gtsu, gtsv, gtui, gtvi, & 93 & tsb, tsa, jpts ) 89 94 CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' ldf0 - Ta: ', mask1=tmask, & 90 95 & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) … … 92 97 CALL tra_ldf_iso_grif( kt, nit000, 'TRA', gtsu, gtsv, tsb, tsa, jpts, ahtb0 ) 93 98 ELSE 94 CALL tra_ldf_iso ( kt, nit000, 'TRA', gtsu, gtsv, tsb, tsa, jpts, ahtb0 ) 99 CALL tra_ldf_iso ( kt, nit000, 'TRA', gtsu, gtsv, gtui, gtvi, & 100 & tsb, tsa, jpts, ahtb0 ) 95 101 ENDIF 96 102 CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' ldf1 - Ta: ', mask1=tmask, & 97 103 & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 98 CALL tra_ldf_bilap ( kt, nit000, 'TRA', gtsu, gtsv, tsb, tsa, jpts ) 104 CALL tra_ldf_bilap ( kt, nit000, 'TRA', gtsu, gtsv, gtui, gtvi, & 105 & tsb, tsa, jpts ) 99 106 CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' ldf2 - Ta: ', mask1=tmask, & 100 107 & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) … … 112 119 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 113 120 ztrds(:,:,:) = tsa(:,:,:,jp_sal) - ztrds(:,:,:) 114 CALL trd_tra( kt, 'TRA', jp_tem, jptra_ trd_ldf, ztrdt )115 CALL trd_tra( kt, 'TRA', jp_sal, jptra_ trd_ldf, ztrds )121 CALL trd_tra( kt, 'TRA', jp_tem, jptra_ldf, ztrdt ) 122 CALL trd_tra( kt, 'TRA', jp_sal, jptra_ldf, ztrds ) 116 123 CALL wrk_dealloc( jpi, jpj, jpk, ztrdt, ztrds ) 117 124 ENDIF … … 174 181 IF ( ln_traldf_iso ) nldf = 1 ! isoneutral ( rotation) 175 182 ENDIF 176 IF ( ln_zps ) THEN ! z -coordinate183 IF ( ln_zps ) THEN ! zps-coordinate 177 184 IF ( ln_traldf_level ) ierr = 1 ! iso-level not allowed 178 185 IF ( ln_traldf_hor ) nldf = 0 ! horizontal (no rotation) 179 186 IF ( ln_traldf_iso ) nldf = 1 ! isoneutral ( rotation) 180 187 ENDIF 181 IF ( ln_sco ) THEN ! z-coordinate188 IF ( ln_sco ) THEN ! s-coordinate 182 189 IF ( ln_traldf_level ) nldf = 0 ! iso-level (no rotation) 183 190 IF ( ln_traldf_hor ) nldf = 1 ! horizontal ( rotation) … … 192 199 IF ( ln_traldf_iso ) ierr = 2 ! isoneutral ( rotation) 193 200 ENDIF 194 IF ( ln_zps ) THEN ! z -coordinate201 IF ( ln_zps ) THEN ! zps-coordinate 195 202 IF ( ln_traldf_level ) ierr = 1 ! iso-level not allowed 196 203 IF ( ln_traldf_hor ) nldf = 2 ! horizontal (no rotation) 197 204 IF ( ln_traldf_iso ) ierr = 2 ! isoneutral ( rotation) 198 205 ENDIF 199 IF ( ln_sco ) THEN ! z-coordinate206 IF ( ln_sco ) THEN ! s-coordinate 200 207 IF ( ln_traldf_level ) nldf = 2 ! iso-level (no rotation) 201 208 IF ( ln_traldf_hor ) nldf = 3 ! horizontal ( rotation) -
branches/2014/dev_r4650_UKMO7_STARTHOUR/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_bilap.F90
r4292 r5075 49 49 CONTAINS 50 50 51 SUBROUTINE tra_ldf_bilap( kt, kit000, cdtype, pgu, pgv, & 51 SUBROUTINE tra_ldf_bilap( kt, kit000, cdtype, pgu, pgv, & 52 & pgui, pgvi, & 52 53 & ptb, pta, kjpt ) 53 54 !!---------------------------------------------------------------------- … … 82 83 CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 83 84 INTEGER , INTENT(in ) :: kjpt ! number of tracers 84 REAL(wp), DIMENSION(jpi,jpj, kjpt), INTENT(in ) :: pgu, pgv ! tracer gradient at pstep levels 85 REAL(wp), DIMENSION(jpi,jpj, kjpt), INTENT(in ) :: pgu , pgv ! tracer gradient at pstep levels 86 REAL(wp), DIMENSION(jpi,jpj, kjpt), INTENT(in ) :: pgui, pgvi ! tracer gradient at pstep levels 85 87 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb ! before and now tracer fields 86 88 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend … … 128 130 IF( mbku(ji,jj) == jk ) ztu(ji,jj,jk) = zeeu(ji,jj) * pgu(ji,jj,jn) 129 131 IF( mbkv(ji,jj) == jk ) ztv(ji,jj,jk) = zeev(ji,jj) * pgv(ji,jj,jn) 132 ! (ISH) 133 IF( miku(ji,jj) == jk ) ztu(ji,jj,jk) = zeeu(ji,jj) * pgui(ji,jj,jn) 134 IF( mikv(ji,jj) == jk ) ztu(ji,jj,jk) = zeev(ji,jj) * pgvi(ji,jj,jn) 130 135 END DO 131 136 END DO -
branches/2014/dev_r4650_UKMO7_STARTHOUR/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_iso.F90
r4292 r5075 52 52 53 53 SUBROUTINE tra_ldf_iso( kt, kit000, cdtype, pgu, pgv, & 54 & pgui, pgvi, & 54 55 & ptb, pta, kjpt, pahtb0 ) 55 56 !!---------------------------------------------------------------------- … … 98 99 CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 99 100 INTEGER , INTENT(in ) :: kjpt ! number of tracers 100 REAL(wp), DIMENSION(jpi,jpj ,kjpt), INTENT(in ) :: pgu, pgv ! tracer gradient at pstep levels 101 REAL(wp), DIMENSION(jpi,jpj ,kjpt), INTENT(in ) :: pgu , pgv ! tracer gradient at pstep levels 102 REAL(wp), DIMENSION(jpi,jpj ,kjpt), INTENT(in ) :: pgui, pgvi ! tracer gradient at pstep levels 101 103 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb ! before and now tracer fields 102 104 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend … … 110 112 REAL(wp) :: zztmp ! local scalar 111 113 #endif 112 REAL(wp), POINTER, DIMENSION(:,: ) :: z dkt, zdk1t, z2d113 REAL(wp), POINTER, DIMENSION(:,:,:) :: zd it, zdjt, ztfw114 REAL(wp), POINTER, DIMENSION(:,: ) :: z2d 115 REAL(wp), POINTER, DIMENSION(:,:,:) :: zdkt, zdk1t, zdit, zdjt, ztfw 114 116 !!---------------------------------------------------------------------- 115 117 ! 116 118 IF( nn_timing == 1 ) CALL timing_start('tra_ldf_iso') 117 119 ! 118 CALL wrk_alloc( jpi, jpj, z dkt, zdk1t, z2d )119 CALL wrk_alloc( jpi, jpj, jpk, zdit, zdjt, ztfw 120 CALL wrk_alloc( jpi, jpj, z2d ) 121 CALL wrk_alloc( jpi, jpj, jpk, zdit, zdjt, ztfw, zdkt, zdk1t ) 120 122 ! 121 123 … … 150 152 DO jj = 1, jpjm1 151 153 DO ji = 1, fs_jpim1 ! vector opt. 152 zdit(ji,jj,mbku(ji,jj)) = pgu(ji,jj,jn) 153 zdjt(ji,jj,mbkv(ji,jj)) = pgv(ji,jj,jn) 154 ! IF useless if zpshde defines pgu everywhere 155 IF (mbku(ji,jj) > 1) zdit(ji,jj,mbku(ji,jj)) = pgu(ji,jj,jn) 156 IF (mbkv(ji,jj) > 1) zdjt(ji,jj,mbkv(ji,jj)) = pgv(ji,jj,jn) 157 ! (ISF) 158 IF (miku(ji,jj) > 1) zdit(ji,jj,miku(ji,jj)) = pgui(ji,jj,jn) 159 IF (mikv(ji,jj) > 1) zdjt(ji,jj,mikv(ji,jj)) = pgvi(ji,jj,jn) 154 160 END DO 155 161 END DO … … 161 167 !CDIR PARALLEL DO PRIVATE( zdk1t ) 162 168 ! ! =============== 163 DO j k = 1, jpkm1! Horizontal slab169 DO jj = 1, jpj ! Horizontal slab 164 170 ! ! =============== 165 ! 1. Vertical tracer gradient at level jk and jk+1 166 ! ------------------------------------------------ 167 ! surface boundary condition: zdkt(jk=1)=zdkt(jk=2) 168 zdk1t(:,:) = ( ptb(:,:,jk,jn) - ptb(:,:,jk+1,jn) ) * tmask(:,:,jk+1) 169 ! 170 IF( jk == 1 ) THEN ; zdkt(:,:) = zdk1t(:,:) 171 ELSE ; zdkt(:,:) = ( ptb(:,:,jk-1,jn) - ptb(:,:,jk,jn) ) * tmask(:,:,jk) 172 ENDIF 171 DO ji = 1, jpi ! vector opt. 172 DO jk = mikt(ji,jj), jpkm1 173 ! 1. Vertical tracer gradient at level jk and jk+1 174 ! ------------------------------------------------ 175 ! surface boundary condition: zdkt(jk=1)=zdkt(jk=2) 176 zdk1t(ji,jj,jk) = ( ptb(ji,jj,jk,jn) - ptb(ji,jj,jk+1,jn) ) * tmask(ji,jj,jk+1) 177 ! 178 IF( jk == mikt(ji,jj) ) THEN ; zdkt(ji,jj,jk) = zdk1t(ji,jj,jk) 179 ELSE ; zdkt(ji,jj,jk) = ( ptb(ji,jj,jk-1,jn) - ptb(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 180 ENDIF 181 END DO 182 END DO 183 END DO 173 184 174 185 ! 2. Horizontal fluxes 175 186 ! -------------------- 176 DO jj = 1 , jpjm1 177 DO ji = 1, fs_jpim1 ! vector opt. 187 DO jj = 1 , jpjm1 188 DO ji = 1, fs_jpim1 ! vector opt. 189 DO jk = mikt(ji,jj), jpkm1 178 190 zabe1 = ( fsahtu(ji,jj,jk) + pahtb0 ) * re2u_e1u(ji,jj) * fse3u_n(ji,jj,jk) 179 191 zabe2 = ( fsahtv(ji,jj,jk) + pahtb0 ) * re1v_e2v(ji,jj) * fse3v_n(ji,jj,jk) … … 189 201 ! 190 202 zftu(ji,jj,jk ) = ( zabe1 * zdit(ji,jj,jk) & 191 & + zcof1 * ( zdkt (ji+1,jj ) + zdk1t(ji,jj) &192 & + zdk1t(ji+1,jj ) + zdkt (ji,jj) ) ) * umask(ji,jj,jk)203 & + zcof1 * ( zdkt (ji+1,jj,jk) + zdk1t(ji,jj,jk) & 204 & + zdk1t(ji+1,jj,jk) + zdkt (ji,jj,jk) ) ) * umask(ji,jj,jk) 193 205 zftv(ji,jj,jk) = ( zabe2 * zdjt(ji,jj,jk) & 194 & + zcof2 * ( zdkt (ji,jj+1) + zdk1t(ji,jj) & 195 & + zdk1t(ji,jj+1) + zdkt (ji,jj) ) ) * vmask(ji,jj,jk) 196 END DO 197 END DO 206 & + zcof2 * ( zdkt (ji,jj+1,jk) + zdk1t(ji,jj,jk) & 207 & + zdk1t(ji,jj+1,jk) + zdkt (ji,jj,jk) ) ) * vmask(ji,jj,jk) 208 END DO 209 END DO 210 END DO 198 211 199 212 ! II.4 Second derivative (divergence) and add to the general trend 200 213 ! ---------------------------------------------------------------- 201 DO jj = 2 , jpjm1 202 DO ji = fs_2, fs_jpim1 ! vector opt. 203 zbtr = 1.0 / ( e12t(ji,jj) * fse3t_n(ji,jj,jk) ) 214 DO jj = 2 , jpjm1 215 DO ji = fs_2, fs_jpim1 ! vector opt. 216 DO jk = mikt(ji,jj), jpkm1 217 zbtr = 1.0 / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 204 218 ztra = zbtr * ( zftu(ji,jj,jk) - zftu(ji-1,jj,jk) + zftv(ji,jj,jk) - zftv(ji,jj-1,jk) ) 205 219 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra … … 264 278 DO jj = 2, jpjm1 265 279 DO ji = fs_2, fs_jpim1 ! vector opt. 266 zcoef0 = - fsahtw(ji,jj,jk) * tmask(ji,jj,jk) 280 zcoef0 = - fsahtw(ji,jj,jk) * tmask(ji,jj,jk) * tmask(ji,jj,jk-1) 267 281 ! 268 282 zmsku = 1./MAX( umask(ji ,jj,jk-1) + umask(ji-1,jj,jk) & … … 297 311 END DO 298 312 ! 299 CALL wrk_dealloc( jpi, jpj, zdkt, zdk1t,z2d )300 CALL wrk_dealloc( jpi, jpj, jpk, zdit, zdjt, ztfw 313 CALL wrk_dealloc( jpi, jpj, z2d ) 314 CALL wrk_dealloc( jpi, jpj, jpk, zdit, zdjt, ztfw, zdkt, zdk1t ) 301 315 ! 302 316 IF( nn_timing == 1 ) CALL timing_stop('tra_ldf_iso') … … 309 323 !!---------------------------------------------------------------------- 310 324 CONTAINS 311 SUBROUTINE tra_ldf_iso( kt, kit000,cdtype, pgu, pgv, p tb, pta, kjpt, pahtb0 ) ! Empty routine325 SUBROUTINE tra_ldf_iso( kt, kit000,cdtype, pgu, pgv, pgui, pgvi, ptb, pta, kjpt, pahtb0 ) ! Empty routine 312 326 INTEGER:: kt, kit000 313 327 CHARACTER(len=3) :: cdtype 314 REAL, DIMENSION(:,:,:) :: pgu, pgv ! tracer gradient at pstep levels328 REAL, DIMENSION(:,:,:) :: pgu, pgv, pgui, pgvi ! tracer gradient at pstep levels 315 329 REAL, DIMENSION(:,:,:,:) :: ptb, pta 316 330 WRITE(*,*) 'tra_ldf_iso: You should not have seen this print! error?', kt, kit000, cdtype, & -
branches/2014/dev_r4650_UKMO7_STARTHOUR/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_iso_grif.F90
r3632 r5075 252 252 END DO 253 253 IF( ln_zps.and.l_grad_zps ) THEN ! partial steps: correction at the last level 254 # if defined key_vectopt_loop255 DO jj = 1, 1256 DO ji = 1, jpij-jpi ! vector opt. (forced unrolling)257 # else258 254 DO jj = 1, jpjm1 259 255 DO ji = 1, jpim1 260 # endif261 256 zdit(ji,jj,mbku(ji,jj)) = pgu(ji,jj,jn) 262 257 zdjt(ji,jj,mbkv(ji,jj)) = pgv(ji,jj,jn) -
branches/2014/dev_r4650_UKMO7_STARTHOUR/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_lap.F90
r4364 r5075 43 43 CONTAINS 44 44 45 SUBROUTINE tra_ldf_lap( kt, kit000, cdtype, pgu, pgv, & 45 SUBROUTINE tra_ldf_lap( kt, kit000, cdtype, pgu , pgv , & 46 & pgui, pgvi, & 46 47 & ptb, pta, kjpt ) 47 48 !!---------------------------------------------------------------------- … … 69 70 INTEGER , INTENT(in ) :: kjpt ! number of tracers 70 71 REAL(wp), DIMENSION(jpi,jpj ,kjpt), INTENT(in ) :: pgu, pgv ! tracer gradient at pstep levels 72 REAL(wp), DIMENSION(jpi,jpj, kjpt), INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels 71 73 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb ! before and now tracer fields 72 74 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend … … 114 116 ztv(ji,jj,jk) = zabe2 * pgv(ji,jj,jn) 115 117 ENDIF 118 119 ! (ISH) 120 ! ice shelf level level MAX(2,jk) => only where ice shelf 121 iku = miku(ji,jj) 122 ikv = mikv(ji,jj) 123 IF( iku == MAX(2,jk) ) THEN 124 zabe1 = fsahtu(ji,jj,iku) * umask(ji,jj,iku) * re2u_e1u(ji,jj) * fse3u_n(ji,jj,iku) 125 ztu(ji,jj,jk) = zabe1 * pgui(ji,jj,jn) 126 ENDIF 127 IF( ikv == MAX(2,jk) ) THEN 128 zabe2 = fsahtv(ji,jj,ikv) * vmask(ji,jj,ikv) * re1v_e2v(ji,jj) * fse3v_n(ji,jj,ikv) 129 ztv(ji,jj,jk) = zabe2 * pgvi(ji,jj,jn) 130 END IF 116 131 END DO 117 132 END DO -
branches/2014/dev_r4650_UKMO7_STARTHOUR/NEMOGCM/NEMO/OPA_SRC/TRA/tranpc.F90
r4313 r5075 2 2 !!============================================================================== 3 3 !! *** MODULE tranpc *** 4 !! Ocean active tracers: non penetrative convecti onscheme4 !! Ocean active tracers: non penetrative convective adjustment scheme 5 5 !!============================================================================== 6 6 !! History : 1.0 ! 1990-09 (G. Madec) Original code … … 9 9 !! 3.0 ! 2008-06 (G. Madec) applied on ta, sa and called before tranxt in step.F90 10 10 !! 3.3 ! 2010-05 (C. Ethe, G. Madec) merge TRC-TRA 11 !! 3.7 ! 2014-06 (L. Brodeau) new algorithm based on local Brunt-Vaisala freq. 11 12 !!---------------------------------------------------------------------- 12 13 … … 14 15 !! tra_npc : apply the non penetrative convection scheme 15 16 !!---------------------------------------------------------------------- 16 USE oce ! ocean dynamics and active tracers 17 USE oce ! ocean dynamics and active tracers 17 18 USE dom_oce ! ocean space and time domain 19 USE phycst ! physical constants 18 20 USE zdf_oce ! ocean vertical physics 19 USE trd mod_oce! ocean active tracer trends21 USE trd_oce ! ocean active tracer trends 20 22 USE trdtra ! ocean active tracer trends 21 USE eosbn2 ! equation of state (eos routine) 23 USE eosbn2 ! equation of state (eos routine) 24 ! 22 25 USE lbclnk ! lateral boundary conditions (or mpp link) 23 26 USE in_out_manager ! I/O manager … … 29 32 PRIVATE 30 33 31 PUBLIC tra_npc 34 PUBLIC tra_npc ! routine called by step.F90 32 35 33 36 !! * Substitutions 34 37 # include "domzgr_substitute.h90" 35 !!---------------------------------------------------------------------- 36 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 37 !! $Id$ 38 # include "vectopt_loop_substitute.h90" 39 !!---------------------------------------------------------------------- 40 !! NEMO/OPA 3.6 , NEMO Consortium (2014) 41 !! $Id$ 38 42 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 39 43 !!---------------------------------------------------------------------- … … 44 48 !! *** ROUTINE tranpc *** 45 49 !! 46 !! ** Purpose : Non penetrative convective adjustment scheme. solve50 !! ** Purpose : Non-penetrative convective adjustment scheme. solve 47 51 !! the static instability of the water column on after fields 48 52 !! while conserving heat and salt contents. 49 53 !! 50 !! ** Method : The algorithm used converges in a maximium of jpk 51 !! iterations. instabilities are treated when the vertical density 52 !! gradient is less than 1.e-5. 53 !! l_trdtra=T: the trend associated with this algorithm is saved. 54 !! ** Method : updated algorithm able to deal with non-linear equation of state 55 !! (i.e. static stability computed locally) 54 56 !! 55 57 !! ** Action : - (ta,sa) after the application od the npc scheme 56 !! - s ave the associated trends (ttrd,strd) ('key_trdtra')58 !! - send the associated trends for on-line diagnostics (l_trdtra=T) 57 59 !! 58 !! References : Madec, et al., 1991, JPO, 21, 9, 1349-1371.60 !! References : Madec, et al., 1991, JPO, 21, 9, 1349-1371. 59 61 !!---------------------------------------------------------------------- 60 !61 62 INTEGER, INTENT(in) :: kt ! ocean time-step index 62 63 ! 63 64 INTEGER :: ji, jj, jk ! dummy loop indices 64 65 INTEGER :: inpcc ! number of statically instable water column 65 INTEGER :: inpci ! number of iteration for npc scheme 66 INTEGER :: jiter, jkdown, jkp ! ??? 67 INTEGER :: ikbot, ik, ikup, ikdown ! ??? 68 REAL(wp) :: ze3tot, zta, zsa, zraua, ze3dwn 69 REAL(wp), POINTER, DIMENSION(:,: ) :: zwx, zwy, zwz 70 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdt, ztrds, zrhop 66 INTEGER :: jiter, ikbot, ik, ikup, ikdown, ilayer, ikm ! local integers 67 LOGICAL :: l_bottom_reached, l_column_treated 68 REAL(wp) :: zta, zalfa, zsum_temp, zsum_alfa, zaw, zdz, zsum_z 69 REAL(wp) :: zsa, zbeta, zsum_sali, zsum_beta, zbw, zrw, z1_r2dt 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 76 ! 77 !!LB debug: 78 LOGICAL, PARAMETER :: l_LB_debug = .FALSE. 79 INTEGER :: ilc1, jlc1, klc1, nncpu 80 LOGICAL :: lp_monitor_point = .FALSE. 81 !!LB debug. 71 82 !!---------------------------------------------------------------------- 72 83 ! 73 84 IF( nn_timing == 1 ) CALL timing_start('tra_npc') 74 85 ! 75 CALL wrk_alloc(jpi, jpj, jpk, zrhop )76 CALL wrk_alloc(jpi, jpk, zwx, zwy, zwz )77 !78 86 IF( MOD( kt, nn_npc ) == 0 ) THEN 79 80 inpcc = 081 inpci = 082 83 CALL eos( tsa, rhd, zrhop, fsdept_n(:,:,:) ) ! Potential density84 85 IF( l_trdtra ) THEN !* Save ta and sa trends87 ! 88 CALL wrk_alloc( jpi, jpj, jpk, zn2 ) ! N2 89 CALL wrk_alloc( jpi, jpj, jpk, 2, zab ) ! Alpha and Beta 90 CALL wrk_alloc( jpk, 2, zvts, zvab ) ! 1D column vector at point ji,jj 91 CALL wrk_alloc( jpk, zvn2 ) ! 1D column vector at point ji,jj 92 93 IF( l_trdtra ) THEN !* Save initial after fields 86 94 CALL wrk_alloc( jpi, jpj, jpk, ztrdt, ztrds ) 87 95 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) … … 89 97 ENDIF 90 98 91 ! ! =============== 92 DO jj = 1, jpj ! Vertical slab 93 ! ! =============== 94 ! Static instability pointer 95 ! ---------------------------- 96 DO jk = 1, jpkm1 97 DO ji = 1, jpi 98 zwx(ji,jk) = ( zrhop(ji,jj,jk) - zrhop(ji,jj,jk+1) ) * tmask(ji,jj,jk+1) 99 END DO 100 END DO 101 102 ! 1.1 do not consider the boundary points 103 104 ! even if east-west cyclic b. c. do not considere ji=1 or jpi 105 DO jk = 1, jpkm1 106 zwx( 1 ,jk) = 0.e0 107 zwx(jpi,jk) = 0.e0 108 END DO 109 ! even if south-symmetric b. c. used, do not considere jj=1 110 IF( jj == 1 ) zwx(:,:) = 0.e0 111 112 DO jk = 1, jpkm1 113 DO ji = 1, jpi 114 zwx(ji,jk) = 1. 115 IF( zwx(ji,jk) < 1.e-5 ) zwx(ji,jk) = 0.e0 116 END DO 117 END DO 118 119 zwy(:,1) = 0.e0 120 DO ji = 1, jpi 121 DO jk = 1, jpkm1 122 zwy(ji,1) = zwy(ji,1) + zwx(ji,jk) 123 END DO 124 END DO 125 126 zwz(1,1) = 0.e0 127 DO ji = 1, jpi 128 zwz(1,1) = zwz(1,1) + zwy(ji,1) 129 END DO 130 131 inpcc = inpcc + NINT( zwz(1,1) ) 132 133 134 ! 2. Vertical mixing for each instable portion of the density profil 135 ! ------------------------------------------------------------------ 136 137 IF( zwz(1,1) /= 0.e0 ) THEN ! -->> the density profil is statically instable : 138 DO ji = 1, jpi 139 IF( zwy(ji,1) /= 0.e0 ) THEN 99 !LB debug: 100 IF( lwp .AND. l_LB_debug ) THEN 101 WRITE(numout,*) 102 WRITE(numout,*) 'LOLO: entering tra_npc, kt, narea =', kt, narea 103 ENDIF 104 !LBdebug: Monitoring of 1 column subject to convection... 105 IF( l_LB_debug ) THEN 106 ! Location of 1 known convection spot to follow what's happening in the water column 107 ilc1 = 54 ; jlc1 = 15 ; ! Labrador ORCA1 4x4 cpus: 108 nncpu = 15 ; ! the CPU domain contains the convection spot 109 !ilc1 = 14 ; jlc1 = 13 ; ! Labrador ORCA1 8x8 cpus: 110 !nncpu = 54 ; ! the CPU domain contains the convection spot 111 klc1 = mbkt(ilc1,jlc1) ! bottom of the ocean for debug point... 112 ENDIF 113 !LBdebug. 114 115 CALL eos_rab( tsa, zab ) ! after alpha and beta 116 CALL bn2 ( tsa, zab, zn2 ) ! after Brunt-Vaisala 117 118 inpcc = 0 119 120 DO jj = 2, jpjm1 ! interior column only 121 DO ji = fs_2, fs_jpim1 122 ! 123 IF( tmask(ji,jj,2) == 1 ) THEN ! At least 2 ocean points 124 ! ! consider one ocean column 125 zvts(:,jp_tem) = tsa(ji,jj,:,jp_tem) ! temperature 126 zvts(:,jp_sal) = tsa(ji,jj,:,jp_sal) ! salinity 127 128 zvab(:,jp_tem) = zab(ji,jj,:,jp_tem) ! Alpha 129 zvab(:,jp_sal) = zab(ji,jj,:,jp_sal) ! Beta 130 zvn2(:) = zn2(ji,jj,:) ! N^2 131 132 IF( l_LB_debug ) THEN !LB debug: 133 lp_monitor_point = .FALSE. 134 IF( ( ji == ilc1 ).AND.( jj == jlc1 ) ) lp_monitor_point = .TRUE. 135 ! writing only if on CPU domain where conv region is: 136 lp_monitor_point = (narea == nncpu).AND.lp_monitor_point 137 138 IF(lp_monitor_point) THEN 139 WRITE(numout,*) '' ;WRITE(numout,*) '' ; 140 WRITE(numout,'("Time step = ",i6.6," !!!")') kt 141 WRITE(numout,'(" *** BEFORE anything, N^2 for point ",i3,",",i3,":" )') ji,jj 142 DO jk = 1, klc1 143 WRITE(numout,*) jk, zvn2(jk) 144 END DO 145 WRITE(numout,*) ' ' 146 ENDIF 147 ENDIF !LB debug end 148 149 ikbot = mbkt(ji,jj) ! ikbot: ocean bottom T-level 150 ik = 1 ! because N2 is irrelevant at the surface level (will start at ik=2) 151 ilayer = 0 152 jiter = 0 153 l_column_treated = .FALSE. 154 155 DO WHILE ( .NOT. l_column_treated ) 140 156 ! 141 ikbot = mbkt(ji,jj) ! ikbot: ocean bottom T-level 157 jiter = jiter + 1 158 159 IF( jiter >= 400 ) EXIT 160 161 l_bottom_reached = .FALSE. 162 163 DO WHILE ( .NOT. l_bottom_reached ) 164 165 ik = ik + 1 166 167 !! Checking level ik for instability 168 !! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 169 170 IF( zvn2(ik) < 0. ) THEN ! Instability found! 171 172 ikm = ik ! first level whith negative N2 173 ilayer = ilayer + 1 ! yet another layer found.... 174 IF(jiter == 1) inpcc = inpcc + 1 175 176 IF(l_LB_debug .AND. lp_monitor_point) & 177 & WRITE(numout,*) 'Negative N2 at ik =', ikm, ' layer nb.', ilayer, & 178 & ' inpcc =', inpcc 179 180 !! Case we mix with upper regions where N2==0: 181 !! All the points above ikup where N2 == 0 must also be mixed => we go 182 !! upward to find a new ikup, where the layer doesn't have N2==0 183 ikup = ikm 184 DO jk = ikm, 2, -1 185 ikup = ikup - 1 186 IF( (zvn2(jk-1) > 0.).OR.(ikup == 1) ) EXIT 187 END DO 188 189 ! adjusting ikup if the upper part of the unstable column was neutral (N2=0) 190 IF((zvn2(ikup+1) == 0.).AND.(ikup /= 1)) ikup = ikup+1 ; 191 192 193 IF( lp_monitor_point ) WRITE(numout,*) ' => ikup is =', ikup, ' layer nb.', ilayer 194 195 zsum_temp = 0._wp 196 zsum_sali = 0._wp 197 zsum_alfa = 0._wp 198 zsum_beta = 0._wp 199 zsum_z = 0._wp 200 201 DO jk = ikup, ikbot+1 ! Inside the instable (and overlying neutral) portion of the column 202 ! 203 IF(l_LB_debug .AND. lp_monitor_point) WRITE(numout,*) ' -> summing for jk =', jk 204 ! 205 zdz = fse3t(ji,jj,jk) 206 zsum_temp = zsum_temp + zvts(jk,jp_tem)*zdz 207 zsum_sali = zsum_sali + zvts(jk,jp_sal)*zdz 208 zsum_alfa = zsum_alfa + zvab(jk,jp_tem)*zdz 209 zsum_beta = zsum_beta + zvab(jk,jp_sal)*zdz 210 zsum_z = zsum_z + zdz 211 ! 212 !! EXIT if we found the bottom of the unstable portion of the water column 213 IF( (zvn2(jk+1) > 0.).OR.(jk == ikbot ).OR.((jk==ikm).AND.(zvn2(jk+1) == 0.)) ) EXIT 214 END DO 215 216 !ik = jk !LB remove? 217 ikdown = jk ! for the current unstable layer, ikdown is the deepest point with a negative N2 218 219 IF(l_LB_debug .AND. lp_monitor_point) & 220 & WRITE(numout,*) ' => ikdown =', ikdown, ' layer nb.', ilayer 221 222 ! Mixing Temperature and salinity between ikup and ikdown: 223 zta = zsum_temp/zsum_z 224 zsa = zsum_sali/zsum_z 225 zalfa = zsum_alfa/zsum_z 226 zbeta = zsum_beta/zsum_z 227 228 IF(l_LB_debug .AND. lp_monitor_point) THEN 229 WRITE(numout,*) ' => Mean temp. in that portion =', zta 230 WRITE(numout,*) ' => Mean sali. in that portion =', zsa 231 WRITE(numout,*) ' => Mean Alpha in that portion =', zalfa 232 WRITE(numout,*) ' => Mean Beta in that portion =', zbeta 233 ENDIF 234 235 !! Homogenaizing the temperature, salinity, alpha and beta in this portion of the column 236 DO jk = ikup, ikdown 237 zvts(jk,jp_tem) = zta 238 zvts(jk,jp_sal) = zsa 239 zvab(jk,jp_tem) = zalfa 240 zvab(jk,jp_sal) = zbeta 241 END DO 242 ! 243 !! Before updating N2, it is possible that another unstable 244 !! layer exists underneath the one we just homogeneized! 245 ik = ikdown 246 ! 247 ENDIF ! IF( zvn2(ik+1) < 0. ) THEN 248 ! 249 IF( ik == ikbot ) l_bottom_reached = .TRUE. 250 ! 251 END DO ! DO WHILE ( .NOT. l_bottom_reached ) 252 253 IF( ik /= ikbot ) STOP 'ERROR: tranpc.F90 => PROBLEM #1' 254 255 ! ******* At this stage ik == ikbot ! ******* 256 257 IF( ilayer > 0 ) THEN 258 !! least an unstable layer has been found 259 !! Temperature, Salinity, Alpha and Beta have been homogenized in the unstable portion 260 !! => Need to re-compute N2! will use Alpha and Beta! 261 ! 262 DO jk = ikup+1, ikdown+1 ! we must go 1 point deeper than ikdown! 263 !! Doing exactly as in eosbn2.F90: 264 !! * Except that we only are interested in the sign of N2 !!! 265 !! => just considering the vertical gradient of density 266 zrw = (fsdepw(ji,jj,jk ) - fsdept(ji,jj,jk)) & 267 & / (fsdept(ji,jj,jk-1) - fsdept(ji,jj,jk)) 268 zaw = zvab(jk,jp_tem) * (1._wp - zrw) + zvab(jk-1,jp_tem) * zrw 269 zbw = zvab(jk,jp_sal) * (1._wp - zrw) + zvab(jk-1,jp_sal) * zrw 270 271 !zvn2(jk) = grav*( zaw * ( zvts(jk-1,jp_tem) - zvts(jk,jp_tem) ) & 272 ! & - zbw * ( zvts(jk-1,jp_sal) - zvts(jk,jp_sal) ) ) & 273 ! & / fse3w(ji,jj,jk) * tmask(ji,jj,jk) 274 zvn2(jk) = ( zaw * ( zvts(jk-1,jp_tem) - zvts(jk,jp_tem) ) & 275 & - zbw * ( zvts(jk-1,jp_sal) - zvts(jk,jp_sal) ) ) 276 END DO 277 278 IF(l_LB_debug .AND. lp_monitor_point) THEN 279 WRITE(numout, '(" *** After iteration #",i3.3,", N^2 for point ",i3,",",i3,":" )') & 280 & jiter, ji,jj 281 DO jk = 1, klc1 282 WRITE(numout,*) jk, zvn2(jk) 283 END DO 284 WRITE(numout,*) ' ' 285 ENDIF 286 287 ik = 1 ! starting again at the surface for the next iteration 288 ilayer = 0 289 ENDIF 142 290 ! 143 DO jiter = 1, jpk ! vertical iteration 144 ! 145 ! search of ikup : the first static instability from the sea surface 146 ! 147 ik = 0 148 220 CONTINUE 149 ik = ik + 1 150 IF( ik >= ikbot ) GO TO 200 151 zwx(ji,ik) = zrhop(ji,jj,ik) - zrhop(ji,jj,ik+1) 152 IF( zwx(ji,ik) <= 0.e0 ) GO TO 220 153 ikup = ik 154 ! the density profil is instable below ikup 155 ! ikdown : bottom of the instable portion of the density profil 156 ! search of ikdown and vertical mixing from ikup to ikdown 157 ! 158 ze3tot= fse3t(ji,jj,ikup) 159 zta = tsa (ji,jj,ikup,jp_tem) 160 zsa = tsa (ji,jj,ikup,jp_sal) 161 zraua = zrhop(ji,jj,ikup) 162 ! 163 DO jkdown = ikup+1, ikbot-1 164 IF( zraua <= zrhop(ji,jj,jkdown) ) THEN 165 ikdown = jkdown 166 GO TO 240 167 ENDIF 168 ze3dwn = fse3t(ji,jj,jkdown) 169 ze3tot = ze3tot + ze3dwn 170 zta = ( zta*(ze3tot-ze3dwn) + tsa(ji,jj,jkdown,jp_tem)*ze3dwn )/ze3tot 171 zsa = ( zsa*(ze3tot-ze3dwn) + tsa(ji,jj,jkdown,jp_sal)*ze3dwn )/ze3tot 172 zraua = ( zraua*(ze3tot-ze3dwn) + zrhop(ji,jj,jkdown)*ze3dwn )/ze3tot 173 inpci = inpci+1 174 END DO 175 ikdown = ikbot-1 176 240 CONTINUE 177 ! 178 DO jkp = ikup, ikdown-1 179 tsa (ji,jj,jkp,jp_tem) = zta 180 tsa (ji,jj,jkp,jp_sal) = zsa 181 zrhop(ji,jj,jkp ) = zraua 182 END DO 183 IF (ikdown == ikbot-1 .AND. zraua >= zrhop(ji,jj,ikdown) ) THEN 184 tsa (ji,jj,jkp,jp_tem) = zta 185 tsa (ji,jj,jkp,jp_sal) = zsa 186 zrhop(ji,jj,ikdown ) = zraua 187 ENDIF 188 END DO 189 ENDIF 190 200 CONTINUE 191 END DO 192 ! <<-- no more static instability on slab jj 193 ENDIF 194 ! ! =============== 195 END DO ! End of slab 196 ! ! =============== 197 ! 198 IF( l_trdtra ) THEN ! save the Non penetrative mixing trends for diagnostic 199 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 200 ztrds(:,:,:) = tsa(:,:,:,jp_sal) - ztrds(:,:,:) 201 CALL trd_tra( kt, 'TRA', jp_tem, jptra_trd_npc, ztrdt ) 202 CALL trd_tra( kt, 'TRA', jp_sal, jptra_trd_npc, ztrds ) 291 IF( ik >= ikbot ) THEN 292 IF(l_LB_debug .AND. lp_monitor_point) WRITE(numout,*) ' --- exiting jiter loop ---' 293 l_column_treated = .TRUE. 294 ENDIF 295 ! 296 END DO ! DO WHILE ( .NOT. l_column_treated ) 297 298 !! Updating tsa: 299 tsa(ji,jj,:,jp_tem) = zvts(:,jp_tem) 300 tsa(ji,jj,:,jp_sal) = zvts(:,jp_sal) 301 302 !! lolo: Should we update something else???? 303 !! => like alpha and beta? 304 305 IF(l_LB_debug .AND. lp_monitor_point) WRITE(numout,*) '' 306 307 ENDIF ! IF( tmask(ji,jj,3) == 1 ) THEN 308 309 END DO ! ji 310 END DO ! jj 311 ! 312 IF( l_trdtra ) THEN ! send the Non penetrative mixing trends for diagnostic 313 z1_r2dt = 1._wp / (2._wp * rdt) 314 ztrdt(:,:,:) = ( tsa(:,:,:,jp_tem) - ztrdt(:,:,:) ) * z1_r2dt 315 ztrds(:,:,:) = ( tsa(:,:,:,jp_sal) - ztrds(:,:,:) ) * z1_r2dt 316 CALL trd_tra( kt, 'TRA', jp_tem, jptra_npc, ztrdt ) 317 CALL trd_tra( kt, 'TRA', jp_sal, jptra_npc, ztrds ) 203 318 CALL wrk_dealloc( jpi, jpj, jpk, ztrdt, ztrds ) 204 319 ENDIF 205 206 ! Lateral boundary conditions on ( ta, sa ) ( Unchanged sign) 207 ! ------------------------------============ 320 ! 208 321 CALL lbc_lnk( tsa(:,:,:,jp_tem), 'T', 1. ) ; CALL lbc_lnk( tsa(:,:,:,jp_sal), 'T', 1. ) 209 210 211 ! 2. non penetrative convective scheme statistics212 ! -----------------------------------------------213 IF( nn_npcp /= 0 .AND. MOD( kt, nn_npcp ) == 0 ) THEN214 IF(lwp) WRITE(numout,*)' kt=',kt, ' number of statically instable', &215 & ' water column : ',inpcc, ' number of iteration : ',inpci216 ENDIF217 !218 ENDIF219 !220 CALL wrk_dealloc(jpi, jpj, jpk, zrhop )221 CALL wrk_dealloc(jpi, jpk, zwx, zwy, zwz )322 ! 323 IF(lwp) THEN 324 WRITE(numout,*) 'LOLO: exiting tra_npc, kt =', kt 325 WRITE(numout,*)' => number of statically instable water column : ',inpcc 326 WRITE(numout,*) '' ; WRITE(numout,*) '' 327 ENDIF 328 ! 329 CALL wrk_dealloc(jpi, jpj, jpk, zn2 ) 330 CALL wrk_dealloc(jpi, jpj, jpk, 2, zab ) 331 CALL wrk_dealloc(jpk, zvn2 ) 332 CALL wrk_dealloc(jpk, 2, zvts, zvab ) 333 ! 334 ENDIF ! IF( MOD( kt, nn_npc ) == 0 ) THEN 222 335 ! 223 336 IF( nn_timing == 1 ) CALL timing_stop('tra_npc') -
branches/2014/dev_r4650_UKMO7_STARTHOUR/NEMOGCM/NEMO/OPA_SRC/TRA/tranxt.F90
r4328 r5075 27 27 USE dom_oce ! ocean space and time domain variables 28 28 USE sbc_oce ! surface boundary condition: ocean 29 USE zdf_oce ! ???29 USE zdf_oce ! ocean vertical mixing 30 30 USE domvvl ! variable volume 31 31 USE dynspg_oce ! surface pressure gradient variables 32 32 USE dynhpg ! hydrostatic pressure gradient 33 USE trdmod_oce ! ocean space and time domain variables 34 USE trdtra ! ocean active tracers trends 35 USE phycst 36 USE bdy_oce 33 USE trd_oce ! trends: ocean variables 34 USE trdtra ! trends manager: tracers 35 USE traqsr ! penetrative solar radiation (needed for nksr) 36 USE phycst ! physical constant 37 USE ldftra_oce ! lateral physics on tracers 38 USE bdy_oce ! BDY open boundary condition variables 37 39 USE bdytra ! open boundary condition (bdy_tra routine) 40 ! 38 41 USE in_out_manager ! I/O manager 39 42 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 40 43 USE prtctl ! Print control 41 USE traqsr ! penetrative solar radiation (needed for nksr) 44 USE wrk_nemo ! Memory allocation 45 USE timing ! Timing 42 46 #if defined key_agrif 43 47 USE agrif_opa_update 44 48 USE agrif_opa_interp 45 49 #endif 46 USE wrk_nemo ! Memory allocation47 USE timing ! Timing48 50 49 51 IMPLICIT NONE … … 80 82 !! at the local domain boundaries through lbc_lnk call, 81 83 !! at the one-way open boundaries (lk_bdy=T), 82 !! at the AGRIF zoom 84 !! at the AGRIF zoom boundaries (lk_agrif=T) 83 85 !! 84 86 !! - Update lateral boundary conditions on AGRIF children … … 127 129 ztrdt(:,:,:) = tsn(:,:,:,jp_tem) 128 130 ztrds(:,:,:) = tsn(:,:,:,jp_sal) 131 IF( ln_traldf_iso ) THEN ! diagnose the "pure" Kz diffusive trend 132 CALL trd_tra( kt, 'TRA', jp_tem, jptra_zdfp, ztrdt ) 133 CALL trd_tra( kt, 'TRA', jp_sal, jptra_zdfp, ztrds ) 134 ENDIF 129 135 ENDIF 130 136 … … 150 156 IF( l_trdtra ) THEN ! trend of the Asselin filter (tb filtered - tb)/dt 151 157 DO jk = 1, jpkm1 152 zfact = 1. e0_wp / r2dtra(jk)158 zfact = 1._wp / r2dtra(jk) 153 159 ztrdt(:,:,jk) = ( tsb(:,:,jk,jp_tem) - ztrdt(:,:,jk) ) * zfact 154 160 ztrds(:,:,jk) = ( tsb(:,:,jk,jp_sal) - ztrds(:,:,jk) ) * zfact 155 161 END DO 156 CALL trd_tra( kt, 'TRA', jp_tem, jptra_ trd_atf, ztrdt )157 CALL trd_tra( kt, 'TRA', jp_sal, jptra_ trd_atf, ztrds )162 CALL trd_tra( kt, 'TRA', jp_tem, jptra_atf, ztrdt ) 163 CALL trd_tra( kt, 'TRA', jp_sal, jptra_atf, ztrds ) 158 164 CALL wrk_dealloc( jpi, jpj, jpk, ztrdt, ztrds ) 159 165 END IF … … 163 169 & tab3d_2=tsn(:,:,:,jp_sal), clinfo2= ' Sn: ', mask2=tmask ) 164 170 ! 165 ! 166 IF( nn_timing == 1 ) CALL timing_stop('tra_nxt') 171 IF( nn_timing == 1 ) CALL timing_stop('tra_nxt') 167 172 ! 168 173 END SUBROUTINE tra_nxt -
branches/2014/dev_r4650_UKMO7_STARTHOUR/NEMOGCM/NEMO/OPA_SRC/TRA/traqsr.F90
r4624 r5075 21 21 USE sbc_oce ! surface boundary condition: ocean 22 22 USE trc_oce ! share SMS/Ocean variables 23 USE trd mod_oce ! ocean variables trends24 USE trdtra ! ocean active tracers trends23 USE trd_oce ! trends: ocean variables 24 USE trdtra ! trends manager: tracers 25 25 USE in_out_manager ! I/O manager 26 26 USE phycst ! physical constants … … 129 129 IF( kt == nit000 ) THEN ! Set the forcing field at nit000 - 1 130 130 ! ! ----------------------------------- 131 qsr_hc(:,:,:) = 0.e0 132 ! 131 133 IF( ln_rstart .AND. & ! Restart: read in restart file 132 134 & iom_varid( numror, 'qsr_hc_b', ldstop = .FALSE. ) > 0 ) THEN … … 167 169 DO ji = 1, jpi 168 170 IF ( qsr(ji,jj) /= 0._wp ) THEN 169 oatte(ji,jj) = ( qsr_hc(ji,jj,1) / ( r1_rau0_rcp * qsr(ji,jj) ) ) 170 iatte(ji,jj) = oatte(ji,jj) 171 fraqsr_1lev(ji,jj) = ( qsr_hc(ji,jj,1) / ( r1_rau0_rcp * qsr(ji,jj) ) ) 171 172 ENDIF 172 173 END DO … … 239 240 zzc2 = zcoef * EXP( - fse3t(ji,jj,1) * zekg(ji,jj) ) 240 241 zzc3 = zcoef * EXP( - fse3t(ji,jj,1) * zekr(ji,jj) ) 241 oatte(ji,jj) = 1.0 - ( zzc0 + zzc1 + zzc2 + zzc3 ) * tmask(ji,jj,2) 242 iatte(ji,jj) = 1.0 - ( zzc0 + zzc1 + zcoef + zcoef ) * tmask(ji,jj,2) 242 fraqsr_1lev(ji,jj) = 1.0 - ( zzc0 + zzc1 + zzc2 + zzc3 ) * tmask(ji,jj,2) 243 243 END DO 244 244 END DO … … 257 257 ! clem: store attenuation coefficient of the first ocean level 258 258 IF ( lk_lim3 .AND. ln_qsr_ice ) THEN 259 oatte(:,:) = etot3(:,:,1) / r1_rau0_rcp 260 iatte(:,:) = oatte(:,:) 259 fraqsr_1lev(:,:) = etot3(:,:,1) / r1_rau0_rcp 261 260 ENDIF 262 261 ENDIF … … 285 284 zc0 = zz0 * EXP( -fsdepw(ji,jj,1)*xsi0r ) + zz1 * EXP( -fsdepw(ji,jj,1)*xsi1r ) 286 285 zc1 = zz0 * EXP( -fsdepw(ji,jj,2)*xsi0r ) + zz1 * EXP( -fsdepw(ji,jj,2)*xsi1r ) 287 oatte(ji,jj) = ( zc0*tmask(ji,jj,1) - zc1*tmask(ji,jj,2) ) / r1_rau0_rcp 288 iatte(ji,jj) = oatte(ji,jj) 286 fraqsr_1lev(ji,jj) = ( zc0*tmask(ji,jj,1) - zc1*tmask(ji,jj,2) ) / r1_rau0_rcp 289 287 END DO 290 288 END DO … … 294 292 DO jj = 2, jpjm1 295 293 DO ji = fs_2, fs_jpim1 ! vector opt. 296 qsr_hc(ji,jj,jk) = etot3(ji,jj,jk) * qsr(ji,jj) 294 ! (ISF) no light penetration below the ice shelves 295 qsr_hc(ji,jj,jk) = etot3(ji,jj,jk) * qsr(ji,jj) * tmask(ji,jj,1) 297 296 END DO 298 297 END DO … … 300 299 ! clem: store attenuation coefficient of the first ocean level 301 300 IF ( lk_lim3 .AND. ln_qsr_ice ) THEN 302 oatte(:,:) = etot3(:,:,1) / r1_rau0_rcp 303 iatte(:,:) = oatte(:,:) 301 fraqsr_1lev(:,:) = etot3(:,:,1) / r1_rau0_rcp 304 302 ENDIF 305 303 ! … … 332 330 IF( l_trdtra ) THEN ! qsr tracers trends saved for diagnostics 333 331 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 334 CALL trd_tra( kt, 'TRA', jp_tem, jptra_ trd_qsr, ztrdt )332 CALL trd_tra( kt, 'TRA', jp_tem, jptra_qsr, ztrdt ) 335 333 CALL wrk_dealloc( jpi, jpj, jpk, ztrdt ) 336 334 ENDIF … … 382 380 IF( nn_timing == 1 ) CALL timing_start('tra_qsr_init') 383 381 ! 384 ! clem init for oatte and iatte382 ! Default value for fraqsr_1lev 385 383 IF( .NOT. ln_rstart ) THEN 386 oatte(:,:) = 1._wp 387 iatte(:,:) = 1._wp 384 fraqsr_1lev(:,:) = 1._wp 388 385 ENDIF 389 386 ! … … 520 517 ! 521 518 DO jk = 1, nksr 522 etot3(:,:,jk) = r1_rau0_rcp * ( zea(:,:,jk) - zea(:,:,jk+1) ) 519 ! (ISF) no light penetration below the ice shelves 520 etot3(:,:,jk) = r1_rau0_rcp * ( zea(:,:,jk) - zea(:,:,jk+1) ) * tmask(:,:,1) 523 521 END DO 524 522 etot3(:,:,nksr+1:jpk) = 0.e0 ! below 400m set to zero … … 548 546 zc0 = zz0 * EXP( -fsdepw(ji,jj,jk )*xsi0r ) + zz1 * EXP( -fsdepw(ji,jj,jk )*xsi1r ) 549 547 zc1 = zz0 * EXP( -fsdepw(ji,jj,jk+1)*xsi0r ) + zz1 * EXP( -fsdepw(ji,jj,jk+1)*xsi1r ) 550 etot3(ji,jj,jk) = ( zc0 * tmask(ji,jj,jk) - zc1 * tmask(ji,jj,jk+1) ) 548 etot3(ji,jj,jk) = ( zc0 * tmask(ji,jj,jk) - zc1 * tmask(ji,jj,jk+1) ) * tmask(ji,jj,1) 551 549 END DO 552 550 END DO -
branches/2014/dev_r4650_UKMO7_STARTHOUR/NEMOGCM/NEMO/OPA_SRC/TRA/trasbc.F90
r3764 r5075 18 18 USE dom_oce ! ocean space domain variables 19 19 USE phycst ! physical constant 20 USE sbcmod ! ln_rnf 21 USE sbcrnf ! River runoff 20 22 USE traqsr ! solar radiation penetration 21 USE trdmod_oce ! ocean trends 22 USE trdtra ! ocean trends 23 USE trd_oce ! trends: ocean variables 24 USE trdtra ! trends manager: tracers 25 ! 23 26 USE in_out_manager ! I/O manager 24 27 USE prtctl ! Print control 25 28 USE sbcrnf ! River runoff 29 USE sbcisf ! Ice shelf 26 30 USE sbcmod ! ln_rnf 27 31 USE iom … … 29 33 USE wrk_nemo ! Memory Allocation 30 34 USE timing ! Timing 35 USE eosbn2 31 36 32 37 IMPLICIT NONE … … 39 44 # include "vectopt_loop_substitute.h90" 40 45 !!---------------------------------------------------------------------- 41 !! NEMO/OPA 3. 3 , NEMO Consortium (2010)46 !! NEMO/OPA 3.7 , NEMO Consortium (2014) 42 47 !! $Id$ 43 48 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 91 96 !! where emp, the surface freshwater budget (evaporation minus 92 97 !! precipitation minus runoff) given in kg/m2/s is divided 93 !! by rau0 = 1020 kg/m3(density of sea water) to obtain m/s.98 !! by rau0 (density of sea water) to obtain m/s. 94 99 !! Note: even though Fwe does not appear explicitly for 95 100 !! temperature in this routine, the heat carried by the water … … 107 112 !! ** Action : - Update the 1st level of (ta,sa) with the trend associated 108 113 !! with the tracer surface boundary condition 109 !! - s ave the trend it in ttrd ('key_trdtra')114 !! - send trends to trdtra module (l_trdtra=T) 110 115 !!---------------------------------------------------------------------- 111 116 INTEGER, INTENT(in) :: kt ! ocean time-step index 112 117 !! 113 118 INTEGER :: ji, jj, jk, jn ! dummy loop indices 119 INTEGER :: ikt, ikb 120 INTEGER :: nk_isf 114 121 REAL(wp) :: zfact, z1_e3t, zdep 122 REAL(wp) :: zalpha, zhk 123 REAL(wp) :: zt_frz, zpress 115 124 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdt, ztrds 116 125 !!---------------------------------------------------------------------- … … 124 133 ENDIF 125 134 126 IF( l_trdtra ) 135 IF( l_trdtra ) THEN !* Save ta and sa trends 127 136 CALL wrk_alloc( jpi, jpj, jpk, ztrdt, ztrds ) 128 137 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) … … 137 146 138 147 !---------------------------------------- 139 ! EMP, EMPSand QNS effects148 ! EMP, SFX and QNS effects 140 149 !---------------------------------------- 141 150 ! Set before sbc tracer content fields … … 146 155 & iom_varid( numror, 'sbc_hc_b', ldstop = .FALSE. ) > 0 ) THEN 147 156 IF(lwp) WRITE(numout,*) ' nit000-1 surface tracer content forcing fields red in the restart file' 148 zfact = 0.5 e0157 zfact = 0.5_wp 149 158 CALL iom_get( numror, jpdom_autoglo, 'sbc_hc_b', sbc_tsc_b(:,:,jp_tem) ) ! before heat content sbc trend 150 159 CALL iom_get( numror, jpdom_autoglo, 'sbc_sc_b', sbc_tsc_b(:,:,jp_sal) ) ! before salt content sbc trend 151 160 ELSE ! No restart or restart not found: Euler forward time stepping 152 zfact = 1. e0153 sbc_tsc_b(:,:,:) = 0. e0161 zfact = 1._wp 162 sbc_tsc_b(:,:,:) = 0._wp 154 163 ENDIF 155 164 ELSE ! Swap of forcing fields 156 165 ! ! ---------------------- 157 zfact = 0.5 e0166 zfact = 0.5_wp 158 167 sbc_tsc_b(:,:,:) = sbc_tsc(:,:,:) 159 168 ENDIF … … 182 191 END DO 183 192 END DO 184 CALL iom_put( "emp_x_sst", emp (:,:) * tsn(:,:,1,jp_tem) )! c/d term on sst185 CALL iom_put( "emp_x_sss", emp (:,:) * tsn(:,:,1,jp_sal) )! c/d term on sss193 IF( iom_use('emp_x_sst') ) CALL iom_put( "emp_x_sst", emp (:,:) * tsn(:,:,1,jp_tem) ) ! c/d term on sst 194 IF( iom_use('emp_x_sss') ) CALL iom_put( "emp_x_sss", emp (:,:) * tsn(:,:,1,jp_sal) ) ! c/d term on sss 186 195 ENDIF 187 196 ! Concentration dilution effect on (t,s) due to evapouration, precipitation and qns, but not river runoff … … 205 214 ENDIF 206 215 ! 216 ! 217 !---------------------------------------- 218 ! Ice Shelf effects (ISF) 219 ! tbl treated as in Losh (2008) JGR 220 !---------------------------------------- 221 ! 222 IF( nn_isf > 0 ) THEN 223 zfact = 0.5e0 224 DO jj = 2, jpj 225 DO ji = fs_2, fs_jpim1 226 227 ikt = misfkt(ji,jj) 228 ikb = misfkb(ji,jj) 229 230 ! level fully include in the ice shelf boundary layer 231 ! if isfdiv, we have to remove heat flux due to inflow at 0oC (as in rnf when you add rnf at sst) 232 ! sign - because fwf sign of evapo (rnf sign of precip) 233 DO jk = ikt, ikb - 1 234 ! compute tfreez for the temperature correction (we add water at freezing temperature) 235 ! zpress = grav*rau0*fsdept(ji,jj,jk)*1.e-04 236 zt_frz = -1.9 !eos_fzp( tsn(ji,jj,jk,jp_sal), zpress ) 237 ! compute trend 238 tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) & 239 & + zfact * (risf_tsc_b(ji,jj,jp_tem) + risf_tsc(ji,jj,jp_tem) & 240 & - rdivisf * (fwfisf(ji,jj) + fwfisf_b(ji,jj)) * zt_frz * r1_rau0) & 241 & * r1_hisf_tbl(ji,jj) 242 tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal) & 243 & + zfact * (risf_tsc_b(ji,jj,jp_sal) + risf_tsc(ji,jj,jp_sal)) * r1_hisf_tbl(ji,jj) 244 END DO 245 246 ! level partially include in ice shelf boundary layer 247 ! compute tfreez for the temperature correction (we add water at freezing temperature) 248 ! zpress = grav*rau0*fsdept(ji,jj,ikb)*1.e-04 249 zt_frz = -1.9 !eos_fzp( tsn(ji,jj,ikb,jp_sal), zpress ) 250 ! compute trend 251 tsa(ji,jj,ikb,jp_tem) = tsa(ji,jj,ikb,jp_tem) & 252 & + zfact * (risf_tsc_b(ji,jj,jp_tem) + risf_tsc(ji,jj,jp_tem) & 253 & - rdivisf * (fwfisf(ji,jj) + fwfisf_b(ji,jj)) * zt_frz * r1_rau0) & 254 & * r1_hisf_tbl(ji,jj) * ralpha(ji,jj) 255 tsa(ji,jj,ikb,jp_sal) = tsa(ji,jj,ikb,jp_sal) & 256 & + zfact * (risf_tsc_b(ji,jj,jp_sal) + risf_tsc(ji,jj,jp_sal)) * r1_hisf_tbl(ji,jj) * ralpha(ji,jj) 257 END DO 258 END DO 259 IF( lrst_oce ) THEN 260 IF(lwp) WRITE(numout,*) 261 IF(lwp) WRITE(numout,*) 'sbc : isf surface tracer content forcing fields written in ocean restart file ', & 262 & 'at it= ', kt,' date= ', ndastp 263 IF(lwp) WRITE(numout,*) '~~~~' 264 CALL iom_rstput( kt, nitrst, numrow, 'fwf_isf_b', fwfisf(:,:) ) 265 CALL iom_rstput( kt, nitrst, numrow, 'isf_hc_b' , risf_tsc(:,:,jp_tem) ) 266 CALL iom_rstput( kt, nitrst, numrow, 'isf_sc_b' , risf_tsc(:,:,jp_sal) ) 267 ENDIF 268 END IF 269 ! 207 270 !---------------------------------------- 208 271 ! River Runoff effects … … 226 289 ENDIF 227 290 228 IF( l_trdtra ) THEN ! s ave the horizontal diffusivetrends for further diagnostics291 IF( l_trdtra ) THEN ! send trends for further diagnostics 229 292 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 230 293 ztrds(:,:,:) = tsa(:,:,:,jp_sal) - ztrds(:,:,:) 231 CALL trd_tra( kt, 'TRA', jp_tem, jptra_ trd_nsr, ztrdt )232 CALL trd_tra( kt, 'TRA', jp_sal, jptra_ trd_nsr, ztrds )294 CALL trd_tra( kt, 'TRA', jp_tem, jptra_nsr, ztrdt ) 295 CALL trd_tra( kt, 'TRA', jp_sal, jptra_nsr, ztrds ) 233 296 CALL wrk_dealloc( jpi, jpj, jpk, ztrdt, ztrds ) 234 297 ENDIF -
branches/2014/dev_r4650_UKMO7_STARTHOUR/NEMOGCM/NEMO/OPA_SRC/TRA/trazdf.F90
r3294 r5075 19 19 USE sbc_oce ! surface boundary condition: ocean 20 20 USE dynspg_oce 21 22 21 USE trazdf_exp ! vertical diffusion: explicit (tra_zdf_exp routine) 23 22 USE trazdf_imp ! vertical diffusion: implicit (tra_zdf_imp routine) 24 25 23 USE ldftra_oce ! ocean active tracers: lateral physics 26 USE trdmod_oce ! ocean active tracers: lateral physics 27 USE trdtra ! ocean tracers trends 24 USE trd_oce ! trends: ocean variables 25 USE trdtra ! trends manager: tracers 26 ! 28 27 USE in_out_manager ! I/O manager 29 28 USE prtctl ! Print control … … 32 31 USE wrk_nemo ! Memory allocation 33 32 USE timing ! Timing 34 35 33 36 34 IMPLICIT NONE … … 47 45 # include "vectopt_loop_substitute.h90" 48 46 !!---------------------------------------------------------------------- 49 !! NEMO/OPA 3. 3 , NEMO Consortium (2010)47 !! NEMO/OPA 3.7 , NEMO Consortium (2014) 50 48 !! $Id$ 51 49 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 96 94 ztrds(:,:,jk) = ( ( tsa(:,:,jk,jp_sal) - tsb(:,:,jk,jp_sal) ) / r2dtra(jk) ) - ztrds(:,:,jk) 97 95 END DO 98 CALL trd_tra( kt, 'TRA', jp_tem, jptra_trd_zdf, ztrdt ) 99 CALL trd_tra( kt, 'TRA', jp_sal, jptra_trd_zdf, ztrds ) 96 CALL lbc_lnk( ztrdt, 'T', 1. ) 97 CALL lbc_lnk( ztrds, 'T', 1. ) 98 CALL trd_tra( kt, 'TRA', jp_tem, jptra_zdf, ztrdt ) 99 CALL trd_tra( kt, 'TRA', jp_sal, jptra_zdf, ztrds ) 100 100 CALL wrk_dealloc( jpi, jpj, jpk, ztrdt, ztrds ) 101 101 ENDIF -
branches/2014/dev_r4650_UKMO7_STARTHOUR/NEMOGCM/NEMO/OPA_SRC/TRA/trazdf_imp.F90
r3294 r5075 120 120 ELSE ; zwt(:,:,2:jpk) = fsavs(:,:,2:jpk) 121 121 ENDIF 122 zwt(:,:,1) = 0._wp 123 ! 122 DO jj=1, jpj 123 DO ji=1, jpi 124 zwt(ji,jj,1:mikt(ji,jj)) = 0._wp 125 END DO 126 END DO 127 ! 124 128 #if defined key_ldfslp 125 129 ! isoneutral diffusion: add the contribution … … 180 184 DO jj = 2, jpjm1 181 185 DO ji = fs_2, fs_jpim1 182 zwt(ji,jj,1) = zwd(ji,jj,1) 183 END DO 184 END DO 185 DO jk = 2, jpkm1 186 DO jj = 2, jpjm1 187 DO ji = fs_2, fs_jpim1 188 zwt(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwt(ji,jj,jk-1) 186 zwt(ji,jj,1:mikt(ji,jj)) = zwd(ji,jj,1:mikt(ji,jj)) 187 DO jk = mikt(ji,jj)+1, jpkm1 188 zwt(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwt(ji,jj,jk-1) 189 189 END DO 190 190 END DO … … 196 196 DO jj = 2, jpjm1 197 197 DO ji = fs_2, fs_jpim1 198 ze3tb = ( 1. - r_vvl ) + r_vvl * fse3t_b(ji,jj,1) 199 ze3tn = ( 1. - r_vvl ) + r_vvl * fse3t(ji,jj,1) 200 pta(ji,jj,1,jn) = ze3tb * ptb(ji,jj,1,jn) + p2dt(1) * ze3tn * pta(ji,jj,1,jn) 201 END DO 202 END DO 203 DO jk = 2, jpkm1 204 DO jj = 2, jpjm1 205 DO ji = fs_2, fs_jpim1 198 ze3tb = ( 1. - r_vvl ) + r_vvl * fse3t_b(ji,jj,mikt(ji,jj)) 199 ze3tn = ( 1. - r_vvl ) + r_vvl * fse3t(ji,jj,mikt(ji,jj)) 200 pta(ji,jj,mikt(ji,jj),jn) = ze3tb * ptb(ji,jj,mikt(ji,jj),jn) & 201 & + p2dt(mikt(ji,jj)) * ze3tn * pta(ji,jj,mikt(ji,jj),jn) 202 DO jk = mikt(ji,jj)+1, jpkm1 206 203 ze3tb = ( 1. - r_vvl ) + r_vvl * fse3t_b(ji,jj,jk) 207 204 ze3tn = ( 1. - r_vvl ) + r_vvl * fse3t (ji,jj,jk) … … 216 213 DO ji = fs_2, fs_jpim1 217 214 pta(ji,jj,jpkm1,jn) = pta(ji,jj,jpkm1,jn) / zwt(ji,jj,jpkm1) * tmask(ji,jj,jpkm1) 218 END DO 219 END DO 220 DO jk = jpk-2, 1, -1 221 DO jj = 2, jpjm1 222 DO ji = fs_2, fs_jpim1 215 DO jk = jpk-2, mikt(ji,jj), -1 223 216 pta(ji,jj,jk,jn) = ( pta(ji,jj,jk,jn) - zws(ji,jj,jk) * pta(ji,jj,jk+1,jn) ) & 224 217 & / zwt(ji,jj,jk) * tmask(ji,jj,jk) -
branches/2014/dev_r4650_UKMO7_STARTHOUR/NEMOGCM/NEMO/OPA_SRC/TRA/zpshde.F90
r3294 r5075 40 40 41 41 SUBROUTINE zps_hde( kt, kjpt, pta, pgtu, pgtv, & 42 prd, pgru, pgrv ) 42 & prd, pgru, pgrv, pmru, pmrv, pgzu, pgzv, pge3ru, pge3rv, & 43 & sgtu, sgtv, sgru, sgrv, smru, smrv, sgzu, sgzv, sge3ru, sge3rv ) 43 44 !!---------------------------------------------------------------------- 44 45 !! *** ROUTINE zps_hde *** … … 74 75 !! Idem for di(s) and dj(s) 75 76 !! 76 !! For rho, we call eos _insitu_2d which will compute rd~(t~,s~) at77 !! the good depth zh from interpolated T and S for the different78 !! formulationof the equation of state (eos).77 !! For rho, we call eos which will compute rd~(t~,s~) at the right 78 !! depth zh from interpolated T and S for the different formulations 79 !! of the equation of state (eos). 79 80 !! Gradient formulation for rho : 80 !! di(rho) = rd~ - rd(i,j,k) orrd(i+1,j,k) - rd~81 !! di(rho) = rd~ - rd(i,j,k) or rd(i+1,j,k) - rd~ 81 82 !! 82 !! ** Action : - pgtu, pgtv: horizontal gradient of tracer at u- & v-points 83 !! - pgru, pgrv: horizontal gradient of rho (if present) at u- & v-points 83 !! ** Action : compute for top and bottom interfaces 84 !! - pgtu, pgtv, sgtu, sgtv: horizontal gradient of tracer at u- & v-points 85 !! - pgru, pgrv, sgru, sgtv: horizontal gradient of rho (if present) at u- & v-points 86 !! - pmru, pmrv, smru, smrv: horizontal sum of rho at u- & v- point (used in dynhpg with vvl) 87 !! - pgzu, pgzv, sgzu, sgzv: horizontal gradient of z at u- and v- point (used in dynhpg with vvl) 88 !! - pge3ru, pge3rv, sge3ru, sge3rv: horizontal gradient of rho weighted by local e3w at u- & v-points 84 89 !!---------------------------------------------------------------------- 85 !86 90 INTEGER , INTENT(in ) :: kt ! ocean time-step index 87 91 INTEGER , INTENT(in ) :: kjpt ! number of tracers 88 92 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: pta ! 4D tracers fields 89 93 REAL(wp), DIMENSION(jpi,jpj, kjpt), INTENT( out) :: pgtu, pgtv ! hor. grad. of ptra at u- & v-pts 94 REAL(wp), DIMENSION(jpi,jpj, kjpt), INTENT( out) :: sgtu, sgtv ! hor. grad. of stra at u- & v-pts (ISF) 90 95 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ), OPTIONAL :: prd ! 3D density anomaly fields 91 REAL(wp), DIMENSION(jpi,jpj ), INTENT( out), OPTIONAL :: pgru, pgrv ! hor. grad. of prd at u- & v-pts 96 REAL(wp), DIMENSION(jpi,jpj ), INTENT( out), OPTIONAL :: pgru, pgrv ! hor. grad of prd at u- & v-pts (bottom) 97 REAL(wp), DIMENSION(jpi,jpj ), INTENT( out), OPTIONAL :: pmru, pmrv ! hor. sum of prd at u- & v-pts (bottom) 98 REAL(wp), DIMENSION(jpi,jpj ), INTENT( out), OPTIONAL :: pgzu, pgzv ! hor. grad of z at u- & v-pts (bottom) 99 REAL(wp), DIMENSION(jpi,jpj ), INTENT( out), OPTIONAL :: pge3ru, pge3rv ! hor. grad of prd weighted by local e3w at u- & v-pts (bottom) 100 REAL(wp), DIMENSION(jpi,jpj ), INTENT( out), OPTIONAL :: sgru, sgrv ! hor. grad of prd at u- & v-pts (top) 101 REAL(wp), DIMENSION(jpi,jpj ), INTENT( out), OPTIONAL :: smru, smrv ! hor. sum of prd at u- & v-pts (top) 102 REAL(wp), DIMENSION(jpi,jpj ), INTENT( out), OPTIONAL :: sgzu, sgzv ! hor. grad of z at u- & v-pts (top) 103 REAL(wp), DIMENSION(jpi,jpj ), INTENT( out), OPTIONAL :: sge3ru, sge3rv ! hor. grad of prd weighted by local e3w at u- & v-pts (top) 92 104 ! 93 105 INTEGER :: ji, jj, jn ! Dummy loop indices 94 INTEGER :: iku, ikv, ikum1, ikvm1 ! partial step level (ocean bottom level) at u- and v-points95 REAL(wp) :: ze3wu, ze3wv, zmaxu, zmaxv ! temporary scalars96 REAL(wp), POINTER, DIMENSION(:,: ) :: zri, zrj, zhi, zhj97 REAL(wp), POINTER, DIMENSION(:,:,:) :: zti, ztj ! interpolated value of tracer106 INTEGER :: iku, ikv, ikum1, ikvm1,ikup1, ikvp1 ! partial step level (ocean bottom level) at u- and v-points 107 REAL(wp) :: ze3wu, ze3wv, zmaxu, zmaxv, zdzwu, zdzwv, zdzwuip1, zdzwvjp1 ! temporary scalars 108 REAL(wp), DIMENSION(jpi,jpj) :: zri, zrj, zhi, zhj ! NB: 3rd dim=1 to use eos 109 REAL(wp), DIMENSION(jpi,jpj,kjpt) :: zti, ztj ! 98 110 !!---------------------------------------------------------------------- 99 111 ! 100 112 IF( nn_timing == 1 ) CALL timing_start( 'zps_hde') 101 113 ! 102 CALL wrk_alloc( jpi, jpj, zri, zrj, zhi, zhj ) 103 CALL wrk_alloc( jpi, jpj, kjpt, zti, ztj ) 114 pgtu(:,:,:)=0.0_wp ; pgtv(:,:,:)=0.0_wp ; 115 sgtu(:,:,:)=0.0_wp ; sgtv(:,:,:)=0.0_wp ; 116 zti (:,:,:)=0.0_wp ; ztj (:,:,:)=0.0_wp ; 117 zhi (:,: )=0.0_wp ; zhj (:,: )=0.0_wp ; 104 118 ! 105 119 DO jn = 1, kjpt !== Interpolation of tracers at the last ocean level ==! 106 120 ! 107 # if defined key_vectopt_loop 108 jj = 1 109 DO ji = 1, jpij-jpi ! vector opt. (forced unrolled) 110 # else 111 DO jj = 1, jpjm1 112 DO ji = 1, jpim1 113 # endif 121 DO jj = 1, jpjm1 122 DO ji = 1, jpim1 114 123 iku = mbku(ji,jj) ; ikum1 = MAX( iku - 1 , 1 ) ! last and before last ocean level at u- & v-points 115 124 ikv = mbkv(ji,jj) ; ikvm1 = MAX( ikv - 1 , 1 ) ! if level first is a p-step, ik.m1=1 116 ze3wu = fse3w(ji+1,jj ,iku) - fse3w(ji,jj,iku) 117 ze3wv = fse3w(ji ,jj+1,ikv) - fse3w(ji,jj,ikv) 125 ! (ISF) case partial step top and bottom in adjacent cell in vertical 126 ! cannot used e3w because if 2 cell water column, we have ps at top and bottom 127 ! in this case e3w(i,j) - e3w(i,j+1) is not the distance between Tj~ and Tj 128 ! the only common depth between cells (i,j) and (i,j+1) is gdepw_0 129 ze3wu = (gdept_0(ji+1,jj,iku) - gdepw_0(ji+1,jj,iku)) - (gdept_0(ji,jj,iku) - gdepw_0(ji,jj,iku)) 130 ze3wv = (gdept_0(ji,jj+1,ikv) - gdepw_0(ji,jj+1,ikv)) - (gdept_0(ji,jj,ikv) - gdepw_0(ji,jj,ikv)) 118 131 ! 119 132 ! i- direction … … 121 134 zmaxu = ze3wu / fse3w(ji+1,jj,iku) 122 135 ! interpolated values of tracers 123 zti (ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,ikum1,jn) - pta(ji+1,jj,iku,jn) )136 zti (ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,ikum1,jn) - pta(ji+1,jj,iku,jn) ) 124 137 ! gradient of tracers 125 pgtu(ji,jj,jn) = umask(ji,jj, 1) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) )138 pgtu(ji,jj,jn) = umask(ji,jj,iku) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) ) 126 139 ELSE ! case 2 127 140 zmaxu = -ze3wu / fse3w(ji,jj,iku) 128 141 ! interpolated values of tracers 129 zti (ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,ikum1,jn) - pta(ji,jj,iku,jn) )130 ! gradient of tracers 131 pgtu(ji,jj,jn) = umask(ji,jj, 1) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) )142 zti (ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,ikum1,jn) - pta(ji,jj,iku,jn) ) 143 ! gradient of tracers 144 pgtu(ji,jj,jn) = umask(ji,jj,iku) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) ) 132 145 ENDIF 133 146 ! … … 136 149 zmaxv = ze3wv / fse3w(ji,jj+1,ikv) 137 150 ! interpolated values of tracers 138 ztj (ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikvm1,jn) - pta(ji,jj+1,ikv,jn) )139 ! gradient of tracers 140 pgtv(ji,jj,jn) = vmask(ji,jj, 1) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) )151 ztj (ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikvm1,jn) - pta(ji,jj+1,ikv,jn) ) 152 ! gradient of tracers 153 pgtv(ji,jj,jn) = vmask(ji,jj,ikv) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) ) 141 154 ELSE ! case 2 142 155 zmaxv = -ze3wv / fse3w(ji,jj,ikv) 143 156 ! interpolated values of tracers 144 ztj(ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikvm1,jn) - pta(ji,jj,ikv,jn) ) 145 ! gradient of tracers 146 pgtv(ji,jj,jn) = vmask(ji,jj,1) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) ) 147 ENDIF 148 # if ! defined key_vectopt_loop 149 END DO 150 # endif 157 ztj (ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikvm1,jn) - pta(ji,jj,ikv,jn) ) 158 ! gradient of tracers 159 pgtv(ji,jj,jn) = vmask(ji,jj,ikv) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) ) 160 ENDIF 161 END DO 151 162 END DO 152 163 CALL lbc_lnk( pgtu(:,:,jn), 'U', -1. ) ; CALL lbc_lnk( pgtv(:,:,jn), 'V', -1. ) ! Lateral boundary cond. … … 156 167 ! horizontal derivative of density anomalies (rd) 157 168 IF( PRESENT( prd ) ) THEN ! depth of the partial step level 158 # if defined key_vectopt_loop 159 jj = 1 160 DO ji = 1, jpij-jpi ! vector opt. (forced unrolled) 161 # else 162 DO jj = 1, jpjm1 163 DO ji = 1, jpim1 164 # endif 169 pgru(:,:)=0.0_wp ; pgrv(:,:)=0.0_wp ; 170 pgzu(:,:)=0.0_wp ; pgzv(:,:)=0.0_wp ; 171 pmru(:,:)=0.0_wp ; pmru(:,:)=0.0_wp ; 172 pge3ru(:,:)=0.0_wp ; pge3rv(:,:)=0.0_wp ; 173 DO jj = 1, jpjm1 174 DO ji = 1, jpim1 165 175 iku = mbku(ji,jj) 166 176 ikv = mbkv(ji,jj) 167 ze3wu = fse3w(ji+1,jj ,iku) - fse3w(ji,jj,iku) 168 ze3wv = fse3w(ji ,jj+1,ikv) - fse3w(ji,jj,ikv) 169 IF( ze3wu >= 0._wp ) THEN ; zhi(ji,jj) = fsdept(ji ,jj,iku) ! i-direction: case 1 170 ELSE ; zhi(ji,jj) = fsdept(ji+1,jj,iku) ! - - case 2 171 ENDIF 172 IF( ze3wv >= 0._wp ) THEN ; zhj(ji,jj) = fsdept(ji,jj ,ikv) ! j-direction: case 1 173 ELSE ; zhj(ji,jj) = fsdept(ji,jj+1,ikv) ! - - case 2 174 ENDIF 175 # if ! defined key_vectopt_loop 176 END DO 177 # endif 178 END DO 179 177 ze3wu = (gdept_0(ji+1,jj,iku) - gdepw_0(ji+1,jj,iku)) - (gdept_0(ji,jj,iku) - gdepw_0(ji,jj,iku)) 178 ze3wv = (gdept_0(ji,jj+1,ikv) - gdepw_0(ji,jj+1,ikv)) - (gdept_0(ji,jj,ikv) - gdepw_0(ji,jj,ikv)) 179 180 IF( ze3wu >= 0._wp ) THEN ; zhi(ji,jj) = fsdept(ji+1,jj,iku) - ze3wu ! i-direction: case 1 181 ELSE ; zhi(ji,jj) = fsdept(ji ,jj,iku) + ze3wu ! - - case 2 182 ENDIF 183 IF( ze3wv >= 0._wp ) THEN ; zhj(ji,jj) = fsdept(ji,jj+1,ikv) - ze3wv ! j-direction: case 1 184 ELSE ; zhj(ji,jj) = fsdept(ji,jj ,ikv) + ze3wv ! - - case 2 185 ENDIF 186 END DO 187 END DO 188 180 189 ! Compute interpolated rd from zti, ztj for the 2 cases at the depth of the partial 181 190 ! step and store it in zri, zrj for each case … … 184 193 185 194 ! Gradient of density at the last level 186 # if defined key_vectopt_loop 187 jj = 1 188 DO ji = 1, jpij-jpi ! vector opt. (forced unrolled) 189 # else 190 DO jj = 1, jpjm1 191 DO ji = 1, jpim1 192 # endif 193 iku = mbku(ji,jj) 194 ikv = mbkv(ji,jj) 195 ze3wu = fse3w(ji+1,jj ,iku) - fse3w(ji,jj,iku) 196 ze3wv = fse3w(ji ,jj+1,ikv) - fse3w(ji,jj,ikv) 197 IF( ze3wu >= 0._wp ) THEN ; pgru(ji,jj) = umask(ji,jj,1) * ( zri(ji ,jj) - prd(ji,jj,iku) ) ! i: 1 198 ELSE ; pgru(ji,jj) = umask(ji,jj,1) * ( prd(ji+1,jj,iku) - zri(ji,jj) ) ! i: 2 199 ENDIF 200 IF( ze3wv >= 0._wp ) THEN ; pgrv(ji,jj) = vmask(ji,jj,1) * ( zrj(ji,jj ) - prd(ji,jj,ikv) ) ! j: 1 201 ELSE ; pgrv(ji,jj) = vmask(ji,jj,1) * ( prd(ji,jj+1,ikv) - zrj(ji,jj) ) ! j: 2 202 ENDIF 203 # if ! defined key_vectopt_loop 204 END DO 205 # endif 206 END DO 207 CALL lbc_lnk( pgru , 'U', -1. ) ; CALL lbc_lnk( pgrv , 'V', -1. ) ! Lateral boundary conditions 195 DO jj = 1, jpjm1 196 DO ji = 1, jpim1 197 iku = mbku(ji,jj) ; ikum1 = MAX( iku - 1 , 1 ) ! last and before last ocean level at u- & v-points 198 ikv = mbkv(ji,jj) ; ikvm1 = MAX( ikv - 1 , 1 ) ! last and before last ocean level at u- & v-points 199 ze3wu = (gdept_0(ji+1,jj,iku) - gdepw_0(ji+1,jj,iku)) - (gdept_0(ji,jj,iku) - gdepw_0(ji,jj,iku)) 200 ze3wv = (gdept_0(ji,jj+1,ikv) - gdepw_0(ji,jj+1,ikv)) - (gdept_0(ji,jj,ikv) - gdepw_0(ji,jj,ikv)) 201 IF( ze3wu >= 0._wp ) THEN 202 pgzu(ji,jj) = (fsde3w(ji+1,jj,iku) - ze3wu) - fsde3w(ji,jj,iku) 203 pgru(ji,jj) = umask(ji,jj,iku) * ( zri(ji ,jj) - prd(ji,jj,iku) ) ! i: 1 204 pmru(ji,jj) = umask(ji,jj,iku) * ( zri(ji ,jj) + prd(ji,jj,iku) ) ! i: 1 205 pge3ru(ji,jj) = umask(ji,jj,iku) & 206 * ( (fse3w(ji+1,jj,iku) - ze3wu )* ( zri(ji ,jj ) + prd(ji+1,jj,ikum1) + 2._wp) & 207 - fse3w(ji ,jj,iku) * ( prd(ji ,jj,iku) + prd(ji ,jj,ikum1) + 2._wp) ) ! j: 2 208 ELSE 209 pgzu(ji,jj) = fsde3w(ji+1,jj,iku) - (fsde3w(ji,jj,iku) + ze3wu) 210 pgru(ji,jj) = umask(ji,jj,iku) * ( prd(ji+1,jj,iku) - zri(ji,jj) ) ! i: 2 211 pmru(ji,jj) = umask(ji,jj,iku) * ( prd(ji+1,jj,iku) + zri(ji,jj) ) ! i: 2 212 pge3ru(ji,jj) = umask(ji,jj,iku) & 213 * ( fse3w(ji+1,jj,iku) * ( prd(ji+1,jj,iku) + prd(ji+1,jj,ikum1) + 2._wp) & 214 -(fse3w(ji ,jj,iku) + ze3wu) * ( zri(ji ,jj ) + prd(ji ,jj,ikum1) + 2._wp) ) ! j: 2 215 ENDIF 216 IF( ze3wv >= 0._wp ) THEN 217 pgzv(ji,jj) = (fsde3w(ji,jj+1,ikv) - ze3wv) - fsde3w(ji,jj,ikv) 218 pgrv(ji,jj) = vmask(ji,jj,ikv) * ( zrj(ji,jj ) - prd(ji,jj,ikv) ) ! j: 1 219 pmrv(ji,jj) = vmask(ji,jj,ikv) * ( zrj(ji,jj ) + prd(ji,jj,ikv) ) ! j: 1 220 pge3rv(ji,jj) = vmask(ji,jj,ikv) & 221 * ( (fse3w(ji,jj+1,ikv) - ze3wv )* ( zrj(ji,jj ) + prd(ji,jj+1,ikvm1) + 2._wp) & 222 - fse3w(ji,jj ,ikv) * ( prd(ji,jj ,ikv) + prd(ji,jj ,ikvm1) + 2._wp) ) ! j: 2 223 ELSE 224 pgzv(ji,jj) = fsde3w(ji,jj+1,ikv) - (fsde3w(ji,jj,ikv) + ze3wv) 225 pgrv(ji,jj) = vmask(ji,jj,ikv) * ( prd(ji,jj+1,ikv) - zrj(ji,jj) ) ! j: 2 226 pmrv(ji,jj) = vmask(ji,jj,ikv) * ( prd(ji,jj+1,ikv) + zrj(ji,jj) ) ! j: 2 227 pge3rv(ji,jj) = vmask(ji,jj,ikv) & 228 * ( fse3w(ji,jj+1,ikv) * ( prd(ji,jj+1,ikv) + prd(ji,jj+1,ikvm1) + 2._wp) & 229 -(fse3w(ji,jj ,ikv) + ze3wv) * ( zrj(ji,jj ) + prd(ji,jj ,ikvm1) + 2._wp) ) ! j: 2 230 ENDIF 231 END DO 232 END DO 233 CALL lbc_lnk( pgru , 'U', -1. ) ; CALL lbc_lnk( pgrv , 'V', -1. ) ! Lateral boundary conditions 234 CALL lbc_lnk( pmru , 'U', 1. ) ; CALL lbc_lnk( pmrv , 'V', 1. ) ! Lateral boundary conditions 235 CALL lbc_lnk( pgzu , 'U', -1. ) ; CALL lbc_lnk( pgzv , 'V', -1. ) ! Lateral boundary conditions 236 CALL lbc_lnk( pge3ru , 'U', -1. ) ; CALL lbc_lnk( pge3rv , 'V', -1. ) ! Lateral boundary conditions 208 237 ! 209 238 END IF 210 ! 211 CALL wrk_dealloc( jpi, jpj, zri, zrj, zhi, zhj ) 212 CALL wrk_dealloc( jpi, jpj, kjpt, zti, ztj ) 239 ! (ISH) compute grui and gruvi 240 DO jn = 1, kjpt !== Interpolation of tracers at the last ocean level ==! ! 241 DO jj = 1, jpjm1 242 DO ji = 1, jpim1 243 iku = miku(ji,jj) ; ikup1 = miku(ji,jj) + 1 244 ikv = mikv(ji,jj) ; ikvp1 = mikv(ji,jj) + 1 245 ! 246 ! (ISF) case partial step top and bottom in adjacent cell in vertical 247 ! cannot used e3w because if 2 cell water column, we have ps at top and bottom 248 ! in this case e3w(i,j) - e3w(i,j+1) is not the distance between Tj~ and Tj 249 ! the only common depth between cells (i,j) and (i,j+1) is gdepw_0 250 ze3wu = (gdepw_0(ji+1,jj,iku+1) - gdept_0(ji+1,jj,iku)) - (gdepw_0(ji,jj,iku+1) - gdept_0(ji,jj,iku)) 251 ze3wv = (gdepw_0(ji,jj+1,ikv+1) - gdept_0(ji,jj+1,ikv)) - (gdepw_0(ji,jj,ikv+1) - gdept_0(ji,jj,ikv)) 252 ! i- direction 253 IF( ze3wu >= 0._wp ) THEN ! case 1 254 zmaxu = ze3wu / fse3w(ji+1,jj,iku+1) 255 ! interpolated values of tracers 256 zti(ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,iku+1,jn) - pta(ji+1,jj,iku,jn) ) 257 ! gradient of tracers 258 sgtu(ji,jj,jn) = umask(ji,jj,iku) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) ) 259 ELSE ! case 2 260 zmaxu = - ze3wu / fse3w(ji,jj,iku+1) 261 ! interpolated values of tracers 262 zti(ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,iku+1,jn) - pta(ji,jj,iku,jn) ) 263 ! gradient of tracers 264 sgtu(ji,jj,jn) = umask(ji,jj,iku) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) ) 265 ENDIF 266 ! 267 ! j- direction 268 IF( ze3wv >= 0._wp ) THEN ! case 1 269 zmaxv = ze3wv / fse3w(ji,jj+1,ikv+1) 270 ! interpolated values of tracers 271 ztj(ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikv+1,jn) - pta(ji,jj+1,ikv,jn) ) 272 ! gradient of tracers 273 sgtv(ji,jj,jn) = vmask(ji,jj,ikv) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) ) 274 ELSE ! case 2 275 zmaxv = - ze3wv / fse3w(ji,jj,ikv+1) 276 ! interpolated values of tracers 277 ztj(ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikv+1,jn) - pta(ji,jj,ikv,jn) ) 278 ! gradient of tracers 279 sgtv(ji,jj,jn) = vmask(ji,jj,ikv) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) ) 280 ENDIF 281 END DO!! 282 END DO!! 283 CALL lbc_lnk( sgtu(:,:,jn), 'U', -1. ) ; CALL lbc_lnk( sgtv(:,:,jn), 'V', -1. ) ! Lateral boundary cond. 284 ! 285 END DO 286 287 ! horizontal derivative of density anomalies (rd) 288 IF( PRESENT( prd ) ) THEN ! depth of the partial step level 289 sgru(:,:) =0.0_wp ; sgrv(:,:) =0.0_wp ; 290 sgzu(:,:) =0.0_wp ; sgzv(:,:) =0.0_wp ; 291 smru(:,:) =0.0_wp ; smru(:,:) =0.0_wp ; 292 sge3ru(:,:)=0.0_wp ; sge3rv(:,:)=0.0_wp ; 293 294 DO jj = 1, jpjm1 295 DO ji = 1, jpim1 296 iku = miku(ji,jj) 297 ikv = mikv(ji,jj) 298 ze3wu = (gdepw_0(ji+1,jj,iku+1) - gdept_0(ji+1,jj,iku)) - (gdepw_0(ji,jj,iku+1) - gdept_0(ji,jj,iku)) 299 ze3wv = (gdepw_0(ji,jj+1,ikv+1) - gdept_0(ji,jj+1,ikv)) - (gdepw_0(ji,jj,ikv+1) - gdept_0(ji,jj,ikv)) 300 301 IF( ze3wu >= 0._wp ) THEN ; zhi(ji,jj) = fsdept(ji+1,jj,iku) + ze3wu ! i-direction: case 1 302 ELSE ; zhi(ji,jj) = fsdept(ji ,jj,iku) - ze3wu ! - - case 2 303 ENDIF 304 IF( ze3wv >= 0._wp ) THEN ; zhj(ji,jj) = fsdept(ji,jj+1,ikv) + ze3wv ! j-direction: case 1 305 ELSE ; zhj(ji,jj) = fsdept(ji,jj ,ikv) - ze3wv ! - - case 2 306 ENDIF 307 END DO 308 END DO 309 310 ! Compute interpolated rd from zti, ztj for the 2 cases at the depth of the partial 311 ! step and store it in zri, zrj for each case 312 CALL eos( zti, zhi, zri ) 313 CALL eos( ztj, zhj, zrj ) 314 315 ! Gradient of density at the last level 316 DO jj = 1, jpjm1 317 DO ji = 1, jpim1 318 iku = miku(ji,jj) ; ikup1 = miku(ji,jj) + 1 319 ikv = mikv(ji,jj) ; ikvp1 = mikv(ji,jj) + 1 320 ze3wu = (gdepw_0(ji+1,jj,iku+1) - gdept_0(ji+1,jj,iku)) - (gdepw_0(ji,jj,iku+1) - gdept_0(ji,jj,iku)) 321 ze3wv = (gdepw_0(ji,jj+1,ikv+1) - gdept_0(ji,jj+1,ikv)) - (gdepw_0(ji,jj,ikv+1) - gdept_0(ji,jj,ikv)) 322 IF( ze3wu >= 0._wp ) THEN 323 sgzu (ji,jj) = (fsde3w(ji+1,jj,iku) + ze3wu) - fsde3w(ji,jj,iku) 324 sgru (ji,jj) = umask(ji,jj,iku) * ( zri(ji,jj) - prd(ji,jj,iku) ) ! i: 1 325 smru (ji,jj) = umask(ji,jj,iku) * ( zri(ji,jj) + prd(ji,jj,iku) ) ! i: 1 326 sge3ru(ji,jj) = umask(ji,jj,iku+1) & 327 * ( (fse3w(ji+1,jj,iku+1) - ze3wu) * (zri(ji,jj ) + prd(ji+1,jj,iku+1) + 2._wp) & 328 - fse3w(ji ,jj,iku+1) * (prd(ji,jj,iku) + prd(ji ,jj,iku+1) + 2._wp) ) ! i: 1 329 ELSE 330 sgzu (ji,jj) = fsde3w(ji+1,jj,iku) - (fsde3w(ji,jj,iku) - ze3wu) 331 sgru (ji,jj) = umask(ji,jj,iku) * ( prd(ji+1,jj,iku) - zri(ji,jj) ) ! i: 2 332 smru (ji,jj) = umask(ji,jj,iku) * ( prd(ji+1,jj,iku) + zri(ji,jj) ) ! i: 2 333 sge3ru(ji,jj) = umask(ji,jj,iku+1) & 334 * ( fse3w(ji+1,jj,iku+1) * (prd(ji+1,jj,iku) + prd(ji+1,jj,iku+1) + 2._wp) & 335 -(fse3w(ji ,jj,iku+1) + ze3wu) * (zri(ji,jj ) + prd(ji ,jj,iku+1) + 2._wp) ) ! i: 2 336 ENDIF 337 IF( ze3wv >= 0._wp ) THEN 338 sgzv (ji,jj) = (fsde3w(ji,jj+1,ikv) + ze3wv) - fsde3w(ji,jj,ikv) 339 sgrv (ji,jj) = vmask(ji,jj,ikv) * ( zrj(ji,jj ) - prd(ji,jj,ikv) ) ! j: 1 340 smrv (ji,jj) = vmask(ji,jj,ikv) * ( zrj(ji,jj ) + prd(ji,jj,ikv) ) ! j: 1 341 sge3rv(ji,jj) = vmask(ji,jj,ikv+1) & 342 * ( (fse3w(ji,jj+1,ikv+1) - ze3wv) * ( zrj(ji,jj ) + prd(ji,jj+1,ikv+1) + 2._wp) & 343 - fse3w(ji,jj ,ikv+1) * ( prd(ji,jj,ikv) + prd(ji,jj ,ikv+1) + 2._wp) ) ! j: 1 344 ! + 2 due to the formulation in density and not in anomalie in hpg sco 345 ELSE 346 sgzv (ji,jj) = fsde3w(ji,jj+1,ikv) - (fsde3w(ji,jj,ikv) - ze3wv) 347 sgrv (ji,jj) = vmask(ji,jj,ikv) * ( prd(ji,jj+1,ikv) - zrj(ji,jj) ) ! j: 2 348 smrv (ji,jj) = vmask(ji,jj,ikv) * ( prd(ji,jj+1,ikv) + zrj(ji,jj) ) ! j: 2 349 sge3rv(ji,jj) = vmask(ji,jj,ikv+1) & 350 * ( fse3w(ji,jj+1,ikv+1) * ( prd(ji,jj+1,ikv) + prd(ji,jj+1,ikv+1) + 2._wp) & 351 -(fse3w(ji,jj ,ikv+1) + ze3wv) * ( zrj(ji,jj ) + prd(ji,jj ,ikv+1) + 2._wp) ) ! j: 2 352 ENDIF 353 END DO 354 END DO 355 CALL lbc_lnk( sgru , 'U', -1. ) ; CALL lbc_lnk( sgrv , 'V', -1. ) ! Lateral boundary conditions 356 CALL lbc_lnk( smru , 'U', 1. ) ; CALL lbc_lnk( smrv , 'V', 1. ) ! Lateral boundary conditions 357 CALL lbc_lnk( sgzu , 'U', -1. ) ; CALL lbc_lnk( sgzv , 'V', -1. ) ! Lateral boundary conditions 358 CALL lbc_lnk( sge3ru , 'U', -1. ) ; CALL lbc_lnk( sge3rv , 'V', -1. ) ! Lateral boundary conditions 359 ! 360 END IF 213 361 ! 214 362 IF( nn_timing == 1 ) CALL timing_stop( 'zps_hde')
Note: See TracChangeset
for help on using the changeset viewer.
