- Timestamp:
- 2011-02-27T13:45:53+01:00 (13 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/TRA/trabbl.F90
r2590 r2623 17 17 !! 'key_trabbl' or bottom boundary layer 18 18 !!---------------------------------------------------------------------- 19 !! tra_bbl_alloc : allocate trabbl arrays 19 20 !! tra_bbl : update the tracer trends due to the bottom boundary layer (advective and/or diffusive) 20 21 !! tra_bbl_dif : generic routine to compute bbl diffusive trend … … 42 43 PUBLIC tra_bbl_adv ! - - - - 43 44 PUBLIC bbl ! routine called by trcbbl.F90 and dtadyn.F90 44 PUBLIC tra_bbl_alloc ! routine called by nemogcm.F9045 45 46 46 LOGICAL, PUBLIC, PARAMETER :: lk_trabbl = .TRUE. !: bottom boundary layer flag … … 54 54 REAL(wp), PUBLIC :: rn_gambbl = 10.0_wp !: lateral coeff. for bottom boundary layer scheme [s] 55 55 56 LOGICAL , PUBLIC :: l_bbl !: flag to compute bbl diffu. flux coef and transport 57 56 58 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: utr_bbl , vtr_bbl ! u- (v-) transport in the bottom boundary layer 57 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: ahu_bbl , ahv_bbl ! masked diffusive bbl coeff icients at u and v-points59 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: ahu_bbl , ahv_bbl ! masked diffusive bbl coeff. at u & v-pts 58 60 59 61 INTEGER , ALLOCATABLE, SAVE, DIMENSION(:,:) :: mbku_d , mbkv_d ! vertical index of the "lower" bottom ocean U/V-level … … 61 63 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ahu_bbl_0, ahv_bbl_0 ! diffusive bbl flux coefficients at u and v-points 62 64 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: e3u_bbl_0, e3v_bbl_0 ! thichness of the bbl (e3) at u and v-points 63 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: e1e2t_r ! thichness of the bbl (e3) at u and v-points 64 LOGICAL, PUBLIC :: l_bbl !: flag to compute bbl diffu. flux coef and transport 65 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: r1_e1e2t ! inverse of the cell surface at t-point [1/m2] 65 66 66 67 !! * Substitutions … … 74 75 CONTAINS 75 76 76 FUNCTION tra_bbl_alloc() 77 IMPLICIT none 78 INTEGER :: tra_bbl_alloc 79 80 ALLOCATE(utr_bbl(jpi,jpj), vtr_bbl(jpi,jpj), & 81 ahu_bbl(jpi,jpj), ahv_bbl(jpi,jpj), & 82 mbku_d(jpi,jpj), mbkv_d(jpi,jpj), & 83 mgrhu(jpi,jpj), mgrhv(jpi,jpj), & 84 ahu_bbl_0(jpi,jpj), ahv_bbl_0(jpi,jpj), & 85 e3u_bbl_0(jpi,jpj), e3v_bbl_0(jpi,jpj), & 86 e1e2t_r(jpi,jpj), & 87 Stat=tra_bbl_alloc) 88 89 IF(tra_bbl_alloc > 0)THEN 90 CALL ctl_warn('tra_bbl_alloc: allocation of arrays failed.') 91 END IF 92 77 INTEGER FUNCTION tra_bbl_alloc() 78 !!---------------------------------------------------------------------- 79 !! *** FUNCTION tra_bbl_alloc *** 80 !!---------------------------------------------------------------------- 81 ALLOCATE( utr_bbl (jpi,jpj) , ahu_bbl (jpi,jpj) , mbku_d (jpi,jpj) , mgrhu(jpi,jpj) , & 82 & vtr_bbl (jpi,jpj) , ahv_bbl (jpi,jpj) , mbkv_d (jpi,jpj) , mgrhv(jpi,jpj) , & 83 & ahu_bbl_0(jpi,jpj) , ahv_bbl_0(jpi,jpj) , & 84 & e3u_bbl_0(jpi,jpj) , e3v_bbl_0(jpi,jpj) , r1_e1e2t(jpi,jpj) , STAT=tra_bbl_alloc) 85 ! 86 IF( lk_mpp ) CALL mpp_sum ( tra_bbl_alloc ) 87 IF( tra_bbl_alloc > 0 ) CALL ctl_warn('tra_bbl_alloc: allocation of arrays failed.') 93 88 END FUNCTION tra_bbl_alloc 89 94 90 95 91 SUBROUTINE tra_bbl( kt ) … … 173 169 !! Campin, J.-M., and H. Goosse, 1999, Tellus, 412-430. 174 170 !!---------------------------------------------------------------------- 175 USE wrk_nemo, ONLY: wrk_use, wrk_release176 USE wrk_nemo, ONLY: zptb => wrk_2d_1177 ! !171 USE wrk_nemo, ONLY: wrk_use, wrk_release 172 USE wrk_nemo, ONLY: zptb => wrk_2d_1 173 ! 178 174 INTEGER , INTENT(in ) :: kjpt ! number of tracers 179 175 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb ! before and now tracer fields 180 176 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend 181 ! !177 ! 182 178 INTEGER :: ji, jj, jn ! dummy loop indices 183 179 INTEGER :: ik ! local integers … … 185 181 !!---------------------------------------------------------------------- 186 182 ! 187 IF(.not. wrk_use(2,1))THEN 188 CALL ctl_stop('tra_bbl_dif: ERROR: requested workspace array unavailable') 189 RETURN 190 END IF 183 IF(.not. wrk_use(2,1) ) THEN 184 CALL ctl_stop('tra_bbl_dif: ERROR: requested workspace array unavailable') ; RETURN 185 ENDIF 191 186 ! 192 187 DO jn = 1, kjpt ! tracer loop … … 212 207 # endif 213 208 ik = mbkt(ji,jj) ! bottom T-level index 214 zbtr = e1e2t_r(ji,jj) / fse3t(ji,jj,ik)209 zbtr = r1_e1e2t(ji,jj) / fse3t(ji,jj,ik) 215 210 pta(ji,jj,ik,jn) = pta(ji,jj,ik,jn) & 216 211 & + ( ahu_bbl(ji ,jj ) * ( zptb(ji+1,jj ) - zptb(ji ,jj ) ) & … … 223 218 END DO ! end tracer 224 219 ! ! =========== 225 IF(.not. wrk_release(2,1))THEN 226 CALL ctl_stop('tra_bbl_dif: ERROR: failed to release workspace array') 227 END IF 220 IF(.not. wrk_release(2,1) ) CALL ctl_stop('tra_bbl_dif: failed to release workspace array') 228 221 ! 229 222 END SUBROUTINE tra_bbl_dif … … 273 266 ! 274 267 ! ! up -slope T-point (shelf bottom point) 275 zbtr = e1e2t_r(iis,jj) / fse3t(iis,jj,ikus)268 zbtr = r1_e1e2t(iis,jj) / fse3t(iis,jj,ikus) 276 269 ztra = zu_bbl * ( ptb(iid,jj,ikus,jn) - ptb(iis,jj,ikus,jn) ) * zbtr 277 270 pta(iis,jj,ikus,jn) = pta(iis,jj,ikus,jn) + ztra 278 271 ! 279 272 DO jk = ikus, ikud-1 ! down-slope upper to down T-point (deep column) 280 zbtr = e1e2t_r(iid,jj) / fse3t(iid,jj,jk)273 zbtr = r1_e1e2t(iid,jj) / fse3t(iid,jj,jk) 281 274 ztra = zu_bbl * ( ptb(iid,jj,jk+1,jn) - ptb(iid,jj,jk,jn) ) * zbtr 282 275 pta(iid,jj,jk,jn) = pta(iid,jj,jk,jn) + ztra 283 276 END DO 284 277 ! 285 zbtr = e1e2t_r(iid,jj) / fse3t(iid,jj,ikud)278 zbtr = r1_e1e2t(iid,jj) / fse3t(iid,jj,ikud) 286 279 ztra = zu_bbl * ( ptb(iis,jj,ikus,jn) - ptb(iid,jj,ikud,jn) ) * zbtr 287 280 pta(iid,jj,ikud,jn) = pta(iid,jj,ikud,jn) + ztra … … 295 288 ! 296 289 ! up -slope T-point (shelf bottom point) 297 zbtr = e1e2t_r(ji,ijs) / fse3t(ji,ijs,ikvs)290 zbtr = r1_e1e2t(ji,ijs) / fse3t(ji,ijs,ikvs) 298 291 ztra = zv_bbl * ( ptb(ji,ijd,ikvs,jn) - ptb(ji,ijs,ikvs,jn) ) * zbtr 299 292 pta(ji,ijs,ikvs,jn) = pta(ji,ijs,ikvs,jn) + ztra 300 293 ! 301 294 DO jk = ikvs, ikvd-1 ! down-slope upper to down T-point (deep column) 302 zbtr = e1e2t_r(ji,ijd) / fse3t(ji,ijd,jk)295 zbtr = r1_e1e2t(ji,ijd) / fse3t(ji,ijd,jk) 303 296 ztra = zv_bbl * ( ptb(ji,ijd,jk+1,jn) - ptb(ji,ijd,jk,jn) ) * zbtr 304 297 pta(ji,ijd,jk,jn) = pta(ji,ijd,jk,jn) + ztra 305 298 END DO 306 299 ! ! down-slope T-point (deep bottom point) 307 zbtr = e1e2t_r(ji,ijd) / fse3t(ji,ijd,ikvd)300 zbtr = r1_e1e2t(ji,ijd) / fse3t(ji,ijd,ikvd) 308 301 ztra = zv_bbl * ( ptb(ji,ijs,ikvs,jn) - ptb(ji,ijd,ikvd,jn) ) * zbtr 309 302 pta(ji,ijd,ikvd,jn) = pta(ji,ijd,ikvd,jn) + ztra … … 345 338 !! Campin, J.-M., and H. Goosse, 1999, Tellus, 412-430. 346 339 !!---------------------------------------------------------------------- 347 USE wrk_nemo, ONLY: wrk_use, wrk_release 348 USE wrk_nemo, ONLY: zub => wrk_2d_1, zvb => wrk_2d_2, ztb => wrk_2d_3, & 349 zsb => wrk_2d_4, zdep => wrk_2d_5 340 USE wrk_nemo, ONLY: wrk_use, wrk_release 341 USE wrk_nemo, ONLY: zub => wrk_2d_1 , ztb => wrk_2d_2 ! 2D workspace 342 USE wrk_nemo, ONLY: zvb => wrk_2d_3 , zsb => wrk_2d_4 , zdep => wrk_2d_5 343 ! 350 344 INTEGER , INTENT(in ) :: kt ! ocean time-step index 351 345 CHARACTER(len=3), INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) … … 391 385 !!---------------------------------------------------------------------- 392 386 393 IF(.not. wrk_use(2, 1,2,3,4,5))THEN 394 CALL ctl_stop('bbl: ERROR: requested workspace arrays unavailable') 395 RETURN 396 END IF 387 IF(.not. wrk_use(2, 1,2,3,4,5) ) THEN 388 CALL ctl_stop('bbl: requested workspace arrays unavailable') ; RETURN 389 ENDIF 397 390 398 391 IF( kt == nit000 ) THEN … … 532 525 ENDIF 533 526 ! 534 IF(.not. wrk_release(2, 1,2,3,4,5))THEN 535 CALL ctl_stop('bbl: ERROR: failed to release workspace arrays') 536 END IF 527 IF(.not. wrk_release(2, 1,2,3,4,5) ) CALL ctl_stop('bbl: failed to release workspace arrays') 537 528 ! 538 529 END SUBROUTINE bbl … … 546 537 !! 547 538 !! ** Method : Read the nambbl namelist and check the parameters 548 !! called by tra_bblat the first timestep (nit000)549 !!---------------------------------------------------------------------- 550 USE wrk_nemo, ONLY: wrk_use, wrk_release551 USE wrk_nemo, ONLY: zmbk => wrk_2d_1539 !! called by nemo_init at the first timestep (nit000) 540 !!---------------------------------------------------------------------- 541 USE wrk_nemo, ONLY: wrk_use, wrk_release 542 USE wrk_nemo, ONLY: zmbk => wrk_2d_1 ! 2D workspace 552 543 INTEGER :: ji, jj ! dummy loop indices 553 544 INTEGER :: ii0, ii1, ij0, ij1 ! temporary integer … … 556 547 !!---------------------------------------------------------------------- 557 548 558 IF(.not. wrk_use(2,1))THEN 559 CALL ctl_stop('tra_bbl_init: ERROR: requested workspace array unavailable') 560 RETURN 561 END IF 549 IF(.not. wrk_use(2,1) ) THEN 550 CALL ctl_stop('tra_bbl_init: requested workspace array unavailable') ; RETURN 551 ENDIF 562 552 563 553 REWIND ( numnam ) !* Read Namelist nambbl : bottom boundary layer scheme … … 576 566 WRITE(numout,*) ' advective bbl coefficient rn_gambbl = ', rn_gambbl, ' s' 577 567 ENDIF 578 568 569 ! ! allocate trabbl arrays 570 IF( tra_bbl_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'tra_bbl_init : unable to allocate arrays' ) 571 579 572 IF( nn_bbl_adv == 1 ) WRITE(numout,*) ' * Advective BBL using upper velocity' 580 573 IF( nn_bbl_adv == 2 ) WRITE(numout,*) ' * Advective BBL using velocity = F( delta rho)' … … 584 577 585 578 ! !* inverse of surface of T-cells 586 e1e2t_r(:,:) = 1.0/ ( e1t(:,:) * e2t(:,:) )579 r1_e1e2t(:,:) = 1._wp / ( e1t(:,:) * e2t(:,:) ) 587 580 588 581 ! !* vertical index of "deep" bottom u- and v-points
Note: See TracChangeset
for help on using the changeset viewer.
