Changeset 13982 for NEMO/trunk/src/OCE/TRA/trabbl.F90
- Timestamp:
- 2020-12-02T11:57:05+01:00 (3 years ago)
- File:
-
- 1 edited
-
NEMO/trunk/src/OCE/TRA/trabbl.F90 (modified) (7 diffs)
Legend:
- Unmodified
- Added
- Removed
-
NEMO/trunk/src/OCE/TRA/trabbl.F90
r13532 r13982 106 106 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation 107 107 ! 108 INTEGER :: ji, jj, jk ! Dummy loop indices 108 109 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds 109 110 !!---------------------------------------------------------------------- … … 112 113 ! 113 114 IF( l_trdtra ) THEN !* Save the T-S input trends 114 ALLOCATE( ztrdt(jpi,jpj,jpk) 115 ALLOCATE( ztrdt(jpi,jpj,jpk), ztrds(jpi,jpj,jpk) ) 115 116 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) 116 117 ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) … … 125 126 CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' bbl_ldf - Ta: ', mask1=tmask, & 126 127 & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 127 ! lateral boundary conditions ; just need for outputs128 CALL lbc_lnk_multi( 'trabbl', ahu_bbl, 'U', 1.0_wp , ahv_bbl, 'V', 1.0_wp )129 CALL iom_put( "ahu_bbl", ahu_bbl ) ! bbl diffusive flux i-coef130 CALL iom_put( "ahv_bbl", ahv_bbl ) ! bbl diffusive flux j-coef128 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only on the last tile 129 CALL iom_put( "ahu_bbl", ahu_bbl ) ! bbl diffusive flux i-coef 130 CALL iom_put( "ahv_bbl", ahv_bbl ) ! bbl diffusive flux j-coef 131 ENDIF 131 132 ! 132 133 ENDIF … … 136 137 CALL tra_bbl_adv( pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts, Kmm ) 137 138 IF(sn_cfctl%l_prtctl) & 138 CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' bbl_adv - Ta: ', mask1=tmask, 139 CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' bbl_adv - Ta: ', mask1=tmask, & 139 140 & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 140 ! lateral boundary conditions ; just need for outputs 141 CALL lbc_lnk_multi( 'trabbl', utr_bbl, 'U', 1.0_wp , vtr_bbl, 'V', 1.0_wp ) 142 CALL iom_put( "uoce_bbl", utr_bbl ) ! bbl i-transport 143 CALL iom_put( "voce_bbl", vtr_bbl ) ! bbl j-transport 141 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only on the last tile 142 ! lateral boundary conditions ; just need for outputs 143 ! NOTE: [tiling-comms-merge] The diagnostic results change along the north fold if this is removed 144 CALL lbc_lnk_multi( 'trabbl', utr_bbl, 'U', 1.0_wp , vtr_bbl, 'V', 1.0_wp ) 145 CALL iom_put( "uoce_bbl", utr_bbl ) ! bbl i-transport 146 CALL iom_put( "voce_bbl", vtr_bbl ) ! bbl j-transport 147 ENDIF 144 148 ! 145 149 ENDIF … … 187 191 INTEGER :: ik ! local integers 188 192 REAL(wp) :: zbtr ! local scalars 189 REAL(wp), DIMENSION( jpi,jpj) :: zptb ! workspace193 REAL(wp), DIMENSION(A2D(nn_hls)) :: zptb ! workspace 190 194 !!---------------------------------------------------------------------- 191 195 ! … … 235 239 INTEGER :: iis , iid , ijs , ijd ! local integers 236 240 INTEGER :: ikus, ikud, ikvs, ikvd ! - - 241 INTEGER :: isi, isj ! - - 237 242 REAL(wp) :: zbtr, ztra ! local scalars 238 243 REAL(wp) :: zu_bbl, zv_bbl ! - - 239 244 !!---------------------------------------------------------------------- 240 245 ! 246 IF( ntsi == Nis0 ) THEN ; isi = 1 ; ELSE ; isi = 0 ; ENDIF ! Avoid double-counting when using tiling 247 IF( ntsj == Njs0 ) THEN ; isj = 1 ; ELSE ; isj = 0 ; ENDIF 241 248 ! ! =========== 242 249 DO jn = 1, kjpt ! tracer loop 243 250 ! ! =========== 244 DO jj = 1, jpjm1 245 DO ji = 1, jpim1 ! CAUTION start from i=1 to update i=2 when cyclic east-west 246 IF( utr_bbl(ji,jj) /= 0.e0 ) THEN ! non-zero i-direction bbl advection 247 ! down-slope i/k-indices (deep) & up-slope i/k indices (shelf) 248 iid = ji + MAX( 0, mgrhu(ji,jj) ) ; iis = ji + 1 - MAX( 0, mgrhu(ji,jj) ) 249 ikud = mbku_d(ji,jj) ; ikus = mbku(ji,jj) 250 zu_bbl = ABS( utr_bbl(ji,jj) ) 251 ! 252 ! ! up -slope T-point (shelf bottom point) 253 zbtr = r1_e1e2t(iis,jj) / e3t(iis,jj,ikus,Kmm) 254 ztra = zu_bbl * ( pt(iid,jj,ikus,jn) - pt(iis,jj,ikus,jn) ) * zbtr 255 pt_rhs(iis,jj,ikus,jn) = pt_rhs(iis,jj,ikus,jn) + ztra 256 ! 257 DO jk = ikus, ikud-1 ! down-slope upper to down T-point (deep column) 258 zbtr = r1_e1e2t(iid,jj) / e3t(iid,jj,jk,Kmm) 259 ztra = zu_bbl * ( pt(iid,jj,jk+1,jn) - pt(iid,jj,jk,jn) ) * zbtr 260 pt_rhs(iid,jj,jk,jn) = pt_rhs(iid,jj,jk,jn) + ztra 261 END DO 262 ! 263 zbtr = r1_e1e2t(iid,jj) / e3t(iid,jj,ikud,Kmm) 264 ztra = zu_bbl * ( pt(iis,jj,ikus,jn) - pt(iid,jj,ikud,jn) ) * zbtr 265 pt_rhs(iid,jj,ikud,jn) = pt_rhs(iid,jj,ikud,jn) + ztra 266 ENDIF 267 ! 268 IF( vtr_bbl(ji,jj) /= 0.e0 ) THEN ! non-zero j-direction bbl advection 269 ! down-slope j/k-indices (deep) & up-slope j/k indices (shelf) 270 ijd = jj + MAX( 0, mgrhv(ji,jj) ) ; ijs = jj + 1 - MAX( 0, mgrhv(ji,jj) ) 271 ikvd = mbkv_d(ji,jj) ; ikvs = mbkv(ji,jj) 272 zv_bbl = ABS( vtr_bbl(ji,jj) ) 273 ! 274 ! up -slope T-point (shelf bottom point) 275 zbtr = r1_e1e2t(ji,ijs) / e3t(ji,ijs,ikvs,Kmm) 276 ztra = zv_bbl * ( pt(ji,ijd,ikvs,jn) - pt(ji,ijs,ikvs,jn) ) * zbtr 277 pt_rhs(ji,ijs,ikvs,jn) = pt_rhs(ji,ijs,ikvs,jn) + ztra 278 ! 279 DO jk = ikvs, ikvd-1 ! down-slope upper to down T-point (deep column) 280 zbtr = r1_e1e2t(ji,ijd) / e3t(ji,ijd,jk,Kmm) 281 ztra = zv_bbl * ( pt(ji,ijd,jk+1,jn) - pt(ji,ijd,jk,jn) ) * zbtr 282 pt_rhs(ji,ijd,jk,jn) = pt_rhs(ji,ijd,jk,jn) + ztra 283 END DO 284 ! ! down-slope T-point (deep bottom point) 285 zbtr = r1_e1e2t(ji,ijd) / e3t(ji,ijd,ikvd,Kmm) 286 ztra = zv_bbl * ( pt(ji,ijs,ikvs,jn) - pt(ji,ijd,ikvd,jn) ) * zbtr 287 pt_rhs(ji,ijd,ikvd,jn) = pt_rhs(ji,ijd,ikvd,jn) + ztra 288 ENDIF 289 END DO 251 ! NOTE: [tiling-comms-merge] Bug fix- correct order of indices 252 DO_2D( isj, 0, isi, 0 ) ! CAUTION start from i=1 to update i=2 when cyclic east-west 253 IF( utr_bbl(ji,jj) /= 0.e0 ) THEN ! non-zero i-direction bbl advection 254 ! down-slope i/k-indices (deep) & up-slope i/k indices (shelf) 255 iid = ji + MAX( 0, mgrhu(ji,jj) ) ; iis = ji + 1 - MAX( 0, mgrhu(ji,jj) ) 256 ikud = mbku_d(ji,jj) ; ikus = mbku(ji,jj) 257 zu_bbl = ABS( utr_bbl(ji,jj) ) 258 ! 259 ! ! up -slope T-point (shelf bottom point) 260 zbtr = r1_e1e2t(iis,jj) / e3t(iis,jj,ikus,Kmm) 261 ztra = zu_bbl * ( pt(iid,jj,ikus,jn) - pt(iis,jj,ikus,jn) ) * zbtr 262 pt_rhs(iis,jj,ikus,jn) = pt_rhs(iis,jj,ikus,jn) + ztra 263 ! 264 DO jk = ikus, ikud-1 ! down-slope upper to down T-point (deep column) 265 zbtr = r1_e1e2t(iid,jj) / e3t(iid,jj,jk,Kmm) 266 ztra = zu_bbl * ( pt(iid,jj,jk+1,jn) - pt(iid,jj,jk,jn) ) * zbtr 267 pt_rhs(iid,jj,jk,jn) = pt_rhs(iid,jj,jk,jn) + ztra 268 END DO 269 ! 270 zbtr = r1_e1e2t(iid,jj) / e3t(iid,jj,ikud,Kmm) 271 ztra = zu_bbl * ( pt(iis,jj,ikus,jn) - pt(iid,jj,ikud,jn) ) * zbtr 272 pt_rhs(iid,jj,ikud,jn) = pt_rhs(iid,jj,ikud,jn) + ztra 273 ENDIF 290 274 ! 291 END DO 292 ! ! =========== 293 END DO ! end tracer 294 ! ! =========== 275 IF( vtr_bbl(ji,jj) /= 0.e0 ) THEN ! non-zero j-direction bbl advection 276 ! down-slope j/k-indices (deep) & up-slope j/k indices (shelf) 277 ijd = jj + MAX( 0, mgrhv(ji,jj) ) ; ijs = jj + 1 - MAX( 0, mgrhv(ji,jj) ) 278 ikvd = mbkv_d(ji,jj) ; ikvs = mbkv(ji,jj) 279 zv_bbl = ABS( vtr_bbl(ji,jj) ) 280 ! 281 ! up -slope T-point (shelf bottom point) 282 zbtr = r1_e1e2t(ji,ijs) / e3t(ji,ijs,ikvs,Kmm) 283 ztra = zv_bbl * ( pt(ji,ijd,ikvs,jn) - pt(ji,ijs,ikvs,jn) ) * zbtr 284 pt_rhs(ji,ijs,ikvs,jn) = pt_rhs(ji,ijs,ikvs,jn) + ztra 285 ! 286 DO jk = ikvs, ikvd-1 ! down-slope upper to down T-point (deep column) 287 zbtr = r1_e1e2t(ji,ijd) / e3t(ji,ijd,jk,Kmm) 288 ztra = zv_bbl * ( pt(ji,ijd,jk+1,jn) - pt(ji,ijd,jk,jn) ) * zbtr 289 pt_rhs(ji,ijd,jk,jn) = pt_rhs(ji,ijd,jk,jn) + ztra 290 END DO 291 ! ! down-slope T-point (deep bottom point) 292 zbtr = r1_e1e2t(ji,ijd) / e3t(ji,ijd,ikvd,Kmm) 293 ztra = zv_bbl * ( pt(ji,ijs,ikvs,jn) - pt(ji,ijd,ikvd,jn) ) * zbtr 294 pt_rhs(ji,ijd,ikvd,jn) = pt_rhs(ji,ijd,ikvd,jn) + ztra 295 ENDIF 296 END_2D 297 ! ! =========== 298 END DO ! end tracer 299 ! ! =========== 295 300 END SUBROUTINE tra_bbl_adv 296 301 … … 333 338 REAL(wp) :: za, zb, zgdrho ! local scalars 334 339 REAL(wp) :: zsign, zsigna, zgbbl ! - - 335 REAL(wp), DIMENSION(jpi,jpj,jpts) :: zts, zab ! 3D workspace 336 REAL(wp), DIMENSION(jpi,jpj) :: zub, zvb, zdep ! 2D workspace 337 !!---------------------------------------------------------------------- 338 ! 339 IF( kt == kit000 ) THEN 340 IF(lwp) WRITE(numout,*) 341 IF(lwp) WRITE(numout,*) 'trabbl:bbl : Compute bbl velocities and diffusive coefficients in ', cdtype 342 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 340 REAL(wp), DIMENSION(A2D(nn_hls),jpts) :: zts, zab ! 3D workspace 341 REAL(wp), DIMENSION(A2D(nn_hls)) :: zub, zvb, zdep ! 2D workspace 342 !!---------------------------------------------------------------------- 343 ! 344 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 345 IF( kt == kit000 ) THEN 346 IF(lwp) WRITE(numout,*) 347 IF(lwp) WRITE(numout,*) 'trabbl:bbl : Compute bbl velocities and diffusive coefficients in ', cdtype 348 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 349 ENDIF 343 350 ENDIF 344 351 ! !* bottom variables (T, S, alpha, beta, depth, velocity)
Note: See TracChangeset
for help on using the changeset viewer.
