- Timestamp:
- 2017-12-13T15:58:53+01:00 (6 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2017/dev_merge_2017/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_fct.F90
r7753 r9019 9 9 !!---------------------------------------------------------------------- 10 10 !! tra_adv_fct : update the tracer trend with a 3D advective trends using a 2nd or 4th order FCT scheme 11 !! tra_adv_fct_zts: update the tracer trend with a 3D advective trends using a 2nd order FCT scheme12 11 !! with sub-time-stepping in the vertical direction 13 12 !! nonosc : compute monotonic tracer fluxes by a non-oscillatory algorithm … … 21 20 USE diaptr ! poleward transport diagnostics 22 21 USE diaar5 ! AR5 diagnostics 23 USE phycst , ONLY: rau0_rcp22 USE phycst , ONLY : rau0_rcp 24 23 ! 25 24 USE in_out_manager ! I/O manager 26 USE iom 25 USE iom ! 27 26 USE lib_mpp ! MPP library 28 27 USE lbclnk ! ocean lateral boundary condition (or mpp link) 29 28 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 30 USE wrk_nemo ! Memory Allocation31 29 USE timing ! Timing 32 30 … … 34 32 PRIVATE 35 33 36 PUBLIC tra_adv_fct ! routine called by traadv.F90 37 PUBLIC tra_adv_fct_zts ! routine called by traadv.F90 38 PUBLIC interp_4th_cpt ! routine called by traadv_cen.F90 34 PUBLIC tra_adv_fct ! called by traadv.F90 35 PUBLIC interp_4th_cpt ! called by traadv_cen.F90 39 36 40 37 LOGICAL :: l_trd ! flag to compute trends … … 50 47 # include "vectopt_loop_substitute.h90" 51 48 !!---------------------------------------------------------------------- 52 !! NEMO/OPA 3.7 , NEMO Consortium (2014)49 !! NEMO/OPA 4.0 , NEMO Consortium (2017) 53 50 !! $Id$ 54 51 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 70 67 !! 71 68 !! ** Action : - update pta with the now advective tracer trends 72 !! - send trends to trdtra module for further diagnost cs (l_trdtra=T)69 !! - send trends to trdtra module for further diagnostics (l_trdtra=T) 73 70 !! - htr_adv, str_adv : poleward advective heat and salt transport (ln_diaptr=T) 74 71 !!---------------------------------------------------------------------- … … 88 85 REAL(wp) :: zfp_ui, zfp_vj, zfp_wk, zC2t_u, zC4t_u ! - - 89 86 REAL(wp) :: zfm_ui, zfm_vj, zfm_wk, zC2t_v, zC4t_v ! - - 90 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwi, zwx, zwy, zwz, ztu, ztv, zltu, zltv, ztw 91 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdx, ztrdy, ztrdz, zptry 92 REAL(wp), POINTER, DIMENSION(:,:) :: z2d 93 !!---------------------------------------------------------------------- 94 ! 95 IF( nn_timing == 1 ) CALL timing_start('tra_adv_fct') 96 ! 97 CALL wrk_alloc( jpi,jpj,jpk, zwi, zwx, zwy, zwz, ztu, ztv, zltu, zltv, ztw ) 87 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwi, zwx, zwy, zwz, ztu, ztv, zltu, zltv, ztw 88 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdx, ztrdy, ztrdz, zptry 89 !!---------------------------------------------------------------------- 90 ! 91 IF( ln_timing ) CALL timing_start('tra_adv_fct') 98 92 ! 99 93 IF( kt == kit000 ) THEN … … 103 97 ENDIF 104 98 ! 105 l_trd = .FALSE. 99 l_trd = .FALSE. ! set local switches 106 100 l_hst = .FALSE. 107 101 l_ptr = .FALSE. 108 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) )l_trd = .TRUE.109 IF( cdtype == 'TRA' .AND. ln_diaptr )l_ptr = .TRUE.110 IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR.&111 & 102 IF( ( cdtype =='TRA' .AND. l_trdtra ) .OR. ( cdtype =='TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 103 IF( cdtype =='TRA' .AND. ln_diaptr ) l_ptr = .TRUE. 104 IF( cdtype =='TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 105 & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. 112 106 ! 113 107 IF( l_trd .OR. l_hst ) THEN 114 CALL wrk_alloc( jpi, jpj, jpk, ztrdx, ztrdy, ztrdz)108 ALLOCATE( ztrdx(jpi,jpj,jpk), ztrdy(jpi,jpj,jpk), ztrdz(jpi,jpj,jpk) ) 115 109 ztrdx(:,:,:) = 0._wp ; ztrdy(:,:,:) = 0._wp ; ztrdz(:,:,:) = 0._wp 116 110 ENDIF 117 111 ! 118 112 IF( l_ptr ) THEN 119 CALL wrk_alloc( jpi, jpj, jpk, zptry)113 ALLOCATE( zptry(jpi,jpj,jpk) ) 120 114 zptry(:,:,:) = 0._wp 121 115 ENDIF … … 184 178 END IF 185 179 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 186 IF( l_ptr ) zptry(:,:,:) = zwy(:,:,:)180 IF( l_ptr ) zptry(:,:,:) = zwy(:,:,:) 187 181 ! 188 182 ! !== anti-diffusive flux : high order minus low order ==! … … 308 302 END DO 309 303 ! 310 IF( l_trd .OR. l_hst ) THEN ! trend diagnostics (contribution of upstream fluxes) 311 ztrdx(:,:,:) = ztrdx(:,:,:) + zwx(:,:,:) ! <<< Add to previously computed 312 ztrdy(:,:,:) = ztrdy(:,:,:) + zwy(:,:,:) ! <<< Add to previously computed 313 ztrdz(:,:,:) = ztrdz(:,:,:) + zwz(:,:,:) ! <<< Add to previously computed 304 IF( l_trd .OR. l_hst ) THEN ! trend diagnostics // heat/salt transport 305 ztrdx(:,:,:) = ztrdx(:,:,:) + zwx(:,:,:) ! <<< add anti-diffusive fluxes 306 ztrdy(:,:,:) = ztrdy(:,:,:) + zwy(:,:,:) ! to upstream fluxes 307 ztrdz(:,:,:) = ztrdz(:,:,:) + zwz(:,:,:) ! 308 ! 309 IF( l_trd ) THEN ! trend diagnostics 310 CALL trd_tra( kt, cdtype, jn, jptra_xad, ztrdx, pun, ptn(:,:,:,jn) ) 311 CALL trd_tra( kt, cdtype, jn, jptra_yad, ztrdy, pvn, ptn(:,:,:,jn) ) 312 CALL trd_tra( kt, cdtype, jn, jptra_zad, ztrdz, pwn, ptn(:,:,:,jn) ) 313 ENDIF 314 ! ! heat/salt transport 315 IF( l_hst ) CALL dia_ar5_hst( jn, 'adv', ztrdx(:,:,:), ztrdy(:,:,:) ) 316 ! 317 DEALLOCATE( ztrdx, ztrdy, ztrdz ) 314 318 ENDIF 315 ! 316 IF( l_trd ) THEN 317 CALL trd_tra( kt, cdtype, jn, jptra_xad, ztrdx, pun, ptn(:,:,:,jn) ) 318 CALL trd_tra( kt, cdtype, jn, jptra_yad, ztrdy, pvn, ptn(:,:,:,jn) ) 319 CALL trd_tra( kt, cdtype, jn, jptra_zad, ztrdz, pwn, ptn(:,:,:,jn) ) 320 ! 321 END IF 322 ! ! heat/salt transport 323 IF( l_hst ) CALL dia_ar5_hst( jn, 'adv', ztrdx(:,:,:), ztrdy(:,:,:) ) 324 325 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 326 IF( l_ptr ) THEN 327 zptry(:,:,:) = zptry(:,:,:) + zwy(:,:,:) ! <<< Add to previously computed 319 IF( l_ptr ) THEN ! "Poleward" transports 320 zptry(:,:,:) = zptry(:,:,:) + zwy(:,:,:) ! <<< add anti-diffusive fluxes 328 321 CALL dia_ptr_hst( jn, 'adv', zptry(:,:,:) ) 322 DEALLOCATE( zptry ) 329 323 ENDIF 330 324 ! 331 325 END DO ! end of tracer loop 332 326 ! 333 CALL wrk_dealloc( jpi,jpj,jpk, zwi, zwx, zwy, zwz, ztu, ztv, zltu, zltv, ztw ) 334 IF( l_trd .OR. l_hst ) CALL wrk_dealloc( jpi, jpj, jpk, ztrdx, ztrdy, ztrdz ) 335 IF( l_ptr ) CALL wrk_dealloc( jpi, jpj, jpk, zptry ) 336 ! 337 IF( nn_timing == 1 ) CALL timing_stop('tra_adv_fct') 327 IF( ln_timing ) CALL timing_stop('tra_adv_fct') 338 328 ! 339 329 END SUBROUTINE tra_adv_fct 340 341 342 SUBROUTINE tra_adv_fct_zts( kt, kit000, cdtype, p2dt, pun, pvn, pwn, &343 & ptb, ptn, pta, kjpt, kn_fct_zts )344 !!----------------------------------------------------------------------345 !! *** ROUTINE tra_adv_fct_zts ***346 !!347 !! ** Purpose : Compute the now trend due to total advection of348 !! tracers and add it to the general trend of tracer equations349 !!350 !! ** Method : TVD ZTS scheme, i.e. 2nd order centered scheme with351 !! corrected flux (monotonic correction). This version use sub-352 !! timestepping for the vertical advection which increases stability353 !! when vertical metrics are small.354 !! note: - this advection scheme needs a leap-frog time scheme355 !!356 !! ** Action : - update (pta) with the now advective tracer trends357 !! - save the trends358 !!----------------------------------------------------------------------359 INTEGER , INTENT(in ) :: kt ! ocean time-step index360 INTEGER , INTENT(in ) :: kit000 ! first time step index361 CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator)362 INTEGER , INTENT(in ) :: kjpt ! number of tracers363 INTEGER , INTENT(in ) :: kn_fct_zts ! number of number of vertical sub-timesteps364 REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step365 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pun, pvn, pwn ! 3 ocean velocity components366 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb, ptn ! before and now tracer fields367 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend368 !369 REAL(wp), DIMENSION( jpk ) :: zts ! length of sub-timestep for vertical advection370 REAL(wp) :: zr_p2dt ! reciprocal of tracer timestep371 INTEGER :: ji, jj, jk, jl, jn ! dummy loop indices372 INTEGER :: jtb, jtn, jta ! sub timestep pointers for leap-frog/euler forward steps373 INTEGER :: jtaken ! toggle for collecting appropriate fluxes from sub timesteps374 REAL(wp) :: z_rzts ! Fractional length of Euler forward sub-timestep for vertical advection375 REAL(wp) :: ztra ! local scalar376 REAL(wp) :: zfp_ui, zfp_vj, zfp_wk ! - -377 REAL(wp) :: zfm_ui, zfm_vj, zfm_wk ! - -378 REAL(wp), POINTER, DIMENSION(:,: ) :: zwx_sav , zwy_sav379 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwi, zwx, zwy, zwz, zhdiv, zwzts, zwz_sav380 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdx, ztrdy, ztrdz381 REAL(wp), POINTER, DIMENSION(:,:,:) :: zptry382 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztrs383 !!----------------------------------------------------------------------384 !385 IF( nn_timing == 1 ) CALL timing_start('tra_adv_fct_zts')386 !387 CALL wrk_alloc( jpi,jpj, zwx_sav, zwy_sav )388 CALL wrk_alloc( jpi,jpj,jpk, zwx, zwy, zwz, zwi, zhdiv, zwzts, zwz_sav )389 CALL wrk_alloc( jpi,jpj,jpk,kjpt+1, ztrs )390 !391 IF( kt == kit000 ) THEN392 IF(lwp) WRITE(numout,*)393 IF(lwp) WRITE(numout,*) 'tra_adv_fct_zts : 2nd order FCT scheme with ', kn_fct_zts, ' vertical sub-timestep on ', cdtype394 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~'395 ENDIF396 !397 l_trd = .FALSE.398 l_hst = .FALSE.399 l_ptr = .FALSE.400 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE.401 IF( cdtype == 'TRA' .AND. ln_diaptr ) l_ptr = .TRUE.402 IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. &403 & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE.404 !405 IF( l_trd .OR. l_hst ) THEN406 CALL wrk_alloc( jpi,jpj,jpk, ztrdx, ztrdy, ztrdz )407 ztrdx(:,:,:) = 0._wp ; ztrdy(:,:,:) = 0._wp ; ztrdz(:,:,:) = 0._wp408 ENDIF409 !410 IF( l_ptr ) THEN411 CALL wrk_alloc( jpi, jpj,jpk, zptry )412 zptry(:,:,:) = 0._wp413 ENDIF414 zwi(:,:,:) = 0._wp415 z_rzts = 1._wp / REAL( kn_fct_zts, wp )416 zr_p2dt = 1._wp / p2dt417 !418 ! surface & Bottom value : flux set to zero for all tracers419 zwz(:,:, 1 ) = 0._wp420 zwx(:,:,jpk) = 0._wp ; zwz(:,:,jpk) = 0._wp421 zwy(:,:,jpk) = 0._wp ; zwi(:,:,jpk) = 0._wp422 !423 ! ! ===========424 DO jn = 1, kjpt ! tracer loop425 ! ! ===========426 !427 ! Upstream advection with initial mass fluxes & intermediate update428 DO jk = 1, jpkm1 ! upstream tracer flux in the i and j direction429 DO jj = 1, jpjm1430 DO ji = 1, fs_jpim1 ! vector opt.431 ! upstream scheme432 zfp_ui = pun(ji,jj,jk) + ABS( pun(ji,jj,jk) )433 zfm_ui = pun(ji,jj,jk) - ABS( pun(ji,jj,jk) )434 zfp_vj = pvn(ji,jj,jk) + ABS( pvn(ji,jj,jk) )435 zfm_vj = pvn(ji,jj,jk) - ABS( pvn(ji,jj,jk) )436 zwx(ji,jj,jk) = 0.5_wp * ( zfp_ui * ptb(ji,jj,jk,jn) + zfm_ui * ptb(ji+1,jj ,jk,jn) )437 zwy(ji,jj,jk) = 0.5_wp * ( zfp_vj * ptb(ji,jj,jk,jn) + zfm_vj * ptb(ji ,jj+1,jk,jn) )438 END DO439 END DO440 END DO441 ! ! upstream tracer flux in the k direction442 DO jk = 2, jpkm1 ! Interior value443 DO jj = 1, jpj444 DO ji = 1, jpi445 zfp_wk = pwn(ji,jj,jk) + ABS( pwn(ji,jj,jk) )446 zfm_wk = pwn(ji,jj,jk) - ABS( pwn(ji,jj,jk) )447 zwz(ji,jj,jk) = 0.5_wp * ( zfp_wk * ptb(ji,jj,jk,jn) + zfm_wk * ptb(ji,jj,jk-1,jn) ) * wmask(ji,jj,jk)448 END DO449 END DO450 END DO451 IF( ln_linssh ) THEN ! top value : linear free surface case only (as zwz is multiplied by wmask)452 IF( ln_isfcav ) THEN ! ice-shelf cavities: top value453 DO jj = 1, jpj454 DO ji = 1, jpi455 zwz(ji,jj, mikt(ji,jj) ) = pwn(ji,jj,mikt(ji,jj)) * ptb(ji,jj,mikt(ji,jj),jn)456 END DO457 END DO458 ELSE ! no cavities, surface value459 zwz(:,:,1) = pwn(:,:,1) * ptb(:,:,1,jn)460 ENDIF461 ENDIF462 !463 DO jk = 1, jpkm1 ! total advective trend464 DO jj = 2, jpjm1465 DO ji = fs_2, fs_jpim1 ! vector opt.466 ! ! total intermediate advective trends467 ztra = - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) &468 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) &469 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) * r1_e1e2t(ji,jj)470 ! ! update and guess with monotonic sheme471 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra / e3t_n(ji,jj,jk) * tmask(ji,jj,jk)472 zwi(ji,jj,jk) = ( e3t_b(ji,jj,jk) * ptb(ji,jj,jk,jn) + p2dt * ztra ) / e3t_a(ji,jj,jk) * tmask(ji,jj,jk)473 END DO474 END DO475 END DO476 !477 CALL lbc_lnk( zwi, 'T', 1. ) ! Lateral boundary conditions on zwi (unchanged sign)478 !479 IF( l_trd .OR. l_hst ) THEN ! trend diagnostics (contribution of upstream fluxes)480 ztrdx(:,:,:) = zwx(:,:,:) ; ztrdy(:,:,:) = zwy(:,:,:) ; ztrdz(:,:,:) = zwz(:,:,:)481 END IF482 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes)483 IF( l_ptr ) zptry(:,:,:) = zwy(:,:,:)484 485 ! 3. anti-diffusive flux : high order minus low order486 ! ---------------------------------------------------487 488 DO jk = 1, jpkm1 !* horizontal anti-diffusive fluxes489 !490 DO jj = 1, jpjm1491 DO ji = 1, fs_jpim1 ! vector opt.492 zwx_sav(ji,jj) = zwx(ji,jj,jk)493 zwy_sav(ji,jj) = zwy(ji,jj,jk)494 !495 zwx(ji,jj,jk) = 0.5_wp * pun(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji+1,jj,jk,jn) )496 zwy(ji,jj,jk) = 0.5_wp * pvn(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji,jj+1,jk,jn) )497 END DO498 END DO499 !500 DO jj = 2, jpjm1 ! partial horizontal divergence501 DO ji = fs_2, fs_jpim1502 zhdiv(ji,jj,jk) = ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk) &503 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk) )504 END DO505 END DO506 !507 DO jj = 1, jpjm1508 DO ji = 1, fs_jpim1 ! vector opt.509 zwx(ji,jj,jk) = zwx(ji,jj,jk) - zwx_sav(ji,jj)510 zwy(ji,jj,jk) = zwy(ji,jj,jk) - zwy_sav(ji,jj)511 END DO512 END DO513 END DO514 !515 ! !* vertical anti-diffusive flux516 zwz_sav(:,:,:) = zwz(:,:,:)517 ztrs (:,:,:,1) = ptb(:,:,:,jn)518 ztrs (:,:,1,2) = ptb(:,:,1,jn)519 ztrs (:,:,1,3) = ptb(:,:,1,jn)520 zwzts (:,:,:) = 0._wp521 !522 DO jl = 1, kn_fct_zts ! Start of sub timestepping loop523 !524 IF( jl == 1 ) THEN ! Euler forward to kick things off525 jtb = 1 ; jtn = 1 ; jta = 2526 zts(:) = p2dt * z_rzts527 jtaken = MOD( kn_fct_zts + 1 , 2) ! Toggle to collect every second flux528 ! ! starting at jl =1 if kn_fct_zts is odd;529 ! ! starting at jl =2 otherwise530 ELSEIF( jl == 2 ) THEN ! First leapfrog step531 jtb = 1 ; jtn = 2 ; jta = 3532 zts(:) = 2._wp * p2dt * z_rzts533 ELSE ! Shuffle pointers for subsequent leapfrog steps534 jtb = MOD(jtb,3) + 1535 jtn = MOD(jtn,3) + 1536 jta = MOD(jta,3) + 1537 ENDIF538 DO jk = 2, jpkm1 ! interior value539 DO jj = 2, jpjm1540 DO ji = fs_2, fs_jpim1541 zwz(ji,jj,jk) = 0.5_wp * pwn(ji,jj,jk) * ( ztrs(ji,jj,jk,jtn) + ztrs(ji,jj,jk-1,jtn) ) * wmask(ji,jj,jk)542 IF( jtaken == 0 ) zwzts(ji,jj,jk) = zwzts(ji,jj,jk) + zwz(ji,jj,jk) * zts(jk) ! Accumulate time-weighted vertcal flux543 END DO544 END DO545 END DO546 IF( ln_linssh ) THEN ! top value (only in linear free surface case)547 IF( ln_isfcav ) THEN ! ice-shelf cavities548 DO jj = 1, jpj549 DO ji = 1, jpi550 zwz(ji,jj, mikt(ji,jj) ) = pwn(ji,jj,mikt(ji,jj)) * ptb(ji,jj,mikt(ji,jj),jn) ! linear free surface551 END DO552 END DO553 ELSE ! no ocean cavities554 zwz(:,:,1) = pwn(:,:,1) * ptb(:,:,1,jn)555 ENDIF556 ENDIF557 !558 jtaken = MOD( jtaken + 1 , 2 )559 !560 DO jk = 2, jpkm1 ! total advective trends561 DO jj = 2, jpjm1562 DO ji = fs_2, fs_jpim1563 ztrs(ji,jj,jk,jta) = ztrs(ji,jj,jk,jtb) &564 & - zts(jk) * ( zhdiv(ji,jj,jk) + zwz(ji,jj,jk) - zwz(ji,jj,jk+1) ) &565 & * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk)566 END DO567 END DO568 END DO569 !570 END DO571 572 DO jk = 2, jpkm1 ! Anti-diffusive vertical flux using average flux from the sub-timestepping573 DO jj = 2, jpjm1574 DO ji = fs_2, fs_jpim1575 zwz(ji,jj,jk) = ( zwzts(ji,jj,jk) * zr_p2dt - zwz_sav(ji,jj,jk) ) * wmask(ji,jj,jk)576 END DO577 END DO578 END DO579 CALL lbc_lnk( zwx, 'U', -1. ) ; CALL lbc_lnk( zwy, 'V', -1. ) ! Lateral bondary conditions580 CALL lbc_lnk( zwz, 'W', 1. )581 582 ! 4. monotonicity algorithm583 ! -------------------------584 CALL nonosc( ptb(:,:,:,jn), zwx, zwy, zwz, zwi, p2dt )585 586 587 ! 5. final trend with corrected fluxes588 ! ------------------------------------589 DO jk = 1, jpkm1590 DO jj = 2, jpjm1591 DO ji = fs_2, fs_jpim1 ! vector opt.592 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ( zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) &593 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) &594 & * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk)595 END DO596 END DO597 END DO598 599 !600 IF( l_trd .OR. l_hst ) THEN ! trend diagnostics (contribution of upstream fluxes)601 ztrdx(:,:,:) = ztrdx(:,:,:) + zwx(:,:,:) ! <<< Add to previously computed602 ztrdy(:,:,:) = ztrdy(:,:,:) + zwy(:,:,:) ! <<< Add to previously computed603 ztrdz(:,:,:) = ztrdz(:,:,:) + zwz(:,:,:) ! <<< Add to previously computed604 ENDIF605 !606 IF( l_trd ) THEN607 CALL trd_tra( kt, cdtype, jn, jptra_xad, ztrdx, pun, ptn(:,:,:,jn) )608 CALL trd_tra( kt, cdtype, jn, jptra_yad, ztrdy, pvn, ptn(:,:,:,jn) )609 CALL trd_tra( kt, cdtype, jn, jptra_zad, ztrdz, pwn, ptn(:,:,:,jn) )610 !611 END IF612 ! ! heat/salt transport613 IF( l_hst ) CALL dia_ar5_hst( jn, 'adv', ztrdx(:,:,:), ztrdy(:,:,:) )614 615 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes)616 IF( l_ptr ) THEN617 zptry(:,:,:) = zptry(:,:,:) + zwy(:,:,:) ! <<< Add to previously computed618 CALL dia_ptr_hst( jn, 'adv', zptry(:,:,:) )619 ENDIF620 !621 END DO622 !623 CALL wrk_alloc( jpi,jpj, zwx_sav, zwy_sav )624 CALL wrk_alloc( jpi,jpj, jpk, zwx, zwy, zwz, zwi, zhdiv, zwzts, zwz_sav )625 CALL wrk_alloc( jpi,jpj,jpk,kjpt+1, ztrs )626 IF( l_trd .OR. l_hst ) CALL wrk_dealloc( jpi, jpj, jpk, ztrdx, ztrdy, ztrdz )627 IF( l_ptr ) CALL wrk_dealloc( jpi, jpj, jpk, zptry )628 !629 IF( nn_timing == 1 ) CALL timing_stop('tra_adv_fct_zts')630 !631 END SUBROUTINE tra_adv_fct_zts632 330 633 331 … … 653 351 REAL(wp) :: zpos, zneg, zbt, za, zb, zc, zbig, zrtrn ! local scalars 654 352 REAL(wp) :: zau, zbu, zcu, zav, zbv, zcv, zup, zdo ! - - 655 REAL(wp), POINTER, DIMENSION(:,:,:) :: zbetup, zbetdo, zbup, zbdo 656 !!---------------------------------------------------------------------- 657 ! 658 IF( nn_timing == 1 ) CALL timing_start('nonosc') 659 ! 660 CALL wrk_alloc( jpi, jpj, jpk, zbetup, zbetdo, zbup, zbdo ) 353 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zbetup, zbetdo, zbup, zbdo 354 !!---------------------------------------------------------------------- 355 ! 356 IF( ln_timing ) CALL timing_start('nonosc') 661 357 ! 662 358 zbig = 1.e+40_wp … … 734 430 CALL lbc_lnk( paa, 'U', -1. ) ; CALL lbc_lnk( pbb, 'V', -1. ) ! lateral boundary condition (changed sign) 735 431 ! 736 CALL wrk_dealloc( jpi, jpj, jpk, zbetup, zbetdo, zbup, zbdo ) 737 ! 738 IF( nn_timing == 1 ) CALL timing_stop('nonosc') 432 IF( ln_timing ) CALL timing_stop('nonosc') 739 433 ! 740 434 END SUBROUTINE nonosc
Note: See TracChangeset
for help on using the changeset viewer.
