- 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/ZDF/zdfbfr.F90
r4624 r6225 41 41 REAL(wp), PUBLIC :: rn_bfrien ! local factor to enhance coefficient bfri (PUBLIC for TAM) 42 42 LOGICAL , PUBLIC :: ln_bfr2d ! logical switch for 2D enhancement (PUBLIC for TAM) 43 REAL(wp), PUBLIC :: rn_tfri1 ! top drag coefficient (linear case) (PUBLIC for TAM) 44 REAL(wp), PUBLIC :: rn_tfri2 ! top drag coefficient (non linear case) (PUBLIC for TAM) 45 REAL(wp), PUBLIC :: rn_tfri2_max ! Maximum top drag coefficient (non linear case and ln_loglayer=T) (PUBLIC for TAM) 46 REAL(wp), PUBLIC :: rn_tfeb2 ! background top turbulent kinetic energy [m2/s2] (PUBLIC for TAM) 47 REAL(wp), PUBLIC :: rn_tfrien ! local factor to enhance coefficient tfri (PUBLIC for TAM) 48 LOGICAL , PUBLIC :: ln_tfr2d ! logical switch for 2D enhancement (PUBLIC for TAM) 49 43 50 LOGICAL , PUBLIC :: ln_loglayer ! switch for log layer bfr coeff. (PUBLIC for TAM) 44 51 REAL(wp), PUBLIC :: rn_bfrz0 ! bottom roughness for loglayer bfr coeff (PUBLIC for TAM) 52 REAL(wp), PUBLIC :: rn_tfrz0 ! bottom roughness for loglayer bfr coeff (PUBLIC for TAM) 45 53 LOGICAL , PUBLIC :: ln_bfrimp ! logical switch for implicit bottom friction 46 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: bfrcoef2d ! 2D bottomdrag coefficient (PUBLIC for TAM)54 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: bfrcoef2d, tfrcoef2d ! 2D bottom/top drag coefficient (PUBLIC for TAM) 47 55 48 56 !! * Substitutions 49 57 # include "vectopt_loop_substitute.h90" 50 # include "domzgr_substitute.h90"51 58 !!---------------------------------------------------------------------- 52 59 !! NEMO/OPA 4.0 , NEMO Consortium (2011) … … 60 67 !! *** FUNCTION zdf_bfr_alloc *** 61 68 !!---------------------------------------------------------------------- 62 ALLOCATE( bfrcoef2d(jpi,jpj), STAT=zdf_bfr_alloc )69 ALLOCATE( bfrcoef2d(jpi,jpj), tfrcoef2d(jpi,jpj), STAT=zdf_bfr_alloc ) 63 70 ! 64 71 IF( lk_mpp ) CALL mpp_sum ( zdf_bfr_alloc ) … … 88 95 INTEGER :: ikbt, ikbu, ikbv ! local integers 89 96 REAL(wp) :: zvu, zuv, zecu, zecv, ztmp ! temporary scalars 90 REAL(wp), POINTER, DIMENSION(:,:) :: zbfrt 97 REAL(wp), POINTER, DIMENSION(:,:) :: zbfrt, ztfrt 91 98 !!---------------------------------------------------------------------- 92 99 ! … … 101 108 IF( nn_bfr == 2 ) THEN ! quadratic bottom friction only 102 109 ! 103 CALL wrk_alloc( jpi, jpj, zbfrt ) 104 105 IF ( ln_loglayer.AND.lk_vvl ) THEN ! "log layer" bottom friction coefficient 106 107 # if defined key_vectopt_loop 108 DO jj = 1, 1 109 !CDIR NOVERRCHK 110 DO ji = 1, jpij ! vector opt. (forced unrolling) 111 # else 112 !CDIR NOVERRCHK 110 CALL wrk_alloc( jpi, jpj, zbfrt, ztfrt ) 111 112 IF ( ln_loglayer.AND. .NOT.ln_linssh ) THEN ! "log layer" bottom friction coefficient 113 113 114 DO jj = 1, jpj 114 !CDIR NOVERRCHK115 115 DO ji = 1, jpi 116 # endif117 116 ikbt = mbkt(ji,jj) 118 ! JC: possible WAD implementation should modify line below if layers vanish119 ztmp = tmask(ji,jj,ikbt) * ( vkarmn / LOG( 0.5_wp * fse3t_n(ji,jj,ikbt) / rn_bfrz0 ))**2._wp117 !! JC: possible WAD implementation should modify line below if layers vanish 118 ztmp = tmask(ji,jj,ikbt) * ( vkarmn / LOG( 0.5_wp * e3t_n(ji,jj,ikbt) / rn_bfrz0 ))**2._wp 120 119 zbfrt(ji,jj) = MAX(bfrcoef2d(ji,jj), ztmp) 121 120 zbfrt(ji,jj) = MIN(zbfrt(ji,jj), rn_bfri2_max) 122 121 END DO 123 122 END DO 124 ! 123 ! (ISF) 124 IF ( ln_isfcav ) THEN 125 DO jj = 1, jpj 126 DO ji = 1, jpi 127 ikbt = mikt(ji,jj) 128 ! JC: possible WAD implementation should modify line below if layers vanish 129 ztmp = (1.-tmask(ji,jj,1)) * ( vkarmn / LOG( 0.5_wp * e3t_n(ji,jj,ikbt) / rn_bfrz0 ))**2._wp 130 ztfrt(ji,jj) = MAX(tfrcoef2d(ji,jj), ztmp) 131 ztfrt(ji,jj) = MIN(ztfrt(ji,jj), rn_tfri2_max) 132 END DO 133 END DO 134 END IF 135 ! 125 136 ELSE 126 137 zbfrt(:,:) = bfrcoef2d(:,:) 127 ENDIF 128 129 # if defined key_vectopt_loop 130 DO jj = 1, 1 131 !CDIR NOVERRCHK 132 DO ji = jpi+2, jpij-jpi-1 ! vector opt. (forced unrolling) 133 # else 134 !CDIR NOVERRCHK 138 ztfrt(:,:) = tfrcoef2d(:,:) 139 ENDIF 140 135 141 DO jj = 2, jpjm1 136 !CDIR NOVERRCHK137 142 DO ji = 2, jpim1 138 # endif139 143 ikbu = mbku(ji,jj) ! ocean bottom level at u- and v-points 140 144 ikbv = mbkv(ji,jj) ! (deepest ocean u- and v-points) … … 150 154 bfrua(ji,jj) = - 0.5_wp * ( zbfrt(ji,jj) + zbfrt(ji+1,jj ) ) * zecu 151 155 bfrva(ji,jj) = - 0.5_wp * ( zbfrt(ji,jj) + zbfrt(ji ,jj+1) ) * zecv 156 ! 157 ! in case of 2 cell water column, we assume each cell feels the top and bottom friction 158 IF ( ln_isfcav ) THEN 159 IF ( miku(ji,jj) + 1 >= mbku(ji,jj) ) THEN 160 bfrua(ji,jj) = - 0.5_wp * ( ( zbfrt(ji,jj) + zbfrt(ji+1,jj ) ) & 161 & + ( ztfrt(ji,jj) + ztfrt(ji+1,jj ) ) ) & 162 & * zecu * (1._wp - umask(ji,jj,1)) 163 ENDIF 164 IF( mikv(ji,jj) + 1 >= mbkv(ji,jj) ) THEN 165 bfrva(ji,jj) = - 0.5_wp * ( ( zbfrt(ji,jj) + zbfrt(ji ,jj+1) ) & 166 & + ( ztfrt(ji,jj) + ztfrt(ji ,jj+1) ) ) & 167 & * zecv * (1._wp - vmask(ji,jj,1)) 168 ENDIF 169 ENDIF 152 170 END DO 153 171 END DO 154 155 !156 172 CALL lbc_lnk( bfrua, 'U', 1. ) ; CALL lbc_lnk( bfrva, 'V', 1. ) ! Lateral boundary condition 173 174 IF( ln_isfcav ) THEN 175 DO jj = 2, jpjm1 176 DO ji = 2, jpim1 177 ! (ISF) ======================================================================== 178 ikbu = miku(ji,jj) ! ocean top level at u- and v-points 179 ikbv = mikv(ji,jj) ! (1st wet ocean u- and v-points) 180 ! 181 zvu = 0.25 * ( vn(ji,jj ,ikbu) + vn(ji+1,jj ,ikbu) & 182 & + vn(ji,jj-1,ikbu) + vn(ji+1,jj-1,ikbu) ) 183 zuv = 0.25 * ( un(ji,jj ,ikbv) + un(ji-1,jj ,ikbv) & 184 & + un(ji,jj+1,ikbv) + un(ji-1,jj+1,ikbv) ) 185 ! 186 zecu = SQRT( un(ji,jj,ikbu) * un(ji,jj,ikbu) + zvu*zvu + rn_tfeb2 ) 187 zecv = SQRT( vn(ji,jj,ikbv) * vn(ji,jj,ikbv) + zuv*zuv + rn_tfeb2 ) 188 ! 189 tfrua(ji,jj) = - 0.5_wp * ( ztfrt(ji,jj) + ztfrt(ji+1,jj ) ) * zecu * (1._wp - umask(ji,jj,1)) 190 tfrva(ji,jj) = - 0.5_wp * ( ztfrt(ji,jj) + ztfrt(ji ,jj+1) ) * zecv * (1._wp - vmask(ji,jj,1)) 191 ! (ISF) END ==================================================================== 192 ! in case of 2 cell water column, we assume each cell feels the top and bottom friction 193 IF ( miku(ji,jj) + 1 .GE. mbku(ji,jj) ) THEN 194 tfrua(ji,jj) = - 0.5_wp * ( ( ztfrt(ji,jj) + ztfrt(ji+1,jj ) ) & 195 & + ( zbfrt(ji,jj) + zbfrt(ji+1,jj ) ) ) & 196 & * zecu * (1._wp - umask(ji,jj,1)) 197 END IF 198 IF ( mikv(ji,jj) + 1 .GE. mbkv(ji,jj) ) THEN 199 tfrva(ji,jj) = - 0.5_wp * ( ( ztfrt(ji,jj) + ztfrt(ji ,jj+1) ) & 200 & + ( zbfrt(ji,jj) + zbfrt(ji ,jj+1) ) ) & 201 & * zecv * (1._wp - vmask(ji,jj,1)) 202 END IF 203 END DO 204 END DO 205 CALL lbc_lnk( tfrua, 'U', 1. ) ; CALL lbc_lnk( tfrva, 'V', 1. ) ! Lateral boundary condition 206 END IF 207 ! 157 208 ! 158 209 IF(ln_ctl) CALL prt_ctl( tab2d_1=bfrua, clinfo1=' bfr - u: ', mask1=umask, & 159 210 & tab2d_2=bfrva, clinfo2= ' v: ', mask2=vmask,ovlap=1 ) 160 CALL wrk_dealloc( jpi,jpj,zbfrt )211 CALL wrk_dealloc( jpi,jpj,zbfrt, ztfrt ) 161 212 ENDIF 162 213 ! … … 183 234 INTEGER :: ios 184 235 REAL(wp) :: zminbfr, zmaxbfr ! temporary scalars 236 REAL(wp) :: zmintfr, zmaxtfr ! temporary scalars 185 237 REAL(wp) :: ztmp, zfru, zfrv ! - - 186 238 !! 187 239 NAMELIST/nambfr/ nn_bfr, rn_bfri1, rn_bfri2, rn_bfri2_max, rn_bfeb2, rn_bfrz0, ln_bfr2d, & 188 & rn_bfrien, ln_bfrimp, ln_loglayer 240 & rn_tfri1, rn_tfri2, rn_tfri2_max, rn_tfeb2, rn_tfrz0, ln_tfr2d, & 241 & rn_bfrien, rn_tfrien, ln_bfrimp, ln_loglayer 189 242 !!---------------------------------------------------------------------- 190 243 ! … … 215 268 bfrua(:,:) = 0.e0 216 269 bfrva(:,:) = 0.e0 270 tfrua(:,:) = 0.e0 271 tfrva(:,:) = 0.e0 217 272 ! 218 273 CASE( 1 ) 219 274 IF(lwp) WRITE(numout,*) ' linear botton friction' 220 IF(lwp) WRITE(numout,*) ' friction coef. rn_bfri1 = ', rn_bfri1275 IF(lwp) WRITE(numout,*) ' bottom friction coef. rn_bfri1 = ', rn_bfri1 221 276 IF( ln_bfr2d ) THEN 222 277 IF(lwp) WRITE(numout,*) ' read coef. enhancement distribution from file ln_bfr2d = ', ln_bfr2d 223 278 IF(lwp) WRITE(numout,*) ' coef rn_bfri2 enhancement factor rn_bfrien = ',rn_bfrien 224 279 ENDIF 280 IF ( ln_isfcav ) THEN 281 IF(lwp) WRITE(numout,*) ' top friction coef. rn_bfri1 = ', rn_tfri1 282 IF( ln_tfr2d ) THEN 283 IF(lwp) WRITE(numout,*) ' read coef. enhancement distribution from file ln_tfr2d = ', ln_tfr2d 284 IF(lwp) WRITE(numout,*) ' coef rn_tfri2 enhancement factor rn_tfrien = ',rn_tfrien 285 ENDIF 286 END IF 225 287 ! 226 288 IF(ln_bfr2d) THEN … … 236 298 bfrua(:,:) = - bfrcoef2d(:,:) 237 299 bfrva(:,:) = - bfrcoef2d(:,:) 300 ! 301 IF ( ln_isfcav ) THEN 302 IF(ln_tfr2d) THEN 303 ! tfr_coef is a coefficient in [0,1] giving the mask where to apply the bfr enhancement 304 CALL iom_open('tfr_coef.nc',inum) 305 CALL iom_get (inum, jpdom_data, 'tfr_coef',tfrcoef2d,1) ! tfrcoef2d is used as tmp array 306 CALL iom_close(inum) 307 tfrcoef2d(:,:) = rn_tfri1 * ( 1 + rn_tfrien * tfrcoef2d(:,:) ) 308 ELSE 309 tfrcoef2d(:,:) = rn_tfri1 ! initialize tfrcoef2d to the namelist variable 310 ENDIF 311 ! 312 tfrua(:,:) = - tfrcoef2d(:,:) 313 tfrva(:,:) = - tfrcoef2d(:,:) 314 END IF 238 315 ! 239 316 CASE( 2 ) … … 252 329 IF(lwp) WRITE(numout,*) ' coef rn_bfri2 enhancement factor rn_bfrien = ',rn_bfrien 253 330 ENDIF 331 IF ( ln_isfcav ) THEN 332 IF(lwp) WRITE(numout,*) ' quadratic top friction' 333 IF(lwp) WRITE(numout,*) ' friction coef. rn_tfri2 = ', rn_tfri2 334 IF(lwp) WRITE(numout,*) ' Max. coef. (log case) rn_tfri2_max = ', rn_tfri2_max 335 IF(lwp) WRITE(numout,*) ' background tke rn_tfeb2 = ', rn_tfeb2 336 IF(lwp) WRITE(numout,*) ' log formulation ln_tfr2d = ', ln_loglayer 337 IF(lwp) WRITE(numout,*) ' top roughness rn_tfrz0 [m] = ', rn_tfrz0 338 IF( rn_tfrz0<=0.e0 ) THEN 339 WRITE(ctmp1,*) ' top roughness must be strictly positive' 340 CALL ctl_stop( ctmp1 ) 341 ENDIF 342 IF( ln_tfr2d ) THEN 343 IF(lwp) WRITE(numout,*) ' read coef. enhancement distribution from file ln_tfr2d = ', ln_tfr2d 344 IF(lwp) WRITE(numout,*) ' coef rn_tfri2 enhancement factor rn_tfrien = ',rn_tfrien 345 ENDIF 346 END IF 254 347 ! 255 348 IF(ln_bfr2d) THEN … … 263 356 bfrcoef2d(:,:) = rn_bfri2 ! initialize bfrcoef2d to the namelist variable 264 357 ENDIF 265 ! 266 IF ( ln_loglayer.AND.(.NOT.lk_vvl) ) THEN ! set "log layer" bottom friction once for all 267 # if defined key_vectopt_loop 268 DO jj = 1, 1 269 !CDIR NOVERRCHK 270 DO ji = 1, jpij ! vector opt. (forced unrolling) 271 # else 272 !CDIR NOVERRCHK 358 359 IF ( ln_isfcav ) THEN 360 IF(ln_tfr2d) THEN 361 ! tfr_coef is a coefficient in [0,1] giving the mask where to apply the bfr enhancement 362 CALL iom_open('tfr_coef.nc',inum) 363 CALL iom_get (inum, jpdom_data, 'tfr_coef',tfrcoef2d,1) ! tfrcoef2d is used as tmp array 364 CALL iom_close(inum) 365 ! 366 tfrcoef2d(:,:) = rn_tfri2 * ( 1 + rn_tfrien * tfrcoef2d(:,:) ) 367 ELSE 368 tfrcoef2d(:,:) = rn_tfri2 ! initialize tfrcoef2d to the namelist variable 369 ENDIF 370 END IF 371 ! 372 IF( ln_loglayer.AND. ln_linssh ) THEN ! set "log layer" bottom friction once for all 273 373 DO jj = 1, jpj 274 !CDIR NOVERRCHK275 374 DO ji = 1, jpi 276 # endif277 375 ikbt = mbkt(ji,jj) 278 ztmp = tmask(ji,jj,ikbt) * ( vkarmn / LOG( 0.5_wp * fse3t_n(ji,jj,ikbt) / rn_bfrz0 ))**2._wp376 ztmp = tmask(ji,jj,ikbt) * ( vkarmn / LOG( 0.5_wp * e3t_n(ji,jj,ikbt) / rn_bfrz0 ))**2._wp 279 377 bfrcoef2d(ji,jj) = MAX(bfrcoef2d(ji,jj), ztmp) 280 378 bfrcoef2d(ji,jj) = MIN(bfrcoef2d(ji,jj), rn_bfri2_max) 281 379 END DO 282 380 END DO 381 IF ( ln_isfcav ) THEN 382 DO jj = 1, jpj 383 DO ji = 1, jpi 384 ikbt = mikt(ji,jj) 385 ztmp = tmask(ji,jj,ikbt) * ( vkarmn / LOG( 0.5_wp * e3t_n(ji,jj,ikbt) / rn_tfrz0 ))**2._wp 386 tfrcoef2d(ji,jj) = MAX(tfrcoef2d(ji,jj), ztmp) 387 tfrcoef2d(ji,jj) = MIN(tfrcoef2d(ji,jj), rn_tfri2_max) 388 END DO 389 END DO 390 END IF 283 391 ENDIF 284 392 ! … … 308 416 zminbfr = 1.e10_wp ! initialise tracker for minimum of bottom friction coefficient 309 417 zmaxbfr = -1.e10_wp ! initialise tracker for maximum of bottom friction coefficient 310 ! 311 # if defined key_vectopt_loop 312 DO jj = 1, 1 313 !CDIR NOVERRCHK 314 DO ji = jpi+2, jpij-jpi-1 ! vector opt. (forced unrolling) 315 # else 316 !CDIR NOVERRCHK 418 zmintfr = 1.e10_wp ! initialise tracker for minimum of bottom friction coefficient 419 zmaxtfr = -1.e10_wp ! initialise tracker for maximum of bottom friction coefficient 420 ! 317 421 DO jj = 2, jpjm1 318 !CDIR NOVERRCHK319 422 DO ji = 2, jpim1 320 # endif321 423 ikbu = mbku(ji,jj) ! deepest ocean level at u- and v-points 322 424 ikbv = mbkv(ji,jj) 323 zfru = 0.5 * fse3u(ji,jj,ikbu) / rdt324 zfrv = 0.5 * fse3v(ji,jj,ikbv) / rdt425 zfru = 0.5 * e3u_n(ji,jj,ikbu) / rdt 426 zfrv = 0.5 * e3v_n(ji,jj,ikbv) / rdt 325 427 IF( ABS( bfrcoef2d(ji,jj) ) > zfru ) THEN 326 428 IF( ln_ctl ) THEN … … 339 441 zminbfr = MIN( zminbfr, MIN( zfru, ABS( bfrcoef2d(ji,jj) ) ) ) 340 442 zmaxbfr = MAX( zmaxbfr, MIN( zfrv, ABS( bfrcoef2d(ji,jj) ) ) ) 443 ! (ISF) 444 IF ( ln_isfcav ) THEN 445 ikbu = miku(ji,jj) ! 1st wet ocean level at u- and v-points 446 ikbv = mikv(ji,jj) 447 zfru = 0.5 * e3u_n(ji,jj,ikbu) / rdt 448 zfrv = 0.5 * e3v_n(ji,jj,ikbv) / rdt 449 IF( ABS( tfrcoef2d(ji,jj) ) > zfru ) THEN 450 IF( ln_ctl ) THEN 451 WRITE(numout,*) 'TFR ', narea, nimpp+ji, njmpp+jj, ikbu 452 WRITE(numout,*) 'TFR ', ABS( tfrcoef2d(ji,jj) ), zfru 453 ENDIF 454 ictu = ictu + 1 455 ENDIF 456 IF( ABS( tfrcoef2d(ji,jj) ) > zfrv ) THEN 457 IF( ln_ctl ) THEN 458 WRITE(numout,*) 'TFR ', narea, nimpp+ji, njmpp+jj, ikbv 459 WRITE(numout,*) 'TFR ', tfrcoef2d(ji,jj), zfrv 460 ENDIF 461 ictv = ictv + 1 462 ENDIF 463 zmintfr = MIN( zmintfr, MIN( zfru, ABS( tfrcoef2d(ji,jj) ) ) ) 464 zmaxtfr = MAX( zmaxtfr, MIN( zfrv, ABS( tfrcoef2d(ji,jj) ) ) ) 465 END IF 466 ! END ISF 341 467 END DO 342 468 END DO … … 346 472 CALL mpp_min( zminbfr ) 347 473 CALL mpp_max( zmaxbfr ) 474 IF ( ln_isfcav) CALL mpp_min( zmintfr ) 475 IF ( ln_isfcav) CALL mpp_max( zmaxtfr ) 348 476 ENDIF 349 477 IF( .NOT.ln_bfrimp) THEN 350 478 IF( lwp .AND. ictu + ictv > 0 ) THEN 351 WRITE(numout,*) ' Bottom friction stability check failed at ', ictu, ' U-points '352 WRITE(numout,*) ' Bottom friction stability check failed at ', ictv, ' V-points '479 WRITE(numout,*) ' Bottom/Top friction stability check failed at ', ictu, ' U-points ' 480 WRITE(numout,*) ' Bottom/Top friction stability check failed at ', ictv, ' V-points ' 353 481 WRITE(numout,*) ' Bottom friction coefficient now ranges from: ', zminbfr, ' to ', zmaxbfr 354 WRITE(numout,*) ' Bottom friction coefficient will be reduced where necessary' 482 IF ( ln_isfcav ) WRITE(numout,*) ' Top friction coefficient now ranges from: ', zmintfr, ' to ', zmaxtfr 483 WRITE(numout,*) ' Bottom/Top friction coefficient will be reduced where necessary' 355 484 ENDIF 356 485 ENDIF
Note: See TracChangeset
for help on using the changeset viewer.
