Changeset 5974 for branches/2015/dev_r5072_UKMO2_OBS_simplification/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftke.F90
- Timestamp:
- 2015-12-02T11:52:05+01:00 (8 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2015/dev_r5072_UKMO2_OBS_simplification/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftke.F90
r5682 r5974 28 28 !! 3.6 ! 2014-11 (P. Mathiot) add ice shelf capability 29 29 !!---------------------------------------------------------------------- 30 #if defined key_zdftke || defined key_esopa30 #if defined key_zdftke 31 31 !!---------------------------------------------------------------------- 32 32 !! 'key_zdftke' TKE vertical physics … … 102 102 # include "vectopt_loop_substitute.h90" 103 103 !!---------------------------------------------------------------------- 104 !! NEMO/OPA 4.0 , NEMO Consortium (2011)104 !! NEMO/OPA 3.7 , NEMO Consortium (2015) 105 105 !! $Id$ 106 106 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 117 117 & e_pdl(jpi,jpj,jpk) , e_ric(jpi,jpj,jpk) , & 118 118 #endif 119 & apdlr(jpi,jpj,jpk) ,htau (jpi,jpj) , dissl(jpi,jpj,jpk) , &120 & STAT= zdf_tke_alloc )119 & htau (jpi,jpj) , dissl(jpi,jpj,jpk) , & 120 & apdlr(jpi,jpj,jpk) , STAT= zdf_tke_alloc ) 121 121 ! 122 122 IF( lk_mpp ) CALL mpp_sum ( zdf_tke_alloc ) … … 197 197 #if defined key_agrif 198 198 ! Update child grid f => parent grid 199 IF(lwp) WRITE(numout,*) 'sebseb', Agrif_Root(), kt, Agrif_NbStepint()200 199 IF( .NOT.Agrif_Root() ) CALL Agrif_Update_Tke( kt ) ! children only 201 200 #endif … … 233 232 REAL(wp) :: zzd_up, zzd_lw ! - - 234 233 !!bfr REAL(wp) :: zebot ! - - 235 INTEGER , POINTER, DIMENSION(:,: ) :: imlc236 REAL(wp), POINTER, DIMENSION(:,: ) :: zhlc237 REAL(wp), POINTER, DIMENSION(:,:,:) :: zpelc, zdiag, zd_up, zd_lw, z3du, z3dv234 INTEGER , POINTER, DIMENSION(:,: ) :: imlc 235 REAL(wp), POINTER, DIMENSION(:,: ) :: zhlc 236 REAL(wp), POINTER, DIMENSION(:,:,:) :: zpelc, zdiag, zd_up, zd_lw, z3du, z3dv 238 237 REAL(wp) :: zri ! local Richardson number 239 238 !!-------------------------------------------------------------------- … … 241 240 IF( nn_timing == 1 ) CALL timing_start('tke_tke') 242 241 ! 243 CALL wrk_alloc( jpi,jpj, imlc ) ! integer244 CALL wrk_alloc( jpi,jpj, zhlc )245 CALL wrk_alloc( jpi,jpj,jpk, zpelc, zdiag, zd_up, zd_lw, z3du, z3dv )242 CALL wrk_alloc( jpi,jpj, imlc ) ! integer 243 CALL wrk_alloc( jpi,jpj, zhlc ) 244 CALL wrk_alloc( jpi,jpj,jpk, zpelc, zdiag, zd_up, zd_lw, z3du, z3dv ) 246 245 ! 247 246 zbbrau = rn_ebb / rau0 ! Local constant initialisation … … 257 256 DO jj = 2, jpjm1 ! en(mikt(ji,jj)) = rn_emin 258 257 DO ji = fs_2, fs_jpim1 ! vector opt. 259 en(ji,jj,mikt(ji,jj)) =rn_emin * tmask(ji,jj,1)258 en(ji,jj,mikt(ji,jj)) = rn_emin * tmask(ji,jj,1) 260 259 END DO 261 260 END DO … … 278 277 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 279 278 ! en(bot) = (rn_ebb0/rau0)*0.5*sqrt(u_botfr^2+v_botfr^2) (min value rn_emin) 280 !CDIR NOVERRCHK281 279 !! DO jj = 2, jpjm1 282 !CDIR NOVERRCHK283 280 !! DO ji = fs_2, fs_jpim1 ! vector opt. 284 281 !! ztx2 = bfrua(ji-1,jj) * ub(ji-1,jj,mbku(ji-1,jj)) + & … … 319 316 END DO 320 317 zcof = 0.016 / SQRT( zrhoa * zcdrag ) 321 !CDIR NOVERRCHK322 318 DO jk = 2, jpkm1 !* TKE Langmuir circulation source term added to en 323 !CDIR NOVERRCHK 324 DO jj = 2, jpjm1 325 !CDIR NOVERRCHK 319 DO jj = 2, jpjm1 326 320 DO ji = fs_2, fs_jpim1 ! vector opt. 327 321 zus = zcof * SQRT( taum(ji,jj) ) ! Stokes drift … … 349 343 z3du(ji,jj,jk) = 0.5 * ( avm(ji,jj,jk ) + avm(ji+1,jj,jk) ) & 350 344 & * ( un(ji,jj,jk-1) - un(ji ,jj,jk) ) & 351 & * ( ub(ji,jj,jk-1) - ub(ji ,jj,jk) ) / ( fse3uw_n(ji,jj,jk) * fse3uw_b(ji,jj,jk) ) 345 & * ( ub(ji,jj,jk-1) - ub(ji ,jj,jk) ) * wumask(ji,jj,jk) & 346 & / ( fse3uw_n(ji,jj,jk) * fse3uw_b(ji,jj,jk) ) 352 347 z3dv(ji,jj,jk) = 0.5 * ( avm(ji,jj,jk ) + avm(ji,jj+1,jk) ) & 353 348 & * ( vn(ji,jj,jk-1) - vn(ji,jj ,jk) ) & 354 & * ( vb(ji,jj,jk-1) - vb(ji,jj ,jk) ) / ( fse3vw_n(ji,jj,jk) * fse3vw_b(ji,jj,jk) ) 349 & * ( vb(ji,jj,jk-1) - vb(ji,jj ,jk) ) * wvmask(ji,jj,jk) & 350 & / ( fse3vw_n(ji,jj,jk) * fse3vw_b(ji,jj,jk) ) 355 351 END DO 356 352 END DO … … 375 371 ! 376 372 ENDIF 377 373 ! 378 374 DO jk = 2, jpkm1 !* Matrix and right hand side in en 379 375 DO jj = 2, jpjm1 … … 407 403 END DO 408 404 END DO 409 ! 410 ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1 411 DO jj = 2, jpjm1 405 DO jj = 2, jpjm1 ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1 412 406 DO ji = fs_2, fs_jpim1 ! vector opt. 413 407 zd_lw(ji,jj,2) = en(ji,jj,2) - zd_lw(ji,jj,2) * en(ji,jj,1) ! Surface boudary conditions on tke … … 421 415 END DO 422 416 END DO 423 ! 424 ! thrid recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk 425 DO jj = 2, jpjm1 417 DO jj = 2, jpjm1 ! thrid recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk 426 418 DO ji = fs_2, fs_jpim1 ! vector opt. 427 419 en(ji,jj,jpkm1) = zd_lw(ji,jj,jpkm1) / zdiag(ji,jj,jpkm1) … … 464 456 END DO 465 457 ELSEIF( nn_etau == 3 ) THEN !* penetration belox the mixed layer (HF variability) 466 !CDIR NOVERRCHK467 458 DO jk = 2, jpkm1 468 !CDIR NOVERRCHK 469 DO jj = 2, jpjm1 470 !CDIR NOVERRCHK 459 DO jj = 2, jpjm1 471 460 DO ji = fs_2, fs_jpim1 ! vector opt. 472 461 ztx2 = utau(ji-1,jj ) + utau(ji,jj) … … 483 472 CALL lbc_lnk( en, 'W', 1. ) ! Lateral boundary conditions (sign unchanged) 484 473 ! 485 CALL wrk_dealloc( jpi,jpj, imlc ) ! integer486 CALL wrk_dealloc( jpi,jpj, zhlc )487 CALL wrk_dealloc( jpi,jpj,jpk, zpelc, zdiag, zd_up, zd_lw, z3du, z3dv )474 CALL wrk_dealloc( jpi,jpj, imlc ) ! integer 475 CALL wrk_dealloc( jpi,jpj, zhlc ) 476 CALL wrk_dealloc( jpi,jpj,jpk, zpelc, zdiag, zd_up, zd_lw, z3du, z3dv ) 488 477 ! 489 478 IF( nn_timing == 1 ) CALL timing_stop('tke_tke') … … 529 518 INTEGER :: ji, jj, jk ! dummy loop indices 530 519 REAL(wp) :: zrn2, zraug, zcoef, zav ! local scalars 531 REAL(wp) :: zdku, zri, zsqen ! - -520 REAL(wp) :: zdku, zri, zsqen ! - - 532 521 REAL(wp) :: zdkv, zemxl, zemlm, zemlp ! - - 533 522 REAL(wp), POINTER, DIMENSION(:,:,:) :: zmpdl, zmxlm, zmxld … … 559 548 ENDIF 560 549 ! 561 !CDIR NOVERRCHK562 550 DO jk = 2, jpkm1 ! interior value : l=sqrt(2*e/n^2) 563 !CDIR NOVERRCHK 564 DO jj = 2, jpjm1 565 !CDIR NOVERRCHK 551 DO jj = 2, jpjm1 566 552 DO ji = fs_2, fs_jpim1 ! vector opt. 567 553 zrn2 = MAX( rn2(ji,jj,jk), rsmall ) 568 zmxlm(ji,jj,jk) = MAX( rmxl_min, SQRT( 2._wp * en(ji,jj,jk) / zrn2 ) )554 zmxlm(ji,jj,jk) = MAX( rmxl_min, SQRT( 2._wp * en(ji,jj,jk) / zrn2 ) ) 569 555 END DO 570 556 END DO … … 573 559 ! !* Physical limits for the mixing length 574 560 ! 575 zmxld(:,:, 1) = zmxlm(:,:,1) ! surface set to the minimum value561 zmxld(:,:, 1 ) = zmxlm(:,:,1) ! surface set to the minimum value 576 562 zmxld(:,:,jpk) = rmxl_min ! last level set to the minimum value 577 563 ! 578 564 SELECT CASE ( nn_mxl ) 579 565 ! 566 !!gm Not sure of that coding for ISF.... 580 567 ! where wmask = 0 set zmxlm == fse3w 581 568 CASE ( 0 ) ! bounded by the distance to surface and bottom … … 636 623 END DO 637 624 END DO 638 !CDIR NOVERRCHK639 625 DO jk = 2, jpkm1 640 !CDIR NOVERRCHK 641 DO jj = 2, jpjm1 642 !CDIR NOVERRCHK 626 DO jj = 2, jpjm1 643 627 DO ji = fs_2, fs_jpim1 ! vector opt. 644 628 zemlm = MIN ( zmxld(ji,jj,jk), zmxlm(ji,jj,jk) ) … … 660 644 ! ! Vertical eddy viscosity and diffusivity (avmu, avmv, avt) 661 645 ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 662 !CDIR NOVERRCHK663 646 DO jk = 1, jpkm1 !* vertical eddy viscosity & diffivity at w-points 664 !CDIR NOVERRCHK 665 DO jj = 2, jpjm1 666 !CDIR NOVERRCHK 647 DO jj = 2, jpjm1 667 648 DO ji = fs_2, fs_jpim1 ! vector opt. 668 649 zsqen = SQRT( en(ji,jj,jk) ) … … 693 674 # if defined key_c1d 694 675 e_pdl(ji,jj,jk) = apdlr(ji,jj,jk) * wmask(ji,jj,jk) ! c1d configuration : save masked Prandlt number 676 !!gm bug NO zri here.... 677 !!gm remove the specific diag for c1d ! 695 678 e_ric(ji,jj,jk) = zri * wmask(ji,jj,jk) ! c1d config. : save Ri 696 679 # endif
Note: See TracChangeset
for help on using the changeset viewer.
