- Timestamp:
- 2016-01-08T10:35:19+01:00 (8 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2014/dev_r4704_NOC5_MPP_BDY_UPDATE/NEMOGCM/NEMO/OPA_SRC/TRA/trabbl.F90
r4624 r6225 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 !!---------------------------------------------------------------------- 15 #if defined key_trabbl || defined key_esopa 14 !! - ! 2013-04 (F. Roquet, G. Madec) use of eosbn2 instead of local hard coded alpha and beta 15 !!---------------------------------------------------------------------- 16 #if defined key_trabbl 16 17 !!---------------------------------------------------------------------- 17 18 !! 'key_trabbl' or bottom boundary layer … … 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 … … 68 70 69 71 !! * Substitutions 70 # include "domzgr_substitute.h90"71 72 # include "vectopt_loop_substitute.h90" 72 73 !!---------------------------------------------------------------------- … … 84 85 & vtr_bbl (jpi,jpj) , ahv_bbl (jpi,jpj) , mbkv_d (jpi,jpj) , mgrhv(jpi,jpj) , & 85 86 & 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)87 & e3u_bbl_0(jpi,jpj) , e3v_bbl_0(jpi,jpj) , STAT=tra_bbl_alloc ) 87 88 ! 88 89 IF( lk_mpp ) CALL mpp_sum ( tra_bbl_alloc ) … … 104 105 !!---------------------------------------------------------------------- 105 106 INTEGER, INTENT( in ) :: kt ! ocean time-step 106 ! !107 ! 107 108 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdt, ztrds 108 109 !!---------------------------------------------------------------------- … … 110 111 IF( nn_timing == 1 ) CALL timing_start( 'tra_bbl') 111 112 ! 112 IF( l_trdtra ) THEN !* Save ta and satrends113 IF( l_trdtra ) THEN !* Save the input trends 113 114 CALL wrk_alloc( jpi, jpj, jpk, ztrdt, ztrds ) 114 115 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) … … 116 117 ENDIF 117 118 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 bbl119 IF( l_bbl ) CALL bbl( kt, nit000, 'TRA' ) !* bbl coef. and transport (only if not already done in trcbbl) 120 121 IF( nn_bbl_ldf == 1 ) THEN !* Diffusive bbl 121 122 ! 122 123 CALL tra_bbl_dif( tsb, tsa, jpts ) 123 124 IF( ln_ctl ) & 124 125 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' )126 & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 126 127 ! lateral boundary conditions ; just need for outputs 127 128 CALL lbc_lnk( ahu_bbl, 'U', 1. ) ; CALL lbc_lnk( ahv_bbl, 'V', 1. ) … … 130 131 ! 131 132 END IF 132 133 IF( nn_bbl_adv /= 0 ) THEN !* Advective bbl133 ! 134 IF( nn_bbl_adv /= 0 ) THEN !* Advective bbl 134 135 ! 135 136 CALL tra_bbl_adv( tsb, tsa, jpts ) 136 137 IF(ln_ctl) & 137 138 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' )139 & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 139 140 ! lateral boundary conditions ; just need for outputs 140 141 CALL lbc_lnk( utr_bbl, 'U', 1. ) ; CALL lbc_lnk( vtr_bbl, 'V', 1. ) … … 144 145 END IF 145 146 146 IF( l_trdtra ) THEN ! s ave the horizontal diffusive trends for further diagnostics147 IF( l_trdtra ) THEN ! send the trends for further diagnostics 147 148 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 148 149 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 )150 CALL trd_tra( kt, 'TRA', jp_tem, jptra_bbl, ztrdt ) 151 CALL trd_tra( kt, 'TRA', jp_sal, jptra_bbl, ztrds ) 151 152 CALL wrk_dealloc( jpi, jpj, jpk, ztrdt, ztrds ) 152 153 ENDIF … … 164 165 !! advection terms. 165 166 !! 166 !! ** Method : 167 !! * diffusive bbl (nn_bbl_ldf=1) : 167 !! ** Method : * diffusive bbl only (nn_bbl_ldf=1) : 168 168 !! When the product grad( rho) * grad(h) < 0 (where grad is an 169 169 !! along bottom slope gradient) an additional lateral 2nd order … … 179 179 !! Campin, J.-M., and H. Goosse, 1999, Tellus, 412-430. 180 180 !!---------------------------------------------------------------------- 181 !182 181 INTEGER , INTENT(in ) :: kjpt ! number of tracers 183 182 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb ! before and now tracer fields … … 196 195 DO jn = 1, kjpt ! tracer loop 197 196 ! ! =========== 198 # if defined key_vectopt_loop199 DO jj = 1, 1 ! vector opt. (forced unrolling)200 DO ji = 1, jpij201 #else202 197 DO jj = 1, jpj 203 198 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 199 ik = mbkt(ji,jj) ! bottom T-level index 200 zptb(ji,jj) = ptb(ji,jj,ik,jn) ! bottom before T and S 207 201 END DO 208 202 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 203 ! 204 DO jj = 2, jpjm1 ! Compute the trend 215 205 DO ji = 2, jpim1 216 # endif217 206 ik = mbkt(ji,jj) ! bottom T-level index 218 zbtr = r1_e12t(ji,jj) / fse3t(ji,jj,ik)219 pta(ji,jj,ik,jn) = pta(ji,jj,ik,jn)&220 & + ( ahu_bbl(ji ,jj ) * ( zptb(ji+1,jj ) - zptb(ji ,jj ) )&221 & - ahu_bbl(ji-1,jj ) * ( zptb(ji ,jj ) - zptb(ji-1,jj ) )&222 & + ahv_bbl(ji ,jj ) * ( zptb(ji ,jj+1) - zptb(ji ,jj ) )&223 & - ahv_bbl(ji ,jj-1) * ( zptb(ji ,jj ) - zptb(ji ,jj-1) ) ) * zbtr207 pta(ji,jj,ik,jn) = pta(ji,jj,ik,jn) & 208 & + ( ahu_bbl(ji ,jj ) * ( zptb(ji+1,jj ) - zptb(ji ,jj ) ) & 209 & - ahu_bbl(ji-1,jj ) * ( zptb(ji ,jj ) - zptb(ji-1,jj ) ) & 210 & + ahv_bbl(ji ,jj ) * ( zptb(ji ,jj+1) - zptb(ji ,jj ) ) & 211 & - ahv_bbl(ji ,jj-1) * ( zptb(ji ,jj ) - zptb(ji ,jj-1) ) ) & 212 & * r1_e1e2t(ji,jj) / e3t_n(ji,jj,ik) 224 213 END DO 225 214 END DO … … 264 253 DO jn = 1, kjpt ! tracer loop 265 254 ! ! =========== 266 # if defined key_vectopt_loop267 DO jj = 1, 1268 DO ji = 1, jpij-jpi-1 ! vector opt. (forced unrolling)269 # else270 255 DO jj = 1, jpjm1 271 256 DO ji = 1, jpim1 ! CAUTION start from i=1 to update i=2 when cyclic east-west 272 # endif273 257 IF( utr_bbl(ji,jj) /= 0.e0 ) THEN ! non-zero i-direction bbl advection 274 258 ! down-slope i/k-indices (deep) & up-slope i/k indices (shelf) … … 278 262 ! 279 263 ! ! up -slope T-point (shelf bottom point) 280 zbtr = r1_e1 2t(iis,jj) / fse3t(iis,jj,ikus)264 zbtr = r1_e1e2t(iis,jj) / e3t_n(iis,jj,ikus) 281 265 ztra = zu_bbl * ( ptb(iid,jj,ikus,jn) - ptb(iis,jj,ikus,jn) ) * zbtr 282 266 pta(iis,jj,ikus,jn) = pta(iis,jj,ikus,jn) + ztra 283 267 ! 284 268 DO jk = ikus, ikud-1 ! down-slope upper to down T-point (deep column) 285 zbtr = r1_e1 2t(iid,jj) / fse3t(iid,jj,jk)269 zbtr = r1_e1e2t(iid,jj) / e3t_n(iid,jj,jk) 286 270 ztra = zu_bbl * ( ptb(iid,jj,jk+1,jn) - ptb(iid,jj,jk,jn) ) * zbtr 287 271 pta(iid,jj,jk,jn) = pta(iid,jj,jk,jn) + ztra 288 272 END DO 289 273 ! 290 zbtr = r1_e1 2t(iid,jj) / fse3t(iid,jj,ikud)274 zbtr = r1_e1e2t(iid,jj) / e3t_n(iid,jj,ikud) 291 275 ztra = zu_bbl * ( ptb(iis,jj,ikus,jn) - ptb(iid,jj,ikud,jn) ) * zbtr 292 276 pta(iid,jj,ikud,jn) = pta(iid,jj,ikud,jn) + ztra … … 300 284 ! 301 285 ! up -slope T-point (shelf bottom point) 302 zbtr = r1_e1 2t(ji,ijs) / fse3t(ji,ijs,ikvs)286 zbtr = r1_e1e2t(ji,ijs) / e3t_n(ji,ijs,ikvs) 303 287 ztra = zv_bbl * ( ptb(ji,ijd,ikvs,jn) - ptb(ji,ijs,ikvs,jn) ) * zbtr 304 288 pta(ji,ijs,ikvs,jn) = pta(ji,ijs,ikvs,jn) + ztra 305 289 ! 306 290 DO jk = ikvs, ikvd-1 ! down-slope upper to down T-point (deep column) 307 zbtr = r1_e1 2t(ji,ijd) / fse3t(ji,ijd,jk)291 zbtr = r1_e1e2t(ji,ijd) / e3t_n(ji,ijd,jk) 308 292 ztra = zv_bbl * ( ptb(ji,ijd,jk+1,jn) - ptb(ji,ijd,jk,jn) ) * zbtr 309 293 pta(ji,ijd,jk,jn) = pta(ji,ijd,jk,jn) + ztra 310 294 END DO 311 295 ! ! down-slope T-point (deep bottom point) 312 zbtr = r1_e1 2t(ji,ijd) / fse3t(ji,ijd,ikvd)296 zbtr = r1_e1e2t(ji,ijd) / e3t_n(ji,ijd,ikvd) 313 297 ztra = zv_bbl * ( ptb(ji,ijs,ikvs,jn) - ptb(ji,ijd,ikvd,jn) ) * zbtr 314 298 pta(ji,ijd,ikvd,jn) = pta(ji,ijd,ikvd,jn) + ztra … … 317 301 ! 318 302 END DO 319 ! ! =========== 320 END DO ! end tracer 321 ! ! =========== 322 ! 303 ! ! =========== 304 END DO ! end tracer 305 ! ! =========== 323 306 IF( nn_timing == 1 ) CALL timing_stop( 'tra_bbl_adv') 324 307 ! … … 333 316 !! advection terms. 334 317 !! 335 !! ** Method : 336 !! * diffusive bbl (nn_bbl_ldf=1) : 318 !! ** Method : * diffusive bbl (nn_bbl_ldf=1) : 337 319 !! When the product grad( rho) * grad(h) < 0 (where grad is an 338 320 !! along bottom slope gradient) an additional lateral 2nd order … … 342 324 !! a downslope velocity of 20 cm/s if the condition for slope 343 325 !! convection is satified) 344 !! * advective bbl (nn_bbl_adv=1 or 2) :326 !! * advective bbl (nn_bbl_adv=1 or 2) : 345 327 !! nn_bbl_adv = 1 use of the ocean velocity as bbl velocity 346 328 !! nn_bbl_adv = 2 follow Campin and Goosse (1999) implentation … … 353 335 !! Campin, J.-M., and H. Goosse, 1999, Tellus, 412-430. 354 336 !!---------------------------------------------------------------------- 355 !356 337 INTEGER , INTENT(in ) :: kt ! ocean time-step index 357 INTEGER , INTENT(in ) :: kit000 338 INTEGER , INTENT(in ) :: kit000 ! first time step index 358 339 CHARACTER(len=3), INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 359 ! !340 ! 360 341 INTEGER :: ji, jj ! dummy loop indices 361 342 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 343 INTEGER :: iis, iid, ikus, ikud ! - - 344 INTEGER :: ijs, ijd, ikvs, ikvd ! - - 345 REAL(wp) :: za, zb, zgdrho ! local scalars 346 REAL(wp) :: zsign, zsigna, zgbbl ! - - 347 REAL(wp), DIMENSION(jpi,jpj,jpts) :: zts, zab ! 3D workspace 348 REAL(wp), DIMENSION(jpi,jpj) :: zub, zvb, zdep ! 2D workspace 349 !!---------------------------------------------------------------------- 401 350 ! 402 351 IF( nn_timing == 1 ) CALL timing_start( 'bbl') 403 352 ! 404 CALL wrk_alloc( jpi, jpj, zub, zvb, ztb, zsb, zdep )405 !406 407 353 IF( kt == kit000 ) THEN 408 354 IF(lwp) WRITE(numout,*) … … 410 356 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 411 357 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 358 ! !* bottom variables (T, S, alpha, beta, depth, velocity) 418 359 DO jj = 1, jpj 419 360 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 361 ik = mbkt(ji,jj) ! bottom T-level index 362 zts (ji,jj,jp_tem) = tsb(ji,jj,ik,jp_tem) ! bottom before T and S 363 zts (ji,jj,jp_sal) = tsb(ji,jj,ik,jp_sal) 425 364 ! 426 zub(ji,jj) = un(ji,jj,mbku(ji,jj)) ! bottom velocity 427 zvb(ji,jj) = vn(ji,jj,mbkv(ji,jj)) 365 zdep(ji,jj) = gdept_n(ji,jj,ik) ! bottom T-level reference depth 366 zub (ji,jj) = un(ji,jj,mbku(ji,jj)) ! bottom velocity 367 zvb (ji,jj) = vn(ji,jj,mbkv(ji,jj)) 428 368 END DO 429 369 END DO 430 370 ! 371 CALL eos_rab( zts, zdep, zab ) 372 ! 431 373 ! !-------------------! 432 374 IF( nn_bbl_ldf == 1 ) THEN ! diffusive bbl ! 433 375 ! !-------------------! 434 376 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) 377 DO ji = 1, fs_jpim1 ! vector opt. 378 ! ! i-direction 379 za = zab(ji+1,jj,jp_tem) + zab(ji,jj,jp_tem) ! 2*(alpha,beta) at u-point 380 zb = zab(ji+1,jj,jp_sal) + zab(ji,jj,jp_sal) 381 ! ! 2*masked bottom density gradient 382 zgdrho = ( za * ( zts(ji+1,jj,jp_tem) - zts(ji,jj,jp_tem) ) & 383 & - zb * ( zts(ji+1,jj,jp_sal) - zts(ji,jj,jp_sal) ) ) * umask(ji,jj,1) 443 384 ! 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) 385 zsign = SIGN( 0.5, -zgdrho * REAL( mgrhu(ji,jj) ) ) ! sign of ( i-gradient * i-slope ) 386 ahu_bbl(ji,jj) = ( 0.5 - zsign ) * ahu_bbl_0(ji,jj) ! masked diffusive flux coeff. 446 387 ! 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) 388 ! ! j-direction 389 za = zab(ji,jj+1,jp_tem) + zab(ji,jj,jp_tem) ! 2*(alpha,beta) at v-point 390 zb = zab(ji,jj+1,jp_sal) + zab(ji,jj,jp_sal) 391 ! ! 2*masked bottom density gradient 392 zgdrho = ( za * ( zts(ji,jj+1,jp_tem) - zts(ji,jj,jp_tem) ) & 393 & - zb * ( zts(ji,jj+1,jp_sal) - zts(ji,jj,jp_sal) ) ) * vmask(ji,jj,1) 454 394 ! 455 zsign 395 zsign = SIGN( 0.5, -zgdrho * REAL( mgrhv(ji,jj) ) ) ! sign of ( j-gradient * j-slope ) 456 396 ahv_bbl(ji,jj) = ( 0.5 - zsign ) * ahv_bbl_0(ji,jj) 457 !458 397 END DO 459 398 END DO 460 399 ! 461 400 ENDIF 462 401 ! 463 402 ! !-------------------! 464 403 IF( nn_bbl_adv /= 0 ) THEN ! advective bbl ! … … 469 408 DO jj = 1, jpjm1 ! criteria: grad(rho).grad(h)<0 and grad(rho).grad(h)<0 470 409 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 410 ! ! i-direction 411 za = zab(ji+1,jj,jp_tem) + zab(ji,jj,jp_tem) ! 2*(alpha,beta) at u-point 412 zb = zab(ji+1,jj,jp_sal) + zab(ji,jj,jp_sal) 413 ! ! 2*masked bottom density gradient 414 zgdrho = ( za * ( zts(ji+1,jj,jp_tem) - zts(ji,jj,jp_tem) ) & 415 - zb * ( zts(ji+1,jj,jp_sal) - zts(ji,jj,jp_sal) ) ) * umask(ji,jj,1) 416 ! 417 zsign = SIGN( 0.5, - zgdrho * REAL( mgrhu(ji,jj) ) ) ! sign of i-gradient * i-slope 418 zsigna= SIGN( 0.5, zub(ji,jj) * REAL( mgrhu(ji,jj) ) ) ! sign of u * i-slope 419 ! 420 ! ! bbl velocity 483 421 utr_bbl(ji,jj) = ( 0.5 + zsigna ) * ( 0.5 - zsign ) * e2u(ji,jj) * e3u_bbl_0(ji,jj) * zub(ji,jj) 484 422 ! 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 423 ! ! j-direction 424 za = zab(ji,jj+1,jp_tem) + zab(ji,jj,jp_tem) ! 2*(alpha,beta) at v-point 425 zb = zab(ji,jj+1,jp_sal) + zab(ji,jj,jp_sal) 426 ! ! 2*masked bottom density gradient 427 zgdrho = ( za * ( zts(ji,jj+1,jp_tem) - zts(ji,jj,jp_tem) ) & 428 & - zb * ( zts(ji,jj+1,jp_sal) - zts(ji,jj,jp_sal) ) ) * vmask(ji,jj,1) 429 zsign = SIGN( 0.5, - zgdrho * REAL( mgrhv(ji,jj) ) ) ! sign of j-gradient * j-slope 430 zsigna= SIGN( 0.5, zvb(ji,jj) * REAL( mgrhv(ji,jj) ) ) ! sign of u * i-slope 431 ! 432 ! ! bbl transport 496 433 vtr_bbl(ji,jj) = ( 0.5 + zsigna ) * ( 0.5 - zsign ) * e1v(ji,jj) * e3v_bbl_0(ji,jj) * zvb(ji,jj) 497 434 END DO … … 502 439 DO jj = 1, jpjm1 ! criteria: rho_up > rho_down 503 440 DO ji = 1, fs_jpim1 ! vector opt. 504 ! ! i-direction441 ! ! i-direction 505 442 ! 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) 443 iid = ji + MAX( 0, mgrhu(ji,jj) ) 444 iis = ji + 1 - MAX( 0, mgrhu(ji,jj) ) 445 ! 446 ikud = mbku_d(ji,jj) 447 ikus = mbku(ji,jj) 448 ! 449 za = zab(ji+1,jj,jp_tem) + zab(ji,jj,jp_tem) ! 2*(alpha,beta) at u-point 450 zb = zab(ji+1,jj,jp_sal) + zab(ji,jj,jp_sal) 451 ! ! masked bottom density gradient 452 zgdrho = 0.5 * ( za * ( zts(iid,jj,jp_tem) - zts(iis,jj,jp_tem) ) & 453 & - zb * ( zts(iid,jj,jp_sal) - zts(iis,jj,jp_sal) ) ) * umask(ji,jj,1) 454 zgdrho = MAX( 0.e0, zgdrho ) ! only if shelf is denser than deep 455 ! 456 ! ! bbl transport (down-slope direction) 519 457 utr_bbl(ji,jj) = e2u(ji,jj) * e3u_bbl_0(ji,jj) * zgbbl * zgdrho * REAL( mgrhu(ji,jj) ) 520 458 ! 521 ! ! j-direction459 ! ! j-direction 522 460 ! 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) 461 ijd = jj + MAX( 0, mgrhv(ji,jj) ) 462 ijs = jj + 1 - MAX( 0, mgrhv(ji,jj) ) 463 ! 464 ikvd = mbkv_d(ji,jj) 465 ikvs = mbkv(ji,jj) 466 ! 467 za = zab(ji,jj+1,jp_tem) + zab(ji,jj,jp_tem) ! 2*(alpha,beta) at v-point 468 zb = zab(ji,jj+1,jp_sal) + zab(ji,jj,jp_sal) 469 ! ! masked bottom density gradient 470 zgdrho = 0.5 * ( za * ( zts(ji,ijd,jp_tem) - zts(ji,ijs,jp_tem) ) & 471 & - zb * ( zts(ji,ijd,jp_sal) - zts(ji,ijs,jp_sal) ) ) * vmask(ji,jj,1) 472 zgdrho = MAX( 0.e0, zgdrho ) ! only if shelf is denser than deep 473 ! 474 ! ! bbl transport (down-slope direction) 536 475 vtr_bbl(ji,jj) = e1v(ji,jj) * e3v_bbl_0(ji,jj) * zgbbl * zgdrho * REAL( mgrhv(ji,jj) ) 537 476 END DO … … 541 480 ENDIF 542 481 ! 543 CALL wrk_dealloc( jpi, jpj, zub, zvb, ztb, zsb, zdep )544 !545 482 IF( nn_timing == 1 ) CALL timing_stop( 'bbl') 546 483 ! … … 558 495 !!---------------------------------------------------------------------- 559 496 INTEGER :: ji, jj ! dummy loop indices 560 INTEGER :: ii0, ii1, ij0, ij1 ! temporaryinteger561 INTEGER :: ios ! Local integer output status for namelist read497 INTEGER :: ii0, ii1, ij0, ij1 ! local integer 498 INTEGER :: ios ! - - 562 499 REAL(wp), POINTER, DIMENSION(:,:) :: zmbk 563 ! !500 ! 564 501 NAMELIST/nambbl/ nn_bbl_ldf, nn_bbl_adv, rn_ahtbbl, rn_gambbl 565 502 !!---------------------------------------------------------------------- … … 567 504 IF( nn_timing == 1 ) CALL timing_start( 'tra_bbl_init') 568 505 ! 569 CALL wrk_alloc( jpi, jpj, zmbk )570 !571 572 506 REWIND( numnam_ref ) ! Namelist nambbl in reference namelist : Bottom boundary layer scheme 573 507 READ ( numnam_ref, nambbl, IOSTAT = ios, ERR = 901) 574 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambbl in reference namelist', lwp )575 508 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambbl in reference namelist', lwp ) 509 ! 576 510 REWIND( numnam_cfg ) ! Namelist nambbl in configuration namelist : Bottom boundary layer scheme 577 511 READ ( numnam_cfg, nambbl, IOSTAT = ios, ERR = 902 ) 578 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambbl in configuration namelist', lwp )512 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambbl in configuration namelist', lwp ) 579 513 IF(lwm) WRITE ( numond, nambbl ) 580 514 ! … … 598 532 IF( nn_bbl_adv == 2 ) WRITE(numout,*) ' * Advective BBL using velocity = F( delta rho)' 599 533 600 IF( nn_eos /= 0 ) CALL ctl_stop ( ' bbl parameterisation requires eos = 0. We stop.' )601 602 534 ! !* vertical index of "deep" bottom u- and v-points 603 535 DO jj = 1, jpjm1 ! (the "shelf" bottom k-indices are mbku and mbkv) … … 607 539 END DO 608 540 END DO 609 ! convert into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk 541 ! converte into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk 542 CALL wrk_alloc( jpi, jpj, zmbk ) 610 543 zmbk(:,:) = REAL( mbku_d(:,:), wp ) ; CALL lbc_lnk(zmbk,'U',1.) ; mbku_d(:,:) = MAX( INT( zmbk(:,:) ), 1 ) 611 544 zmbk(:,:) = REAL( mbkv_d(:,:), wp ) ; CALL lbc_lnk(zmbk,'V',1.) ; mbkv_d(:,:) = MAX( INT( zmbk(:,:) ), 1 ) 612 613 !* sign of grad(H) at u- and v-points 614 mgrhu(jpi,:) = 0. ; mgrhu(:,jpj) = 0. ; mgrhv(jpi,:) = 0. ; mgrhv(:,jpj) = 0. 545 CALL wrk_dealloc( jpi, jpj, zmbk ) 546 547 !* sign of grad(H) at u- and v-points 548 mgrhu(jpi,:) = 0 ; mgrhu(:,jpj) = 0 ; mgrhv(jpi,:) = 0 ; mgrhv(:,jpj) = 0 615 549 DO jj = 1, jpjm1 616 550 DO ji = 1, jpim1 … … 621 555 622 556 DO jj = 1, jpjm1 !* bbl thickness at u- (v-) point 623 DO ji = 1, jpim1 ! minimum of top & bottom e3u_0 (e3v_0)557 DO ji = 1, jpim1 ! minimum of top & bottom e3u_0 (e3v_0) 624 558 e3u_bbl_0(ji,jj) = MIN( e3u_0(ji,jj,mbkt(ji+1,jj )), e3u_0(ji,jj,mbkt(ji,jj)) ) 625 559 e3v_bbl_0(ji,jj) = MIN( e3v_0(ji,jj,mbkt(ji ,jj+1)), e3v_0(ji,jj,mbkt(ji,jj)) ) … … 629 563 630 564 ! !* masked diffusive flux coefficients 631 ahu_bbl_0(:,:) = rn_ahtbbl * e2 u(:,:) * e3u_bbl_0(:,:) / e1u(:,:)* umask(:,:,1)632 ahv_bbl_0(:,:) = rn_ahtbbl * e1 v(:,:) * e3v_bbl_0(:,:) / e2v(:,:)* vmask(:,:,1)565 ahu_bbl_0(:,:) = rn_ahtbbl * e2_e1u(:,:) * e3u_bbl_0(:,:) * umask(:,:,1) 566 ahv_bbl_0(:,:) = rn_ahtbbl * e1_e2v(:,:) * e3v_bbl_0(:,:) * vmask(:,:,1) 633 567 634 568 … … 656 590 ENDIF 657 591 ! 658 CALL wrk_dealloc( jpi, jpj, zmbk )659 !660 592 IF( nn_timing == 1 ) CALL timing_stop( 'tra_bbl_init') 661 593 !
Note: See TracChangeset
for help on using the changeset viewer.
