New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
Changeset 2024 – NEMO

Changeset 2024


Ignore:
Timestamp:
2010-07-29T12:57:35+02:00 (14 years ago)
Author:
cetlod
Message:

Merge of active and passive tracer advection/diffusion modules, see ticket:693

Location:
branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA
Files:
1 added
1 deleted
24 edited

Legend:

Unmodified
Added
Removed

  • branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/traadv.F90

    r1601 r2024  
    44   !! Ocean active tracers:  advection trend  
    55   !!============================================================================== 
    6    !! History :  2.0  !  05-11  (G. Madec)  Original code 
     6   !! History :  2.0  !  2005-11  (G. Madec)  Original code 
     7   !!            3.0  !  2008-01  (C. Ethe, G. Madec)  merge TRC-TRA + switch from velocity to transport 
    78   !!---------------------------------------------------------------------- 
    89 
    … …  
    1819   USE traadv_muscl2   ! MUSCL2   scheme           (tra_adv_muscl2 routine) 
    1920   USE traadv_ubs      ! UBS      scheme           (tra_adv_ubs    routine) 
    20    USE traadv_qck     !! QUICKEST scheme           (tra_adv_qck    routine) 
     21   USE traadv_qck      ! QUICKEST scheme           (tra_adv_qck    routine) 
    2122   USE traadv_eiv      ! eddy induced velocity     (tra_adv_eiv    routine) 
    22    USE trabbl          ! tracers: bottom boundary layer 
    2323   USE ldftra_oce      ! lateral diffusion coefficient on tracers 
    2424   USE in_out_manager  ! I/O manager 
    … …  
    2929   PRIVATE 
    3030 
    31    PUBLIC   tra_adv    ! routine called by step module 
     31   PUBLIC   tra_adv         ! routine called by step module 
     32   PUBLIC   tra_adv_init    ! routine called by opa module 
    3233  
    3334   !                                                   !!* Namelist namtra_adv * 
    34    LOGICAL, PUBLIC ::   ln_traadv_cen2   = .TRUE.       ! 2nd order centered scheme flag 
    35    LOGICAL, PUBLIC ::   ln_traadv_tvd    = .FALSE.      ! TVD scheme flag 
    36    LOGICAL, PUBLIC ::   ln_traadv_muscl  = .FALSE.      ! MUSCL scheme flag 
    37    LOGICAL, PUBLIC ::   ln_traadv_muscl2 = .FALSE.      ! MUSCL2 scheme flag 
    38    LOGICAL, PUBLIC ::   ln_traadv_ubs    = .FALSE.      ! UBS scheme flag 
    39    LOGICAL, PUBLIC ::   ln_traadv_qck    = .FALSE.      ! QUICKEST scheme flag 
     35   LOGICAL ::   ln_traadv_cen2   = .TRUE.       ! 2nd order centered scheme flag 
     36   LOGICAL ::   ln_traadv_tvd    = .FALSE.      ! TVD scheme flag 
     37   LOGICAL ::   ln_traadv_muscl  = .FALSE.      ! MUSCL scheme flag 
     38   LOGICAL ::   ln_traadv_muscl2 = .FALSE.      ! MUSCL2 scheme flag 
     39   LOGICAL ::   ln_traadv_ubs    = .FALSE.      ! UBS scheme flag 
     40   LOGICAL ::   ln_traadv_qck    = .FALSE.      ! QUICKEST scheme flag 
    4041 
    4142   INTEGER ::   nadv   ! choice of the type of advection scheme 
    … …  
    6061      !! ** Method  : - Update (ua,va) with the advection term following nadv 
    6162      !!---------------------------------------------------------------------- 
    62 #if ( defined key_trabbl_adv || defined key_traldf_eiv ) 
    63       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zun, zvn, zwn   ! effective velocity 
    64 #else 
    65       USE oce, ONLY :                       zun => un       ! the effective velocity is the 
    66       USE oce, ONLY :                       zvn => vn       ! Eulerian velocity 
    67       USE oce, ONLY :                       zwn => wn       !  
    68 #endif 
     63      INTEGER, INTENT( in ) ::   kt   ! ocean time-step index 
    6964      !! 
    70       INTEGER, INTENT( in ) ::   kt   ! ocean time-step index 
    71       !!---------------------------------------------------------------------- 
    72  
    73       IF( kt == nit000 )   CALL tra_adv_ctl          ! initialisation & control of options 
    74  
    75 #if defined key_trabbl_adv 
    76       zun(:,:,:) = un(:,:,:) - u_bbl(:,:,:)          ! add the bbl velocity 
    77       zvn(:,:,:) = vn(:,:,:) - v_bbl(:,:,:) 
    78       zwn(:,:,:) = wn(:,:,:) + w_bbl(:,:,:) 
    79 #endif 
    80       IF( lk_traldf_eiv ) THEN                       ! commpute and add the eiv velocity 
    81          IF( .NOT. lk_trabbl_adv ) THEN  
    82             zun(:,:,:) = un(:,:,:) 
    83             zvn(:,:,:) = vn(:,:,:) 
    84             zwn(:,:,:) = wn(:,:,:) 
    85          ENDIF 
    86          CALL tra_adv_eiv( kt, zun, zvn, zwn )  
    87       ENDIF 
     65      INTEGER ::   jk   ! dummy loop index 
     66      REAL(wp), DIMENSION(jpi,jpj,jpk)   ::  zun, zvn, zwn   ! effective transport 
     67      !!---------------------------------------------------------------------- 
     68 
     69      !                                                   ! effective transport 
     70      DO jk = 1, jpkm1 
     71         !                                                ! eulerian transport only 
     72         zun(:,:,jk) = e2u(:,:) * fse3u(:,:,jk) * un(:,:,jk) 
     73         zvn(:,:,jk) = e1v(:,:) * fse3v(:,:,jk) * vn(:,:,jk) 
     74         zwn(:,:,jk) = e1t(:,:) * e2t(:,:)      * wn(:,:,jk) 
     75         ! 
     76      END DO 
     77      zwn(:,:,jpk) = 0.e0                                 ! no transport trough the bottom 
     78 
     79      !                                                   ! add the eiv transport (if necessary) 
     80      IF( lk_traldf_eiv )   CALL tra_adv_eiv( kt, zun, zvn, zwn, 'TRA' ) 
     81 
    8882 
    8983      SELECT CASE ( nadv )                           ! compute advection trend and add it to general trend 
    90       CASE ( 1 )   ;   CALL tra_adv_cen2    ( kt, zun, zvn, zwn )    ! 2nd order centered scheme 
    91       CASE ( 2 )   ;   CALL tra_adv_tvd     ( kt, zun, zvn, zwn )    ! TVD      scheme 
    92       CASE ( 3 )   ;   CALL tra_adv_muscl   ( kt, zun, zvn, zwn )    ! MUSCL    scheme 
    93       CASE ( 4 )   ;   CALL tra_adv_muscl2  ( kt, zun, zvn, zwn )    ! MUSCL2   scheme 
    94       CASE ( 5 )   ;   CALL tra_adv_ubs     ( kt, zun, zvn, zwn )    ! UBS      scheme 
    95       CASE ( 6 )   ;   CALL tra_adv_qck     ( kt, zun, zvn, zwn )    ! QUICKEST scheme 
     84      CASE ( 1 )   ;    CALL tra_adv_cen2  ( kt , 'TRA', zun, zvn, zwn, & 
     85                        &                    tsb, tsn  , tsa, jpts      )    !  2nd order centered scheme 
     86      CASE ( 2 )   ;    CALL tra_adv_tvd   ( kt , 'TRA', zun, zvn, zwn, & 
     87                        &                    tsb, tsn  , tsa, jpts      )    !  TVD scheme 
     88      CASE ( 3 )   ;    CALL tra_adv_muscl ( kt , 'TRA', zun, zvn, zwn, & 
     89                        &                    tsb, tsa  , jpts           )    !  MUSCL scheme 
     90      CASE ( 4 )   ;    CALL tra_adv_muscl2( kt , 'TRA', zun, zvn, zwn, & 
     91                        &                    tsb, tsn  , tsa, jpts      )    !  MUSCL2 scheme 
     92      CASE ( 5 )   ;    CALL tra_adv_ubs   ( kt , 'TRA', zun, zvn, zwn, & 
     93                        &                    tsb, tsn  , tsa, jpts      )    !  UBS scheme 
     94      CASE ( 6 )   ;    CALL tra_adv_qck   ( kt , 'TRA', zun, zvn, zwn, & 
     95                        &                    tsb, tsn  , tsa, jpts      )    !  QUICKEST scheme 
    9696      ! 
    97       CASE (-1 )                                                     ! esopa: test all possibility with control print 
    98                        CALL tra_adv_cen2    ( kt, zun, zvn, zwn ) 
    99                        CALL prt_ctl( tab3d_1=ta, clinfo1=' adv0 - Ta: ', mask1=tmask,               & 
    100             &                        tab3d_2=sa, clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    101                        CALL tra_adv_tvd     ( kt, zun, zvn, zwn ) 
    102                        CALL prt_ctl( tab3d_1=ta, clinfo1=' adv2 - Ta: ', mask1=tmask,               & 
    103             &                        tab3d_2=sa, clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    104                        CALL tra_adv_muscl   ( kt, zun, zvn, zwn ) 
    105                        CALL prt_ctl( tab3d_1=ta, clinfo1=' adv3 - Ta: ', mask1=tmask,               & 
    106             &                        tab3d_2=sa, clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    107                        CALL tra_adv_muscl2  ( kt, zun, zvn, zwn ) 
    108                        CALL prt_ctl( tab3d_1=ta, clinfo1=' adv4 - Ta: ', mask1=tmask,               & 
    109             &                        tab3d_2=sa, clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    110                        CALL tra_adv_ubs     ( kt, zun, zvn, zwn ) 
    111                        CALL prt_ctl( tab3d_1=ta, clinfo1=' adv5 - Ta: ', mask1=tmask,               & 
    112             &                        tab3d_2=sa, clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    113                        CALL tra_adv_qck     ( kt, zun, zvn, zwn ) 
    114                        CALL prt_ctl( tab3d_1=ta, clinfo1=' adv6 - Ta: ', mask1=tmask,               & 
    115             &                        tab3d_2=sa, clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
     97      CASE (-1 )                                   ! esopa: test all possibility with control pr 
     98                        CALL tra_adv_cen2  ( kt , 'TRA', zun, zvn, zwn, & 
     99                        &                    tsb, tsn  , tsa, jpts      )           
     100                        CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' adv0 - Ta: ', mask1=tmask,               & 
     101         &                            tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
     102                        CALL tra_adv_tvd   ( kt , 'TRA', zun, zvn, zwn, & 
     103                        &                    tsb, tsn  , tsa, jpts      )           
     104                        CALL tra_adv_tvd   ( kt, 'TRA', zun, zvn, zwn, tsb, tsn, tsa, jpts )           
     105                        CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' adv1 - Ta: ', mask1=tmask,               & 
     106         &                            tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
     107                        CALL tra_adv_muscl ( kt , 'TRA', zun, zvn, zwn, & 
     108                        &                    tsb, tsa  , jpts           )           
     109                        CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' adv3 - Ta: ', mask1=tmask,               & 
     110         &                            tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
     111                        CALL tra_adv_muscl2( kt , 'TRA', zun, zvn, zwn, & 
     112                        &                    tsb, tsn  , tsa, jpts      )           
     113                        CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' adv4 - Ta: ', mask1=tmask,               & 
     114         &                            tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
     115                        CALL tra_adv_ubs   ( kt , 'TRA', zun, zvn, zwn, & 
     116                        &                    tsb, tsn  , tsa, jpts      )           
     117                        CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' adv5 - Ta: ', mask1=tmask,               & 
     118         &                            tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
     119                        CALL tra_adv_qck   ( kt , 'TRA', zun, zvn, zwn, & 
     120                        &                    tsb, tsn  , tsa, jpts      )           
     121                        CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' adv6 - Ta: ', mask1=tmask,               & 
     122         &                            tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
     123         ! 
    116124      END SELECT 
    117125        
    … …  
    121129 
    122130      !                                              ! print mean trends (used for debugging) 
    123       IF(ln_ctl)   CALL prt_ctl( tab3d_1=ta, clinfo1=' adv  - Ta: ', mask1=tmask,               & 
    124          &                       tab3d_2=sa, clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
     131      IF(ln_ctl)   CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' adv  - Ta: ', mask1=tmask,               & 
     132         &                       tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    125133      ! 
    126134   END SUBROUTINE tra_adv 
    127135 
    128136 
    129    SUBROUTINE tra_adv_ctl 
     137   SUBROUTINE tra_adv_init 
    130138      !!--------------------------------------------------------------------- 
    131       !!                  ***  ROUTINE tra_adv_ctl  *** 
     139      !!                  ***  ROUTINE tra_adv_init  *** 
    132140      !!                 
    133141      !! ** Purpose :   Control the consistency between namelist options for  
    … …  
    146154      IF(lwp) THEN                    ! Namelist print 
    147155         WRITE(numout,*) 
    148          WRITE(numout,*) 'tra_adv_ctl : choice/control of the tracer advection scheme' 
     156         WRITE(numout,*) 'tra_adv_init : choice/control of the tracer advection scheme' 
    149157         WRITE(numout,*) '~~~~~~~~~~~' 
    150158         WRITE(numout,*) '   Namelist namtra_adv : chose a advection scheme for tracers' 
    … …  
    188196         IF( nadv ==  5 )   WRITE(numout,*) '         UBS       scheme is used' 
    189197         IF( nadv ==  6 )   WRITE(numout,*) '         QUICKEST  scheme is used' 
     198         IF( nadv ==  7 )   WRITE(numout,*) '         SMOLAR    scheme is used' 
    190199         IF( nadv == -1 )   WRITE(numout,*) '         esopa test: use all advection scheme' 
    191200      ENDIF 
    192201      ! 
    193    END SUBROUTINE tra_adv_ctl 
     202   END SUBROUTINE tra_adv_init 
    194203 
    195204  !!====================================================================== 

  • branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/traadv_cen2.F90

    r1559 r2024  
    22   !!====================================================================== 
    33   !!                     ***  MODULE  traadv_cen2  *** 
    4    !! Ocean active tracers:  horizontal & vertical advective trend 
     4   !! Ocean tracers:  horizontal & vertical advective trend 
    55   !!====================================================================== 
    66   !! History :  8.2  ! 2001-08  (G. Madec, E. Durand)  trahad+trazad=traadv  
    … …  
    1111   !!             -   ! 2006-07  (G. madec)  add ups_orca_set routine 
    1212   !!            3.2  ! 2009-07  (G. Madec) add avmb, avtb in restart for cen2 advection 
     13   !!            3.3  ! 2010-05  (C. Ethe, G. Madec)  merge TRC-TRA + switch from velocity to transport 
    1314   !!---------------------------------------------------------------------- 
    1415 
    … …  
    1920   !!                  area (set for orca 2 and 4 only) 
    2021   !!---------------------------------------------------------------------- 
    21    USE oce             ! ocean dynamics and active tracers 
     22   USE oce, ONLY: tsn  ! now ocean temperature and salinity 
    2223   USE dom_oce         ! ocean space and time domain 
    23    USE sbc_oce         ! surface boundary condition: ocean 
    24    USE dynspg_oce      ! choice/control of key cpp for surface pressure gradient 
    25    USE trdmod_oce      ! ocean variables trends 
    2624   USE eosbn2          ! equation of state 
    27    USE trdmod          ! ocean active tracers trends  
     25   USE trdmod_oce      ! tracers trends 
     26   USE trdtra          ! tracers trends 
    2827   USE closea          ! closed sea 
    29    USE trabbl          ! advective term in the BBL 
    30    USE sbcmod          ! surface Boundary Condition 
    3128   USE sbcrnf          ! river runoffs 
    3229   USE in_out_manager  ! I/O manager 
    3330   USE iom             ! IOM library 
    34    USE lib_mpp 
    35    USE lbclnk          ! ocean lateral boundary condition (or mpp link) 
    3631   USE diaptr          ! poleward transport diagnostics 
    37    USE prtctl          ! Print control 
    3832   USE zdf_oce         ! ocean vertical physics 
    3933   USE restart         ! ocean restart 
    … …  
    4539   PUBLIC   ups_orca_set    ! routine used by traadv_cen2_jki.F90 
    4640 
    47    REAL(wp), PUBLIC, DIMENSION(jpi,jpj) ::   upsmsk    !: mixed upstream/centered scheme near some straits  
     41   LOGICAL  :: l_trd       ! flag to compute trends 
     42 
     43   REAL(wp), PUBLIC, DIMENSION(jpi,jpj) :: upsmsk    !: mixed upstream/centered scheme near some straits  
    4844   !                                                   !  and in closed seas (orca 2 and 4 configurations) 
    49  
    50    REAL(wp), DIMENSION(jpi,jpj) ::   btr2   ! inverse of T-point surface [1/(e1t*e2t)] 
    51  
    5245   !! * Substitutions 
    5346#  include "domzgr_substitute.h90" 
    … …  
    6154CONTAINS 
    6255 
    63    SUBROUTINE tra_adv_cen2( kt, pun, pvn, pwn ) 
     56   SUBROUTINE tra_adv_cen2( kt   , cdtype, pun  , pvn, pwn, & 
     57      &                     ptrab, ptran , ptraa, kjpt   )  
    6458      !!---------------------------------------------------------------------- 
    6559      !!                  ***  ROUTINE tra_adv_cen2  *** 
    … …  
    7771      !!         Part I : horizontal advection 
    7872      !!       * centered flux: 
    79       !!               zcenu = e2u*e3u  un  mi(tn) 
    80       !!               zcenv = e1v*e3v  vn  mj(tn) 
     73      !!               zcenu = e2u*e3u  un  mi(ptran) 
     74      !!               zcenv = e1v*e3v  vn  mj(ptran) 
    8175      !!       * upstream flux: 
    82       !!               zupsu = e2u*e3u  un  (tb(i) or tb(i-1) ) [un>0 or <0] 
    83       !!               zupsv = e1v*e3v  vn  (tb(j) or tb(j-1) ) [vn>0 or <0] 
     76      !!               zupsu = e2u*e3u  un  (ptrab(i) or ptrab(i-1) ) [un>0 or <0] 
     77      !!               zupsv = e1v*e3v  vn  (ptrab(j) or ptrab(j-1) ) [vn>0 or <0] 
    8478      !!       * mixed upstream / centered horizontal advection scheme 
    8579      !!               zcofi = max(zind(i+1), zind(i)) 
    … …  
    8882      !!               zwy = zcofj * zupsv + (1-zcofj) * zcenv 
    8983      !!       * horizontal advective trend (divergence of the fluxes) 
    90       !!               zta = 1/(e1t*e2t*e3t) { di-1[zwx] + dj-1[zwy] } 
     84      !!               ztra = 1/(e1t*e2t*e3t) { di-1[zwx] + dj-1[zwy] } 
    9185      !!       * Add this trend now to the general trend of tracer (ta,sa): 
    92       !!              (ta,sa) = (ta,sa) + ( zta , zsa ) 
     86      !!               ptraa = ptraa + ztra 
    9387      !!       * trend diagnostic ('key_trdtra' defined): the trend is 
    9488      !!      saved for diagnostics. The trends saved is expressed as 
    9589      !!      Uh.gradh(T), i.e. 
    96       !!                     save trend = zta + tn divn 
    97       !!         In addition, the advective trend in the two horizontal direc- 
    98       !!      tion is also re-computed as Uh gradh(T). Indeed hadt+tn divn is 
    99       !!      equal to (in s-coordinates, and similarly in z-coord.): 
    100       !!         zta+tn*divn=1/(e1t*e2t*e3t) { mi-1( e2u*e3u  un  di[tn] ) 
    101       !!                                      +mj-1( e1v*e3v  vn  mj[tn] )  } 
    102       !!         NB:in z-coordinate - full step (ln_zco=T) e3u=e3v=e3t, so 
    103       !!      they vanish from the expression of the flux and divergence. 
     90      !!                     save trend = ztra + ptran divn 
    10491      !! 
    10592      !!         Part II : vertical advection 
    10693      !!      For temperature (idem for salinity) the advective trend is com- 
    10794      !!      puted as follows : 
    108       !!            zta = 1/e3t dk+1[ zwz ] 
     95      !!            ztra = 1/e3t dk+1[ zwz ] 
    10996      !!      where the vertical advective flux, zwz, is given by : 
    11097      !!            zwz = zcofk * zupst + (1-zcofk) * zcent 
    11198      !!      with 
    112       !!        zupsv = upstream flux = wn * (tb(k) or tb(k-1) ) [wn>0 or <0] 
     99      !!        zupsv = upstream flux = wn * (ptrab(k) or ptrab(k-1) ) [wn>0 or <0] 
    113100      !!        zcenu = centered flux = wn * mk(tn) 
    114101      !!         The surface boundary condition is : 
    115102      !!      variable volume (lk_vvl = T) : zero advective flux 
    116       !!      lin. free-surf  (lk_vvl = F) : wn(:,:,1) * tn(:,:,1) 
     103      !!      lin. free-surf  (lk_vvl = F) : wn(:,:,1) * ptran(:,:,1) 
    117104      !!         Add this trend now to the general trend of tracer (ta,sa): 
    118       !!            (ta,sa) = (ta,sa) + ( zta , zsa ) 
     105      !!             ptraa = ptraa + ztra 
    119106      !!         Trend diagnostic ('key_trdtra' defined): the trend is 
    120107      !!      saved for diagnostics. The trends saved is expressed as : 
    121       !!             save trend =  w.gradz(T) = zta - tn divn. 
    122       !! 
    123       !! ** Action :  - update (ta,sa) with the now advective tracer trends 
    124       !!              - save trends in (ztrdt,ztrds) ('key_trdtra') 
    125       !!---------------------------------------------------------------------- 
    126       USE oce, ONLY :   zwx => ua   ! use ua as workspace 
    127       USE oce, ONLY :   zwy => va   ! use va as workspace 
    128       !! 
    129       INTEGER , INTENT(in)                         ::   kt    ! ocean time-step index 
    130       REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) ::   pun   ! ocean velocity u-component 
    131       REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) ::   pvn   ! ocean velocity v-component 
    132       REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) ::   pwn   ! ocean velocity w-component 
    133       !! 
    134       INTEGER  ::   ji, jj, jk                       ! dummy loop indices 
    135       REAL(wp) ::   zbtr, zhw, ze3tr                 ! temporary scalars 
    136       REAL(wp) ::   zfp_ui, zfp_vj, zfp_w , zfui     !    -         - 
    137       REAL(wp) ::   zfm_ui, zfm_vj, zfm_w , zfvj     !    -         - 
     108      !!             save trend =  w.gradz(T) = ztra - ptran divn. 
     109      !! 
     110      !! ** Action :  - update ptraa  with the now advective tracer trends 
     111      !!              - save trends if needed 
     112      !!---------------------------------------------------------------------- 
     113      !!* Module used 
     114      USE oce         , zwx => ua   ! use ua as workspace 
     115      USE oce         , zwy => va   ! use va as workspace 
     116      !!* Arguments 
     117      INTEGER         , INTENT(in   )                               ::   kt              ! ocean time-step index 
     118      CHARACTER(len=3), INTENT(in   )                               ::   cdtype          ! =TRA or TRC (tracer indicator) 
     119      REAL(wp)        , INTENT(in   ), DIMENSION(jpi,jpj,jpk)       ::   pun, pvn, pwn   ! 3 ocean velocity components 
     120      INTEGER         , INTENT(in   )                               ::   kjpt            ! number of tracers 
     121      REAL(wp)        , INTENT(in   ), DIMENSION(jpi,jpj,jpk,kjpt)  ::   ptrab, ptran        ! before and now tracer fields 
     122      REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::   ptraa           ! tracer trend  
     123      !!* Local declarations 
     124      INTEGER  ::   ji, jj, jk, jn                   ! dummy loop indices 
     125      REAL(wp) ::   zbtr, ztra                       ! temporary scalars 
     126      REAL(wp) ::   zfp_ui, zfp_vj, zfp_w            !    -         - 
     127      REAL(wp) ::   zfm_ui, zfm_vj, zfm_w            !    -         - 
    138128      REAL(wp) ::   zcofi , zcofj , zcofk            !    -         - 
    139       REAL(wp) ::   zupsut, zupsus, zcenut, zcenus   !    -         - 
    140       REAL(wp) ::   zupsvt, zupsvs, zcenvt, zcenvs   !    -         - 
    141       REAL(wp) ::   zupst , zupss , zcent , zcens    !    -         - 
    142       REAL(wp) ::   z_hdivn_x, z_hdivn_y, z_hdivn    !    -         - 
     129      REAL(wp) ::   zupsut, zcenut                   !    -         - 
     130      REAL(wp) ::   zupsvt, zcenvt                   !    -         - 
     131      REAL(wp) ::   zupst , zcent                    !    -         - 
    143132      REAL(wp) ::   zice                             !    -         - 
    144133      REAL(wp), DIMENSION(jpi,jpj)     ::   ztfreez            ! 2D workspace 
    145       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zwz, ztrdt, zind   ! 3D workspace 
    146       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zww, ztrds         !  "      " 
     134      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zwz, zind   ! 3D workspace  
    147135      !!---------------------------------------------------------------------- 
    148136 
    … …  
    157145         IF( cp_cfg == "orca" )   CALL ups_orca_set      ! set mixed Upstream/centered scheme near some straits 
    158146         !                                               ! and in closed seas (orca2 and orca4 only) 
    159          !    
    160          btr2(:,:) = 1. / ( e1t(:,:) * e2t(:,:) )        ! inverse of T-point surface 
    161          ! 
    162147         IF( jp_cfg == 2 .AND. .NOT. ln_rstart ) THEN    ! Increase the background in the surface layers 
    163148            avmb(1) = 10.  * avmb(1)      ;      avtb(1) = 10.  * avtb(1) 
    … …  
    166151            avmb(4) =  2.5 * avmb(4)      ;      avtb(4) =  2.5 * avtb(4) 
    167152         ENDIF 
     153         ! 
     154         l_trd = .FALSE. 
     155         IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 
    168156      ENDIF 
    169  
     157      ! 
    170158      ! Upstream / centered scheme indicator 
    171159      ! ------------------------------------ 
    172160!!gm  not strickly exact : the freezing point should be computed at each ocean levels... 
    173161!!gm  not a big deal since cen2 is no more used in global ice-ocean simulations 
    174       ztfreez(:,:) = tfreez( sn(:,:,1) ) 
     162      ztfreez(:,:) = tfreez( tsn(:,:,1,jp_sal) ) 
    175163      DO jk = 1, jpk 
    176164         DO jj = 1, jpj 
    177165            DO ji = 1, jpi 
    178166               !                                        ! below ice covered area (if tn < "freezing"+0.1 ) 
    179                IF( tn(ji,jj,jk) <= ztfreez(ji,jj) + 0.1 ) THEN   ;   zice = 1.e0 
     167               IF( tsn(ji,jj,jk,jp_tem) <= ztfreez(ji,jj) + 0.1 ) THEN   ;   zice = 1.e0 
    180168               ELSE                                              ;   zice = 0.e0 
    181169               ENDIF 
    … …  
    189177      END DO 
    190178 
    191       ! I. Horizontal advection 
    192       !    ==================== 
    193       ! 
    194       DO jk = 1, jpkm1 
    195          !                        ! Second order centered tracer flux at u- and v-points 
    196          DO jj = 1, jpjm1 
    197             DO ji = 1, fs_jpim1   ! vector opt. 
    198                ! upstream indicator 
    199                zcofi = MAX( zind(ji+1,jj,jk), zind(ji,jj,jk) ) 
    200                zcofj = MAX( zind(ji,jj+1,jk), zind(ji,jj,jk) ) 
    201                ! volume fluxes * 1/2 
    202                zfui = 0.5 * e2u(ji,jj) * fse3u(ji,jj,jk) * pun(ji,jj,jk) 
    203                zfvj = 0.5 * e1v(ji,jj) * fse3v(ji,jj,jk) * pvn(ji,jj,jk) 
     179      DO jn = 1, kjpt 
     180         ! 
     181         ! I. Horizontal advection 
     182         !    ==================== 
     183         ! 
     184         DO jk = 1, jpkm1 
     185            !                        ! Second order centered tracer flux at u- and v-points 
     186            DO jj = 1, jpjm1 
    204187               ! 
    205                ! upstream scheme 
    206                zfp_ui = zfui + ABS( zfui ) 
    207                zfp_vj = zfvj + ABS( zfvj ) 
    208                zfm_ui = zfui - ABS( zfui ) 
    209                zfm_vj = zfvj - ABS( zfvj ) 
    210                zupsut = zfp_ui * tb(ji,jj,jk) + zfm_ui * tb(ji+1,jj  ,jk) 
    211                zupsvt = zfp_vj * tb(ji,jj,jk) + zfm_vj * tb(ji  ,jj+1,jk) 
    212                zupsus = zfp_ui * sb(ji,jj,jk) + zfm_ui * sb(ji+1,jj  ,jk) 
    213                zupsvs = zfp_vj * sb(ji,jj,jk) + zfm_vj * sb(ji  ,jj+1,jk) 
    214                ! centered scheme 
    215                zcenut = zfui * ( tn(ji,jj,jk) + tn(ji+1,jj  ,jk) ) 
    216                zcenvt = zfvj * ( tn(ji,jj,jk) + tn(ji  ,jj+1,jk) ) 
    217                zcenus = zfui * ( sn(ji,jj,jk) + sn(ji+1,jj  ,jk) ) 
    218                zcenvs = zfvj * ( sn(ji,jj,jk) + sn(ji  ,jj+1,jk) ) 
    219                ! mixed centered / upstream scheme 
    220                zwx(ji,jj,jk) = zcofi * zupsut + (1.-zcofi) * zcenut 
    221                zwy(ji,jj,jk) = zcofj * zupsvt + (1.-zcofj) * zcenvt 
    222                zww(ji,jj,jk) = zcofi * zupsus + (1.-zcofi) * zcenus 
    223                zwz(ji,jj,jk) = zcofj * zupsvs + (1.-zcofj) * zcenvs 
     188               DO ji = 1, fs_jpim1   ! vector opt. 
     189                  ! upstream indicator 
     190                  zcofi = MAX( zind(ji+1,jj,jk), zind(ji,jj,jk) ) 
     191                  zcofj = MAX( zind(ji,jj+1,jk), zind(ji,jj,jk) ) 
     192                  ! 
     193                  ! upstream scheme 
     194                  zfp_ui = pun(ji,jj,jk) + ABS( pun(ji,jj,jk) ) 
     195                  zfm_ui = pun(ji,jj,jk) - ABS( pun(ji,jj,jk) ) 
     196                  zfp_vj = pvn(ji,jj,jk) + ABS( pvn(ji,jj,jk) ) 
     197                  zfm_vj = pvn(ji,jj,jk) - ABS( pvn(ji,jj,jk) ) 
     198                  zupsut = zfp_ui * ptrab(ji,jj,jk,jn) + zfm_ui * ptrab(ji+1,jj  ,jk,jn) 
     199                  zupsvt = zfp_vj * ptrab(ji,jj,jk,jn) + zfm_vj * ptrab(ji  ,jj+1,jk,jn) 
     200                  ! centered scheme 
     201                  zcenut = pun(ji,jj,jk) * ( ptran(ji,jj,jk,jn) + ptran(ji+1,jj  ,jk,jn) ) 
     202                  zcenvt = pvn(ji,jj,jk) * ( ptran(ji,jj,jk,jn) + ptran(ji  ,jj+1,jk,jn) ) 
     203                  ! mixed centered / upstream scheme 
     204                  zwx(ji,jj,jk) = 0.5 * ( zcofi * zupsut + (1.-zcofi) * zcenut ) 
     205                  zwy(ji,jj,jk) = 0.5 * ( zcofj * zupsvt + (1.-zcofj) * zcenvt ) 
     206               END DO 
    224207            END DO 
    225208         END DO 
    226          !                        ! Tracer flux divergence at t-point added to the general trend 
    227          DO jj = 2, jpjm1 
    228             DO ji = fs_2, fs_jpim1   ! vector opt. 
    229                zbtr = btr2(ji,jj) / fse3t(ji,jj,jk) 
    230                ! 
    231                ta(ji,jj,jk) = ta(ji,jj,jk) - zbtr * (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk)  & 
    232                   &                                  + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk)  ) 
    233                sa(ji,jj,jk) = sa(ji,jj,jk) - zbtr * (  zww(ji,jj,jk) - zww(ji-1,jj  ,jk)  & 
    234                   &                                  + zwz(ji,jj,jk) - zwz(ji  ,jj-1,jk)  ) 
     209 
     210         ! II. Vertical advection 
     211         !     ================== 
     212         ! 
     213         !                                                ! Vertical advective fluxes 
     214         zwz(:,:,jpk) = 0.e0                                   ! Bottom  value : flux set to zero 
     215         !                                                     ! Surface value :  
     216         IF( lk_vvl ) THEN   ;   zwz(:,:, 1 ) = 0.e0                         ! volume variable 
     217         ELSE                ;   zwz(:,:, 1 ) = pwn(:,:,1) * ptran(:,:,1,jn)   ! linear free surface  
     218         ENDIF 
     219         ! 
     220         DO jk = 2, jpk              ! Second order centered tracer flux at w-point 
     221            DO jj = 2, jpjm1 
     222               DO ji = fs_2, fs_jpim1   ! vector opt. 
     223                  ! upstream indicator 
     224                  zcofk = MAX( zind(ji,jj,jk-1), zind(ji,jj,jk) )  
     225                  ! mixed centered / upstream scheme 
     226                  zfp_w = pwn(ji,jj,jk) + ABS( pwn(ji,jj,jk) ) 
     227                  zfm_w = pwn(ji,jj,jk) - ABS( pwn(ji,jj,jk) ) 
     228                  zupst = zfp_w * ptrab(ji,jj,jk,jn) + zfm_w * ptrab(ji,jj,jk-1,jn) 
     229                  ! centered scheme 
     230                  zcent = pwn(ji,jj,jk) * ( ptran(ji,jj,jk,jn) + ptran(ji,jj,jk-1,jn) ) 
     231                  ! mixed centered / upstream scheme 
     232                  zwz(ji,jj,jk) = 0.5 * ( zcofk * zupst + (1.-zcofk) * zcent ) 
     233               END DO 
    235234            END DO 
    236235         END DO 
    237       END DO 
    238  
    239  
    240       IF( l_trdtra ) THEN      ! Save the i- and j-advective trends for diagnostic (U.gradz(T) trends) 
    241          ! 
     236 
     237         ! II. Divergence of advective fluxes 
     238         ! ---------------------------------- 
    242239         DO jk = 1, jpkm1 
    243240            DO jj = 2, jpjm1 
    244241               DO ji = fs_2, fs_jpim1   ! vector opt. 
    245                   !-- Compute zonal divergence by splitting hdivn (see divcur.F90) 
    246                   !   N.B. This computation is not valid with OBC, BDY, cla, eiv, advective bbl  
    247                   zbtr      = btr2(ji,jj) / fse3t(ji,jj,jk) 
    248                   z_hdivn_x = (  e2u(ji  ,jj) * fse3u(ji  ,jj,jk) * pun(ji  ,jj,jk)          & 
    249                      &         - e2u(ji-1,jj) * fse3u(ji-1,jj,jk) * pun(ji-1,jj,jk) ) * zbtr 
    250                   ! 
    251                   ztrdt(ji,jj,jk) = - zbtr * ( zwx(ji,jj,jk) - zwx(ji-1,jj,jk) ) + tn(ji,jj,jk) * z_hdivn_x 
    252                   ztrds(ji,jj,jk) = - zbtr * ( zww(ji,jj,jk) - zww(ji-1,jj,jk) ) + sn(ji,jj,jk) * z_hdivn_x 
     242                  zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) *  fse3t(ji,jj,jk) ) 
     243                  ! advective trends 
     244                  ztra = - zbtr * (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
     245                  &                + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   & 
     246                  &                + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1)  ) 
     247                  ! advective trends added to the general tracer trends 
     248                  ptraa(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn) + ztra 
    253249               END DO 
    254250            END DO 
    255251         END DO 
    256          CALL trd_mod(ztrdt, ztrds, jptra_trd_xad, 'TRA', kt) 
    257          ! 
    258          DO jk = 1, jpkm1           ! T/S MERIDIONAL advection trends 
    259             DO jj = 2, jpjm1 
    260                DO ji = fs_2, fs_jpim1   ! vector opt. 
    261                   zbtr      = btr2(ji,jj) / fse3t(ji,jj,jk) 
    262                   z_hdivn_y = (  e1v(ji,  jj) * fse3v(ji,jj  ,jk) * pvn(ji,jj  ,jk)          & 
    263                      &         - e1v(ji,jj-1) * fse3v(ji,jj-1,jk) * pvn(ji,jj-1,jk) ) * zbtr 
    264                   ! 
    265                   ztrdt(ji,jj,jk) = - zbtr * ( zwy(ji,jj,jk) - zwy(ji,jj-1,jk) ) + tn(ji,jj,jk) * z_hdivn_y           
    266                   ztrds(ji,jj,jk) = - zbtr * ( zwz(ji,jj,jk) - zwz(ji,jj-1,jk) ) + sn(ji,jj,jk) * z_hdivn_y 
    267                END DO 
    268             END DO 
    269          END DO 
    270          CALL trd_mod(ztrdt, ztrds, jptra_trd_yad, 'TRA', kt) 
    271          ! 
    272          ztrdt(:,:,:) = ta(:,:,:)   ;   ztrds(:,:,:) = sa(:,:,:)       ! Save the horizontal up-to-date ta/sa trends 
    273          ! 
    274       ENDIF 
    275  
    276       IF( ln_diaptr .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN      ! "zonal" mean advective heat and salt transport  
    277          pht_adv(:) = ptr_vj( zwy(:,:,:) ) 
    278          pst_adv(:) = ptr_vj( zwz(:,:,:) ) 
    279       ENDIF 
    280  
    281       IF(ln_ctl)   CALL prt_ctl( tab3d_1=ta, clinfo1=' cen2 had  - Ta: ', mask1=tmask, & 
    282          &                       tab3d_2=sa, clinfo2=            ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    283  
    284  
    285       ! II. Vertical advection 
    286       !     ================== 
    287       ! 
    288       zwx(:,:,jpk) = 0.e0     ;    zwy(:,:,jpk) = 0.e0      ! Bottom value  : flux set to zero 
    289       ! 
    290       IF( lk_vvl ) THEN                                     ! Surface value : zero in variable volume 
    291          zwx(:,:, 1 ) = 0.e0    ;    zwy(:,:, 1 ) = 0.e0 
    292       ELSE                                                  !               : linear free surface case 
    293          zwx(:,:, 1 ) = pwn(:,:,1) * tn(:,:,1) 
    294          zwy(:,:, 1 ) = pwn(:,:,1) * sn(:,:,1) 
    295       ENDIF 
    296       ! 
    297       DO jk = 2, jpk              ! Second order centered tracer flux at w-point 
    298          DO jj = 2, jpjm1 
    299             DO ji = fs_2, fs_jpim1   ! vector opt. 
    300                zcofk = MAX( zind(ji,jj,jk-1), zind(ji,jj,jk) )      ! upstream indicator 
    301                zhw = 0.5 * pwn(ji,jj,jk)                            ! velocity * 1/2 
    302                ! 
    303                zfp_w = zhw + ABS( zhw )                             ! upstream scheme 
    304                zfm_w = zhw - ABS( zhw ) 
    305                zupst = zfp_w * tb(ji,jj,jk) + zfm_w * tb(ji,jj,jk-1) 
    306                zupss = zfp_w * sb(ji,jj,jk) + zfm_w * sb(ji,jj,jk-1) 
    307                ! 
    308                zcent = zhw * ( tn(ji,jj,jk) + tn(ji,jj,jk-1) )      ! centered scheme 
    309                zcens = zhw * ( sn(ji,jj,jk) + sn(ji,jj,jk-1) ) 
    310                ! 
    311                zwx(ji,jj,jk) = zcofk * zupst + (1.-zcofk) * zcent   ! mixed centered / upstream scheme 
    312                zwy(ji,jj,jk) = zcofk * zupss + (1.-zcofk) * zcens 
    313             END DO 
    314          END DO 
    315       END DO 
    316       ! 
    317       DO jk = 1, jpkm1            ! divergence of Tracer flux added to the general trend 
    318          DO jj = 2, jpjm1 
    319             DO ji = fs_2, fs_jpim1   ! vector opt. 
    320                ze3tr = 1. / fse3t(ji,jj,jk) 
    321                ta(ji,jj,jk) =  ta(ji,jj,jk) - ze3tr * ( zwx(ji,jj,jk) - zwx(ji,jj,jk+1) ) 
    322                sa(ji,jj,jk) =  sa(ji,jj,jk) - ze3tr * ( zwy(ji,jj,jk) - zwy(ji,jj,jk+1) ) 
    323             END DO 
    324          END DO 
    325       END DO 
    326  
    327       IF( l_trdtra ) THEN      ! Save the vertical advective trends for diagnostic (W gradz(T) trends) 
    328          DO jk = 1, jpkm1 
    329             DO jj = 2, jpjm1 
    330                DO ji = fs_2, fs_jpim1   ! vector opt. 
    331                   zbtr      = btr2(ji,jj) / fse3t(ji,jj,jk) 
    332                   z_hdivn_x = e2u(ji,jj)*fse3u(ji,jj,jk)*pun(ji,jj,jk) - e2u(ji-1,jj)*fse3u(ji-1,jj,jk)*pun(ji-1,jj,jk) 
    333                   z_hdivn_y = e1v(ji,jj)*fse3v(ji,jj,jk)*pvn(ji,jj,jk) - e1v(ji,jj-1)*fse3v(ji,jj-1,jk)*pvn(ji,jj-1,jk) 
    334                   ! 
    335                   z_hdivn   = (z_hdivn_x + z_hdivn_y) * zbtr 
    336                   ztrdt(ji,jj,jk) = ta(ji,jj,jk) - ztrdt(ji,jj,jk) - tn(ji,jj,jk) * z_hdivn  
    337                   ztrds(ji,jj,jk) = sa(ji,jj,jk) - ztrds(ji,jj,jk) - sn(ji,jj,jk) * z_hdivn 
    338                END DO 
    339             END DO 
    340          END DO 
    341          CALL trd_mod(ztrdt, ztrds, jptra_trd_zad, 'TRA', kt) 
    342       ENDIF 
    343  
    344       ! write avmb, avtb in restart (traadv_cen2 requires a modified avmb, avtb that are 
     252 
     253         !                                 ! trend diagnostics (contribution of upstream fluxes) 
     254         IF( l_trd ) THEN 
     255            CALL trd_tra( kt, cdtype, jn, jptra_trd_xad, zwx, pun, ptran(:,:,:,jn) ) 
     256            CALL trd_tra( kt, cdtype, jn, jptra_trd_yad, zwy, pvn, ptran(:,:,:,jn) ) 
     257            CALL trd_tra( kt, cdtype, jn, jptra_trd_zad, zwz, pwn, ptran(:,:,:,jn) ) 
     258         END IF 
     259         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
     260         IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN   
     261           IF( jn == jp_tem )  pht_adv(:) = ptr_vj( zwy(:,:,:) ) 
     262           IF( jn == jp_sal )  pst_adv(:) = ptr_vj( zwy(:,:,:) ) 
     263         ENDIF 
     264         ! 
     265      ENDDO 
     266 
    345267      ! ---------------------------  required in restart file to ensure restartability) 
    346268      ! avmb, avtb will be read in zdfini in restart case as they are used in zdftke, kpp etc... 
    347       IF( lrst_oce ) THEN 
     269      IF( lrst_oce .AND. cdtype == 'TRA' ) THEN 
    348270         CALL iom_rstput( kt, nitrst, numrow, 'avmb', avmb ) 
    349271         CALL iom_rstput( kt, nitrst, numrow, 'avtb', avtb ) 
    350272      ENDIF 
    351  
    352       IF(ln_ctl)   CALL prt_ctl( tab3d_1=ta, clinfo1=' cen2 zad  - Ta: ', mask1=tmask, & 
    353          &                       tab3d_2=sa, clinfo2=            ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    354273      ! 
    355274   END SUBROUTINE tra_adv_cen2 

  • branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/traadv_eiv.F90

    r1756 r2024  
    22   !!====================================================================== 
    33   !!                    ***  MODULE  traadv_eiv  *** 
    4    !! Ocean active tracers:  advection trend - eddy induced velocity 
     4   !! Ocean tracers:  advection trend - eddy induced velocity 
    55   !!====================================================================== 
    6    !! History :  9.0  !  05-11  (G. Madec)  Original code, from traldf and zdf _iso 
     6   !! History :  9.0  !  05-11 (G. Madec)  Original code, from traldf and zdf _iso 
     7   !!            3.3  !  10-05 (C. Ethe, G. Madec)  merge TRC-TRA  
    78   !!---------------------------------------------------------------------- 
    89#if defined key_traldf_eiv   ||   defined key_esopa 
    … …  
    4546CONTAINS 
    4647 
    47    SUBROUTINE tra_adv_eiv( kt, pun, pvn, pwn ) 
     48   SUBROUTINE tra_adv_eiv( kt, pun, pvn, pwn, cdtype ) 
    4849      !!---------------------------------------------------------------------- 
    4950      !!                  ***  ROUTINE tra_adv_eiv  *** 
    … …  
    6364      !! ** Action  : - add to p.n the eiv component 
    6465      !!---------------------------------------------------------------------- 
    65       INTEGER , INTENT(in   )                         ::   kt    ! ocean time-step index 
    66       REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) ::   pun   ! in : 3 ocean velocity components  
    67       REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) ::   pvn   ! out: 3 ocean velocity components 
    68       REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) ::   pwn   !      increased by the eiv 
     66      INTEGER , INTENT(in   )                         ::   kt     ! ocean time-step index 
     67      CHARACTER(len=3), INTENT(in)                    ::   cdtype          ! =TRA or TRC (tracer indicator) 
     68      REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) ::   pun    ! in : 3 ocean velocity components  
     69      REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) ::   pvn    ! out: 3 ocean velocity components 
     70      REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) ::   pwn    ! increased by the eiv 
    6971      !! 
    7072      INTEGER  ::   ji, jj, jk                 ! dummy loop indices 
    7173      REAL(wp) ::   zuwk, zuwk1, zuwi, zuwi1   ! temporary scalar 
    7274      REAL(wp) ::   zvwk, zvwk1, zvwj, zvwj1   !    "         " 
    73       REAL(wp) ::   zu_eiv, zv_eiv, zw_eiv     !    "         " 
    74 # if defined key_diaeiv 
     75      REAL(wp), DIMENSION(jpi,jpj) ::   zu_eiv, zv_eiv, zw_eiv     !    "         " 
     76# if defined key_diaeiv  
    7577      REAL(wp) ::   zztmp                      !    "         " 
    7678      REAL(wp), DIMENSION(jpi,jpj) ::   z2d    !    "         " 
    … …  
    8284         IF(lwp) WRITE(numout,*) 'tra_adv_eiv : eddy induced advection :' 
    8385         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~   add to velocity fields the eiv component' 
    84 # if defined key_diaeiv 
    85          u_eiv(:,:,:) = 0.e0 
    86          v_eiv(:,:,:) = 0.e0 
    87          w_eiv(:,:,:) = 0.e0 
     86# if defined key_diaeiv  
     87         IF( cdtype == 'TRA') THEN 
     88            u_eiv(:,:,:) = 0.e0 
     89            v_eiv(:,:,:) = 0.e0 
     90            w_eiv(:,:,:) = 0.e0 
     91         END IF 
    8892# endif 
    8993      ENDIF 
    90       !                                             ! ================= 
     94 
     95      zu_eiv(:,:) = 0.e0   ;   zv_eiv(:,:) = 0.e0   ;    zw_eiv(:,:) = 0.e0   
     96                                                    ! ================= 
    9197      DO jk = 1, jpkm1                              !  Horizontal slab 
    9298         !                                          ! ================= 
    … …  
    98104               zvwk1= ( wslpj(ji,jj,jk+1) + wslpj(ji,jj+1,jk+1) ) * fsaeiv(ji,jj,jk+1) * vmask(ji,jj,jk+1) 
    99105 
    100                zu_eiv = 0.5 * umask(ji,jj,jk) * ( zuwk - zuwk1 ) / fse3u(ji,jj,jk) 
    101                zv_eiv = 0.5 * vmask(ji,jj,jk) * ( zvwk - zvwk1 ) / fse3v(ji,jj,jk) 
     106               zu_eiv(ji,jj) = 0.5 * umask(ji,jj,jk) * ( zuwk - zuwk1 )  
     107               zv_eiv(ji,jj) = 0.5 * vmask(ji,jj,jk) * ( zvwk - zvwk1 )  
    102108    
    103                pun(ji,jj,jk) = pun(ji,jj,jk) + zu_eiv 
    104                pvn(ji,jj,jk) = pvn(ji,jj,jk) + zv_eiv 
    105 # if defined key_diaeiv 
    106                u_eiv(ji,jj,jk) = zu_eiv 
    107                v_eiv(ji,jj,jk) = zv_eiv 
    108 # endif 
     109               pun(ji,jj,jk) = pun(ji,jj,jk) + e2u(ji,jj) * zu_eiv(ji,jj) 
     110               pvn(ji,jj,jk) = pvn(ji,jj,jk) + e1v(ji,jj) * zv_eiv(ji,jj) 
    109111            END DO 
    110112         END DO 
     113# if defined key_diaeiv  
     114         IF( cdtype == 'TRA') THEN 
     115            u_eiv(:,:,jk) = zu_eiv(:,:) / fse3u(:,:,jk) 
     116            v_eiv(:,:,jk) = zv_eiv(:,:) / fse3v(:,:,jk) 
     117         END IF 
     118# endif 
    111119         IF( jk >=2 ) THEN                             ! jk=1 zw_eiv=0, not computed 
    112120            DO jj = 2, jpjm1 
    … …  
    118126                  zvwj1 = ( wslpj(ji,jj,jk)+wslpj(ji,jj+1,jk) ) * fsaeiv(ji,jj  ,jk) * e1v(ji  ,jj) * vmask(ji  ,jj,jk) 
    119127   
    120                   zw_eiv = - 0.5 * tmask(ji,jj,jk) * ( zuwi1 - zuwi + zvwj1 - zvwj ) / ( e1t(ji,jj)*e2t(ji,jj) ) 
     128                  zw_eiv(ji,jj) = - 0.5 * tmask(ji,jj,jk) * ( zuwi1 - zuwi + zvwj1 - zvwj )  
    121129# else 
    122130                  zuwi  = ( wslpi(ji,jj,jk) + wslpi(ji-1,jj,jk) ) * e2u(ji-1,jj) * umask(ji-1,jj,jk) 
    … …  
    125133                  zvwj1 = ( wslpj(ji,jj,jk) + wslpj(ji,jj+1,jk) ) * e1v(ji  ,jj) * vmask(ji  ,jj,jk) 
    126134 
    127                   zw_eiv = - 0.5 * tmask(ji,jj,jk) * fsaeiw(ji,jj,jk) * ( zuwi1 - zuwi + zvwj1 - zvwj )  & 
    128                      &                                                / ( e1t(ji,jj)*e2t(ji,jj) ) 
     135                  zw_eiv(ji,jj) = - 0.5 * tmask(ji,jj,jk) * fsaeiw(ji,jj,jk) * ( zuwi1 - zuwi + zvwj1 - zvwj ) 
    129136# endif 
    130                   pwn(ji,jj,jk) = pwn(ji,jj,jk) + zw_eiv 
    131  
    132 # if defined key_diaeiv 
    133                   w_eiv(ji,jj,jk) = zw_eiv 
    134 # endif 
     137                  pwn(ji,jj,jk) = pwn(ji,jj,jk) + zw_eiv(ji,jj) 
    135138               END DO 
    136139            END DO 
     140# if defined key_diaeiv  
     141            IF( cdtype == 'TRA')  w_eiv(:,:,jk) = zw_eiv(:,:) / ( e1t(:,:) * e2t(:,:) ) 
     142# endif 
    137143         ENDIF 
    138144         !                                          ! ================= 
    … …  
    140146      !                                             ! ================= 
    141147 
    142 # if defined key_diaeiv 
    143       CALL iom_put( "uoce_eiv", u_eiv )    ! i-eiv current 
    144       CALL iom_put( "voce_eiv", v_eiv )    ! j-eiv current 
    145       CALL iom_put( "woce_eiv", w_eiv )    ! vert. eiv current 
    146       IF( lk_diaar5 ) THEN 
    147          zztmp = 0.5 * rau0 * rcp  
    148          z2d(:,:) = 0.e0  
    149          DO jk = 1, jpkm1 
    150             DO jj = 2, jpjm1 
    151                DO ji = fs_2, fs_jpim1   ! vector opt. 
    152                   z2d(ji,jj) = z2d(ji,jj) + zztmp * u_eiv(ji,jj,jk) * (tn(ji,jj,jk)+tn(ji+1,jj,jk)) * e1u(ji,jj) * fse3u(ji,jj,jk)  
     148# if defined key_diaeiv  
     149      IF( cdtype == 'TRA') THEN 
     150         CALL iom_put( "uoce_eiv", u_eiv )    ! i-eiv current 
     151         CALL iom_put( "voce_eiv", v_eiv )    ! j-eiv current 
     152         CALL iom_put( "woce_eiv", w_eiv )    ! vert. eiv current 
     153         IF( lk_diaar5 ) THEN 
     154            zztmp = 0.5 * rau0 * rcp  
     155            z2d(:,:) = 0.e0  
     156            DO jk = 1, jpkm1 
     157               DO jj = 2, jpjm1 
     158                  DO ji = fs_2, fs_jpim1   ! vector opt. 
     159                     z2d(ji,jj) = z2d(ji,jj) + zztmp * u_eiv(ji,jj,jk) & 
     160                       &         * (tsn(ji,jj,jk,jp_tem)+tsn(ji+1,jj,jk,jp_tem)) * e1u(ji,jj) * fse3u(ji,jj,jk)  
     161                  END DO 
    153162               END DO 
    154163            END DO 
    155          END DO 
    156          CALL lbc_lnk( z2d, 'U', -1. ) 
    157          CALL iom_put( "ueiv_heattr", z2d )                  ! heat transport in i-direction 
    158          z2d(:,:) = 0.e0  
    159          DO jk = 1, jpkm1 
    160             DO jj = 2, jpjm1 
    161                DO ji = fs_2, fs_jpim1   ! vector opt. 
    162                   z2d(ji,jj) = z2d(ji,jj) + zztmp * v_eiv(ji,jj,jk) * (tn(ji,jj,jk)+tn(ji,jj+1,jk)) * e2v(ji,jj) * fse3v(ji,jj,jk)  
     164            CALL lbc_lnk( z2d, 'U', -1. ) 
     165            CALL iom_put( "ueiv_heattr", z2d )                  ! heat transport in i-direction 
     166            z2d(:,:) = 0.e0  
     167            DO jk = 1, jpkm1 
     168               DO jj = 2, jpjm1 
     169                  DO ji = fs_2, fs_jpim1   ! vector opt. 
     170                     z2d(ji,jj) = z2d(ji,jj) + zztmp * v_eiv(ji,jj,jk) & 
     171                     &           * (tsn(ji,jj,jk,jp_tem)+tsn(ji,jj+1,jk,jp_tem)) * e2v(ji,jj) * fse3v(ji,jj,jk)  
     172                  END DO 
    163173               END DO 
    164174            END DO 
    165          END DO 
    166          CALL lbc_lnk( z2d, 'V', -1. ) 
    167          CALL iom_put( "veiv_heattr", z2d )                  !  heat transport in i-direction 
    168       ENDIF 
     175            CALL lbc_lnk( z2d, 'V', -1. ) 
     176            CALL iom_put( "veiv_heattr", z2d )                  !  heat transport in i-direction 
     177         ENDIF 
     178    END IF 
    169179# endif   
    170180      !  
    … …  
    176186   !!---------------------------------------------------------------------- 
    177187CONTAINS 
    178    SUBROUTINE tra_adv_eiv( kt, pun, pvn, pwn )              ! Empty routine 
     188   SUBROUTINE tra_adv_eiv( kt, pun, pvn, pwn, cdtype )              ! Empty routine 
     189      INTEGER , INTENT(in   )           ::   kt     ! ocean time-step index 
     190      CHARACTER(len=3), INTENT(in)      ::   cdtype          ! =TRA or TRC (tracer indicator) 
    179191      REAL, DIMENSION(:,:,:) ::   pun, pvn, pwn 
    180       WRITE(*,*) 'tra_adv_eiv: You should not have seen this print! error?', kt, pun(1,1,1), pvn(1,1,1), pwn(1,1,1) 
     192      WRITE(*,*) 'tra_adv_eiv: You should not have seen this print! error?', kt 
     193      WRITE(*,*) 'tra_adv_eiv: You should not have seen this print! error?', cdtype 
     194      WRITE(*,*) 'tra_adv_eiv: You should not have seen this print! error?', pun(1,1,1), pvn(1,1,1), pwn(1,1,1) 
    181195   END SUBROUTINE tra_adv_eiv 
    182196#endif 

  • branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/traadv_muscl.F90

    r1528 r2024  
    22   !!====================================================================== 
    33   !!                       ***  MODULE  traadv_muscl  *** 
    4    !! Ocean active tracers:  horizontal & vertical advective trend 
     4   !! Ocean tracers:  horizontal & vertical advective trend 
    55   !!====================================================================== 
    6    !! History :       !  06-00  (A.Estublier)  for passive tracers 
    7    !!                 !  01-08  (E.Durand, G.Madec)  adapted for T & S 
    8    !!            8.5  !  02-06  (G. Madec)  F90: Free form and module 
     6   !! History :       !  2000-06  (A.Estublier)  for passive tracers 
     7   !!                 !  2001-08  (E.Durand, G.Madec)  adapted for T & S 
     8   !!   NEMO     1.0  !  2002-06  (G. Madec)  F90: Free form and module 
     9   !!            3.2  !  2010-05  (C. Ethe, G. Madec)  merge TRC-TRA + switch from velocity to transport 
    910   !!---------------------------------------------------------------------- 
    1011 
    … …  
    1516   USE oce             ! ocean dynamics and active tracers 
    1617   USE dom_oce         ! ocean space and time domain 
    17    USE trdmod          ! ocean active tracers trends  
    18    USE trdmod_oce      ! ocean variables trends 
     18   USE trdmod_oce      ! tracers trends  
     19   USE trdtra      ! tracers trends  
    1920   USE in_out_manager  ! I/O manager 
    2021   USE dynspg_oce      ! choice/control of key cpp for surface pressure gradient 
    … …  
    2324   USE lbclnk          ! ocean lateral boundary condition (or mpp link)  
    2425   USE diaptr          ! poleward transport diagnostics 
    25    USE prtctl          ! Print control 
     26 
    2627 
    2728   IMPLICIT NONE 
    … …  
    2930 
    3031   PUBLIC   tra_adv_muscl  ! routine called by step.F90 
     32 
     33   LOGICAL  :: l_trd       ! flag to compute trends 
    3134 
    3235   !! * Substitutions 
    … …  
    4144CONTAINS 
    4245 
    43    SUBROUTINE tra_adv_muscl( kt, pun, pvn, pwn ) 
     46   SUBROUTINE tra_adv_muscl( kt   , cdtype, pun, pvn, pwn, & 
     47      &                      ptrab, ptraa , kjpt   ) 
    4448      !!---------------------------------------------------------------------- 
    4549      !!                    ***  ROUTINE tra_adv_muscl  *** 
    … …  
    5256      !! 
    5357      !! ** Action  : - update (ta,sa) with the now advective tracer trends 
    54       !!              - save trends in (ztrdt,ztrds) ('key_trdtra') 
     58      !!              - save trends  
    5559      !! 
    5660      !! References : Estubier, A., and M. Levy, Notes Techn. Pole de Modelisation 
    5761      !!              IPSL, Sept. 2000 (http://www.lodyc.jussieu.fr/opa) 
    5862      !!---------------------------------------------------------------------- 
    59       USE oce, ONLY :   ztrdt => ua   ! use ua as workspace 
    60       USE oce, ONLY :   ztrds => va   ! use va as workspace 
    61       !! 
    62       INTEGER , INTENT(in)                         ::   kt    ! ocean time-step index 
    63       REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) ::   pun   ! ocean velocity u-component 
    64       REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) ::   pvn   ! ocean velocity v-component 
    65       REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) ::   pwn   ! ocean velocity w-component 
    66       !! 
    67       INTEGER ::   ji, jj, jk   ! dummy loop indices 
    68       REAL(wp) ::   & 
    69          zu, zv, zw, zeu, zev,           &   
    70          zew, zbtr, zstep,               & 
    71          z0u, z0v, z0w,                  & 
    72          zzt1, zzt2, zalpha,             & 
    73          zzs1, zzs2, z2,                 & 
    74          zta, zsa,                       & 
    75         z_hdivn_x, z_hdivn_y, z_hdivn 
    76       REAL(wp), DIMENSION (jpi,jpj,jpk) ::   zt1, zt2, ztp1, ztp2   ! 3D workspace 
    77       REAL(wp), DIMENSION (jpi,jpj,jpk) ::   zs1, zs2, zsp1, zsp2   !  "      " 
     63      !!* Module used 
     64      USE oce         , zwx => ua   ! use ua as workspace 
     65      USE oce         , zwy => va   ! use va as workspace 
     66      !!* Arguments 
     67      INTEGER         , INTENT(in   )                               ::   kt              ! ocean time-step index 
     68      CHARACTER(len=3), INTENT(in   )                               ::   cdtype          ! =TRA or TRC (tracer indicator) 
     69      INTEGER         , INTENT(in   )                               ::   kjpt            ! number of tracers 
     70      REAL(wp)        , INTENT(in   ), DIMENSION(jpi,jpj,jpk)       ::   pun, pvn, pwn   ! 3 ocean velocity components 
     71      REAL(wp)        , INTENT(in   ), DIMENSION(jpi,jpj,jpk,kjpt)  ::   ptrab           ! before and now tracer fields 
     72      REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::   ptraa           ! tracer trend  
     73      !!* Local declarations 
     74      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
     75      REAL(wp) ::   zu, z0u, zzwx 
     76      REAL(wp) ::   zv, z0v, zzwy 
     77      REAL(wp) ::   zw, z0w 
     78      REAL(wp) ::   ztra, zbtr, z2, zdt, zalpha 
     79      REAL(wp), DIMENSION (jpi,jpj,jpk) :: zslpx, zslpy   ! 3D workspace 
    7880      !!---------------------------------------------------------------------- 
    7981 
    … …  
    8284         WRITE(numout,*) 'tra_adv : MUSCL advection scheme' 
    8385         WRITE(numout,*) '~~~~~~~' 
     86         ! 
     87         l_trd = .FALSE. 
     88         IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 
    8489      ENDIF 
    8590 
    … …  
    8792      ELSE                                        ;    z2 = 2. 
    8893      ENDIF 
    89  
    90       ! I. Horizontal advective fluxes 
    91       ! ------------------------------ 
    92       ! first guess of the slopes 
    93       ! interior values 
    94       DO jk = 1, jpkm1 
    95          DO jj = 1, jpjm1       
    96             DO ji = 1, fs_jpim1   ! vector opt. 
    97                zt1(ji,jj,jk) = umask(ji,jj,jk) * ( tb(ji+1,jj,jk) - tb(ji,jj,jk) ) 
    98                zs1(ji,jj,jk) = umask(ji,jj,jk) * ( sb(ji+1,jj,jk) - sb(ji,jj,jk) ) 
    99                zt2(ji,jj,jk) = vmask(ji,jj,jk) * ( tb(ji,jj+1,jk) - tb(ji,jj,jk) ) 
    100                zs2(ji,jj,jk) = vmask(ji,jj,jk) * ( sb(ji,jj+1,jk) - sb(ji,jj,jk) ) 
    101             END DO 
    102          END DO 
    103       END DO 
    104       ! bottom values 
    105       zt1(:,:,jpk) = 0.e0    ;    zt2(:,:,jpk) = 0.e0 
    106       zs1(:,:,jpk) = 0.e0    ;    zs2(:,:,jpk) = 0.e0 
    107  
    108       ! lateral boundary conditions on zt1, zt2 ; zs1, zs2   (changed sign) 
    109       CALL lbc_lnk( zt1, 'U', -1. )   ;   CALL lbc_lnk( zs1, 'U', -1. ) 
    110       CALL lbc_lnk( zt2, 'V', -1. )   ;   CALL lbc_lnk( zs2, 'V', -1. ) 
    111  
    112       ! Slopes 
    113       ! interior values 
    114       DO jk = 1, jpkm1 
    115          DO jj = 2, jpj 
    116             DO ji = fs_2, jpi   ! vector opt. 
    117                ztp1(ji,jj,jk) =                    ( zt1(ji,jj,jk) + zt1(ji-1,jj  ,jk) )   & 
    118                   &           * ( 0.25 + SIGN( 0.25, zt1(ji,jj,jk) * zt1(ji-1,jj  ,jk) ) ) 
    119                zsp1(ji,jj,jk) =                    ( zs1(ji,jj,jk) + zs1(ji-1,jj  ,jk) )   & 
    120                   &           * ( 0.25 + SIGN( 0.25, zs1(ji,jj,jk) * zs1(ji-1,jj  ,jk) ) ) 
    121                ztp2(ji,jj,jk) =                    ( zt2(ji,jj,jk) + zt2(ji  ,jj-1,jk) )   & 
    122                   &           * ( 0.25 + SIGN( 0.25, zt2(ji,jj,jk) * zt2(ji  ,jj-1,jk) ) ) 
    123                zsp2(ji,jj,jk) =                    ( zs2(ji,jj,jk) + zs2(ji  ,jj-1,jk) )   & 
    124                   &           * ( 0.25 + SIGN( 0.25, zs2(ji,jj,jk) * zs2(ji  ,jj-1,jk) ) ) 
    125             END DO 
    126          END DO 
    127       END DO 
    128       ! bottom values 
    129       ztp1(:,:,jpk) = 0.e0    ;    ztp2(:,:,jpk) = 0.e0 
    130       zsp1(:,:,jpk) = 0.e0    ;    zsp2(:,:,jpk) = 0.e0 
    131  
    132       ! Slopes limitation 
    133       DO jk = 1, jpkm1 
    134          DO jj = 2, jpj 
    135             DO ji = fs_2, jpi   ! vector opt. 
    136                ztp1(ji,jj,jk) = SIGN( 1., ztp1(ji,jj,jk) )   & 
    137                   &           * MIN(    ABS( ztp1(ji  ,jj,jk) ),   & 
    138                   &                  2.*ABS( zt1 (ji-1,jj,jk) ),   & 
    139                   &                  2.*ABS( zt1 (ji  ,jj,jk) ) ) 
    140                zsp1(ji,jj,jk) = SIGN( 1., zsp1(ji,jj,jk) )   & 
    141                   &           * MIN(    ABS( zsp1(ji  ,jj,jk) ),   & 
    142                   &                  2.*ABS( zs1 (ji-1,jj,jk) ),   & 
    143                   &                  2.*ABS( zs1 (ji  ,jj,jk) ) ) 
    144                ztp2(ji,jj,jk) = SIGN( 1., ztp2(ji,jj,jk) )   & 
    145                   &           * MIN(    ABS( ztp2(ji,jj  ,jk) ),   & 
    146                   &                  2.*ABS( zt2 (ji,jj-1,jk) ),   & 
    147                   &                  2.*ABS( zt2 (ji,jj  ,jk) ) ) 
    148                zsp2(ji,jj,jk) = SIGN( 1., zsp2(ji,jj,jk) )   & 
    149                   &           * MIN(    ABS( zsp2(ji,jj  ,jk) ),   & 
    150                   &                  2.*ABS( zs2 (ji,jj-1,jk) ),   & 
    151                   &                  2.*ABS( zs2 (ji,jj  ,jk) ) ) 
    152             END DO 
    153          END DO 
    154       END DO         
    155  
    156       ! Advection terms 
    157       ! interior values 
    158       DO jk = 1, jpkm1 
    159          zstep  = z2 * rdttra(jk) 
    160          DO jj = 2, jpjm1       
    161             DO ji = fs_2, fs_jpim1   ! vector opt. 
    162                ! volume fluxes 
    163 #if defined key_zco 
    164                zeu = e2u(ji,jj)                   * pun(ji,jj,jk) 
    165                zev = e1v(ji,jj)                   * pvn(ji,jj,jk) 
    166 #else 
    167                zeu = e2u(ji,jj) * fse3u(ji,jj,jk) * pun(ji,jj,jk) 
    168                zev = e1v(ji,jj) * fse3v(ji,jj,jk) * pvn(ji,jj,jk) 
    169 #endif 
    170                ! MUSCL fluxes 
    171                z0u = SIGN( 0.5, pun(ji,jj,jk) )             
    172                zalpha = 0.5 - z0u 
    173                zu  = z0u - 0.5 * pun(ji,jj,jk) * zstep / e1u(ji,jj) 
    174                zzt1 = tb(ji+1,jj,jk) + zu*ztp1(ji+1,jj,jk) 
    175                zzt2 = tb(ji  ,jj,jk) + zu*ztp1(ji  ,jj,jk) 
    176                zzs1 = sb(ji+1,jj,jk) + zu*zsp1(ji+1,jj,jk) 
    177                zzs2 = sb(ji  ,jj,jk) + zu*zsp1(ji  ,jj,jk) 
    178                zt1(ji,jj,jk) = zeu * ( zalpha * zzt1 + (1.-zalpha) * zzt2 ) 
    179                zs1(ji,jj,jk) = zeu * ( zalpha * zzs1 + (1.-zalpha) * zzs2 ) 
    180                ! 
    181                z0v = SIGN( 0.5, pvn(ji,jj,jk) )             
    182                zalpha = 0.5 - z0v 
    183                zv  = z0v - 0.5 * pvn(ji,jj,jk) * zstep / e2v(ji,jj) 
    184                zzt1 = tb(ji,jj+1,jk) + zv*ztp2(ji,jj+1,jk) 
    185                zzt2 = tb(ji,jj  ,jk) + zv*ztp2(ji,jj  ,jk) 
    186                zzs1 = sb(ji,jj+1,jk) + zv*zsp2(ji,jj+1,jk) 
    187                zzs2 = sb(ji,jj  ,jk) + zv*zsp2(ji,jj  ,jk) 
    188                zt2(ji,jj,jk) = zev * ( zalpha * zzt1 + (1.-zalpha) * zzt2 ) 
    189                zs2(ji,jj,jk) = zev * ( zalpha * zzs1 + (1.-zalpha) * zzs2 ) 
    190             END DO 
    191          END DO 
    192       END DO 
    193  
    194       ! lateral boundary conditions on zt1, zt2 ; zs1, zs2   (changed sign) 
    195       CALL lbc_lnk( zt1, 'U', -1. )   ;   CALL lbc_lnk( zs1, 'U', -1. )  
    196       CALL lbc_lnk( zt2, 'V', -1. )   ;   CALL lbc_lnk( zs2, 'V', -1. ) 
    197  
    198       ! Tracer flux divergence at t-point added to the general trend 
    199       DO jk = 1, jpkm1 
    200          DO jj = 2, jpjm1       
    201             DO ji = fs_2, fs_jpim1   ! vector opt. 
    202 #if defined key_zco 
    203                zbtr = 1. / ( e1t(ji,jj)*e2t(ji,jj) ) 
    204 #else 
    205                zbtr = 1. / ( e1t(ji,jj)*e2t(ji,jj)*fse3t(ji,jj,jk) ) 
    206 #endif 
    207                ! horizontal advective trends 
    208                zta = - zbtr * ( zt1(ji,jj,jk) - zt1(ji-1,jj  ,jk  )   & 
    209                   &           + zt2(ji,jj,jk) - zt2(ji  ,jj-1,jk  ) ) 
    210                zsa = - zbtr * ( zs1(ji,jj,jk) - zs1(ji-1,jj  ,jk  )   & 
    211                   &           + zs2(ji,jj,jk) - zs2(ji  ,jj-1,jk  ) )  
    212                ! add it to the general tracer trends 
    213                ta(ji,jj,jk) = ta(ji,jj,jk) + zta 
    214                sa(ji,jj,jk) = sa(ji,jj,jk) + zsa 
    215             END DO 
    216         END DO 
    217       END DO         
    218  
    219       IF(ln_ctl)   CALL prt_ctl( tab3d_1=ta, clinfo1=' muscl had  - Ta: ', mask1=tmask ,  & 
    220          &                       tab3d_2=sa, clinfo2=             ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    221  
    222       ! Save the horizontal advective trends for diagnostics 
    223       IF( l_trdtra ) THEN 
    224          ztrdt(:,:,:) = 0.e0   ;   ztrds(:,:,:) = 0.e0 
    225          ! 
    226          ! T/S ZONAL advection trends 
     94      ! 
     95      !                                                     ! =========== 
     96      DO jn = 1, kjpt                                       ! tracer loop 
     97         !                                                  ! =========== 
     98         ! I. Horizontal advective fluxes 
     99         ! ------------------------------ 
     100         ! first guess of the slopes 
     101         zwx(:,:,jpk) = 0.e0   ;   zwy(:,:,jpk) = 0.e0        ! bottom values 
     102         ! interior values 
    227103         DO jk = 1, jpkm1 
     104            DO jj = 1, jpjm1       
     105               DO ji = 1, fs_jpim1   ! vector opt. 
     106                  zwx(ji,jj,jk) = umask(ji,jj,jk) * ( ptrab(ji+1,jj,jk,jn) - ptrab(ji,jj,jk,jn) ) 
     107                  zwy(ji,jj,jk) = vmask(ji,jj,jk) * ( ptrab(ji,jj+1,jk,jn) - ptrab(ji,jj,jk,jn) ) 
     108               END DO 
     109           END DO 
     110         END DO 
     111         ! 
     112         CALL lbc_lnk( zwx, 'U', -1. )                        ! lateral boundary conditions on zwx, zwy   (changed sign) 
     113         CALL lbc_lnk( zwy, 'V', -1. ) 
     114         !                                             !-- Slopes of tracer 
     115         zslpx(:,:,jpk) = 0.e0   ;   zslpy(:,:,jpk) = 0.e0    ! bottom values 
     116         DO jk = 1, jpkm1                                     ! interior values 
     117            DO jj = 2, jpj 
     118               DO ji = fs_2, jpi   ! vector opt. 
     119                  zslpx(ji,jj,jk) =                    ( zwx(ji,jj,jk) + zwx(ji-1,jj  ,jk) )   & 
     120                     &            * ( 0.25 + SIGN( 0.25, zwx(ji,jj,jk) * zwx(ji-1,jj  ,jk) ) ) 
     121                  zslpy(ji,jj,jk) =                    ( zwy(ji,jj,jk) + zwy(ji  ,jj-1,jk) )   & 
     122                     &            * ( 0.25 + SIGN( 0.25, zwy(ji,jj,jk) * zwy(ji  ,jj-1,jk) ) ) 
     123               END DO 
     124            END DO 
     125         END DO 
     126         ! 
     127         DO jk = 1, jpkm1                                     ! Slopes limitation 
     128            DO jj = 2, jpj 
     129               DO ji = fs_2, jpi   ! vector opt. 
     130                  zslpx(ji,jj,jk) = SIGN( 1., zslpx(ji,jj,jk) ) * MIN(    ABS( zslpx(ji  ,jj,jk) ),   & 
     131                     &                                                 2.*ABS( zwx  (ji-1,jj,jk) ),   & 
     132                     &                                                 2.*ABS( zwx  (ji  ,jj,jk) ) ) 
     133                  zslpy(ji,jj,jk) = SIGN( 1., zslpy(ji,jj,jk) ) * MIN(    ABS( zslpy(ji,jj  ,jk) ),   & 
     134                     &                                                 2.*ABS( zwy  (ji,jj-1,jk) ),   & 
     135                     &                                                 2.*ABS( zwy  (ji,jj  ,jk) ) ) 
     136               END DO 
     137           END DO 
     138         END DO             ! interior values 
     139 
     140         !                                             !-- MUSCL horizontal advective fluxes 
     141         DO jk = 1, jpkm1                                     ! interior values 
     142            zdt  = z2 * rdttra(jk) 
    228143            DO jj = 2, jpjm1 
    229144               DO ji = fs_2, fs_jpim1   ! vector opt. 
    230                   !-- Compute zonal divergence by splitting hdivn (see divcur.F90) 
    231                   !   N.B. This computation is not valid along OBCs (if any) 
    232 #if defined key_zco 
    233                   zbtr      = 1. / ( e1t(ji,jj) * e2t(ji,jj) ) 
    234                   z_hdivn_x = (  e2u(ji  ,jj) * pun(ji  ,jj,jk)                              & 
    235                      &         - e2u(ji-1,jj) * pun(ji-1,jj,jk) ) * zbtr 
    236 #else 
    237                   zbtr      = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    238                   z_hdivn_x = (  e2u(ji  ,jj) * fse3u(ji  ,jj,jk) * pun(ji  ,jj,jk)          & 
    239                      &         - e2u(ji-1,jj) * fse3u(ji-1,jj,jk) * pun(ji-1,jj,jk) ) * zbtr 
    240 #endif 
    241                   ztrdt(ji,jj,jk) = - zbtr * ( zt1(ji,jj,jk) - zt1(ji-1,jj,jk) ) + tn(ji,jj,jk) * z_hdivn_x 
    242                   ztrds(ji,jj,jk) = - zbtr * ( zs1(ji,jj,jk) - zs1(ji-1,jj,jk) ) + sn(ji,jj,jk) * z_hdivn_x 
    243                END DO 
    244             END DO 
    245          END DO 
    246          CALL trd_mod(ztrdt, ztrds, jptra_trd_xad, 'TRA', kt) 
    247  
    248          ! T/S MERIDIONAL advection trends 
     145                  ! MUSCL fluxes 
     146                  z0u = SIGN( 0.5, pun(ji,jj,jk) ) 
     147                  zalpha = 0.5 - z0u 
     148                  zu  = z0u - 0.5 * pun(ji,jj,jk) * zdt / ( e1u(ji,jj) * e2u(ji,jj) * fse3u(ji,jj,jk) ) 
     149                  zzwx = ptrab(ji+1,jj,jk,jn) + zu * zslpx(ji+1,jj,jk) 
     150                  zzwy = ptrab(ji  ,jj,jk,jn) + zu * zslpx(ji  ,jj,jk) 
     151                  zwx(ji,jj,jk) = pun(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 
     152                  ! 
     153                  z0v = SIGN( 0.5, pvn(ji,jj,jk) ) 
     154                  zalpha = 0.5 - z0v 
     155                  zv  = z0v - 0.5 * pvn(ji,jj,jk) * zdt / ( e1v(ji,jj) * e2v(ji,jj) * fse3v(ji,jj,jk) ) 
     156                  zzwx = ptrab(ji,jj+1,jk,jn) + zv * zslpy(ji,jj+1,jk) 
     157                  zzwy = ptrab(ji,jj  ,jk,jn) + zv * zslpy(ji,jj  ,jk)  
     158                  zwy(ji,jj,jk) = pvn(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 
     159               END DO 
     160            END DO 
     161         END DO 
     162         !                                                    ! lateral boundary conditions on zwx, zwy   (changed sign) 
     163         CALL lbc_lnk( zwx, 'U', -1. )   ;   CALL lbc_lnk( zwy, 'V', -1. ) 
     164         ! 
     165         ! Tracer flux divergence at t-point added to the general trend 
    249166         DO jk = 1, jpkm1 
    250             DO jj = 2, jpjm1 
    251                DO ji = fs_2, fs_jpim1   ! vector opt. 
    252                   !-- Compute merid. divergence by splitting hdivn (see divcur.F90) 
    253                   !   N.B. This computation is not valid along OBCs (if any) 
    254 #if defined key_zco 
    255                   zbtr      = 1. / ( e1t(ji,jj) * e2t(ji,jj) ) 
    256                   z_hdivn_y = (  e1v(ji,jj  ) * pvn(ji,jj  ,jk)                              & 
    257                      &         - e1v(ji,jj-1) * pvn(ji,jj-1,jk) ) * zbtr 
    258 #else 
    259                   zbtr      = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    260                   z_hdivn_y = (  e1v(ji,  jj) * fse3v(ji,jj  ,jk) * pvn(ji,jj  ,jk)          & 
    261                      &         - e1v(ji,jj-1) * fse3v(ji,jj-1,jk) * pvn(ji,jj-1,jk) ) * zbtr 
    262 #endif 
    263                   ztrdt(ji,jj,jk) = - zbtr * ( zt2(ji,jj,jk) - zt2(ji,jj-1,jk) ) + tn(ji,jj,jk) * z_hdivn_y           
    264                   ztrds(ji,jj,jk) = - zbtr * ( zs2(ji,jj,jk) - zs2(ji,jj-1,jk) ) + sn(ji,jj,jk) * z_hdivn_y 
    265                END DO 
    266             END DO 
    267          END DO 
    268          CALL trd_mod(ztrdt, ztrds, jptra_trd_yad, 'TRA', kt) 
    269  
    270          ! Save the up-to-date ta and sa trends 
    271          ztrdt(:,:,:) = ta(:,:,:)  
    272          ztrds(:,:,:) = sa(:,:,:)  
    273          ! 
    274       ENDIF 
    275  
    276       ! "zonal" mean advective heat and salt transport 
    277       IF( ln_diaptr .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN 
    278          IF( lk_zco ) THEN 
    279             DO jk = 1, jpkm1 
    280                DO jj = 2, jpjm1 
    281                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    282                     zt2(ji,jj,jk) = zt2(ji,jj,jk) * fse3v(ji,jj,jk) 
    283                     zs2(ji,jj,jk) = zs2(ji,jj,jk) * fse3v(ji,jj,jk) 
     167            DO jj = 2, jpjm1       
     168               DO ji = fs_2, fs_jpim1   ! vector opt. 
     169                  zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
     170                  ! horizontal advective trends 
     171                  ztra = - zbtr * ( zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
     172                  &               + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  ) ) 
     173                  ! add it to the general tracer trends 
     174                  ptraa(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn) + ztra 
     175               END DO 
     176           END DO 
     177         END DO         
     178         !                                 ! trend diagnostics (contribution of upstream fluxes) 
     179         IF( l_trd )  THEN 
     180            CALL trd_tra( kt, cdtype, jn, jptra_trd_xad, zwx, pun, ptrab(:,:,:,jn) ) 
     181            CALL trd_tra( kt, cdtype, jn, jptra_trd_yad, zwy, pvn, ptrab(:,:,:,jn) ) 
     182         END IF 
     183         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
     184         IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN   
     185            IF( lk_zco ) THEN 
     186               DO jk = 1, jpkm1 
     187                  DO jj = 2, jpjm1 
     188                     DO ji = fs_2, fs_jpim1   ! vector opt. 
     189                       zwy(ji,jj,jk) = zwy(ji,jj,jk) * fse3v(ji,jj,jk)                  
     190                     END DO 
    284191                  END DO 
    285192               END DO 
    286             END DO 
     193            ENDIF 
     194            IF( jn == jp_tem )  pht_adv(:) = ptr_vj( zwy(:,:,:) ) 
     195            IF( jn == jp_sal )  pst_adv(:) = ptr_vj( zwy(:,:,:) ) 
    287196         ENDIF 
    288          pht_adv(:) = ptr_vj( zt2(:,:,:) ) 
    289          pst_adv(:) = ptr_vj( zs2(:,:,:) ) 
    290       ENDIF 
    291  
    292       ! II. Vertical advective fluxes 
    293       ! ----------------------------- 
    294        
    295       ! First guess of the slope 
    296       ! interior values 
    297       DO jk = 2, jpkm1 
    298          zt1(:,:,jk) = tmask(:,:,jk) * ( tb(:,:,jk-1) - tb(:,:,jk) ) 
    299          zs1(:,:,jk) = tmask(:,:,jk) * ( sb(:,:,jk-1) - sb(:,:,jk) ) 
    300       END DO 
    301       ! surface & bottom boundary conditions 
    302       zt1 (:,:, 1 ) = 0.e0    ;    zt1 (:,:,jpk) = 0.e0 
    303       zs1 (:,:, 1 ) = 0.e0    ;    zs1 (:,:,jpk) = 0.e0 
    304  
    305       ! Slopes 
    306       DO jk = 2, jpkm1 
    307          DO jj = 1, jpj 
    308             DO ji = 1, jpi 
    309                ztp1(ji,jj,jk) =                    ( zt1(ji,jj,jk) + zt1(ji,jj,jk+1) )   & 
    310                   &           * ( 0.25 + SIGN( 0.25, zt1(ji,jj,jk) * zt1(ji,jj,jk+1) ) ) 
    311                zsp1(ji,jj,jk) =                    ( zs1(ji,jj,jk) + zs1(ji,jj,jk+1) )   & 
    312                   &           * ( 0.25 + SIGN( 0.25, zs1(ji,jj,jk) * zs1(ji,jj,jk+1) ) ) 
    313             END DO 
    314          END DO 
    315       END DO 
    316  
    317       ! Slopes limitation 
    318       ! interior values 
    319       DO jk = 2, jpkm1 
    320          DO jj = 1, jpj 
    321             DO ji = 1, jpi 
    322                ztp1(ji,jj,jk) = SIGN( 1., ztp1(ji,jj,jk) )   & 
    323                   &           * MIN(    ABS( ztp1(ji,jj,jk  ) ),   & 
    324                   &                  2.*ABS( zt1 (ji,jj,jk+1) ),   & 
    325                   &                  2.*ABS( zt1 (ji,jj,jk  ) ) ) 
    326                zsp1(ji,jj,jk) = SIGN( 1., zsp1(ji,jj,jk) )   & 
    327                   &           * MIN(    ABS( zsp1(ji,jj,jk  ) ),   & 
    328                   &                  2.*ABS( zs1 (ji,jj,jk+1) ),   & 
    329                   &                  2.*ABS( zs1 (ji,jj,jk  ) ) ) 
    330             END DO 
    331          END DO 
    332       END DO 
    333       ! surface values 
    334       ztp1(:,:,1) = 0.e0 
    335       zsp1(:,:,1) = 0.e0 
    336  
    337       ! vertical advective flux 
    338       ! interior values 
    339       DO jk = 1, jpkm1 
    340          zstep  = z2 * rdttra(jk) 
    341          DO jj = 2, jpjm1       
    342             DO ji = fs_2, fs_jpim1   ! vector opt. 
    343                zew = pwn(ji,jj,jk+1) 
    344                z0w = SIGN( 0.5, pwn(ji,jj,jk+1) ) 
    345                zalpha = 0.5 + z0w 
    346                zw  = z0w - 0.5 * pwn(ji,jj,jk+1)*zstep / fse3w(ji,jj,jk+1) 
    347                zzt1 = tb(ji,jj,jk+1) + zw*ztp1(ji,jj,jk+1) 
    348                zzt2 = tb(ji,jj,jk  ) + zw*ztp1(ji,jj,jk  ) 
    349                zzs1 = sb(ji,jj,jk+1) + zw*zsp1(ji,jj,jk+1) 
    350                zzs2 = sb(ji,jj,jk  ) + zw*zsp1(ji,jj,jk  ) 
    351                zt1(ji,jj,jk+1) = zew * ( zalpha * zzt1 + (1.-zalpha)*zzt2 ) 
    352                zs1(ji,jj,jk+1) = zew * ( zalpha * zzs1 + (1.-zalpha)*zzs2 ) 
    353             END DO 
    354          END DO 
    355       END DO 
    356       ! surface values 
    357       IF( lk_vvl ) THEN 
    358          ! variable volume : flux set to zero 
    359          zt1(:,:, 1 ) = 0.e0 
    360          zs1(:,:, 1 ) = 0.e0 
    361       ELSE 
    362          ! free surface-constant volume 
    363          zt1(:,:, 1 ) = pwn(:,:,1) * tb(:,:,1) 
    364          zs1(:,:, 1 ) = pwn(:,:,1) * sb(:,:,1) 
    365       ENDIF 
    366  
    367       ! bottom values 
    368       zt1(:,:,jpk) = 0.e0 
    369       zs1(:,:,jpk) = 0.e0 
    370  
    371  
    372       ! Compute & add the vertical advective trend 
    373  
    374       DO jk = 1, jpkm1 
    375          DO jj = 2, jpjm1       
    376             DO ji = fs_2, fs_jpim1   ! vector opt. 
    377                zbtr = 1. / fse3t(ji,jj,jk) 
    378                ! horizontal advective trends 
    379                zta = - zbtr * ( zt1(ji,jj,jk) - zt1(ji,jj,jk+1) ) 
    380                zsa = - zbtr * ( zs1(ji,jj,jk) - zs1(ji,jj,jk+1) ) 
    381                ! add it to the general tracer trends 
    382                ta(ji,jj,jk) =  ta(ji,jj,jk) + zta 
    383                sa(ji,jj,jk) =  sa(ji,jj,jk) + zsa 
    384             END DO 
    385          END DO 
    386       END DO 
    387  
    388       ! Save the vertical advective trends for diagnostic 
    389       ! ------------------------------------------------- 
    390       IF( l_trdtra )   THEN 
    391          ! Recompute the vertical advection zta & zsa trends computed  
    392          ! at the step 2. above in making the difference between the new  
    393          ! trends and the previous one: ta()/sa - ztrdt()/ztrds() and substract 
    394          ! the term tn()/sn()*hdivn() to recover the W gradz(T/S) trends 
    395  
     197 
     198         ! II. Vertical advective fluxes 
     199         ! ----------------------------- 
     200         !                                             !-- first guess of the slopes 
     201         zwx (:,:, 1 ) = 0.e0    ;    zwx (:,:,jpk) = 0.e0    ! surface & bottom boundary conditions 
     202         DO jk = 2, jpkm1                                     ! interior values 
     203            zwx(:,:,jk) = tmask(:,:,jk) * ( ptrab(:,:,jk-1,jn) - ptrab(:,:,jk,jn) ) 
     204         END DO 
     205 
     206         !                                             !-- Slopes of tracer 
     207         zslpx(:,:,1) = 0.e0                                  ! surface values 
     208         DO jk = 2, jpkm1                                     ! interior value 
     209            DO jj = 1, jpj 
     210               DO ji = 1, jpi 
     211                  zslpx(ji,jj,jk) =                    ( zwx(ji,jj,jk) + zwx(ji,jj,jk+1) )   & 
     212                     &            * ( 0.25 + SIGN( 0.25, zwx(ji,jj,jk) * zwx(ji,jj,jk+1) ) ) 
     213               END DO 
     214            END DO 
     215         END DO 
     216         !                                             !-- Slopes limitation 
     217         DO jk = 2, jpkm1                                     ! interior values 
     218            DO jj = 1, jpj 
     219               DO ji = 1, jpi 
     220                  zslpx(ji,jj,jk) = SIGN( 1., zslpx(ji,jj,jk) ) * MIN(    ABS( zslpx(ji,jj,jk  ) ),   & 
     221                     &                                                 2.*ABS( zwx  (ji,jj,jk+1) ),   & 
     222                     &                                                 2.*ABS( zwx  (ji,jj,jk  ) )  ) 
     223               END DO 
     224            END DO 
     225         END DO 
     226         !                                             !-- vertical advective flux 
     227         !                                                    ! surface values  (bottom already set to zero) 
     228         IF( lk_vvl ) THEN    ;   zwx(:,:, 1 ) = 0.e0                      !  variable volume 
     229         ELSE                 ;   zwx(:,:, 1 ) = pwn(:,:,1) * ptrab(:,:,1,jn)   ! linear free surface 
     230         ENDIF  
     231         ! 
     232         DO jk = 1, jpkm1                                     ! interior values 
     233            zdt  = z2 * rdttra(jk) 
     234            DO jj = 2, jpjm1       
     235               DO ji = fs_2, fs_jpim1   ! vector opt. 
     236                  zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3w(ji,jj,jk+1) ) 
     237                  z0w = SIGN( 0.5, pwn(ji,jj,jk+1) ) 
     238                  zalpha = 0.5 + z0w 
     239                  zw  = z0w - 0.5 * pwn(ji,jj,jk+1) * zdt * zbtr  
     240                  zzwx = ptrab(ji,jj,jk+1,jn) + zw * zslpx(ji,jj,jk+1) 
     241                  zzwy = ptrab(ji,jj,jk  ,jn) + zw * zslpx(ji,jj,jk  ) 
     242                  zwx(ji,jj,jk+1) = pwn(ji,jj,jk+1) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 
     243               END DO  
     244            END DO 
     245         END DO 
     246 
     247         ! Compute & add the vertical advective trend 
    396248         DO jk = 1, jpkm1 
    397             DO jj = 2, jpjm1 
    398                DO ji = fs_2, fs_jpim1   ! vector opt. 
    399 #if defined key_zco 
    400                   zbtr      = 1. / ( e1t(ji,jj) * e2t(ji,jj) ) 
    401                   z_hdivn_x = e2u(ji,jj)*pun(ji,jj,jk) - e2u(ji-1,jj)*pun(ji-1,jj,jk) 
    402                   z_hdivn_y = e1v(ji,jj)*pvn(ji,jj,jk) - e1v(ji,jj-1)*pvn(ji,jj-1,jk) 
    403 #else 
    404                   zbtr      = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    405                   z_hdivn_x = e2u(ji,jj)*fse3u(ji,jj,jk)*pun(ji,jj,jk) - e2u(ji-1,jj)*fse3u(ji-1,jj,jk)*pun(ji-1,jj,jk) 
    406                   z_hdivn_y = e1v(ji,jj)*fse3v(ji,jj,jk)*pvn(ji,jj,jk) - e1v(ji,jj-1)*fse3v(ji,jj-1,jk)*pvn(ji,jj-1,jk) 
    407 #endif 
    408                   z_hdivn   = (z_hdivn_x + z_hdivn_y) * zbtr 
    409                   ztrdt(ji,jj,jk) = ta(ji,jj,jk) - ztrdt(ji,jj,jk) - tn(ji,jj,jk) * z_hdivn  
    410                   ztrds(ji,jj,jk) = sa(ji,jj,jk) - ztrds(ji,jj,jk) - sn(ji,jj,jk) * z_hdivn 
    411                END DO 
    412             END DO 
    413          END DO 
    414          CALL trd_mod(ztrdt, ztrds, jptra_trd_zad, 'TRA', kt) 
    415          ! 
    416       ENDIF 
    417  
    418       IF(ln_ctl)   CALL prt_ctl( tab3d_1=ta, clinfo1=' muscl zad  - Ta: ', mask1=tmask ,   & 
    419          &                       tab3d_2=sa, clinfo2=             ' Sa: ', mask2=tmask, clinfo3='tra' ) 
     249            DO jj = 2, jpjm1       
     250               DO ji = fs_2, fs_jpim1   ! vector opt. 
     251                  zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
     252                  ! vertical advective trends  
     253                  ztra = - zbtr * ( zwx(ji,jj,jk) - zwx(ji,jj,jk+1) ) 
     254                  ! add it to the general tracer trends 
     255                  ptraa(ji,jj,jk,jn) =  ptraa(ji,jj,jk,jn) + ztra 
     256               END DO 
     257            END DO 
     258         END DO 
     259         !                                 ! Save the vertical advective trends for diagnostic 
     260         IF( l_trd ) CALL trd_tra( kt, cdtype, jn, jptra_trd_zad, zwx, pwn, ptrab(:,:,:,jn) ) 
     261         ! 
     262      ENDDO 
    420263      ! 
    421264   END SUBROUTINE tra_adv_muscl 

  • branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/traadv_muscl2.F90

    r1528 r2024  
    22   !!============================================================================== 
    33   !!                       ***  MODULE  traadv_muscl2  *** 
    4    !! Ocean active tracers:  horizontal & vertical advective trend 
     4   !! Ocean tracers:  horizontal & vertical advective trend 
    55   !!============================================================================== 
    6    !! History :  9.0  !  02-06  (G. Madec) from traadv_muscl 
     6   !! History :  1.0  !  2002-06  (G. Madec) from traadv_muscl 
     7   !!            3.2  !  2010-05  (C. Ethe, G. Madec)  merge TRC-TRA + switch from velocity to transport 
    78   !!---------------------------------------------------------------------- 
    89 
    … …  
    1314   USE oce             ! ocean dynamics and active tracers 
    1415   USE dom_oce         ! ocean space and time domain 
    15    USE trdmod          ! ocean active tracers trends  
    16    USE trdmod_oce      ! ocean variables trends 
     16   USE trdmod_oce      ! tracers trends  
     17   USE trdtra          ! tracers trends  
    1718   USE in_out_manager  ! I/O manager 
    1819   USE dynspg_oce      ! choice/control of key cpp for surface pressure gradient 
    1920   USE trabbl          ! tracers: bottom boundary layer 
    20    USE lib_mpp 
     21   USE lib_mpp         ! distribued memory computing 
    2122   USE lbclnk          ! ocean lateral boundary condition (or mpp link)  
    2223   USE diaptr          ! poleward transport diagnostics 
    23    USE prtctl          ! Print control 
     24 
    2425 
    2526   IMPLICIT NONE 
    … …  
    2829   !! * Accessibility 
    2930   PUBLIC tra_adv_muscl2        ! routine called by step.F90 
     31 
     32   LOGICAL  :: l_trd       ! flag to compute trends 
    3033 
    3134   !! * Substitutions 
    … …  
    4043CONTAINS 
    4144 
    42    SUBROUTINE tra_adv_muscl2( kt, pun, pvn, pwn ) 
     45   SUBROUTINE tra_adv_muscl2( kt   , cdtype, pun  , pvn, pwn, & 
     46      &                       ptrab, ptran , ptraa, kjpt   ) 
    4347      !!---------------------------------------------------------------------- 
    4448      !!                   ***  ROUTINE tra_adv_muscl2  *** 
    … …  
    5054      !! ** Method  : MUSCL scheme plus centered scheme at ocean boundaries 
    5155      !! 
    52       !! ** Action  : - update (ta,sa) with the now advective tracer trends 
    53       !!              - save trends in (ztrdt,ztrds) ('key_trdtra') 
     56      !! ** Action  : - update (ptraa) with the now advective tracer trends 
     57      !!              - save trends  
    5458      !! 
    5559      !! References : Estubier, A., and M. Levy, Notes Techn. Pole de Modelisation 
    5660      !!              IPSL, Sept. 2000 (http://www.lodyc.jussieu.fr/opa) 
    5761      !!---------------------------------------------------------------------- 
    58       USE oce              , ztrdt => ua   ! use ua as workspace 
    59       USE oce              , ztrds => va   ! use va as workspace 
    60       !! 
    61       INTEGER , INTENT(in)                         ::   kt    ! ocean time-step index 
    62       REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) ::   pun   ! ocean velocity u-component 
    63       REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) ::   pvn   ! ocean velocity v-component 
    64       REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) ::   pwn   ! ocean velocity w-component 
    65       !! 
    66       INTEGER ::   ji, jj, jk   ! dummy loop indices 
    67       REAL(wp) ::   & 
    68          zu, zv, zw, zeu, zev,           &   
    69          zew, zbtr, zstep,               & 
    70          z0u, z0v, z0w,                  & 
    71          zzt1, zzt2, zalpha,             & 
    72          zzs1, zzs2, z2,                 & 
    73          zta, zsa,                       & 
    74          z_hdivn_x, z_hdivn_y, z_hdivn 
    75       REAL(wp), DIMENSION (jpi,jpj,jpk) ::   zt1, zt2, ztp1, ztp2   ! 3D workspace 
    76       REAL(wp), DIMENSION (jpi,jpj,jpk) ::   zs1, zs2, zsp1, zsp2   !  "      " 
     62      !!* Module used 
     63      USE oce         , zwx => ua   ! use ua as workspace 
     64      USE oce         , zwy => va   ! use va as workspace 
     65      !!* Arguments 
     66      INTEGER         , INTENT(in   )                               ::   kt              ! ocean time-step index 
     67      CHARACTER(len=3), INTENT(in   )                               ::   cdtype          ! =TRA or TRC (tracer indicator) 
     68      INTEGER         , INTENT(in   )                               ::   kjpt            ! number of tracers 
     69      REAL(wp)        , INTENT(in   ), DIMENSION(jpi,jpj,jpk)       ::   pun, pvn, pwn   ! 3 ocean velocity components 
     70      REAL(wp)        , INTENT(in   ), DIMENSION(jpi,jpj,jpk,kjpt)  ::   ptrab, ptran        ! before and now tracer fields 
     71      REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::   ptraa           ! tracer trend  
     72      !!* Local declarations 
     73      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
     74      REAL(wp) ::   zu, z0u, zzwx 
     75      REAL(wp) ::   zv, z0v, zzwy 
     76      REAL(wp) ::   zw, z0w 
     77      REAL(wp) ::   ztra, zbtr, z2, zdt, zalpha 
     78      REAL(wp), DIMENSION (jpi,jpj,jpk) ::  zslpx, zslpy   ! 3D workspace 
    7779      !!---------------------------------------------------------------------- 
    7880 
    … …  
    8183         WRITE(numout,*) 'tra_adv_muscl2 : MUSCL2 advection scheme' 
    8284         WRITE(numout,*) '~~~~~~~~~~~~~~~' 
     85         ! 
     86         l_trd = .FALSE. 
     87         IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 
    8388      ENDIF 
    8489 
    … …  
    8691      ELSE                                        ;   z2 = 2. 
    8792      ENDIF 
    88  
    89       ! I. Horizontal advective fluxes 
    90       ! ------------------------------ 
    91  
    92       ! first guess of the slopes 
    93       ! interior values 
    94       DO jk = 1, jpkm1 
    95          DO jj = 1, jpjm1       
    96             DO ji = 1, fs_jpim1   ! vector opt. 
    97                zt1(ji,jj,jk) = umask(ji,jj,jk) * ( tb(ji+1,jj,jk) - tb(ji,jj,jk) ) 
    98                zs1(ji,jj,jk) = umask(ji,jj,jk) * ( sb(ji+1,jj,jk) - sb(ji,jj,jk) ) 
    99                zt2(ji,jj,jk) = vmask(ji,jj,jk) * ( tb(ji,jj+1,jk) - tb(ji,jj,jk) ) 
    100                zs2(ji,jj,jk) = vmask(ji,jj,jk) * ( sb(ji,jj+1,jk) - sb(ji,jj,jk) ) 
    101             END DO 
    102          END DO 
    103       END DO 
    104       ! bottom values 
    105       zt1(:,:,jpk) = 0.e0    ;    zt2(:,:,jpk) = 0.e0 
    106       zs1(:,:,jpk) = 0.e0    ;    zs2(:,:,jpk) = 0.e0 
    107  
    108       ! lateral boundary conditions on zt1, zt2 ; zs1, zs2   (changed sign) 
    109       CALL lbc_lnk( zt1, 'U', -1. )   ;   CALL lbc_lnk( zs1, 'U', -1. ) 
    110       CALL lbc_lnk( zt2, 'V', -1. )   ;   CALL lbc_lnk( zs2, 'V', -1. ) 
    111  
    112       ! Slopes 
    113       ! interior values 
    114       DO jk = 1, jpkm1 
    115          DO jj = 2, jpj 
    116             DO ji = fs_2, jpi   ! vector opt. 
    117                ztp1(ji,jj,jk) =                    ( zt1(ji,jj,jk) + zt1(ji-1,jj  ,jk) )   & 
    118                   &           * ( 0.25 + SIGN( 0.25, zt1(ji,jj,jk) * zt1(ji-1,jj  ,jk) ) ) 
    119                zsp1(ji,jj,jk) =                    ( zs1(ji,jj,jk) + zs1(ji-1,jj  ,jk) )   & 
    120                   &           * ( 0.25 + SIGN( 0.25, zs1(ji,jj,jk) * zs1(ji-1,jj  ,jk) ) ) 
    121                ztp2(ji,jj,jk) =                    ( zt2(ji,jj,jk) + zt2(ji  ,jj-1,jk) )   & 
    122                   &           * ( 0.25 + SIGN( 0.25, zt2(ji,jj,jk) * zt2(ji  ,jj-1,jk) ) ) 
    123                zsp2(ji,jj,jk) =                    ( zs2(ji,jj,jk) + zs2(ji  ,jj-1,jk) )   & 
    124                   &           * ( 0.25 + SIGN( 0.25, zs2(ji,jj,jk) * zs2(ji  ,jj-1,jk) ) ) 
    125             END DO 
    126          END DO 
    127       END DO 
    128       ! bottom values 
    129       ztp1(:,:,jpk) = 0.e0    ;    ztp2(:,:,jpk) = 0.e0 
    130       zsp1(:,:,jpk) = 0.e0    ;    zsp2(:,:,jpk) = 0.e0 
    131  
    132       ! Slopes limitation 
    133       DO jk = 1, jpkm1 
    134          DO jj = 2, jpj 
    135             DO ji = fs_2, jpi   ! vector opt. 
    136                ztp1(ji,jj,jk) = SIGN( 1., ztp1(ji,jj,jk) )   & 
    137                   &           * MIN(    ABS( ztp1(ji  ,jj,jk) ),   & 
    138                   &                  2.*ABS( zt1 (ji-1,jj,jk) ),   & 
    139                   &                  2.*ABS( zt1 (ji  ,jj,jk) ) ) 
    140                zsp1(ji,jj,jk) = SIGN( 1., zsp1(ji,jj,jk) )   & 
    141                   &           * MIN(    ABS( zsp1(ji  ,jj,jk) ),   & 
    142                   &                  2.*ABS( zs1 (ji-1,jj,jk) ),   & 
    143                   &                  2.*ABS( zs1 (ji  ,jj,jk) ) ) 
    144                ztp2(ji,jj,jk) = SIGN( 1., ztp2(ji,jj,jk) )   & 
    145                   &           * MIN(    ABS( ztp2(ji,jj  ,jk) ),   & 
    146                   &                  2.*ABS( zt2 (ji,jj-1,jk) ),   & 
    147                   &                  2.*ABS( zt2 (ji,jj  ,jk) ) ) 
    148                zsp2(ji,jj,jk) = SIGN( 1., zsp2(ji,jj,jk) )   & 
    149                   &           * MIN(    ABS( zsp2(ji,jj  ,jk) ),   & 
    150                   &                  2.*ABS( zs2 (ji,jj-1,jk) ),   & 
    151                   &                  2.*ABS( zs2 (ji,jj  ,jk) ) ) 
    152             END DO 
    153          END DO 
    154       END DO         
    155  
    156       ! Advection terms 
    157       ! interior values 
    158       DO jk = 1, jpkm1 
    159          zstep  = z2 * rdttra(jk) 
    160          DO jj = 2, jpjm1       
    161             DO ji = fs_2, fs_jpim1   ! vector opt. 
    162                ! volume fluxes 
    163 #if defined key_zco 
    164                zeu = e2u(ji,jj)                   * pun(ji,jj,jk) 
    165                zev = e1v(ji,jj)                   * pvn(ji,jj,jk) 
    166 #else 
    167                zeu = e2u(ji,jj) * fse3u(ji,jj,jk) * pun(ji,jj,jk) 
    168                zev = e1v(ji,jj) * fse3v(ji,jj,jk) * pvn(ji,jj,jk) 
    169 #endif 
    170                ! MUSCL fluxes 
    171                z0u = SIGN( 0.5, pun(ji,jj,jk) )             
    172                zalpha = 0.5 - z0u 
    173                zu  = z0u - 0.5 * pun(ji,jj,jk) * zstep / e1u(ji,jj) 
    174                zzt1 = tb(ji+1,jj,jk) + zu*ztp1(ji+1,jj,jk) 
    175                zzt2 = tb(ji  ,jj,jk) + zu*ztp1(ji  ,jj,jk) 
    176                zzs1 = sb(ji+1,jj,jk) + zu*zsp1(ji+1,jj,jk) 
    177                zzs2 = sb(ji  ,jj,jk) + zu*zsp1(ji  ,jj,jk) 
    178                zt1(ji,jj,jk) = zeu * ( zalpha * zzt1 + (1.-zalpha) * zzt2 ) 
    179                zs1(ji,jj,jk) = zeu * ( zalpha * zzs1 + (1.-zalpha) * zzs2 ) 
    180                ! 
    181                z0v = SIGN( 0.5, pvn(ji,jj,jk) )             
    182                zalpha = 0.5 - z0v 
    183                zv  = z0v - 0.5 * pvn(ji,jj,jk) * zstep / e2v(ji,jj) 
    184                zzt1 = tb(ji,jj+1,jk) + zv*ztp2(ji,jj+1,jk) 
    185                zzt2 = tb(ji,jj  ,jk) + zv*ztp2(ji,jj  ,jk) 
    186                zzs1 = sb(ji,jj+1,jk) + zv*zsp2(ji,jj+1,jk) 
    187                zzs2 = sb(ji,jj  ,jk) + zv*zsp2(ji,jj  ,jk) 
    188                zt2(ji,jj,jk) = zev * ( zalpha * zzt1 + (1.-zalpha) * zzt2 ) 
    189                zs2(ji,jj,jk) = zev * ( zalpha * zzs1 + (1.-zalpha) * zzs2 ) 
    190             END DO 
    191          END DO 
    192       END DO 
    193  
    194       !!!!  centered scheme at lateral b.C. if off-shore velocity 
    195       DO jk = 1, jpkm1 
    196         DO jj = 2, jpjm1 
    197             DO ji = fs_2, fs_jpim1   ! vector opt. 
    198 #if defined key_zco 
    199                IF( umask(ji,jj,jk) == 0. ) THEN 
    200                   IF( pun(ji+1,jj,jk) > 0. .AND. ji /= jpi ) THEN 
    201                      zt1(ji+1,jj,jk) = e2u(ji+1,jj) * pun(ji+1,jj,jk) * ( tb(ji+1,jj,jk) + tb(ji+2,jj,jk) ) * 0.5 
    202                      zs1(ji+1,jj,jk) = e2u(ji+1,jj) * pun(ji+1,jj,jk) * ( sb(ji+1,jj,jk) + sb(ji+2,jj,jk) ) * 0.5 
     93      ! 
     94      ! 
     95      DO jn = 1, kjpt                                            ! tracer loop 
     96         !                                                       ! =========== 
     97         ! I. Horizontal advective fluxes 
     98         ! ------------------------------ 
     99         ! first guess of the slopes 
     100         zwx(:,:,jpk) = 0.e0   ;   zwy(:,:,jpk) = 0.e0        ! bottom values 
     101         ! interior values 
     102         DO jk = 1, jpkm1 
     103            DO jj = 1, jpjm1       
     104               DO ji = 1, fs_jpim1   ! vector opt. 
     105                  zwx(ji,jj,jk) = umask(ji,jj,jk) * ( ptrab(ji+1,jj,jk,jn) - ptrab(ji,jj,jk,jn) ) 
     106                  zwy(ji,jj,jk) = vmask(ji,jj,jk) * ( ptrab(ji,jj+1,jk,jn) - ptrab(ji,jj,jk,jn) ) 
     107               END DO 
     108           END DO 
     109         END DO 
     110         ! 
     111         CALL lbc_lnk( zwx, 'U', -1. )                        ! lateral boundary conditions on zwx, zwy   (changed sign) 
     112         CALL lbc_lnk( zwy, 'V', -1. ) 
     113         !                                             !-- Slopes of tracer 
     114         zslpx(:,:,jpk) = 0.e0   ;   zslpy(:,:,jpk) = 0.e0    ! bottom values 
     115         DO jk = 1, jpkm1                                     ! interior values 
     116            DO jj = 2, jpj 
     117               DO ji = fs_2, jpi   ! vector opt. 
     118                  zslpx(ji,jj,jk) =                    ( zwx(ji,jj,jk) + zwx(ji-1,jj  ,jk) )   & 
     119                     &            * ( 0.25 + SIGN( 0.25, zwx(ji,jj,jk) * zwx(ji-1,jj  ,jk) ) ) 
     120                  zslpy(ji,jj,jk) =                    ( zwy(ji,jj,jk) + zwy(ji  ,jj-1,jk) )   & 
     121                     &            * ( 0.25 + SIGN( 0.25, zwy(ji,jj,jk) * zwy(ji  ,jj-1,jk) ) ) 
     122               END DO 
     123            END DO 
     124         END DO 
     125         ! 
     126         DO jk = 1, jpkm1                                     ! Slopes limitation 
     127            DO jj = 2, jpj 
     128               DO ji = fs_2, jpi   ! vector opt. 
     129                  zslpx(ji,jj,jk) = SIGN( 1., zslpx(ji,jj,jk) ) * MIN(    ABS( zslpx(ji  ,jj,jk) ),   & 
     130                     &                                                 2.*ABS( zwx  (ji-1,jj,jk) ),   & 
     131                     &                                                 2.*ABS( zwx  (ji  ,jj,jk) ) ) 
     132                  zslpy(ji,jj,jk) = SIGN( 1., zslpy(ji,jj,jk) ) * MIN(    ABS( zslpy(ji,jj  ,jk) ),   & 
     133                     &                                                 2.*ABS( zwy  (ji,jj-1,jk) ),   & 
     134                     &                                                 2.*ABS( zwy  (ji,jj  ,jk) ) ) 
     135               END DO 
     136           END DO 
     137         END DO             ! interior values 
     138 
     139        !                                             !-- MUSCL horizontal advective fluxes 
     140         DO jk = 1, jpkm1                                     ! interior values 
     141            zdt  = z2 * rdttra(jk) 
     142            DO jj = 2, jpjm1 
     143               DO ji = fs_2, fs_jpim1   ! vector opt. 
     144                  ! MUSCL fluxes 
     145                  z0u = SIGN( 0.5, pun(ji,jj,jk) ) 
     146                  zalpha = 0.5 - z0u 
     147                  zu  = z0u - 0.5 * pun(ji,jj,jk) * zdt / ( e1u(ji,jj) * e2u(ji,jj) * fse3u(ji,jj,jk) ) 
     148                  zzwx = ptrab(ji+1,jj,jk,jn) + zu * zslpx(ji+1,jj,jk) 
     149                  zzwy = ptrab(ji  ,jj,jk,jn) + zu * zslpx(ji  ,jj,jk) 
     150                  zwx(ji,jj,jk) = pun(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 
     151                  ! 
     152                  z0v = SIGN( 0.5, pvn(ji,jj,jk) ) 
     153                  zalpha = 0.5 - z0v 
     154                  zv  = z0v - 0.5 * pvn(ji,jj,jk) * zdt / ( e1v(ji,jj) * e2v(ji,jj) * fse3v(ji,jj,jk) ) 
     155                  zzwx = ptrab(ji,jj+1,jk,jn) + zv * zslpy(ji,jj+1,jk) 
     156                  zzwy = ptrab(ji,jj  ,jk,jn) + zv * zslpy(ji,jj  ,jk) 
     157                  zwy(ji,jj,jk) = pvn(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 
     158               END DO 
     159            END DO 
     160         END DO 
     161 
     162         !!  centered scheme at lateral b.C. if off-shore velocity 
     163         DO jk = 1, jpkm1 
     164            DO jj = 2, jpjm1 
     165               DO ji = fs_2, fs_jpim1   ! vector opt. 
     166                  IF( umask(ji,jj,jk) == 0. ) THEN 
     167                     IF( pun(ji+1,jj,jk) > 0. .AND. ji /= jpi ) THEN 
     168                        zwx(ji+1,jj,jk) = 0.5 * pun(ji+1,jj,jk) * ( ptran(ji+1,jj,jk,jn) + ptran(ji+2,jj,jk,jn) ) 
     169                     ENDIF 
     170                     IF( pun(ji-1,jj,jk) < 0. ) THEN 
     171                        zwx(ji-1,jj,jk) = 0.5 * pun(ji-1,jj,jk) * ( ptran(ji-1,jj,jk,jn) + ptran(ji,jj,jk,jn) )  
     172                     ENDIF 
    203173                  ENDIF 
    204                   IF( pun(ji-1,jj,jk) < 0. ) THEN 
    205                      zt1(ji-1,jj,jk) = e2u(ji-1,jj) * pun(ji-1,jj,jk) * ( tb(ji-1,jj,jk) + tb(ji  ,jj,jk) ) * 0.5 
    206                      zs1(ji-1,jj,jk) = e2u(ji-1,jj) * pun(ji-1,jj,jk) * ( sb(ji-1,jj,jk) + sb(ji  ,jj,jk) ) * 0.5 
     174                  IF( vmask(ji,jj,jk) == 0. ) THEN 
     175                     IF( pvn(ji,jj+1,jk) > 0. .AND. jj /= jpj ) THEN 
     176                        zwy(ji,jj+1,jk) = 0.5 * pvn(ji,jj+1,jk) * ( ptran(ji,jj+1,jk,jn) + ptran(ji,jj+2,jk,jn) ) 
     177                     ENDIF 
     178                     IF( pvn(ji,jj-1,jk) < 0. ) THEN 
     179                        zwy(ji,jj-1,jk) = 0.5 * pvn(ji,jj-1,jk) * ( ptran(ji,jj-1,jk,jn) + ptran(ji,jj,jk,jn) )  
     180                     ENDIF 
    207181                  ENDIF 
    208                ENDIF 
    209                IF( vmask(ji,jj,jk) == 0. ) THEN 
    210                   IF( pvn(ji,jj+1,jk) > 0. .AND. jj /= jpj ) THEN 
    211                      zt2(ji,jj+1,jk) = e1v(ji,jj+1) * pvn(ji,jj+1,jk) * ( tb(ji,jj+1,jk) + tb(ji,jj+2,jk) ) * 0.5 
    212                      zs2(ji,jj+1,jk) = e1v(ji,jj+1) * pvn(ji,jj+1,jk) * ( sb(ji,jj+1,jk) + sb(ji,jj+2,jk) ) * 0.5 
     182               END DO 
     183            END DO 
     184         END DO 
     185 
     186         !                                                    ! lateral boundary conditions on zwx, zwy   (changed sign) 
     187         CALL lbc_lnk( zwx, 'U', -1. )   ;   CALL lbc_lnk( zwy, 'V', -1. ) 
     188         ! Tracer flux divergence at t-point added to the general trend 
     189         DO jk = 1, jpkm1 
     190            DO jj = 2, jpjm1 
     191               DO ji = fs_2, fs_jpim1   ! vector opt. 
     192                  zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
     193                  ! horizontal advective trends  
     194                  ztra = - zbtr * ( zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
     195                  &               + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  ) ) 
     196                  ! added to the general tracer trends 
     197                  ptraa(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn) + ztra 
     198               END DO 
     199           END DO 
     200         END DO 
     201         !                                 ! trend diagnostics (contribution of upstream fluxes) 
     202         IF( l_trd ) THEN 
     203            CALL trd_tra( kt, cdtype, jn, jptra_trd_xad, zwx, pun, ptrab(:,:,:,jn) ) 
     204            CALL trd_tra( kt, cdtype, jn, jptra_trd_yad, zwy, pvn, ptrab(:,:,:,jn) ) 
     205         END IF 
     206 
     207         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
     208         IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN 
     209            IF( lk_zco ) THEN 
     210               DO jk = 1, jpkm1 
     211                  DO jj = 2, jpjm1 
     212                     DO ji = fs_2, fs_jpim1   ! vector opt. 
     213                       zwy(ji,jj,jk) = zwy(ji,jj,jk) * fse3v(ji,jj,jk) 
     214                     END DO 
     215                  END DO 
     216               END DO 
     217            ENDIF 
     218            IF( jn == jp_tem )  pht_adv(:) = ptr_vj( zwy(:,:,:) ) 
     219            IF( jn == jp_sal )  pst_adv(:) = ptr_vj( zwy(:,:,:) ) 
     220         ENDIF 
     221 
     222         ! II. Vertical advective fluxes 
     223         ! ----------------------------- 
     224         !                                             !-- first guess of the slopes 
     225         zwx (:,:, 1 ) = 0.e0    ;    zwx (:,:,jpk) = 0.e0    ! surface & bottom boundary conditions 
     226         DO jk = 2, jpkm1                                     ! interior values 
     227            zwx(:,:,jk) = tmask(:,:,jk) * ( ptrab(:,:,jk-1,jn) - ptrab(:,:,jk,jn) ) 
     228         END DO 
     229 
     230         !                                             !-- Slopes of tracer 
     231         zslpx(:,:,1) = 0.e0                                  ! surface values 
     232         DO jk = 2, jpkm1                                     ! interior value 
     233            DO jj = 1, jpj 
     234               DO ji = 1, jpi 
     235                  zslpx(ji,jj,jk) =                    ( zwx(ji,jj,jk) + zwx(ji,jj,jk+1) )   & 
     236                     &            * ( 0.25 + SIGN( 0.25, zwx(ji,jj,jk) * zwx(ji,jj,jk+1) ) ) 
     237               END DO 
     238            END DO 
     239         END DO 
     240         !                                             !-- Slopes limitation 
     241         DO jk = 2, jpkm1                                     ! interior values 
     242            DO jj = 1, jpj 
     243               DO ji = 1, jpi 
     244                  zslpx(ji,jj,jk) = SIGN( 1., zslpx(ji,jj,jk) ) * MIN(    ABS( zslpx(ji,jj,jk  ) ),   & 
     245                     &                                                 2.*ABS( zwx  (ji,jj,jk+1) ),   & 
     246                     &                                                 2.*ABS( zwx  (ji,jj,jk  ) )  ) 
     247               END DO 
     248            END DO 
     249         END DO 
     250         !                                             !-- vertical advective flux 
     251         !                                                    ! surface values  (bottom already set to zero) 
     252         IF( lk_vvl ) THEN    ;   zwx(:,:, 1 ) = 0.e0                      !  variable volume 
     253         ELSE                 ;   zwx(:,:, 1 ) = pwn(:,:,1) * ptrab(:,:,1,jn)   ! linear free surface 
     254         ENDIF 
     255         ! 
     256         DO jk = 1, jpkm1                                     ! interior values 
     257            zdt  = z2 * rdttra(jk) 
     258            DO jj = 2, jpjm1 
     259               DO ji = fs_2, fs_jpim1   ! vector opt. 
     260                  zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3w(ji,jj,jk+1) ) 
     261                  z0w = SIGN( 0.5, pwn(ji,jj,jk+1) ) 
     262                  zalpha = 0.5 + z0w 
     263                  zw  = z0w - 0.5 * pwn(ji,jj,jk+1) * zdt * zbtr 
     264                  zzwx = ptrab(ji,jj,jk+1,jn) + zw * zslpx(ji,jj,jk+1) 
     265                  zzwy = ptrab(ji,jj,jk  ,jn) + zw * zslpx(ji,jj,jk  ) 
     266                  zwx(ji,jj,jk+1) = pwn(ji,jj,jk+1) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 
     267               END DO 
     268            END DO 
     269         END DO 
     270         ! 
     271         DO jk = 2, jpkm1        ! centered near the bottom 
     272            DO jj = 2, jpjm1 
     273               DO ji = fs_2, fs_jpim1   ! vector opt. 
     274                  IF( tmask(ji,jj,jk+1) == 0. ) THEN 
     275                     IF( pwn(ji,jj,jk) > 0. ) THEN 
     276                        zwx(ji,jj,jk) = 0.5 * pwn(ji,jj,jk) * ( ptran(ji,jj,jk-1,jn) + ptran(ji,jj,jk,jn) )  
     277                     ENDIF 
    213278                  ENDIF 
    214                   IF( pvn(ji,jj-1,jk) < 0. ) THEN 
    215                      zt2(ji,jj-1,jk) = e1v(ji,jj-1) * pvn(ji,jj-1,jk) * ( tb(ji,jj-1,jk) + tb(ji  ,jj,jk) ) * 0.5 
    216                      zs2(ji,jj-1,jk) = e1v(ji,jj-1) * pvn(ji,jj-1,jk) * ( sb(ji,jj-1,jk) + sb(ji  ,jj,jk) ) * 0.5 
    217                   ENDIF 
    218                ENDIF 
    219 #else 
    220                IF( umask(ji,jj,jk) == 0. ) THEN 
    221                   IF( pun(ji+1,jj,jk) > 0. .AND. ji /= jpi ) THEN 
    222                      zt1(ji+1,jj,jk) = e2u(ji+1,jj)* fse3u(ji+1,jj,jk)   & 
    223                         &            * pun(ji+1,jj,jk) * ( tb(ji+1,jj,jk) + tb(ji+2,jj,jk) ) * 0.5 
    224                      zs1(ji+1,jj,jk) = e2u(ji+1,jj)* fse3u(ji+1,jj,jk)   & 
    225                         &            * pun(ji+1,jj,jk) * ( sb(ji+1,jj,jk) + sb(ji+2,jj,jk) ) * 0.5 
    226                   ENDIF 
    227                   IF( pun(ji-1,jj,jk) < 0. ) THEN 
    228                      zt1(ji-1,jj,jk) = e2u(ji-1,jj)* fse3u(ji-1,jj,jk)   & 
    229                         &            * pun(ji-1,jj,jk) * ( tb(ji-1,jj,jk) + tb(ji  ,jj,jk) ) * 0.5 
    230                      zs1(ji-1,jj,jk) = e2u(ji-1,jj)* fse3u(ji-1,jj,jk)   & 
    231                         &            * pun(ji-1,jj,jk) * ( sb(ji-1,jj,jk) + sb(ji  ,jj,jk) ) * 0.5 
    232                   ENDIF 
    233                ENDIF 
    234                IF( vmask(ji,jj,jk) == 0. ) THEN 
    235                   IF( pvn(ji,jj+1,jk) > 0. .AND. jj /= jpj ) THEN 
    236                      zt2(ji,jj+1,jk) = e1v(ji,jj+1) * fse3v(ji,jj+1,jk)   & 
    237                         &            * pvn(ji,jj+1,jk) * ( tb(ji,jj+1,jk) + tb(ji,jj+2,jk) ) * 0.5 
    238                      zs2(ji,jj+1,jk) = e1v(ji,jj+1) * fse3v(ji,jj+1,jk)   & 
    239                         &            * pvn(ji,jj+1,jk) * ( sb(ji,jj+1,jk) + sb(ji,jj+2,jk) ) * 0.5 
    240                   ENDIF 
    241                   IF( pvn(ji,jj-1,jk) < 0. ) THEN 
    242                      zt2(ji,jj-1,jk) = e1v(ji,jj-1)* fse3v(ji,jj-1,jk)   & 
    243                         &            * pvn(ji,jj-1,jk) * ( tb(ji,jj-1,jk) + tb(ji  ,jj,jk) ) * 0.5 
    244                      zs2(ji,jj-1,jk) = e1v(ji,jj-1)* fse3v(ji,jj-1,jk)   & 
    245                         &            * pvn(ji,jj-1,jk) * ( sb(ji,jj-1,jk) + sb(ji  ,jj,jk) ) * 0.5 
    246                   ENDIF 
    247                ENDIF 
    248 #endif 
    249             END DO 
    250          END DO 
    251       END DO 
    252  
    253       ! lateral boundary conditions on zt1, zt2 ; zs1, zs2   (changed sign) 
    254       CALL lbc_lnk( zt1, 'U', -1. )   ;   CALL lbc_lnk( zs1, 'U', -1. )  
    255       CALL lbc_lnk( zt2, 'V', -1. )   ;   CALL lbc_lnk( zs2, 'V', -1. ) 
    256  
    257       ! Compute & add the horizontal advective trend 
    258  
    259       DO jk = 1, jpkm1 
    260          DO jj = 2, jpjm1       
    261             DO ji = fs_2, fs_jpim1   ! vector opt. 
    262 #if defined key_zco 
    263                zbtr = 1. / ( e1t(ji,jj)*e2t(ji,jj) ) 
    264 #else 
    265                zbtr = 1. / ( e1t(ji,jj)*e2t(ji,jj)*fse3t(ji,jj,jk) ) 
    266 #endif 
    267                ! horizontal advective trends 
    268                zta = - zbtr * ( zt1(ji,jj,jk) - zt1(ji-1,jj  ,jk  )   & 
    269                   &           + zt2(ji,jj,jk) - zt2(ji  ,jj-1,jk  ) ) 
    270                zsa = - zbtr * ( zs1(ji,jj,jk) - zs1(ji-1,jj  ,jk  )   & 
    271                   &           + zs2(ji,jj,jk) - zs2(ji  ,jj-1,jk  ) )  
    272                ! add it to the general tracer trends 
    273                ta(ji,jj,jk) = ta(ji,jj,jk) + zta 
    274                sa(ji,jj,jk) = sa(ji,jj,jk) + zsa 
    275             END DO 
    276         END DO 
    277       END DO         
    278  
    279       ! Save the horizontal advective trends for diagnostic 
    280       IF( l_trdtra ) THEN 
    281          ztrdt(:,:,:) = 0.e0   ;   ztrds(:,:,:) = 0.e0 
    282          ! 
    283          ! T/S ZONAL advection trends 
     279               END DO 
     280            END DO 
     281         END DO 
     282 
     283         ! Compute & add the vertical advective trend 
    284284         DO jk = 1, jpkm1 
    285             DO jj = 2, jpjm1 
    286                DO ji = fs_2, fs_jpim1   ! vector opt. 
    287                   !-- Compute zonal divergence by splitting hdivn (see divcur.F90) 
    288                   !   N.B. This computation is not valid along OBCs (if any) 
    289 #if defined key_zco 
    290                   zbtr      = 1. / ( e1t(ji,jj) * e2t(ji,jj) ) 
    291                   z_hdivn_x = (  e2u(ji  ,jj) * pun(ji  ,jj,jk)                              & 
    292                      &         - e2u(ji-1,jj) * pun(ji-1,jj,jk) ) * zbtr 
    293 #else 
    294                   zbtr      = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    295                   z_hdivn_x = (  e2u(ji  ,jj) * fse3u(ji  ,jj,jk) * pun(ji  ,jj,jk)          & 
    296                      &         - e2u(ji-1,jj) * fse3u(ji-1,jj,jk) * pun(ji-1,jj,jk) ) * zbtr 
    297 #endif 
    298                   ztrdt(ji,jj,jk) = - zbtr * ( zt1(ji,jj,jk) - zt1(ji-1,jj,jk) ) + tn(ji,jj,jk) * z_hdivn_x 
    299                   ztrds(ji,jj,jk) = - zbtr * ( zs1(ji,jj,jk) - zs1(ji-1,jj,jk) ) + sn(ji,jj,jk) * z_hdivn_x 
    300                END DO 
    301             END DO 
    302          END DO 
    303          CALL trd_mod(ztrdt, ztrds, jptra_trd_xad, 'TRA', kt) 
    304  
    305          ! T/S MERIDIONAL advection trends 
    306          DO jk = 1, jpkm1 
    307             DO jj = 2, jpjm1 
    308                DO ji = fs_2, fs_jpim1   ! vector opt. 
    309                   !-- Compute merid. divergence by splitting hdivn (see divcur.F90) 
    310                   !   N.B. This computation is not valid along OBCs (if any) 
    311 #if defined key_zco 
    312                   zbtr      = 1. / ( e1t(ji,jj) * e2t(ji,jj) ) 
    313                   z_hdivn_y = (  e1v(ji,jj  ) * pvn(ji,jj  ,jk)                              & 
    314                      &         - e1v(ji,jj-1) * pvn(ji,jj-1,jk) ) * zbtr 
    315 #else 
    316                   zbtr      = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    317                   z_hdivn_y = (  e1v(ji,  jj) * fse3v(ji,jj  ,jk) * pvn(ji,jj  ,jk)          & 
    318                      &         - e1v(ji,jj-1) * fse3v(ji,jj-1,jk) * pvn(ji,jj-1,jk) ) * zbtr 
    319 #endif 
    320                   ztrdt(ji,jj,jk) = - zbtr * ( zt2(ji,jj,jk) - zt2(ji,jj-1,jk) ) + tn(ji,jj,jk) * z_hdivn_y           
    321                   ztrds(ji,jj,jk) = - zbtr * ( zs2(ji,jj,jk) - zs2(ji,jj-1,jk) ) + sn(ji,jj,jk) * z_hdivn_y 
    322                END DO 
    323             END DO 
    324          END DO 
    325          CALL trd_mod(ztrdt, ztrds, jptra_trd_yad, 'TRA', kt) 
    326  
    327          ! Save the up-to-date ta and sa trends 
    328          ztrdt(:,:,:) = ta(:,:,:)  
    329          ztrds(:,:,:) = sa(:,:,:)  
    330          ! 
    331       ENDIF 
    332  
    333       IF(ln_ctl)   CALL prt_ctl( tab3d_1=ta, clinfo1=' muscl2 had  - Ta: ', mask1=tmask,   & 
    334          &                       tab3d_2=sa, clinfo2=              ' Sa: ', mask2=tmask, clinfo3='tra') 
    335  
    336       ! "zonal" mean advective heat and salt transport 
    337       IF( ln_diaptr .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN 
    338          IF( lk_zco ) THEN 
    339             DO jk = 1, jpkm1 
    340                DO jj = 2, jpjm1 
    341                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    342                     zt2(ji,jj,jk) = zt2(ji,jj,jk) * fse3v(ji,jj,jk) 
    343                     zs2(ji,jj,jk) = zs2(ji,jj,jk) * fse3v(ji,jj,jk) 
    344                   END DO 
    345                END DO 
    346             END DO 
    347          ENDIF 
    348          pht_adv(:) = ptr_vj( zt2(:,:,:) ) 
    349          pst_adv(:) = ptr_vj( zs2(:,:,:) ) 
    350       ENDIF 
    351  
    352       ! II. Vertical advective fluxes 
    353       ! ----------------------------- 
    354        
    355       ! First guess of the slope 
    356       ! interior values 
    357       DO jk = 2, jpkm1 
    358          zt1(:,:,jk) = tmask(:,:,jk) * ( tb(:,:,jk-1) - tb(:,:,jk) ) 
    359          zs1(:,:,jk) = tmask(:,:,jk) * ( sb(:,:,jk-1) - sb(:,:,jk) ) 
    360       END DO 
    361       ! surface & bottom boundary conditions 
    362       zt1 (:,:, 1 ) = 0.e0    ;    zt1 (:,:,jpk) = 0.e0 
    363       zs1 (:,:, 1 ) = 0.e0    ;    zs1 (:,:,jpk) = 0.e0 
    364  
    365       ! Slopes 
    366       DO jk = 2, jpkm1 
    367          DO jj = 1, jpj 
    368             DO ji = 1, jpi 
    369                ztp1(ji,jj,jk) =                    ( zt1(ji,jj,jk) + zt1(ji,jj,jk+1) )   & 
    370                   &           * ( 0.25 + SIGN( 0.25, zt1(ji,jj,jk) * zt1(ji,jj,jk+1) ) ) 
    371                zsp1(ji,jj,jk) =                    ( zs1(ji,jj,jk) + zs1(ji,jj,jk+1) )   & 
    372                   &           * ( 0.25 + SIGN( 0.25, zs1(ji,jj,jk) * zs1(ji,jj,jk+1) ) ) 
    373             END DO 
    374          END DO 
    375       END DO 
    376  
    377       ! Slopes limitation 
    378       ! interior values 
    379       DO jk = 2, jpkm1 
    380          DO jj = 1, jpj 
    381             DO ji = 1, jpi 
    382                ztp1(ji,jj,jk) = SIGN( 1., ztp1(ji,jj,jk) )   & 
    383                   &           * MIN(    ABS( ztp1(ji,jj,jk  ) ),   & 
    384                   &                  2.*ABS( zt1 (ji,jj,jk+1) ),   & 
    385                   &                  2.*ABS( zt1 (ji,jj,jk  ) ) ) 
    386                zsp1(ji,jj,jk) = SIGN( 1., zsp1(ji,jj,jk) )   & 
    387                   &           * MIN(    ABS( zsp1(ji,jj,jk  ) ),   & 
    388                   &                  2.*ABS( zs1 (ji,jj,jk+1) ),   & 
    389                   &                  2.*ABS( zs1 (ji,jj,jk  ) ) ) 
    390             END DO 
    391          END DO 
    392       END DO 
    393       ! surface values 
    394       ztp1(:,:,1) = 0.e0 
    395       zsp1(:,:,1) = 0.e0 
    396  
    397       ! vertical advective flux 
    398       ! interior values 
    399       DO jk = 1, jpkm1 
    400          zstep  = z2 * rdttra(jk) 
    401          DO jj = 2, jpjm1       
    402             DO ji = fs_2, fs_jpim1   ! vector opt. 
    403                zew = pwn(ji,jj,jk+1) 
    404                z0w = SIGN( 0.5, pwn(ji,jj,jk+1) ) 
    405                zalpha = 0.5 + z0w 
    406                zw  = z0w - 0.5 * pwn(ji,jj,jk+1)*zstep / fse3w(ji,jj,jk+1) 
    407                zzt1 = tb(ji,jj,jk+1) + zw*ztp1(ji,jj,jk+1) 
    408                zzt2 = tb(ji,jj,jk  ) + zw*ztp1(ji,jj,jk  ) 
    409                zzs1 = sb(ji,jj,jk+1) + zw*zsp1(ji,jj,jk+1) 
    410                zzs2 = sb(ji,jj,jk  ) + zw*zsp1(ji,jj,jk  ) 
    411                zt1(ji,jj,jk+1) = zew * ( zalpha * zzt1 + (1.-zalpha)*zzt2 ) 
    412                zs1(ji,jj,jk+1) = zew * ( zalpha * zzs1 + (1.-zalpha)*zzs2 ) 
    413             END DO 
    414          END DO 
    415       END DO 
    416       DO jk = 2, jpkm1 
    417         DO jj = 2, jpjm1 
    418             DO ji = fs_2, fs_jpim1   ! vector opt. 
    419                IF( tmask(ji,jj,jk+1) == 0. ) THEN 
    420                   IF( pwn(ji,jj,jk) > 0. ) THEN 
    421                      zt1(ji,jj,jk) = pwn(ji,jj,jk) * ( tb(ji,jj,jk-1) + tb(ji,jj,jk) ) * 0.5 
    422                      zs1(ji,jj,jk) = pwn(ji,jj,jk) * ( sb(ji,jj,jk-1) + sb(ji,jj,jk) ) * 0.5 
    423                   ENDIF 
    424                ENDIF 
    425             END DO 
    426          END DO 
    427       END DO 
    428  
    429       ! surface values 
    430       IF( lk_vvl ) THEN 
    431          ! variable volume : flux set to zero 
    432          zt1(:,:, 1 ) = 0.e0 
    433          zs1(:,:, 1 ) = 0.e0 
    434       ELSE 
    435          ! free surface-constant volume 
    436          zt1(:,:, 1 ) = pwn(:,:,1) * tb(:,:,1) 
    437          zs1(:,:, 1 ) = pwn(:,:,1) * sb(:,:,1) 
    438       ENDIF 
    439  
    440       ! bottom values 
    441       zt1(:,:,jpk) = 0.e0 
    442       zs1(:,:,jpk) = 0.e0 
    443  
    444  
    445       ! Compute & add the vertical advective trend 
    446  
    447       DO jk = 1, jpkm1 
    448          DO jj = 2, jpjm1       
    449             DO ji = fs_2, fs_jpim1   ! vector opt. 
    450                zbtr = 1. / fse3t(ji,jj,jk) 
    451                ! horizontal advective trends 
    452                zta = - zbtr * ( zt1(ji,jj,jk) - zt1(ji,jj,jk+1) ) 
    453                zsa = - zbtr * ( zs1(ji,jj,jk) - zs1(ji,jj,jk+1) ) 
    454                ! add it to the general tracer trends 
    455                ta(ji,jj,jk) =  ta(ji,jj,jk) + zta 
    456                sa(ji,jj,jk) =  sa(ji,jj,jk) + zsa 
    457             END DO 
    458          END DO 
    459       END DO 
    460  
    461       ! Save the vertical advective trends for diagnostic 
    462       IF( l_trdtra )   THEN 
    463          ! Recompute the vertical advection zta & zsa trends computed  
    464          ! at the step 2. above in making the difference between the new  
    465          ! trends and the previous one: ta()/sa - ztrdt()/ztrds() and substract 
    466          ! the term tn()/sn()*hdivn() to recover the W gradz(T/S) trends 
    467  
    468          DO jk = 1, jpkm1 
    469             DO jj = 2, jpjm1 
    470                DO ji = fs_2, fs_jpim1   ! vector opt. 
    471 #if defined key_zco 
    472                   zbtr      = 1. / ( e1t(ji,jj) * e2t(ji,jj) ) 
    473                   z_hdivn_x = e2u(ji,jj)*pun(ji,jj,jk) - e2u(ji-1,jj)*pun(ji-1,jj,jk) 
    474                   z_hdivn_y = e1v(ji,jj)*pvn(ji,jj,jk) - e1v(ji,jj-1)*pvn(ji,jj-1,jk) 
    475 #else 
    476                   zbtr      = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    477                   z_hdivn_x = e2u(ji,jj)*fse3u(ji,jj,jk)*pun(ji,jj,jk) - e2u(ji-1,jj)*fse3u(ji-1,jj,jk)*pun(ji-1,jj,jk) 
    478                   z_hdivn_y = e1v(ji,jj)*fse3v(ji,jj,jk)*pvn(ji,jj,jk) - e1v(ji,jj-1)*fse3v(ji,jj-1,jk)*pvn(ji,jj-1,jk) 
    479 #endif 
    480                   z_hdivn   = (z_hdivn_x + z_hdivn_y) * zbtr 
    481                   ztrdt(ji,jj,jk) = ta(ji,jj,jk) - ztrdt(ji,jj,jk) - tn(ji,jj,jk) * z_hdivn  
    482                   ztrds(ji,jj,jk) = sa(ji,jj,jk) - ztrds(ji,jj,jk) - sn(ji,jj,jk) * z_hdivn 
    483                END DO 
    484             END DO 
    485          END DO 
    486          CALL trd_mod(ztrdt, ztrds, jptra_trd_zad, 'TRA', kt) 
    487          ! 
    488       ENDIF 
    489  
    490       IF(ln_ctl)   CALL prt_ctl( tab3d_1=ta, clinfo1=' muscl2 zad  - Ta: ', mask1=tmask,   & 
    491          &                       tab3d_2=sa, clinfo2=              ' Sa: ', mask2=tmask, clinfo3='tra' ) 
     285            DO jj = 2, jpjm1       
     286               DO ji = fs_2, fs_jpim1   ! vector opt. 
     287                  zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
     288                  ! vertical advective trends  
     289                  ztra = - zbtr * ( zwx(ji,jj,jk) - zwx(ji,jj,jk+1) ) 
     290                  ! added to the general tracer trends 
     291                  ptraa(ji,jj,jk,jn) =  ptraa(ji,jj,jk,jn) + ztra 
     292               END DO 
     293            END DO 
     294         END DO 
     295 
     296         ! Save the vertical advective trends for diagnostic 
     297         ! ------------------------------------------------- 
     298         !                                 ! trend diagnostics (contribution of upstream fluxes) 
     299         IF( l_trd )  CALL trd_tra( kt, cdtype, jn, jptra_trd_zad, zwx, pwn, ptrab(:,:,:,jn) ) 
     300         ! 
     301      ENDDO 
    492302      ! 
    493303   END SUBROUTINE tra_adv_muscl2 

  • branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/traadv_qck.F90

    r1559 r2024  
    22   !!============================================================================== 
    33   !!                       ***  MODULE  traadv_qck  *** 
    4    !! Ocean active tracers:  horizontal & vertical advective trend 
     4   !! Ocean tracers:  horizontal & vertical advective trend 
    55   !!============================================================================== 
    66   !! History :  3.0  !  2008-07  (G. Reffray)  Original code 
     7   !!            3.3  !  2010-05  (C.Ethe, G. Madec)  merge TRC-TRA + switch from velocity to transport 
    78   !!---------------------------------------------------------------------- 
    89 
    … …  
    1617   USE oce             ! ocean dynamics and active tracers 
    1718   USE dom_oce         ! ocean space and time domain 
    18    USE trdmod          ! ocean active tracers trends  
    19    USE trdmod_oce      ! ocean variables trends 
     19   USE trdmod_oce         ! ocean space and time domain 
     20   USE trdtra      ! ocean tracers trends  
    2021   USE trabbl          ! advective term in the BBL 
    2122   USE lib_mpp         ! distribued memory computing 
    … …  
    2425   USE in_out_manager  ! I/O manager 
    2526   USE diaptr          ! poleward transport diagnostics 
    26    USE prtctl          ! Print control 
    2727 
    2828   IMPLICIT NONE 
    … …  
    3131   PUBLIC   tra_adv_qck   ! routine called by step.F90 
    3232 
    33    REAL(wp), DIMENSION(jpi,jpj) ::   btr2 
    34    REAL(wp)                     ::   r1_6 
     33   REAL(wp)  ::   r1_6 = 1./ 6. 
     34   LOGICAL   :: l_trd    ! flag to compute trends 
    3535 
    3636   !! * Substitutions 
    … …  
    4545CONTAINS 
    4646 
    47    SUBROUTINE tra_adv_qck( kt, pun, pvn, pwn ) 
     47   SUBROUTINE tra_adv_qck ( kt   , cdtype, pun  , pvn, pwn, & 
     48      &                     ptrab, ptran , ptraa, kjpt   ) 
    4849      !!---------------------------------------------------------------------- 
    4950      !!                  ***  ROUTINE tra_adv_qck  *** 
    … …  
    6970      !!         dt = 2*rdtra and the scalar values are tb and sb 
    7071      !! 
    71       !!       On the vertical, the simple centered scheme used tn and sn 
     72      !!       On the vertical, the simple centered scheme used ptran 
    7273      !! 
    7374      !!               The fluxes are bounded by the ULTIMATE limiter to 
    … …  
    7576      !!            prevent the appearance of spurious numerical oscillations 
    7677      !! 
    77       !! ** Action : - update (ta,sa) with the now advective tracer trends 
    78       !!             - save the trends ('key_trdtra') 
     78      !! ** Action : - update (ptraa) with the now advective tracer trends 
     79      !!             - save the trends  
    7980      !! 
    8081      !! ** Reference : Leonard (1979, 1991) 
    8182      !!---------------------------------------------------------------------- 
    82       USE oce, ONLY :   ztrdt => ua   ! use ua as workspace 
    83       USE oce, ONLY :   ztrds => va   ! use va as workspace 
    84       !! 
    85       INTEGER , INTENT(in)                         ::  kt  ! ocean time-step index 
    86       REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) ::  pun ! effective ocean velocity, u_component 
    87       REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) ::  pvn ! effective ocean velocity, v_component 
    88       REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) ::  pwn ! effective ocean velocity, w_component 
    89       !! 
    90       INTEGER  ::   ji, jj, jk                          ! dummy loop indices 
    91       REAL(wp) ::   z_hdivn_x, z_hdivn_y, z_hdivn       ! temporary scalars 
    92       REAL(wp) ::   zbtr, z2                            !    "         " 
     83      !!* Arguments 
     84      INTEGER         , INTENT(in   )                               ::   kt              ! ocean time-step index 
     85      CHARACTER(len=3), INTENT(in   )                               ::   cdtype          ! =TRA or TRC (tracer indicator) 
     86      INTEGER         , INTENT(in   )                               ::   kjpt            ! number of tracers 
     87      REAL(wp)        , INTENT(in   ), DIMENSION(jpi,jpj,jpk)       ::   pun, pvn, pwn   ! 3 ocean velocity components 
     88      REAL(wp)        , INTENT(in   ), DIMENSION(jpi,jpj,jpk,kjpt)  ::   ptrab, ptran        ! before and now tracer fields 
     89      REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::   ptraa           ! tracer trend  
     90      !!* Local declarations 
     91      REAL(wp) ::   z2                            !    temporary scalar 
    9392      !!---------------------------------------------------------------------- 
    9493 
    … …  
    9897         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' 
    9998         IF(lwp) WRITE(numout,*) 
    100          btr2(:,:) = 1. / ( e1t(:,:) * e2t(:,:) ) 
    101          r1_6      = 1. / 6. 
     99         ! 
     100         l_trd = .FALSE. 
     101         IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 
    102102      ENDIF 
    103103 
    … …  
    109109      !--------------------------------------------------------------------------- 
    110110 
    111       CALL tra_adv_qck_i( pun, tb, tn, ta, ztrdt, z2) 
    112       CALL tra_adv_qck_i( pun, sb, sn, sa, ztrds, z2) 
    113  
    114       IF( l_trdtra ) CALL trd_mod(ztrdt, ztrds, jptra_trd_xad, 'TRA', kt) 
    115  
    116       CALL tra_adv_qck_j( kt, pvn, tb, tn, ta, ztrdt, pht_adv, z2) 
    117       CALL tra_adv_qck_j( kt, pvn, sb, sn, sa, ztrds, pst_adv, z2)   
    118  
    119       IF( l_trdtra ) THEN 
    120          CALL trd_mod(ztrdt, ztrds, jptra_trd_yad, 'TRA', kt) 
    121          ! 
    122          ztrdt(:,:,:) = ta(:,:,:)    ! Save the horizontal up-to-date ta/sa trends 
    123          ztrds(:,:,:) = sa(:,:,:) 
    124       END IF 
    125  
    126       IF(ln_ctl)   CALL prt_ctl( tab3d_1=ta, clinfo1=' qck had  - Ta: ', mask1=tmask, & 
    127          &                       tab3d_2=sa, clinfo2=           ' Sa: ', mask2=tmask, clinfo3='tra' ) 
     111      CALL tra_adv_qck_i( kt   , cdtype, pun  , z2,  & 
     112      &                   ptrab, ptran , ptraa, kjpt ) 
     113      CALL tra_adv_qck_j( kt   , cdtype, pvn  , z2,  & 
     114      &                   ptrab, ptran , ptraa, kjpt ) 
    128115 
    129116      ! II. The vertical fluxes are computed with the 2nd order centered scheme 
    130117      !------------------------------------------------------------------------- 
    131118      ! 
    132       CALL tra_adv_cen2_k( pwn, tn, ta ) 
    133       CALL tra_adv_cen2_k( pwn, sn, sa ) 
    134       ! 
    135       !Save the vertical advective trends for diagnostic 
    136       ! ---------------------------------------------------- 
    137       IF( l_trdtra )   THEN 
    138          ! Recompute the vertical advection zta & zsa trends computed 
    139          ! at the step 2. above in making the difference between the new 
    140          ! trends and the previous one: ta()/sa - ztrdt()/ztrds() and substract 
    141          ! the term tn()/sn()*hdivn() to recover the W gradz(T/S) trends 
    142  
    143          DO jk = 1, jpkm1 
     119      CALL tra_adv_cen2_k( kt   , cdtype, pwn,      & 
     120      &                    ptran, ptraa , kjpt      ) 
     121      ! 
     122   END SUBROUTINE tra_adv_qck 
     123 
     124   SUBROUTINE tra_adv_qck_i( kt   , cdtype, pun  , pz2,   & 
     125      &                      ptrab, ptran , ptraa, kjpt   ) 
     126      !!---------------------------------------------------------------------- 
     127      !! 
     128      !!---------------------------------------------------------------------- 
     129      !!* Module used 
     130      USE oce         , zwx => ua   ! use ua as workspace 
     131      !!* Arguments 
     132      INTEGER         , INTENT(in   )                               ::   kt              ! ocean time-step index 
     133      CHARACTER(len=3), INTENT(in   )                               ::   cdtype          ! =TRA or TRC (tracer indicator) 
     134      INTEGER         , INTENT(in   )                               ::   kjpt            ! number of tracers 
     135      REAL(wp)        , INTENT(in   ), DIMENSION(jpi,jpj,jpk)       ::   pun             ! zonal velocity component 
     136      REAL(wp)        , INTENT(in   ), DIMENSION(jpi,jpj,jpk,kjpt)  ::   ptrab, ptran    ! before tracer fields 
     137      REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::   ptraa           ! tracer trend  
     138      REAL(wp)        , INTENT(in   )                               ::   pz2 
     139      !!* Local declarations 
     140      INTEGER  :: ji, jj, jk, jn           ! dummy loop indices 
     141      REAL(wp) :: ztra, zbtr               ! temporary scalars 
     142      REAL(wp) :: zdir, zdx, zdt, zmsk     ! temporary scalars 
     143      REAL(wp), DIMENSION(jpi,jpj,jpk) ::  zfu, zfc, zfd 
     144      !---------------------------------------------------------------------- 
     145 
     146       
     147      DO jn = 1, kjpt                                            ! tracer loop 
     148         !                                                       ! =========== 
     149         zfu(:,:,:) = 0.0     ;   zfc(:,:,:) = 0.0   
     150         zfd(:,:,:) = 0.0     ;   zwx(:,:,:) = 0.0      
     151         !                                                   
     152         DO jk = 1, jpkm1                                 
     153            !                                              
     154            !--- Computation of the ustream and downstream value of the tracer and the mask 
    144155            DO jj = 2, jpjm1 
    145156               DO ji = fs_2, fs_jpim1   ! vector opt. 
    146 #if defined key_zco 
    147                   zbtr      = btr2(ji,jj) 
    148                   z_hdivn_x = e2u(ji,jj)*pun(ji,jj,jk) - e2u(ji-1,jj)*pun(ji-1,jj,jk) 
    149                   z_hdivn_y = e1v(ji,jj)*pvn(ji,jj,jk) - e1v(ji,jj-1)*pvn(ji,jj-1,jk) 
    150 #else 
    151                   zbtr      = btr2(ji,jj) / fse3t(ji,jj,jk) 
    152                   z_hdivn_x = e2u(ji,jj)*fse3u(ji,jj,jk)*pun(ji,jj,jk) - e2u(ji-1,jj)*fse3u(ji-1,jj,jk)*pun(ji-1,jj,jk) 
    153                   z_hdivn_y = e1v(ji,jj)*fse3v(ji,jj,jk)*pvn(ji,jj,jk) - e1v(ji,jj-1)*fse3v(ji,jj-1,jk)*pvn(ji,jj-1,jk) 
    154 #endif 
    155                   z_hdivn   = (z_hdivn_x + z_hdivn_y) * zbtr 
    156                   ztrdt(ji,jj,jk) = ta(ji,jj,jk) - ztrdt(ji,jj,jk) - tn(ji,jj,jk) * z_hdivn 
    157                   ztrds(ji,jj,jk) = sa(ji,jj,jk) - ztrds(ji,jj,jk) - sn(ji,jj,jk) * z_hdivn 
    158                END DO 
    159             END DO 
    160          END DO 
    161          CALL trd_mod(ztrdt, ztrds, jptra_trd_zad, 'TRA', kt) 
    162       ENDIF 
    163  
    164       IF(ln_ctl)   CALL prt_ctl( tab3d_1=ta, clinfo1=' qck zad  - Ta: ', mask1=tmask, & 
    165          &                       tab3d_2=sa, clinfo2=           ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    166       ! 
    167    END SUBROUTINE tra_adv_qck 
    168  
    169  
    170    SUBROUTINE tra_adv_qck_i ( pun, tra, tran, traa, ztrdtra, z2 ) 
    171       !!---------------------------------------------------------------------- 
    172       !! 
    173       !!---------------------------------------------------------------------- 
    174       REAL,     INTENT(in)                            :: z2 
    175       REAL(wp), INTENT(in)   , DIMENSION(jpi,jpj,jpk) :: pun, tra, tran  ! horizontal effective velocity 
    176       REAL(wp), INTENT(out)  , DIMENSION(jpi,jpj,jpk) :: ztrdtra 
    177       REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) :: traa 
    178       ! 
    179       INTEGER  :: ji, jj, jk 
    180       REAL(wp) :: za, zbtr, dir, dx, dt     ! temporary scalars 
    181       REAL(wp) :: z_hdivn_x 
    182       REAL(wp), DIMENSION(jpi,jpj)     ::  zmask, zupst, zdwst, zc_cfl 
    183       REAL(wp), DIMENSION(jpi,jpj)     ::  zfu, zfc, zfd, zfho, zmskl, zsc_e  
    184       REAL(wp), DIMENSION(jpi,jpj,jpk) ::  zflux 
    185       !---------------------------------------------------------------------- 
    186  
    187       zfu   (:,jpj) = 0.e0   ;   zfc   (:,jpj) = 0.e0 
    188       zfd   (:,jpj) = 0.e0   ;   zc_cfl(:,jpj) = 0.e0 
    189       zsc_e (:,jpj) = 0.e0   ;   zmskl (:,jpj) = 0.e0 
    190       zfho  (:,jpj) = 0.e0 
    191                                                        ! =============== 
    192       DO jk = 1, jpkm1                                 ! Horizontal slab 
    193          !                                             ! =============== 
    194          !--- Computation of the ustream and downstream value of the tracer and the mask 
    195          DO jj = 2, jpjm1 
    196             DO ji = 2, fs_jpim1   ! vector opt. 
    197                ! Upstream in the x-direction for the tracer 
    198                zupst(ji,jj)=tra(ji-1,jj,jk) 
    199                ! Downstream in the x-direction for the tracer 
    200                zdwst(ji,jj)=tra(ji+1,jj,jk) 
    201                ! Mask at the T-points in the x-direction (mask=0 or mask=1) 
    202                zmask(ji,jj)=tmask(ji-1,jj,jk)+tmask(ji,jj,jk)+tmask(ji+1,jj,jk)-2 
    203             END DO 
    204          END DO 
    205          ! 
    206          !--- Lateral boundary conditions  
    207          CALL lbc_lnk( zupst(:,:), 'T', 1. ) 
    208          CALL lbc_lnk( zdwst(:,:), 'T', 1. )  
    209          CALL lbc_lnk( zmask(:,:), 'T', 1. )  
     157                  ! Upstream in the x-direction for the tracer 
     158                  zfc(ji,jj,jk) = ptrab(ji-1,jj,jk,jn) 
     159                  ! Downstream in the x-direction for the tracer 
     160                  zfd(ji,jj,jk) = ptrab(ji+1,jj,jk,jn) 
     161               END DO 
     162            END DO 
     163         END DO 
     164         ! 
     165         !--- Lateral boundary conditions  
     166         CALL lbc_lnk( zfc(:,:,:), 'T', 1. )      ;     CALL lbc_lnk( zfd(:,:,:), 'T', 1. )  
     167          
    210168         ! 
    211169         ! Horizontal advective fluxes 
    212170         ! --------------------------- 
    213171         ! 
    214          dt = z2 * rdttra(jk) 
    215          !--- tracer flux at u-points 
    216          DO jj = 1, jpjm1 
    217             DO ji = 1, jpi 
    218 #if defined key_zco 
    219                zsc_e(ji,jj) = e2u(ji,jj) 
    220 #else 
    221                zsc_e(ji,jj) = e2u(ji,jj) * fse3u(ji,jj,jk) 
    222 #endif 
    223                dir = 0.5 + sign(0.5,pun(ji,jj,jk))                             ! if pun>0 : dir = 1 otherwise dir = 0 
    224                dx = dir * e1t(ji,jj) + (1-dir)* e1t(ji+1,jj) 
    225                zc_cfl (ji,jj) = ABS(pun(ji,jj,jk))*dt/dx                       ! (0<zc_cfl<1 : Courant number on x-direction) 
    226  
    227                zfu(ji,jj)   = dir*zupst(ji  ,jj   )+(1-dir)*zdwst(ji+1,jj   )  ! FU in the x-direction for T 
    228                zfc(ji,jj)   = dir*tra  (ji  ,jj,jk)+(1-dir)*tra  (ji+1,jj,jk)  ! FC in the x-direction for T 
    229                zfd(ji,jj)   = dir*tra  (ji+1,jj,jk)+(1-dir)*tra  (ji  ,jj,jk)  ! FD in the x-direction for T 
    230                zmskl(ji,jj) = dir*zmask(ji  ,jj)   +(1-dir)*zmask(ji+1,jj) 
    231            END DO 
    232          END DO 
    233          ! 
     172         DO jk = 1, jpkm1                              
     173            DO jj = 2, jpjm1 
     174               DO ji = fs_2, fs_jpim1   ! vector opt.          
     175                  zdir = 0.5 + SIGN( 0.5, pun(ji,jj,jk) )   ! if pun > 0 : zdir = 1 otherwise zdir = 0  
     176                  zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji+1,jj,jk)  ! FU in the x-direction for T  
     177               END DO 
     178            END DO 
     179         END DO 
     180         ! 
     181         DO jk = 1, jpkm1   
     182            zdt =  pz2 * rdttra(jk) 
     183            DO jj = 2, jpjm1 
     184               DO ji = fs_2, fs_jpim1   ! vector opt.    
     185                  zdir = 0.5 + SIGN( 0.5, pun(ji,jj,jk) )   ! if pun > 0 : zdir = 1 otherwise zdir = 0  
     186                  zdx  = ( zdir * e1t(ji,jj) + ( 1. - zdir ) * e1t(ji+1,jj) ) * e2u(ji,jj) * fse3u(ji,jj,jk) 
     187                  zwx(ji,jj,jk)  = ABS( pun(ji,jj,jk) ) * zdt / zdx    ! (0<zc_cfl<1 : Courant number on x-direction) 
     188                  zfc(ji,jj,jk)  = zdir * ptrab(ji  ,jj,jk,jn) + ( 1. - zdir ) * ptrab(ji+1,jj,jk,jn)  ! FC in the x-direction for T 
     189                  zfd(ji,jj,jk)  = zdir * ptrab(ji+1,jj,jk,jn) + ( 1. - zdir ) * ptrab(ji  ,jj,jk,jn)  ! FD in the x-direction for T 
     190               END DO 
     191            END DO 
     192         END DO      ! 
     193 
     194         !--- Lateral boundary conditions  
     195         CALL lbc_lnk( zfu(:,:,:), 'T', 1. )      ;     CALL lbc_lnk( zfd(:,:,:), 'T', 1. ) 
     196         CALL lbc_lnk( zfc(:,:,:), 'T', 1. )      ;     CALL lbc_lnk( zwx(:,:,:), 'T', 1. ) 
     197 
    234198         !--- QUICKEST scheme 
     199         CALL quickest( zfu, zfd, zfc, zwx ) 
     200         ! 
     201         ! Mask at the T-points in the x-direction (mask=0 or mask=1) 
     202         DO jk = 1, jpkm1   
     203            DO jj = 2, jpjm1 
     204               DO ji = fs_2, fs_jpim1   ! vector opt.                
     205                  zfu(ji,jj,jk) = tmask(ji-1,jj,jk) + tmask(ji,jj,jk) + tmask(ji+1,jj,jk) - 2. 
     206               ENDDO 
     207            END DO 
     208         END DO 
     209         !--- Lateral boundary conditions  
     210         CALL lbc_lnk( zfu(:,:,:), 'T', 1. )  
     211         ! 
    235212         ! Tracer flux on the x-direction 
    236          CALL quickest(zfu,zfd,zfc,zfho,zc_cfl) 
    237          !--- If the second ustream point is a land point 
    238          !--- the flux is computed by the 1st order UPWIND scheme 
    239          zfho(:,:) = zmskl(:,:)*zfho(:,:) + (1.-zmskl(:,:))*zfc(:,:) 
    240          !--- Computation of fluxes 
    241          zflux(:,:,jk) = zsc_e(:,:)*pun(:,:,jk)*zfho(:,:) 
    242          ! 
    243          !--- Tracer flux divergence at t-point added to the general trend 
    244          DO jj = 2, jpjm1 
    245             DO ji = fs_2, fs_jpim1   ! vector opt. 
    246                !--- horizontal advective trends 
    247 #if defined key_zco 
    248                zbtr = btr2(ji,jj) 
    249 #else 
    250                zbtr = btr2(ji,jj) / fse3t(ji,jj,jk)               
    251 #endif 
    252                za = - zbtr * ( zflux(ji,jj,jk) - zflux(ji-1,jj,jk) ) 
    253                !--- add it to the general tracer trends 
    254                traa(ji,jj,jk) = traa(ji,jj,jk) + za 
    255             END DO 
    256          END DO 
    257          !                                             ! =============== 
    258       END DO                                           !   End of slab 
    259       !                                                ! =============== 
    260       ! 
    261       !  Save the horizontal advective trends for diagnostic 
    262       ! ----------------------------------------------------- 
    263       IF( l_trdtra ) THEN 
    264          ! T/S ZONAL advection trends 
    265          ztrdtra(:,:,:) = 0.e0 
    266          ! 
    267          DO jk = 1, jpkm1 
     213         DO jk = 1, jpkm1   
     214            ! 
     215            DO jj = 2, jpjm1 
     216               DO ji = fs_2, fs_jpim1   ! vector opt.                
     217                  zdir = 0.5 + SIGN( 0.5, pun(ji,jj,jk) )   ! if pun > 0 : zdir = 1 otherwise zdir = 0  
     218                  !--- If the second ustream point is a land point 
     219                  !--- the flux is computed by the 1st order UPWIND scheme 
     220                  zmsk = zdir * zfu(ji,jj,jk) + ( 1. - zdir ) * zfu(ji+1,jj,jk) 
     221                  zwx(ji,jj,jk) = zmsk * zwx(ji,jj,jk) + ( 1. - zmsk ) * zfc(ji,jj,jk) 
     222                  zwx(ji,jj,jk) = zwx(ji,jj,jk) * pun(ji,jj,jk) 
     223               END DO 
     224            END DO 
     225            ! 
     226            ! Computation of the trend 
     227            DO jj = 2, jpjm1 
     228               DO ji = fs_2, fs_jpim1   ! vector opt.   
     229                  zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
     230                  ! horizontal advective trends 
     231                  ztra = - zbtr * ( zwx(ji,jj,jk) - zwx(ji-1,jj,jk) ) 
     232                  !--- add it to the general tracer trends 
     233                  ptraa(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn) + ztra 
     234               END DO 
     235            END DO 
     236            ! 
     237         END DO 
     238         !                                 ! trend diagnostics (contribution of upstream fluxes) 
     239         IF( l_trd )  CALL trd_tra( kt, cdtype, jn, jptra_trd_xad, zwx, pun, ptran(:,:,:,jn) ) 
     240         ! 
     241      END DO 
     242      ! 
     243   END SUBROUTINE tra_adv_qck_i 
     244 
     245   SUBROUTINE tra_adv_qck_j( kt   , cdtype, pvn  , pz2,   & 
     246      &                      ptrab, ptran , ptraa, kjpt   ) 
     247      !!---------------------------------------------------------------------- 
     248      !! 
     249      !!---------------------------------------------------------------------- 
     250      !!* Module used 
     251      USE oce         , zwy => ua   ! use ua as workspace 
     252      !!* Arguments 
     253      INTEGER         , INTENT(in   )                               ::   kt              ! ocean time-step index 
     254      CHARACTER(len=3), INTENT(in   )                               ::   cdtype          ! =TRA or TRC (tracer indicator) 
     255      INTEGER         , INTENT(in   )                               ::   kjpt            ! number of tracers 
     256      REAL(wp)        , INTENT(in   ), DIMENSION(jpi,jpj,jpk)       ::   pvn             ! meridional velocity component 
     257      REAL(wp)        , INTENT(in   ), DIMENSION(jpi,jpj,jpk,kjpt)  ::   ptrab, ptran    ! before tracer fields 
     258      REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::   ptraa           ! tracer trend  
     259      REAL(wp)        , INTENT(in   )                               ::   pz2 
     260      !!* Local declarations 
     261      INTEGER  :: ji, jj, jk, jn           ! dummy loop indices 
     262      REAL(wp) :: ztra, zbtr               ! temporary scalars 
     263      REAL(wp) :: zdir, zdx, zdt, zmsk     ! temporary scalars 
     264      REAL(wp), DIMENSION(jpi,jpj,jpk) ::  zfu, zfc, zfd 
     265      !---------------------------------------------------------------------- 
     266 
     267      DO jn = 1, kjpt                                            ! tracer loop 
     268         !                                                       ! =========== 
     269         zfu(:,:,:) = 0.0     ;   zfc(:,:,:) = 0.0   
     270         zfd(:,:,:) = 0.0     ;   zwy(:,:,:) = 0.0      
     271         !                                                   
     272         DO jk = 1, jpkm1                                 
     273            !                                              
     274            !--- Computation of the ustream and downstream value of the tracer and the mask 
    268275            DO jj = 2, jpjm1 
    269276               DO ji = fs_2, fs_jpim1   ! vector opt. 
    270                   !-- Compute zonal divergence by splitting hdivn (see divcur.F90) 
    271                   !   N.B. This computation is not valid along OBCs (if any) 
    272 #if defined key_zco 
    273                   zbtr      = btr2(ji,jj) 
    274                   z_hdivn_x = (  e2u(ji  ,jj) * pun(ji  ,jj,jk)                              & 
    275                      &         - e2u(ji-1,jj) * pun(ji-1,jj,jk) ) * zbtr 
    276 #else 
    277                   zbtr      = btr2(ji,jj) / fse3t(ji,jj,jk) 
    278                   z_hdivn_x = (  e2u(ji  ,jj) * fse3u(ji  ,jj,jk) * pun(ji  ,jj,jk)          & 
    279                      &         - e2u(ji-1,jj) * fse3u(ji-1,jj,jk) * pun(ji-1,jj,jk) ) * zbtr 
    280 #endif 
    281                   ztrdtra(ji,jj,jk) = - zbtr * ( zflux(ji,jj,jk) - zflux(ji-1,jj,jk) ) + tran(ji,jj,jk) * z_hdivn_x 
    282                END DO 
    283             END DO 
    284          END DO 
    285       END IF 
    286  
    287    END SUBROUTINE tra_adv_qck_i 
    288  
    289  
    290    SUBROUTINE tra_adv_qck_j ( kt, pvn, tra, tran, traa, ztrdtra, trd_adv, z2 ) 
    291       !!---------------------------------------------------------------------- 
    292       !! 
    293       !!---------------------------------------------------------------------- 
    294       INTEGER,  INTENT(in)                            :: kt              ! ocean time-step index 
    295       REAL,     INTENT(in)                            :: z2 
    296       REAL(wp), INTENT(in)   , DIMENSION(jpi,jpj,jpk) :: pvn, tra, tran  ! horizontal effective velocity 
    297       REAL(wp), INTENT(out)  , DIMENSION(jpj)         :: trd_adv 
    298       REAL(wp), INTENT(out)  , DIMENSION(jpi,jpj,jpk) :: ztrdtra 
    299       REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) :: traa 
    300       !! 
    301       INTEGER  :: ji, jj, jk 
    302       REAL(wp) :: za, zbtr, dir, dx, dt     ! temporary scalars 
    303       REAL(wp) :: z_hdivn_y 
    304       REAL(wp), DIMENSION(jpi,jpj)     ::  zmask, zupst, zdwst, zc_cfl 
    305       REAL(wp), DIMENSION(jpi,jpj)     ::  zfu, zfc, zfd, zfho, zmskl, zsc_e 
    306       REAL(wp), DIMENSION(jpi,jpj,jpk) ::  zflux 
    307       !---------------------------------------------------------------------- 
    308       ! II. Part 2 : y-direction 
    309       !---------------------------------------------------------------------- 
    310  
    311       zfu   (:,jpj) = 0.e0   ;   zfc   (:,jpj) = 0.e0 
    312       zfd   (:,jpj) = 0.e0   ;   zc_cfl(:,jpj) = 0.e0 
    313       zsc_e (:,jpj) = 0.e0   ;   zmskl (:,jpj) = 0.e0 
    314       zfho  (:,jpj) = 0.e0 
    315  
    316                                                        ! =============== 
    317       DO jk = 1, jpkm1                                 ! Horizontal slab 
    318          !                                             ! =============== 
    319          !--- Computation of the ustream and downstream value of the tracer and the mask 
    320          DO jj = 2, jpjm1 
    321             DO ji = 2, fs_jpim1   ! vector opt. 
    322                ! Upstream in the x-direction for the tracer 
    323                zupst(ji,jj)=tra(ji,jj-1,jk) 
    324                ! Downstream in the x-direction for the tracer 
    325                zdwst(ji,jj)=tra(ji,jj+1,jk) 
    326                ! Mask at the T-points in the x-direction (mask=0 or mask=1) 
    327                zmask(ji,jj)=tmask(ji,jj-1,jk)+tmask(ji,jj,jk)+tmask(ji,jj+1,jk)-2 
    328             END DO 
    329          END DO 
    330          ! 
    331          !--- Lateral boundary conditions 
    332          CALL lbc_lnk( zupst(:,:), 'T', 1. ) 
    333          CALL lbc_lnk( zdwst(:,:), 'T', 1. ) 
    334          CALL lbc_lnk( zmask(:,:), 'T', 1. ) 
     277                  ! Upstream in the x-direction for the tracer 
     278                  zfc(ji,jj,jk) = ptrab(ji,jj-1,jk,jn) 
     279                  ! Downstream in the x-direction for the tracer 
     280                  zfd(ji,jj,jk) = ptrab(ji,jj+1,jk,jn) 
     281               END DO 
     282            END DO 
     283         END DO 
     284         ! 
     285         !--- Lateral boundary conditions  
     286         CALL lbc_lnk( zfc(:,:,:), 'T', 1. )      ;     CALL lbc_lnk( zfd(:,:,:), 'T', 1. )  
     287          
    335288         ! 
    336289         ! Horizontal advective fluxes 
    337290         ! --------------------------- 
    338291         ! 
    339          dt = z2 * rdttra(jk) 
    340          !--- tracer flux at v-points 
    341          DO jj = 1, jpjm1 
     292         DO jk = 1, jpkm1                              
     293            DO jj = 2, jpjm1 
     294               DO ji = fs_2, fs_jpim1   ! vector opt.          
     295                  zdir = 0.5 + SIGN( 0.5, pvn(ji,jj,jk) )   ! if pun > 0 : zdir = 1 otherwise zdir = 0  
     296                  zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji,jj+1,jk)  ! FU in the x-direction for T  
     297               END DO 
     298            END DO 
     299         END DO 
     300         ! 
     301         DO jk = 1, jpkm1   
     302            zdt =  pz2 * rdttra(jk) 
     303            DO jj = 2, jpjm1 
     304               DO ji = fs_2, fs_jpim1   ! vector opt.    
     305                  zdir = 0.5 + SIGN( 0.5, pvn(ji,jj,jk) )   ! if pun > 0 : zdir = 1 otherwise zdir = 0  
     306                  zdx  = ( zdir * e2t(ji,jj) + ( 1. - zdir ) * e2t(ji,jj+1) ) * e1v(ji,jj) * fse3v(ji,jj,jk) 
     307                  zwy(ji,jj,jk)  = ABS( pvn(ji,jj,jk) ) * zdt / zdx    ! (0<zc_cfl<1 : Courant number on x-direction) 
     308                  zfc(ji,jj,jk)  = zdir * ptrab(ji,jj  ,jk,jn) + ( 1. - zdir ) * ptrab(ji,jj+1,jk,jn)  ! FC in the x-direction for T 
     309                  zfd(ji,jj,jk)  = zdir * ptrab(ji,jj+1,jk,jn) + ( 1. - zdir ) * ptrab(ji,jj  ,jk,jn)  ! FD in the x-direction for T 
     310               END DO 
     311            END DO 
     312         END DO      ! 
     313 
     314         !--- Lateral boundary conditions  
     315         CALL lbc_lnk( zfu(:,:,:), 'T', 1. )      ;     CALL lbc_lnk( zfd(:,:,:), 'T', 1. ) 
     316         CALL lbc_lnk( zfc(:,:,:), 'T', 1. )      ;     CALL lbc_lnk( zwy(:,:,:), 'T', 1. ) 
     317 
     318         !--- QUICKEST scheme 
     319         CALL quickest( zfu, zfd, zfc, zwy ) 
     320         ! 
     321         ! Mask at the T-points in the x-direction (mask=0 or mask=1) 
     322         DO jk = 1, jpkm1   
     323            DO jj = 2, jpjm1 
     324               DO ji = fs_2, fs_jpim1   ! vector opt.                
     325                  zfu(ji,jj,jk) = tmask(ji,jj-1,jk) + tmask(ji,jj,jk) + tmask(ji,jj+1,jk) - 2. 
     326               ENDDO 
     327            END DO 
     328         END DO 
     329         !--- Lateral boundary conditions  
     330         CALL lbc_lnk( zfu(:,:,:), 'T', 1. )  
     331         ! 
     332         ! Tracer flux on the x-direction 
     333         DO jk = 1, jpkm1   
     334            ! 
     335            DO jj = 2, jpjm1 
     336               DO ji = fs_2, fs_jpim1   ! vector opt.                
     337                  zdir = 0.5 + SIGN( 0.5, pvn(ji,jj,jk) )   ! if pun > 0 : zdir = 1 otherwise zdir = 0  
     338                  !--- If the second ustream point is a land point 
     339                  !--- the flux is computed by the 1st order UPWIND scheme 
     340                  zmsk = zdir * zfu(ji,jj,jk) + ( 1. - zdir ) * zfu(ji,jj+1,jk) 
     341                  zwy(ji,jj,jk) = zmsk * zwy(ji,jj,jk) + ( 1. - zmsk ) * zfc(ji,jj,jk) 
     342                  zwy(ji,jj,jk) = zwy(ji,jj,jk) * pvn(ji,jj,jk) 
     343               END DO 
     344            END DO 
     345            ! 
     346            ! Computation of the trend 
     347            DO jj = 2, jpjm1 
     348               DO ji = fs_2, fs_jpim1   ! vector opt.   
     349                  zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
     350                  ! horizontal advective trends 
     351                  ztra = - zbtr * ( zwy(ji,jj,jk) - zwy(ji,jj-1,jk) ) 
     352                  !--- add it to the general tracer trends 
     353                  ptraa(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn) + ztra 
     354               END DO 
     355            END DO 
     356            ! 
     357         END DO 
     358         !                                 ! trend diagnostics (contribution of upstream fluxes) 
     359         IF( l_trd )  CALL trd_tra( kt, cdtype, jn, jptra_trd_yad, zwy, pvn, ptran(:,:,:,jn) ) 
     360         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
     361         IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN   
     362           IF( jn == jp_tem )  pht_adv(:) = ptr_vj( zwy(:,:,:) ) 
     363           IF( jn == jp_sal )  pst_adv(:) = ptr_vj( zwy(:,:,:) ) 
     364         ENDIF 
     365         ! 
     366      END DO 
     367 
     368   END SUBROUTINE tra_adv_qck_j 
     369 
     370   SUBROUTINE tra_adv_cen2_k( kt   , cdtype, pwn,   & 
     371     &                        ptran, ptraa , kjpt   ) 
     372      !!---------------------------------------------------------------------- 
     373      !! 
     374      !!---------------------------------------------------------------------- 
     375      !!* Module used 
     376      USE oce         , zwz => ua   ! use ua as workspace 
     377      !!* Arguments 
     378      INTEGER         , INTENT(in   )                               ::   kt              ! ocean time-step index 
     379      CHARACTER(len=3), INTENT(in   )                               ::   cdtype          ! =TRA or TRC (tracer indicator) 
     380      INTEGER         , INTENT(in   )                               ::   kjpt            ! number of tracers 
     381      REAL(wp)        , INTENT(in   ), DIMENSION(jpi,jpj,jpk)       ::   pwn             ! vertical velocity component 
     382      REAL(wp)        , INTENT(in   ), DIMENSION(jpi,jpj,jpk,kjpt)  ::   ptran           ! now tracer field 
     383      REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::   ptraa           ! tracer trend  
     384      !!* Local declarations 
     385      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
     386      REAL(wp) ::   zbtr , ztra      ! temporary scalars 
     387      !!---------------------------------------------------------------------- 
     388 
     389      ! 
     390      DO jn = 1, kjpt                                            ! tracer loop 
     391         !                                                       ! =========== 
     392         ! 1. Bottom value : flux set to zero 
     393         zwz(:,:,jpk) = 0.e0             ! Bottom value : flux set to zero 
     394         ! 
     395         !                                 ! Surface value 
     396         IF( lk_vvl ) THEN   ;   zwz(:,:, 1 ) = 0.e0                      ! Variable volume : flux set to zero 
     397         ELSE                ;   zwz(:,:, 1 ) = pwn(:,:,1) * ptran(:,:,1,jn)   ! Constant volume : advective flux through the surface 
     398         ENDIF 
     399         ! 
     400         DO jk = 2, jpkm1                  ! Interior point: second order centered tracer flux at w-point 
     401            DO jj = 2, jpjm1 
     402               DO ji = fs_2, fs_jpim1   ! vector opt. 
     403                  zwz(ji,jj,jk) = 0.5 * pwn(ji,jj,jk) * ( ptran(ji,jj,jk-1,jn) + ptran(ji,jj,jk,jn) ) 
     404               END DO 
     405            END DO 
     406         END DO 
     407         ! 
     408         DO jk = 1, jpkm1          !==  Tracer flux divergence added to the general trend  ==! 
     409            DO jj = 2, jpjm1 
     410               DO ji = fs_2, fs_jpim1   ! vector opt. 
     411                  zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
     412                  ! k- vertical advective trends  
     413                  ztra = - zbtr * ( zwz(ji,jj,jk) - zwz(ji,jj,jk+1) )  
     414                  ! added to the general tracer trends 
     415                  ptraa(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn) + ztra 
     416               END DO 
     417            END DO 
     418         END DO 
     419         !                                 ! Save the vertical advective trends for diagnostic 
     420         IF( l_trd )  CALL trd_tra( kt, cdtype, jn, jptra_trd_zad, zwz, pwn, ptran(:,:,:,jn) ) 
     421         ! 
     422      END DO 
     423      ! 
     424   END SUBROUTINE tra_adv_cen2_k 
     425 
     426 
     427   SUBROUTINE quickest( pfu, pfd, pfc, puc ) 
     428      !!---------------------------------------------------------------------- 
     429      !! 
     430      !! ** Purpose :  Computation of advective flux with Quickest scheme 
     431      !! 
     432      !! ** Method :    
     433      !!---------------------------------------------------------------------- 
     434      REAL(wp), INTENT(in)    , DIMENSION(jpi,jpj,jpk) :: pfu   ! second upwind point 
     435      REAL(wp), INTENT(in)    , DIMENSION(jpi,jpj,jpk) :: pfd   ! first douwning point 
     436      REAL(wp), INTENT(in)    , DIMENSION(jpi,jpj,jpk) :: pfc   ! the central point (or the first upwind point) 
     437      REAL(wp), INTENT(inout) , DIMENSION(jpi,jpj,jpk) :: puc   ! input as Courant number ; output as flux 
     438      !! 
     439      INTEGER  ::  ji, jj, jk               ! dummy loop indices  
     440      REAL(wp) ::  zcoef1, zcoef2, zcoef3   ! temporary scalars           
     441      REAL(wp) ::  zc, zcurv, zfho          !  
     442      !---------------------------------------------------------------------- 
     443 
     444      DO jk = 1, jpkm1 
     445         DO jj = 1, jpj 
    342446            DO ji = 1, jpi 
    343 #if defined key_zco 
    344                zsc_e(ji,jj) = e1v(ji,jj) 
    345 #else 
    346                zsc_e(ji,jj) = e1v(ji,jj) * fse3v(ji,jj,jk) 
    347 #endif 
    348                dir = 0.5 + sign(0.5,pvn(ji,jj,jk))                             ! if pvn>0 : dir = 1 otherwise dir = 0 
    349                dx = dir * e2t(ji,jj) + (1-dir)* e2t(ji,jj+1) 
    350                zc_cfl(ji,jj) = ABS(pvn(ji,jj,jk))*dt/dx                        ! (0<zc_cfl<1 : Courant number on y-direction) 
    351  
    352                zfu(ji,jj)   = dir*zupst(ji,jj     )+(1-dir)*zdwst(ji,jj+1   )  ! FU in the y-direction for T 
    353                zfc(ji,jj)   = dir*tra  (ji,jj  ,jk)+(1-dir)*tra  (ji,jj+1,jk)  ! FC in the y-direction for T 
    354                zfd(ji,jj)   = dir*tra  (ji,jj+1,jk)+(1-dir)*tra  (ji,jj  ,jk)  ! FD in the y-direction for T 
    355                zmskl(ji,jj) = dir*zmask(ji,jj     )+(1-dir)*zmask(ji,jj+1) 
    356             END DO 
    357          END DO 
    358          ! 
    359          !--- QUICKEST scheme 
    360          ! Tracer flux on the y-direction 
    361          CALL quickest(zfu,zfd,zfc,zfho,zc_cfl) 
    362          !--- If the second ustream point is a land point 
    363          !--- the flux is computed by the 1st order UPWIND scheme 
    364          zfho(:,:) = zmskl(:,:)*zfho(:,:) + (1.-zmskl(:,:))*zfc(:,:) 
    365          !--- Computation of fluxes 
    366          zflux(:,:,jk) = zsc_e(:,:)*pvn(:,:,jk)*zfho(:,:) 
    367          ! 
    368          !--- Tracer flux divergence at t-point added to the general trend 
    369          DO jj = 2, jpjm1 
    370             DO ji = fs_2, fs_jpim1   ! vector opt. 
    371                !--- horizontal advective trends 
    372 #if defined key_zco 
    373                zbtr = btr2(ji,jj) 
    374 #else 
    375                zbtr = btr2(ji,jj) / fse3t(ji,jj,jk) 
    376 #endif 
    377                za = - zbtr * ( zflux(ji,jj,jk) - zflux(ji,jj-1,jk) ) 
    378                !--- add it to the general tracer trends 
    379                traa(ji,jj,jk) = traa(ji,jj,jk) + za 
    380             END DO 
    381          END DO 
    382          !                                             ! =============== 
    383       END DO                                           !   End of slab 
    384       !                                                ! =============== 
    385       ! 
    386       !  Save the horizontal advective trends for diagnostic 
    387       ! ----------------------------------------------------- 
    388       IF( l_trdtra ) THEN 
    389          ! T/S MERIDIONAL advection trends 
    390          DO jk = 1, jpkm1 
    391             DO jj = 2, jpjm1 
    392                DO ji = fs_2, fs_jpim1   ! vector opt. 
    393                   !-- Compute merid. divergence by splitting hdivn (see divcur.F90) 
    394                   !   N.B. This computation is not valid along OBCs (if any) 
    395 #if defined key_zco 
    396                   zbtr      = btr2(ji,jj) 
    397                   z_hdivn_y = (  e1v(ji,jj  ) * pvn(ji,jj  ,jk)                              & 
    398                      &         - e1v(ji,jj-1) * pvn(ji,jj-1,jk) ) * zbtr 
    399 #else 
    400                   zbtr      = btr2(ji,jj) / fse3t(ji,jj,jk) 
    401                   z_hdivn_y = (  e1v(ji,  jj) * fse3v(ji,jj  ,jk) * pvn(ji,jj  ,jk)          & 
    402                      &         - e1v(ji,jj-1) * fse3v(ji,jj-1,jk) * pvn(ji,jj-1,jk) ) * zbtr 
    403 #endif 
    404                   ztrdtra(ji,jj,jk) = - zbtr * ( zflux(ji,jj,jk) - zflux(ji,jj-1,jk) ) + tran(ji,jj,jk) * z_hdivn_y 
    405                END DO 
    406             END DO 
    407          END DO 
    408       END IF 
    409  
    410       ! "zonal" mean advective heat and salt transport 
    411       ! ---------------------------------------------- 
    412  
    413       IF( ln_diaptr .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN 
    414          IF( lk_zco ) THEN 
    415             DO jk = 1, jpkm1 
    416                DO jj = 2, jpjm1 
    417                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    418                     zflux(ji,jj,jk) = zflux(ji,jj,jk) * fse3v(ji,jj,jk) 
    419                   END DO 
    420                END DO 
    421             END DO 
    422          ENDIF 
    423          trd_adv(:) = ptr_vj( zflux(:,:,:) ) 
    424       ENDIF 
    425  
    426    END SUBROUTINE tra_adv_qck_j 
    427  
    428  
    429    SUBROUTINE tra_adv_cen2_k ( pwn, ptn, pta ) 
    430       !!---------------------------------------------------------------------- 
    431       !! 
    432       !!---------------------------------------------------------------------- 
    433       REAL(wp), INTENT(in   ), DIMENSION(jpi,jpj,jpk)  :: pwn   ! vertical effective velocity 
    434       REAL(wp), INTENT(in   ), DIMENSION(jpi,jpj,jpk)  :: ptn   ! now tracer 
    435       REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk)  :: pta   ! tracer general trend 
    436       !! 
    437       INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    438       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zflux   ! 3D workspace 
    439       !!---------------------------------------------------------------------- 
    440       ! 
    441       !                         !==  Vertical advective fluxes  ==! 
    442       zflux(:,:,jpk) = 0.e0             ! Bottom value : flux set to zero 
    443       ! 
    444       !                                 ! Surface value 
    445       IF( lk_vvl ) THEN   ;   zflux(:,:, 1 ) = 0.e0                      ! Variable volume : flux set to zero 
    446       ELSE                ;   zflux(:,:, 1 ) = pwn(:,:,1) * ptn(:,:,1)   ! Constant volume : advective flux through the surface 
    447       ENDIF 
    448       ! 
    449       DO jk = 2, jpkm1                  ! Interior point: second order centered tracer flux at w-point 
    450          DO jj = 2, jpjm1 
    451             DO ji = fs_2, fs_jpim1   ! vector opt. 
    452                zflux(ji,jj,jk) = 0.5 * pwn(ji,jj,jk) * ( ptn(ji,jj,jk-1) + ptn(ji,jj,jk) ) 
    453             END DO 
    454          END DO 
    455       END DO 
    456       ! 
    457       DO jk = 1, jpkm1          !==  Tracer flux divergence added to the general trend  ==! 
    458          DO jj = 2, jpjm1 
    459             DO ji = fs_2, fs_jpim1   ! vector opt. 
    460                pta(ji,jj,jk) =  pta(ji,jj,jk) - ( zflux(ji,jj,jk) - zflux(ji,jj,jk+1) )   & 
    461                   &                           /   fse3t(ji,jj,jk) 
    462             END DO 
    463          END DO 
    464       END DO 
    465       ! 
    466    END SUBROUTINE tra_adv_cen2_k 
    467  
    468  
    469    SUBROUTINE quickest( fu, fd, fc, fho, fc_cfl ) 
    470       !!---------------------------------------------------------------------- 
    471       !! 
    472       !!---------------------------------------------------------------------- 
    473       REAL(wp), INTENT(in)  , DIMENSION(jpi,jpj) :: fu, fd, fc, fc_cfl   
    474       REAL(wp), INTENT(out) , DIMENSION(jpi,jpj) :: fho 
    475       REAL(wp)              , DIMENSION(jpi,jpj) :: zcurv, zcoef1, zcoef2, zcoef3  ! temporary scalars 
    476       ! 
    477       zcurv (:,:) = fd(:,:) + fu(:,:) - 2.*fc(:,:) 
    478       zcoef1(:,:) = 0.5*( fc(:,:) + fd(:,:) ) 
    479       zcoef2(:,:) = 0.5*fc_cfl(:,:)*( fd(:,:) - fc(:,:) ) 
    480       zcoef3(:,:) = ( ( 1. - ( fc_cfl(:,:)*fc_cfl(:,:) ) )*r1_6 )*zcurv(:,:) 
    481       fho   (:,:) = zcoef1(:,:) - zcoef2(:,:) - zcoef3(:,:)                         ! phi_f QUICKEST  
    482       ! 
    483       zcoef1(:,:) = fd(:,:) - fu(:,:)                                               ! DEL 
    484       zcoef2(:,:) = ABS( zcoef1(:,:) )                                              ! ABS(DEL) 
    485       zcoef3(:,:) = ABS( zcurv(:,:) )                                               ! ABS(CURV) 
    486       ! 
    487       WHERE ( zcoef3(:,:) >= zcoef2(:,:) )  
    488         fho(:,:) = fc(:,:) 
    489       ELSEWHERE 
    490         zcoef3(:,:) = fu(:,:) + ( ( fc(:,:) - fu(:,:) )/MAX(fc_cfl(:,:),1.e-9) )    ! phi_REF 
    491           WHERE ( zcoef1(:,:) >= 0.e0 ) 
    492             fho(:,:) = MAX(fc(:,:),fho(:,:)) 
    493             fho(:,:) = MIN(fho(:,:),MIN(zcoef3(:,:),fd(:,:))) 
    494           ELSEWHERE 
    495             fho(:,:) = MIN(fc(:,:),fho(:,:)) 
    496             fho(:,:) = MAX(fho(:,:),MAX(zcoef3(:,:),fd(:,:))) 
    497           ENDWHERE 
    498       ENDWHERE 
     447               zc     = puc(ji,jj,jk)                         ! Courant number 
     448               zcurv  = pfd(ji,jj,jk) + pfu(ji,jj,jk) - 2. * pfc(ji,jj,jk) 
     449               zcoef1 = 0.5 *      ( pfc(ji,jj,jk) + pfd(ji,jj,jk) ) 
     450               zcoef2 = 0.5 * zc * ( pfd(ji,jj,jk) - pfc(ji,jj,jk) ) 
     451               zcoef3 = ( 1. - ( zc * zc ) ) * r1_6 * zcurv 
     452               zfho   = zcoef1 - zcoef2 - zcoef3              !  phi_f QUICKEST  
     453               ! 
     454               zcoef1 = pfd(ji,jj,jk) - pfu(ji,jj,jk) 
     455               zcoef2 = ABS( zcoef1 ) 
     456               zcoef3 = ABS( zcurv ) 
     457               IF( zcoef3 >= zcoef2 ) THEN 
     458                  zfho = pfc(ji,jj,jk)  
     459               ELSE 
     460                  zcoef3 = pfu(ji,jj,jk) + ( ( pfc(ji,jj,jk) - pfu(ji,jj,jk) ) / MAX( zc, 1.e-9 ) )    ! phi_REF 
     461                  IF( zcoef1 >= 0. ) THEN 
     462                     zfho = MAX( pfc(ji,jj,jk), zfho )  
     463                     zfho = MIN( zfho, MIN( zcoef3, pfd(ji,jj,jk) ) )  
     464                  ELSE 
     465                     zfho = MIN( pfc(ji,jj,jk), zfho )  
     466                     zfho = MAX( zfho, MAX( zcoef3, pfd(ji,jj,jk) ) )  
     467                  ENDIF 
     468               ENDIF 
     469               puc(ji,jj,jk) = zfho 
     470            ENDDO 
     471         ENDDO 
     472      ENDDO 
    499473      ! 
    500474   END SUBROUTINE quickest 

  • branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/traadv_tvd.F90

    r1970 r2024  
    22   !!============================================================================== 
    33   !!                       ***  MODULE  traadv_tvd  *** 
    4    !! Ocean active tracers:  horizontal & vertical advective trend 
     4   !! Ocean tracers:  horizontal & vertical advective trend 
    55   !!============================================================================== 
    66   !! History :       !  95-12  (L. Mortier)  Original code 
    … …  
    88   !!                 !  00-10  (MA Foujols E.Kestenare)  include file not routine 
    99   !!                 !  00-12  (E. Kestenare M. Levy)  fix bug in trtrd indexes 
    10    !!                 !  01-07  (E. Durand G. Madec)  adaptation to ORCA config 
     10   !!                 !  01-07  (E. Durand G. Madec)  adaptraation to ORCA config 
    1111   !!            8.5  !  02-06  (G. Madec)  F90: Free form and module 
    1212   !!            9.0  !  04-01  (A. de Miranda, G. Madec, J.M. Molines ): advective bbl 
    1313   !!            9.0  !  08-04  (S. Cravatte) add the i-, j- & k- trends computation 
    14    !!            " "  !  05-11  (V. Garnier) Surface pressure gradient organization 
     14   !!            " "  !  09-11  (V. Garnier) Surface pressure gradient organization 
     15   !!            3.3  !  10-05 (C. Ethe, G. Madec)  merge TRC-TRA + switch from velocity to transport 
    1516   !!---------------------------------------------------------------------- 
    1617 
    … …  
    2425   USE oce             ! ocean dynamics and active tracers 
    2526   USE dom_oce         ! ocean space and time domain 
    26    USE trdmod          ! ocean active tracers trends  
    27    USE trdmod_oce      ! ocean variables trends 
     27   USE trdmod_oce      ! tracers trends 
     28   USE trdtra      ! tracers trends 
    2829   USE in_out_manager  ! I/O manager 
    2930   USE dynspg_oce      ! choice/control of key cpp for surface pressure gradient 
    30    USE trabbl          ! Advective term of BBL 
    3131   USE lib_mpp 
    3232   USE lbclnk          ! ocean lateral boundary condition (or mpp link)  
    3333   USE diaptr          ! poleward transport diagnostics 
    34    USE prtctl          ! Print control 
    3534 
    3635 
    … …  
    3938 
    4039   PUBLIC   tra_adv_tvd    ! routine called by step.F90 
     40 
     41   LOGICAL  :: l_trd       ! flag to compute trends 
    4142 
    4243   !! * Substitutions 
    … …  
    5152CONTAINS 
    5253 
    53    SUBROUTINE tra_adv_tvd( kt, pun, pvn, pwn ) 
     54   SUBROUTINE tra_adv_tvd ( kt   , cdtype, pun  , pvn, pwn, & 
     55      &                     ptrab, ptran , ptraa, kjpt   ) 
    5456      !!---------------------------------------------------------------------- 
    5557      !!                  ***  ROUTINE tra_adv_tvd  *** 
    … …  
    6264      !!       note: - this advection scheme needs a leap-frog time scheme 
    6365      !! 
    64       !! ** Action : - update (ta,sa) with the now advective tracer trends 
    65       !!             - save the trends in (ztrdt,ztrds) ('key_trdtra') 
    66       !!---------------------------------------------------------------------- 
    67       USE oce              , ztrdt => ua   ! use ua as workspace 
    68       USE oce              , ztrds => va   ! use va as workspace 
    69       !! 
    70       INTEGER , INTENT(in)                         ::   kt    ! ocean time-step index 
    71       REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) ::   pun   ! ocean velocity u-component 
    72       REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) ::   pvn   ! ocean velocity v-component 
    73       REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) ::   pwn   ! ocean velocity w-component 
    74       !! 
    75       INTEGER  ::   ji, jj, jk              ! dummy loop indices 
    76       REAL(wp) ::                        &  ! temporary scalar 
    77          ztat, zsat,                     &  !    "         "    
    78          z_hdivn_x, z_hdivn_y, z_hdivn 
     66      !! ** Action : - update (ptraa) with the now advective tracer trends 
     67      !!             - save the trends  
     68      !!---------------------------------------------------------------------- 
     69      !!* Module used 
     70      USE oce         , zwx => ua   ! use ua as workspace 
     71      USE oce         , zwy => va   ! use va as workspace 
     72      !!* Arguments 
     73      INTEGER         , INTENT(in   )                               ::   kt              ! ocean time-step index 
     74      CHARACTER(len=3), INTENT(in   )                               ::   cdtype          ! =TRA or TRC (tracer indicator) 
     75      INTEGER         , INTENT(in   )                               ::   kjpt            ! number of tracers 
     76      REAL(wp)        , INTENT(in   ), DIMENSION(jpi,jpj,jpk)       ::   pun, pvn, pwn   ! 3 ocean velocity components 
     77      REAL(wp)        , INTENT(in   ), DIMENSION(jpi,jpj,jpk,kjpt)  ::   ptrab, ptran        ! before and now tracer fields 
     78      REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::   ptraa           ! tracer trend  
     79      !!* Local declarations 
     80      INTEGER  ::   ji, jj, jk, jn          ! dummy loop indices   
    7981      REAL(wp) ::   & 
    80          z2dtt, zbtr, zeu, zev,          &  ! temporary scalar 
    81          zew, z2, zbtr1,                 &  ! temporary scalar 
    82          zfp_ui, zfp_vj, zfp_wk,         &  !    "         " 
    83          zfm_ui, zfm_vj, zfm_wk             !    "         " 
    84       REAL(wp), DIMENSION (jpi,jpj,jpk) ::   zti, ztu, ztv, ztw   ! temporary workspace 
    85       REAL(wp), DIMENSION (jpi,jpj,jpk) ::   zsi, zsu, zsv, zsw   !    "           " 
    86       !!---------------------------------------------------------------------- 
    87  
    88       zti(:,:,:) = 0.e0   ;   zsi(:,:,:) = 0.e0 
     82         z2, z2dtt, zbtr, ztra,              &  ! temporary scalar 
     83         zfp_ui, zfp_vj, zfp_wk,             &  !    "         " 
     84         zfm_ui, zfm_vj, zfm_wk                 !    "         " 
     85      REAL(wp), DIMENSION (jpi,jpj,jpk) ::   zwi, zwz   ! temporary workspace 
     86      REAL(wp), DIMENSION (:,:,:), ALLOCATABLE :: ztrdx, ztrdy, ztrdz 
     87      !!---------------------------------------------------------------------- 
     88 
     89      zwi(:,:,:) = 0.e0 
    8990 
    9091      IF( kt == nit000 .AND. lwp ) THEN 
    … …  
    9293         WRITE(numout,*) 'tra_adv_tvd : TVD advection scheme' 
    9394         WRITE(numout,*) '~~~~~~~~~~~' 
     95         ! 
     96         l_trd = .FALSE. 
     97         IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 
    9498      ENDIF 
    95  
     99      ! 
     100      IF( l_trd )  THEN 
     101        ALLOCATE( ztrdx(jpi,jpj,jpk) )      ;      ztrdx(:,:,:) = 0. 
     102        ALLOCATE( ztrdy(jpi,jpj,jpk) )      ;      ztrdy(:,:,:) = 0. 
     103        ALLOCATE( ztrdz(jpi,jpj,jpk) )      ;      ztrdz(:,:,:) = 0. 
     104      END IF 
     105      ! 
    96106      IF( neuler == 0 .AND. kt == nit000 ) THEN   ;    z2 = 1. 
    97107      ELSE                                        ;    z2 = 2. 
    98108      ENDIF 
    99  
    100       ! 1. Bottom value : flux set to zero 
    101       ! --------------- 
    102       ztu(:,:,jpk) = 0.e0   ;   zsu(:,:,jpk) = 0.e0 
    103       ztv(:,:,jpk) = 0.e0   ;   zsv(:,:,jpk) = 0.e0 
    104       ztw(:,:,jpk) = 0.e0   ;   zsw(:,:,jpk) = 0.e0 
    105       zti(:,:,jpk) = 0.e0   ;   zsi(:,:,jpk) = 0.e0 
    106  
    107  
    108       ! 2. upstream advection with initial mass fluxes & intermediate update 
    109       ! -------------------------------------------------------------------- 
    110       ! upstream tracer flux in the i and j direction 
    111       DO jk = 1, jpkm1 
    112          DO jj = 1, jpjm1 
    113             DO ji = 1, fs_jpim1   ! vector opt. 
    114                zeu = 0.5 * e2u(ji,jj) * fse3u(ji,jj,jk) * pun(ji,jj,jk) 
    115                zev = 0.5 * e1v(ji,jj) * fse3v(ji,jj,jk) * pvn(ji,jj,jk) 
    116                ! upstream scheme 
    117                zfp_ui = zeu + ABS( zeu ) 
    118                zfm_ui = zeu - ABS( zeu ) 
    119                zfp_vj = zev + ABS( zev ) 
    120                zfm_vj = zev - ABS( zev ) 
    121                ztu(ji,jj,jk) = zfp_ui * tb(ji,jj,jk) + zfm_ui * tb(ji+1,jj  ,jk) 
    122                ztv(ji,jj,jk) = zfp_vj * tb(ji,jj,jk) + zfm_vj * tb(ji  ,jj+1,jk) 
    123                zsu(ji,jj,jk) = zfp_ui * sb(ji,jj,jk) + zfm_ui * sb(ji+1,jj  ,jk) 
    124                zsv(ji,jj,jk) = zfp_vj * sb(ji,jj,jk) + zfm_vj * sb(ji  ,jj+1,jk) 
    125             END DO 
    126          END DO 
    127       END DO 
    128  
    129       ! upstream tracer flux in the k direction 
    130       ! Surface value 
    131       IF( lk_vvl ) THEN 
    132          ! variable volume : flux set to zero 
    133          ztw(:,:,1) = 0.e0 
    134          zsw(:,:,1) = 0.e0 
    135       ELSE 
    136          ! free surface-constant volume 
    137          DO jj = 1, jpj 
    138             DO ji = 1, jpi 
    139                zew = e1t(ji,jj) * e2t(ji,jj) * pwn(ji,jj,1) 
    140                ztw(ji,jj,1) = zew * tb(ji,jj,1) 
    141                zsw(ji,jj,1) = zew * sb(ji,jj,1) 
    142             END DO 
    143          END DO 
    144       ENDIF 
    145  
    146       ! Interior value 
    147       DO jk = 2, jpkm1 
    148          DO jj = 1, jpj 
    149             DO ji = 1, jpi 
    150                zew = 0.5 * e1t(ji,jj) * e2t(ji,jj) * pwn(ji,jj,jk) 
    151                zfp_wk = zew + ABS( zew ) 
    152                zfm_wk = zew - ABS( zew ) 
    153                ztw(ji,jj,jk) = zfp_wk * tb(ji,jj,jk) + zfm_wk * tb(ji,jj,jk-1) 
    154                zsw(ji,jj,jk) = zfp_wk * sb(ji,jj,jk) + zfm_wk * sb(ji,jj,jk-1) 
    155             END DO 
    156          END DO 
    157       END DO 
    158  
    159       ! total advective trend 
    160       DO jk = 1, jpkm1 
    161          z2dtt = z2 * rdttra(jk) 
    162          DO jj = 2, jpjm1 
    163             DO ji = fs_2, fs_jpim1   ! vector opt. 
    164                zbtr = 1./ ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    165                ! total intermediate advective trends 
    166                ztat = - ( ztu(ji,jj,jk) - ztu(ji-1,jj  ,jk  )   & 
    167                   &     + ztv(ji,jj,jk) - ztv(ji  ,jj-1,jk  )   & 
    168                   &     + ztw(ji,jj,jk) - ztw(ji  ,jj  ,jk+1) ) * zbtr 
    169                zsat = - ( zsu(ji,jj,jk) - zsu(ji-1,jj  ,jk  )   &  
    170                   &     + zsv(ji,jj,jk) - zsv(ji  ,jj-1,jk  )   & 
    171                   &     + zsw(ji,jj,jk) - zsw(ji  ,jj  ,jk+1) ) * zbtr 
    172                ! update and guess with monotonic sheme 
    173                ta(ji,jj,jk) =  ta(ji,jj,jk) + ztat 
    174                sa(ji,jj,jk) =  sa(ji,jj,jk) + zsat 
    175                zti (ji,jj,jk) = ( tb(ji,jj,jk) + z2dtt * ztat ) * tmask(ji,jj,jk) 
    176                zsi (ji,jj,jk) = ( sb(ji,jj,jk) + z2dtt * zsat ) * tmask(ji,jj,jk) 
    177             END DO 
    178          END DO 
    179       END DO 
    180  
    181       ! "zonal" mean advective heat and salt transport 
    182       IF( ln_diaptr .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN 
    183          pht_adv(:) = ptr_vj( ztv(:,:,:) ) 
    184          pst_adv(:) = ptr_vj( zsv(:,:,:) ) 
    185       ENDIF 
    186  
    187       ! Save the intermediate i / j / k advective trends for diagnostics 
    188       ! ------------------------------------------------------------------- 
    189       ! Warning : We should use zun instead of un in the computations below, but we 
    190       ! also use hdivn which is computed with un, vn (check ???). So we use un, vn 
    191       ! for consistency. Results are therefore approximate with key_trabbl_adv. 
    192  
    193       IF( l_trdtra ) THEN 
    194          ztrdt(:,:,:) = 0.e0   ;   ztrds(:,:,:) = 0.e0 
    195          !  
    196          ! T/S ZONAL advection trends 
     109      ! 
     110      !                                                          ! =========== 
     111      DO jn = 1, kjpt                                            ! tracer loop 
     112         !                                                       ! =========== 
     113         ! 1. Bottom value : flux set to zero 
     114         ! ---------------------------------- 
     115         zwx(:,:,jpk) = 0.e0    ;    zwz(:,:,jpk) = 0.e0 
     116         zwy(:,:,jpk) = 0.e0    ;    zwi(:,:,jpk) = 0.e0 
     117 
     118         ! 2. upstream advection with initial mass fluxes & intermediate update 
     119         ! -------------------------------------------------------------------- 
     120         ! upstream tracer flux in the i and j direction 
    197121         DO jk = 1, jpkm1 
     122            DO jj = 1, jpjm1 
     123               DO ji = 1, fs_jpim1   ! vector opt. 
     124                  ! upstream scheme 
     125                  zfp_ui = pun(ji,jj,jk) + ABS( pun(ji,jj,jk) ) 
     126                  zfm_ui = pun(ji,jj,jk) - ABS( pun(ji,jj,jk) ) 
     127                  zfp_vj = pvn(ji,jj,jk) + ABS( pvn(ji,jj,jk) ) 
     128                  zfm_vj = pvn(ji,jj,jk) - ABS( pvn(ji,jj,jk) ) 
     129                  zwx(ji,jj,jk) = 0.5 * ( zfp_ui * ptrab(ji,jj,jk,jn) + zfm_ui * ptrab(ji+1,jj  ,jk,jn) ) 
     130                  zwy(ji,jj,jk) = 0.5 * ( zfp_vj * ptrab(ji,jj,jk,jn) + zfm_vj * ptrab(ji  ,jj+1,jk,jn) ) 
     131               END DO 
     132            END DO 
     133         END DO 
     134 
     135         ! upstream tracer flux in the k direction 
     136         ! Surface value 
     137         IF( lk_vvl ) THEN   ;   zwz(:,:, 1 ) = 0.e0                         ! volume variable 
     138         ELSE                ;   zwz(:,:, 1 ) = pwn(:,:,1) * ptrab(:,:,1,jn)   ! linear free surface  
     139         ENDIF 
     140         ! Interior value 
     141         DO jk = 2, jpkm1 
     142            DO jj = 1, jpj 
     143               DO ji = 1, jpi 
     144                  zfp_wk = pwn(ji,jj,jk) + ABS( pwn(ji,jj,jk) ) 
     145                  zfm_wk = pwn(ji,jj,jk) - ABS( pwn(ji,jj,jk) ) 
     146                  zwz(ji,jj,jk) = 0.5 * ( zfp_wk * ptrab(ji,jj,jk,jn) + zfm_wk * ptrab(ji,jj,jk-1,jn) ) 
     147               END DO 
     148            END DO 
     149         END DO 
     150 
     151         ! total advective trend 
     152         DO jk = 1, jpkm1 
     153            z2dtt = z2 * rdttra(jk) 
    198154            DO jj = 2, jpjm1 
    199155               DO ji = fs_2, fs_jpim1   ! vector opt. 
    200156                  zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    201                   ztrdt(ji,jj,jk) = - ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) ) * zbtr 
    202                   ztrds(ji,jj,jk) = - ( zsu(ji,jj,jk) - zsu(ji-1,jj,jk) ) * zbtr 
    203                END DO 
    204             END DO 
    205          END DO 
    206          CALL trd_mod(ztrdt, ztrds, jptra_trd_xad, 'TRA', kt)    ! save the trends 
    207          ! 
    208          ! T/S MERIDIONAL advection trends 
     157                  ! total intermediate advective trends 
     158                  ztra = - zbtr * (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
     159                     &             + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   & 
     160                     &             + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) 
     161                  ! update and guess with monotonic sheme 
     162                  ptraa(ji,jj,jk,jn) =   ptraa(ji,jj,jk,jn)         + ztra 
     163                  zwi(ji,jj,jk)    = ( ptrab(ji,jj,jk,jn) + z2dtt * ztra ) * tmask(ji,jj,jk) 
     164               END DO 
     165            END DO 
     166         END DO 
     167         !                             ! Lateral boundary conditions on zwi  (unchanged sign) 
     168         CALL lbc_lnk( zwi, 'T', 1. )   
     169 
     170         !                                 ! trend diagnostics (contribution of upstream fluxes) 
     171         IF( l_trd )  THEN  
     172            ! store intermediate advective trends 
     173            ztrdx(:,:,:) = zwx(:,:,:)   ;    ztrdy(:,:,:) = zwy(:,:,:)  ;   ztrdz(:,:,:) = zwz(:,:,:) 
     174         END IF 
     175         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
     176         IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN   
     177           IF( jn == jp_tem )  pht_adv(:) = ptr_vj( zwy(:,:,:) ) 
     178           IF( jn == jp_sal )  pst_adv(:) = ptr_vj( zwy(:,:,:) ) 
     179         ENDIF 
     180 
     181         ! 3. antidiffusive flux : high order minus low order 
     182         ! -------------------------------------------------- 
     183         ! antidiffusive flux on i and j 
     184         DO jk = 1, jpkm1 
     185            DO jj = 1, jpjm1 
     186               DO ji = 1, fs_jpim1   ! vector opt. 
     187                  zwx(ji,jj,jk) = 0.5 * pun(ji,jj,jk) * ( ptran(ji,jj,jk,jn) + ptran(ji+1,jj,jk,jn) ) - zwx(ji,jj,jk) 
     188                  zwy(ji,jj,jk) = 0.5 * pvn(ji,jj,jk) * ( ptran(ji,jj,jk,jn) + ptran(ji,jj+1,jk,jn) ) - zwy(ji,jj,jk) 
     189               END DO 
     190            END DO 
     191         END DO 
     192       
     193         ! antidiffusive flux on k 
     194         ! Surface value 
     195         zwz(:,:,1) = 0.e0 
     196         ! Interior value 
     197         DO jk = 2, jpkm1 
     198            DO jj = 1, jpj 
     199               DO ji = 1, jpi 
     200                  zwz(ji,jj,jk) = 0.5 * pwn(ji,jj,jk) * ( ptran(ji,jj,jk,jn) + ptran(ji,jj,jk-1,jn) ) - zwz(ji,jj,jk) 
     201               END DO 
     202            END DO 
     203         END DO 
     204 
     205         ! Lateral bondary conditions 
     206         CALL lbc_lnk( zwx, 'U', -1. ) 
     207         CALL lbc_lnk( zwy, 'V', -1. ) 
     208         CALL lbc_lnk( zwz, 'W',  1. ) 
     209 
     210         ! 4. monotonicity algorithm 
     211         ! ------------------------- 
     212         CALL nonosc( ptrab(:,:,:,jn), zwx, zwy, zwz, zwi, z2 ) 
     213 
     214 
     215         ! 5. final trend with corrected fluxes 
     216         ! ------------------------------------ 
    209217         DO jk = 1, jpkm1 
    210218            DO jj = 2, jpjm1 
    211                DO ji = fs_2, fs_jpim1   ! vector opt. 
    212                   zbtr      = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    213                   ztrdt(ji,jj,jk) = - ( ztv(ji,jj,jk) - ztv(ji,jj-1,jk) ) * zbtr 
    214                   ztrds(ji,jj,jk) = - ( zsv(ji,jj,jk) - zsv(ji,jj-1,jk) ) * zbtr 
    215                END DO 
    216             END DO 
    217          END DO 
    218          CALL trd_mod(ztrdt, ztrds, jptra_trd_yad, 'TRA', kt)     ! save the trends 
     219               DO ji = fs_2, fs_jpim1   ! vector opt.   
     220                  zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
     221                  ! total advective trends 
     222                  ztra = - zbtr * (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
     223                     &             + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   & 
     224                     &             + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) 
     225                  ! add them to the general tracer trends 
     226                  ptraa(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn) + ztra 
     227               END DO 
     228            END DO 
     229         END DO 
     230 
     231         !                                 ! trend diagnostics (contribution of upstream fluxes) 
     232         IF( l_trd )  THEN  
     233            ztrdx(:,:,:) = ztrdx(:,:,:) + zwx(:,:,:)  ! <<< Add to previously computed 
     234            ztrdy(:,:,:) = ztrdy(:,:,:) + zwy(:,:,:)  ! <<< Add to previously computed 
     235            ztrdz(:,:,:) = ztrdz(:,:,:) + zwz(:,:,:)  ! <<< Add to previously computed 
     236             
     237            CALL trd_tra( kt, cdtype, jn, jptra_trd_xad, ztrdx, pun, ptran(:,:,:,jn) )    
     238            CALL trd_tra( kt, cdtype, jn, jptra_trd_yad, ztrdy, pvn, ptran(:,:,:,jn) )   
     239            CALL trd_tra( kt, cdtype, jn, jptra_trd_zad, ztrdz, pwn, ptran(:,:,:,jn) )  
     240         END IF 
     241         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
     242         IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN   
     243           IF( jn == jp_tem )  pht_adv(:) = ptr_vj( zwy(:,:,:) ) + pht_adv(:) 
     244           IF( jn == jp_sal )  pst_adv(:) = ptr_vj( zwy(:,:,:) ) + pst_adv(:) 
     245         ENDIF 
    219246         ! 
    220          ! T/S VERTICAL advection trends 
    221          DO jk = 1, jpkm1 
    222             DO jj = 2, jpjm1 
    223                DO ji = fs_2, fs_jpim1   ! vector opt.          
    224                   zbtr      = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    225                   ztrdt(ji,jj,jk) = - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) * zbtr 
    226                   ztrds(ji,jj,jk) = - ( zsw(ji,jj,jk) - zsw(ji,jj,jk+1) ) * zbtr 
    227                END DO 
    228             END DO 
    229          END DO 
    230          CALL trd_mod(ztrdt, ztrds, jptra_trd_zad, 'TRA', kt)     ! save the trends 
    231          ! 
    232       ENDIF 
    233  
    234       ! Lateral boundary conditions on zti, zsi   (unchanged sign) 
    235       CALL lbc_lnk( zti, 'T', 1. ) 
    236       CALL lbc_lnk( zsi, 'T', 1. ) 
    237  
    238  
    239       ! 3. antidiffusive flux : high order minus low order 
    240       ! -------------------------------------------------- 
    241       ! antidiffusive flux on i and j 
    242       DO jk = 1, jpkm1 
    243          DO jj = 1, jpjm1 
    244             DO ji = 1, fs_jpim1   ! vector opt. 
    245                zeu = 0.5 * e2u(ji,jj) * fse3u(ji,jj,jk) * pun(ji,jj,jk) 
    246                zev = 0.5 * e1v(ji,jj) * fse3v(ji,jj,jk) * pvn(ji,jj,jk) 
    247                ztu(ji,jj,jk) = zeu * ( tn(ji,jj,jk) + tn(ji+1,jj,jk) ) - ztu(ji,jj,jk) 
    248                zsu(ji,jj,jk) = zeu * ( sn(ji,jj,jk) + sn(ji+1,jj,jk) ) - zsu(ji,jj,jk) 
    249                ztv(ji,jj,jk) = zev * ( tn(ji,jj,jk) + tn(ji,jj+1,jk) ) - ztv(ji,jj,jk) 
    250                zsv(ji,jj,jk) = zev * ( sn(ji,jj,jk) + sn(ji,jj+1,jk) ) - zsv(ji,jj,jk) 
    251             END DO 
    252          END DO 
    253       END DO 
    254        
    255       ! antidiffusive flux on k 
    256       ! Surface value 
    257       ztw(:,:,1) = 0.e0 
    258       zsw(:,:,1) = 0.e0 
    259  
    260       ! Interior value 
    261       DO jk = 2, jpkm1 
    262          DO jj = 1, jpj 
    263             DO ji = 1, jpi 
    264                zew = 0.5 * e1t(ji,jj) * e2t(ji,jj) * pwn(ji,jj,jk) 
    265                ztw(ji,jj,jk) = zew * ( tn(ji,jj,jk) + tn(ji,jj,jk-1) ) - ztw(ji,jj,jk) 
    266                zsw(ji,jj,jk) = zew * ( sn(ji,jj,jk) + sn(ji,jj,jk-1) ) - zsw(ji,jj,jk) 
    267             END DO 
    268          END DO 
    269       END DO 
    270  
    271       ! Lateral bondary conditions 
    272       CALL lbc_lnk( ztu, 'U', -1. )   ;   CALL lbc_lnk( zsu, 'U', -1. ) 
    273       CALL lbc_lnk( ztv, 'V', -1. )   ;   CALL lbc_lnk( zsv, 'V', -1. ) 
    274       CALL lbc_lnk( ztw, 'W',  1. )   ;   CALL lbc_lnk( zsw, 'W',  1. ) 
    275  
    276       ! 4. monotonicity algorithm 
    277       ! ------------------------- 
    278       CALL nonosc( tb, ztu, ztv, ztw, zti, z2 ) 
    279       CALL nonosc( sb, zsu, zsv, zsw, zsi, z2 ) 
    280  
    281  
    282       ! 5. final trend with corrected fluxes 
    283       ! ------------------------------------ 
    284       DO jk = 1, jpkm1 
    285          DO jj = 2, jpjm1 
    286             DO ji = fs_2, fs_jpim1   ! vector opt.   
    287                zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    288                ! total advective trends 
    289                ztat = - ( ztu(ji,jj,jk) - ztu(ji-1,jj  ,jk  )   & 
    290                   &     + ztv(ji,jj,jk) - ztv(ji  ,jj-1,jk  )   & 
    291                   &     + ztw(ji,jj,jk) - ztw(ji  ,jj  ,jk+1) ) * zbtr 
    292                zsat = - ( zsu(ji,jj,jk) - zsu(ji-1,jj  ,jk  )   & 
    293                   &     + zsv(ji,jj,jk) - zsv(ji  ,jj-1,jk  )   & 
    294                   &     + zsw(ji,jj,jk) - zsw(ji  ,jj  ,jk+1) ) * zbtr 
    295                ! add them to the general tracer trends 
    296                ta(ji,jj,jk) = ta(ji,jj,jk) + ztat 
    297                sa(ji,jj,jk) = sa(ji,jj,jk) + zsat 
    298             END DO 
    299          END DO 
    300       END DO 
    301  
    302  
    303       ! Save the advective trends for diagnostics 
    304       ! -------------------------------------------- 
    305  
    306       IF( l_trdtra ) THEN 
    307          ztrdt(:,:,:) = 0.e0   ;   ztrds(:,:,:) = 0.e0 
    308          ! 
    309          ! T/S ZONAL advection trends 
    310          DO jk = 1, jpkm1 
    311             DO jj = 2, jpjm1 
    312                DO ji = fs_2, fs_jpim1   ! vector opt. 
    313                   !-- Compute zonal divergence by splitting hdivn (see divcur.F90) 
    314                   !   N.B. This computation is not valid along OBCs (if any) 
    315                   zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    316                   z_hdivn_x = (  e2u(ji  ,jj) * fse3u(ji  ,jj,jk) * pun(ji  ,jj,jk)          & 
    317                      &         - e2u(ji-1,jj) * fse3u(ji-1,jj,jk) * pun(ji-1,jj,jk) ) * zbtr 
    318                   !-- Compute T/S zonal advection trends 
    319                   ztrdt(ji,jj,jk) = - ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) ) * zbtr + tn(ji,jj,jk) * z_hdivn_x 
    320                   ztrds(ji,jj,jk) = - ( zsu(ji,jj,jk) - zsu(ji-1,jj,jk) ) * zbtr + sn(ji,jj,jk) * z_hdivn_x 
    321                END DO 
    322             END DO 
    323          END DO 
    324          CALL trd_mod(ztrdt, ztrds, jptra_trd_xad, 'TRA', kt, cnbpas='bis')   ! <<< ADD TO PREVIOUSLY COMPUTED 
    325          ! 
    326          ! T/S MERIDIONAL advection trends 
    327          DO jk = 1, jpkm1 
    328             DO jj = 2, jpjm1 
    329                DO ji = fs_2, fs_jpim1   ! vector opt. 
    330                   !-- Compute merid. divergence by splitting hdivn (see divcur.F90) 
    331                   !   N.B. This computation is not valid along OBCs (if any) 
    332                   zbtr      = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    333                   z_hdivn_y = (  e1v(ji,  jj) * fse3v(ji,jj  ,jk) * pvn(ji,jj  ,jk)          & 
    334                      &         - e1v(ji,jj-1) * fse3v(ji,jj-1,jk) * pvn(ji,jj-1,jk) ) * zbtr 
    335                   !-- Compute T/S meridional advection trends 
    336                   ztrdt(ji,jj,jk) = - ( ztv(ji,jj,jk) - ztv(ji,jj-1,jk) ) * zbtr + tn(ji,jj,jk) * z_hdivn_y           
    337                   ztrds(ji,jj,jk) = - ( zsv(ji,jj,jk) - zsv(ji,jj-1,jk) ) * zbtr + sn(ji,jj,jk) * z_hdivn_y           
    338                END DO 
    339             END DO 
    340          END DO 
    341          CALL trd_mod(ztrdt, ztrds, jptra_trd_yad, 'TRA', kt, cnbpas='bis')   ! <<< ADD TO PREVIOUSLY COMPUTED 
    342          ! 
    343          ! T/S VERTICAL advection trends 
    344          DO jk = 1, jpkm1 
    345             DO jj = 2, jpjm1 
    346                DO ji = fs_2, fs_jpim1   ! vector opt. 
    347                   zbtr1     = 1. / ( e1t(ji,jj) * e2t(ji,jj) ) 
    348 #if defined key_zco 
    349                   zbtr      = zbtr1 
    350                   z_hdivn_x = e2u(ji,jj)*pun(ji,jj,jk) - e2u(ji-1,jj)*pun(ji-1,jj,jk) 
    351                   z_hdivn_y = e1v(ji,jj)*pvn(ji,jj,jk) - e1v(ji,jj-1)*pvn(ji,jj-1,jk) 
    352 #else 
    353                   zbtr      = zbtr1 / fse3t(ji,jj,jk) 
    354                   z_hdivn_x = e2u(ji,jj)*fse3u(ji,jj,jk)*pun(ji,jj,jk) - e2u(ji-1,jj)*fse3u(ji-1,jj,jk)*pun(ji-1,jj,jk) 
    355                   z_hdivn_y = e1v(ji,jj)*fse3v(ji,jj,jk)*pvn(ji,jj,jk) - e1v(ji,jj-1)*fse3v(ji,jj-1,jk)*pvn(ji,jj-1,jk) 
    356 #endif 
    357                   z_hdivn   = (z_hdivn_x + z_hdivn_y) * zbtr 
    358                   zbtr      = zbtr1 / fse3t(ji,jj,jk) 
    359                   ztrdt(ji,jj,jk) = - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) * zbtr - tn(ji,jj,jk) * z_hdivn 
    360                   ztrds(ji,jj,jk) = - ( zsw(ji,jj,jk) - zsw(ji,jj,jk+1) ) * zbtr - sn(ji,jj,jk) * z_hdivn 
    361                END DO 
    362             END DO 
    363          END DO 
    364          CALL trd_mod(ztrdt, ztrds, jptra_trd_zad, 'TRA', kt, cnbpas='bis')   ! <<< ADD TO PREVIOUSLY COMPUTED 
    365          ! 
    366       ENDIF 
    367  
    368       IF(ln_ctl)   CALL prt_ctl( tab3d_1=ta, clinfo1=' tvd adv  - Ta: ', mask1=tmask,   & 
    369          &                       tab3d_2=sa, clinfo2=           ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    370  
    371       ! "zonal" mean advective heat and salt transport 
    372       IF( ln_diaptr .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN 
    373          pht_adv(:) = ptr_vj( ztv(:,:,:) ) + pht_adv(:) 
    374          pst_adv(:) = ptr_vj( zsv(:,:,:) ) + pst_adv(:) 
    375       ENDIF 
     247      ENDDO 
     248      ! 
     249      IF( l_trd )  THEN 
     250        DEALLOCATE( ztrdx )     ;     DEALLOCATE( ztrdy )     ;      DEALLOCATE( ztrdz )   
     251      END IF 
    376252      ! 
    377253   END SUBROUTINE tra_adv_tvd 
    … …  
    392268      !!---------------------------------------------------------------------- 
    393269      REAL(wp), INTENT( in ) ::   prdt   ! ??? 
     270      REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT( in    ) ::   & 
     271         pbef,                            & ! before field 
     272         paft                               ! after field 
    394273      REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT( inout ) ::   & 
    395          pbef,                            & ! before field 
    396          paft,                            & ! after field 
    397274         paa,                             & ! monotonic flux in the i direction 
    398275         pbb,                             & ! monotonic flux in the j direction 

  • branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/traadv_ubs.F90

    r1528 r2024  
    44   !! Ocean active tracers:  horizontal & vertical advective trend 
    55   !!============================================================================== 
    6    !! History :  9.0  !  06-08  (L. Debreu, R. Benshila)  Original code 
     6   !! History :  1.0  !  2006-08  (L. Debreu, R. Benshila)  Original code 
     7  !!             3.3  !  2010-05  (C. Ethe, G. Madec)  merge TRC-TRA + switch from velocity to transport 
    78   !!---------------------------------------------------------------------- 
    89 
    … …  
    1314   USE oce             ! ocean dynamics and active tracers 
    1415   USE dom_oce         ! ocean space and time domain 
    15    USE trdmod 
    16    USE trdmod_oce 
     16   USE trdmod_oce         ! ocean space and time domain 
     17   USE trdtra 
    1718   USE lib_mpp 
    1819   USE lbclnk          ! ocean lateral boundary condition (or mpp link) 
    … …  
    2021   USE diaptr          ! poleward transport diagnostics 
    2122   USE dynspg_oce      ! choice/control of key cpp for surface pressure gradient 
    22    USE prtctl 
    2323 
    2424   IMPLICIT NONE 
    … …  
    2727   PUBLIC   tra_adv_ubs   ! routine called by traadv module 
    2828 
    29    REAL(wp), DIMENSION(jpi,jpj) ::   e1e2tr   ! = 1/(e1t * e2t) 
     29   LOGICAL :: l_trd  ! flag to compute trends or not 
    3030 
    3131   !! * Substitutions 
    … …  
    4040CONTAINS 
    4141 
    42    SUBROUTINE tra_adv_ubs( kt, pun, pvn, pwn ) 
     42   SUBROUTINE tra_adv_ubs ( kt   , cdtype, pun  , pvn, pwn, & 
     43      &                     ptrab, ptran , ptraa, kjpt   ) 
    4344      !!---------------------------------------------------------------------- 
    4445      !!                  ***  ROUTINE tra_adv_ubs  *** 
    … …  
    6768      !!      the UBS have been found to be too diffusive. 
    6869      !! 
    69       !! ** Action : - update (ta,sa) with the now advective tracer trends 
     70      !! ** Action : - update (ptraa) with the now advective tracer trends 
    7071      !! 
    7172      !! Reference : Shchepetkin, A. F., J. C. McWilliams, 2005, Ocean Modelling, 9, 347-404.  
    7273      !!             Farrow, D.E., Stevens, D.P., 1995, J. Phys. Ocean. 25, 1731Ð1741.  
    7374      !!---------------------------------------------------------------------- 
    74       USE oce, ONLY :   zwx => ua   ! use ua as workspace 
    75       USE oce, ONLY :   zwy => va   ! use va as workspace 
    76       !! 
    77       INTEGER , INTENT(in)                         ::   kt             ! ocean time-step index 
    78       REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) ::  pun   ! effective ocean velocity, u_component 
    79       REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) ::  pvn   ! effective ocean velocity, v_component 
    80       REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) ::  pwn   ! effective ocean velocity, w_component 
    81       !! 
    82       INTEGER  ::   ji, jj, jk                 ! dummy loop indices 
    83       REAL(wp) ::   zta, zsa, zbtr, zcoef                  ! temporary scalars 
    84       REAL(wp) ::   zfui, zfp_ui, zfm_ui, zcenut, zcenus   !    "         " 
    85       REAL(wp) ::   zfvj, zfp_vj, zfm_vj, zcenvt, zcenvs   !    "         " 
    86       REAL(wp) ::   z_hdivn_x, z_hdivn_y, z_hdivn          !    "         " 
    87       REAL(wp), DIMENSION(jpi,jpj)     ::   zeeu, zeev     ! temporary 2D workspace 
    88       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zwz , zww                        ! temporary 3D workspace 
    89       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   ztu , ztv , zltu , zltv, ztrdt   !    "              " 
    90       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zsu , zsv , zlsu , zlsv, ztrds   !    "              " 
    91       !!---------------------------------------------------------------------- 
    92  
    93       zltu(:,:,:) = 0.e0 
    94       zltv(:,:,:) = 0.e0 
    95       zlsu(:,:,:) = 0.e0 
    96       zlsv(:,:,:) = 0.e0 
     75      !!* Module used 
     76      USE oce         , zwx => ua   ! use ua as workspace 
     77      USE oce         , zwy => va   ! use va as workspace 
     78      !!* Arguments 
     79      INTEGER         , INTENT(in   )                               ::   kt              ! ocean time-step index 
     80      CHARACTER(len=3), INTENT(in   )                               ::   cdtype          ! =TRA or TRC (tracer indicator) 
     81      REAL(wp)        , INTENT(in   ), DIMENSION(jpi,jpj,jpk)       ::   pun, pvn, pwn   ! 3 ocean velocity components 
     82      INTEGER         , INTENT(in   )                               ::   kjpt            ! number of tracers 
     83      REAL(wp)        , INTENT(in   ), DIMENSION(jpi,jpj,jpk,kjpt)  ::   ptrab, ptran        ! before and now tracer fields 
     84      REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::   ptraa           ! tracer trend  
     85      !!* Local declarations 
     86      INTEGER  ::   ji, jj, jk, jn          ! dummy loop indices 
     87      REAL(wp) ::   ztra, zbtr, zcoef                  ! temporary scalars 
     88      REAL(wp) ::   zfp_ui, zfm_ui, zcenut  !    "         " 
     89      REAL(wp) ::   zfp_vj, zfm_vj, zcenvt  !    "         "    !    "         " 
     90      REAL(wp) ::   z2dtt, z2                    
     91      REAL(wp) ::   ztak, zfp_wk, zfm_wk    !    "         " 
     92      REAL(wp) ::   zeeu, zeev, z_hdivn      
     93      REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztu, ztv, zltu , zltv   !    "              " 
     94      REAL(wp), DIMENSION(jpi,jpj,jpk) :: zti, ztw                !    "              " 
     95      !!---------------------------------------------------------------------- 
     96 
    9797 
    9898      IF( kt == nit000 ) THEN 
    … …  
    101101         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' 
    102102         ! 
    103          e1e2tr(:,:) = 1. / ( e1t(:,:) * e2t(:,:) ) 
     103         l_trd = .FALSE. 
     104         IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 
    104105      ENDIF 
    105  
    106       ! Save ta and sa trends 
    107       ztrdt(:,:,:) = ta(:,:,:) 
    108       ztrds(:,:,:) = sa(:,:,:) 
    109  
    110       zcoef = 1./6. 
    111       !                                                ! =============== 
    112       DO jk = 1, jpkm1                                 ! Horizontal slab 
    113          !                                             ! =============== 
    114  
    115          !  Initialization of metric arrays (for z- or s-coordinates) 
    116          DO jj = 1, jpjm1 
    117             DO ji = 1, fs_jpim1   ! vector opt. 
    118 #if defined key_zco 
    119                ! z-coordinates, no vertical scale factors 
    120                zeeu(ji,jj) = e2u(ji,jj) / e1u(ji,jj) * umask(ji,jj,jk) 
    121                zeev(ji,jj) = e1v(ji,jj) / e2v(ji,jj) * vmask(ji,jj,jk) 
    122 #else 
    123                ! s-coordinates, vertical scale factor are used 
    124                zeeu(ji,jj) = e2u(ji,jj) * fse3u(ji,jj,jk) / e1u(ji,jj) * umask(ji,jj,jk) 
    125                zeev(ji,jj) = e1v(ji,jj) * fse3v(ji,jj,jk) / e2v(ji,jj) * vmask(ji,jj,jk) 
    126 #endif 
    127             END DO 
    128          END DO 
    129  
    130          !  Laplacian 
    131          ! First derivative (gradient) 
    132          DO jj = 1, jpjm1 
    133             DO ji = 1, fs_jpim1   ! vector opt. 
    134                ztu(ji,jj,jk) = zeeu(ji,jj) * ( tb(ji+1,jj  ,jk) - tb(ji,jj,jk) ) 
    135                zsu(ji,jj,jk) = zeeu(ji,jj) * ( sb(ji+1,jj  ,jk) - sb(ji,jj,jk) ) 
    136                ztv(ji,jj,jk) = zeev(ji,jj) * ( tb(ji  ,jj+1,jk) - tb(ji,jj,jk) ) 
    137                zsv(ji,jj,jk) = zeev(ji,jj) * ( sb(ji  ,jj+1,jk) - sb(ji,jj,jk) ) 
    138             END DO 
    139          END DO 
    140          ! Second derivative (divergence) 
    141          DO jj = 2, jpjm1 
    142             DO ji = fs_2, fs_jpim1   ! vector opt. 
    143 #if ! defined key_zco 
    144                zcoef = 1. / ( 6. * fse3t(ji,jj,jk) ) 
    145 #endif          
    146                zltu(ji,jj,jk) = (  ztu(ji,jj,jk) - ztu(ji-1,jj,jk)  ) * zcoef 
    147                zlsu(ji,jj,jk) = (  zsu(ji,jj,jk) - zsu(ji-1,jj,jk)  ) * zcoef 
    148                zltv(ji,jj,jk) = (  ztv(ji,jj,jk) - ztv(ji,jj-1,jk)  ) * zcoef 
    149                zlsv(ji,jj,jk) = (  zsv(ji,jj,jk) - zsv(ji,jj-1,jk)  ) * zcoef 
    150             END DO 
    151          END DO 
    152          !                                             ! ================= 
    153       END DO                                           !    End of slab 
    154       !                                                ! ================= 
    155  
    156       ! Lateral boundary conditions on the laplacian (zlt,zls)   (unchanged sgn) 
    157       CALL lbc_lnk( zltu, 'T', 1. )   ;    CALL lbc_lnk( zlsu, 'T', 1. ) 
    158       CALL lbc_lnk( zltv, 'T', 1. )   ;    CALL lbc_lnk( zlsv, 'T', 1. ) 
    159  
    160       !                                                ! =============== 
    161       DO jk = 1, jpkm1                                 ! Horizontal slab 
    162          !                                             ! =============== 
    163          !  Horizontal advective fluxes 
    164          DO jj = 1, jpjm1 
    165             DO ji = 1, fs_jpim1   ! vector opt. 
    166                ! volume fluxes * 1/2 
    167 #if defined key_zco 
    168                zfui = 0.5 * e2u(ji,jj) * pun(ji,jj,jk) 
    169                zfvj = 0.5 * e1v(ji,jj) * pvn(ji,jj,jk) 
    170 #else 
    171                zfui = 0.5 * e2u(ji,jj) * fse3u(ji,jj,jk) * pun(ji,jj,jk) 
    172                zfvj = 0.5 * e1v(ji,jj) * fse3v(ji,jj,jk) * pvn(ji,jj,jk) 
    173 #endif 
    174                ! upstream scheme 
    175                zfp_ui = zfui + ABS( zfui ) 
    176                zfp_vj = zfvj + ABS( zfvj ) 
    177                zfm_ui = zfui - ABS( zfui ) 
    178                zfm_vj = zfvj - ABS( zfvj ) 
    179                ! centered scheme 
    180                zcenut = zfui * ( tn(ji,jj,jk) + tn(ji+1,jj  ,jk) ) 
    181                zcenvt = zfvj * ( tn(ji,jj,jk) + tn(ji  ,jj+1,jk) ) 
    182                zcenus = zfui * ( sn(ji,jj,jk) + sn(ji+1,jj  ,jk) ) 
    183                zcenvs = zfvj * ( sn(ji,jj,jk) + sn(ji  ,jj+1,jk) ) 
    184                ! mixed centered / upstream scheme 
    185                zwx(ji,jj,jk) = zcenut - zfp_ui * zltu(ji,jj,jk) -zfm_ui * zltu(ji+1,jj,jk) 
    186                zwy(ji,jj,jk) = zcenvt - zfp_vj * zltv(ji,jj,jk) -zfm_vj * zltv(ji,jj+1,jk) 
    187                zww(ji,jj,jk) = zcenus - zfp_ui * zlsu(ji,jj,jk) -zfm_ui * zlsu(ji+1,jj,jk) 
    188                zwz(ji,jj,jk) = zcenvs - zfp_vj * zlsv(ji,jj,jk) -zfm_vj * zlsv(ji,jj+1,jk) 
    189             END DO 
    190          END DO 
    191  
    192          !  Tracer flux divergence at t-point added to the general trend 
    193          DO jj = 2, jpjm1 
    194             DO ji = fs_2, fs_jpim1   ! vector opt. 
    195                ! horizontal advective trends 
    196 #if defined key_zco 
    197                zbtr = e1e2tr(ji,jj) 
    198 #else 
    199                zbtr = e1e2tr(ji,jj) / fse3t(ji,jj,jk) 
    200 #endif 
    201                zta = - zbtr * (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk)   & 
    202                   &            + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk)  ) 
    203                zsa = - zbtr * (  zww(ji,jj,jk) - zww(ji-1,jj  ,jk)   & 
    204                   &            + zwz(ji,jj,jk) - zwz(ji  ,jj-1,jk)  ) 
    205                ! add it to the general tracer trends 
    206                ta(ji,jj,jk) = ta(ji,jj,jk) + zta 
    207                sa(ji,jj,jk) = sa(ji,jj,jk) + zsa 
    208             END DO 
    209          END DO 
    210          !                                             ! =============== 
    211       END DO                                           !   End of slab 
    212       !                                                ! =============== 
    213  
    214       ! Horizontal trend used in tra_adv_ztvd subroutine 
    215       zltu(:,:,:) = ta(:,:,:) - ztrdt(:,:,:)  
    216       zlsu(:,:,:) = sa(:,:,:) - ztrds(:,:,:)  
    217  
    218       ! 3. Save the horizontal advective trends for diagnostic 
    219       ! ------------------------------------------------------ 
    220       IF( l_trdtra )   THEN 
    221          ! Recompute the hoizontal advection zta & zsa trends computed  
    222          ! at the step 2. above in making the difference between the new  
    223          ! trends and the previous one ta()/sa - ztrdt()/ztrds() and add 
    224          ! the term tn()/sn()*hdivn() to recover the Uh gradh(T/S) trends 
    225          ztrdt(:,:,:) = 0.e0   ;   ztrds(:,:,:) = 0.e0 
    226          ! 
    227          ! T/S ZONAL advection trends 
    228          DO jk = 1, jpkm1 
    229             DO jj = 2, jpjm1 
    230                DO ji = fs_2, fs_jpim1   ! vector opt. 
    231                   !-- Compute zonal divergence by splitting hdivn (see divcur.F90) 
    232 #if defined key_zco 
    233                   zbtr = e1e2tr(ji,jj) 
    234                   z_hdivn_x = (  e2u(ji  ,jj) * pun(ji  ,jj,jk)          & 
    235                      &         - e2u(ji-1,jj) * pun(ji-1,jj,jk) ) * zbtr 
    236 #else 
    237                   zbtr = e1e2tr(ji,jj) / fse3t(ji,jj,jk) 
    238                   z_hdivn_x = (  e2u(ji  ,jj) * fse3u(ji  ,jj,jk) * pun(ji  ,jj,jk)          & 
    239                      &         - e2u(ji-1,jj) * fse3u(ji-1,jj,jk) * pun(ji-1,jj,jk) ) * zbtr 
    240 #endif 
    241                   ztrdt(ji,jj,jk) = - ( zwx(ji,jj,jk) - zwx(ji-1,jj,jk) ) * zbtr + tn(ji,jj,jk) * z_hdivn_x 
    242                   ztrds(ji,jj,jk) = - ( zww(ji,jj,jk) - zww(ji-1,jj,jk) ) * zbtr + sn(ji,jj,jk) * z_hdivn_x 
    243                END DO 
    244             END DO 
    245          END DO 
    246          CALL trd_mod(ztrdt, ztrds, jptra_trd_xad, 'TRA', kt)    ! save the trends 
    247          ! 
    248          ! T/S MERIDIONAL advection trends 
    249          DO jk = 1, jpkm1 
    250             DO jj = 2, jpjm1 
    251                DO ji = fs_2, fs_jpim1   ! vector opt. 
    252                   !-- Compute merid. divergence by splitting hdivn (see divcur.F90) 
    253 #if defined key_zco 
    254                   zbtr      = e1e2tr(ji,jj) 
    255                   z_hdivn_y = (  e1v(ji,  jj) * pvn(ji,jj  ,jk)          & 
    256                      &         - e1v(ji,jj-1) * pvn(ji,jj-1,jk) ) * zbtr 
    257 #else 
    258                   zbtr      = e1e2tr(ji,jj) / fse3t(ji,jj,jk) 
    259                   z_hdivn_y = (  e1v(ji,  jj) * fse3v(ji,jj  ,jk) * pvn(ji,jj  ,jk)          & 
    260                      &         - e1v(ji,jj-1) * fse3v(ji,jj-1,jk) * pvn(ji,jj-1,jk) ) * zbtr 
    261 #endif 
    262                   ztrdt(ji,jj,jk) = - ( zwy(ji,jj,jk) - zwy(ji,jj-1,jk) ) * zbtr + tn(ji,jj,jk) * z_hdivn_y           
    263                   ztrds(ji,jj,jk) = - ( zwz(ji,jj,jk) - zwz(ji,jj-1,jk) ) * zbtr + sn(ji,jj,jk) * z_hdivn_y 
    264                END DO 
    265             END DO 
    266          END DO 
    267          CALL trd_mod(ztrdt, ztrds, jptra_trd_yad, 'TRA', kt)     ! save the trends 
    268          ! 
    269       ENDIF 
    270  
    271       IF(ln_ctl)   CALL prt_ctl( tab3d_1=ta, clinfo1=' ubs had  - Ta: ', mask1=tmask,   & 
    272          &                       tab3d_2=sa, clinfo2=           ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    273  
    274       ! "zonal" mean advective heat and salt transport  
    275       IF( ln_diaptr .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN 
    276          IF( lk_zco ) THEN 
    277             DO jk = 1, jpkm1 
    278                DO jj = 2, jpjm1 
    279                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    280                      zwy(ji,jj,jk) = zwy(ji,jj,jk) * fse3v(ji,jj,jk) 
    281                      zwz(ji,jj,jk) = zwz(ji,jj,jk) * fse3v(ji,jj,jk) 
    282                   END DO 
    283                END DO 
    284             END DO 
    285          ENDIF 
    286          pht_adv(:) = ptr_vj( zwy(:,:,:) ) 
    287          pst_adv(:) = ptr_vj( zwz(:,:,:) ) 
    288       ENDIF 
    289  
    290       ! II. Vertical advection 
    291       ! ---------------------- 
    292       IF( l_trdtra ) THEN          ! Save ta and sa trends 
    293          ztrdt(:,:,:) = ta(:,:,:) 
    294          ztrds(:,:,:) = sa(:,:,:) 
    295       ENDIF 
    296      
    297       ! TVD scheme the vertical direction   
    298       CALL tra_adv_ztvd(kt, pwn, zltu, zlsu) 
    299  
    300       IF( l_trdtra )   THEN         !  Save the final vertical advective trends 
    301          DO jk = 1, jpkm1 
    302             DO jj = 2, jpjm1 
    303                DO ji = fs_2, fs_jpim1   ! vector opt. 
    304 #if defined key_zco 
    305                   zbtr      = e1e2tr(ji,jj) 
    306                   z_hdivn_x = e2u(ji,jj)*pun(ji,jj,jk) - e2u(ji-1,jj)*pun(ji-1,jj,jk) 
    307                   z_hdivn_y = e1v(ji,jj)*pvn(ji,jj,jk) - e1v(ji,jj-1)*pvn(ji,jj-1,jk) 
    308 #else 
    309                   zbtr      = e1e2tr(ji,jj) / fse3t(ji,jj,jk) 
    310                   z_hdivn_x = e2u(ji,jj)*fse3u(ji,jj,jk)*pun(ji,jj,jk) - e2u(ji-1,jj)*fse3u(ji-1,jj,jk)*pun(ji-1,jj,jk) 
    311                   z_hdivn_y = e1v(ji,jj)*fse3v(ji,jj,jk)*pvn(ji,jj,jk) - e1v(ji,jj-1)*fse3v(ji,jj-1,jk)*pvn(ji,jj-1,jk) 
    312 #endif 
    313                   z_hdivn   = (z_hdivn_x + z_hdivn_y) * zbtr 
    314                   zbtr      = e1e2tr(ji,jj) / fse3t(ji,jj,jk) 
    315                   ztrdt(ji,jj,jk) = ta(ji,jj,jk) - ztrdt(ji,jj,jk) - tn(ji,jj,jk) * z_hdivn 
    316                   ztrds(ji,jj,jk) = sa(ji,jj,jk) - ztrds(ji,jj,jk) - sn(ji,jj,jk) * z_hdivn 
    317                END DO 
    318             END DO 
    319          END DO 
    320          CALL trd_mod(ztrdt, ztrds, jptra_trd_zad, 'TRA', kt)   ! <<< ADD TO PREVIOUSLY COMPUTED 
    321          ! 
    322       ENDIF 
    323  
    324       IF(ln_ctl)   CALL prt_ctl( tab3d_1=ta, clinfo1=' ubs zad  - Ta: ', mask1=tmask,   & 
    325          &                       tab3d_2=sa, clinfo2=           ' Sa: ', mask2=tmask, clinfo3='tra') 
    326106      ! 
    327    END SUBROUTINE tra_adv_ubs 
    328  
    329  
    330    SUBROUTINE tra_adv_ztvd( kt, pwn, zttrd, zstrd ) 
    331       !!---------------------------------------------------------------------- 
    332       !!                  ***  ROUTINE tra_adv_ztvd  *** 
    333       !!  
    334       !! **  Purpose :   Compute the now trend due to total advection of  
    335       !!       tracers and add it to the general trend of tracer equations 
    336       !! 
    337       !! **  Method  :   TVD scheme, i.e. 2nd order centered scheme with 
    338       !!       corrected flux (monotonic correction) 
    339       !!       note: - this advection scheme needs a leap-frog time scheme 
    340       !! 
    341       !! ** Action : - update (ta,sa) with the now advective tracer trends 
    342       !!             - save the trends in (ztrdt,ztrds) ('key_trdtra') 
    343       !!---------------------------------------------------------------------- 
    344       INTEGER , INTENT(in)                         ::   kt             ! ocean time-step 
    345       REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) ::   pwn            ! verical effective velocity 
    346       REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) ::   zttrd, zstrd   ! lateral advective trends on T & S  
    347       !! 
    348       INTEGER  ::   ji, jj, jk              ! dummy loop indices 
    349       REAL(wp) ::   z2dtt, zbtr, zew, z2    ! temporary scalar   
    350       REAL(wp) ::   ztak, zfp_wk            !    "         " 
    351       REAL(wp) ::   zsak, zfm_wk            !    "         " 
    352       REAL(wp), DIMENSION (jpi,jpj,jpk) ::   zti, ztw   ! temporary 3D workspace 
    353       REAL(wp), DIMENSION (jpi,jpj,jpk) ::   zsi, zsw   !    "              " 
    354       !!---------------------------------------------------------------------- 
    355  
    356       IF( kt == nit000 .AND. lwp ) THEN 
    357          WRITE(numout,*) 
    358          WRITE(numout,*) 'tra_adv_ztvd : vertical TVD advection scheme' 
    359          WRITE(numout,*) '~~~~~~~~~~~~' 
    360       ENDIF 
    361  
    362107      IF( neuler == 0 .AND. kt == nit000 ) THEN   ;    z2 = 1. 
    363108      ELSE                                        ;    z2 = 2. 
    364109      ENDIF 
    365  
    366       !  Bottom value : flux set to zero 
    367       ! -------------- 
    368       ztw(:,:,jpk) = 0.e0   ;   zsw(:,:,jpk) = 0.e0 
    369       zti  (:,:,:) = 0.e0   ;   zsi  (:,:,:) = 0.e0 
    370  
    371  
    372       !  upstream advection with initial mass fluxes & intermediate update 
    373       ! ------------------------------------------------------------------- 
    374       ! Surface value 
    375       IF( lk_vvl ) THEN 
    376          ! variable volume : flux set to zero 
    377          ztw(:,:,1) = 0.e0 
    378          zsw(:,:,1) = 0.e0 
    379       ELSE 
    380          ! free surface-constant volume 
    381          DO jj = 1, jpj 
    382             DO ji = 1, jpi 
    383                zew = e1t(ji,jj) * e2t(ji,jj) * pwn(ji,jj,1) 
    384                ztw(ji,jj,1) = zew * tb(ji,jj,1) 
    385                zsw(ji,jj,1) = zew * sb(ji,jj,1) 
    386             END DO 
    387          END DO 
    388       ENDIF 
    389  
    390       ! Interior value 
    391       DO jk = 2, jpkm1 
    392          DO jj = 1, jpj 
    393             DO ji = 1, jpi 
    394                zew = 0.5 * e1t(ji,jj) * e2t(ji,jj) * pwn(ji,jj,jk) 
    395                zfp_wk = zew + ABS( zew ) 
    396                zfm_wk = zew - ABS( zew ) 
    397                ztw(ji,jj,jk) = zfp_wk * tb(ji,jj,jk) + zfm_wk * tb(ji,jj,jk-1) 
    398                zsw(ji,jj,jk) = zfp_wk * sb(ji,jj,jk) + zfm_wk * sb(ji,jj,jk-1) 
    399             END DO 
    400          END DO 
    401       END DO 
    402  
    403       ! update and guess with monotonic sheme 
    404       DO jk = 1, jpkm1 
    405          z2dtt = z2 * rdttra(jk) 
    406          DO jj = 2, jpjm1 
    407             DO ji = fs_2, fs_jpim1   ! vector opt. 
    408                zbtr = 1./ ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    409                ztak = - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) * zbtr 
    410                zsak = - ( zsw(ji,jj,jk) - zsw(ji,jj,jk+1) ) * zbtr 
    411                ta(ji,jj,jk) =  ta(ji,jj,jk) + ztak 
    412                sa(ji,jj,jk) =  sa(ji,jj,jk) + zsak  
    413                zti (ji,jj,jk) = ( tb(ji,jj,jk) + z2dtt * ( ztak + zttrd(ji,jj,jk) ) ) * tmask(ji,jj,jk) 
    414                zsi (ji,jj,jk) = ( sb(ji,jj,jk) + z2dtt * ( zsak + zstrd(ji,jj,jk) ) ) * tmask(ji,jj,jk) 
    415             END DO 
    416          END DO 
    417       END DO 
    418  
    419       ! Lateral boundary conditions on zti, zsi   (unchanged sign) 
    420       CALL lbc_lnk( zti, 'T', 1. ) 
    421       CALL lbc_lnk( zsi, 'T', 1. ) 
    422  
    423  
    424       !  antidiffusive flux : high order minus low order 
    425       ! -------------------------------------------------       
    426       ! Surface value 
    427       ztw(:,:,1) = 0.e0   ;   zsw(:,:,1) = 0.e0 
    428  
    429       ! Interior value 
    430       DO jk = 2, jpkm1 
    431          DO jj = 1, jpj 
    432             DO ji = 1, jpi 
    433                zew = 0.5 * e1t(ji,jj) * e2t(ji,jj) * pwn(ji,jj,jk) 
    434                ztw(ji,jj,jk) = zew * ( tn(ji,jj,jk) + tn(ji,jj,jk-1) ) - ztw(ji,jj,jk) 
    435                zsw(ji,jj,jk) = zew * ( sn(ji,jj,jk) + sn(ji,jj,jk-1) ) - zsw(ji,jj,jk) 
    436             END DO 
    437          END DO 
    438       END DO 
    439  
    440       !  monotonicity algorithm 
    441       ! ------------------------ 
    442       CALL nonosc_z( tb, ztw, zti, z2 ) 
    443       CALL nonosc_z( sb, zsw, zsi, z2 ) 
    444  
    445  
    446       !  final trend with corrected fluxes 
    447       ! ----------------------------------- 
    448       DO jk = 1, jpkm1 
    449          DO jj = 2, jpjm1 
    450             DO ji = fs_2, fs_jpim1   ! vector opt.   
    451                zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    452                ! k- vertical advective trends 
    453                ztak = - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) * zbtr 
    454                zsak = - ( zsw(ji,jj,jk) - zsw(ji,jj,jk+1) ) * zbtr 
    455                ! add them to the general tracer trends 
    456                ta(ji,jj,jk) = ta(ji,jj,jk) + ztak 
    457                sa(ji,jj,jk) = sa(ji,jj,jk) + zsak 
    458             END DO 
    459          END DO 
    460       END DO 
    461110      ! 
    462    END SUBROUTINE tra_adv_ztvd 
    463  
     111      !                                                          ! =========== 
     112      DO jn = 1, kjpt                                            ! tracer loop 
     113         !                                                       ! =========== 
     114         ! 1. Bottom value : flux set to zero 
     115         ! ---------------------------------- 
     116         zltu(:,:,jpk) = 0.e0       ;      zltv(:,:,jpk) = 0.e0 
     117         !                                                ! =============== 
     118         DO jk = 1, jpkm1                                 ! Horizontal slab 
     119            !                                             ! =============== 
     120            !  Laplacian 
     121            ! First derivative (gradient) 
     122            DO jj = 1, jpjm1 
     123               DO ji = 1, fs_jpim1   ! vector opt. 
     124                  zeeu = e2u(ji,jj) * fse3u(ji,jj,jk) / e1u(ji,jj) * umask(ji,jj,jk) 
     125                  zeev = e1v(ji,jj) * fse3v(ji,jj,jk) / e2v(ji,jj) * vmask(ji,jj,jk) 
     126                  ztu(ji,jj,jk) = zeeu * ( ptrab(ji+1,jj  ,jk,jn) - ptrab(ji,jj,jk,jn) ) 
     127                  ztv(ji,jj,jk) = zeev * ( ptrab(ji  ,jj+1,jk,jn) - ptrab(ji,jj,jk,jn) ) 
     128               END DO 
     129            END DO 
     130            ! Second derivative (divergence) 
     131            DO jj = 2, jpjm1 
     132               DO ji = fs_2, fs_jpim1   ! vector opt. 
     133                  zcoef = 1. / ( 6. * fse3t(ji,jj,jk) ) 
     134                  zltu(ji,jj,jk) = (  ztu(ji,jj,jk) - ztu(ji-1,jj,jk)  ) * zcoef 
     135                  zltv(ji,jj,jk) = (  ztv(ji,jj,jk) - ztv(ji,jj-1,jk)  ) * zcoef 
     136               END DO 
     137            END DO 
     138            !                                             ! ================= 
     139         END DO                                           !    End of slab 
     140         !                                                ! ================= 
     141          
     142         ! Lateral boundary conditions on the laplacian (zlt)   (unchanged sgn) 
     143         CALL lbc_lnk( zltu, 'T', 1. )   ;    CALL lbc_lnk( zltv, 'T', 1. ) 
     144 
     145         !     
     146         !  Horizontal advective fluxes                
     147         DO jk = 1, jpkm1  
     148            DO jj = 1, jpjm1 
     149               DO ji = 1, fs_jpim1   ! vector opt. 
     150                  ! upstream transport 
     151                  zfp_ui = pun(ji,jj,jk) + ABS( pun(ji,jj,jk) ) 
     152                  zfm_ui = pun(ji,jj,jk) - ABS( pun(ji,jj,jk) ) 
     153                  zfp_vj = pvn(ji,jj,jk) + ABS( pvn(ji,jj,jk) ) 
     154                  zfm_vj = pvn(ji,jj,jk) - ABS( pvn(ji,jj,jk) ) 
     155                  ! centered scheme 
     156                  zcenut = 0.5 * pun(ji,jj,jk) * ( ptran(ji,jj,jk,jn) + ptran(ji+1,jj  ,jk,jn) ) 
     157                  zcenvt = 0.5 * pvn(ji,jj,jk) * ( ptran(ji,jj,jk,jn) + ptran(ji  ,jj+1,jk,jn) ) 
     158                  ! UBS scheme 
     159                  zwx(ji,jj,jk) =  zcenut - zfp_ui * zltu(ji,jj,jk) - zfm_ui * zltu(ji+1,jj,jk)  
     160                  zwy(ji,jj,jk) =  zcenvt - zfp_vj * zltv(ji,jj,jk) - zfm_vj * zltv(ji,jj+1,jk)  
     161               END DO 
     162            END DO 
     163         ENDDO 
     164 
     165         zltu(:,:,:) = ptraa(:,:,:,jn)      ! store ptraa trends 
     166 
     167         ! Horizontal advective trends 
     168         DO jk = 1, jpkm1 
     169            !  Tracer flux divergence at t-point added to the general trend 
     170            DO jj = 2, jpjm1 
     171               DO ji = fs_2, fs_jpim1   ! vector opt. 
     172                  zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
     173                  ! horizontal advective 
     174                  ztra = - zbtr * (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk)   & 
     175                     &             + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk)  ) 
     176                  ! add it to the general tracer trends 
     177                  ptraa(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn) + ztra 
     178               END DO 
     179            END DO 
     180            !                                             ! =============== 
     181         END DO                                           !   End of slab 
     182         !                                                ! =============== 
     183 
     184         ! Horizontal trend used in tra_adv_ztvd subroutine 
     185         zltu(:,:,:) = ptraa(:,:,:,jn) - zltu(:,:,:) 
     186 
     187         ! 3. Save the horizontal advective trends for diagnostic 
     188         ! ------------------------------------------------------ 
     189         !                                 ! trend diagnostics (contribution of upstream fluxes) 
     190         IF( l_trd ) THEN 
     191             CALL trd_tra( kt, cdtype, jn, jptra_trd_xad, zwx, pun, ptran(:,:,:,jn) ) 
     192             CALL trd_tra( kt, cdtype, jn, jptra_trd_yad, zwy, pvn, ptran(:,:,:,jn) ) 
     193         END IF 
     194         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
     195         IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN   
     196            IF( lk_zco ) THEN 
     197               DO jk = 1, jpkm1 
     198                  DO jj = 2, jpjm1 
     199                     DO ji = fs_2, fs_jpim1   ! vector opt. 
     200                       zwy(ji,jj,jk) = zwy(ji,jj,jk) * fse3v(ji,jj,jk)                  
     201                     END DO 
     202                  END DO 
     203               END DO 
     204            ENDIF 
     205            IF( jn == jp_tem )  pht_adv(:) = ptr_vj( zwy(:,:,:) ) 
     206            IF( jn == jp_sal )  pst_adv(:) = ptr_vj( zwy(:,:,:) ) 
     207         ENDIF 
     208          
     209         ! TVD scheme for the vertical direction   
     210         ! ---------------------- 
     211         IF( l_trd )   zltv(:,:,:) = ptraa(:,:,:,jn)          ! store pta if trend diag. 
     212 
     213         !  Bottom value : flux set to zero 
     214         ztw(:,:,jpk) = 0.e0   ;   zti(:,:,jpk) = 0.e0 
     215 
     216         ! Surface value 
     217         IF( lk_vvl ) THEN   ;   ztw(:,:,1) = 0.e0                      ! variable volume : flux set to zero 
     218         ELSE                ;   ztw(:,:,1) = pwn(:,:,1) * ptrab(:,:,1,jn)   ! free constant surface  
     219         ENDIF 
     220         !  upstream advection with initial mass fluxes & intermediate update 
     221         ! ------------------------------------------------------------------- 
     222         ! Interior value 
     223         DO jk = 2, jpkm1 
     224            DO jj = 1, jpj 
     225               DO ji = 1, jpi 
     226                   zfp_wk = pwn(ji,jj,jk) + ABS( pwn(ji,jj,jk) ) 
     227                   zfm_wk = pwn(ji,jj,jk) - ABS( pwn(ji,jj,jk) ) 
     228                   ztw(ji,jj,jk) = 0.5 * (  zfp_wk * ptrab(ji,jj,jk,jn) + zfm_wk * ptrab(ji,jj,jk-1,jn)  ) 
     229               END DO 
     230            END DO 
     231         END DO  
     232         ! update and guess with monotonic sheme 
     233         DO jk = 1, jpkm1 
     234            z2dtt = z2 * rdttra(jk) 
     235            DO jj = 2, jpjm1 
     236               DO ji = fs_2, fs_jpim1   ! vector opt. 
     237                  zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
     238                  ztak = - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) * zbtr 
     239                  ptraa(ji,jj,jk,jn) =   ptraa(ji,jj,jk,jn) +  ztak  
     240                  zti(ji,jj,jk)    = ( ptrab(ji,jj,jk,jn) + z2dtt * ( ztak + zltu(ji,jj,jk) ) ) * tmask(ji,jj,jk) 
     241               END DO 
     242            END DO 
     243         END DO 
     244         ! 
     245         CALL lbc_lnk( zti, 'T', 1. )      ! Lateral boundary conditions on zti, zsi   (unchanged sign) 
     246 
     247         !  antidiffusive flux : high order minus low order 
     248         ztw(:,:,1) = 0.e0       ! Surface value 
     249         DO jk = 2, jpkm1        ! Interior value 
     250            DO jj = 1, jpj 
     251               DO ji = 1, jpi 
     252                  ztw(ji,jj,jk) = 0.5 * pwn(ji,jj,jk) * ( ptran(ji,jj,jk,jn) + ptran(ji,jj,jk-1,jn) ) - ztw(ji,jj,jk) 
     253               END DO 
     254            END DO 
     255         END DO 
     256         ! 
     257         CALL nonosc_z( ptrab(:,:,:,jn), ztw, zti, z2 )      !  monotonicity algorithm 
     258 
     259         !  final trend with corrected fluxes 
     260         DO jk = 1, jpkm1 
     261            DO jj = 2, jpjm1  
     262               DO ji = fs_2, fs_jpim1   ! vector opt.    
     263                  zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
     264                  ! k- vertical advective trends   
     265                  ztra = - zbtr * ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) 
     266                  ! added to the general tracer trends 
     267                  ptraa(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn) + ztra 
     268               END DO 
     269            END DO 
     270         END DO 
     271 
     272         !  Save the final vertical advective trends 
     273         IF( l_trd )  THEN                        ! vertical advective trend diagnostics 
     274            DO jk = 1, jpkm1                       ! (compute -w.dk[ptn]= -dk[w.ptn] + ptn.dk[w]) 
     275               DO jj = 2, jpjm1 
     276                  DO ji = fs_2, fs_jpim1   ! vector opt. 
     277                     zbtr = 1.e0 / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
     278                     z_hdivn = (  pwn(ji,jj,jk) - pwn(ji,jj,jk+1)  ) * zbtr 
     279                     zltv(ji,jj,jk) = ptraa(ji,jj,jk,jn) - zltv(ji,jj,jk) + ptran(ji,jj,jk,jn) * z_hdivn 
     280                  END DO 
     281               END DO 
     282            END DO 
     283            CALL trd_tra( kt, cdtype, jn, jptra_trd_zad, zltv ) 
     284         ENDIF 
     285         ! 
     286      ENDDO 
     287      ! 
     288   END SUBROUTINE tra_adv_ubs 
    464289 
    465290   SUBROUTINE nonosc_z( pbef, pcc, paft, prdt ) 
    … …  
    477302      !!---------------------------------------------------------------------- 
    478303      REAL(wp), INTENT(in   )                          ::   prdt   ! ??? 
    479       REAL(wp), INTENT(inout), DIMENSION (jpi,jpj,jpk) ::   pbef   ! before field 
     304      REAL(wp),               DIMENSION (jpi,jpj,jpk) ::   pbef   ! before field 
    480305      REAL(wp), INTENT(inout), DIMENSION (jpi,jpj,jpk) ::   paft   ! after field 
    481306      REAL(wp), INTENT(inout), DIMENSION (jpi,jpj,jpk) ::   pcc    ! monotonic flux in the k direction 
    … …  
    525350      pbef(:,:,:) = pbef(:,:,:) * tmask(:,:,:) 
    526351      paft(:,:,:) = paft(:,:,:) * tmask(:,:,:) 
    527   
     352 
    528353 
    529354      ! 2. Positive and negative part of fluxes and beta terms 
    … …  
    544369         END DO 
    545370      END DO 
    546  
    547371      ! monotonic flux in the k direction, i.e. pcc 
    548372      ! ------------------------------------------- 

  • branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/trabbc.F90

    r1601 r2024  
    1818   USE dom_oce         ! ocean space and time domain 
    1919   USE phycst          ! physical constants 
    20    USE trdmod          ! ocean trends  
    21    USE trdmod_oce      ! ocean variables trends 
     20   USE trdmod_oce      ! ocean trends  
     21   USE trdtra      ! ocean trends  
    2222   USE in_out_manager  ! I/O manager 
    2323   USE prtctl          ! Print control 
    … …  
    2727 
    2828   PUBLIC tra_bbc          ! routine called by step.F90 
     29   PUBLIC tra_bbc_init     ! routine called by opa.F90 
    2930 
    3031   !! to be transfert in the namelist ???!    
    … …  
    7071      !!              Emile-Geay and Madec, 2009, Ocean Science. 
    7172      !!---------------------------------------------------------------------- 
    72       USE oce, ONLY :   ztrdt => ua   ! use ua as 3D workspace    
    73       USE oce, ONLY :   ztrds => va   ! use va as 3D workspace    
    7473      !! 
    7574      INTEGER, INTENT( in ) ::   kt   ! ocean time-step index 
    7675      !! 
    77       INTEGER  ::   ji, jj    ! dummy loop indices 
     76      INTEGER  ::   ji, jj, ik    ! dummy loop indices 
    7877      REAL(wp) ::   zqgh_trd  ! geothermal heat flux trend 
     78      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  ztrdt, ztrds 
    7979      !!---------------------------------------------------------------------- 
    8080 
    81       IF( kt == nit000 )   CALL tra_bbc_init      ! Initialization 
    82  
    8381      IF( l_trdtra )   THEN         ! Save ta and sa trends 
    84          ztrdt(:,:,:) = ta(:,:,:)  
    85          ztrds(:,:,:) = 0.e0 
     82         ALLOCATE( ztrdt(jpi,jpj,jpk) )     ;   ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 
     83         ALLOCATE( ztrds(jpi,jpj,jpk) )     ;   ztrds(:,:,:) = 0. 
    8684      ENDIF 
    8785 
    … …  
    9896            DO ji = 2, jpim1 
    9997#endif 
    100                zqgh_trd = ro0cpr * qgh_trd0(ji,jj) / fse3t(ji,jj,nbotlevt(ji,jj)) 
    101                ta(ji,jj,nbotlevt(ji,jj)) = ta(ji,jj,nbotlevt(ji,jj)) + zqgh_trd 
     98               ik = nbotlevt(ji,jj) 
     99               zqgh_trd = ro0cpr * qgh_trd0(ji,jj) / fse3t(ji,jj,ik) 
     100               tsa(ji,jj,ik,jp_tem) = tsa(ji,jj,ik,jp_tem) + zqgh_trd 
    102101            END DO 
    103102         END DO 
    … …  
    105104 
    106105      IF( l_trdtra ) THEN        ! Save the geothermal heat flux trend for diagnostics 
    107          ztrdt(:,:,:) = ta(:,:,:) - ztrdt(:,:,:) 
    108          CALL trd_mod( ztrdt, ztrds, jptra_trd_bbc, 'TRA', kt ) 
     106         ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 
     107         CALL trd_tra( kt, 'TRA', jp_tem, jptra_trd_bbc, ztrdt ) 
     108         CALL trd_tra( kt, 'TRA', jp_sal, jptra_trd_bbc, ztrds ) 
     109         DEALLOCATE( ztrdt )   ;     DEALLOCATE( ztrds ) 
    109110      ENDIF 
    110111      ! 
    111       IF(ln_ctl)   CALL prt_ctl( tab3d_1=ta, clinfo1=' bbc  - Ta: ', mask1=tmask, clinfo3='tra-ta' ) 
     112      IF(ln_ctl)   CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' bbc  - Ta: ', mask1=tmask, clinfo3='tra-ta' ) 
    112113      ! 
    113114   END SUBROUTINE tra_bbc 

  • branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/trabbl.F90

    r1601 r2024  
    44   !! Ocean physics :  advective and/or diffusive bottom boundary layer scheme 
    55   !!============================================================================== 
    6    !! History :  8.0  !  96-06  (L. Mortier)  Original code 
    7    !!            8.0  !  97-11  (G. Madec)  Optimization 
    8    !!            8.5  !  02-08  (G. Madec)  free form + modules 
    9    !!---------------------------------------------------------------------- 
    10 #if   defined key_trabbl_dif   ||   defined key_trabbl_adv   || defined key_esopa 
    11    !!---------------------------------------------------------------------- 
    12    !!   'key_trabbl_dif'   or            diffusive bottom boundary layer 
    13    !!   'key_trabbl_adv'                 advective bottom boundary layer 
    14    !!---------------------------------------------------------------------- 
    15    !!---------------------------------------------------------------------- 
    16    !!   tra_bbl_dif  : update the active tracer trends due to the bottom 
    17    !!                  boundary layer (diffusive only) 
    18    !!   tra_bbl_adv  : update the active tracer trends due to the bottom 
    19    !!                  boundary layer (advective and/or diffusive) 
    20    !!   tra_bbl_init : initialization, namlist read, parameters control 
    21    !!---------------------------------------------------------------------- 
    22    USE oce                ! ocean dynamics and active tracers 
    23    USE dom_oce            ! ocean space and time domain 
    24    USE trdmod             ! ocean active tracers trends 
    25    USE trdmod_oce         ! ocean variables trends 
    26    USE in_out_manager     ! I/O manager 
    27    USE lbclnk             ! ocean lateral boundary conditions 
    28    USE prtctl             ! Print control 
     6   !! History :  OPA  !  1996-06  (L. Mortier)  Original code 
     7   !!            8.0  !  1997-11  (G. Madec)    Optimization 
     8   !!   NEMO     1.0  !  2002-08  (G. Madec)  free form + modules 
     9   !!             -   !  2004-01  (A. de Miranda, G. Madec, J.M. Molines ) add advective bbl 
     10   !!            3.3  !  2009-11  (G. Madec)  merge trabbl and trabbl_adv + style + optimization  
     11   !!             -   !  2010-04  (G. Madec)  Campin & Goosse advective bbl  
     12   !!             -   !  2010-06  (C. Ethe, G. Madec)  merge TRA-TRC 
     13   !!---------------------------------------------------------------------- 
     14#if   defined key_trabbl   ||   defined key_esopa 
     15   !!---------------------------------------------------------------------- 
     16   !!   'key_trabbl'   or                             bottom boundary layer 
     17   !!---------------------------------------------------------------------- 
     18   !!   tra_bbl       : update the tracer trends due to the bottom boundary layer (advective and/or diffusive) 
     19   !!   tra_bbl_dif   : generic routine to compute bbl diffusive trend 
     20   !!   tra_bbl_adv   : generic routine to compute bbl advective trend 
     21   !!   bbl           : computation of bbl diffu. flux coef. & transport in bottom boundary layer 
     22   !!   tra_bbl_init  : initialization, namlist read, parameters control 
     23   !!---------------------------------------------------------------------- 
     24   USE oce            ! ocean dynamics and active tracers 
     25   USE dom_oce        ! ocean space and time domain 
     26   USE phycst         !  
     27   USE eosbn2         ! equation of state 
     28   USE trdmod_oce        ! ocean space and time domain 
     29   USE trdtra     ! ocean active tracers trends 
     30   USE iom            ! IOM server                
     31   USE in_out_manager ! I/O manager 
     32   USE lbclnk         ! ocean lateral boundary conditions 
     33   USE prtctl         ! Print control 
    2934 
    3035   IMPLICIT NONE 
    3136   PRIVATE 
    3237 
    33    PUBLIC tra_bbl_dif    ! routine called by step.F90 
    34    PUBLIC tra_bbl_adv    ! routine called by step.F90 
    35  
    36    !!* Namelist nambbl: bottom boundary layer 
    37    REAL(wp), PUBLIC ::   rn_ahtbbl = 1.e+3   !: lateral coeff. for bottom boundary layer scheme (m2/s) 
    38  
    39 # if defined key_trabbl_dif 
    40    LOGICAL, PUBLIC, PARAMETER ::   lk_trabbl_dif = .TRUE.          !: diffusive bottom boundary layer flag 
     38   PUBLIC   tra_bbl       ! routine called by step.F90 
     39   PUBLIC   tra_bbl_init  !  routine called by opa.F90 
     40   PUBLIC   tra_bbl_dif   !  routine called by tra_bbl and trc_bbl 
     41   PUBLIC   tra_bbl_adv   !  -          -          -              - 
     42   PUBLIC   bbl           !  -          -          -              - 
     43 
     44# if defined key_trabbl 
     45   LOGICAL, PUBLIC, PARAMETER ::   lk_trabbl = .TRUE.    !: bottom boundary layer flag 
    4146# else 
    42    LOGICAL, PUBLIC, PARAMETER ::   lk_trabbl_dif = .FALSE.         !: diffusive bottom boundary layer flag 
     47   LOGICAL, PUBLIC, PARAMETER ::   lk_trabbl = .FALSE.   !: bottom boundary layer flag 
    4348# endif 
    4449 
    45 # if defined key_trabbl_adv 
    46    LOGICAL, PUBLIC, PARAMETER ::   lk_trabbl_adv = .TRUE.   !: advective bottom boundary layer flag 
    47    REAL(wp), PUBLIC, DIMENSION(jpi,jpj,jpk) ::   u_bbl      !: 3 components of the velocity 
    48    REAL(wp), PUBLIC, DIMENSION(jpi,jpj,jpk) ::   v_bbl      !: associated with advective BBL 
    49    REAL(wp), PUBLIC, DIMENSION(jpi,jpj,jpk) ::   w_bbl      !: (only affect tracer) 
    50 # else 
    51    LOGICAL, PUBLIC, PARAMETER ::   lk_trabbl_adv = .FALSE.  !: advective bottom boundary layer flag 
    52 # endif 
    53  
    54    INTEGER, DIMENSION(jpi,jpj) ::   mbkt          ! vertical index of the bottom ocean T-level 
    55    INTEGER, DIMENSION(jpi,jpj) ::   mbku, mbkv    ! vertical index of the bottom ocean U/V-level 
     50   !                                         !!* Namelist nambbl *  
     51   INTEGER , PUBLIC ::   nn_bbl_ldf = 0       !: =1   : diffusive bbl or not (=0) 
     52   INTEGER , PUBLIC ::   nn_bbl_adv = 0       !: =1/2 : advective bbl or not (=0) 
     53   !                                          !  =1 : advective bbl using the model velocity 
     54   !                                          !  =2 :   -        -  using utr_bbl proportional to grad(rho) 
     55   REAL(wp), PUBLIC ::   rn_ahtbbl  = 1.e+3   !: along slope bbl diffusive coefficient [m2/s] 
     56   REAL(wp), PUBLIC ::   rn_gambbl  = 10.e0   !: lateral coeff. for bottom boundary layer scheme [s] 
     57 
     58   INTEGER , DIMENSION(jpi,jpj) ::   mbkt                   ! vertical index of the bottom ocean T-level 
     59   INTEGER , DIMENSION(jpi,jpj) ::   mbku     , mbkv        ! vertical index of the (upper) bottom ocean U/V-level 
     60   INTEGER , DIMENSION(jpi,jpj) ::   mbku_d   , mbkv_d      ! vertical index of the "lower" bottom ocean U/V-level 
     61   INTEGER , DIMENSION(jpi,jpj) ::   mgrhu    , mgrhv       ! = +/-1, sign of grad(H) in u-(v-)direction 
     62   REAL(wp), DIMENSION(jpi,jpj), PUBLIC ::   utr_bbl  , vtr_bbl     ! u- (v-) transport in the bottom boundary layer 
     63   REAL(wp), DIMENSION(jpi,jpj) ::   ahu_bbl_0, ahv_bbl_0   ! diffusive bbl flux coefficients at u and v-points 
     64   REAL(wp), DIMENSION(jpi,jpj) ::   ahu_bbl  , ahv_bbl     ! masked diffusive bbl coefficients at u and v-points 
     65   REAL(wp), DIMENSION(jpi,jpj) ::   e3u_bbl_0, e3v_bbl_0   ! thichness of the bbl (e3) at u and v-points 
     66   REAL(wp), DIMENSION(jpi,jpj) ::   e1e2t_r   ! thichness of the bbl (e3) at u and v-points 
     67   LOGICAL, PUBLIC              ::   l_bbl                    !: flag to compute bbl diffu. flux coef and transport 
    5668 
    5769   !! * Substitutions 
    … …  
    5971#  include "vectopt_loop_substitute.h90" 
    6072   !!---------------------------------------------------------------------- 
    61    !!   OPA 9.0 , LOCEAN-IPSL (2006)  
     73   !! NEMO/OPA 3.2 , LOCEAN-IPSL (2009)  
    6274   !! $Id$  
    6375   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 
    … …  
    6678CONTAINS 
    6779 
    68    SUBROUTINE tra_bbl_dif( kt ) 
    69       !!---------------------------------------------------------------------- 
    70       !!                   ***  ROUTINE tra_bbl_dif  *** 
    71       !! 
     80 
     81   SUBROUTINE tra_bbl( kt ) 
     82      !!---------------------------------------------------------------------- 
     83      !!                  ***  ROUTINE bbl  *** 
     84      !!                    
    7285      !! ** Purpose :   Compute the before tracer (t & s) trend associated  
    73       !!      with the bottom boundary layer and add it to the general trend  
    74       !!      of tracer equations. The bottom boundary layer is supposed to be 
    75       !!      a purely diffusive bottom boundary layer. 
    76       !! 
    77       !! ** Method  :   When the product grad( rho) * grad(h) < 0 (where grad  
    78       !!      is an along bottom slope gradient) an additional lateral diffu- 
    79       !!      sive trend along the bottom slope is added to the general tracer 
    80       !!      trend, otherwise nothing is done. 
    81       !!      Second order operator (laplacian type) with variable coefficient 
    82       !!      computed as follow for temperature (idem on s):  
    83       !!         difft = 1/(e1t*e2t*e3t) { di-1[ ahbt e2u*e3u/e1u di[ztb] ] 
    84       !!                                 + dj-1[ ahbt e1v*e3v/e2v dj[ztb] ] } 
    85       !!      where ztb is a 2D array: the bottom ocean temperature and ahtb 
    86       !!      is a time and space varying diffusive coefficient defined by: 
    87       !!         ahbt = zahbp    if grad(rho).grad(h) < 0 
    88       !!              = 0.       otherwise. 
    89       !!      Note that grad(.) is the along bottom slope gradient. grad(rho) 
    90       !!      is evaluated using the local density (i.e. referenced at the 
    91       !!      local depth). Typical value of ahbt is 2000 m2/s (equivalent to 
     86      !!     with the bottom boundary layer and add it to the general trend 
     87      !!     of tracer equations. 
     88      !! 
     89      !!----------------------------------------------------------------------   
     90      INTEGER, INTENT( in ) ::   kt   ! ocean time-step  
     91      ! 
     92      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  ztrdt, ztrds 
     93      !!---------------------------------------------------------------------- 
     94 
     95      IF( l_trdtra )   THEN                    !* Save ta and sa trends 
     96         ALLOCATE( ztrdt(jpi,jpj,jpk) )   ;    ztrdt(:,:,:) = tsa(:,:,:,jp_tem)  
     97         ALLOCATE( ztrds(jpi,jpj,jpk) )   ;    ztrds(:,:,:) = tsa(:,:,:,jp_sal) 
     98      ENDIF 
     99 
     100      !* bbl coef and transport are computed only if not already done in passive tracers routine 
     101      IF( l_bbl )      CALL bbl( kt, 'TRA' )  
     102 
     103      !* Diffusive bbl : 
     104      IF( nn_bbl_ldf == 1 ) THEN 
     105         CALL tra_bbl_dif( tsb, tsa, jpts ) 
     106         IF( ln_ctl )  & 
     107         CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' bbl_ldf  - Ta: ', mask1=tmask, & 
     108         &             tab3d_2=tsa(:,:,:,jp_sal), clinfo2=           ' Sa: ', mask2=tmask, clinfo3='tra' ) 
     109         ! lateral boundary conditions ; just need for outputs                           
     110         CALL lbc_lnk( ahu_bbl, 'U', 1. )     ;     CALL lbc_lnk( ahv_bbl, 'V', 1. ) 
     111         CALL iom_put( "ahu_bbl", ahu_bbl )   ! bbl diffusive flux i-coef      
     112         CALL iom_put( "ahv_bbl", ahv_bbl )   ! bbl diffusive flux j-coef 
     113      END IF 
     114 
     115      !* Advective bbl : bbl upstream advective trends added to the tracer trends 
     116      IF( nn_bbl_adv /= 0 ) THEN 
     117         CALL tra_bbl_adv( tsb, tsa, jpts )   
     118         IF(ln_ctl)   & 
     119         CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' bbl_adv  - Ta: ', mask1=tmask,   & 
     120         &             tab3d_2=tsa(:,:,:,jp_sal), clinfo2=           ' Sa: ', mask2=tmask, clinfo3='tra' ) 
     121         ! lateral boundary conditions ; just need for outputs                           
     122         CALL lbc_lnk( utr_bbl, 'U', 1. )     ;   CALL lbc_lnk( vtr_bbl, 'V', 1. )    
     123         CALL iom_put( "uoce_bbl", utr_bbl )  ! bbl i-transport      
     124         CALL iom_put( "voce_bbl", vtr_bbl )  ! bbl j-transport 
     125      END IF 
     126 
     127      IF( l_trdtra )   THEN                      ! save the horizontal diffusive trends for further diagnostics 
     128         ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 
     129         ztrds(:,:,:) = tsa(:,:,:,jp_sal) - ztrds(:,:,:) 
     130         CALL trd_tra( kt, 'TRA', jp_tem, jptra_trd_bbl, ztrdt ) 
     131         CALL trd_tra( kt, 'TRA', jp_sal, jptra_trd_bbl, ztrds ) 
     132         DEALLOCATE( ztrdt )      ;     DEALLOCATE( ztrds )  
     133      ENDIF 
     134      ! 
     135   END SUBROUTINE tra_bbl 
     136 
     137 
     138   SUBROUTINE tra_bbl_dif( ptrab, ptraa, kjpt ) 
     139      !!---------------------------------------------------------------------- 
     140      !!                  ***  ROUTINE tra_bbl_dif  *** 
     141      !!                    
     142      !! ** Purpose :   Computes the bottom boundary horizontal and vertical 
     143      !!                advection terms.  
     144      !! 
     145      !! ** Method  :    
     146      !!        * diffusive bbl (nn_bbl_ldf=1) : 
     147      !!        When the product grad( rho) * grad(h) < 0 (where grad is an 
     148      !!      along bottom slope gradient) an additional lateral 2nd order 
     149      !!      diffusion along the bottom slope is added to the general 
     150      !!      tracer trend, otherwise the additional trend is set to 0. 
     151      !!      A typical value of ahbt is 2000 m2/s (equivalent to 
    92152      !!      a downslope velocity of 20 cm/s if the condition for slope 
    93153      !!      convection is satified) 
    94       !!      Add this before trend to the general trend (ta,sa) of the  
    95       !!      botton ocean tracer point: 
    96       !!         ta = ta + difft 
    97       !! 
    98       !! ** Action  : - update (ta,sa) at the bottom level with the bottom 
    99       !!                boundary layer trend 
    100       !!              - save the trends in ztrdt/ztrds ('key_trdtra') 
     154      !! 
    101155      !! 
    102156      !! References : Beckmann, A., and R. Doscher, 1997, J. Phys.Oceanogr., 581-591. 
    103       !!---------------------------------------------------------------------- 
    104       USE oce, ONLY :   ztrdt => ua   ! use ua as 3D workspace    
    105       USE oce, ONLY :   ztrds => va   ! use va as 3D workspace    
    106       USE eosbn2                      ! equation of state 
    107       !! 
    108       INTEGER, INTENT( in ) ::   kt   ! ocean time-step 
    109       !! 
    110       INTEGER  ::   ji, jj                  ! dummy loop indices 
    111       INTEGER  ::   ik 
    112       INTEGER  ::   ii0, ii1, ij0, ij1      ! temporary integers 
    113       INTEGER  ::   iku1, iku2, ikv1,ikv2   ! temporary intergers 
    114       REAL(wp) ::   ze3u, ze3v              ! temporary scalars 
    115       INTEGER  ::   iku, ikv 
    116       REAL(wp) ::   zsign, zt, zs, zh, zalbet   ! temporary scalars 
    117       REAL(wp) ::   zgdrho, zbtr, zta, zsa 
    118       REAL(wp), DIMENSION(jpi,jpj) ::   zki, zkj, zkw, zkx, zky, zkz             ! 2D workspace 
    119       REAL(wp), DIMENSION(jpi,jpj) ::   ztnb, zsnb, zdep, ztbb, zsbb, zahu, zahv 
    120       !! 
    121       REAL(wp) ::    fsalbt, pft, pfs, pfh   ! statement function 
    122       !!---------------------------------------------------------------------- 
    123       ! ratio alpha/beta 
    124       ! ================ 
    125       !  fsalbt: ratio of thermal over saline expension coefficients 
    126       !       pft :  potential temperature in degrees celcius 
    127       !       pfs :  salinity anomaly (s-35) in psu 
    128       !       pfh :  depth in meters 
    129  
    130       fsalbt( pft, pfs, pfh ) =                                              & 
    131          ( ( ( -0.255019e-07 * pft + 0.298357e-05 ) * pft                    & 
    132          &                         - 0.203814e-03 ) * pft                    & 
    133          &                         + 0.170907e-01 ) * pft                    & 
    134          &                         + 0.665157e-01                            & 
    135          +(-0.678662e-05 * pfs - 0.846960e-04 * pft + 0.378110e-02 ) * pfs   & 
    136          +  ( ( - 0.302285e-13 * pfh                                         & 
    137          &      - 0.251520e-11 * pfs                                         & 
    138          &      + 0.512857e-12 * pft * pft          ) * pfh                  & 
    139          &                           - 0.164759e-06   * pfs                  & 
    140          &   +(   0.791325e-08 * pft - 0.933746e-06 ) * pft                  & 
    141          &                           + 0.380374e-04 ) * pfh    
    142       !!---------------------------------------------------------------------- 
    143  
    144       IF( kt == nit000 )   CALL tra_bbl_init 
    145  
    146       IF( l_trdtra )   THEN         ! Save ta and sa trends 
    147          ztrdt(:,:,:) = ta(:,:,:)  
    148          ztrds(:,:,:) = sa(:,:,:)  
    149       ENDIF 
    150  
    151       ! 0. 2D fields of bottom temperature and salinity, and bottom slope 
    152       ! ----------------------------------------------------------------- 
    153       ! mbathy= number of w-level, minimum value=1 (cf dommsk.F) 
     157      !!              Campin, J.-M., and H. Goosse, 1999, Tellus, 412-430. 
     158      !!----------------------------------------------------------------------   
     159      !!* Arguments 
     160      INTEGER         , INTENT(in   )                                ::   kjpt      ! number of tracers 
     161      REAL(wp)        , INTENT(in   ), DIMENSION(jpi,jpj,jpk,kjpt)   ::   ptrab     ! before and now tracer fields 
     162      REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)   ::   ptraa     ! tracer trend  
     163      ! 
     164      INTEGER  ::   ji, jj, jn           ! dummy loop indices 
     165      INTEGER  ::   ik                       ! temporary integers 
     166      REAL(wp) ::   zbtr, ztra               ! temporary  
     167      REAL(wp), DIMENSION(jpi,jpj) :: ztrb, zkx, zky        ! 2D workspace 
     168      !!---------------------------------------------------------------------- 
     169                                                          ! =========== 
     170      DO jn = 1, kjpt                                     ! tracer loop 
     171         !                                                ! =========== 
     172#if defined key_vectopt_loop 
     173         DO jj = 1, 1   ! vector opt. (forced unrolling) 
     174            DO ji = 1, jpij 
     175#else 
     176         DO jj = 1, jpj 
     177            DO ji = 1, jpi 
     178#endif 
     179               ik = mbkt(ji,jj)                        ! bottom T-level index 
     180               ztrb(ji,jj) = ptrab(ji,jj,ik,jn)              ! bottom before T and S 
     181            END DO 
     182         END DO 
     183         ! 
    154184#  if defined key_vectopt_loop 
    155       DO jj = 1, 1 
    156          DO ji = 1, jpij   ! vector opt. (forced unrolling) 
    157 #  else 
    158       DO jj = 1, jpj 
    159          DO ji = 1, jpi 
    160 #  endif 
    161             ik = mbkt(ji,jj)                              ! index of the bottom ocean T-level 
    162             ztnb(ji,jj) = tn(ji,jj,ik) * tmask(ji,jj,1)   ! masked now T and S at ocean bottom  
    163             zsnb(ji,jj) = sn(ji,jj,ik) * tmask(ji,jj,1) 
    164             ztbb(ji,jj) = tb(ji,jj,ik) * tmask(ji,jj,1)   ! masked before T and S at ocean bottom  
    165             zsbb(ji,jj) = sb(ji,jj,ik) * tmask(ji,jj,1) 
    166             zdep(ji,jj) = fsdept(ji,jj,ik)                ! depth of the ocean bottom T-level 
    167          END DO 
    168       END DO 
    169  
    170       IF( ln_zps ) THEN      ! partial steps correction  
    171 # if defined key_vectopt_loop 
    172          DO jj = 1, 1 
    173             DO ji = 1, jpij-jpi   ! vector opt. (forced unrolling) 
    174 # else 
    175          DO jj = 1, jpjm1 
    176             DO ji = 1, jpim1 
    177 # endif 
    178                iku1 = MAX( mbathy(ji+1,jj  )-1, 1 ) 
    179                iku2 = MAX( mbathy(ji  ,jj  )-1, 1 ) 
    180                ikv1 = MAX( mbathy(ji  ,jj+1)-1, 1 ) 
    181                ikv2 = MAX( mbathy(ji  ,jj  )-1, 1 ) 
    182                ze3u = MIN( fse3u(ji,jj,iku1), fse3u(ji,jj,iku2) )  
    183                ze3v = MIN( fse3v(ji,jj,ikv1), fse3v(ji,jj,ikv2) )  
    184                zahu(ji,jj) = rn_ahtbbl * e2u(ji,jj) * ze3u / e1u(ji,jj) * umask(ji,jj,1) 
    185                zahv(ji,jj) = rn_ahtbbl * e1v(ji,jj) * ze3v / e2v(ji,jj) * vmask(ji,jj,1) 
    186             END DO 
    187          END DO 
    188       ELSE                    ! z-coordinate - full steps or s-coordinate 
    189 #   if defined key_vectopt_loop 
    190          DO jj = 1, 1 
    191             DO ji = 1, jpij-jpi   ! vector opt. (forced unrolling) 
    192 #   else 
    193          DO jj = 1, jpjm1 
    194             DO ji = 1, jpim1 
    195 #   endif 
    196                iku = mbku(ji,jj) 
    197                ikv = mbkv(ji,jj) 
    198                zahu(ji,jj) = rn_ahtbbl * e2u(ji,jj) * fse3u(ji,jj,iku) / e1u(ji,jj) * umask(ji,jj,1) 
    199                zahv(ji,jj) = rn_ahtbbl * e1v(ji,jj) * fse3v(ji,jj,ikv) / e2v(ji,jj) * vmask(ji,jj,1) 
    200             END DO 
    201          END DO 
    202       ENDIF 
    203  
    204       ! 1. Criteria of additional bottom diffusivity: grad(rho).grad(h)<0 
    205       ! -------------------------------------------- 
    206       ! Sign of the local density gradient along the i- and j-slopes 
    207       ! multiplied by the slope of the ocean bottom 
    208  
    209       SELECT CASE ( nn_eos ) 
    210       ! 
    211       CASE ( 0 )                 !==  Jackett and McDougall (1994) formulation  ==! 
    212 #  if defined key_vectopt_loop 
    213          DO jj = 1, 1 
    214             DO ji = 1, jpij-jpi   ! vector opt. (forced unrolling) 
     185         DO jj = 1, 1   ! vector opt. (forced unrolling) 
     186            DO ji = 1, jpij-jpi 
    215187#  else 
    216188         DO jj = 1, jpjm1 
    217189            DO ji = 1, jpim1 
    218190#  endif 
    219                ! temperature, salinity anomalie and depth 
    220                zt = 0.5 * ( ztnb(ji,jj) + ztnb(ji+1,jj) ) 
    221                zs = 0.5 * ( zsnb(ji,jj) + zsnb(ji+1,jj) ) - 35.0 
    222                zh = 0.5 * ( zdep(ji,jj) + zdep(ji+1,jj) ) 
    223                ! masked ratio alpha/beta 
    224                zalbet = fsalbt( zt, zs, zh )*umask(ji,jj,1) 
    225                ! local density gradient along i-bathymetric slope 
    226                zgdrho = zalbet * ( ztnb(ji+1,jj) - ztnb(ji,jj) )   & 
    227                       -          ( zsnb(ji+1,jj) - zsnb(ji,jj) ) 
    228                ! sign of local i-gradient of density multiplied by the i-slope 
    229                zsign = SIGN( 0.5, - zgdrho * ( zdep(ji+1,jj) - zdep(ji,jj) ) ) 
    230                zki(ji,jj) = ( 0.5 - zsign ) * zahu(ji,jj) 
    231                ! 
    232                ! temperature, salinity anomalie and depth 
    233                zt = 0.5 * ( ztnb(ji,jj+1) + ztnb(ji,jj) ) 
    234                zs = 0.5 * ( zsnb(ji,jj+1) + zsnb(ji,jj) ) - 35.0 
    235                zh = 0.5 * ( zdep(ji,jj+1) + zdep(ji,jj) ) 
    236                ! masked ratio alpha/beta 
    237                zalbet = fsalbt( zt, zs, zh )*vmask(ji,jj,1) 
    238                ! local density gradient along j-bathymetric slope 
    239                zgdrho = zalbet * ( ztnb(ji,jj+1) - ztnb(ji,jj) )   & 
    240                       -          ( zsnb(ji,jj+1) - zsnb(ji,jj) ) 
    241                ! sign of local j-gradient of density multiplied by the j-slope 
    242                zsign = sign( 0.5, -zgdrho * ( zdep(ji,jj+1) - zdep(ji,jj) ) ) 
    243                zkj(ji,jj) = ( 0.5 - zsign ) * zahv(ji,jj) 
     191               zkx(ji,jj) = ahu_bbl(ji,jj) * ( ztrb(ji+1,jj  ) - ztrb(ji,jj) )  ! diffusive i-flux 
     192               zky(ji,jj) = ahv_bbl(ji,jj) * ( ztrb(ji  ,jj+1) - ztrb(ji,jj) )  ! diffusive j-flux 
    244193            END DO 
    245194         END DO 
    246          ! 
    247       CASE ( 1 )               !==  Linear formulation function of temperature only  ==! 
     195            !                                        ! Add the diffusive trends 
    248196#  if defined key_vectopt_loop 
     197         DO jj = 1, 1   ! vector opt. (forced unrolling) 
     198            DO ji = jpi+1, jpij-jpi-1 
     199#  else 
     200         DO jj = 2, jpjm1 
     201            DO ji = 2, jpim1 
     202#  endif 
     203               ik = mbkt(ji,jj) 
     204               zbtr = e1e2t_r(ji,jj)  / fse3t(ji,jj,ik) 
     205               ztra = ( zkx(ji,jj) - zkx(ji-1,jj) + zky(ji,jj) - zky(ji,jj-1) ) * zbtr 
     206               ptraa(ji,jj,ik,jn) = ptraa(ji,jj,ik,jn) + ztra 
     207            END DO 
     208         END DO 
     209         ! 
     210      END DO 
     211      ! 
     212   END SUBROUTINE tra_bbl_dif 
     213 
     214   SUBROUTINE tra_bbl_adv( ptrab, ptraa, kjpt ) 
     215      !!---------------------------------------------------------------------- 
     216      !!                  ***  ROUTINE trc_bbl  *** 
     217      !!                    
     218      !! ** Purpose :   Compute the before passive tracer trend associated  
     219      !!     with the bottom boundary layer and add it to the general trend 
     220      !!     of tracer equations. 
     221      !!        * advective bbl (nn_bbl_adv=1 or 2) : 
     222      !!      nn_bbl_adv = 1   use of the ocean velocity as bbl velocity 
     223      !!      nn_bbl_adv = 2   follow Campin and Goosse (1999) implentation 
     224      !!        i.e. transport proportional to the along-slope density gradient 
     225      !! 
     226      !!      NB: the along slope density gradient is evaluated using the 
     227      !!      local density (i.e. referenced at a common local depth). 
     228      !! 
     229      !! 
     230      !! References : Beckmann, A., and R. Doscher, 1997, J. Phys.Oceanogr., 581-591. 
     231      !!              Campin, J.-M., and H. Goosse, 1999, Tellus, 412-430. 
     232      !! 
     233      !!----------------------------------------------------------------------   
     234      !!* Arguments 
     235      INTEGER         , INTENT(in   )                                ::   kjpt            ! number of tracers 
     236      REAL(wp)        , INTENT(in   ), DIMENSION(jpi,jpj,jpk,kjpt)   ::   ptrab          ! before and now tracer fields 
     237      REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)   ::   ptraa          ! tracer trend  
     238      ! 
     239      INTEGER  ::   ji, jj, jk, jn           ! dummy loop indices 
     240      INTEGER  ::   ik                       ! temporary integers 
     241      INTEGER  ::   iis , iid , ijs , ijd    !    -          - 
     242      INTEGER  ::   ikus, ikud, ikvs, ikvd   !    -          - 
     243      REAL(wp) ::   zbtr, ztra               !    -         - 
     244      REAL(wp) ::   zu_bbl, zv_bbl           !    -         - 
     245      !!---------------------------------------------------------------------- 
     246 
     247      !                                                          ! =========== 
     248      DO jn = 1, kjpt                                            ! tracer loop 
     249         !                                                       ! ===========          
     250# if defined key_vectopt_loop 
    249251         DO jj = 1, 1 
    250             DO ji = 1, jpij-jpi   ! vector opt. (forced unrolling) 
     252            DO ji = jpi+1, jpij-jpi-1   ! vector opt. (forced unrolling) 
     253# else 
     254         DO jj = 2, jpjm1 
     255            DO ji = 1, jpim1            ! CAUTION start from i=1 to update i=2 when cyclic east-west 
     256# endif 
     257               IF( utr_bbl(ji,jj) /= 0.e0 ) THEN            ! non-zero i-direction bbl advection 
     258                  ! down-slope i/k-indices (deep)      &   up-slope i/k indices (shelf) 
     259                  iid  = ji + MAX( 0, mgrhu(ji,jj) )   ;   iis  = ji + 1 - MAX( 0, mgrhu(ji,jj) ) 
     260                  ikud = mbku_d(ji,jj)                 ;   ikus = mbku(ji,jj) 
     261                  zu_bbl = ABS( utr_bbl(ji,jj) ) 
     262                  ! 
     263                  !                                               ! up  -slope T-point (shelf bottom point) 
     264                  zbtr = e1e2t_r(iis,jj) / fse3t(iis,jj,ikus) 
     265                  ztra = zu_bbl * ( ptrab(iid,jj,ikus,jn) - ptrab(iis,jj,ikus,jn) ) * zbtr 
     266                  ptraa(iis,jj,ikus,jn) = ptraa(iis,jj,ikus,jn) + ztra 
     267                  !                    
     268                  DO jk = ikus, ikud-1                            ! down-slope upper to down T-point (deep column) 
     269                     zbtr = e1e2t_r(iid,jj) / fse3t(iid,jj,jk) 
     270                     ztra = zu_bbl * ( ptrab(iid,jj,jk+1,jn) - ptrab(iid,jj,jk,jn) ) * zbtr 
     271                     ptraa(iid,jj,jk,jn) = ptraa(iid,jj,jk,jn) + ztra 
     272                  END DO 
     273                  !  
     274                  zbtr = e1e2t_r(iid,jj) / fse3t(iid,jj,ikud) 
     275                  ztra = zu_bbl * ( ptrab(iis,jj,ikus,jn) - ptrab(iid,jj,ikud,jn) ) * zbtr 
     276                  ptraa(iid,jj,ikud,jn) = ptraa(iid,jj,ikud,jn) + ztra 
     277               ENDIF 
     278               IF( vtr_bbl(ji,jj) /= 0.e0 ) THEN            ! non-zero j-direction bbl advection 
     279                  ! down-slope j/k-indices (deep)        &   up-slope j/k indices (shelf) 
     280                  ijd  = jj + MAX( 0, mgrhv(ji,jj) )     ;   ijs  = jj + 1 - MAX( 0, mgrhv(ji,jj) ) 
     281                  ikvd = mbkv_d(ji,jj)                   ;   ikvs = mbkv(ji,jj) 
     282                  zv_bbl = ABS( vtr_bbl(ji,jj) ) 
     283                  !  
     284                  ! up  -slope T-point (shelf bottom point) 
     285                  zbtr = e1e2t_r(ji,ijs) / fse3t(ji,ijs,ikvs) 
     286                  ztra = zv_bbl * ( ptrab(ji,ijd,ikvs,jn) - ptrab(ji,ijs,ikvs,jn) ) * zbtr 
     287                  ptraa(ji,ijs,ikvs,jn) = ptraa(ji,ijs,ikvs,jn) + ztra 
     288                  !                    
     289                  DO jk = ikvs, ikvd-1                            ! down-slope upper to down T-point (deep column) 
     290                     zbtr = e1e2t_r(ji,ijd) / fse3t(ji,ijd,jk) 
     291                     ztra = zv_bbl * ( ptrab(ji,ijd,jk+1,jn) - ptrab(ji,ijd,jk,jn) ) * zbtr 
     292                     ptraa(ji,ijd,jk,jn) = ptraa(ji,ijd,jk,jn)  + ztra 
     293                  END DO 
     294                  !                                               ! down-slope T-point (deep bottom point) 
     295                  zbtr = e1e2t_r(ji,ijd) / fse3t(ji,ijd,ikvd) 
     296                  ztra = zv_bbl * ( ptrab(ji,ijs,ikvs,jn) - ptrab(ji,ijd,ikvd,jn) ) * zbtr 
     297                  ptraa(ji,ijd,ikvd,jn) = ptraa(ji,ijd,ikvd,jn) + ztra 
     298               ENDIF 
     299            END DO 
     300            ! 
     301         END DO 
     302            ! 
     303      END DO 
     304      ! 
     305   END SUBROUTINE tra_bbl_adv 
     306 
     307   SUBROUTINE bbl( kt, cdtype ) 
     308      !!---------------------------------------------------------------------- 
     309      !!                  ***  ROUTINE bbl  *** 
     310      !!                    
     311      !! ** Purpose :   Computes the bottom boundary horizontal and vertical 
     312      !!                advection terms.  
     313      !! 
     314      !! ** Method  :    
     315      !!        * diffusive bbl (nn_bbl_ldf=1) : 
     316      !!        When the product grad( rho) * grad(h) < 0 (where grad is an 
     317      !!      along bottom slope gradient) an additional lateral 2nd order 
     318      !!      diffusion along the bottom slope is added to the general 
     319      !!      tracer trend, otherwise the additional trend is set to 0. 
     320      !!      A typical value of ahbt is 2000 m2/s (equivalent to 
     321      !!      a downslope velocity of 20 cm/s if the condition for slope 
     322      !!      convection is satified) 
     323      !!        * advective bbl (nn_bbl_adv=1 or 2) : 
     324      !!      nn_bbl_adv = 1   use of the ocean velocity as bbl velocity 
     325      !!      nn_bbl_adv = 2   follow Campin and Goosse (1999) implentation 
     326      !!        i.e. transport proportional to the along-slope density gradient 
     327      !! 
     328      !!      NB: the along slope density gradient is evaluated using the 
     329      !!      local density (i.e. referenced at a common local depth). 
     330      !! 
     331      !! 
     332      !! References : Beckmann, A., and R. Doscher, 1997, J. Phys.Oceanogr., 581-591. 
     333      !!              Campin, J.-M., and H. Goosse, 1999, Tellus, 412-430. 
     334      !!----------------------------------------------------------------------   
     335      INTEGER         , INTENT(in   )                               ::   kt              ! ocean time-step index 
     336      CHARACTER(len=3), INTENT(in   )                               ::   cdtype          ! =TRA or TRC (tracer indicator) 
     337      INTEGER  ::   ji, jj                    ! dummy loop indices 
     338      INTEGER  ::   ik                         ! temporary integers 
     339      INTEGER  ::   iis , iid , ijs , ijd     !    -          - 
     340      INTEGER  ::   ikus, ikud, ikvs, ikvd    !    -          - 
     341      REAL(wp) ::   zsign, zsigna, zgbbl      ! temporary scalars 
     342      REAL(wp) ::   zgdrho, zt, zs, zh        !    -         - 
     343      REAL(wp), DIMENSION(jpi,jpj) ::   zub, zvb, ztb, zsb, zdep  !  -      - 
     344      !! 
     345      REAL(wp) ::   fsalbt, fsbeta, pft, pfs, pfh   ! statement function 
     346      !!----------------------- zv_bbl----------------------------------------------- 
     347      ! ratio alpha/beta = fsalbt : ratio of thermal over saline expension coefficients 
     348      ! ================            pft :  potential temperature in degrees celcius 
     349      !                             pfs :  salinity anomaly (s-35) in psu 
     350      !                             pfh :  depth in meters 
     351      ! nn_eos = 0  (Jackett and McDougall 1994 formulation) 
     352      fsalbt( pft, pfs, pfh ) =                                              &   ! alpha/beta 
     353         ( ( ( -0.255019e-07 * pft + 0.298357e-05 ) * pft                    & 
     354                                   - 0.203814e-03 ) * pft                    & 
     355                                   + 0.170907e-01 ) * pft                    & 
     356                                   + 0.665157e-01                            & 
     357         +(-0.678662e-05 * pfs - 0.846960e-04 * pft + 0.378110e-02 ) * pfs   & 
     358         +  ( ( - 0.302285e-13 * pfh                                         & 
     359                - 0.251520e-11 * pfs                                         & 
     360                + 0.512857e-12 * pft * pft          ) * pfh                  & 
     361                                     - 0.164759e-06   * pfs                  & 
     362             +(   0.791325e-08 * pft - 0.933746e-06 ) * pft                  & 
     363                                     + 0.380374e-04 ) * pfh 
     364      fsbeta( pft, pfs, pfh ) =                                              &   ! beta 
     365         ( ( -0.415613e-09 * pft + 0.555579e-07 ) * pft                      & 
     366                                 - 0.301985e-05 ) * pft                      & 
     367                                 + 0.785567e-03                              & 
     368         + (     0.515032e-08 * pfs                                          & 
     369               + 0.788212e-08 * pft - 0.356603e-06 ) * pfs                   & 
     370               +(  (   0.121551e-17 * pfh                                    & 
     371                     - 0.602281e-15 * pfs                                    & 
     372                     - 0.175379e-14 * pft + 0.176621e-12 ) * pfh             & 
     373                                          + 0.408195e-10   * pfs             & 
     374                 + ( - 0.213127e-11 * pft + 0.192867e-09 ) * pft             & 
     375                                          - 0.121555e-07 ) * pfh 
     376      !!---------------------------------------------------------------------- 
     377       
     378      !                                        !* bottom temperature, salinity, velocity and depth 
     379      IF( kt == nit000 ) THEN 
     380         IF(lwp)  WRITE(numout,*) ' ' 
     381         IF(lwp)  WRITE(numout,*) ' trabbl:bbl  : Compute bbl velocities and diffusive coefficients in ', cdtype, ' at time step ', kt 
     382         IF(lwp)  WRITE(numout,*) ' ' 
     383      ENDIF 
     384 
     385#if defined key_vectopt_loop 
     386      DO jj = 1, 1   ! vector opt. (forced unrolling) 
     387         DO ji = 1, jpij 
     388#else 
     389      DO jj = 1, jpj 
     390         DO ji = 1, jpi 
     391#endif 
     392            ik = mbkt(ji,jj)                        ! bottom T-level index 
     393            ztb (ji,jj) = tb(ji,jj,ik)              ! bottom before T and S 
     394            zsb (ji,jj) = sb(ji,jj,ik) 
     395            zdep(ji,jj) = fsdept_0(ji,jj,ik)        ! bottom T-level reference depth 
     396            ! 
     397            zub(ji,jj) = un(ji,jj,mbku(ji,jj))      ! bottom velocity 
     398            zvb(ji,jj) = vn(ji,jj,mbkv(ji,jj))  
     399         END DO 
     400      END DO 
     401       
     402      !                                   !-------------------! 
     403      IF( nn_bbl_ldf == 1 ) THEN          !   diffusive bbl   ! 
     404         !                                !-------------------! 
     405         !                                        ! bbl diffusive fluxes 
     406         !                                             ! (criteria for non zero flux: grad(rho).grad(h) < 0 ) 
     407#  if defined key_vectopt_loop 
     408         DO jj = 1, 1   ! vector opt. (forced unrolling) 
     409            DO ji = 1, jpij-jpi 
    251410#  else 
    252411         DO jj = 1, jpjm1 
    253412            DO ji = 1, jpim1 
    254413#  endif 
    255                ! local 'density/temperature' gradient along i-bathymetric slope 
    256                zgdrho =  ztnb(ji+1,jj) - ztnb(ji,jj)  
    257                ! sign of local i-gradient of density multiplied by the i-slope 
    258                zsign = SIGN( 0.5, - zgdrho * ( zdep(ji+1,jj) - zdep(ji,jj) ) ) 
    259                zki(ji,jj) = ( 0.5 - zsign ) * zahu(ji,jj) 
     414               !                                                ! i-direction  
     415               zt = 0.5 * ( ztb (ji,jj) + ztb (ji+1,jj) )  ! T, S anomalie, and depth 
     416               zs = 0.5 * ( zsb (ji,jj) + zsb (ji+1,jj) ) - 35.0 
     417               zh = 0.5 * ( zdep(ji,jj) + zdep(ji+1,jj) ) 
     418               !                                                         ! masked bbl i-gradient of density 
     419               zgdrho = (  fsalbt( zt, zs, zh ) * ( ztb(ji+1,jj) - ztb(ji,jj) )    & 
     420                  &                             - ( zsb(ji+1,jj) - zsb(ji,jj) )  ) * umask(ji,jj,1) 
     421               !                                                      
     422               zsign          = SIGN(  0.5, - zgdrho * REAL( mgrhu(ji,jj) )  )    ! sign of ( i-gradient * i-slope ) 
     423               ahu_bbl(ji,jj) = ( 0.5 - zsign ) * ahu_bbl_0(ji,jj)                  ! masked diffusive flux coeff. 
    260424               ! 
    261                ! local density gradient along j-bathymetric slope 
    262                zgdrho =  ztnb(ji,jj+1) - ztnb(ji,jj)  
    263                ! sign of local j-gradient of density multiplied by the j-slope 
    264                zsign = sign( 0.5, -zgdrho * ( zdep(ji,jj+1) - zdep(ji,jj) ) ) 
    265                zkj(ji,jj) = ( 0.5 - zsign ) * zahv(ji,jj) 
     425               !                                                ! j-direction  
     426               zt = 0.5 * ( ztb (ji,jj+1) + ztb (ji,jj) )                ! T, S anomalie, and depth 
     427               zs = 0.5 * ( zsb (ji,jj+1) + zsb (ji,jj) ) - 35.0 
     428               zh = 0.5 * ( zdep(ji,jj+1) + zdep(ji,jj) ) 
     429               !                                                         ! masked bbl j-gradient of density 
     430               zgdrho = (  fsalbt( zt, zs, zh ) * ( ztb(ji,jj+1) - ztb(ji,jj) )    & 
     431                  &                             - ( zsb(ji,jj+1) - zsb(ji,jj) )  ) * vmask(ji,jj,1) 
     432               !                                                     
     433               zsign          = SIGN(  0.5, -zgdrho * REAL( mgrhv(ji,jj) )  )     ! sign of ( j-gradient * j-slope ) 
     434               ahv_bbl(ji,jj) = ( 0.5 - zsign ) * ahv_bbl_0(ji,jj) 
     435               ! 
    266436            END DO 
    267437         END DO 
    268438         ! 
    269       CASE ( 2 )               !==  Linear formulation function of temperature and salinity  ==! 
    270 #  if defined key_vectopt_loop 
    271          DO jj = 1, 1 
    272             DO ji = 1, jpij-jpi   ! vector opt. (forced unrolling) 
    273 #  else 
    274          DO jj = 1, jpjm1 
    275             DO ji = 1, jpim1 
    276 #  endif       
    277                ! local density gradient along i-bathymetric slope 
    278                zgdrho = - ( rn_beta *( zsnb(ji+1,jj) - zsnb(ji,jj) )   & 
    279                   &       - rn_alpha*( ztnb(ji+1,jj) - ztnb(ji,jj) ) ) 
    280                ! sign of local i-gradient of density multiplied by the i-slope 
    281                zsign = SIGN( 0.5, - zgdrho * ( zdep(ji+1,jj) - zdep(ji,jj) ) ) 
    282                zki(ji,jj) = ( 0.5 - zsign ) * zahu(ji,jj) 
    283                ! 
    284                ! local density gradient along j-bathymetric slope 
    285                zgdrho = - ( rn_beta *( zsnb(ji,jj+1) - zsnb(ji,jj) )   & 
    286                   &       - rn_alpha*( ztnb(ji,jj+1) - ztnb(ji,jj) ) )    
    287                ! sign of local j-gradient of density multiplied by the j-slope 
    288                zsign = sign( 0.5, -zgdrho * ( zdep(ji,jj+1) - zdep(ji,jj) ) ) 
    289                zkj(ji,jj) = ( 0.5 - zsign ) * zahv(ji,jj) 
     439      ENDIF 
     440 
     441 
     442      !                                   !-------------------! 
     443      IF( nn_bbl_adv /= 0 ) THEN          !   advective bbl   ! 
     444         !                                !-------------------! 
     445         SELECT CASE ( nn_bbl_adv )             !* bbl transport type 
     446         ! 
     447         CASE( 1 )                                   != use of upper velocity 
     448            DO jj = 2, jpjm1                                 ! criteria: grad(rho).grad(h)<0  and grad(rho).grad(h)<0 
     449               DO ji = 1, fs_jpim1   ! vector opt. 
     450                  !                                               ! i-direction 
     451                  zt = 0.5 * ( ztb (ji,jj) + ztb (ji+1,jj) )                  ! T, S anomalie, and depth 
     452                  zs = 0.5 * ( zsb (ji,jj) + zsb (ji+1,jj) ) - 35.0 
     453                  zh = 0.5 * ( zdep(ji,jj) + zdep(ji+1,jj) ) 
     454                  !                                                           ! masked bbl i-gradient of density 
     455                  zgdrho = (  fsalbt( zt, zs, zh ) * ( ztb(ji+1,jj) - ztb(ji,jj) )    &   
     456                     &                             - ( zsb(ji+1,jj) - zsb(ji,jj) )  ) * umask(ji,jj,1) 
     457                  !                                                          
     458                  zsign = SIGN(  0.5, - zgdrho   * REAL( mgrhu(ji,jj) )  )    ! sign of i-gradient * i-slope 
     459                  zsigna= SIGN(  0.5, zub(ji,jj) * REAL( mgrhu(ji,jj) )  )    ! sign of u * i-slope 
     460                  ! 
     461                  !                                                           ! bbl velocity 
     462                  utr_bbl(ji,jj) = ( 0.5 + zsigna ) * ( 0.5 - zsign ) * e2u(ji,jj) * e3u_bbl_0(ji,jj) * zub(ji,jj) 
     463                  ! 
     464                  !                                               ! j-direction 
     465                  zt = 0.5 * ( ztb (ji,jj+1) + ztb (ji,jj) )                  ! T, S anomalie, and depth 
     466                  zs = 0.5 * ( zsb (ji,jj+1) + zsb (ji,jj) ) - 35.0 
     467                  zh = 0.5 * ( zdep(ji,jj+1) + zdep(ji,jj) ) 
     468                  !                                                           ! masked bbl j-gradient of density 
     469                  zgdrho = (  fsalbt( zt, zs, zh ) * ( ztb(ji,jj+1) - ztb(ji,jj) )    &   
     470                     &                             - ( zsb(ji,jj+1) - zsb(ji,jj) )  ) * vmask(ji,jj,1) 
     471                  zsign = SIGN(  0.5, - zgdrho   * REAL( mgrhv(ji,jj) )  )    ! sign of j-gradient * j-slope 
     472                  zsigna= SIGN(  0.5, zvb(ji,jj) * REAL( mgrhv(ji,jj) )  )    ! sign of u * i-slope 
     473                  ! 
     474                  !                                                           ! bbl velocity 
     475                  vtr_bbl(ji,jj) = ( 0.5 + zsigna ) * ( 0.5 - zsign ) * e1v(ji,jj) * e3v_bbl_0(ji,jj) * zvb(ji,jj) 
     476               END DO 
    290477            END DO 
    291          END DO 
    292          ! 
    293       END SELECT 
    294  
    295       ! 2. Additional second order diffusive trends 
    296       ! ------------------------------------------- 
    297  
    298       ! first derivative (gradient) 
    299 #  if defined key_vectopt_loop 
    300       jj = 1 
    301       DO ji = 1, jpij-jpi   ! vector opt. (forced unrolling) 
    302 #  else 
    303       DO jj = 1, jpjm1 
    304          DO ji = 1, jpim1 
    305 #  endif 
    306             zkx(ji,jj) = zki(ji,jj) * ( ztbb(ji+1,jj) - ztbb(ji,jj) ) 
    307             zkz(ji,jj) = zki(ji,jj) * ( zsbb(ji+1,jj) - zsbb(ji,jj) ) 
    308  
    309             zky(ji,jj) = zkj(ji,jj) * ( ztbb(ji,jj+1) - ztbb(ji,jj) ) 
    310             zkw(ji,jj) = zkj(ji,jj) * ( zsbb(ji,jj+1) - zsbb(ji,jj) ) 
    311 #  if ! defined key_vectopt_loop 
    312          END DO 
    313 #  endif 
    314       END DO 
    315  
    316       IF( cp_cfg == "orca" ) THEN 
    317          ! 
    318          SELECT CASE ( jp_cfg ) 
    319          !                                           ! ======================= 
    320          CASE ( 2 )                                  !  ORCA_R2 configuration 
    321             !                                        ! ======================= 
    322             ! Gibraltar enhancement of BBL 
    323             ij0 = 102   ;   ij1 = 102 
    324             ii0 = 139   ;   ii1 = 140   
    325             zkx( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 4.e0 * zkx( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) 
    326             zky( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 4.e0 * zky( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) 
    327             ! 
    328             ! Red Sea enhancement of BBL 
    329             ij0 =  88   ;   ij1 =  88 
    330             ii0 = 161   ;   ii1 = 162 
    331             zkx( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 10.e0 * zkx( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) 
    332             zky( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 10.e0 * zky( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) 
    333             ! 
    334             !                                        ! ======================= 
    335          CASE ( 4 )                                  !  ORCA_R4 configuration 
    336             !                                        ! ======================= 
    337             ! Gibraltar enhancement of BBL 
    338             ij0 =  52   ;   ij1 =  52 
    339             ii0 =  70   ;   ii1 =  71   
    340             zkx( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 4.e0 * zkx( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) 
    341             zky( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 4.e0 * zky( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) 
    342             ! 
     478         ! 
     479         CASE( 2 )                                 != bbl velocity = F( delta rho ) 
     480            zgbbl = grav * rn_gambbl 
     481            DO jj = 2, jpjm1                            ! criteria: rho_up > rho_down 
     482               DO ji = 1, fs_jpim1   ! vector opt. 
     483                  !                                         ! i-direction 
     484                  ! down-slope T-point i/k-index (deep)  &   up-slope T-point i/k-index (shelf) 
     485                  iid  = ji + MAX( 0, mgrhu(ji,jj) )     ;    iis  = ji + 1 - MAX( 0, mgrhu(ji,jj) ) 
     486                  ikud = mbku_d(ji,jj)                   ;    ikus = mbku(ji,jj) 
     487                  ! 
     488                  !                                             ! mid-depth density anomalie (up-slope minus down-slope) 
     489                  zt = 0.5 * ( ztb (ji,jj) + ztb (ji+1,jj) )           ! mid slope depth of T, S, and depth 
     490                  zs = 0.5 * ( zsb (ji,jj) + zsb (ji+1,jj) ) - 35.0 
     491                  zh = 0.5 * ( zdep(ji,jj) + zdep(ji+1,jj) ) 
     492                  zgdrho =    fsbeta( zt, zs, zh )                                    & 
     493                     &   * (  fsalbt( zt, zs, zh ) * ( ztb(iid,jj) - ztb(iis,jj) )    &   
     494                     &                             - ( zsb(iid,jj) - zsb(iis,jj) )  ) * umask(ji,jj,1) 
     495                  zgdrho = MAX( 0.e0, zgdrho )                         ! only if shelf is denser than deep 
     496                  ! 
     497                  !                                             ! bbl transport (down-slope direction) 
     498                  utr_bbl(ji,jj) = e2u(ji,jj) * e3u_bbl_0(ji,jj) * zgbbl * zgdrho * REAL( mgrhu(ji,jj) ) 
     499                  ! 
     500                  !                                         ! j-direction 
     501                  !  down-slope T-point j/k-index (deep)  &   of the up  -slope T-point j/k-index (shelf) 
     502                  ijd  = jj + MAX( 0, mgrhv(ji,jj) )      ;    ijs  = jj + 1 - MAX( 0, mgrhv(ji,jj) ) 
     503                  ikvd = mbkv_d(ji,jj)                    ;    ikvs = mbkv(ji,jj) 
     504                  ! 
     505                  !                                             ! mid-depth density anomalie (up-slope minus down-slope) 
     506                  zt = 0.5 * ( ztb (ji,jj) + ztb (ji,jj+1) )           ! mid slope depth of T, S, and depth 
     507                  zs = 0.5 * ( zsb (ji,jj) + zsb (ji,jj+1) ) - 35.0 
     508                  zh = 0.5 * ( zdep(ji,jj) + zdep(ji,jj+1) ) 
     509                  zgdrho =    fsbeta( zt, zs, zh )                                    & 
     510                     &   * (  fsalbt( zt, zs, zh ) * ( ztb(ji,ijd) - ztb(ji,ijs) )    &   
     511                     &                             - ( zsb(ji,ijd) - zsb(ji,ijs) )  ) * vmask(ji,jj,1) 
     512                  zgdrho = MAX( 0.e0, zgdrho )                         ! only if shelf is denser than deep 
     513                  ! 
     514                  !                                             ! bbl transport (down-slope direction) 
     515                  vtr_bbl(ji,jj) = e1v(ji,jj) * e3v_bbl_0(ji,jj) * zgbbl * zgdrho * REAL( mgrhv(ji,jj) ) 
     516               END DO 
     517            END DO 
    343518         END SELECT 
    344       ! 
     519         ! 
    345520      ENDIF 
    346  
    347  
    348       ! second derivative (divergence) and add to the general tracer trend 
    349 #  if defined key_vectopt_loop 
    350       DO jj = 1, 1 
    351          DO ji = jpi+2, jpij-jpi-1   ! vector opt. (forced unrolling) 
    352 #  else 
    353       DO jj = 2, jpjm1 
    354          DO ji = 2, jpim1 
    355 #  endif 
    356             ik = max( mbathy(ji,jj)-1, 1 ) 
    357             zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,ik) ) 
    358             zta = (  zkx(ji,jj) - zkx(ji-1,jj  )    & 
    359                    + zky(ji,jj) - zky(ji  ,jj-1)  ) * zbtr 
    360             zsa = (  zkz(ji,jj) - zkz(ji-1,jj  )    & 
    361                    + zkw(ji,jj) - zkw(ji  ,jj-1)  ) * zbtr 
    362             ta(ji,jj,ik) = ta(ji,jj,ik) + zta 
    363             sa(ji,jj,ik) = sa(ji,jj,ik) + zsa 
    364          END DO 
    365       END DO 
    366  
    367       IF( l_trdtra ) THEN      ! save the BBL lateral diffusion trends for diagnostic 
    368          ztrdt(:,:,:) = ta(:,:,:) - ztrdt(:,:,:) 
    369          ztrds(:,:,:) = sa(:,:,:) - ztrds(:,:,:) 
    370          CALL trd_mod(ztrdt, ztrds, jptra_trd_bbl, 'TRA', kt) 
    371       ENDIF 
    372  
    373       IF(ln_ctl)   CALL prt_ctl( tab3d_1=ta, clinfo1=' bbl  - Ta: ', mask1=tmask,   & 
    374          &                       tab3d_2=sa, clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    375       ! 
    376    END SUBROUTINE tra_bbl_dif 
    377  
    378 # if defined key_trabbl_adv 
    379    !!---------------------------------------------------------------------- 
    380    !!   'key_trabbl_adv'                    advective bottom boundary layer 
    381    !!---------------------------------------------------------------------- 
    382 #  include "trabbl_adv.h90" 
    383 # else 
    384    !!---------------------------------------------------------------------- 
    385    !!   Default option :                 NO advective bottom boundary layer 
    386    !!---------------------------------------------------------------------- 
    387    SUBROUTINE tra_bbl_adv (kt )              ! Empty routine 
    388       INTEGER, INTENT(in) :: kt 
    389       WRITE(*,*) 'tra_bbl_adv: You should not have seen this print! error?', kt 
    390    END SUBROUTINE tra_bbl_adv 
    391 # endif 
     521      ! 
     522   END SUBROUTINE bbl 
     523 
    392524 
    393525   SUBROUTINE tra_bbl_init 
    … …  
    400532      !!      called by tra_bbl at the first timestep (nit000) 
    401533      !!---------------------------------------------------------------------- 
    402       INTEGER ::   ji, jj      ! dummy loop indices 
    403       REAL(wp),  DIMENSION(jpi,jpj) :: zmbk   
    404  
    405       NAMELIST/nambbl/ rn_ahtbbl 
    406       !!---------------------------------------------------------------------- 
    407  
    408       REWIND ( numnam )              ! Read Namelist nambbl : bottom boundary layer scheme 
     534      INTEGER ::   ji, jj               ! dummy loop indices 
     535      INTEGER ::   ii0, ii1, ij0, ij1   ! temporary integer 
     536      REAL(wp), DIMENSION(jpi,jpj) ::   zmbk   ! 2D workspace  
     537 
     538      NAMELIST/nambbl/ nn_bbl_ldf, nn_bbl_adv, rn_ahtbbl, rn_gambbl 
     539      !!---------------------------------------------------------------------- 
     540 
     541      REWIND ( numnam )              !* Read Namelist nambbl : bottom boundary layer scheme 
    409542      READ   ( numnam, nambbl ) 
    410543 
    411       IF(lwp) THEN                   ! Parameter control and print 
     544      IF(lwp) THEN                   !* Parameter control and print 
    412545         WRITE(numout,*) 
    413          WRITE(numout,*) 'tra_bbl_init : ' 
     546         WRITE(numout,*) 'tra_bbl_init : bottom boundary layer initialisation' 
    414547         WRITE(numout,*) '~~~~~~~~~~~~' 
    415          IF( lk_trabbl_dif )   WRITE(numout,*) '               * Diffusive Bottom Boundary Layer' 
    416          IF( lk_trabbl_adv )   WRITE(numout,*) '               * Advective Bottom Boundary Layer' 
    417548         WRITE(numout,*) '       Namelist nambbl : set bbl parameters' 
    418          WRITE(numout,*) '          bottom boundary layer coef.    rn_ahtbbl = ', rn_ahtbbl 
     549         WRITE(numout,*) '          diffusive bbl (=1)   or not (=0)    nn_bbl_ldf = ', nn_bbl_ldf 
     550         WRITE(numout,*) '          advective bbl (=1/2) or not (=0)    nn_bbl_adv = ', nn_bbl_adv 
     551         WRITE(numout,*) '          diffusive bbl coefficient           rn_ahtbbl  = ', rn_ahtbbl, ' m2/s' 
     552         WRITE(numout,*) '          advective bbl coefficient           rn_gambbl  = ', rn_gambbl, ' s' 
    419553      ENDIF 
    420   
    421       DO jj = 1, jpj 
     554       
     555      IF( nn_bbl_adv == 1 )    WRITE(numout,*) '       * Advective BBL using upper velocity' 
     556      IF( nn_bbl_adv == 2 )    WRITE(numout,*) '       * Advective BBL using velocity = F( delta rho)' 
     557 
     558      IF( nn_eos /= 0 )   CALL ctl_stop ( ' bbl parameterisation requires eos = 0. We stop.' ) 
     559 
     560 
     561      !                             !* inverse of surface of T-cells 
     562      e1e2t_r(:,:) = 1.0 / ( e1t(:,:) * e2t(:,:) ) 
     563       
     564      !                             !* vertical index of bottom t-, u- and v-points 
     565      DO jj = 1, jpj                      ! bottom k-index of T-level 
    422566         DO ji = 1, jpi 
    423             mbkt(ji,jj) = MAX( mbathy(ji,jj) - 1, 1 )   ! vertical index of the bottom ocean T-level 
     567            mbkt(ji,jj) = MAX( mbathy(ji,jj) - 1, 1 ) 
    424568         END DO 
    425569      END DO 
    426       DO jj = 1, jpjm1 
     570      DO jj = 1, jpjm1                    ! bottom k-index of u- (v-) level (shelf and deep) 
    427571         DO ji = 1, jpim1 
    428             mbku(ji,jj) = MAX( MIN( mbathy(ji+1,jj  ), mbathy(ji,jj) ) - 1, 1 ) 
    429             mbkv(ji,jj) = MAX( MIN( mbathy(ji  ,jj+1), mbathy(ji,jj) ) - 1, 1 ) 
     572            mbku  (ji,jj) = MAX( MIN( mbathy(ji+1,jj  ), mbathy(ji,jj) ) - 1, 1 )   ! "shelf" 
     573            mbkv  (ji,jj) = MAX( MIN( mbathy(ji  ,jj+1), mbathy(ji,jj) ) - 1, 1 ) 
     574            mbku_d(ji,jj) = MAX( MAX( mbathy(ji+1,jj  ), mbathy(ji,jj) ) - 1, 1 )   ! "deep" 
     575            mbkv_d(ji,jj) = MAX( MAX( mbathy(ji  ,jj+1), mbathy(ji,jj) ) - 1, 1 ) 
    430576         END DO 
    431577      END DO 
    432  
    433       zmbk(:,:) = FLOAT( mbku (:,:) )    
    434       CALL lbc_lnk(zmbk,'U',1.) 
    435       mbku(:,:) = MAX( INT( zmbk(:,:) ), 1 )  
    436  
    437       zmbk(:,:) = FLOAT( mbkv (:,:) )    
    438       CALL lbc_lnk(zmbk,'V',1.) 
    439       mbkv(:,:) = MAX( INT( zmbk(:,:) ), 1 )  
    440  
    441 # if defined key_trabbl_adv 
    442       w_bbl(:,:,:) = 0.e0          ! initialisation of w_bbl to zero 
    443 # endif 
     578      zmbk(:,:) = FLOAT( mbku  (:,:) )   ;   CALL lbc_lnk(zmbk,'U',1.)   ;   mbku  (:,:) = MAX( INT( zmbk(:,:) ), 1 ) 
     579      zmbk(:,:) = FLOAT( mbkv  (:,:) )   ;   CALL lbc_lnk(zmbk,'V',1.)   ;   mbkv  (:,:) = MAX( INT( zmbk(:,:) ), 1 ) 
     580      zmbk(:,:) = FLOAT( mbku_d(:,:) )   ;   CALL lbc_lnk(zmbk,'U',1.)   ;   mbku_d(:,:) = MAX( INT( zmbk(:,:) ), 1 ) 
     581      zmbk(:,:) = FLOAT( mbkv_d(:,:) )   ;   CALL lbc_lnk(zmbk,'V',1.)   ;   mbkv_d(:,:) = MAX( INT( zmbk(:,:) ), 1 ) 
     582 
     583      DO jj = 1, jpj                !* sign of grad(H) at u- and v-points 
     584         DO ji = 1, jpi 
     585            mgrhu(ji,jj) = INT(  SIGN( 1.e0, fsdept_0(ji+1,jj,mbkt(ji+1,jj)) - fsdept_0(ji,jj,mbkt(ji,jj)) )  ) 
     586            mgrhv(ji,jj) = INT(  SIGN( 1.e0, fsdept_0(ji,jj+1,mbkt(ji,jj+1)) - fsdept_0(ji,jj,mbkt(ji,jj)) )  ) 
     587         END DO 
     588      END DO 
     589 
     590      DO jj = 1, jpjm1              !* bbl thickness at u- (v-) point  
     591         DO ji = 1, jpim1                 ! minimum of top & bottom e3u_0 (e3v_0) 
     592            e3u_bbl_0(ji,jj) = MIN( fse3u_0(ji,jj,mbkt(ji+1,jj  )), fse3u_0(ji,jj,mbkt(ji,jj)) )   
     593            e3v_bbl_0(ji,jj) = MIN( fse3v_0(ji,jj,mbkt(ji  ,jj+1)), fse3v_0(ji,jj,mbkt(ji,jj)) )   
     594         END DO  
     595      END DO 
     596      CALL lbc_lnk( e3u_bbl_0, 'U', 1. )   ;   CALL lbc_lnk( e3v_bbl_0, 'V', 1. )      ! lateral boundary conditions 
     597 
     598      !                             !* masked diffusive flux coefficients  
     599      ahu_bbl_0(:,:) = rn_ahtbbl * e2u(:,:) * e3u_bbl_0(:,:) / e1u(:,:)  * umask(:,:,1) 
     600      ahv_bbl_0(:,:) = rn_ahtbbl * e1v(:,:) * e3v_bbl_0(:,:) / e2v(:,:)  * vmask(:,:,1) 
     601 
     602      IF( cp_cfg == "orca" ) THEN   !* ORCA configuration : regional enhancement of ah_bbl 
     603         ! 
     604         SELECT CASE ( jp_cfg ) 
     605         CASE ( 2 )                          ! ORCA_R2 
     606            ij0 = 102   ;   ij1 = 102              ! Gibraltar enhancement of BBL 
     607            ii0 = 139   ;   ii1 = 140   
     608            ahu_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) =  4.e0*ahu_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) 
     609            ahv_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) =  4.e0*ahv_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) 
     610            ! 
     611            ij0 =  88   ;   ij1 =  88              ! Red Sea enhancement of BBL 
     612            ii0 = 161   ;   ii1 = 162 
     613            ahu_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) = 10.e0*ahu_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) 
     614            ahv_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) = 10.e0*ahv_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) 
     615            ! 
     616         CASE ( 4 )                          ! ORCA_R4 
     617            ij0 =  52   ;   ij1 =  52              ! Gibraltar enhancement of BBL 
     618            ii0 =  70   ;   ii1 =  71   
     619            ahu_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) =  4.e0*ahu_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) 
     620            ahv_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) =  4.e0*ahv_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) 
     621         END SELECT 
     622         ! 
     623      ENDIF 
     624      ! 
     625      l_bbl = .TRUE.     !: flag to compute bbl coef and transport 
    444626      ! 
    445627   END SUBROUTINE tra_bbl_init 
    … …  
    449631   !!   Dummy module :                      No bottom boundary layer scheme 
    450632   !!---------------------------------------------------------------------- 
    451    LOGICAL, PUBLIC, PARAMETER ::   lk_trabbl_dif = .FALSE.   !: diff bbl flag 
    452    LOGICAL, PUBLIC, PARAMETER ::   lk_trabbl_adv = .FALSE.   !: adv  bbl flag 
     633   LOGICAL, PUBLIC, PARAMETER ::   lk_trabbl = .FALSE.   !: bbl flag 
    453634CONTAINS 
    454    SUBROUTINE tra_bbl_dif( kt )              ! Empty routine 
    455       WRITE(*,*) 'tra_bbl_dif: You should not have seen this print! error?', kt 
    456    END SUBROUTINE tra_bbl_dif 
    457    SUBROUTINE tra_bbl_adv( kt )              ! Empty routine 
    458       WRITE(*,*) 'tra_bbl_adv: You should not have seen this print! error?', kt 
    459    END SUBROUTINE tra_bbl_adv 
     635   SUBROUTINE tra_bbl( kt )              ! Empty routine 
     636      WRITE(*,*) 'tra_bbl: You should not have seen this print! error?', kt 
     637   END SUBROUTINE tra_bbl 
    460638#endif 
    461639 

  • branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/tradmp.F90

    r1601 r2024  
    1313   !!  NEMO      1.0  ! 2002-08  (G. Madec, E. Durand)  free form + modules 
    1414   !!            3.2  ! 2009-08  (G. Madec, C. Talandier)  DOCTOR norm for namelist parameter 
     15   !!            3.3  ! 2010-06  (C. Ethe, G. Madec) merge TRA-TRC  
    1516   !!---------------------------------------------------------------------- 
    1617#if   defined key_tradmp   ||   defined key_esopa 
    … …  
    2627   USE oce             ! ocean dynamics and tracers variables 
    2728   USE dom_oce         ! ocean space and time domain variables 
    28    USE trdmod          ! ocean active tracers trends  
    29    USE trdmod_oce      ! ocean variables trends 
     29   USE trdmod_oce         ! ocean space and time domain variables 
     30   USE trdtra         ! ocean space and time domain variables 
    3031   USE zdf_oce         ! ocean vertical physics 
    3132   USE phycst          ! Define parameters for the routines 
    … …  
    4041   PRIVATE 
    4142 
    42    PUBLIC   tra_dmp    ! routine called by step.F90 
     43   PUBLIC   tra_dmp      ! routine called by step.F90 
     44   PUBLIC   tra_dmp_init ! routine called by opa.F90 
     45   PUBLIC   dtacof       ! routine called by tradmp.F90 and trcdmp.F90 
     46   PUBLIC   dtacof_zoom  ! routine called by tradmp.F90 and trcdmp.F90 
    4347 
    4448#if ! defined key_agrif 
    … …  
    8690      !! ** Action  : - (ta,sa)   tracer trends updated with the damping trend 
    8791      !!---------------------------------------------------------------------- 
    88       USE oce, ONLY :   ztrdt => ua   ! use ua as 3D workspace    
    89       USE oce, ONLY :   ztrds => va   ! use va as 3D workspace    
    90       !! 
    9192      INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
    9293      !! 
    9394      INTEGER ::   ji, jj, jk   ! dummy loop indices 
    94       !!---------------------------------------------------------------------- 
    95  
    96       IF( kt == nit000 )   CALL tra_dmp_init      ! Initialization 
    97  
    98       IF( l_trdtra )   THEN                       ! Save ta and sa trends 
    99          ztrdt(:,:,:) = ta(:,:,:)  
    100          ztrds(:,:,:) = sa(:,:,:)  
     95      REAL(wp) ::  zta, zsa 
     96      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  ztrdt, ztrds 
     97      !!---------------------------------------------------------------------- 
     98 
     99      IF( l_trdtra )   THEN                    !* Save ta and sa trends 
     100         ALLOCATE( ztrdt(jpi,jpj,jpk) )   ;    ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 
     101         ALLOCATE( ztrds(jpi,jpj,jpk) )   ;    ztrds(:,:,:) = tsa(:,:,:,jp_sal) 
    101102      ENDIF 
    102103 
    … …  
    107108            DO jj = 2, jpjm1 
    108109               DO ji = fs_2, fs_jpim1   ! vector opt. 
    109                   ta(ji,jj,jk) = ta(ji,jj,jk) + resto(ji,jj,jk) * ( t_dta(ji,jj,jk) - tb(ji,jj,jk) ) 
    110                   sa(ji,jj,jk) = sa(ji,jj,jk) + resto(ji,jj,jk) * ( s_dta(ji,jj,jk) - sb(ji,jj,jk) ) 
     110                  zta = resto(ji,jj,jk) * ( t_dta(ji,jj,jk) - tsb(ji,jj,jk,jp_tem) ) 
     111                  zsa = resto(ji,jj,jk) * ( s_dta(ji,jj,jk) - tsb(ji,jj,jk,jp_sal) ) 
     112                  tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) + zta 
     113                  tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal) + zsa 
    111114               END DO 
    112115            END DO 
    … …  
    118121               DO ji = fs_2, fs_jpim1   ! vector opt. 
    119122                  IF( avt(ji,jj,jk) <= 5.e-4 ) THEN 
    120                      ta(ji,jj,jk) = ta(ji,jj,jk) + resto(ji,jj,jk) * ( t_dta(ji,jj,jk) - tb(ji,jj,jk) ) 
    121                      sa(ji,jj,jk) = sa(ji,jj,jk) + resto(ji,jj,jk) * ( s_dta(ji,jj,jk) - sb(ji,jj,jk) ) 
     123                     zta = resto(ji,jj,jk) * ( t_dta(ji,jj,jk) - tsb(ji,jj,jk,jp_tem) ) 
     124                     zsa = resto(ji,jj,jk) * ( s_dta(ji,jj,jk) - tsb(ji,jj,jk,jp_sal) ) 
     125                     tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) + zta 
     126                     tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal) + zsa 
    122127                  ENDIF 
    123128               END DO 
    … …  
    130135               DO ji = fs_2, fs_jpim1   ! vector opt. 
    131136                  IF( fsdept(ji,jj,jk) >= hmlp (ji,jj) ) THEN 
    132                      ta(ji,jj,jk) = ta(ji,jj,jk) + resto(ji,jj,jk) * ( t_dta(ji,jj,jk) - tb(ji,jj,jk) ) 
    133                      sa(ji,jj,jk) = sa(ji,jj,jk) + resto(ji,jj,jk) * ( s_dta(ji,jj,jk) - sb(ji,jj,jk) ) 
     137                     zta = resto(ji,jj,jk) * ( t_dta(ji,jj,jk) - tsb(ji,jj,jk,jp_tem) ) 
     138                     zsa = resto(ji,jj,jk) * ( s_dta(ji,jj,jk) - tsb(ji,jj,jk,jp_sal) ) 
     139                     tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) + zta 
     140                     tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal) + zsa 
    134141                  ENDIF 
    135142               END DO 
    … …  
    140147 
    141148      IF( l_trdtra )   THEN       ! trend diagnostic 
    142          ztrdt(:,:,:) = ta(:,:,:) - ztrdt(:,:,:) 
    143          ztrds(:,:,:) = sa(:,:,:) - ztrds(:,:,:) 
    144          CALL trd_mod( ztrdt, ztrds, jptra_trd_dmp, 'TRA', kt ) 
     149         ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 
     150         ztrds(:,:,:) = tsa(:,:,:,jp_sal) - ztrds(:,:,:) 
     151         CALL trd_tra( kt, 'TRA', jp_tem, jptra_trd_dmp, ztrdt ) 
     152         CALL trd_tra( kt, 'TRA', jp_sal, jptra_trd_dmp, ztrds ) 
     153         DEALLOCATE( ztrdt )      ;     DEALLOCATE( ztrds ) 
    145154      ENDIF 
    146155      !                           ! Control print 
    147       IF(ln_ctl)   CALL prt_ctl( tab3d_1=ta, clinfo1=' dmp  - Ta: ', mask1=tmask,   & 
    148          &                       tab3d_2=sa, clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
     156      IF(ln_ctl)   CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' dmp  - Ta: ', mask1=tmask,   & 
     157         &                       tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    149158      ! 
    150159   END SUBROUTINE tra_dmp 
    … …  
    200209 
    201210      !                          ! Damping coefficients initialization 
    202       IF( lzoom ) THEN   ;   CALL dtacof_zoom 
    203       ELSE               ;   CALL dtacof 
     211      IF( lzoom ) THEN   ;   CALL dtacof_zoom( resto ) 
     212      ELSE               ;   CALL dtacof( nn_hdmp, rn_surf, rn_bot, rn_dep,  & 
     213                             &            nn_file, 'TRA'  , resto            ) 
    204214      ENDIF 
    205215      ! 
    … …  
    207217 
    208218 
    209    SUBROUTINE dtacof_zoom 
     219   SUBROUTINE dtacof_zoom( presto ) 
    210220      !!---------------------------------------------------------------------- 
    211221      !!                  ***  ROUTINE dtacof_zoom  *** 
    … …  
    220230      !! ** Action  : - resto, the damping coeff. for T and S 
    221231      !!---------------------------------------------------------------------- 
     232      !! * Arguments 
     233      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout)  ::  presto     !: restoring coeff. (s-1) 
     234      ! 
    222235      INTEGER  ::   ji, jj, jk, jn              ! dummy loop indices 
    223236      REAL(wp) ::   zlat, zlat0, zlat1, zlat2   ! temporary scalar 
    … …  
    233246      zfact(:) = zfact(:) / ( 5. * rday )    ! 5 days max restoring time scale 
    234247 
    235       resto(:,:,:) = 0.e0 
     248      presto(:,:,:) = 0.e0 
    236249 
    237250      ! damping along the forced closed boundary over 6 grid-points 
    238251      DO jn = 1, 6 
    239          IF( lzoom_w )   resto( mi0(jn+jpizoom):mi1(jn+jpizoom), : , : )                    = zfact(jn)   ! west  closed 
    240          IF( lzoom_s )   resto( : , mj0(jn+jpjzoom):mj1(jn+jpjzoom), : )                    = zfact(jn)   ! south closed  
    241          IF( lzoom_e )   resto( mi0(jpiglo+jpizoom-1-jn):mi1(jpiglo+jpizoom-1-jn) , : , : ) = zfact(jn)   ! east  closed  
    242          IF( lzoom_n )   resto( : , mj0(jpjglo+jpjzoom-1-jn):mj1(jpjglo+jpjzoom-1-jn) , : ) = zfact(jn)   ! north closed 
     252         IF( lzoom_w )   presto( mi0(jn+jpizoom):mi1(jn+jpizoom), : , : )                    = zfact(jn)   ! west  closed 
     253         IF( lzoom_s )   presto( : , mj0(jn+jpjzoom):mj1(jn+jpjzoom), : )                    = zfact(jn)   ! south closed  
     254         IF( lzoom_e )   presto( mi0(jpiglo+jpizoom-1-jn):mi1(jpiglo+jpizoom-1-jn) , : , : ) = zfact(jn)   ! east  closed  
     255         IF( lzoom_n )   presto( : , mj0(jpjglo+jpjzoom-1-jn):mj1(jpjglo+jpjzoom-1-jn) , : ) = zfact(jn)   ! north closed 
    243256      END DO 
    244257 
    … …  
    252265         ! 
    253266         !                          ! Initialization :  
    254          resto(:,:,:) = 0.e0 
     267         presto(:,:,:) = 0.e0 
    255268         zlat0 = 10.                     ! zlat0 : latitude strip where resto decreases 
    256269         zlat1 = 30.                     ! zlat1 : resto = 1 before zlat1 
    … …  
    262275                  zlat = ABS( gphit(ji,jj) ) 
    263276                  IF( zlat1 <= zlat .AND. zlat <= zlat2 ) THEN 
    264                      resto(ji,jj,jk) = 0.5 * ( 1./(5.*rday) ) * ( 1. - cos(rpi*(zlat2-zlat)/zlat0) )  
     277                     presto(ji,jj,jk) = 0.5 * ( 1./(5.*rday) ) * ( 1. - cos(rpi*(zlat2-zlat)/zlat0) )  
    265278                  ELSEIF( zlat < zlat1 ) THEN 
    266                      resto(ji,jj,jk) = 1./(5.*rday) 
     279                     presto(ji,jj,jk) = 1./(5.*rday) 
    267280                  ENDIF 
    268281               END DO 
    … …  
    272285      ENDIF 
    273286      !                             ! Mask resto array 
    274       resto(:,:,:) = resto(:,:,:) * tmask(:,:,:) 
     287      presto(:,:,:) = presto(:,:,:) * tmask(:,:,:) 
    275288      ! 
    276289   END SUBROUTINE dtacof_zoom 
    277290 
    278291 
    279    SUBROUTINE dtacof 
     292   SUBROUTINE dtacof( kn_hdmp, pn_surf, pn_bot, pn_dep,  & 
     293      &               kn_file, cdtype , presto           ) 
    280294      !!---------------------------------------------------------------------- 
    281295      !!                  ***  ROUTINE dtacof  *** 
    … …  
    291305      USE iom 
    292306      USE ioipsl 
    293       !! 
     307      !! * Arguments 
     308      INTEGER                         , INTENT(in   )  ::  kn_hdmp    !: damping option 
     309      REAL(wp)                        , INTENT(in   )  ::  pn_surf    !: surface time scale (days) 
     310      REAL(wp)                        , INTENT(in   )  ::  pn_bot     !: bottom time scale (days) 
     311      REAL(wp)                        , INTENT(in   )  ::  pn_dep     !: depth of transition (meters) 
     312      INTEGER                         , INTENT(in   )  ::  kn_file    !: save the damping coef on a file or not 
     313      CHARACTER(len=3)                , INTENT(in   )  ::  cdtype     ! =TRA or TRC (tracer indicator) 
     314      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout)  ::  presto     !: restoring coeff. (s-1) 
     315      ! 
    294316      INTEGER ::   ji, jj, jk                   ! dummy loop indices 
    295317      INTEGER ::   ii0, ii1, ij0, ij1           !    -          - 
    … …  
    302324      REAL(wp), DIMENSION(jpi,jpj)     ::   zmrs 
    303325      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zdct 
     326      CHARACTER(len=20)                ::   cfile 
    304327      !!---------------------------------------------------------------------- 
    305328 
    … …  
    313336 
    314337      ! ... Initialization :  
    315       resto(:,:,:) = 0.e0 
    316  
    317       !                           !-----------------------------------------! 
    318       IF( nn_hdmp > 0 ) THEN      !  Damping poleward of 'nn_hdmp' degrees  ! 
     338      presto(:,:,:) = 0.e0 
     339      ! 
     340      IF( kn_hdmp > 0 ) THEN      !  Damping poleward of 'nn_hdmp' degrees  ! 
    319341         !                        !-----------------------------------------! 
    320342         IF(lwp) WRITE(numout,*) 
    321          IF(lwp) WRITE(numout,*) '              Damping poleward of ', nn_hdmp,' deg.' 
     343         IF(lwp) WRITE(numout,*) '              Damping poleward of ', kn_hdmp,' deg.' 
    322344         ! 
    323345         CALL iom_open ( 'dist.coast.nc', icot, ldstop = .FALSE. ) 
    … …  
    333355         zinfl = 1000.e3                   ! distance of influence for damping term 
    334356         zlat0 = 10.                       ! latitude strip where resto decreases 
    335          zlat1 = REAL( nn_hdmp )           ! resto = 0 between -zlat1 and zlat1 
     357         zlat1 = REAL( kn_hdmp )           ! resto = 0 between -zlat1 and zlat1 
    336358         zlat2 = zlat1 + zlat0             ! resto increases from 0 to 1 between |zlat1| and |zlat2| 
    337359 
    … …  
    340362               zlat = ABS( gphit(ji,jj) ) 
    341363               IF ( zlat1 <= zlat .AND. zlat <= zlat2 ) THEN 
    342                   resto(ji,jj,1) = 0.5 * ( 1. - cos(rpi*(zlat-zlat1)/zlat0 ) ) 
     364                  presto(ji,jj,1) = 0.5 * ( 1. - cos(rpi*(zlat-zlat1)/zlat0 ) ) 
    343365               ELSEIF ( zlat > zlat2 ) THEN 
    344                   resto(ji,jj,1) = 1. 
     366                  presto(ji,jj,1) = 1. 
    345367               ENDIF 
    346368            END DO 
    347369         END DO 
    348370 
    349          IF ( nn_hdmp == 20 ) THEN       ! North Indian ocean (20N/30N x 45E/100E) : resto=0 
     371         IF ( kn_hdmp == 20 ) THEN       ! North Indian ocean (20N/30N x 45E/100E) : resto=0 
    350372            DO jj = 1, jpj 
    351373               DO ji = 1, jpi 
    … …  
    353375                  zlon = MOD( glamt(ji,jj), 360. ) 
    354376                  IF ( zlat1 < zlat .AND. zlat < zlat2 .AND. 45. < zlon .AND. zlon < 100. ) THEN 
    355                      resto(ji,jj,1) = 0.e0 
     377                     presto(ji,jj,1) = 0.e0 
    356378                  ENDIF 
    357379               END DO 
    … …  
    359381         ENDIF 
    360382 
    361          zsdmp = 1./(rn_surf * rday) 
    362          zbdmp = 1./(rn_bot  * rday) 
     383         zsdmp = 1./(pn_surf * rday) 
     384         zbdmp = 1./(pn_bot  * rday) 
    363385         DO jk = 2, jpkm1 
    364386            DO jj = 1, jpj 
    … …  
    366388                  zdct(ji,jj,jk) = MIN( zinfl, zdct(ji,jj,jk) ) 
    367389                  !   ... Decrease the value in the vicinity of the coast 
    368                   resto(ji,jj,jk) = resto(ji,jj,1) * 0.5 * ( 1. - COS( rpi*zdct(ji,jj,jk)/zinfl) ) 
     390                  presto(ji,jj,jk) = presto(ji,jj,1) * 0.5 * ( 1. - COS( rpi*zdct(ji,jj,jk)/zinfl) ) 
    369391                  !   ... Vertical variation from zsdmp (sea surface) to zbdmp (bottom) 
    370                   resto(ji,jj,jk) = resto(ji,jj,jk)      * ( zbdmp + (zsdmp-zbdmp)*EXP(-fsdept(ji,jj,jk)/rn_dep) ) 
     392                  presto(ji,jj,jk) = presto(ji,jj,jk)      * ( zbdmp + (zsdmp-zbdmp)*EXP(-fsdept(ji,jj,jk)/pn_dep) ) 
    371393               END DO 
    372394            END DO 
    … …  
    376398 
    377399 
    378       IF( cp_cfg == "orca" .AND. ( nn_hdmp > 0 .OR. nn_hdmp == -1 ) ) THEN 
     400      IF( cp_cfg == "orca" .AND. ( kn_hdmp > 0 .OR. kn_hdmp == -1 ) ) THEN 
    379401 
    380402         !                                         ! ========================= 
    … …  
    465487               zmrs( ji , mj0(ij0):mj1(ij1) ) = 0.1 * ABS( FLOAT(ji - mi1(ii1)) ) 
    466488            END DO  
    467             zsdmp = 1./(rn_surf * rday) 
    468             zbdmp = 1./(rn_bot * rday) 
     489            zsdmp = 1./(pn_surf * rday) 
     490            zbdmp = 1./(pn_bot * rday) 
    469491            DO jk = 1, jpk 
    470                zhfac (jk) = ( zbdmp + (zsdmp-zbdmp) * EXP(-fsdept(1,1,jk)/rn_dep) ) 
     492               zhfac (jk) = ( zbdmp + (zsdmp-zbdmp) * EXP(-fsdept(1,1,jk)/pn_dep) ) 
    471493            END DO 
    472494            !                                       ! ======================== 
    … …  
    478500 
    479501         DO jk = 1, jpkm1 
    480             resto(:,:,jk) = zmrs(:,:) * zhfac(jk) + ( 1. - zmrs(:,:) ) * resto(:,:,jk) 
     502            presto(:,:,jk) = zmrs(:,:) * zhfac(jk) + ( 1. - zmrs(:,:) ) * presto(:,:,jk) 
    481503         END DO 
    482504 
    483505         ! Mask resto array and set to 0 first and last levels 
    484          resto(:,:, : ) = resto(:,:,:) * tmask(:,:,:) 
    485          resto(:,:, 1 ) = 0.e0 
    486          resto(:,:,jpk) = 0.e0 
     506         presto(:,:, : ) = presto(:,:,:) * tmask(:,:,:) 
     507         presto(:,:, 1 ) = 0.e0 
     508         presto(:,:,jpk) = 0.e0 
    487509         !                         !--------------------! 
    488510      ELSE                         !     No damping     ! 
    … …  
    492514 
    493515      !                            !--------------------------------! 
    494       IF( nn_file == 1 ) THEN      !  save damping coef. in a file  ! 
     516      IF( kn_file == 1 ) THEN      !  save damping coef. in a file  ! 
    495517         !                         !--------------------------------! 
    496518         IF(lwp) WRITE(numout,*) '              create damping.coeff.nc file' 
    497          CALL iom_open  ( 'damping.coeff', inum0, ldwrt = .TRUE., kiolib = jprstlib ) 
    498          CALL iom_rstput( 0, 0, inum0, 'Resto', resto ) 
     519         IF( cdtype == 'TRA' ) cfile = 'damping.coeff' 
     520         IF( cdtype == 'TRC' ) cfile = 'damping.coeff.trc' 
     521         cfile = TRIM( cfile ) 
     522         CALL iom_open  ( cfile, inum0, ldwrt = .TRUE., kiolib = jprstlib ) 
     523         CALL iom_rstput( 0, 0, inum0, 'Resto', presto ) 
    499524         CALL iom_close ( inum0 ) 
    500525      ENDIF 

  • branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/traldf.F90

    r1601 r2024  
    44   !! Ocean Active tracers : lateral diffusive trends  
    55   !!===================================================================== 
    6    !! History :  9.0  ! 05-11 (G. Madec)  Original code 
     6   !! History :  9.0  ! 2005-11 (G. Madec)  Original code 
     7   !!       NEMO 3.0  ! 2008-01  (C. Ethe, G. Madec)  merge TRC-TRA  
    78   !!---------------------------------------------------------------------- 
    89 
    … …  
    2122   USE traldf_iso      ! lateral mixing               (tra_ldf_iso routine) 
    2223   USE traldf_lap      ! lateral mixing               (tra_ldf_lap routine) 
    23    USE trdmod          ! ocean active tracers trends 
    24    USE trdmod_oce      ! ocean variables trends 
     24   USE trdmod_oce      ! ocean space and time domain 
     25   USE trdtra          ! ocean active tracers trends 
    2526   USE prtctl          ! Print control 
    2627   USE in_out_manager  ! I/O manager 
    … …  
    3132   PRIVATE 
    3233 
    33    PUBLIC   tra_ldf    ! called by step.F90  
    34  
    35    INTEGER, PUBLIC ::   nldf = 0   ! type of lateral diffusion used defined from ln_traldf_... namlist logicals) 
    36                                    ! (need to be public to be used in vertical diffusion routine) 
     34   PUBLIC   tra_ldf         ! called by step.F90  
     35   PUBLIC   tra_ldf_init    ! called by opa.F90  
     36   ! 
     37   INTEGER ::   nldf = 0   ! type of lateral diffusion used defined from ln_traldf_... namlist logicals) 
    3738#if defined key_traldf_ano 
    3839   REAL, DIMENSION(jpi,jpj,jpk) ::   t0_ldf, s0_ldf   ! lateral diffusion trends of T & S 
    … …  
    6061      INTEGER, INTENT( in ) ::   kt   ! ocean time-step index 
    6162      !! 
    62       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   ztrdt, ztrds   ! 3D temporary workspace 
    63       !!---------------------------------------------------------------------- 
    64  
    65       IF( kt == nit000 )   CALL ldf_ctl          ! initialisation & control of options 
    66  
    67       IF( l_trdtra )   THEN                      ! temporary save of ta and sa trends 
    68          ztrdt(:,:,:) = ta(:,:,:)  
    69          ztrds(:,:,:) = sa(:,:,:)  
    70       ENDIF 
     63      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  ztrdt, ztrds 
     64      REAL(wp), DIMENSION(jpi,jpj,jpts) :: zgtsu, zgtsv 
     65      !!---------------------------------------------------------------------- 
     66 
     67      IF( l_trdtra )   THEN                    !* Save ta and sa trends 
     68         ALLOCATE( ztrdt(jpi,jpj,jpk) )   ;    ztrdt(:,:,:) = tsa(:,:,:,jp_tem)  
     69         ALLOCATE( ztrds(jpi,jpj,jpk) )   ;    ztrds(:,:,:) = tsa(:,:,:,jp_sal) 
     70      ENDIF 
     71 
     72      zgtsu(:,:,jp_tem) = gtu(:,:)        ;        zgtsu(:,:,jp_sal) = gsu(:,:) 
     73      zgtsv(:,:,jp_tem) = gtv(:,:)        ;        zgtsv(:,:,jp_sal) = gsv(:,:) 
    7174 
    7275      SELECT CASE ( nldf )                       ! compute lateral mixing trend and add it to the general trend 
    73       CASE ( 0 )   ;   CALL tra_ldf_lap   ( kt )      ! iso-level laplacian 
    74       CASE ( 1 )   ;   CALL tra_ldf_iso   ( kt )      ! rotated laplacian (except dk[ dk[.] ] part) 
    75       CASE ( 2 )   ;   CALL tra_ldf_bilap ( kt )      ! iso-level bilaplacian 
    76       CASE ( 3 )   ;   CALL tra_ldf_bilapg( kt )      ! s-coord. horizontal bilaplacian 
     76      CASE ( 0 )   ;   CALL tra_ldf_lap   ( kt , 'TRA', zgtsu, zgtsv,  & 
     77                       &                    tsb, tsa  , jpts           )   ! iso-level laplacian 
     78      CASE ( 1 )   ;   CALL tra_ldf_iso   ( kt , 'TRA', zgtsu, zgtsv,  & 
     79                       &                    tsb, tsa  , jpts , ahtb0   )   ! rotated laplacian  
     80      CASE ( 2 )   ;   CALL tra_ldf_bilap ( kt , 'TRA', zgtsu, zgtsv,  & 
     81                       &                    tsb, tsa  , jpts           )   ! iso-level bilaplacian 
     82      CASE ( 3 )   ;   CALL tra_ldf_bilapg( kt , 'TRA', tsb, tsa, jpts )      ! s-coord. horizontal bilaplacian 
    7783         ! 
    7884      CASE ( -1 )                                     ! esopa: test all possibility with control print 
    79          CALL tra_ldf_lap    ( kt ) 
    80          CALL prt_ctl( tab3d_1=ta, clinfo1=' ldf0 - Ta: ', mask1=tmask,               & 
    81             &          tab3d_2=sa, clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    82          CALL tra_ldf_iso    ( kt ) 
    83          CALL prt_ctl( tab3d_1=ta, clinfo1=' ldf1 - Ta: ', mask1=tmask,               & 
    84             &          tab3d_2=sa, clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    85          CALL tra_ldf_bilap  ( kt ) 
    86          CALL prt_ctl( tab3d_1=ta, clinfo1=' ldf2 - Ta: ', mask1=tmask,               & 
    87             &          tab3d_2=sa, clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    88          CALL tra_ldf_bilapg ( kt ) 
    89          CALL prt_ctl( tab3d_1=ta, clinfo1=' ldf3 - Ta: ', mask1=tmask,               & 
    90             &          tab3d_2=sa, clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
     85                       CALL tra_ldf_lap   ( kt , 'TRA', zgtsu, zgtsv,  & 
     86                       &                    tsb, tsa  , jpts           )  
     87                       CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' ldf0 - Ta: ', mask1=tmask,               & 
     88                       &             tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
     89                       CALL tra_ldf_iso   ( kt , 'TRA', zgtsu, zgtsv,  & 
     90                       &                    tsb, tsa  , jpts , ahtb0   )  
     91                       CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' ldf1 - Ta: ', mask1=tmask,               & 
     92                       &             tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
     93                       CALL tra_ldf_bilap ( kt , 'TRA', zgtsu, zgtsv,  & 
     94                       &                    tsb, tsa  , jpts           )  
     95                       CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' ldf2 - Ta: ', mask1=tmask,               & 
     96                       &             tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
     97                       CALL tra_ldf_bilapg( kt , 'TRA', tsb, tsa, jpts )  
     98                       CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' ldf3 - Ta: ', mask1=tmask,               & 
     99                       &             tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    91100      END SELECT 
    92101 
    93102#if defined key_traldf_ano 
    94       ta(:,:,:) = ta(:,:,:) - t0_ldf(:,:,:)      ! anomaly: substract the reference diffusivity 
    95       sa(:,:,:) = sa(:,:,:) - s0_ldf(:,:,:) 
     103      tsa(:,:,:,jp_tem) = tsa(:,:,:,jp_tem) - t0_ldf(:,:,:)      ! anomaly: substract the reference diffusivity 
     104      tsa(:,:,:,jp_sal) = tsa(:,:,:,jp_sal) - s0_ldf(:,:,:) 
    96105#endif 
     106 
    97107      IF( l_trdtra )   THEN                      ! save the horizontal diffusive trends for further diagnostics 
    98          ztrdt(:,:,:) = ta(:,:,:) - ztrdt(:,:,:) 
    99          ztrds(:,:,:) = sa(:,:,:) - ztrds(:,:,:) 
    100          CALL trd_mod( ztrdt, ztrds, jptra_trd_ldf, 'TRA', kt ) 
     108         ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 
     109         ztrds(:,:,:) = tsa(:,:,:,jp_sal) - ztrds(:,:,:) 
     110         CALL trd_tra( kt, 'TRA', jp_tem, jptra_trd_ldf, ztrdt ) 
     111         CALL trd_tra( kt, 'TRA', jp_sal, jptra_trd_ldf, ztrds ) 
     112         DEALLOCATE( ztrdt )      ;     DEALLOCATE( ztrds )  
    101113      ENDIF 
    102114      !                                          ! print mean trends (used for debugging) 
    103       IF(ln_ctl)   CALL prt_ctl( tab3d_1=ta, clinfo1=' ldf  - Ta: ', mask1=tmask,               & 
    104          &                       tab3d_2=sa, clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
     115      IF(ln_ctl)   CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' ldf  - Ta: ', mask1=tmask,               & 
     116         &                       tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    105117      ! 
    106118   END SUBROUTINE tra_ldf 
    107119 
    108120 
    109    SUBROUTINE ldf_ctl 
    110       !!---------------------------------------------------------------------- 
    111       !!                  ***  ROUTINE ldf_ctl  *** 
     121   SUBROUTINE tra_ldf_init 
     122      !!---------------------------------------------------------------------- 
     123      !!                  ***  ROUTINE tra_ldf_init  *** 
    112124      !!  
    113125      !! ** Purpose :   Choice of the operator for the lateral tracer diffusion 
    … …  
    135147      IF(lwp) THEN                    ! Namelist print 
    136148         WRITE(numout,*) 
    137          WRITE(numout,*) 'tra:ldf_ctl : lateral tracer diffusive operator' 
     149         WRITE(numout,*) 'tra_ldf_init : lateral tracer diffusive operator' 
    138150         WRITE(numout,*) '~~~~~~~~~~~' 
    139151         WRITE(numout,*) '   Namelist namtra_ldf : set lateral mixing parameters (type, direction, coefficients)' 
    … …  
    225237      CALL ldf_ano 
    226238      ! 
    227    END SUBROUTINE ldf_ctl 
     239   END SUBROUTINE tra_ldf_init 
    228240 
    229241#if defined key_traldf_ano 
    … …  
    271283      t0_ldf(:,:,:) = 0.e0 
    272284      s0_ldf(:,:,:) = 0.e0 
    273       ztb   (:,:,:) = tb (:,:,:) 
    274       zsb   (:,:,:) = sb (:,:,:) 
    275       ua    (:,:,:) = ta (:,:,:) 
    276       va    (:,:,:) = sa (:,:,:) 
     285      ztb   (:,:,:) = tsb (:,:,:,jp_tem) 
     286      zsb   (:,:,:) = tsb (:,:,:,jp_sal) 
     287      ua    (:,:,:) = tsa (:,:,:,jp_tem) 
     288      va    (:,:,:) = tsa (:,:,:,jp_sal) 
    277289      zavt  (:,:,:) = avt(:,:,:) 
    278290      IF( lk_zdfddm ) THEN CALL ctl_stop( ' key_traldf_ano with key_zdfddm not implemented' ) 
    279291      ! set tb, sb to reference values and avr to zero 
    280       tb (:,:,:) = zt_ref(:,:,:) 
    281       sb (:,:,:) = zs_ref(:,:,:) 
    282       ta (:,:,:) = 0.e0 
    283       sa (:,:,:) = 0.e0 
    284       avt(:,:,:) = 0.e0 
     292      tsb (:,:,:,jp_tem) = zt_ref(:,:,:) 
     293      tsb (:,:,:,jp_sal) = zs_ref(:,:,:) 
     294      tsa (:,:,:,jp_tem) = 0.e0 
     295      tsa (:,:,:,jp_sal) = 0.e0 
     296      avt(:,:,:)         = 0.e0 
    285297 
    286298      ! Compute the ldf trends 
    … …  
    295307      IF( neuler == 1)   z12 = 1.e0 
    296308      IF( ln_zdfexp ) THEN      ! ta,sa are the trends 
    297          t0_ldf(:,:,:) = ta(:,:,:) 
    298          s0_ldf(:,:,:) = sa(:,:,:) 
     309         t0_ldf(:,:,:) = tsa(:,:,:,jp_tem) 
     310         s0_ldf(:,:,:) = tsa(:,:,:,jp_sal) 
    299311      ELSE 
    300312         DO jk = 1, jpkm1 
    301             t0_ldf(:,:,jk) = ( ta(:,:,jk) - tb(:,:,jk) ) / ( z12 *rdttra(jk) ) 
    302             s0_ldf(:,:,jk) = ( sa(:,:,jk) - tb(:,:,jk) ) / ( z12 *rdttra(jk) ) 
     313            t0_ldf(:,:,jk) = ( tsa(:,:,jk,jp_tem) - tsb(:,:,jk,jp_tem) ) / ( z12 *rdttra(jk) ) 
     314            s0_ldf(:,:,jk) = ( tsa(:,:,jk,jp_sal) - tsb(:,:,jk,jp_sal) ) / ( z12 *rdttra(jk) ) 
    303315         END DO 
    304316      ENDIF 
    305       tb    (:,:,:) = ztb (:,:,:) 
    306       sb    (:,:,:) = zsb (:,:,:) 
    307       ta    (:,:,:) = ua  (:,:,:) 
    308       sa    (:,:,:) = va  (:,:,:) 
    309       avt   (:,:,:) = zavt(:,:,:) 
     317      tsb(:,:,:,jp_tem) = ztb (:,:,:) 
     318      tsb(:,:,:,jp_sal) = zsb (:,:,:) 
     319      tsa(:,:,:,jp_tem) = ua  (:,:,:) 
     320      tsa(:,:,:,jp_sal) = va  (:,:,:) 
     321      avt(:,:,:)        = zavt(:,:,:) 
    310322      ! 
    311323   END SUBROUTINE ldf_ano 

  • branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/traldf_bilap.F90

    r1152 r2024  
    22   !!============================================================================== 
    33   !!                   ***  MODULE  traldf_bilap  *** 
    4    !! Ocean active tracers:  horizontal component of the lateral tracer mixing trend 
     4   !! Ocean  tracers:  horizontal component of the lateral tracer mixing trend 
     5   !!============================================================================== 
     6   !! History :     !  91-11  (G. Madec)  Original code 
     7   !!               !  93-03  (M. Guyon)  symetrical conditions 
     8   !!               !  95-11  (G. Madec)  suppress volumetric scale factors 
     9   !!               !  96-01  (G. Madec)  statement function for e3 
     10   !!               !  96-01  (M. Imbard)  mpp exchange 
     11   !!               !  97-07  (G. Madec)  optimization, and ahtt 
     12   !!          8.5  !  02-08  (G. Madec)  F90: Free form and module 
     13   !!          9.0  !  04-08  (C. Talandier) New trends organization 
     14   !!               !  05-11  (G. Madec)  zps or sco as default option 
     15   !!          3.3  !  10-05  (C. Ethe, G. Madec)  merge TRC-TRA  
    516   !!============================================================================== 
    617 
    … …  
    1324   USE dom_oce         ! ocean space and time domain 
    1425   USE ldftra_oce      ! ocean tracer   lateral physics 
    15    USE trdmod          ! ocean active tracers trends  
    16    USE trdmod_oce      ! ocean variables trends 
    1726   USE in_out_manager  ! I/O manager 
    1827   USE ldfslp          ! iso-neutral slopes  
    1928   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    2029   USE diaptr          ! poleward transport diagnostics 
    21    USE prtctl          ! Print control 
    2230 
    2331   IMPLICIT NONE 
    … …  
    3947 
    4048CONTAINS 
    41     
    42    SUBROUTINE tra_ldf_bilap( kt ) 
     49  
     50   SUBROUTINE tra_ldf_bilap( kt   , cdtype, pgtu, pgtv,  & 
     51      &                      ptrab, ptraa , kjpt         )   
    4352      !!---------------------------------------------------------------------- 
    4453      !!                  ***  ROUTINE tra_ldf_bilap  *** 
    4554      !! 
    46       !! ** Purpose :   Compute the before horizontal tracer (t & s) diffusive  
     55      !! ** Purpose :   Compute the before horizontal tracer diffusive  
    4756      !!      trend and add it to the general trend of tracer equation. 
    4857      !! 
    4958      !! ** Method  :   4th order diffusive operator along model level surfaces  
    5059      !!      evaluated using before fields (forward time scheme). The hor. 
    51       !!      diffusive trends of temperature (idem for salinity) is given by: 
     60      !!      diffusive trends is given by: 
    5261      !!      Laplacian of tb: 
    5362      !!         zlt   = 1/(e1t*e2t*e3t) {  di-1[ e2u*e3u/e1u di(tb) ] 
    … …  
    5968      !!         difft = 1/(e1t*e2t*e3t) {  di-1[ e2u*e3u/e1u di(zlt) ] 
    6069      !!                                  + dj-1[ e1v*e3v/e2v dj(zlt) ]  } 
    61       !!      Note: if key_zco defined, e3t=e3u=e3v, they are simplified. 
    6270      !! 
    63       !!      Add this trend to the general trend (ta,sa): 
    64       !!         (ta,sa) = (ta,sa) + ( difft , diffs ) 
     71      !!      Add this trend to the general trend 
     72      !!         (ptraa) = (ptraa) + ( difft ) 
    6573      !! 
    66       !! ** Action : - Update (ta,sa) arrays with the before iso-level 
     74      !! ** Action : - Update ptraa arrays with the before iso-level 
    6775      !!               biharmonic mixing trend. 
    68       !! 
    69       !! History : 
    70       !!        !  91-11  (G. Madec)  Original code 
    71       !!        !  93-03  (M. Guyon)  symetrical conditions 
    72       !!        !  95-11  (G. Madec)  suppress volumetric scale factors 
    73       !!        !  96-01  (G. Madec)  statement function for e3 
    74       !!        !  96-01  (M. Imbard)  mpp exchange 
    75       !!        !  97-07  (G. Madec)  optimization, and ahtt 
    76       !!   8.5  !  02-08  (G. Madec)  F90: Free form and module 
    77       !!   9.0  !  04-08  (C. Talandier) New trends organization 
    78       !!        !  05-11  (G. Madec)  zps or sco as default option 
    7976      !!---------------------------------------------------------------------- 
    80       !! * Modules used 
    81       USE oce           , ztu => ua,  &  ! use ua as workspace 
    82          &                ztv => va      ! use va as workspace 
    83  
    84       !! * Arguments 
    85       INTEGER, INTENT( in ) ::   kt       ! ocean time-step index 
    86  
    87       !! * Local declarations 
    88       INTEGER ::   ji, jj, jk             ! dummy loop indices 
    89       INTEGER ::   iku, ikv               ! temporary integers 
    90       REAL(wp) ::   zta, zsa              ! temporary scalars 
     77      !!* Module used 
     78      USE oce         , ztu => ua   ! use ua as workspace 
     79      USE oce         , ztv => va   ! use va as workspace 
     80      !!* Arguments 
     81      INTEGER         , INTENT(in   )                                ::   kt             ! ocean time-step index 
     82      CHARACTER(len=3), INTENT(in   )                                ::   cdtype         ! =TRA or TRC (tracer indicator) 
     83      INTEGER         , INTENT(in   )                                ::   kjpt            ! number of tracers 
     84      REAL(wp)        , INTENT(in   ), DIMENSION(jpi,jpj,kjpt  )     ::   pgtu, pgtv     ! tracer gradient at pstep levels 
     85      REAL(wp)        , INTENT(in   ), DIMENSION(jpi,jpj,jpk,kjpt)   ::   ptrab          ! before and now tracer fields 
     86      REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)   ::   ptraa          ! tracer trend  
     87      !!* Local declarations 
     88      INTEGER  ::  ji, jj, jk, jn         ! dummy loop indices 
     89      INTEGER  ::  iku, ikv               ! temporary integers 
     90      REAL(wp) ::  zbtr, ztra             ! temporary scalars 
    9191      REAL(wp), DIMENSION(jpi,jpj) ::   &  
    92          zeeu, zeev, zbtr,              & ! 2D workspace 
    93          zlt, zls 
    94       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   &  
    95          zsu, zsv                         ! 3D workspace  
     92         zeeu, zeev, zlt               ! 2D workspace 
    9693      !!---------------------------------------------------------------------- 
    9794 
    … …  
    10198         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~' 
    10299      ENDIF 
    103  
    104  
    105       !                                                ! =============== 
    106       DO jk = 1, jpkm1                                 ! Horizontal slab 
    107          !                                             ! =============== 
    108  
    109          ! 0. Initialization of metric arrays (for z- or s-coordinates) 
    110          ! ---------------------------------- 
    111  
    112          IF( lk_zco ) THEN      ! z-coordinate (1D arrays): no vertical scale factors 
     100      !                                                          ! =========== 
     101      DO jn = 1, kjpt                                            ! tracer loop 
     102         !                                                       ! =========== 
     103         !                                                
     104         DO jk = 1, jpkm1                                  
     105            !                                              
     106             
     107            ! 0. Initialization of metric arrays (for z- or s-coordinates) 
     108            ! ---------------------------------- 
    113109            DO jj = 1, jpjm1 
    114110               DO ji = 1, fs_jpim1   ! vector opt. 
    115                   zbtr(ji,jj) = 1. / ( e1t(ji,jj)*e2t(ji,jj) ) 
    116                   zeeu(ji,jj) = e2u(ji,jj) / e1u(ji,jj) * umask(ji,jj,jk) 
    117                   zeev(ji,jj) = e1v(ji,jj) / e2v(ji,jj) * vmask(ji,jj,jk) 
    118                END DO 
    119             END DO 
    120          ELSE                   ! All coordinates (3D arrays): vertical scale factor are used 
    121             DO jj = 1, jpjm1 
    122                DO ji = 1, fs_jpim1   ! vector opt. 
    123                   zbtr(ji,jj) = 1. / ( e1t(ji,jj)*e2t(ji,jj)*fse3t(ji,jj,jk) ) 
    124111                  zeeu(ji,jj) = e2u(ji,jj) * fse3u(ji,jj,jk) / e1u(ji,jj) * umask(ji,jj,jk) 
    125112                  zeev(ji,jj) = e1v(ji,jj) * fse3v(ji,jj,jk) / e2v(ji,jj) * vmask(ji,jj,jk) 
    126113               END DO 
    127114            END DO 
    128          ENDIF 
    129115 
    130116 
    131          ! 1. Laplacian 
    132          ! ------------ 
    133  
    134          ! First derivative (gradient) 
    135          DO jj = 1, jpjm1 
    136             DO ji = 1, fs_jpim1   ! vector opt. 
    137                ztu(ji,jj,jk) = zeeu(ji,jj) * ( tb(ji+1,jj  ,jk) - tb(ji,jj,jk) ) 
    138                zsu(ji,jj,jk) = zeeu(ji,jj) * ( sb(ji+1,jj  ,jk) - sb(ji,jj,jk) ) 
    139                ztv(ji,jj,jk) = zeev(ji,jj) * ( tb(ji  ,jj+1,jk) - tb(ji,jj,jk) ) 
    140                zsv(ji,jj,jk) = zeev(ji,jj) * ( sb(ji  ,jj+1,jk) - sb(ji,jj,jk) ) 
    141             END DO 
    142          END DO 
    143          IF( ln_zps ) THEN      ! set gradient at partial step level 
     117            ! 1. Laplacian 
     118            ! ------------ 
     119             
     120            ! First derivative (gradient) 
    144121            DO jj = 1, jpjm1 
    145                DO ji = 1, jpim1 
    146                   ! last level 
    147                   iku = MIN ( mbathy(ji,jj), mbathy(ji+1,jj  ) ) - 1 
    148                   ikv = MIN ( mbathy(ji,jj), mbathy(ji  ,jj+1) ) - 1 
    149                   IF( iku == jk ) THEN 
    150                      ztu(ji,jj,jk) = zeeu(ji,jj) * gtu(ji,jj) 
    151                      zsu(ji,jj,jk) = zeeu(ji,jj) * gsu(ji,jj) 
    152                   ENDIF 
    153                   IF( ikv == jk ) THEN 
    154                      ztv(ji,jj,jk) = zeev(ji,jj) * gtv(ji,jj) 
    155                      zsv(ji,jj,jk) = zeev(ji,jj) * gsv(ji,jj) 
    156                   ENDIF 
     122               DO ji = 1, fs_jpim1   ! vector opt. 
     123                  ztu(ji,jj,jk) = zeeu(ji,jj) * ( ptrab(ji+1,jj  ,jk,jn) - ptrab(ji,jj,jk,jn) ) 
     124                  ztv(ji,jj,jk) = zeev(ji,jj) * ( ptrab(ji  ,jj+1,jk,jn) - ptrab(ji,jj,jk,jn) ) 
    157125               END DO 
    158126            END DO 
    159          ENDIF 
    160  
    161          ! Second derivative (divergence) 
    162          DO jj = 2, jpjm1 
    163             DO ji = fs_2, fs_jpim1   ! vector opt. 
    164                zlt(ji,jj) = zbtr(ji,jj) * (  ztu(ji,jj,jk) - ztu(ji-1,jj,jk) + ztv(ji,jj,jk) - ztv(ji,jj-1,jk)  ) 
    165                zls(ji,jj) = zbtr(ji,jj) * (  zsu(ji,jj,jk) - zsu(ji-1,jj,jk) + zsv(ji,jj,jk) - zsv(ji,jj-1,jk)  ) 
    166             END DO 
    167          END DO 
    168  
    169          ! Multiply by the eddy diffusivity coefficient 
    170          DO jj = 2, jpjm1 
    171             DO ji = fs_2, fs_jpim1   ! vector opt. 
    172                zlt(ji,jj) = fsahtt(ji,jj,jk) * zlt(ji,jj) 
    173                zls(ji,jj) = fsahtt(ji,jj,jk) * zls(ji,jj) 
    174             END DO 
    175          END DO 
    176  
    177          ! Lateral boundary conditions on the laplacian (zlt,zls)   (unchanged sgn) 
    178          CALL lbc_lnk( zlt, 'T', 1. )   ;    CALL lbc_lnk( zls, 'T', 1. ) 
    179  
    180          ! 2. Bilaplacian 
    181          ! -------------- 
    182  
    183          ! third derivative (gradient) 
    184          DO jj = 1, jpjm1 
    185             DO ji = 1, fs_jpim1   ! vector opt. 
    186                ztu(ji,jj,jk) = zeeu(ji,jj) * ( zlt(ji+1,jj  ) - zlt(ji,jj) ) 
    187                zsu(ji,jj,jk) = zeeu(ji,jj) * ( zls(ji+1,jj  ) - zls(ji,jj) ) 
    188                ztv(ji,jj,jk) = zeev(ji,jj) * ( zlt(ji  ,jj+1) - zlt(ji,jj) ) 
    189                zsv(ji,jj,jk) = zeev(ji,jj) * ( zls(ji  ,jj+1) - zls(ji,jj) ) 
    190             END DO 
    191          END DO 
    192  
    193          ! fourth derivative (divergence) and add to the general tracer trend 
    194          DO jj = 2, jpjm1 
    195             DO ji = fs_2, fs_jpim1   ! vector opt. 
    196                ! horizontal diffusive trends 
    197                zta = zbtr(ji,jj) * (  ztu(ji,jj,jk) - ztu(ji-1,jj,jk) + ztv(ji,jj,jk) - ztv(ji,jj-1,jk)  ) 
    198                zsa = zbtr(ji,jj) * (  zsu(ji,jj,jk) - zsu(ji-1,jj,jk) + zsv(ji,jj,jk) - zsv(ji,jj-1,jk)  ) 
    199                ! add it to the general tracer trends 
    200                ta(ji,jj,jk) = ta(ji,jj,jk) + zta 
    201                sa(ji,jj,jk) = sa(ji,jj,jk) + zsa 
    202             END DO 
    203          END DO 
    204          !                                             ! =============== 
    205       END DO                                           ! Horizontal slab 
    206       !                                                ! =============== 
    207  
    208       ! "zonal" mean lateral diffusive heat and salt transport 
    209       IF( ln_diaptr .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN 
    210          IF( lk_zco ) THEN      ! z-coordinate (1D arrays): multiply by the vertical scale factor 
    211             DO jk = 1, jpkm1 
    212                DO jj = 2, jpjm1 
    213                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    214                      ztv(ji,jj,jk) = ztv(ji,jj,jk) * fse3v(ji,jj,jk) 
    215                      zsv(ji,jj,jk) = zsv(ji,jj,jk) * fse3v(ji,jj,jk) 
     127            IF( ln_zps ) THEN      ! set gradient at partial step level 
     128               DO jj = 1, jpjm1 
     129                  DO ji = 1, jpim1 
     130                     ! last level 
     131                     iku = MIN ( mbathy(ji,jj), mbathy(ji+1,jj  ) ) - 1 
     132                     ikv = MIN ( mbathy(ji,jj), mbathy(ji  ,jj+1) ) - 1 
     133                     IF( iku == jk )  ztu(ji,jj,jk) = zeeu(ji,jj) * pgtu(ji,jj,jn) 
     134                     IF( ikv == jk )  ztv(ji,jj,jk) = zeev(ji,jj) * pgtv(ji,jj,jn) 
    216135                  END DO 
    217136               END DO 
     137            ENDIF 
     138 
     139            ! Second derivative (divergence) multiply by the eddy diffusivity coefficient 
     140            DO jj = 2, jpjm1 
     141               DO ji = fs_2, fs_jpim1   ! vector opt. 
     142                  zbtr = 1.0 / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
     143                  zlt(ji,jj) = fsahtt(ji,jj,jk) & 
     144                     &                * zbtr * (  ztu(ji,jj,jk) - ztu(ji-1,jj,jk) + ztv(ji,jj,jk) - ztv(ji,jj-1,jk)  ) 
     145               END DO 
    218146            END DO 
     147 
     148            ! Lateral boundary conditions on the laplacian (zlt)   (unchanged sgn) 
     149            CALL lbc_lnk( zlt, 'T', 1. ) 
     150 
     151            ! 2. Bilaplacian 
     152            ! -------------- 
     153             
     154            ! third derivative (gradient) 
     155            DO jj = 1, jpjm1 
     156               DO ji = 1, fs_jpim1   ! vector opt. 
     157                  ztu(ji,jj,jk) = zeeu(ji,jj) * ( zlt(ji+1,jj  ) - zlt(ji,jj) ) 
     158                  ztv(ji,jj,jk) = zeev(ji,jj) * ( zlt(ji  ,jj+1) - zlt(ji,jj) ) 
     159               END DO 
     160            END DO 
     161 
     162            ! fourth derivative (divergence) and add to the general tracer trend 
     163            DO jj = 2, jpjm1 
     164               DO ji = fs_2, fs_jpim1   ! vector opt. 
     165                  ! horizontal diffusive trends 
     166                  zbtr = 1.0 / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
     167                  ztra = zbtr * (  ztu(ji,jj,jk) - ztu(ji-1,jj,jk) + ztv(ji,jj,jk) - ztv(ji,jj-1,jk)  ) 
     168                  ! add it to the general tracer trends 
     169                  ptraa(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn) + ztra 
     170               END DO 
     171            END DO 
     172            !                                             ! =============== 
     173         END DO                                           ! Horizontal slab 
     174         !                                                ! =============== 
     175         ! "zonal" mean lateral diffusive heat and salt transport 
     176         IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN   
     177           IF( jn == jp_tem )  pht_ldf(:) = ptr_vj( ztv(:,:,:) ) 
     178           IF( jn == jp_sal )  pst_ldf(:) = ptr_vj( ztv(:,:,:) ) 
    219179         ENDIF 
    220          pht_ldf(:) = ptr_vj( ztv(:,:,:) ) 
    221          pst_ldf(:) = ptr_vj( zsv(:,:,:) ) 
    222       ENDIF 
     180         ! 
     181      END DO 
    223182 
    224183   END SUBROUTINE tra_ldf_bilap 

  • branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/traldf_bilapg.F90

    r1152 r2024  
    22   !!============================================================================== 
    33   !!                       ***  MODULE  traldf_bilapg  *** 
    4    !! Ocean active tracers:  horizontal component of the lateral tracer mixing trend 
     4   !! Ocean  tracers:  horizontal component of the lateral tracer mixing trend 
     5   !!============================================================================== 
     6   !! History : 8.0   !  1997-07  (G. Madec)  Original code 
     7   !!           NEMO  !  2002-08  (G. Madec)  F90: Free form and module 
     8   !!           3.3   !  2010-06  (C. Ethe, G. Madec) Merge TRA-TRC 
    59   !!============================================================================== 
    610#if defined key_ldfslp   ||   defined key_esopa 
    … …  
    1620   USE dom_oce         ! ocean space and time domain variables 
    1721   USE ldftra_oce      ! ocean active tracers: lateral physics 
    18    USE trdmod          ! ocean active tracers trends  
    19    USE trdmod_oce      ! ocean variables trends 
    2022   USE in_out_manager  ! I/O manager 
    2123   USE ldfslp          ! iso-neutral slopes available 
    2224   USE lbclnk          ! ocean lateral boundary condition (or mpp link) 
    2325   USE diaptr          ! poleward transport diagnostics  
    24    USE prtctl          ! Print control 
    2526 
    2627   IMPLICIT NONE 
    … …  
    4243CONTAINS 
    4344 
    44    SUBROUTINE tra_ldf_bilapg( kt ) 
     45   SUBROUTINE tra_ldf_bilapg( kt, cdtype, ptrab, ptraa, kjpt ) 
    4546      !!---------------------------------------------------------------------- 
    4647      !!                 ***  ROUTINE tra_ldf_bilapg  *** 
    4748      !!                     
    48       !! ** Purpose :   Compute the before horizontal tracer (t & s) diffusive  
     49      !! ** Purpose :   Compute the before horizontal tracer diffusive  
    4950      !!      trend and add it to the general trend of tracer equation. 
    5051      !! 
    … …  
    5455      !!      computed in routine inildf. 
    5556      !!         -1- compute the geopotential harmonic operator applied to 
    56       !!      (tb,sb) and multiply it by the eddy diffusivity coefficient 
    57       !!      (done by a call to ldfght routine, result in (wk1,wk2) arrays). 
     57      !!        ptrab and multiply it by the eddy diffusivity coefficient 
     58      !!       (done by a call to ldfght routine, result in wk1 arrays). 
    5859      !!      Applied the domain lateral boundary conditions by call to lbc_lnk 
    5960      !!         -2- compute the geopotential harmonic operator applied to 
    60       !!      (wk1,wk2) by a second call to ldfght routine (result in (wk3,wk4) 
     61      !!      wk1 by a second call to ldfght routine (result in wk2) 
    6162      !!      arrays). 
    62       !!         -3- Add this trend to the general trend (ta,sa): 
    63       !!            (ta,sa) = (ta,sa) + (wk3,wk4) 
    64       !! 
    65       !! ** Action : - Update (ta,sa) arrays with the before geopotential  
     63      !!         -3- Add this trend to the general trend  
     64      !!            ptraa = ptraa + wk2 
     65      !! 
     66      !! ** Action : - Update ptraa arrays with the before geopotential  
    6667      !!               biharmonic mixing trend. 
    67       !! 
    68       !! History : 
    69       !!   8.0  !  97-07  (G. Madec)  Original code 
    70       !!   8.5  !  02-08  (G. Madec)  F90: Free form and module 
    71       !!   9.0  !  04-08  (C. Talandier) New trends organization 
    72       !!---------------------------------------------------------------------- 
    73       !! * Modules used 
    74       USE oce           , wk1 => ua,  &  ! use ua as workspace 
    75          &                wk2 => va      ! use va as workspace 
    76  
    77       !! * Arguments 
    78       INTEGER, INTENT( in ) ::   kt           ! ocean time-step index 
    79  
     68      !!---------------------------------------------------------------------- 
     69      !!* Arguments 
     70      INTEGER         , INTENT(in   )                                ::   kt             ! ocean time-step index 
     71      CHARACTER(len=3), INTENT(in   )                                ::   cdtype         ! =TRA or TRC (tracer indicator) 
     72      INTEGER         , INTENT(in   )                                ::   kjpt            ! number of tracers 
     73      REAL(wp)        , INTENT(in   ), DIMENSION(jpi,jpj,jpk,kjpt)   ::   ptrab          ! before and now tracer fields 
     74      REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)   ::   ptraa          ! tracer trend  
    8075      !! * Local declarations 
    81       INTEGER ::   ji, jj, jk                 ! dummy loop indices 
    82       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   & 
    83          wk3, wk4                ! work array used for rotated biharmonic 
     76      INTEGER ::   ji, jj, jk, jn                 ! dummy loop indices 
     77      REAL(wp), DIMENSION(jpi,jpj,jpk,SIZE(ptrab,4)) ::   & 
     78         wk1, wk2                ! work array used for rotated biharmonic 
    8479         !                       ! operator on tracers and/or momentum 
    8580      !!---------------------------------------------------------------------- 
    … …  
    9085         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~' 
    9186      ENDIF 
    92  
    93       ! 1. Laplacian of (tb,sb) * aht 
     87      ! 
     88      ! 
     89 
     90      ! 1. Laplacian of ptrab * aht 
    9491      ! -----------------------------  
    95       ! rotated harmonic operator applied to (tb,sb) 
    96       ! and multiply by aht (output in (wk1,wk2) ) 
    97  
    98       CALL ldfght ( kt, tb, sb, wk1, wk2, 1 ) 
    99  
    100  
    101       ! Lateral boundary conditions on (wk1,wk2)   (unchanged sign) 
    102       CALL lbc_lnk( wk1, 'T', 1. )   ;   CALL lbc_lnk( wk2, 'T', 1. ) 
    103  
    104       ! 2. Bilaplacian of (tb,sb) 
     92      ! rotated harmonic operator applied to ptrab and multiply by aht ; output in wk1  
     93 
     94      CALL ldfght( kt, cdtype, ptrab, wk1, kjpt, 1 ) 
     95 
     96      ! 
     97      DO jn = 1, kjpt 
     98      ! Lateral boundary conditions on wk1   (unchanged sign) 
     99         CALL lbc_lnk( wk1(:,:,:,jn) , 'T', 1. ) 
     100      END DO 
     101 
     102      ! 2. Bilaplacian of ptrab 
    105103      ! ------------------------- 
    106       ! rotated harmonic operator applied to (wk1,wk2) 
    107       ! (output in (wk3,wk4) ) 
    108  
    109       CALL ldfght ( kt, wk1, wk2, wk3, wk4, 2 ) 
     104      ! rotated harmonic operator applied to wk1 ; output in wk2 
     105 
     106      CALL ldfght( kt, cdtype, wk1, wk2, kjpt, 2 ) 
    110107 
    111108 
    112109      ! 3. Update the tracer trends                    (j-slab :   2, jpj-1) 
    113110      ! --------------------------- 
    114       !                                                ! =============== 
    115       DO jj = 2, jpjm1                                 !  Vertical slab 
    116          !                                             ! =============== 
    117          DO jk = 1, jpkm1 
    118             DO ji = 2, jpim1 
    119                ! add it to the general tracer trends 
    120                ta(ji,jj,jk) = ta(ji,jj,jk) + wk3(ji,jj,jk) 
    121                sa(ji,jj,jk) = sa(ji,jj,jk) + wk4(ji,jj,jk) 
    122             END DO 
    123          END DO 
    124          !                                             ! =============== 
    125       END DO                                           !   End of slab 
    126       !                                                ! =============== 
     111      ! 
     112      DO jn = 1, kjpt 
     113         !                                                ! =============== 
     114         DO jj = 2, jpjm1                                 !  Vertical slab 
     115            !                                             ! =============== 
     116            DO jk = 1, jpkm1 
     117               DO ji = 2, jpim1 
     118                  ! add it to the general tracer trends 
     119                  ptraa(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn) + wk2(ji,jj,jk,jn) 
     120               END DO 
     121            END DO 
     122            !                                             ! =============== 
     123         END DO                                           !   End of slab 
     124         !                                                ! =============== 
     125      END DO 
    127126 
    128127   END SUBROUTINE tra_ldf_bilapg 
    129128 
    130129 
    131    SUBROUTINE ldfght ( kt, pt, ps, plt, pls, kaht ) 
     130   SUBROUTINE ldfght ( kt, cdtype, pt, plt, kjpt, kaht ) 
    132131      !!---------------------------------------------------------------------- 
    133132      !!                  ***  ROUTINE ldfght  *** 
    134133      !!           
    135       !! ** Purpose :   Apply a geopotential harmonic operator to (pt,ps) and  
     134      !! ** Purpose :   Apply a geopotential harmonic operator to (pt) and  
    136135      !!      multiply it by the eddy diffusivity coefficient (if kaht=1). 
    137136      !!      Routine only used in s-coordinates (l_sco=T) with bilaplacian 
    … …  
    140139      !! 
    141140      !! ** Method  :   The harmonic operator rotated along geopotential  
    142       !!      surfaces is applied to (pt,ps) using the slopes of geopotential 
     141      !!      surfaces is applied to (pt) using the slopes of geopotential 
    143142      !!      surfaces computed in inildf routine. The result is provided in 
    144143      !!      (plt,pls) arrays. It is computed in 2 steps: 
    … …  
    166165      !!         plt  =  1  / (e1t*e2t*e3t) { plt + dk[ zftw ] } 
    167166      !! 
    168       !! * Action : 
    169       !!      'key_trdtra' defined: the trend is saved for diagnostics. 
    170       !! 
    171       !! History : 
    172       !!   8.0  !  97-07  (G. Madec)  Original code 
    173       !!   8.5  !  02-08  (G. Madec)  F90: Free form and module 
    174       !!---------------------------------------------------------------------- 
     167      !!---------------------------------------------------------------------- 
     168      !! * Modules used 
     169      USE oce         , zftv => ua     ! use ua as workspace 
    175170      !! * Arguments 
    176       INTEGER, INTENT( in ) ::   kt           ! ocean time-step index 
    177       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( in  ) ::   & 
    178          pt, ps           ! tracer fields (before t and s for 1st call 
    179       !                   ! and laplacian of these fields for 2nd call. 
    180       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( out ) ::   & 
    181          plt, pls         ! partial harmonic operator applied to 
    182       !                   ! pt & ps components except 
    183       !                   ! second order vertical derivative term) 
    184       INTEGER, INTENT( in ) ::   & 
    185          kaht             ! =1 multiply the laplacian by the eddy diffusivity coeff. 
    186       !                   ! =2 no multiplication 
    187  
     171      INTEGER         , INTENT(in )                              ::  kt      ! ocean time-step index 
     172      CHARACTER(len=3), INTENT(in )                              ::  cdtype  ! =TRA or TRC (tracer indicator)  
     173      INTEGER         , INTENT(in )                              ::  kjpt    !: dimension of  
     174      REAL(wp)        , INTENT(in ), DIMENSION(jpi,jpj,jpk,kjpt) ::  pt      ! tracer fields ( before for 1st call 
     175      !                                                         ! and laplacian of these fields for 2nd call.  
     176      REAL(wp)        , INTENT(out), DIMENSION(jpi,jpj,jpk,kjpt) ::  plt     !: partial harmonic operator applied to  pt  components except 
     177      !                                                             !: second order vertical derivative term   
     178      INTEGER         , INTENT(in )                              ::  kaht    !: =1 multiply the laplacian by the eddy diffusivity coeff. 
     179      !                                                             !: =2 no multiplication  
    188180      !! * Local declarations 
    189       INTEGER ::   ji, jj, jk             ! dummy loop indices 
    190       REAL(wp) ::   & 
    191          zabe1, zabe2, zmku, zmkv,     &  ! temporary scalars 
    192          zbtr, ztah, zsah, ztav, zsav, & 
    193          zcof0, zcof1, zcof2,          & 
    194          zcof3, zcof4 
    195       REAL(wp), DIMENSION(jpi,jpj) ::  & 
    196          zftu, zfsu,                   &  ! workspace 
    197          zdkt, zdk1t,                  & 
    198          zdks, zdk1s 
    199       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   & 
    200          zftv, zfsv                       ! workspace (only v components for ptr) 
    201       REAL(wp), DIMENSION(jpi,jpk) ::  & 
    202          zftw, zfsw,                   &  ! workspace 
    203          zdit, zdjt, zdj1t,            & 
    204          zdis, zdjs, zdj1s 
    205       !!---------------------------------------------------------------------- 
    206  
    207       !                               ! ********** !   ! =============== 
    208       DO jk = 1, jpkm1                ! First step !   ! Horizontal slab 
    209          !                            ! ********** !   ! =============== 
    210  
    211          ! I.1 Vertical gradient of pt and ps at level jk and jk+1 
    212          ! ------------------------------------------------------- 
    213          !     surface boundary condition: zdkt(jk=1)=zdkt(jk=2) 
    214  
    215          zdk1t(:,:) = ( pt(:,:,jk) - pt(:,:,jk+1) ) * tmask(:,:,jk+1) 
    216          zdk1s(:,:) = ( ps(:,:,jk) - ps(:,:,jk+1) ) * tmask(:,:,jk+1) 
    217  
    218          IF( jk == 1 ) THEN 
    219             zdkt(:,:) = zdk1t(:,:) 
    220             zdks(:,:) = zdk1s(:,:) 
    221          ELSE 
    222             zdkt(:,:) = ( pt(:,:,jk-1) - pt(:,:,jk) ) * tmask(:,:,jk) 
    223             zdks(:,:) = ( ps(:,:,jk-1) - ps(:,:,jk) ) * tmask(:,:,jk) 
     181      INTEGER ::   ji, jj, jk,jn          ! dummy loop indices 
     182      !                                   ! temporary scalars 
     183      REAL(wp) ::  zabe1, zabe2, zmku, zmkv  
     184      REAL(wp) ::  zbtr, ztah, ztav 
     185      REAL(wp) ::  zcof0, zcof1, zcof2, zcof3, zcof4 
     186      REAL(wp), DIMENSION(jpi,jpj) ::  zftu,  zdkt, zdk1t       ! workspace 
     187      REAL(wp), DIMENSION(jpi,jpk) ::  zftw, zdit, zdjt, zdj1t  !  
     188      !!---------------------------------------------------------------------- 
     189 
     190      ! 
     191      DO jn = 1, kjpt 
     192         !                               ! ********** !   ! =============== 
     193         DO jk = 1, jpkm1                ! First step !   ! Horizontal slab 
     194            !                            ! ********** !   ! =============== 
     195             
     196            ! I.1 Vertical gradient of pt and ps at level jk and jk+1 
     197            ! ------------------------------------------------------- 
     198            !     surface boundary condition: zdkt(jk=1)=zdkt(jk=2) 
     199             
     200            zdk1t(:,:) = ( pt(:,:,jk,jn) - pt(:,:,jk+1,jn) ) * tmask(:,:,jk+1) 
     201            IF( jk == 1 ) THEN 
     202               zdkt(:,:) = zdk1t(:,:) 
     203            ELSE 
     204               zdkt(:,:) = ( pt(:,:,jk-1,jn) - pt(:,:,jk,jn) ) * tmask(:,:,jk) 
     205            ENDIF 
     206 
     207 
     208            ! I.2 Horizontal fluxes 
     209            ! --------------------- 
     210             
     211            DO jj = 1, jpjm1 
     212               DO ji = 1, jpim1 
     213                  zabe1 = e2u(ji,jj) * fse3u(ji,jj,jk) / e1u(ji,jj) 
     214                  zabe2 = e1v(ji,jj) * fse3v(ji,jj,jk) / e2v(ji,jj) 
     215                   
     216                  zmku = 1./MAX( tmask(ji+1,jj,jk  )+tmask(ji,jj,jk+1)   & 
     217                     &          +tmask(ji+1,jj,jk+1)+tmask(ji,jj,jk  ),1. ) 
     218                  zmkv = 1./MAX( tmask(ji,jj+1,jk  )+tmask(ji,jj,jk+1)   & 
     219                     &          +tmask(ji,jj+1,jk+1)+tmask(ji,jj,jk  ),1. ) 
     220                   
     221                  zcof1 = -e2u(ji,jj) * uslp(ji,jj,jk) * zmku 
     222                  zcof2 = -e1v(ji,jj) * vslp(ji,jj,jk) * zmkv 
     223                   
     224                  zftu(ji,jj)= umask(ji,jj,jk) *   & 
     225                     &         (  zabe1 *( pt   (ji+1,jj,jk,jn) - pt(ji,jj,jk,jn) )   & 
     226                     &          + zcof1 *( zdkt (ji+1,jj) + zdk1t(ji,jj)     & 
     227                     &                    +zdk1t(ji+1,jj) + zdkt (ji,jj) )  ) 
     228                   
     229                  zftv(ji,jj,jk)= vmask(ji,jj,jk) *   & 
     230                     &         (  zabe2 *( pt(ji,jj+1,jk,jn) - pt(ji,jj,jk,jn) )   & 
     231                     &          + zcof2 *( zdkt (ji,jj+1) + zdk1t(ji,jj)     & 
     232                     &                    +zdk1t(ji,jj+1) + zdkt (ji,jj) )  )                   
     233               END DO 
     234            END DO 
     235 
     236 
     237            ! I.3 Second derivative (divergence) (not divided by the volume) 
     238            ! --------------------- 
     239             
     240            DO jj = 2 , jpjm1 
     241               DO ji = 2 , jpim1 
     242                  ztah = zftu(ji,jj) - zftu(ji-1,jj) + zftv(ji,jj,jk) - zftv(ji,jj-1,jk) 
     243                  plt(ji,jj,jk,jn) = ztah 
     244               END DO 
     245            END DO 
     246            !                                             ! =============== 
     247         END DO                                           !   End of slab 
     248         !                                                ! =============== 
     249         ! "Poleward" diffusive heat or salt transport 
     250         IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( kaht == 2 ) .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN 
     251            IF( jn == jp_tem)   pht_ldf(:) = ptr_vj( zftv(:,:,:) ) 
     252            IF( jn == jp_sal)   pst_ldf(:) = ptr_vj( zftv(:,:,:) ) 
    224253         ENDIF 
    225254 
    226  
    227          ! I.2 Horizontal fluxes 
    228          ! --------------------- 
    229  
    230          DO jj = 1, jpjm1 
    231             DO ji = 1, jpim1 
    232                zabe1 = e2u(ji,jj) * fse3u(ji,jj,jk) / e1u(ji,jj) 
    233                zabe2 = e1v(ji,jj) * fse3v(ji,jj,jk) / e2v(ji,jj) 
    234  
    235                zmku=1./MAX( tmask(ji+1,jj,jk  )+tmask(ji,jj,jk+1)   & 
    236                            +tmask(ji+1,jj,jk+1)+tmask(ji,jj,jk  ),1. ) 
    237                zmkv=1./MAX( tmask(ji,jj+1,jk  )+tmask(ji,jj,jk+1)   & 
    238                            +tmask(ji,jj+1,jk+1)+tmask(ji,jj,jk  ),1. ) 
    239  
    240                zcof1= -e2u(ji,jj) * uslp(ji,jj,jk) * zmku 
    241                zcof2= -e1v(ji,jj) * vslp(ji,jj,jk) * zmkv 
    242  
    243                zftu(ji,jj)= umask(ji,jj,jk) *   & 
    244                   (  zabe1 *( pt(ji+1,jj,jk) - pt(ji,jj,jk) )   & 
    245                    + zcof1 *( zdkt (ji+1,jj) + zdk1t(ji,jj)     & 
    246                              +zdk1t(ji+1,jj) + zdkt (ji,jj) )  ) 
    247  
    248                zftv(ji,jj,jk)= vmask(ji,jj,jk) *   & 
    249                   (  zabe2 *( pt(ji,jj+1,jk) - pt(ji,jj,jk) )   & 
    250                    + zcof2 *( zdkt (ji,jj+1) + zdk1t(ji,jj)     & 
    251                              +zdk1t(ji,jj+1) + zdkt (ji,jj) )  ) 
    252  
    253                zfsu(ji,jj)= umask(ji,jj,jk) *   & 
    254                   (  zabe1 *( ps(ji+1,jj,jk) - ps(ji,jj,jk) )   & 
    255                    + zcof1 *( zdks (ji+1,jj) + zdk1s(ji,jj)     & 
    256                              +zdk1s(ji+1,jj) + zdks (ji,jj) )  ) 
    257  
    258                zfsv(ji,jj,jk)= vmask(ji,jj,jk) *   & 
    259                   (  zabe2 *( ps(ji,jj+1,jk) - ps(ji,jj,jk) )   & 
    260                    + zcof2 *( zdks (ji,jj+1) + zdk1s(ji,jj)     & 
    261                              +zdk1s(ji,jj+1) + zdks (ji,jj) )  ) 
    262             END DO 
    263          END DO 
    264  
    265  
    266          ! I.3 Second derivative (divergence) (not divided by the volume) 
    267          ! --------------------- 
    268  
    269          DO jj = 2 , jpjm1 
    270             DO ji = 2 , jpim1 
    271                ztah = zftu(ji,jj) - zftu(ji-1,jj) + zftv(ji,jj,jk) - zftv(ji,jj-1,jk) 
    272                zsah = zfsu(ji,jj) - zfsu(ji-1,jj) + zfsv(ji,jj,jk) - zfsv(ji,jj-1,jk) 
    273                plt(ji,jj,jk) = ztah 
    274                pls(ji,jj,jk) = zsah 
    275             END DO 
    276          END DO 
    277          !                                             ! =============== 
    278       END DO                                           !   End of slab 
    279       !                                                ! =============== 
    280   
    281       !!but this should be done somewhere after  
    282       ! "zonal" mean diffusive heat and salt transport 
    283       IF( ln_diaptr .AND. ( kaht == 2 ) .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN 
    284          pht_ldf(:) = ptr_vj( zftv(:,:,:) ) 
    285          pst_ldf(:) = ptr_vj( zfsv(:,:,:) ) 
    286       ENDIF 
    287  
    288       !                             ! ************ !   ! =============== 
    289       DO jj = 2, jpjm1              !  Second step !   ! Horizontal slab 
    290          !                          ! ************ !   ! =============== 
    291  
    292          ! II.1 horizontal tracer gradient 
    293          ! ------------------------------- 
    294  
    295          DO jk = 1, jpk 
    296             DO ji = 1, jpim1 
    297                zdit (ji,jk) = ( pt(ji+1,jj  ,jk) - pt(ji,jj  ,jk) ) * umask(ji,jj  ,jk) 
    298                zdis (ji,jk) = ( ps(ji+1,jj  ,jk) - ps(ji,jj  ,jk) ) * umask(ji,jj  ,jk) 
    299                zdjt (ji,jk) = ( pt(ji  ,jj+1,jk) - pt(ji,jj  ,jk) ) * vmask(ji,jj  ,jk) 
    300                zdjs (ji,jk) = ( ps(ji  ,jj+1,jk) - ps(ji,jj  ,jk) ) * vmask(ji,jj  ,jk) 
    301                zdj1t(ji,jk) = ( pt(ji  ,jj  ,jk) - pt(ji,jj-1,jk) ) * vmask(ji,jj-1,jk) 
    302                zdj1s(ji,jk) = ( ps(ji  ,jj  ,jk) - ps(ji,jj-1,jk) ) * vmask(ji,jj-1,jk) 
    303             END DO 
    304          END DO 
    305  
    306  
    307          ! II.2 Vertical fluxes 
    308          ! -------------------- 
    309  
    310          ! Surface and bottom vertical fluxes set to zero 
    311          zftw(:, 1 ) = 0.e0 
    312          zfsw(:, 1 ) = 0.e0 
    313          zftw(:,jpk) = 0.e0 
    314          zfsw(:,jpk) = 0.e0 
    315  
    316          ! interior (2=<jk=<jpk-1) 
    317          DO jk = 2, jpkm1 
    318             DO ji = 2, jpim1 
    319                zcof0 = e1t(ji,jj) * e2t(ji,jj) / fse3w(ji,jj,jk)   & 
    320                      * (  wslpi(ji,jj,jk) * wslpi(ji,jj,jk)        & 
    321                         + wslpj(ji,jj,jk) * wslpj(ji,jj,jk)  ) 
    322  
    323                zmku =1./MAX(  umask(ji  ,jj,jk-1)+umask(ji-1,jj,jk)   & 
    324                              +umask(ji-1,jj,jk-1)+umask(ji  ,jj,jk), 1. ) 
    325  
    326                zmkv =1./MAX(  vmask(ji,jj  ,jk-1)+vmask(ji,jj-1,jk)   & 
    327                              +vmask(ji,jj-1,jk-1)+vmask(ji,jj  ,jk), 1. ) 
    328  
    329                zcof3 = - e2t(ji,jj) * wslpi (ji,jj,jk) * zmku 
    330                zcof4 = - e1t(ji,jj) * wslpj (ji,jj,jk) * zmkv 
    331  
    332                zftw(ji,jk) = tmask(ji,jj,jk) *   & 
    333                   (  zcof0 * ( pt  (ji,jj,jk-1) - pt  (ji,jj,jk) )   & 
    334                    + zcof3 * ( zdit (ji  ,jk-1) + zdit (ji-1,jk)     & 
    335                               +zdit (ji-1,jk-1) + zdit (ji  ,jk) )   & 
    336                    + zcof4 * ( zdjt (ji  ,jk-1) + zdj1t(ji  ,jk)     & 
    337                               +zdj1t(ji  ,jk-1) + zdjt (ji  ,jk) )  ) 
    338  
    339                zfsw(ji,jk) = tmask(ji,jj,jk) *   & 
    340                   (  zcof0 * ( ps  (ji,jj,jk-1) - ps  (ji,jj,jk) )   & 
    341                    + zcof3 * ( zdis (ji  ,jk-1) + zdis (ji-1,jk)     & 
    342                               +zdis (ji-1,jk-1) + zdis (ji  ,jk) )   & 
    343                    + zcof4 * ( zdjs (ji  ,jk-1) + zdj1s(ji  ,jk)     & 
    344                               +zdj1s(ji  ,jk-1) + zdjs (ji  ,jk) )  ) 
    345             END DO 
    346          END DO 
    347  
    348  
    349          ! II.3 Divergence of vertical fluxes added to the horizontal divergence 
    350          ! --------------------------------------------------------------------- 
    351  
    352          IF( kaht == 1 ) THEN 
    353             ! multiply the laplacian by the eddy diffusivity coefficient 
    354             DO jk = 1, jpkm1 
     255         !                             ! ************ !   ! =============== 
     256         DO jj = 2, jpjm1              !  Second step !   ! Horizontal slab 
     257            !                          ! ************ !   ! =============== 
     258             
     259            ! II.1 horizontal tracer gradient 
     260            ! ------------------------------- 
     261             
     262            DO jk = 1, jpk 
     263               DO ji = 1, jpim1 
     264                  zdit (ji,jk) = ( pt(ji+1,jj  ,jk,jn) - pt(ji,jj  ,jk,jn) ) * umask(ji,jj  ,jk) 
     265                  zdjt (ji,jk) = ( pt(ji  ,jj+1,jk,jn) - pt(ji,jj  ,jk,jn) ) * vmask(ji,jj  ,jk) 
     266                  zdj1t(ji,jk) = ( pt(ji  ,jj  ,jk,jn) - pt(ji,jj-1,jk,jn) ) * vmask(ji,jj-1,jk) 
     267               END DO 
     268            END DO 
     269 
     270 
     271            ! II.2 Vertical fluxes 
     272            ! -------------------- 
     273             
     274            ! Surface and bottom vertical fluxes set to zero 
     275            zftw(:, 1 ) = 0.e0 
     276            zftw(:,jpk) = 0.e0 
     277             
     278            ! interior (2=<jk=<jpk-1) 
     279            DO jk = 2, jpkm1 
    355280               DO ji = 2, jpim1 
    356                   ! eddy coef. divided by the volume element 
    357                   zbtr = fsahtt(ji,jj,jk) / ( e1t(ji,jj)*e2t(ji,jj)*fse3t(ji,jj,jk) ) 
    358                   ! vertical divergence 
    359                   ztav = zftw(ji,jk) - zftw(ji,jk+1) 
    360                   zsav = zfsw(ji,jk) - zfsw(ji,jk+1) 
    361                   ! harmonic operator applied to (pt,ps) and multiply by aht 
    362                   plt(ji,jj,jk) = ( plt(ji,jj,jk) + ztav ) * zbtr 
    363                   pls(ji,jj,jk) = ( pls(ji,jj,jk) + zsav ) * zbtr 
    364                END DO 
    365             END DO 
    366          ELSEIF( kaht == 2 ) THEN 
    367             ! second call, no multiplication 
    368             DO jk = 1, jpkm1 
    369                DO ji = 2, jpim1 
    370                   ! inverse of the volume element 
    371                   zbtr = 1. / ( e1t(ji,jj)*e2t(ji,jj)*fse3t(ji,jj,jk) ) 
    372                   ! vertical divergence 
    373                   ztav = zftw(ji,jk) - zftw(ji,jk+1) 
    374                   zsav = zfsw(ji,jk) - zfsw(ji,jk+1) 
    375                   ! harmonic operator applied to (pt,ps)  
    376                   plt(ji,jj,jk) = ( plt(ji,jj,jk) + ztav ) * zbtr 
    377                   pls(ji,jj,jk) = ( pls(ji,jj,jk) + zsav ) * zbtr 
    378                END DO 
    379             END DO 
    380          ELSE 
    381             IF(lwp) WRITE(numout,*) ' ldfght: kaht= 1 or 2, here =', kaht 
    382             IF(lwp) WRITE(numout,*) '         We stop' 
    383             STOP 'ldfght' 
    384          ENDIF 
    385          !                                             ! =============== 
    386       END DO                                           !   End of slab 
    387       !                                                ! =============== 
     281                  zcof0 = e1t(ji,jj) * e2t(ji,jj) / fse3w(ji,jj,jk)   & 
     282                     &     * (  wslpi(ji,jj,jk) * wslpi(ji,jj,jk)        & 
     283                     &        + wslpj(ji,jj,jk) * wslpj(ji,jj,jk)  ) 
     284                   
     285                  zmku = 1./MAX(  umask(ji  ,jj,jk-1)+umask(ji-1,jj,jk)   & 
     286                     &           +umask(ji-1,jj,jk-1)+umask(ji  ,jj,jk), 1. ) 
     287                   
     288                  zmkv = 1./MAX(  vmask(ji,jj  ,jk-1)+vmask(ji,jj-1,jk)   & 
     289                     &           +vmask(ji,jj-1,jk-1)+vmask(ji,jj  ,jk), 1. ) 
     290                   
     291                  zcof3 = - e2t(ji,jj) * wslpi (ji,jj,jk) * zmku 
     292                  zcof4 = - e1t(ji,jj) * wslpj (ji,jj,jk) * zmkv 
     293                   
     294                  zftw(ji,jk) = tmask(ji,jj,jk) *   & 
     295                     &    (  zcof0 * ( pt   (ji,jj,jk-1,jn) - pt   (ji  ,jj,jk,jn) )   & 
     296                     &     + zcof3 * ( zdit (ji   ,jk-1   ) + zdit (ji-1,jk      )     & 
     297                     &                +zdit (ji-1 ,jk-1   ) + zdit (ji  ,jk      ) )   & 
     298                     &     + zcof4 * ( zdjt (ji   ,jk-1   ) + zdj1t(ji  ,jk)     & 
     299                     &                +zdj1t(ji   ,jk-1   ) + zdjt (ji  ,jk      ) )  )                  
     300               END DO 
     301            END DO 
     302 
     303 
     304            ! II.3 Divergence of vertical fluxes added to the horizontal divergence 
     305            ! --------------------------------------------------------------------- 
     306             
     307            IF( kaht == 1 ) THEN 
     308               ! multiply the laplacian by the eddy diffusivity coefficient 
     309               DO jk = 1, jpkm1 
     310                  DO ji = 2, jpim1 
     311                     ! eddy coef. divided by the volume element 
     312                     zbtr = 1.0 / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
     313                     ! vertical divergence 
     314                     ztav = fsahtt(ji,jj,jk) * ( zftw(ji,jk) - zftw(ji,jk+1) ) 
     315                     ! harmonic operator applied to (pt,ps) and multiply by aht 
     316                     plt(ji,jj,jk,jn) = ( plt(ji,jj,jk,jn) + ztav ) * zbtr 
     317                  END DO 
     318               END DO 
     319            ELSEIF( kaht == 2 ) THEN 
     320               ! second call, no multiplication 
     321               DO jk = 1, jpkm1 
     322                  DO ji = 2, jpim1 
     323                     ! inverse of the volume element 
     324                     zbtr = 1.0 / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
     325                     ! vertical divergence 
     326                     ztav = zftw(ji,jk) - zftw(ji,jk+1) 
     327                     ! harmonic operator applied to (pt,ps)  
     328                     plt(ji,jj,jk,jn) = ( plt(ji,jj,jk,jn) + ztav ) * zbtr 
     329                  END DO 
     330               END DO 
     331            ELSE 
     332               IF(lwp) WRITE(numout,*) ' ldfght: kaht= 1 or 2, here =', kaht 
     333               IF(lwp) WRITE(numout,*) '         We stop' 
     334               STOP 'ldfght' 
     335            ENDIF 
     336            !                                             ! =============== 
     337         END DO                                           !   End of slab 
     338         !                                                ! =============== 
     339      END DO 
     340      ! 
    388341   END SUBROUTINE ldfght 
    389342 

  • branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/traldf_iso.F90

    r1756 r2024  
    22   !!====================================================================== 
    33   !!                   ***  MODULE  traldf_iso  *** 
    4    !! Ocean active tracers:  horizontal component of the lateral tracer mixing trend 
     4   !! Ocean tracers:  horizontal component of the lateral tracer mixing trend 
    55   !!====================================================================== 
    6    !! History :        !  94-08  (G. Madec, M. Imbard) 
    7    !!                  !  97-05  (G. Madec)  split into traldf and trazdf 
    8    !!             8.5  !  02-08  (G. Madec)  Free form, F90 
    9    !!             9.0  !  05-11  (G. Madec)  merge traldf and trazdf :-) 
     6   !! History :   OPA  !  1994-08  (G. Madec, M. Imbard) 
     7   !!                  !  1997-05  (G. Madec)  split into traldf and trazdf 
     8   !!             NEMO !  2002-08  (G. Madec)  Free form, F90 
     9   !!             1.0  !  2005-11  (G. Madec)  merge traldf and trazdf :-) 
     10   !!             3.0  !  2008-01  (C. Ethe, G. Madec) Merge TRA-TRC 
    1011   !!---------------------------------------------------------------------- 
    1112#if   defined key_ldfslp   ||   defined key_esopa 
    … …  
    2223   USE dom_oce         ! ocean space and time domain 
    2324   USE ldftra_oce      ! ocean active tracers: lateral physics 
    24    USE trdmod          ! ocean active tracers trends  
    25    USE trdmod_oce      ! ocean variables trends 
    2625   USE zdf_oce         ! ocean vertical physics 
    2726   USE in_out_manager  ! I/O manager 
    … …  
    2928   USE ldfslp          ! iso-neutral slopes 
    3029   USE diaptr          ! poleward transport diagnostics 
    31    USE prtctl          ! Print control 
    3230#if defined key_diaar5 
    3331   USE phycst          ! physical constants 
    … …  
    5250CONTAINS 
    5351 
    54    SUBROUTINE tra_ldf_iso( kt ) 
     52   SUBROUTINE tra_ldf_iso( kt   , cdtype, pgtu, pgtv,  & 
     53      &                    ptrab, ptraa , kjpt, pahtb0 ) 
    5554      !!---------------------------------------------------------------------- 
    5655      !!                  ***  ROUTINE tra_ldf_iso  *** 
    … …  
    6665      !!      nal or geopotential slopes computed in routine ldfslp. 
    6766      !! 
    68       !!      1st part :  masked horizontal derivative of T & S ( di[ t ] ) 
     67      !!      1st part :  masked horizontal derivative of T ( di[ t ] ) 
    6968      !!      ========    with partial cell update if ln_zps=T. 
    7069      !! 
    … …  
    8887      !!         difft = 1/(e1t*e2t*e3t) dk[ zftw ] 
    8988      !!      Add this trend to the general trend (ta,sa): 
    90       !!         ta = ta + difft 
    91       !! 
    92       !! ** Action :   Update (ta,sa) arrays with the before rotated diffusion 
    93       !!            trend (except the dk[ dk[.] ] term) 
     89      !!         pta = pta + difft 
     90      !! 
     91      !! ** Action :   Update pta arrays with the before rotated diffusion 
    9492      !!---------------------------------------------------------------------- 
    95       USE oce           , zftv => ua   ! use ua as workspace 
    96       USE oce           , zfsv => va   ! use va as workspace 
    97       !! 
    98       INTEGER, INTENT( in ) ::   kt    ! ocean time-step index 
    99       !! 
    100       INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    101       INTEGER  ::   iku, ikv     ! temporary integer 
    102       REAL(wp) ::   zmsku, zabe1, zcof1, zcoef3, zta   ! temporary scalars 
    103       REAL(wp) ::   zmskv, zabe2, zcof2, zcoef4, zsa   !    "         " 
    104       REAL(wp) ::   zcoef0, zbtr                       !    "         " 
    105       REAL(wp), DIMENSION(jpi,jpj)     ::   zdkt , zdk1t         ! 2D workspace 
    106       REAL(wp), DIMENSION(jpi,jpj)     ::   zdks , zdk1s, zfsu   !  "         " 
     93      !!* Module used 
     94      USE oce         , zftu => ua   ! use ua as workspace 
     95      USE oce         , zftv => va   ! use va as workspace 
     96      !!* Arguments 
     97      INTEGER         , INTENT(in   )                                ::   kt             ! ocean time-step index 
     98      CHARACTER(len=3), INTENT(in   )                                ::   cdtype         ! =TRA or TRC (tracer indicator) 
     99      INTEGER         , INTENT(in   )                                ::   kjpt            ! number of tracers 
     100      REAL(wp)        , INTENT(in   ), DIMENSION(jpi,jpj,kjpt  )     ::   pgtu, pgtv     ! tracer gradient at pstep levels 
     101      REAL(wp)        , INTENT(in   ), DIMENSION(jpi,jpj,jpk,kjpt)   ::   ptrab          ! before and now tracer fields 
     102      REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)   ::   ptraa          ! tracer trend  
     103      REAL(wp)        , INTENT(in   )                                ::   pahtb0         ! background diffusion coef 
     104      !!* Local declarations 
     105      INTEGER  ::  ji, jj, jk,jn   ! dummy loop indices 
     106      INTEGER  ::  iku, ikv     ! temporary integer 
     107      REAL(wp) ::  zmsku, zabe1, zcof1, zcoef3   ! temporary scalars 
     108      REAL(wp) ::  zmskv, zabe2, zcof2, zcoef4   !    "         " 
     109      REAL(wp) ::  zcoef0, zbtr, ztra                           !    "         " 
     110      REAL(wp), DIMENSION(jpi,jpj)     ::   zdkt, zdk1t         ! 2D workspace 
     111      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zdit, zdjt, ztfw     ! 3D workspace 
    107112#if defined key_diaar5 
    108113      REAL(wp), DIMENSION(jpi,jpj)     ::   z2d                  !  "         " 
    109114      REAL(wp)                         ::   zztmp                !  "         " 
    110       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zftu                 ! 3D workspace 
    111 #else 
    112       REAL(wp), DIMENSION(jpi,jpj)     ::   zftu                 ! 2D workspace 
    113115#endif 
    114       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zdit, zdjt, ztfw     ! 3D workspace 
    115       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zdis, zdjs, zsfw     !  "      " 
    116 # if defined key_diaar5 
    117 # endif   
    118116      !!---------------------------------------------------------------------- 
    119117 
    … …  
    123121         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 
    124122      ENDIF 
    125  
    126       !!---------------------------------------------------------------------- 
    127       !!   I - masked horizontal derivative of T & S 
    128       !!---------------------------------------------------------------------- 
    129 !!bug ajout.... why?   ( 1,jpj,:) and (jpi,1,:) should be sufficient.... 
    130       zdit (1,:,:) = 0.e0     ;     zdit (jpi,:,:) = 0.e0 
    131       zdis (1,:,:) = 0.e0     ;     zdis (jpi,:,:) = 0.e0 
    132       zdjt (1,:,:) = 0.e0     ;     zdjt (jpi,:,:) = 0.e0 
    133       zdjs (1,:,:) = 0.e0     ;     zdjs (jpi,:,:) = 0.e0 
    134 !!end 
    135  
    136       ! Horizontal temperature and salinity gradient  
    137       DO jk = 1, jpkm1 
    138          DO jj = 1, jpjm1 
    139             DO ji = 1, fs_jpim1   ! vector opt. 
    140                zdit(ji,jj,jk) = ( tb(ji+1,jj  ,jk) - tb(ji,jj,jk) ) * umask(ji,jj,jk) 
    141                zdis(ji,jj,jk) = ( sb(ji+1,jj  ,jk) - sb(ji,jj,jk) ) * umask(ji,jj,jk) 
    142                zdjt(ji,jj,jk) = ( tb(ji  ,jj+1,jk) - tb(ji,jj,jk) ) * vmask(ji,jj,jk) 
    143                zdjs(ji,jj,jk) = ( sb(ji  ,jj+1,jk) - sb(ji,jj,jk) ) * vmask(ji,jj,jk) 
     123      ! 
     124      !                                                          ! =========== 
     125      DO jn = 1, kjpt                                            ! tracer loop 
     126         !                                                       ! =========== 
     127         !                                                
     128         !!---------------------------------------------------------------------- 
     129         !!   I - masked horizontal derivative  
     130         !!---------------------------------------------------------------------- 
     131         !!bug ajout.... why?   ( 1,jpj,:) and (jpi,1,:) should be sufficient.... 
     132         zdit (1,:,:) = 0.e0     ;     zdit (jpi,:,:) = 0.e0 
     133         zdjt (1,:,:) = 0.e0     ;     zdjt (jpi,:,:) = 0.e0 
     134         !!end 
     135 
     136         ! Horizontal tracer gradient  
     137         DO jk = 1, jpkm1 
     138            DO jj = 1, jpjm1 
     139               DO ji = 1, fs_jpim1   ! vector opt. 
     140                  zdit(ji,jj,jk) = ( ptrab(ji+1,jj  ,jk,jn) - ptrab(ji,jj,jk,jn) ) * umask(ji,jj,jk) 
     141                  zdjt(ji,jj,jk) = ( ptrab(ji  ,jj+1,jk,jn) - ptrab(ji,jj,jk,jn) ) * vmask(ji,jj,jk) 
     142               END DO 
    144143            END DO 
    145144         END DO 
    146       END DO 
    147       IF( ln_zps ) THEN      ! partial steps correction at the last level  
    148          DO jj = 1, jpjm1 
    149             DO ji = 1, fs_jpim1   ! vector opt. 
    150                ! last level 
    151                iku = MIN( mbathy(ji,jj), mbathy(ji+1,jj  ) ) - 1 
    152                ikv = MIN( mbathy(ji,jj), mbathy(ji  ,jj+1) ) - 1 
    153                zdit(ji,jj,iku) = gtu(ji,jj)  
    154                zdis(ji,jj,iku) = gsu(ji,jj)                
    155                zdjt(ji,jj,ikv) = gtv(ji,jj)  
    156                zdjs(ji,jj,ikv) = gsv(ji,jj)                
     145         IF( ln_zps ) THEN      ! partial steps correction at the last level  
     146            DO jj = 1, jpjm1 
     147               DO ji = 1, fs_jpim1   ! vector opt. 
     148                  ! last level 
     149                  iku = MIN( mbathy(ji,jj), mbathy(ji+1,jj  ) ) - 1 
     150                  ikv = MIN( mbathy(ji,jj), mbathy(ji  ,jj+1) ) - 1 
     151                  zdit(ji,jj,iku) = pgtu(ji,jj,jn)           
     152                  zdjt(ji,jj,ikv) = pgtv(ji,jj,jn)       
     153               END DO 
     154            END DO 
     155         ENDIF 
     156 
     157         !!---------------------------------------------------------------------- 
     158         !!   II - horizontal trend  (full) 
     159         !!---------------------------------------------------------------------- 
     160          
     161!CDIR PARALLEL DO PRIVATE( zdk1t )  
     162         !                                                ! =============== 
     163         DO jk = 1, jpkm1                                 ! Horizontal slab 
     164            !                                             ! =============== 
     165            ! 1. Vertical tracer gradient at level jk and jk+1 
     166            ! ------------------------------------------------ 
     167            ! surface boundary condition: zdkt(jk=1)=zdkt(jk=2) 
     168             
     169            zdk1t(:,:) = ( ptrab(:,:,jk,jn) - ptrab(:,:,jk+1,jn) ) * tmask(:,:,jk+1) 
     170             
     171            IF( jk == 1 ) THEN 
     172               zdkt(:,:) = zdk1t(:,:) 
     173            ELSE 
     174               zdkt(:,:) = ( ptrab(:,:,jk-1,jn) - ptrab(:,:,jk,jn) ) * tmask(:,:,jk) 
     175            ENDIF 
     176 
     177 
     178            ! 2. Horizontal fluxes 
     179            ! -------------------- 
     180             
     181            DO jj = 1 , jpjm1 
     182               DO ji = 1, fs_jpim1   ! vector opt. 
     183                  zabe1 = ( fsahtu(ji,jj,jk) + pahtb0 ) * e2u(ji,jj) * fse3u(ji,jj,jk) / e1u(ji,jj) 
     184                  zabe2 = ( fsahtv(ji,jj,jk) + pahtb0 ) * e1v(ji,jj) * fse3v(ji,jj,jk) / e2v(ji,jj) 
     185                   
     186                  zmsku = 1. / MAX(  tmask(ji+1,jj,jk  ) + tmask(ji,jj,jk+1)   & 
     187                     &             + tmask(ji+1,jj,jk+1) + tmask(ji,jj,jk  ), 1. ) 
     188                   
     189                  zmskv = 1. / MAX(  tmask(ji,jj+1,jk  ) + tmask(ji,jj,jk+1)   & 
     190                     &             + tmask(ji,jj+1,jk+1) + tmask(ji,jj,jk  ), 1. ) 
     191                   
     192                  zcof1 = - fsahtu(ji,jj,jk) * e2u(ji,jj) * uslp(ji,jj,jk) * zmsku 
     193                  zcof2 = - fsahtv(ji,jj,jk) * e1v(ji,jj) * vslp(ji,jj,jk) * zmskv 
     194                  ! 
     195                  zftu(ji,jj,jk ) = (  zabe1 * zdit(ji,jj,jk)   & 
     196                     &              + zcof1 * (  zdkt (ji+1,jj) + zdk1t(ji,jj)      & 
     197                     &                         + zdk1t(ji+1,jj) + zdkt (ji,jj)  )  ) * umask(ji,jj,jk) 
     198                  zftv(ji,jj,jk) = (  zabe2 * zdjt(ji,jj,jk)   & 
     199                     &              + zcof2 * (  zdkt (ji,jj+1) + zdk1t(ji,jj)      & 
     200                     &                         + zdk1t(ji,jj+1) + zdkt (ji,jj)  )  ) * vmask(ji,jj,jk)                   
     201               END DO 
     202            END DO 
     203 
     204 
     205            ! II.4 Second derivative (divergence) and add to the general trend 
     206            ! ---------------------------------------------------------------- 
     207            DO jj = 2 , jpjm1 
     208               DO ji = fs_2, fs_jpim1   ! vector opt. 
     209                  zbtr = 1.0 / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
     210                  ztra = zbtr * ( zftu(ji,jj,jk) - zftu(ji-1,jj,jk) + zftv(ji,jj,jk) - zftv(ji,jj-1,jk)  ) 
     211                  ptraa(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn) + ztra 
     212               END DO 
     213            END DO 
     214            !                                          ! =============== 
     215         END DO                                        !   End of slab   
     216         !                                             ! =============== 
     217         ! "Poleward" diffusive heat or salt transports 
     218         IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN 
     219            IF( jn == jp_tem)   pht_ldf(:) = ptr_vj( zftv(:,:,:) ) 
     220            IF( jn == jp_sal)   pst_ldf(:) = ptr_vj( zftv(:,:,:) ) 
     221         ENDIF 
     222  
     223#if defined key_diaar5 
     224         IF( cdtype == 'TRA' .AND. jn == jp_tem  ) THEN 
     225            zztmp = 0.5 * rau0 * rcp  
     226            z2d(:,:) = 0.e0  
     227            DO jk = 1, jpkm1 
     228               DO jj = 2, jpjm1 
     229                  DO ji = fs_2, fs_jpim1   ! vector opt. 
     230                     z2d(ji,jj) = z2d(ji,jj) + zztmp * zftu(ji,jj,jk)   & 
     231            &                    * ( ptran(ji,jj,jk,jn) + ptran(ji+1,jj,jk,jn) ) * e1u(ji,jj) * fse3u(ji,jj,jk)  
     232                  END DO 
     233               END DO 
     234            END DO 
     235            CALL lbc_lnk( z2d, 'U', -1. ) 
     236            CALL iom_put( "udiff_heattr", z2d )                  ! heat transport in i-direction 
     237            z2d(:,:) = 0.e0  
     238            DO jk = 1, jpkm1 
     239               DO jj = 2, jpjm1 
     240                  DO ji = fs_2, fs_jpim1   ! vector opt. 
     241                     z2d(ji,jj) = z2d(ji,jj) + zztmp * zftv(ji,jj,jk)   & 
     242           &                   * ( ptran(ji,jj,jk,jn) + ptran(ji,jj+1,jk,jn) ) * e2v(ji,jj) * fse3v(ji,jj,jk)  
     243                  END DO 
     244               END DO 
     245            END DO 
     246            CALL lbc_lnk( z2d, 'V', -1. ) 
     247            CALL iom_put( "vdiff_heattr", z2d )                  !  heat transport in i-direction 
     248         END IF 
     249#endif 
     250 
     251         !!---------------------------------------------------------------------- 
     252         !!   III - vertical trend of T & S (extra diagonal terms only) 
     253         !!---------------------------------------------------------------------- 
     254          
     255         ! Local constant initialization 
     256         ! ----------------------------- 
     257         ztfw(1,:,:) = 0.e0     ;     ztfw(jpi,:,:) = 0.e0 
     258          
     259         ! Vertical fluxes 
     260         ! --------------- 
     261          
     262         ! Surface and bottom vertical fluxes set to zero 
     263         ztfw(:,:, 1 ) = 0.e0      ;      ztfw(:,:,jpk) = 0.e0 
     264          
     265         ! interior (2=<jk=<jpk-1) 
     266         DO jk = 2, jpkm1 
     267            DO jj = 2, jpjm1 
     268               DO ji = fs_2, fs_jpim1   ! vector opt. 
     269                  zcoef0 = - fsahtw(ji,jj,jk) * tmask(ji,jj,jk) 
     270                   
     271                  zmsku = 1./MAX(   umask(ji  ,jj,jk-1) + umask(ji-1,jj,jk)      & 
     272                     &            + umask(ji-1,jj,jk-1) + umask(ji  ,jj,jk), 1.  ) 
     273                   
     274                  zmskv = 1./MAX(   vmask(ji,jj  ,jk-1) + vmask(ji,jj-1,jk)      & 
     275                     &            + vmask(ji,jj-1,jk-1) + vmask(ji,jj  ,jk), 1.  ) 
     276                   
     277                  zcoef3 = zcoef0 * e2t(ji,jj) * zmsku * wslpi (ji,jj,jk) 
     278                  zcoef4 = zcoef0 * e1t(ji,jj) * zmskv * wslpj (ji,jj,jk) 
     279                   
     280                  ztfw(ji,jj,jk) = zcoef3 * (   zdit(ji  ,jj  ,jk-1) + zdit(ji-1,jj  ,jk)      & 
     281                     &                        + zdit(ji-1,jj  ,jk-1) + zdit(ji  ,jj  ,jk)  )   & 
     282                     &           + zcoef4 * (   zdjt(ji  ,jj  ,jk-1) + zdjt(ji  ,jj-1,jk)      & 
     283                     &                        + zdjt(ji  ,jj-1,jk-1) + zdjt(ji  ,jj  ,jk)  ) 
     284               END DO 
    157285            END DO 
    158286         END DO 
    159       ENDIF 
    160  
    161       !!---------------------------------------------------------------------- 
    162       !!   II - horizontal trend of T & S (full) 
    163       !!---------------------------------------------------------------------- 
    164        
    165 #if defined key_diaar5 
    166 !CDIR PARALLEL DO PRIVATE( zdk1t, zdk1s, zfsu )  
    167 #else 
    168 !CDIR PARALLEL DO PRIVATE( zdk1t, zdk1s, zftu, zfsu )  
    169 #endif 
    170       !                                                ! =============== 
    171       DO jk = 1, jpkm1                                 ! Horizontal slab 
    172          !                                             ! =============== 
    173          ! 1. Vertical tracer gradient at level jk and jk+1 
    174          ! ------------------------------------------------ 
    175          ! surface boundary condition: zdkt(jk=1)=zdkt(jk=2) 
    176  
    177          zdk1t(:,:) = ( tb(:,:,jk) - tb(:,:,jk+1) ) * tmask(:,:,jk+1) 
    178          zdk1s(:,:) = ( sb(:,:,jk) - sb(:,:,jk+1) ) * tmask(:,:,jk+1) 
    179  
    180          IF( jk == 1 ) THEN 
    181             zdkt(:,:) = zdk1t(:,:) 
    182             zdks(:,:) = zdk1s(:,:) 
    183          ELSE 
    184             zdkt(:,:) = ( tb(:,:,jk-1) - tb(:,:,jk) ) * tmask(:,:,jk) 
    185             zdks(:,:) = ( sb(:,:,jk-1) - sb(:,:,jk) ) * tmask(:,:,jk) 
    186          ENDIF 
    187  
    188  
    189          ! 2. Horizontal fluxes 
    190          ! -------------------- 
    191  
    192          DO jj = 1 , jpjm1 
    193             DO ji = 1, fs_jpim1   ! vector opt. 
    194                zabe1 = ( fsahtu(ji,jj,jk) + ahtb0 ) * e2u(ji,jj) * fse3u(ji,jj,jk) / e1u(ji,jj) 
    195                zabe2 = ( fsahtv(ji,jj,jk) + ahtb0 ) * e1v(ji,jj) * fse3v(ji,jj,jk) / e2v(ji,jj) 
    196  
    197                zmsku = 1. / MAX(  tmask(ji+1,jj,jk  ) + tmask(ji,jj,jk+1)   & 
    198                   &             + tmask(ji+1,jj,jk+1) + tmask(ji,jj,jk  ), 1. ) 
    199  
    200                zmskv = 1. / MAX(  tmask(ji,jj+1,jk  ) + tmask(ji,jj,jk+1)   & 
    201                   &             + tmask(ji,jj+1,jk+1) + tmask(ji,jj,jk  ), 1. ) 
    202  
    203                zcof1 = -fsahtu(ji,jj,jk) * e2u(ji,jj) * uslp(ji,jj,jk) * zmsku 
    204                zcof2 = -fsahtv(ji,jj,jk) * e1v(ji,jj) * vslp(ji,jj,jk) * zmskv 
    205  
    206 #if defined key_diaar5 
    207                zftu(ji,jj,jk) = (  zabe1 * zdit(ji,jj,jk)   & 
    208 #else 
    209                zftu(ji,jj   ) = (  zabe1 * zdit(ji,jj,jk)   & 
    210 #endif 
    211                   &              + zcof1 * (  zdkt (ji+1,jj) + zdk1t(ji,jj)      & 
    212                   &                         + zdk1t(ji+1,jj) + zdkt (ji,jj)  )  ) * umask(ji,jj,jk) 
    213                zftv(ji,jj,jk) = (  zabe2 * zdjt(ji,jj,jk)   & 
    214                   &              + zcof2 * (  zdkt (ji,jj+1) + zdk1t(ji,jj)      & 
    215                   &                         + zdk1t(ji,jj+1) + zdkt (ji,jj)  )  ) * vmask(ji,jj,jk) 
    216                zfsu(ji,jj   ) = (  zabe1 * zdis(ji,jj,jk)   & 
    217                   &              + zcof1 * (  zdks (ji+1,jj) + zdk1s(ji,jj)      & 
    218                   &                         + zdk1s(ji+1,jj) + zdks (ji,jj)  )  ) * umask(ji,jj,jk) 
    219                zfsv(ji,jj,jk) = (  zabe2 * zdjs(ji,jj,jk)   & 
    220                   &              + zcof2 * (  zdks (ji,jj+1) + zdk1s(ji,jj)      & 
    221                   &                         + zdk1s(ji,jj+1) + zdks (ji,jj)  )  ) * vmask(ji,jj,jk) 
     287          
     288          
     289         ! I.5 Divergence of vertical fluxes added to the general tracer trend 
     290         ! ------------------------------------------------------------------- 
     291          
     292         DO jk = 1, jpkm1 
     293            DO jj = 2, jpjm1 
     294               DO ji = fs_2, fs_jpim1   ! vector opt. 
     295                  zbtr = 1.0 / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
     296                  ztra = (  ztfw(ji,jj,jk) - ztfw(ji,jj,jk+1)  ) * zbtr 
     297                  ptraa(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn) + ztra 
     298               END DO 
    222299            END DO 
    223300         END DO 
    224  
    225  
    226          ! II.4 Second derivative (divergence) and add to the general trend 
    227          ! ---------------------------------------------------------------- 
    228          DO jj = 2 , jpjm1 
    229             DO ji = fs_2, fs_jpim1   ! vector opt. 
    230                zbtr= 1. / ( e1t(ji,jj)*e2t(ji,jj)*fse3t(ji,jj,jk) ) 
    231 #if defined key_diaar5 
    232                zta = zbtr * ( zftu(ji,jj,jk) - zftu(ji-1,jj,jk) + zftv(ji,jj,jk) - zftv(ji,jj-1,jk)  ) 
    233 #else 
    234                zta = zbtr * ( zftu(ji,jj   ) - zftu(ji-1,jj   ) + zftv(ji,jj,jk) - zftv(ji,jj-1,jk)  ) 
    235 #endif 
    236                zsa = zbtr * ( zfsu(ji,jj   ) - zfsu(ji-1,jj   ) + zfsv(ji,jj,jk) - zfsv(ji,jj-1,jk)  ) 
    237                ta (ji,jj,jk) = ta (ji,jj,jk) + zta 
    238                sa (ji,jj,jk) = sa (ji,jj,jk) + zsa 
    239             END DO 
    240          END DO 
    241          !                                          ! =============== 
    242       END DO                                        !   End of slab   
    243       !                                             ! =============== 
    244  
    245       IF( ln_diaptr .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN   ! Poleward diffusive heat and salt transports 
    246          pht_ldf(:) = ptr_vj( zftv(:,:,:) ) 
    247          pst_ldf(:) = ptr_vj( zfsv(:,:,:) ) 
    248       ENDIF 
    249 #if defined key_diaar5 
    250       zztmp = 0.5 * rau0 * rcp  
    251       z2d(:,:) = 0.e0  
    252       DO jk = 1, jpkm1 
    253          DO jj = 2, jpjm1 
    254             DO ji = fs_2, fs_jpim1   ! vector opt. 
    255                z2d(ji,jj) = z2d(ji,jj) + zztmp * zftu(ji,jj,jk) * ( tn(ji,jj,jk) + tn(ji+1,jj,jk) ) * e1u(ji,jj) * fse3u(ji,jj,jk)  
    256             END DO 
    257          END DO 
    258       END DO 
    259       CALL lbc_lnk( z2d, 'U', -1. ) 
    260       CALL iom_put( "udiff_heattr", z2d )                  ! heat transport in i-direction 
    261       z2d(:,:) = 0.e0  
    262       DO jk = 1, jpkm1 
    263          DO jj = 2, jpjm1 
    264             DO ji = fs_2, fs_jpim1   ! vector opt. 
    265                z2d(ji,jj) = z2d(ji,jj) + zztmp * zftv(ji,jj,jk) * ( tn(ji,jj,jk) + tn(ji,jj+1,jk) ) * e2v(ji,jj) * fse3v(ji,jj,jk)  
    266             END DO 
    267          END DO 
    268       END DO 
    269       CALL lbc_lnk( z2d, 'V', -1. ) 
    270       CALL iom_put( "vdiff_heattr", z2d )                  !  heat transport in i-direction 
    271 #endif 
    272  
    273       !!---------------------------------------------------------------------- 
    274       !!   III - vertical trend of T & S (extra diagonal terms only) 
    275       !!---------------------------------------------------------------------- 
    276  
    277       ! Local constant initialization 
    278       ! ----------------------------- 
    279       ztfw(1,:,:) = 0.e0     ;     ztfw(jpi,:,:) = 0.e0 
    280       zsfw(1,:,:) = 0.e0     ;     zsfw(jpi,:,:) = 0.e0 
    281  
    282  
    283       ! Vertical fluxes 
    284       ! --------------- 
    285  
    286       ! Surface and bottom vertical fluxes set to zero 
    287       ztfw(:,:, 1 ) = 0.e0      ;      ztfw(:,:,jpk) = 0.e0 
    288       zsfw(:,:, 1 ) = 0.e0      ;      zsfw(:,:,jpk) = 0.e0 
    289  
    290       ! interior (2=<jk=<jpk-1) 
    291       DO jk = 2, jpkm1 
    292          DO jj = 2, jpjm1 
    293             DO ji = fs_2, fs_jpim1   ! vector opt. 
    294                zcoef0 = - fsahtw(ji,jj,jk) * tmask(ji,jj,jk) 
    295  
    296                zmsku = 1./MAX(   umask(ji  ,jj,jk-1) + umask(ji-1,jj,jk)      & 
    297                   &            + umask(ji-1,jj,jk-1) + umask(ji  ,jj,jk), 1.  ) 
    298  
    299                zmskv = 1./MAX(   vmask(ji,jj  ,jk-1) + vmask(ji,jj-1,jk)      & 
    300                   &            + vmask(ji,jj-1,jk-1) + vmask(ji,jj  ,jk), 1.  ) 
    301  
    302                zcoef3 = zcoef0 * e2t(ji,jj) * zmsku * wslpi (ji,jj,jk) 
    303                zcoef4 = zcoef0 * e1t(ji,jj) * zmskv * wslpj (ji,jj,jk) 
    304  
    305                ztfw(ji,jj,jk) = zcoef3 * (   zdit(ji  ,jj  ,jk-1) + zdit(ji-1,jj  ,jk)      & 
    306                   &                        + zdit(ji-1,jj  ,jk-1) + zdit(ji  ,jj  ,jk)  )   & 
    307                   &           + zcoef4 * (   zdjt(ji  ,jj  ,jk-1) + zdjt(ji  ,jj-1,jk)      & 
    308                   &                        + zdjt(ji  ,jj-1,jk-1) + zdjt(ji  ,jj  ,jk)  ) 
    309  
    310                zsfw(ji,jj,jk) = zcoef3 * (   zdis(ji  ,jj  ,jk-1) + zdis(ji-1,jj  ,jk)      & 
    311                   &                        + zdis(ji-1,jj  ,jk-1) + zdis(ji  ,jj  ,jk)  )   & 
    312                   &           + zcoef4 * (   zdjs(ji  ,jj  ,jk-1) + zdjs(ji  ,jj-1,jk)      & 
    313                   &                        + zdjs(ji  ,jj-1,jk-1) + zdjs(ji  ,jj  ,jk)  ) 
    314             END DO 
    315          END DO 
    316       END DO 
    317  
    318  
    319       ! I.5 Divergence of vertical fluxes added to the general tracer trend 
    320       ! ------------------------------------------------------------------- 
    321  
    322       DO jk = 1, jpkm1 
    323          DO jj = 2, jpjm1 
    324             DO ji = fs_2, fs_jpim1   ! vector opt. 
    325                zbtr =  1. / ( e1t(ji,jj)*e2t(ji,jj)*fse3t(ji,jj,jk) ) 
    326                zta  = (  ztfw(ji,jj,jk) - ztfw(ji,jj,jk+1)  ) * zbtr 
    327                zsa  = (  zsfw(ji,jj,jk) - zsfw(ji,jj,jk+1)  ) * zbtr 
    328                ta(ji,jj,jk) = ta(ji,jj,jk) + zta 
    329                sa(ji,jj,jk) = sa(ji,jj,jk) + zsa 
    330             END DO 
    331          END DO 
     301         ! 
    332302      END DO 
    333303      ! 

  • branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/traldf_lap.F90

    r1152 r2024  
    22   !!============================================================================== 
    33   !!                       ***  MODULE  traldf_lap  *** 
    4    !! Ocean active tracers:  horizontal component of the lateral tracer mixing trend 
     4   !! Ocean tracers:  horizontal component of the lateral tracer mixing trend 
    55   !!============================================================================== 
    6  
     6   !! History :  OPA  !  87-06  (P. Andrich, D. L Hostis)  Original code 
     7   !!                 !  91-11  (G. Madec) 
     8   !!                 !  95-11  (G. Madec)  suppress volumetric scale factors 
     9   !!                 !  96-01  (G. Madec)  statement function for e3 
     10   !!            NEMO !  02-06  (G. Madec)  F90: Free form and module 
     11   !!            1.0  !  04-08  (C. Talandier) New trends organization 
     12   !!                 !  05-11  (G. Madec)  add zps case 
     13   !!            3.0  !  10-06  (C. Ethe, G. Madec) Merge TRA-TRC 
     14   !!---------------------------------------------------------------------- 
    715   !!---------------------------------------------------------------------- 
    816   !!   tra_ldf_lap  : update the tracer trend with the horizontal diffusion 
    … …  
    1321   USE dom_oce         ! ocean space and time domain 
    1422   USE ldftra_oce      ! ocean active tracers: lateral physics 
    15    USE trdmod          ! ocean active tracers trends  
    16    USE trdmod_oce      ! ocean variables trends 
    1723   USE in_out_manager  ! I/O manager 
    1824   USE diaptr          ! poleward transport diagnostics 
    19    USE prtctl          ! Print control 
    2025 
    2126 
    … …  
    2530   !! * Routine accessibility 
    2631   PUBLIC tra_ldf_lap  ! routine called by step.F90 
     32 
     33   REAL(wp), DIMENSION(jpi,jpj) ::   e1ur, e2vr   ! scale factor coefficients 
    2734 
    2835   !! * Substitutions 
    … …  
    3845CONTAINS 
    3946 
    40    SUBROUTINE tra_ldf_lap( kt ) 
     47   SUBROUTINE tra_ldf_lap( kt   , cdtype, pgtu, pgtv,  & 
     48      &                    ptrab, ptraa , kjpt         )  
    4149      !!---------------------------------------------------------------------- 
    4250      !!                  ***  ROUTINE tra_ldf_lap  *** 
    … …  
    4755      !! ** Method  :   Second order diffusive operator evaluated using before 
    4856      !!      fields (forward time scheme). The horizontal diffusive trends of  
    49       !!      temperature (idem for salinity) is given by: 
     57      !!      the tracer is given by: 
    5058      !!          difft = 1/(e1t*e2t*e3t) {  di-1[ aht e2u*e3u/e1u di(tb) ] 
    5159      !!                                   + dj-1[ aht e1v*e3v/e2v dj(tb) ] } 
    … …  
    5361      !!          difft = 1/(e1t*e2t) {  di-1[ aht e2u/e1u di(tb) ] 
    5462      !!                               + dj-1[ aht e1v/e2v dj(tb) ] } 
    55       !!      Add this trend to the general tracer trend (ta,sa): 
    56       !!          (ta,sa) = (ta,sa) + ( difft , diffs ) 
     63      !!      Add this trend to the general tracer trend pta : 
     64      !!          pta = pta + difft 
    5765      !! 
    58       !! ** Action  : - Update (ta,sa) arrays with the before iso-level  
     66      !! ** Action  : - Update pta arrays with the before iso-level  
    5967      !!                harmonic mixing trend. 
    60       !! 
    61       !! History : 
    62       !!   1.0  !  87-06  (P. Andrich, D. L Hostis)  Original code 
    63       !!        !  91-11  (G. Madec) 
    64       !!        !  95-11  (G. Madec)  suppress volumetric scale factors 
    65       !!        !  96-01  (G. Madec)  statement function for e3 
    66       !!   8.5  !  02-06  (G. Madec)  F90: Free form and module 
    67       !!   9.0  !  04-08  (C. Talandier) New trends organization 
    68       !!        !  05-11  (G. Madec)  add zps case 
    6968      !!---------------------------------------------------------------------- 
    70       USE oce              , ztu => ua,  &  ! use ua as workspace 
    71          &                   zsu => va      ! use va as workspace 
    72  
    73       !! * Arguments 
    74       INTEGER, INTENT( in ) ::   kt       ! ocean time-step index 
    75        
    76       !! * Local save 
    77       REAL(wp), DIMENSION(jpi,jpj), SAVE ::   & 
    78          ze1ur, ze2vr, zbtr2              ! scale factor coefficients 
    79        
    80       !! * Local declarations 
    81       INTEGER ::   ji, jj, jk             ! dummy loop indices 
    82       INTEGER ::   iku, ikv               ! temporary integers 
     69      !!* Module used 
     70      USE oce         , ztu => ua   ! use ua as workspace 
     71      USE oce         , ztv => va   ! use va as workspace 
     72      !!* Arguments 
     73      INTEGER         , INTENT(in   )                                ::   kt             ! ocean time-step index 
     74      CHARACTER(len=3), INTENT(in   )                                ::   cdtype         ! =TRA or TRC (tracer indicator) 
     75      INTEGER         , INTENT(in   )                                ::   kjpt            ! number of tracers 
     76      REAL(wp)        , INTENT(in   ), DIMENSION(jpi,jpj,kjpt  )     ::   pgtu, pgtv     ! tracer gradient at pstep levels 
     77      REAL(wp)        , INTENT(in   ), DIMENSION(jpi,jpj,jpk,kjpt)   ::   ptrab          ! before and now tracer fields 
     78      REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)   ::   ptraa          ! tracer trend  
     79      !!* Local declarations 
     80      INTEGER ::   ji, jj, jk, jn          ! dummy loop indices 
     81      INTEGER ::   iku, ikv                ! temporary integers 
    8382      REAL(wp) ::   & 
    84          zabe1, zta,                   &  ! temporary scalars 
    85          zabe2, zsa, zbtr                 !    "         " 
    86       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   & 
    87          ztv, zsv                         ! 3D workspace 
     83         zabe1, zabe2, ztra, zbtr           ! temporary scalars 
    8884      !!---------------------------------------------------------------------- 
    8985       
    … …  
    9288         IF(lwp) WRITE(numout,*) 'tra_ldf_lap : iso-level laplacian diffusion' 
    9389         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ ' 
    94          ze1ur(:,:) = e2u(:,:) / e1u(:,:) 
    95          ze2vr(:,:) = e1v(:,:) / e2v(:,:) 
    96          zbtr2(:,:) = 1. / ( e1t(:,:) * e2t(:,:) ) 
     90         e1ur(:,:) = e2u(:,:) / e1u(:,:) 
     91         e2vr(:,:) = e1v(:,:) / e2v(:,:) 
    9792      ENDIF 
    98        
    99       !                                                  ! ============= 
    100       DO jk = 1, jpkm1                                   ! Vertical slab 
    101          !                                               ! ============= 
    102          ! 1. First derivative (gradient) 
    103          ! ------------------- 
    104          DO jj = 1, jpjm1 
    105             DO ji = 1, fs_jpim1   ! vector opt. 
    106 #if defined key_zco 
    107                zabe1 = fsahtu(ji,jj,jk) * umask(ji,jj,jk) * ze1ur(ji,jj) 
    108                zabe2 = fsahtv(ji,jj,jk) * vmask(ji,jj,jk) * ze2vr(ji,jj) 
    109 #else 
    110                zabe1 = fsahtu(ji,jj,jk) * umask(ji,jj,jk) * ze1ur(ji,jj) * fse3u(ji,jj,jk) 
    111                zabe2 = fsahtv(ji,jj,jk) * vmask(ji,jj,jk) * ze2vr(ji,jj) * fse3v(ji,jj,jk) 
    112 #endif 
    113                ztu(ji,jj,jk) = zabe1 * ( tb(ji+1,jj  ,jk) - tb(ji,jj,jk) ) 
    114                zsu(ji,jj,jk) = zabe1 * ( sb(ji+1,jj  ,jk) - sb(ji,jj,jk) ) 
    115                ztv(ji,jj,jk) = zabe2 * ( tb(ji  ,jj+1,jk) - tb(ji,jj,jk) ) 
    116                zsv(ji,jj,jk) = zabe2 * ( sb(ji  ,jj+1,jk) - sb(ji,jj,jk) ) 
    117             END DO   
    118          END DO   
    119          IF( ln_zps ) THEN      ! set gradient at partial step level 
     93 
     94      ! 
     95      DO jn = 1, kjpt                                            ! tracer loop 
     96         !                                                       ! ===========       
     97         !                                                  
     98         DO jk = 1, jpkm1                                 
     99            !                                            
     100            ! 1. First derivative (gradient) 
     101            ! ------------------- 
    120102            DO jj = 1, jpjm1 
    121103               DO ji = 1, fs_jpim1   ! vector opt. 
    122                   ! last level 
    123                   iku = MIN ( mbathy(ji,jj), mbathy(ji+1,jj  ) ) - 1 
    124                   ikv = MIN ( mbathy(ji,jj), mbathy(ji  ,jj+1) ) - 1 
    125                   IF( iku == jk ) THEN 
    126                      zabe1 = fsahtu(ji,jj,iku) * umask(ji,jj,iku) * ze1ur(ji,jj) * fse3u(ji,jj,iku) 
    127                      ztu(ji,jj,jk) = zabe1 * gtu(ji,jj) 
    128                      zsu(ji,jj,jk) = zabe1 * gsu(ji,jj) 
    129                   ENDIF 
    130                   IF( ikv == jk ) THEN 
    131                      zabe2 = fsahtv(ji,jj,ikv) * vmask(ji,jj,ikv) * ze2vr(ji,jj) * fse3v(ji,jj,ikv) 
    132                      ztv(ji,jj,jk) = zabe2 * gtv(ji,jj) 
    133                      zsv(ji,jj,jk) = zabe2 * gsv(ji,jj) 
    134                   ENDIF 
     104                  zabe1 = fsahtu(ji,jj,jk) * umask(ji,jj,jk) * e1ur(ji,jj) * fse3u(ji,jj,jk) 
     105                  zabe2 = fsahtv(ji,jj,jk) * vmask(ji,jj,jk) * e2vr(ji,jj) * fse3v(ji,jj,jk) 
     106                  ztu(ji,jj,jk) = zabe1 * ( ptrab(ji+1,jj  ,jk,jn) - ptrab(ji,jj,jk,jn) ) 
     107                  ztv(ji,jj,jk) = zabe2 * ( ptrab(ji  ,jj+1,jk,jn) - ptrab(ji,jj,jk,jn) ) 
    135108               END DO 
    136109            END DO 
    137          ENDIF 
     110            IF( ln_zps ) THEN      ! set gradient at partial step level 
     111               DO jj = 1, jpjm1 
     112                  DO ji = 1, fs_jpim1   ! vector opt. 
     113                     ! last level 
     114                     iku = MIN ( mbathy(ji,jj), mbathy(ji+1,jj  ) ) - 1 
     115                     ikv = MIN ( mbathy(ji,jj), mbathy(ji  ,jj+1) ) - 1 
     116                     IF( iku == jk ) THEN 
     117                        zabe1 = fsahtu(ji,jj,iku) * umask(ji,jj,iku) * e1ur(ji,jj) * fse3u(ji,jj,iku) 
     118                        ztu(ji,jj,jk) = zabe1 * pgtu(ji,jj,jn) 
     119                     ENDIF 
     120                     IF( ikv == jk ) THEN 
     121                        zabe2 = fsahtv(ji,jj,ikv) * vmask(ji,jj,ikv) * e2vr(ji,jj) * fse3v(ji,jj,ikv) 
     122                        ztv(ji,jj,jk) = zabe2 * pgtv(ji,jj,jn) 
     123                     ENDIF 
     124                  END DO 
     125               END DO 
     126            ENDIF 
    138127          
    139128          
    140          ! 2. Second derivative (divergence) 
    141          ! -------------------- 
    142          DO jj = 2, jpjm1 
    143             DO ji = fs_2, fs_jpim1   ! vector opt. 
    144 #if defined key_zco 
    145                zbtr = zbtr2(ji,jj) 
    146 #else 
    147                zbtr = zbtr2(ji,jj) / fse3t(ji,jj,jk) 
    148 #endif 
    149                ! horizontal diffusive trends 
    150                zta = zbtr * (  ztu(ji,jj,jk) - ztu(ji-1,jj,jk)   & 
    151                   &          + ztv(ji,jj,jk) - ztv(ji,jj-1,jk)  ) 
    152                zsa = zbtr * (  zsu(ji,jj,jk) - zsu(ji-1,jj,jk)   & 
    153                   &          + zsv(ji,jj,jk) - zsv(ji,jj-1,jk)  ) 
    154                ! add it to the general tracer trends 
    155                ta(ji,jj,jk) = ta(ji,jj,jk) + zta 
    156                sa(ji,jj,jk) = sa(ji,jj,jk) + zsa 
    157             END DO   
    158          END DO   
    159          !                                               ! ============= 
    160       END DO                                             !  End of slab   
    161       !                                                  ! ============= 
    162  
    163       ! "zonal" mean lateral diffusive heat and salt transport  
    164       IF( ln_diaptr .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN 
    165          IF( lk_zco ) THEN   ! z-coordinate - full step (1D arrays) 
    166             DO jk = 1, jpkm1 
    167                DO jj = 2, jpjm1 
    168                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    169                     ztv(ji,jj,jk) = ztv(ji,jj,jk) * fse3v(ji,jj,jk) 
    170                     zsv(ji,jj,jk) = zsv(ji,jj,jk) * fse3v(ji,jj,jk) 
    171                   END DO 
     129            ! 2. Second derivative (divergence) added to the general tracer trends 
     130            ! --------------------------------------------------------------------- 
     131            DO jj = 2, jpjm1 
     132               DO ji = fs_2, fs_jpim1   ! vector opt. 
     133                  zbtr = 1.0 / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
     134                  ! horizontal diffusive trends 
     135                  ztra = zbtr * (  ztu(ji,jj,jk) - ztu(ji-1,jj,jk)   & 
     136                     &           + ztv(ji,jj,jk) - ztv(ji,jj-1,jk)  ) 
     137                  ! add it to the general tracer trends 
     138                  ptraa(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn) + ztra 
    172139               END DO 
    173140            END DO 
     141            !                                               ! ============= 
     142         END DO                                             !  End of slab   
     143         !                                                  ! ============= 
     144         ! "Poleward" diffusive heat or salt transports 
     145         IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN 
     146            IF( jn  == jp_tem)   pht_ldf(:) = ptr_vj( ztv(:,:,:) ) 
     147            IF( jn  == jp_sal)   pst_ldf(:) = ptr_vj( ztv(:,:,:) ) 
    174148         ENDIF 
    175          pht_ldf(:) = ptr_vj( ztv(:,:,:) ) 
    176          pst_ldf(:) = ptr_vj( zsv(:,:,:) ) 
    177       ENDIF 
    178  
     149         ! 
     150      END DO 
     151      ! 
    179152   END SUBROUTINE tra_ldf_lap 
    180153 

  • branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/tranpc.F90

    r1537 r2024  
    1616   USE dom_oce         ! ocean space and time domain 
    1717   USE zdf_oce         ! ocean vertical physics 
    18    USE trdmod          ! ocean active tracer trends 
    19    USE trdmod_oce      ! ocean variables trends 
     18   USE trdmod_oce      ! ocean active tracer trends 
     19   USE trdtra      ! ocean active tracer trends 
    2020   USE eosbn2          ! equation of state (eos routine)  
    2121   USE lbclnk          ! lateral boundary conditions (or mpp link) 
    … …  
    5555      !! References : Madec, et al., 1991, JPO, 21, 9, 1349-1371. 
    5656      !!---------------------------------------------------------------------- 
    57       USE oce, ONLY :    ztrdt => ua   ! use ua as 3D workspace    
    58       USE oce, ONLY :    ztrds => va   ! use va as 3D workspace    
    5957      !!  
    6058      INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
    … …  
    6866      REAL(wp), DIMENSION(jpi,jpk)     ::   zwx, zwy, zwz   ! 2D arrays 
    6967      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zrhop           ! 3D arrays 
     68      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  ztrdt, ztrds 
    7069      !!---------------------------------------------------------------------- 
    7170 
    … …  
    7574         inpci = 0 
    7675 
    77          CALL eos( ta, sa, rhd, zrhop )         ! Potential density 
    78  
    79  
    80          IF( l_trdtra )   THEN                  ! Save ta and sa trends 
    81             ztrdt(:,:,:) = ta(:,:,:)  
    82             ztrds(:,:,:) = sa(:,:,:)  
     76         CALL eos( tsa(:,:,:,jp_tem), tsa(:,:,:,jp_sal), rhd, zrhop )         ! Potential density 
     77 
     78         IF( l_trdtra )   THEN                    !* Save ta and sa trends 
     79            ALLOCATE( ztrdt(jpi,jpj,jpk) )  ;    ztrdt(:,:,:) = tsa(:,:,:,jp_tem)  
     80            ALLOCATE( ztrds(jpi,jpj,jpk) )  ;    ztrds(:,:,:) = tsa(:,:,:,jp_sal) 
    8381         ENDIF 
    8482 
    … …  
    151149                        ! 
    152150                        ze3tot= fse3t(ji,jj,ikup) 
    153                         zta   = ta   (ji,jj,ikup) 
    154                         zsa   = sa   (ji,jj,ikup) 
     151                        zta   = tsa  (ji,jj,ikup,jp_tem) 
     152                        zsa   = tsa  (ji,jj,ikup,jp_sal) 
    155153                        zraua = zrhop(ji,jj,ikup) 
    156154                        ! 
    … …  
    162160                           ze3dwn =  fse3t(ji,jj,jkdown) 
    163161                           ze3tot =  ze3tot + ze3dwn 
    164                            zta   = ( zta*(ze3tot-ze3dwn) + ta(ji,jj,jkdown)*ze3dwn )/ze3tot 
    165                            zsa   = ( zsa*(ze3tot-ze3dwn) + sa(ji,jj,jkdown)*ze3dwn )/ze3tot 
     162                           zta   = ( zta*(ze3tot-ze3dwn) + tsa(ji,jj,jkdown,jp_tem)*ze3dwn )/ze3tot 
     163                           zsa   = ( zsa*(ze3tot-ze3dwn) + tsa(ji,jj,jkdown,jp_sal)*ze3dwn )/ze3tot 
    166164                           zraua = ( zraua*(ze3tot-ze3dwn) + zrhop(ji,jj,jkdown)*ze3dwn )/ze3tot 
    167165                           inpci = inpci+1 
    … …  
    171169                        ! 
    172170                        DO jkp = ikup, ikdown-1 
    173                            ta(ji,jj,jkp) = zta 
    174                            sa(ji,jj,jkp) = zsa 
    175                            zrhop(ji,jj,jkp) = zraua 
     171                           tsa  (ji,jj,jkp,jp_tem) = zta 
     172                           tsa  (ji,jj,jkp,jp_sal) = zsa 
     173                           zrhop(ji,jj,jkp       ) = zraua 
    176174                        END DO 
    177175                        IF (ikdown == ikbot-1 .AND. zraua >= zrhop(ji,jj,ikdown) ) THEN 
    178                            ta(ji,jj,ikdown) = zta 
    179                            sa(ji,jj,ikdown) = zsa 
    180                            zrhop(ji,jj,ikdown) = zraua 
     176                           tsa  (ji,jj,jkp,jp_tem) = zta 
     177                           tsa  (ji,jj,jkp,jp_sal) = zsa 
     178                           zrhop(ji,jj,ikdown    ) = zraua 
    181179                        ENDIF 
    182180                     END DO 
    … …  
    191189         !  
    192190         IF( l_trdtra )   THEN         ! save the Non penetrative mixing trends for diagnostic 
    193             ztrdt(:,:,:) = ta(:,:,:) - ztrdt(:,:,:) 
    194             ztrds(:,:,:) = sa(:,:,:) - ztrds(:,:,:) 
    195             CALL trd_mod(ztrdt, ztrds, jptra_trd_npc, 'TRA', kt) 
     191            ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 
     192            ztrds(:,:,:) = tsa(:,:,:,jp_sal) - ztrds(:,:,:) 
     193            CALL trd_tra( kt, 'TRA', jp_tem, jptra_trd_npc, ztrdt ) 
     194            CALL trd_tra( kt, 'TRA', jp_sal, jptra_trd_npc, ztrds ) 
     195            DEALLOCATE( ztrdt )      ;     DEALLOCATE( ztrds )  
    196196         ENDIF 
    197197       
    198198         ! Lateral boundary conditions on ( ta, sa )   ( Unchanged sign) 
    199199         ! ------------------------------============ 
    200          CALL lbc_lnk( ta, 'T', 1. ) 
    201          CALL lbc_lnk( sa, 'T', 1. ) 
     200         CALL lbc_lnk( tsa(:,:,:,jp_tem), 'T', 1. ) 
     201         CALL lbc_lnk( tsa(:,:,:,jp_sal), 'T', 1. ) 
    202202       
    203203 

  • branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/tranxt.F90

    r1970 r2024  
    2828   USE dynspg_oce      ! surface     pressure gradient variables 
    2929   USE dynhpg          ! hydrostatic pressure gradient  
    30    USE trdmod_oce      ! ocean variables trends 
    31    USE trdmod          ! ocean active tracers trends  
     30   USE trdmod_oce      ! ocean space and time domain variables  
     31   USE trdtra          ! ocean active tracers trends  
    3232   USE phycst 
    3333   USE obctra          ! open boundary condition (obc_tra routine) 
    … …  
    3636   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    3737   USE prtctl          ! Print control 
     38   USE traswp          ! swap array 
    3839   USE agrif_opa_update 
    3940   USE agrif_opa_interp 
    40    USE obc_oce  
     41   USE obc_oce 
    4142 
    4243   IMPLICIT NONE 
    4344   PRIVATE 
    4445 
    45    PUBLIC   tra_nxt    ! routine called by step.F90 
     46   PUBLIC   tra_nxt       ! routine called by step.F90 
     47   PUBLIC   tra_nxt_fix   ! to be used in trcnxt 
     48   PUBLIC   tra_nxt_vvl   ! to be used in trcnxt 
    4649 
    4750   REAL(wp), DIMENSION(jpk) ::   r2dt_t   ! vertical profile time step, =2*rdttra (leapfrog) or =rdttra (Euler) 
    … …  
    8184      !!              - (ta,sa) time averaged (t,s)   (ln_dynhpg_imp = T) 
    8285      !!---------------------------------------------------------------------- 
    83       USE oce, ONLY :    ztrdt => ua   ! use ua as 3D workspace    
    84       USE oce, ONLY :    ztrds => va   ! use va as 3D workspace    
    85       !! 
    8686      INTEGER, INTENT(in) ::   kt    ! ocean time-step index 
    8787      !! 
    8888      INTEGER  ::   jk    ! dummy loop indices 
    8989      REAL(wp) ::   zfact ! temporary scalars 
     90      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  ztrdt, ztrds 
     91 
    9092      !!---------------------------------------------------------------------- 
    9193 
    … …  
    98100      ! Update after tracer on domain lateral boundaries 
    99101      !  
    100       CALL lbc_lnk( ta, 'T', 1. )      ! local domain boundaries  (T-point, unchanged sign) 
    101       CALL lbc_lnk( sa, 'T', 1. ) 
    102       ! 
     102      CALL lbc_lnk( tsa(:,:,:,jp_tem), 'T', 1. )      ! local domain boundaries  (T-point, unchanged sign) 
     103      CALL lbc_lnk( tsa(:,:,:,jp_sal), 'T', 1. ) 
     104      ! 
     105#if defined key_obc || defined key_bdy || defined key_agrif 
     106      CALL tra_unswap 
     107#endif 
    103108#if defined key_obc 
    104109      IF( lk_obc )   CALL obc_tra( kt )  ! OBC open boundaries 
    … …  
    110115      CALL Agrif_tra                   ! AGRIF zoom boundaries 
    111116#endif 
     117#if defined key_obc || defined key_bdy || defined key_agrif 
     118      CALL tra_swap 
     119#endif 
    112120  
    113121      ! set time step size (Euler/Leapfrog) 
    … …  
    117125 
    118126      ! trends computation initialisation 
    119       IF( l_trdtra ) THEN              ! store now fields before applying the Asselin filter 
    120          ztrdt(:,:,:) = tn(:,:,:)       
    121          ztrds(:,:,:) = sn(:,:,:) 
     127      IF( l_trdtra )   THEN                    !* store now fields before applying the Asselin filter 
     128         ALLOCATE( ztrdt(jpi,jpj,jpk) )   ;    ztrdt(:,:,:) = tsn(:,:,:,jp_tem)  
     129         ALLOCATE( ztrds(jpi,jpj,jpk) )   ;    ztrds(:,:,:) = tsn(:,:,:,jp_sal) 
    122130      ENDIF 
    123131 
    124132      ! Leap-Frog + Asselin filter time stepping 
    125       IF( lk_vvl )   THEN   ;   CALL tra_nxt_vvl( kt )      ! variable volume level (vvl) 
    126       ELSE                  ;   CALL tra_nxt_fix( kt )      ! fixed    volume level 
     133      IF( lk_vvl )   THEN   ;   CALL tra_nxt_vvl( kt , nit000,           & 
     134                                &                 tsb, tsn   , tsa, jpts )      ! variable volume level (vvl) 
     135      ELSE                  ;   CALL tra_nxt_fix( kt , nit000,           & 
     136                                &                 tsb, tsn   , tsa, jpts )      ! fixed    volume level 
    127137      ENDIF 
    128138 
    129139#if defined key_agrif 
     140      CALL tra_unswap 
    130141      ! Update tracer at AGRIF zoom boundaries 
    131142      IF( .NOT.Agrif_Root() )    CALL Agrif_Update_Tra( kt )      ! children only 
     143      CALL tra_swap 
    132144#endif       
    133145 
    … …  
    136148         DO jk = 1, jpkm1 
    137149            zfact = 1.e0 / r2dt_t(jk)              
    138             ztrdt(:,:,jk) = ( tb(:,:,jk) - ztrdt(:,:,jk) ) * zfact 
    139             ztrds(:,:,jk) = ( sb(:,:,jk) - ztrds(:,:,jk) ) * zfact 
     150            ztrdt(:,:,jk) = ( tsb(:,:,jk,jp_tem) - ztrdt(:,:,jk) ) * zfact 
     151            ztrds(:,:,jk) = ( tsb(:,:,jk,jp_sal) - ztrds(:,:,jk) ) * zfact 
    140152         END DO 
    141          CALL trd_mod( ztrdt, ztrds, jptra_trd_atf, 'TRA', kt ) 
     153         CALL trd_tra( kt, 'TRA', jp_tem, jptra_trd_atf, ztrdt ) 
     154         CALL trd_tra( kt, 'TRA', jp_sal, jptra_trd_atf, ztrds ) 
     155         DEALLOCATE( ztrdt )      ;     DEALLOCATE( ztrds )  
    142156      END IF 
    143157 
    144158      !                        ! control print 
    145       IF(ln_ctl)   CALL prt_ctl( tab3d_1=tn, clinfo1=' nxt  - Tn: ', mask1=tmask,   & 
    146          &                       tab3d_2=sn, clinfo2=       ' Sn: ', mask2=tmask ) 
     159      IF(ln_ctl)   CALL prt_ctl( tab3d_1=tsn(:,:,:,jp_tem), clinfo1=' nxt  - Tn: ', mask1=tmask,   & 
     160         &                       tab3d_2=tsn(:,:,:,jp_sal), clinfo2=       ' Sn: ', mask2=tmask ) 
    147161      ! 
    148162   END SUBROUTINE tra_nxt 
    149163 
    150  
    151    SUBROUTINE tra_nxt_fix( kt ) 
     164   SUBROUTINE tra_nxt_fix( kt   , kit000,              & 
     165      &                    ptrab, ptran , ptraa, kjpt ) 
    152166      !!---------------------------------------------------------------------- 
    153167      !!                   ***  ROUTINE tra_nxt_fix  *** 
    … …  
    171185      !!              - (ta,sa) time averaged (t,s)   (ln_dynhpg_imp = T) 
    172186      !!---------------------------------------------------------------------- 
    173       INTEGER, INTENT(in) ::   kt    ! ocean time-step index 
    174       !! 
    175       INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    176       REAL(wp) ::   ztm, ztf     ! temporary scalars 
    177       REAL(wp) ::   zsm, zsf     !    -         - 
    178       !!---------------------------------------------------------------------- 
    179  
    180       IF( kt == nit000 ) THEN 
     187      INTEGER , INTENT(in   )                               ::  kt            ! ocean time-step index 
     188      INTEGER , INTENT(in   )                               ::  kit000        ! first time-step index 
     189      INTEGER , INTENT(in   )                               ::  kjpt            ! number of tracers 
     190      REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::  ptrab  ! before tracer fields 
     191      REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::  ptran  ! now tracer fields 
     192      REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::  ptraa         ! tracer trend 
     193      !! 
     194      INTEGER  :: ji, jj, jk, jn   ! dummy loop indices 
     195      REAL(wp) :: ztm, ztf     ! temporary scalars 
     196      !!---------------------------------------------------------------------- 
     197 
     198      IF( kt == kit000 ) THEN 
    181199         IF(lwp) WRITE(numout,*) 
    182200         IF(lwp) WRITE(numout,*) 'tra_nxt_fix : time stepping' 
    … …  
    188206         !                                           ! ----------------------- ! 
    189207         ! 
    190          IF( neuler == 0 .AND. kt == nit000 ) THEN        ! Euler time-stepping at first time-step 
    191             DO jk = 1, jpkm1                              ! (only swap) 
    192                DO jj = 1, jpj 
    193                   DO ji = 1, jpi 
    194                      tn(ji,jj,jk) = ta(ji,jj,jk)                                           ! tb <-- tn 
    195                      sn(ji,jj,jk) = sa(ji,jj,jk) 
     208         IF( neuler == 0 .AND. kt == kit000 ) THEN        ! Euler time-stepping at first time-step 
     209            !                                             ! (only swap) 
     210            DO jn = 1, kjpt 
     211               DO jk = 1, jpkm1                               
     212                  DO jj = 1, jpj 
     213                     DO ji = 1, jpi 
     214                        ptran(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn)     ! ptrab <-- ptran 
     215                     END DO 
    196216                  END DO 
    197217               END DO 
    198218            END DO 
    199219         ELSE                                             ! general case (Leapfrog + Asselin filter 
    200             DO jk = 1, jpkm1 
    201                DO jj = 1, jpj 
    202                   DO ji = 1, jpi 
    203                      ztm = 0.25 * ( ta(ji,jj,jk) + 2.* tn(ji,jj,jk) + tb(ji,jj,jk) )       ! mean t 
    204                      zsm = 0.25 * ( sa(ji,jj,jk) + 2.* sn(ji,jj,jk) + sb(ji,jj,jk) ) 
    205                      ztf = atfp * ( ta(ji,jj,jk) - 2.* tn(ji,jj,jk) + tb(ji,jj,jk) )       ! Asselin filter on t  
    206                      zsf = atfp * ( sa(ji,jj,jk) - 2.* sn(ji,jj,jk) + sb(ji,jj,jk) ) 
    207                      tb(ji,jj,jk) = tn(ji,jj,jk) + ztf                                     ! tb <-- filtered tn  
    208                      sb(ji,jj,jk) = sn(ji,jj,jk) + zsf 
    209                      tn(ji,jj,jk) = ta(ji,jj,jk)                                           ! tn <-- ta 
    210                      sn(ji,jj,jk) = sa(ji,jj,jk) 
    211                      ta(ji,jj,jk) = ztm                                                    ! ta <-- mean t 
    212                      sa(ji,jj,jk) = zsm 
     220            DO jn = 1, kjpt 
     221               DO jk = 1, jpkm1 
     222                  DO jj = 1, jpj 
     223                     DO ji = 1, jpi 
     224                        ztm = 0.25 * ( ptraa(ji,jj,jk,jn) + 2.* ptran(ji,jj,jk,jn) + ptrab(ji,jj,jk,jn) )  ! mean ptra 
     225                        ztf = atfp * ( ptraa(ji,jj,jk,jn) - 2.* ptran(ji,jj,jk,jn) + ptran(ji,jj,jk,jn) )  ! Asselin filter on ptra  
     226                        ptrab(ji,jj,jk,jn) = ptran(ji,jj,jk,jn) + ztf                                      ! ptrab <-- filtered ptran  
     227                        ptran(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn)                                            ! ptran <-- ptraa 
     228                        ptraa(ji,jj,jk,jn) = ztm                                                           ! ptraa <-- mean ptra 
     229                     END DO 
    213230                  END DO 
    214231               END DO 
    … …  
    219236         !                                           ! ----------------------- ! 
    220237         ! 
    221          IF( neuler == 0 .AND. kt == nit000 ) THEN        ! Euler time-stepping at first time-step 
    222             DO jk = 1, jpkm1 
    223                DO jj = 1, jpj 
    224                   DO ji = 1, jpi 
    225                      tn(ji,jj,jk) = ta(ji,jj,jk)                                           ! tn <-- ta 
    226                      sn(ji,jj,jk) = sa(ji,jj,jk) 
     238         IF( neuler == 0 .AND. kt == kit000 ) THEN        ! Euler time-stepping at first time-step 
     239            DO jn = 1, kjpt 
     240               DO jk = 1, jpkm1 
     241                  DO jj = 1, jpj 
     242                     DO ji = 1, jpi 
     243                        ptran(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn)                                             ! ptran <-- ptraa 
     244                     END DO 
    227245                  END DO 
    228246               END DO 
    229247            END DO 
    230248         ELSE                                             ! general case (Leapfrog + Asselin filter 
    231             DO jk = 1, jpkm1 
    232                DO jj = 1, jpj 
    233                   DO ji = 1, jpi 
    234                      ztf = atfp * ( ta(ji,jj,jk) - 2.* tn(ji,jj,jk) + tb(ji,jj,jk) )       ! Asselin filter on t  
    235                      zsf = atfp * ( sa(ji,jj,jk) - 2.* sn(ji,jj,jk) + sb(ji,jj,jk) ) 
    236                      tb(ji,jj,jk) = tn(ji,jj,jk) + ztf                                     ! tb <-- filtered tn  
    237                      sb(ji,jj,jk) = sn(ji,jj,jk) + zsf 
    238                      tn(ji,jj,jk) = ta(ji,jj,jk)                                           ! tn <-- ta 
    239                      sn(ji,jj,jk) = sa(ji,jj,jk) 
     249            DO jn = 1, kjpt 
     250               DO jk = 1, jpkm1 
     251                  DO jj = 1, jpj 
     252                     DO ji = 1, jpi 
     253                        ztf = atfp * ( ptraa(ji,jj,jk,jn) - 2.* ptran(ji,jj,jk,jn) + ptrab(ji,jj,jk,jn) )       ! Asselin filter on t  
     254                        ptrab(ji,jj,jk,jn) = ptran(ji,jj,jk,jn) + ztf                                     ! ptrab <-- filtered ptran  
     255                        ptran(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn)                                           ! ptran <-- ptraa 
     256                     END DO 
    240257                  END DO 
    241258               END DO 
    242259            END DO 
    243260         ENDIF 
     261         ! 
    244262      ENDIF 
    245263      ! 
    … …  
    247265 
    248266 
    249    SUBROUTINE tra_nxt_vvl( kt ) 
     267   SUBROUTINE tra_nxt_vvl( kt   , kit000,              & 
     268      &                    ptrab, ptran , ptraa, kjpt  ) 
    250269      !!---------------------------------------------------------------------- 
    251270      !!                   ***  ROUTINE tra_nxt_vvl  *** 
    … …  
    271290      !!              - (ta,sa) time averaged (t,s)   (ln_dynhpg_imp = T) 
    272291      !!---------------------------------------------------------------------- 
    273       INTEGER, INTENT(in) ::   kt    ! ocean time-step index 
     292      INTEGER , INTENT(in   )                               ::  kt            ! ocean time-step index 
     293      INTEGER , INTENT(in   )                               ::  kit000        ! first time-step index 
     294      INTEGER , INTENT(in   )                               ::  kjpt            ! number of tracers 
     295      REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::  ptrab  ! before tracer fields 
     296      REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::  ptran  ! now tracer fields 
     297      REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::  ptraa         ! tracer trend 
    274298      !!      
    275       INTEGER  ::   ji, jj, jk             ! dummy loop indices 
     299      INTEGER  ::   ji, jj, jk, jn             ! dummy loop indices 
    276300      REAL(wp) ::   ztm , ztc_f , ztf , ztca, ztcn, ztcb   ! temporary scalar 
    277       REAL(wp) ::   zsm , zsc_f , zsf , zsca, zscn, zscb   !    -         - 
    278301      REAL(wp) ::   ze3mr, ze3fr                           !    -         - 
    279302      REAL(wp) ::   ze3t_b, ze3t_n, ze3t_a, ze3t_f         !    -         - 
    280303      !!---------------------------------------------------------------------- 
    281304 
    282       IF( kt == nit000 ) THEN 
     305      IF( kt == kit000 ) THEN 
    283306         IF(lwp) WRITE(numout,*) 
    284307         IF(lwp) WRITE(numout,*) 'tra_nxt_vvl : time stepping' 
    285308         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 
    286309      ENDIF 
    287  
     310      ! 
    288311      !                                              ! ----------------------- ! 
    289312      IF( ln_dynhpg_imp ) THEN                       ! semi-implicite hpg case ! 
    290313         !                                           ! ----------------------- ! 
    291314         ! 
    292          IF( neuler == 0 .AND. kt == nit000 ) THEN        ! Euler time-stepping at first time-step 
    293             DO jk = 1, jpkm1                              ! (only swap) 
    294                DO jj = 1, jpj 
    295                   DO ji = 1, jpi 
    296                      tn(ji,jj,jk) = ta(ji,jj,jk)                    ! tn <-- ta 
    297                      sn(ji,jj,jk) = sa(ji,jj,jk) 
     315         IF( neuler == 0 .AND. kt == kit000 ) THEN        ! Euler time-stepping at first time-step 
     316            DO jn = 1, kjpt                               ! (only swap) 
     317               DO jk = 1, jpkm1                               
     318                  DO jj = 1, jpj 
     319                     DO ji = 1, jpi 
     320                        ptran(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn)                    ! tn <-- ta 
     321                     END DO 
    298322                  END DO 
    299323               END DO 
    300324            END DO 
    301325         ELSE 
    302             DO jk = 1, jpkm1 
    303                DO jj = 1, jpj 
    304                   DO ji = 1, jpi 
    305                      ze3t_b = fse3t_b(ji,jj,jk) 
    306                      ze3t_n = fse3t_n(ji,jj,jk) 
    307                      ze3t_a = fse3t_a(ji,jj,jk) 
    308                      !                                         ! tracer content at Before, now and after 
    309                      ztcb = tb(ji,jj,jk) *  ze3t_b   ;   zscb = sb(ji,jj,jk) * ze3t_b 
    310                      ztcn = tn(ji,jj,jk) *  ze3t_n   ;   zscn = sn(ji,jj,jk) * ze3t_n 
    311                      ztca = ta(ji,jj,jk) *  ze3t_a   ;   zsca = sa(ji,jj,jk) * ze3t_a 
    312                      ! 
    313                      !                                         ! Asselin filter on thickness and tracer content 
    314                      ze3t_f = atfp * ( ze3t_a - 2.* ze3t_n + ze3t_b ) 
    315                      ztc_f  = atfp * ( ztca   - 2.* ztcn   + ztcb   )  
    316                      zsc_f  = atfp * ( zsca   - 2.* zscn   + zscb   )  
    317                      ! 
    318                      !                                         ! filtered tracer including the correction  
    319                      ze3fr = 1.e0  / ( ze3t_n + ze3t_f ) 
    320                      ztf   = ze3fr * ( ztcn   + ztc_f  ) 
    321                      zsf   = ze3fr * ( zscn   + zsc_f  ) 
    322                      !                                         ! mean thickness and tracer 
    323                      ze3mr = 1.e0  / ( ze3t_a + 2.* ze3t_n + ze3t_b ) 
    324                      ztm   = ze3mr * ( ztca   + 2.* ztcn   + ztcb   ) 
    325                      zsm   = ze3mr * ( zsca   + 2.* zscn   + zscb   ) 
    326 !!gm mean e3t have to be saved and used in dynhpg  or it can be recomputed in dynhpg !! 
    327 !!gm                 e3t_m(ji,jj,jk) = 0.25 / ze3mr 
    328                      !                                         ! swap of arrays 
    329                      tb(ji,jj,jk) = ztf                             ! tb <-- tn + filter 
    330                      sb(ji,jj,jk) = zsf 
    331                      tn(ji,jj,jk) = ta(ji,jj,jk)                    ! tn <-- ta 
    332                      sn(ji,jj,jk) = sa(ji,jj,jk) 
    333                      ta(ji,jj,jk) = ztm                             ! ta <-- mean t 
    334                      sa(ji,jj,jk) = zsm 
     326            DO jn = 1, kjpt                               ! (only swap) 
     327               DO jk = 1, jpkm1 
     328                  DO jj = 1, jpj 
     329                     DO ji = 1, jpi 
     330                        ze3t_b = fse3t_b(ji,jj,jk) 
     331                        ze3t_n = fse3t_n(ji,jj,jk) 
     332                        ze3t_a = fse3t_a(ji,jj,jk) 
     333                        !                                         ! tracer content at Before, now and after 
     334                        ztcb = ptrab(ji,jj,jk,jn) *  ze3t_b   
     335                        ztcn = ptran(ji,jj,jk,jn) *  ze3t_n   
     336                        ztca = ptraa(ji,jj,jk,jn) *  ze3t_a   
     337                        ! 
     338                        !                                         ! Asselin filter on thickness and tracer content 
     339                        ze3t_f = atfp * ( ze3t_a - 2.* ze3t_n + ze3t_b ) 
     340                        ztc_f  = atfp * ( ztca   - 2.* ztcn   + ztcb   )  
     341                        ! 
     342                        !                                         ! filtered tracer including the correction  
     343                        ze3fr = 1.e0  / ( ze3t_n + ze3t_f ) 
     344                        ztf   = ze3fr * ( ztcn   + ztc_f  ) 
     345                        !                                         ! mean thickness and tracer 
     346                        ze3mr = 1.e0  / ( ze3t_a + 2.* ze3t_n + ze3t_b ) 
     347                        ztm   = ze3mr * ( ztca   + 2.* ztcn   + ztcb   ) 
     348                        !!gm mean e3t have to be saved and used in dynhpg  or it can be recomputed in dynhpg !! 
     349                        !!gm                 e3t_m(ji,jj,jk) = 0.25 / ze3mr 
     350                        !                                         ! swap of arrays 
     351                        ptrab(ji,jj,jk,jn) = ztf                             ! ptrab <-- ptran + filter 
     352                        ptran(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn)              ! ptran <-- ptraa 
     353                        ptraa(ji,jj,jk,jn) = ztm                             ! ptraa <-- mean t 
     354                     END DO 
    335355                  END DO 
    336356               END DO 
    … …  
    341361         !                                           ! ----------------------- ! 
    342362         ! 
    343          IF( neuler == 0 .AND. kt == nit000 ) THEN        ! case of Euler time-stepping at first time-step 
    344             DO jk = 1, jpkm1                              ! No filter nor thickness weighting computation required 
    345                DO jj = 1, jpj                             ! ONLY swap 
    346                   DO ji = 1, jpi 
    347                      tn(ji,jj,jk) = ta(ji,jj,jk)                                 ! tn <-- ta 
    348                      sn(ji,jj,jk) = sa(ji,jj,jk) 
     363         IF( neuler == 0 .AND. kt == kit000 ) THEN        ! case of Euler time-stepping at first time-step 
     364            DO jn = 1, kjpt                               ! No filter nor thickness weighting computation required     
     365               DO jk = 1, jpkm1                           ! ONLY swap                         
     366                  DO jj = 1, jpj                              
     367                     DO ji = 1, jpi 
     368                        ptran(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn)                                 ! tn <-- ta 
     369                     END DO 
    349370                  END DO 
    350371               END DO 
    … …  
    352373            !                                             ! general case (Leapfrog + Asselin filter) 
    353374         ELSE                                             ! apply filter on thickness weighted tracer and swap 
    354             DO jk = 1, jpkm1 
    355                DO jj = 1, jpj 
    356                   DO ji = 1, jpi 
    357                      ze3t_b = fse3t_b(ji,jj,jk) 
    358                      ze3t_n = fse3t_n(ji,jj,jk) 
    359                      ze3t_a = fse3t_a(ji,jj,jk) 
    360                      !                                         ! tracer content at Before, now and after 
    361                      ztcb = tb(ji,jj,jk) *  ze3t_b   ;   zscb = sb(ji,jj,jk) * ze3t_b 
    362                      ztcn = tn(ji,jj,jk) *  ze3t_n   ;   zscn = sn(ji,jj,jk) * ze3t_n 
    363                      ztca = ta(ji,jj,jk) *  ze3t_a   ;   zsca = sa(ji,jj,jk) * ze3t_a 
    364                      ! 
    365                      !                                         ! Asselin filter on thickness and tracer content 
    366                      ze3t_f = atfp * ( ze3t_a - 2.* ze3t_n + ze3t_b ) 
    367                      ztc_f  = atfp * ( ztca   - 2.* ztcn   + ztcb   )  
    368                      zsc_f  = atfp * ( zsca   - 2.* zscn   + zscb   )  
    369                      ! 
    370                      !                                         ! filtered tracer including the correction  
    371                      ze3fr = 1.e0 / ( ze3t_n + ze3t_f ) 
    372                      ztf   =  ( ztcn  + ztc_f ) * ze3fr 
    373                      zsf   =  ( zscn  + zsc_f ) * ze3fr 
    374                      !                                         ! swap of arrays 
    375                      tb(ji,jj,jk) = ztf                             ! tb <-- tn filtered 
    376                      sb(ji,jj,jk) = zsf 
    377                      tn(ji,jj,jk) = ta(ji,jj,jk)                    ! tn <-- ta 
    378                      sn(ji,jj,jk) = sa(ji,jj,jk) 
     375            DO jn = 1, kjpt       
     376               DO jk = 1, jpkm1 
     377                  DO jj = 1, jpj 
     378                     DO ji = 1, jpi 
     379                        ze3t_b = fse3t_b(ji,jj,jk) 
     380                        ze3t_n = fse3t_n(ji,jj,jk) 
     381                        ze3t_a = fse3t_a(ji,jj,jk) 
     382                        !                                         ! tracer content at Before, now and after 
     383                        ztcb = ptrab(ji,jj,jk,jn) *  ze3t_b   
     384                        ztcn = ptran(ji,jj,jk,jn) *  ze3t_n    
     385                        ztca = ptraa(ji,jj,jk,jn) *  ze3t_a   
     386                        ! 
     387                        !                                         ! Asselin filter on thickness and tracer content 
     388                        ze3t_f = atfp * ( ze3t_a - 2.* ze3t_n + ze3t_b ) 
     389                        ztc_f  = atfp * ( ztca   - 2.* ztcn   + ztcb   )  
     390                        ! 
     391                        !                                         ! filtered tracer including the correction  
     392                        ze3fr = 1.e0 / ( ze3t_n + ze3t_f ) 
     393                        ztf   =  ( ztcn  + ztc_f ) * ze3fr 
     394                        !                                         ! swap of arrays 
     395                        ptrab(ji,jj,jk,jn) = ztf                  ! tb <-- tn filtered 
     396                        ptran(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn)   ! tn <-- ta 
     397                     END DO 
    379398                  END DO 
    380399               END DO 

  • branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/traqsr.F90

    r1951 r2024  
    2121   USE trc_oce         ! share SMS/Ocean variables 
    2222   USE trdmod_oce      ! ocean variables trends 
    23    USE trdmod          ! ocean active tracers trends  
     23   USE trdtra          ! ocean active tracers trends  
    2424   USE in_out_manager  ! I/O manager 
    2525   USE phycst          ! physical constants 
    … …  
    3131   PRIVATE 
    3232 
    33    PUBLIC   tra_qsr        ! routine called by step.F90 (ln_traqsr=T) 
     33   PUBLIC   tra_qsr       ! routine called by step.F90 (ln_traqsr=T) 
     34   PUBLIC   tra_qsr_init  ! routine called by opa.F90 
    3435 
    3536   !                                           !!* Namelist namtra_qsr: penetrative solar radiation 
    … …  
    8788      !!              Lengaigne et al. 2007, Clim. Dyn., V28, 5, 503-516. 
    8889      !!---------------------------------------------------------------------- 
    89       USE oce, ONLY :   ztrdt => ua   ! use ua as 3D workspace    
    90       USE oce, ONLY :   ztrds => va   ! use va as 3D workspace    
    9190      !! 
    9291      INTEGER, INTENT(in) ::   kt     ! ocean time-step 
    … …  
    9897      REAL(wp), DIMENSION(jpi,jpj)     ::   zekb, zekg, zekr            ! 2D workspace 
    9998      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   ze0, ze1 , ze2, ze3, zea    ! 3D workspace 
     99      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  ztrdt,  ztrds 
    100100      !!---------------------------------------------------------------------- 
    101101 
    … …  
    104104         IF(lwp) WRITE(numout,*) 'tra_qsr : penetration of the surface solar radiation' 
    105105         IF(lwp) WRITE(numout,*) '~~~~~~~' 
    106          CALL tra_qsr_init 
    107106         IF( .NOT.ln_traqsr )   RETURN 
    108107      ENDIF 
    109108 
    110109      IF( l_trdtra ) THEN      ! Save ta and sa trends 
    111          ztrdt(:,:,:) = ta(:,:,:)  
    112          ztrds(:,:,:) = 0.e0 
    113       ENDIF 
    114  
     110         ALLOCATE( ztrdt(jpi,jpj,jpk) )   ;    ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 
     111         ALLOCATE( ztrds(jpi,jpj,jpk) )   ;    ztrds(:,:,:) = 0. 
     112      ENDIF 
    115113       
    116114      !                                           ! ============================================== ! 
    … …  
    177175               ! 
    178176               DO jk = 1, nksr                                        ! compute and add qsr trend to ta 
    179                   ta(:,:,jk) = ta(:,:,jk) + ro0cpr * ( zea(:,:,jk) - zea(:,:,jk+1) ) / fse3t(:,:,jk) 
     177                  tsa(:,:,jk,jp_tem) = tsa(:,:,jk,jp_tem) + ro0cpr * ( zea(:,:,jk) - zea(:,:,jk+1) ) / fse3t(:,:,jk) 
    180178               END DO 
    181179               zea(:,:,nksr+1:jpk) = 0.e0     ! below 400m set to zero 
    … …  
    184182            ELSE                                                 !*  Constant Chlorophyll 
    185183               DO jk = 1, nksr 
    186                   ta(:,:,jk) = ta(:,:,jk) + etot3(:,:,jk) * qsr(:,:) 
     184                  tsa(:,:,jk,jp_tem) = tsa(:,:,jk,jp_tem) + etot3(:,:,jk) * qsr(:,:) 
    187185               END DO 
    188186            ENDIF 
    … …  
    196194               DO jj = 2, jpjm1 
    197195                  DO ji = fs_2, fs_jpim1   ! vector opt. 
    198                      ta(ji,jj,jk) = ta(ji,jj,jk) + etot3(ji,jj,jk) * qsr(ji,jj) 
     196                     tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) + etot3(ji,jj,jk) * qsr(ji,jj) 
    199197                  END DO 
    200198               END DO 
    … …  
    206204 
    207205      IF( l_trdtra ) THEN     ! qsr tracers trends saved for diagnostics 
    208          ztrdt(:,:,:) = ta(:,:,:) - ztrdt(:,:,:) 
    209          CALL trd_mod( ztrdt, ztrds, jptra_trd_qsr, 'TRA', kt ) 
     206         ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 
     207         CALL trd_tra( kt, 'TRA', jp_tem, jptra_trd_qsr, ztrdt ) 
     208         CALL trd_tra( kt, 'TRA', jp_sal, jptra_trd_qsr, ztrds ) 
     209         DEALLOCATE( ztrdt )    ;        DEALLOCATE( ztrds ) 
    210210      ENDIF 
    211211      !                       ! print mean trends (used for debugging) 
    212       IF(ln_ctl)   CALL prt_ctl( tab3d_1=ta, clinfo1=' qsr  - Ta: ', mask1=tmask, clinfo3='tra-ta' ) 
     212      IF(ln_ctl)   CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' qsr  - Ta: ', mask1=tmask, clinfo3='tra-ta' ) 
    213213      ! 
    214214   END SUBROUTINE tra_qsr 

  • branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/trasbc.F90

    r2004 r2024  
    1717   USE phycst          ! physical constant 
    1818   USE traqsr          ! solar radiation penetration 
    19    USE trdmod          ! ocean trends  
    20    USE trdmod_oce      ! ocean variables trends 
     19   USE trdmod_oce      ! ocean trends  
     20   USE trdtra          ! ocean trends 
    2121   USE in_out_manager  ! I/O manager 
    2222   USE prtctl          ! Print control 
    … …  
    100100      !!              - save the trend it in ttrd ('key_trdtra') 
    101101      !!---------------------------------------------------------------------- 
    102       USE oce, ONLY :   ztrdt => ua   ! use ua as 3D workspace    
    103       USE oce, ONLY :   ztrds => va   ! use va as 3D workspace    
    104102      !! 
    105103      INTEGER, INTENT(in) ::   kt     ! ocean time-step index 
    … …  
    110108      REAL(wp) ::   zsrau, zse3t, zdep   ! temporary scalars, 1/density, 1/height of box, 1/height of effected water column   
    111109      REAL(wp) ::   zdheat, zdsalt       ! total change of temperature and salinity   
     110      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  ztrdt, ztrds 
    112111      !!---------------------------------------------------------------------- 
    113112 
    … …  
    123122#endif 
    124123 
    125       IF( l_trdtra ) THEN           ! Save ta and sa trends 
    126          ztrdt(:,:,:) = ta(:,:,:)  
    127          ztrds(:,:,:) = sa(:,:,:)  
     124      IF( l_trdtra )   THEN                    !* Save ta and sa trends 
     125         ALLOCATE( ztrdt(jpi,jpj,jpk) )   ;    ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 
     126         ALLOCATE( ztrds(jpi,jpj,jpk) )   ;    ztrds(:,:,:) = tsa(:,:,:,jp_sal) 
    128127      ENDIF 
    129128 
    … …  
    138137            IF( lk_vvl) THEN 
    139138               zta =  ro0cpr * qns(ji,jj) * zse3t &                  ! temperature : heat flux  
    140                 &    - emp(ji,jj) * zsrau * tn(ji,jj,1) * zse3t      ! & cooling/heating effet of EMP flux  
     139                &    - emp(ji,jj) * zsrau * tsn(ji,jj,1,jp_tem) * zse3t      ! & cooling/heating effet of EMP flux  
    141140               zsa = ( emps(ji,jj) - emp(ji,jj) ) & 
    142                 &                 * zsrau * sn(ji,jj,1) * zse3t     ! concent./dilut. effect due to sea-ice  
     141                &                 * zsrau * tsn(ji,jj,1,jp_sal) * zse3t     ! concent./dilut. effect due to sea-ice  
    143142                                                                     ! melt/formation and (possibly) SSS restoration 
    144143            ELSE 
    145144               zta =  ro0cpr * qns(ji,jj) * zse3t                    ! temperature : heat flux  
    146                zsa =  emps(ji,jj) * zsrau * sn(ji,jj,1) * zse3t      ! salinity :  concent./dilut. effect  
     145               zsa =  emps(ji,jj) * zsrau * tsn(ji,jj,1,jp_sal) * zse3t      ! salinity :  concent./dilut. effect  
    147146            ENDIF 
    148             ta(ji,jj,1) = ta(ji,jj,1) + zta                          ! add the trend to the general tracer trend 
    149             sa(ji,jj,1) = sa(ji,jj,1) + zsa 
     147            tsa(ji,jj,1,jp_tem) = tsa(ji,jj,1,jp_tem) + zta                  ! add the trend to the general tracer trend 
     148            tsa(ji,jj,1,jp_sal) = tsa(ji,jj,1,jp_sal) + zsa 
    150149         END DO 
    151150      END DO 
    152151 
    153152      IF ( ln_rnf .AND. ln_rnf_att ) THEN   
    154       ! Concentration / dilution effect on (t,s) due to river runoff   
    155         DO jj=1,jpj   
    156            DO ji=1,jpi   
    157               rnf_dep(ji,jj)=0   
    158               DO jk=1,rnf_mod_dep(ji,jj)                          ! recalculates rnf_dep to be the depth   
    159                 rnf_dep(ji,jj)=rnf_dep(ji,jj)+fse3t(ji,jj,jk)    ! in metres to the bottom of the relevant grid box   
     153        ! Concentration / dilution effect on (t,s) due to river runoff   
     154        DO jj = 1, jpj   
     155           DO ji = 1, jpi   
     156              rnf_dep(ji,jj) = 0.   
     157              DO jk = 1, rnf_mod_dep(ji,jj)                          ! recalculates rnf_dep to be the depth   
     158                rnf_dep(ji,jj) = rnf_dep(ji,jj) + fse3t(ji,jj,jk)    ! in metres to the bottom of the relevant grid box   
    160159              ENDDO   
    161160              zdep = 1. / rnf_dep(ji,jj)   
    162161              zse3t= 1. / fse3t(ji,jj,1)   
    163               IF ( rnf_tmp(ji,jj) == -999 )   rnf_tmp(ji,jj)=tn(ji,jj,1)        ! if not specified set runoff temp to be sst   
    164    
    165               IF ( rnf(ji,jj) .gt. 0.0 ) THEN   
    166    
    167                 IF( lk_vvl) THEN   
    168                   !!!indirect flux, concentration or dilution effect   
    169                   !!!force a dilution effect in all levels;   
    170                   zdheat=0.0   
    171                   zdsalt=0.0   
    172                   DO jk=1, rnf_mod_dep(ji,jj)   
    173                     zta = -tn(ji,jj,jk) * rnf(ji,jj) * zsrau * zdep   
    174                     zsa = -sn(ji,jj,jk) * rnf(ji,jj) * zsrau * zdep   
    175                     ta(ji,jj,jk)=ta(ji,jj,jk)+zta   
    176                     sa(ji,jj,jk)=sa(ji,jj,jk)+zsa   
    177                     zdheat=zdheat+zta*fse3t(ji,jj,jk)   
    178                     zdsalt=zdsalt+zsa*fse3t(ji,jj,jk)   
     162              IF ( rnf_tmp(ji,jj) == -999 )   rnf_tmp(ji,jj) = tsn(ji,jj,1,jp_tem)    ! if not specified set runoff temp to be sst   
     163   
     164              IF ( rnf(ji,jj) > 0.0 ) THEN   
     165   
     166                IF( lk_vvl ) THEN   
     167                  ! indirect flux, concentration or dilution effect : force a dilution effect in all levels  
     168                  zdheat = 0.0   
     169                  zdsalt = 0.0   
     170                  DO jk = 1, rnf_mod_dep(ji,jj)   
     171                    zta = -tsn(ji,jj,jk,jp_tem) * rnf(ji,jj) * zsrau * zdep   
     172                    zsa = -tsn(ji,jj,jk,jp_sal) * rnf(ji,jj) * zsrau * zdep   
     173                    tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) + zta                  ! add the trend to the general tracer trend 
     174                    tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal) + zsa 
     175                    zdheat = zdheat + zta * fse3t(ji,jj,jk)   
     176                    zdsalt = zdsalt + zsa * fse3t(ji,jj,jk)   
    179177                  ENDDO   
    180                   !!!negate this total change in heat and salt content from top level   
    181                   zta=-zdheat*zse3t   
    182                   zsa=-zdsalt*zse3t   
    183                   ta(ji,jj,1)=ta(ji,jj,1)+zta   
    184                   sa(ji,jj,1)=sa(ji,jj,1)+zsa   
     178                  ! negate this total change in heat and salt content from top level   
     179                  zta = -zdheat * zse3t   
     180                  zsa = -zdsalt * zse3t   
     181                  tsa(ji,jj,1,jp_tem) = tsa(ji,jj,1,jp_tem) + zta                  ! add the trend to the general tracer trend 
     182                  tsa(ji,jj,1,jp_sal) = tsa(ji,jj,1,jp_sal) + zsa 
    185183     
    186                   !!!direct flux   
     184                  ! direct flux   
    187185                  zta = rnf_tmp(ji,jj) * rnf(ji,jj) * zsrau * zdep   
    188186                  zsa = rnf_sal(ji,jj) * rnf(ji,jj) * zsrau * zdep   
    189187     
    190                   DO jk=1, rnf_mod_dep(ji,jj)   
    191                     ta(ji,jj,jk) = ta(ji,jj,jk) + zta   
    192                     sa(ji,jj,jk) = sa(ji,jj,jk) + zsa   
     188                  DO jk = 1, rnf_mod_dep(ji,jj)   
     189                    tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) + zta                  ! add the trend to the general tracer trend 
     190                    tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal) + zsa 
    193191                  ENDDO   
    194192    
    195193                ELSE   
    196                   DO jk=1, rnf_mod_dep(ji,jj)   
    197                     zta = ( rnf_tmp(ji,jj)-tn(ji,jj,jk) ) * rnf(ji,jj) * zsrau * zdep   
    198                     zsa = ( rnf_sal(ji,jj)-sn(ji,jj,jk) ) * rnf(ji,jj) * zsrau * zdep   
    199                     ta(ji,jj,jk) = ta(ji,jj,jk) + zta   
    200                     sa(ji,jj,jk) = sa(ji,jj,jk) + zsa   
     194                  DO jk = 1, rnf_mod_dep(ji,jj)   
     195                    zta = ( rnf_tmp(ji,jj) - tsn(ji,jj,jk,jp_tem) ) * rnf(ji,jj) * zsrau * zdep   
     196                    zsa = ( rnf_sal(ji,jj) - tsn(ji,jj,jk,jp_sal) ) * rnf(ji,jj) * zsrau * zdep   
     197                    tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) + zta                  ! add the trend to the general tracer trend 
     198                    tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal) + zsa 
    201199                  ENDDO   
    202200                ENDIF   
    203201   
    204               ELSEIF (rnf(ji,jj) .lt. 0.) THEN   !! for use in baltic when flow is out of domain, want no change in temp and sal   
    205    
    206                 IF( lk_vvl) THEN   
    207                   !calculate automatic adjustment to sal and temp due to dilution/concentraion effect    
    208                   zata = tn(ji,jj,1) * rnf(ji,jj) * zsrau * zse3t   
    209                   zasa = sn(ji,jj,1) * rnf(ji,jj) * zsrau * zse3t   
    210                   ta(ji,jj,1)=ta(ji,jj,1) + zata   
    211                   sa(ji,jj,1)=sa(ji,jj,1) + zasa   
     202              ELSE IF( rnf(ji,jj) > 0.) THEN   ! for use in baltic when flow is out of domain, want no change in temp and sal   
     203   
     204                IF( lk_vvl ) THEN   
     205                  ! calculate automatic adjustment to sal and temp due to dilution/concentraion effect    
     206                  zata = tsn(ji,jj,1,jp_tem) * rnf(ji,jj) * zsrau * zse3t   
     207                  zasa = tsn(ji,jj,1,jp_sal) * rnf(ji,jj) * zsrau * zse3t   
     208                  tsa(ji,jj,1,jp_tem) = tsa(ji,jj,1,jp_tem) + zata                  ! add the trend to the general tracer trend 
     209                  tsa(ji,jj,1,jp_sal) = tsa(ji,jj,1,jp_sal) + zasa 
    212210                ENDIF   
    213211   
    … …  
    226224#endif 
    227225              IF( lk_vvl) THEN 
    228                  zta =  rnf(ji,jj) * zsrau * tn(ji,jj,1) * zse3t       ! & cooling/heating effect of runoff 
    229                  zsa = 0.e0                                            ! No salinity concent./dilut. effect 
     226                 zta =    rnf(ji,jj) * zsrau * tsn(ji,jj,1,jp_tem) * zse3t       ! & cooling/heating effect of runoff 
     227                 zsa =    0.e0                                            ! No salinity concent./dilut. effect 
    230228              ELSE 
    231                  zta =  0.0                                            ! temperature : heat flux  
    232                  zsa =  - rnf(ji,jj) * zsrau * sn(ji,jj,1) * zse3t     ! salinity :  concent./dilut. effect 
     229                 zta =    0.0                                            ! temperature : heat flux  
     230                 zsa =  - rnf(ji,jj) * zsrau * tsn(ji,jj,1,jp_sal) * zse3t     ! salinity :  concent./dilut. effect 
    233231              ENDIF 
    234               ta(ji,jj,1) = ta(ji,jj,1) + zta                          ! add the trend to the general tracer trend 
    235               sa(ji,jj,1) = sa(ji,jj,1) + zsa 
     232              tsa(ji,jj,1,jp_tem) = tsa(ji,jj,1,jp_tem) + zta          ! add the trend to the general tracer trend 
     233              tsa(ji,jj,1,jp_sal) = tsa(ji,jj,1,jp_sal) + zsa 
    236234           END DO 
    237235        END DO 
    … …  
    239237      ENDIF   
    240238 
    241       IF( l_trdtra ) THEN      ! save the sbc trends for diagnostic 
    242          ztrdt(:,:,:) = ta(:,:,:) - ztrdt(:,:,:) 
    243          ztrds(:,:,:) = sa(:,:,:) - ztrds(:,:,:) 
    244          CALL trd_mod(ztrdt, ztrds, jptra_trd_nsr, 'TRA', kt) 
     239      IF( l_trdtra )   THEN                      ! save the horizontal diffusive trends for further diagnostics 
     240         ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 
     241         ztrds(:,:,:) = tsa(:,:,:,jp_sal) - ztrds(:,:,:) 
     242         CALL trd_tra( kt, 'TRA', jp_tem, jptra_trd_nsr, ztrdt ) 
     243         CALL trd_tra( kt, 'TRA', jp_sal, jptra_trd_nsr, ztrds ) 
     244         DEALLOCATE( ztrdt )      ;     DEALLOCATE( ztrds ) 
    245245      ENDIF 
    246246      ! 
    247       IF(ln_ctl)   CALL prt_ctl( tab3d_1=ta, clinfo1=' sbc  - Ta: ', mask1=tmask,   & 
    248          &                       tab3d_2=sa, clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
     247      IF(ln_ctl)   CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' sbc  - Ta: ', mask1=tmask,   & 
     248         &                       tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    249249      ! 
    250250   END SUBROUTINE tra_sbc 

  • branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/trazdf.F90

    r1533 r2024  
    44   !! Ocean active tracers:  vertical component of the tracer mixing trend 
    55   !!============================================================================== 
    6    !! History :  9.0  !  05-11  (G. Madec)  Original code 
     6   !! History :  9.0  ! 2005-11  (G. Madec)  Original code 
     7   !!       NEMO 3.0  ! 2008-01  (C. Ethe, G. Madec)  merge TRC-TRA 
    78   !!---------------------------------------------------------------------- 
    89 
    … …  
    2122 
    2223   USE ldftra_oce      ! ocean active tracers: lateral physics 
    23    USE trdmod          ! ocean active tracers trends  
    24    USE trdmod_oce      ! ocean variables trends 
     24   USE trdmod_oce      ! ocean active tracers: lateral physics 
     25   USE trdtra      ! ocean tracers trends  
    2526   USE in_out_manager  ! I/O manager 
    2627   USE prtctl          ! Print control 
    … …  
    3334   PRIVATE 
    3435 
    35    PUBLIC tra_zdf   !  routine called by step.F90 
     36   PUBLIC tra_zdf      !  routine called by step.F90 
     37   PUBLIC tra_zdf_init !  routine called by opa.F90 
    3638 
    3739   INTEGER ::   nzdf = 0               ! type vertical diffusion algorithm used 
    3840      !                                ! defined from ln_zdf...  namlist logicals) 
    39  
    4041   REAL(wp), DIMENSION(jpk) ::   r2dt  ! vertical profile time-step, = 2 rdttra 
    4142      !                                ! except at nit000 (=rdttra) if neuler=0 
    … …  
    6263 
    6364      INTEGER  ::   jk                   ! Dummy loop indices 
    64       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   ztrdt, ztrds   ! 3D workspace 
     65      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   ztrdt, ztrds   ! 3D workspace 
    6566      !!--------------------------------------------------------------------- 
    66  
    67       IF( kt == nit000 )   CALL zdf_ctl          ! initialisation & control of options 
    6867 
    6968      !                                          ! set time step 
    … …  
    7473      ENDIF 
    7574 
    76       IF( l_trdtra )   THEN                      ! temporary save of ta and sa trends 
    77          ztrdt(:,:,:) = ta(:,:,:) 
    78          ztrds(:,:,:) = sa(:,:,:) 
     75      IF( l_trdtra )   THEN                    !* Save ta and sa trends 
     76         ALLOCATE( ztrdt(jpi,jpj,jpk) )   ;    ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 
     77         ALLOCATE( ztrds(jpi,jpj,jpk) )   ;    ztrds(:,:,:) = tsa(:,:,:,jp_sal) 
    7978      ENDIF 
    8079 
    8180      SELECT CASE ( nzdf )                       ! compute lateral mixing trend and add it to the general trend 
     81      CASE ( 0 )    ;    CALL tra_zdf_exp( kt , 'TRA', r2dt, nn_zdfexp,  & 
     82                         &                 tsb, tsa  , jpts              )    !   explicit scheme 
     83      CASE ( 1 )    ;    CALL tra_zdf_imp( kt , 'TRA', r2dt,             & 
     84                         &                 tsb, tsa  , jpts              )    !   implicit scheme 
    8285      CASE ( -1 )                                       ! esopa: test all possibility with control print 
    83          CALL tra_zdf_exp    ( kt, r2dt ) 
    84          CALL prt_ctl( tab3d_1=ta, clinfo1=' zdf0 - Ta: ', mask1=tmask,               & 
    85             &          tab3d_2=sa, clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    86          CALL tra_zdf_imp    ( kt, r2dt ) 
    87          CALL prt_ctl( tab3d_1=ta, clinfo1=' zdf1 - Ta: ', mask1=tmask,               & 
    88             &          tab3d_2=sa, clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    89  
    90       CASE ( 0 )                                       ! explicit scheme 
    91          CALL tra_zdf_exp    ( kt, r2dt ) 
    92  
    93       CASE ( 1 )                                       ! implicit scheme  
    94          CALL tra_zdf_imp    ( kt, r2dt ) 
    95  
     86                         CALL tra_zdf_exp( kt , 'TRA', r2dt, nn_zdfexp,  & 
     87                         &                 tsb, tsa  , jpts              )  
     88                         CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' zdf0 - Ta: ', mask1=tmask,               & 
     89                         &             tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
     90                         CALL tra_zdf_imp( kt , 'TRA', r2dt,             & 
     91                         &                 tsb, tsa  , jpts              )  
     92                         CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' zdf1 - Ta: ', mask1=tmask,               & 
     93                         &             tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    9694      END SELECT 
    9795 
    9896      IF( l_trdtra )   THEN                      ! save the vertical diffusive trends for further diagnostics 
    9997         DO jk = 1, jpkm1 
    100             ztrdt(:,:,jk) = ( ( ta(:,:,jk) - tb(:,:,jk) ) / r2dt(jk) ) - ztrdt(:,:,jk) 
    101             ztrds(:,:,jk) = ( ( sa(:,:,jk) - sb(:,:,jk) ) / r2dt(jk) ) - ztrds(:,:,jk) 
     98            ztrdt(:,:,jk) = ( ( tsa(:,:,jk,jp_tem) - tsb(:,:,jk,jp_tem) ) / r2dt(jk) ) - ztrdt(:,:,jk) 
     99            ztrds(:,:,jk) = ( ( tsa(:,:,jk,jp_sal) - tsb(:,:,jk,jp_sal) ) / r2dt(jk) ) - ztrds(:,:,jk) 
    102100         END DO 
    103          CALL trd_mod( ztrdt, ztrds, jptra_trd_zdf, 'TRA', kt ) 
     101         CALL trd_tra( kt, 'TRA', jp_tem, jptra_trd_zdf, ztrdt ) 
     102         CALL trd_tra( kt, 'TRA', jp_sal, jptra_trd_zdf, ztrds ) 
     103         DEALLOCATE( ztrdt )      ;     DEALLOCATE( ztrds )  
    104104      ENDIF 
    105105 
    106106      !                                          ! print mean trends (used for debugging) 
    107       IF(ln_ctl)   CALL prt_ctl( tab3d_1=ta, clinfo1=' zdf  - Ta: ', mask1=tmask,               & 
    108          &                       tab3d_2=sa, clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
     107      IF(ln_ctl)   CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' zdf  - Ta: ', mask1=tmask,               & 
     108         &                       tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    109109 
    110110   END SUBROUTINE tra_zdf 
    111111 
    112112 
    113    SUBROUTINE zdf_ctl 
     113   SUBROUTINE tra_zdf_init 
    114114      !!---------------------------------------------------------------------- 
    115       !!                 ***  ROUTINE zdf_ctl  *** 
     115      !!                 ***  ROUTINE tra_zdf_init  *** 
    116116      !! 
    117117      !! ** Purpose :   Choose the vertical mixing scheme 
    … …  
    153153      IF(lwp) THEN 
    154154         WRITE(numout,*) 
    155          WRITE(numout,*) 'tra:zdf_ctl : vertical tracer physics scheme' 
     155         WRITE(numout,*) 'tra_zdf_init : vertical tracer physics scheme' 
    156156         WRITE(numout,*) '~~~~~~~~~~~' 
    157157         IF( nzdf == -1 )   WRITE(numout,*) '              ESOPA test All scheme used' 
    … …  
    160160      ENDIF 
    161161 
    162    END SUBROUTINE zdf_ctl 
     162   END SUBROUTINE tra_zdf_init 
    163163 
    164164   !!============================================================================== 

  • branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/trazdf_exp.F90

    r1537 r2024  
    22   !!============================================================================== 
    33   !!                    ***  MODULE  trazdf_exp  *** 
    4    !! Ocean active tracers:  vertical component of the tracer mixing trend using 
    5    !!                        a split-explicit time-stepping  
     4   !! Ocean tracers:  vertical component of the tracer mixing trend using 
     5   !!                  a split-explicit time-stepping  
    66   !!============================================================================== 
    77   !! History :  OPA  !  1990-10  (B. Blanke)  Original code 
    … …  
    1616   !!             -   !  2005-11  (G. Madec)  New organisation 
    1717   !!            3.0  !  2008-04  (G. Madec)  leap-frog time stepping done in trazdf 
     18   !!            3.3  !  2010-06  (C. Ethe, G. Madec) Merge TRA-TRC 
    1819   !!---------------------------------------------------------------------- 
    1920 
    … …  
    2425   USE oce             ! ocean dynamics and active tracers  
    2526   USE dom_oce         ! ocean space and time domain  
    26    USE domvvl          ! variablevolume levels 
    27    USE trdmod          ! ocean active tracers trends  
    28    USE trdmod_oce      ! ocean variables trends 
     27   USE domvvl          ! variable volume levels 
    2928   USE zdf_oce         ! ocean vertical physics 
    3029   USE zdfddm          ! ocean vertical physics: double diffusion 
    3130   USE in_out_manager  ! I/O manager 
    32    USE prtctl          ! Print control 
    3331 
    3432   IMPLICIT NONE 
    … …  
    4947CONTAINS 
    5048 
    51    SUBROUTINE tra_zdf_exp( kt, p2dt ) 
     49   SUBROUTINE tra_zdf_exp( kt    , cdtype, p2dt, kn_zdfexp,  & 
     50      &                    ptrab , ptraa , kjpt              ) 
    5251      !!---------------------------------------------------------------------- 
    5352      !!                  ***  ROUTINE tra_zdf_exp  *** 
    … …  
    5857      !! ** Method  : - The after tracer fields due to the vertical diffusion 
    5958      !!      of tracers alone is given by: 
    60       !!                zwx = tb + p2dt difft 
    61       !!      where difft = dz( avt dz(tb) ) = 1/e3t dk+1( avt/e3w dk(tb) ) 
    62       !!           (if lk_zdfddm=T use avs on salinity instead of avt) 
     59      !!                zwx = ptrab + p2dt difft 
     60      !!      where difft = dz( avt dz(ptrab) ) = 1/e3t dk+1( avt/e3w dk(ptrab) ) 
     61      !!           (if lk_zdfddm=T use avs on salinity and passive tracers instead of avt) 
    6362      !!      difft is evaluated with an Euler split-explit scheme using a 
    6463      !!      no flux boundary condition at both surface and bottomi boundaries. 
    … …  
    6665      !!              - the after tracer fields due to the whole trend is  
    6766      !!      obtained in leap-frog environment by : 
    68       !!          ta = zwx + p2dt ta 
     67      !!          ptraa = zwx + p2dt ptraa 
    6968      !!              - in case of variable level thickness (lk_vvl=T) the  
    7069      !!     the leap-frog is applied on thickness weighted tracer. That is: 
    71       !!          ta = [ tb*e3tb + e3tn*( zwx - tb + p2dt ta ) ] / e3tn 
     70      !!          ptraa = [ ptrab*e3tb + e3tn*( zwx - ptrab + p2dt ptraa ) ] / e3tn 
    7271      !! 
    73       !! ** Action : - after tracer fields (ta,sa)  
     72      !! ** Action : - after tracer fields pta 
    7473      !!--------------------------------------------------------------------- 
    75       INTEGER , INTENT(in)                 ::   kt     ! ocean time-step index 
    76       REAL(wp), INTENT(in), DIMENSION(jpk) ::   p2dt   ! vertical profile of tracer time-step 
    77       !! 
    78       INTEGER  ::   ji, jj, jk, jl            ! dummy loop indices 
    79       REAL(wp) ::   zlavmr, zave3r, ze3tr     ! temporary scalars 
    80       REAL(wp) ::   zta, zsa, ze3tb           ! temporary scalars 
    81       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zwx, zwy, zwz, zww   ! 3D workspace 
     74      !! * Arguments 
     75      INTEGER         , INTENT(in   )                                ::   kt          ! ocean time-step index 
     76      CHARACTER(len=3), INTENT(in   )                                ::   cdtype      ! =TRA or TRC (tracer indicator) 
     77      INTEGER         , INTENT(in   )                                ::   kjpt        ! number of tracers 
     78      INTEGER         , INTENT(in   )                                ::   kn_zdfexp   ! number of sub-time step 
     79      REAL(wp)        , INTENT(in   ), DIMENSION(jpk)                ::   p2dt        ! vertical profile of tracer time-step 
     80      REAL(wp)        , INTENT(in   ), DIMENSION(jpi,jpj,jpk,kjpt)   ::   ptrab       ! before and now tracer fields 
     81      REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)   ::   ptraa       ! tracer trend  
     82      !! * Local declarations 
     83      INTEGER  ::  ji, jj, jk, jn, jl        ! dummy loop indices 
     84      REAL(wp) ::  zlavmr, zave3r, ze3tr     ! temporary scalars 
     85      REAL(wp) ::  ztra, ze3tb               ! temporary scalars 
     86      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zwx, zwy   ! 3D workspace 
    8287      !!--------------------------------------------------------------------- 
    8388 
    … …  
    9095      ! Initializations 
    9196      ! --------------- 
    92       zlavmr = 1. / float( nn_zdfexp )                           ! Local constant 
     97      zlavmr = 1. / float( kn_zdfexp )                           ! Local constant 
    9398      ! 
    94       zwy(:,:, 1 ) = 0.e0        ;   zww(:,:, 1 ) = 0.e0        ! surface boundary conditions: no flux 
    95       zwy(:,:,jpk) = 0.e0        ;   zww(:,:,jpk) = 0.e0        ! bottom  boundary conditions: no flux 
    9699      ! 
    97       zwx(:,:,:)   = tb(:,:,:)   ;   zwz(:,:,:)   = sb(:,:,:)   ! zwx and zwz arrays set to before tracer values 
     100      DO jn = 1, kjpt 
     101         ! 
     102         zwy(:,:, 1 ) = 0.e0     ! surface boundary conditions: no flux 
     103         zwy(:,:,jpk) = 0.e0     ! bottom  boundary conditions: no flux 
     104         ! 
     105         zwx(:,:,:)   = ptrab(:,:,:,jn)  ! zwx array set to before tracer values 
    98106 
    99       ! Split-explicit loop  (after tracer due to the vertical diffusion alone) 
    100       ! ------------------- 
    101       ! 
    102       DO jl = 1, nn_zdfexp 
    103          !                     ! first vertical derivative 
    104          DO jk = 2, jpk 
    105             DO jj = 2, jpjm1  
    106                DO ji = fs_2, fs_jpim1   ! vector opt. 
    107                   zave3r = 1.e0 / fse3w_n(ji,jj,jk)  
    108                   zwy(ji,jj,jk) =   avt(ji,jj,jk) * ( zwx(ji,jj,jk-1) - zwx(ji,jj,jk) ) * zave3r 
    109                   zww(ji,jj,jk) = fsavs(ji,jj,jk) * ( zwz(ji,jj,jk-1) - zwz(ji,jj,jk) ) * zave3r 
     107         ! Split-explicit loop  (after tracer due to the vertical diffusion alone) 
     108         ! ------------------- 
     109         ! 
     110         DO jl = 1, kn_zdfexp 
     111            !                     ! first vertical derivative 
     112            DO jk = 2, jpk 
     113               DO jj = 2, jpjm1  
     114                  DO ji = fs_2, fs_jpim1   ! vector opt. 
     115                     zave3r = 1.e0 / fse3w_n(ji,jj,jk)  
     116                     IF( cdtype == 'TRA' .AND. jn == jp_tem ) THEN  ! temperature : use of avt 
     117                        zwy(ji,jj,jk) =   avt(ji,jj,jk) * ( zwx(ji,jj,jk-1) - zwx(ji,jj,jk) ) * zave3r 
     118                     ELSE                                           ! salinity or pass. tracer : use of avs 
     119                        zwy(ji,jj,jk) = fsavs(ji,jj,jk) * ( zwx(ji,jj,jk-1) - zwx(ji,jj,jk) ) * zave3r 
     120                     END IF 
     121                  END DO 
    110122               END DO 
    111123            END DO 
    112          END DO 
    113          ! 
    114          DO jk = 1, jpkm1      ! second vertical derivative   ==> tracer at kt+l*2*rdt/nn_zdfexp 
    115             DO jj = 2, jpjm1  
    116                DO ji = fs_2, fs_jpim1   ! vector opt. 
    117                   ze3tr = zlavmr / fse3t_n(ji,jj,jk) 
    118                   zwx(ji,jj,jk) = zwx(ji,jj,jk) + p2dt(jk) * ( zwy(ji,jj,jk) - zwy(ji,jj,jk+1) ) * ze3tr 
    119                   zwz(ji,jj,jk) = zwz(ji,jj,jk) + p2dt(jk) * ( zww(ji,jj,jk) - zww(ji,jj,jk+1) ) * ze3tr 
     124            ! 
     125            DO jk = 1, jpkm1      ! second vertical derivative   ==> tracer at kt+l*2*rdt/nn_zdfexp 
     126               DO jj = 2, jpjm1  
     127                  DO ji = fs_2, fs_jpim1   ! vector opt. 
     128                     ze3tr = zlavmr / fse3t_n(ji,jj,jk) 
     129                     zwx(ji,jj,jk) = zwx(ji,jj,jk) + p2dt(jk) * ( zwy(ji,jj,jk) - zwy(ji,jj,jk+1) ) * ze3tr 
     130                  END DO 
    120131               END DO 
    121132            END DO 
     133            ! 
    122134         END DO 
     135 
     136         ! After tracer due to all trends 
     137         ! ------------------------------ 
     138         IF( lk_vvl ) THEN          ! variable level thickness : leap-frog on tracer*e3t 
     139            DO jk = 1, jpkm1 
     140               DO jj = 2, jpjm1  
     141                  DO ji = fs_2, fs_jpim1   ! vector opt. 
     142                     ze3tb = fse3t_b(ji,jj,jk) / fse3t(ji,jj,jk)                          ! before e3t 
     143                     ztra  = zwx(ji,jj,jk) - ptrab(ji,jj,jk,jn) + p2dt(jk) * ptraa(ji,jj,jk,jn)       ! total trends * 2*rdt  
     144                     ptraa(ji,jj,jk,jn) = ( ze3tb * ptrab(ji,jj,jk,jn) + ztra ) * tmask(ji,jj,jk) 
     145                  END DO 
     146               END DO 
     147            END DO 
     148         ELSE                       ! fixed level thickness : leap-frog on tracers 
     149            DO jk = 1, jpkm1 
     150               DO jj = 2, jpjm1  
     151                  DO ji = fs_2, fs_jpim1   ! vector opt. 
     152                     ptraa(ji,jj,jk,jn) = ( zwx(ji,jj,jk) + p2dt(jk) * ptraa(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 
     153                  END DO 
     154               END DO 
     155            END DO 
     156         ENDIF 
    123157         ! 
    124158      END DO 
    125  
    126       ! After tracer due to all trends 
    127       ! ------------------------------ 
    128       IF( lk_vvl ) THEN          ! variable level thickness : leap-frog on tracer*e3t 
    129          DO jk = 1, jpkm1 
    130             DO jj = 2, jpjm1  
    131                DO ji = fs_2, fs_jpim1   ! vector opt. 
    132                   ze3tb = fse3t_b(ji,jj,jk) / fse3t(ji,jj,jk)                          ! before e3t 
    133                   zta   = zwx(ji,jj,jk) - tb(ji,jj,jk) + p2dt(jk) * ta(ji,jj,jk)       ! total trends * 2*rdt 
    134                   zsa   = zwz(ji,jj,jk) - sb(ji,jj,jk) + p2dt(jk) * sa(ji,jj,jk)      
    135                   ta(ji,jj,jk) = (  ze3tb * tb(ji,jj,jk) + zta  ) * tmask(ji,jj,jk) 
    136                   sa(ji,jj,jk) = (  ze3tb * sb(ji,jj,jk) + zsa  ) * tmask(ji,jj,jk) 
    137                END DO 
    138             END DO 
    139          END DO 
    140       ELSE                       ! fixed level thickness : leap-frog on tracers 
    141          DO jk = 1, jpkm1 
    142             DO jj = 2, jpjm1  
    143                DO ji = fs_2, fs_jpim1   ! vector opt. 
    144                   ta(ji,jj,jk) = ( zwx(ji,jj,jk) + p2dt(jk) * ta(ji,jj,jk) ) * tmask(ji,jj,jk) 
    145                   sa(ji,jj,jk) = ( zwz(ji,jj,jk) + p2dt(jk) * sa(ji,jj,jk) ) * tmask(ji,jj,jk) 
    146                END DO 
    147             END DO 
    148          END DO 
    149       ENDIF 
    150159      ! 
    151160   END SUBROUTINE tra_zdf_exp 

  • branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/trazdf_imp.F90

    r1517 r2024  
    22   !!====================================================================== 
    33   !!                 ***  MODULE  trazdf_imp  *** 
    4    !! Ocean active tracers:  vertical component of the tracer mixing trend 
     4   !! Ocean tracers:  vertical component of the tracer mixing trend 
    55   !!====================================================================== 
    66   !! History :  OPA  !  1990-10  (B. Blanke)  Original code 
    … …  
    1414   !!            2.0  !  2006-11  (G. Madec) New step reorganisation 
    1515   !!            3.2  !  2009-03  (G. Madec)  heat and salt content trends 
     16   !!            3.3  !  2010-06  (C. Ethe, G. Madec) Merge TRA-TRC 
    1617   !!---------------------------------------------------------------------- 
    1718   
    … …  
    2526   USE ldftra_oce      ! ocean active tracers: lateral physics 
    2627   USE ldfslp          ! lateral physics: slope of diffusion 
    27    USE trdmod          ! ocean active tracers trends  
    28    USE trdmod_oce      ! ocean variables trends 
    2928   USE zdfddm          ! ocean vertical physics: double diffusion 
    3029   USE in_out_manager  ! I/O manager 
    3130   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    32    USE prtctl          ! Print control 
    3331   USE domvvl          ! variable volume 
    3432   USE ldftra          ! lateral mixing type 
    … …  
    5048   !!---------------------------------------------------------------------- 
    5149CONTAINS 
    52     
    53    SUBROUTINE tra_zdf_imp( kt, p2dt ) 
     50  
     51   SUBROUTINE tra_zdf_imp( kt    , cdtype, p2dt,    & 
     52      &                    ptrab , ptraa , kjpt     ) 
    5453      !!---------------------------------------------------------------------- 
    5554      !!                  ***  ROUTINE tra_zdf_imp  *** 
    … …  
    7170      !!                  associated with the lateral mixing, through the 
    7271      !!                  update of avt) 
    73       !!      The vertical diffusion of tracers (t & s) is given by: 
     72      !!      The vertical diffusion of the tracer t is given by: 
    7473      !!             difft = dz( avt dz(t) ) = 1/e3t dk+1( avt/e3w dk(t) ) 
    7574      !!      It is computed using a backward time scheme (t=ta). 
    … …  
    7877      !!      Add this trend to the general trend ta,sa : 
    7978      !!         ta = ta + dz( avt dz(t) ) 
    80       !!         (sa = sa + dz( avs dz(t) ) if lk_zdfddm=T ) 
     79      !!         if lk_zdfddm=T, use avs for salinity or for passive tracers 
     80      !!         (sa = sa + dz( avs dz(t) )  
    8181      !! 
    8282      !!      Third part: recover avt resulting from the vertical physics 
    8383      !!      ==========  alone, for further diagnostics (for example to 
    8484      !!                  compute the turbocline depth in zdfmxl.F90). 
    85       !!         avt = zavt 
     85      !!         if lk_zdfddm=T, use avt = zavt 
    8686      !!         (avs = zavs if lk_zdfddm=T ) 
    8787      !! 
    88       !! ** Action  : - Update (ta,sa) with before vertical diffusion trend 
     88      !! ** Action  : - Update (ta) with before vertical diffusion trend 
    8989      !! 
    9090      !!--------------------------------------------------------------------- 
     91      !! * Modules used 
    9192      USE oce    , ONLY :   zwd   => ua   ! ua used as workspace 
    9293      USE oce    , ONLY :   zws   => va   ! va  -          - 
    93       !! 
    94       INTEGER                 , INTENT(in) ::   kt     ! ocean time-step index 
    95       REAL(wp), DIMENSION(jpk), INTENT(in) ::   p2dt   ! vertical profile of tracer time-step 
    96       !! 
    97       INTEGER  ::   ji, jj, jk            ! dummy loop indices 
    98       REAL(wp) ::   zavi, zrhs, znvvl     ! temporary scalars 
    99       REAL(wp) ::   ze3tb, ze3tn, ze3ta   ! variable vertical scale factors 
    100       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zwi, zwt, zavsi   ! workspace arrays 
     94      !! * Arguments 
     95      INTEGER         , INTENT(in   )                                ::   kt             ! ocean time-step index 
     96      CHARACTER(len=3), INTENT(in   )                                ::   cdtype         ! =TRA or TRC (tracer indicator) 
     97      INTEGER         , INTENT(in   )                                ::   kjpt            ! number of tracers 
     98      REAL(wp)        , INTENT(in   ), DIMENSION(jpk)                ::   p2dt        ! vertical profile of tracer time-step 
     99      REAL(wp)        , INTENT(in   ), DIMENSION(jpi,jpj,jpk,kjpt)   ::   ptrab          ! before and now tracer fields 
     100      REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)   ::   ptraa          ! tracer trend  
     101      !! 
     102      INTEGER  ::  ji, jj, jk, jn        ! dummy loop indices 
     103      REAL(wp) ::  zavi, zrhs, znvvl     ! temporary scalars 
     104      REAL(wp) ::  ze3tb, ze3tn, ze3ta   ! variable vertical scale factors 
     105      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zwi, zwt   ! workspace arrays 
    101106      !!--------------------------------------------------------------------- 
    102107 
    … …  
    107112         zavi = 0.e0      ! avoid warning at compilation phase when lk_ldfslp=F 
    108113      ENDIF 
    109  
     114      ! 
    110115      ! I. Local initialization 
    111116      ! ----------------------- 
    112       zwd  (1,:, : ) = 0.e0     ;     zwd  (jpi,:,:) = 0.e0 
    113       zws  (1,:, : ) = 0.e0     ;     zws  (jpi,:,:) = 0.e0 
    114       zwi  (1,:, : ) = 0.e0     ;     zwi  (jpi,:,:) = 0.e0 
    115       zwt  (1,:, : ) = 0.e0     ;     zwt  (jpi,:,:) = 0.e0 
    116       zavsi(1,:, : ) = 0.e0     ;     zavsi(jpi,:,:) = 0.e0 
    117       zwt  (:,:,jpk) = 0.e0     ;     zwt  ( : ,:,1) = 0.e0 
    118       zavsi(:,:,jpk) = 0.e0     ;     zavsi( : ,:,1) = 0.e0 
     117      zwd(1,:, : ) = 0.e0     ;     zwd(jpi,:,:) = 0.e0 
     118      zws(1,:, : ) = 0.e0     ;     zws(jpi,:,:) = 0.e0 
     119      zwi(1,:, : ) = 0.e0     ;     zwi(jpi,:,:) = 0.e0 
     120      zwt(1,:, : ) = 0.e0     ;     zwt(jpi,:,:) = 0.e0 
     121      zwt(:,:,jpk) = 0.e0     ;     zwt( : ,:,1) = 0.e0 
    119122 
    120123      ! I.1 Variable volume : to take into account vertical variable vertical scale factors 
    … …  
    130133      !     dk[ avt dk[ (t,s) ] ] diffusive trends 
    131134 
    132  
     135      ! 
    133136      ! II.0 Matrix construction 
    134137      ! ------------------------ 
    135  
     138      DO jn = 1, kjpt 
     139         ! 
     140         !  Matrix construction 
     141         ! ------------------------ 
     142         IF( cdtype == 'TRA' .AND. jn == jp_tem )  THEN  
    136143#if defined key_ldfslp 
    137       ! update and save of avt (and avs if double diffusive mixing) 
    138       IF( l_traldf_rot ) THEN 
    139          DO jk = 2, jpkm1 
     144            ! update and save of avt (and avs if double diffusive mixing) 
     145            IF( l_traldf_rot ) THEN 
     146               DO jk = 2, jpkm1 
     147                  DO jj = 2, jpjm1 
     148                     DO ji = fs_2, fs_jpim1   ! vector opt. 
     149                        zavi = fsahtw(ji,jj,jk)                       &   ! vertical mixing coef. due to lateral mixing 
     150                           & * (  wslpi(ji,jj,jk) * wslpi(ji,jj,jk)   & 
     151                           &    + wslpj(ji,jj,jk) * wslpj(ji,jj,jk)  ) 
     152                        zwt(ji,jj,jk) = avt(ji,jj,jk) + zavi              ! zwt=avt+zavi (total vertical mixing coef. on temperature) 
     153                     END DO 
     154                  END DO 
     155               END DO 
     156            ELSE                         ! no rotation but key_ldfslp defined 
     157               zwt  (:,:,:) = avt(:,:,:) 
     158            ENDIF 
     159#else 
     160            ! No isopycnal diffusion 
     161            zwt(:,:,:) = avt(:,:,:)            
     162#endif 
     163            ! Diagonal, inferior, superior  (including the bottom boundary condition via avt masked) 
     164            DO jk = 1, jpkm1 
     165               DO jj = 2, jpjm1 
     166                  DO ji = fs_2, fs_jpim1   ! vector opt. 
     167                     ze3ta =  ( 1. - znvvl ) +        znvvl   * fse3t_a(ji,jj,jk)   ! after scale factor at T-point 
     168                     ze3tn =         znvvl   + ( 1. - znvvl ) * fse3t_n(ji,jj,jk)   ! now   scale factor at T-point 
     169                     zwi(ji,jj,jk) = - p2dt(jk) * zwt(ji,jj,jk  ) / ( ze3tn * fse3w(ji,jj,jk  ) ) 
     170                     zws(ji,jj,jk) = - p2dt(jk) * zwt(ji,jj,jk+1) / ( ze3tn * fse3w(ji,jj,jk+1) ) 
     171                     zwd(ji,jj,jk) = ze3ta - zwi(ji,jj,jk) - zws(ji,jj,jk) 
     172                 END DO 
     173               END DO 
     174            END DO 
     175            ! Surface boudary conditions 
    140176            DO jj = 2, jpjm1 
    141177               DO ji = fs_2, fs_jpim1   ! vector opt. 
    142                   zavi = fsahtw(ji,jj,jk)                       &   ! vertical mixing coef. due to lateral mixing 
    143                      & * (  wslpi(ji,jj,jk) * wslpi(ji,jj,jk)   & 
    144                      &    + wslpj(ji,jj,jk) * wslpj(ji,jj,jk)  ) 
    145                   zwt(ji,jj,jk) = avt(ji,jj,jk) + zavi              ! zwt=avt+zavi (total vertical mixing coef. on temperature) 
    146 # if defined key_zdfddm 
    147                   zavsi(ji,jj,jk) = fsavs(ji,jj,jk) + zavi          ! dd mixing: zavsi = total vertical mixing coef. on salinity 
    148 # endif 
    149                END DO 
    150             END DO 
    151          END DO 
    152       ELSE                         ! no rotation but key_ldfslp defined 
    153          zwt  (:,:,:) = avt(:,:,:) 
    154 # if defined key_zdfddm 
    155          zavsi(:,:,:) = avs(:,:,:)       ! avs /= avt (double diffusion mixing) 
    156 # endif 
    157       ENDIF    
     178                 ze3ta = ( 1. - znvvl ) +  znvvl * fse3t_a(ji,jj,1)    ! after scale factor at T-point 
     179                 zwi(ji,jj,1) = 0.e0 
     180                 zwd(ji,jj,1) = ze3ta - zws(ji,jj,1) 
     181               END DO 
     182            END DO 
     183            ! 
     184         ELSE IF( ( cdtype == 'TRA' .AND. jn == jp_sal ) .OR. ( cdtype == 'TRC' .AND. jn == 1 ) ) THEN 
     185#if defined key_ldfslp 
     186            ! update and save of avt (and avs if double diffusive mixing) 
     187            IF( l_traldf_rot ) THEN 
     188               DO jk = 2, jpkm1 
     189                  DO jj = 2, jpjm1 
     190                     DO ji = fs_2, fs_jpim1   ! vector opt. 
     191                        zavi = fsahtw(ji,jj,jk)                       &   ! vertical mixing coef. due to lateral mixing 
     192                           & * (  wslpi(ji,jj,jk) * wslpi(ji,jj,jk)   & 
     193                           &    + wslpj(ji,jj,jk) * wslpj(ji,jj,jk)  ) 
     194                        zwt(ji,jj,jk) = fsavs(ji,jj,jk) + zavi              ! zwt=avt+zavi (total vertical mixing coef. on temperature) 
     195                     END DO 
     196                  END DO 
     197               END DO 
     198            ELSE                         ! no rotation but key_ldfslp defined 
     199               zwt  (:,:,:) = fsavs(:,:,:) 
     200            ENDIF 
    158201#else 
    159       ! No isopycnal diffusion 
    160       zwt(:,:,:) = avt(:,:,:) 
    161 # if defined key_zdfddm 
    162       zavsi(:,:,:) = avs(:,:,:) 
    163 # endif 
    164  
     202            ! No isopycnal diffusion 
     203            zwt(:,:,:) = fsavs(:,:,:)            
    165204#endif 
    166  
    167       ! Diagonal, inferior, superior  (including the bottom boundary condition via avt masked) 
    168       DO jk = 1, jpkm1 
    169          DO jj = 2, jpjm1 
    170             DO ji = fs_2, fs_jpim1   ! vector opt. 
    171                ze3ta =  ( 1. - znvvl )   &                            ! after scale factor at T-point 
    172                   &   +        znvvl    * fse3t_a(ji,jj,jk)  
    173                ze3tn =    znvvl          &                            ! now   scale factor at T-point 
    174                   &   + ( 1. - znvvl ) * fse3t_n(ji,jj,jk) 
    175                zwi(ji,jj,jk) = - p2dt(jk) * zwt(ji,jj,jk  ) / ( ze3tn * fse3w(ji,jj,jk  ) ) 
    176                zws(ji,jj,jk) = - p2dt(jk) * zwt(ji,jj,jk+1) / ( ze3tn * fse3w(ji,jj,jk+1) ) 
    177                zwd(ji,jj,jk) = ze3ta - zwi(ji,jj,jk) - zws(ji,jj,jk) 
    178             END DO 
    179          END DO 
    180       END DO 
    181  
    182       ! Surface boudary conditions 
    183       DO jj = 2, jpjm1 
    184          DO ji = fs_2, fs_jpim1   ! vector opt. 
    185             ze3ta = ( 1. - znvvl )        &                           ! after scale factor at T-point 
    186                &   +       znvvl      * fse3t_a(ji,jj,1)  
    187             zwi(ji,jj,1) = 0.e0 
    188             zwd(ji,jj,1) = ze3ta - zws(ji,jj,1) 
    189          END DO 
    190       END DO 
    191  
    192  
    193       ! II.1. Vertical diffusion on t 
    194       ! --------------------------- 
    195  
    196       !! Matrix inversion from the first level 
    197       !!---------------------------------------------------------------------- 
    198       !   solve m.x = y  where m is a tri diagonal matrix ( jpk*jpk ) 
    199       ! 
    200       !        ( zwd1 zws1   0    0    0  )( zwx1 ) ( zwy1 ) 
    201       !        ( zwi2 zwd2 zws2   0    0  )( zwx2 ) ( zwy2 ) 
    202       !        (  0   zwi3 zwd3 zws3   0  )( zwx3 )=( zwy3 ) 
    203       !        (        ...               )( ...  ) ( ...  ) 
    204       !        (  0    0    0   zwik zwdk )( zwxk ) ( zwyk ) 
    205       ! 
    206       !   m is decomposed in the product of an upper and lower triangular matrix 
    207       !   The 3 diagonal terms are in 2d arrays: zwd, zws, zwi 
    208       !   The second member is in 2d array zwy 
    209       !   The solution is in 2d array zwx 
    210       !   The 3d arry zwt is a work space array 
    211       !   zwy is used and then used as a work space array : its value is modified! 
    212  
    213       ! first recurrence:   Tk = Dk - Ik Sk-1 / Tk-1   (increasing k) 
    214       DO jj = 2, jpjm1 
    215          DO ji = fs_2, fs_jpim1 
    216             zwt(ji,jj,1) = zwd(ji,jj,1) 
    217          END DO 
    218       END DO 
    219       DO jk = 2, jpkm1 
     205            ! Diagonal, inferior, superior  (including the bottom boundary condition via avt masked) 
     206            DO jk = 1, jpkm1 
     207               DO jj = 2, jpjm1 
     208                  DO ji = fs_2, fs_jpim1   ! vector opt. 
     209                     ze3ta =  ( 1. - znvvl ) +        znvvl   * fse3t_a(ji,jj,jk)   ! after scale factor at T-point 
     210                     ze3tn =         znvvl   + ( 1. - znvvl ) * fse3t_n(ji,jj,jk)   ! now   scale factor at T-point 
     211                     zwi(ji,jj,jk) = - p2dt(jk) * zwt(ji,jj,jk  ) / ( ze3tn * fse3w(ji,jj,jk  ) ) 
     212                     zws(ji,jj,jk) = - p2dt(jk) * zwt(ji,jj,jk+1) / ( ze3tn * fse3w(ji,jj,jk+1) ) 
     213                     zwd(ji,jj,jk) = ze3ta - zwi(ji,jj,jk) - zws(ji,jj,jk) 
     214                 END DO 
     215               END DO 
     216            END DO 
     217            ! Surface boudary conditions 
     218            DO jj = 2, jpjm1 
     219               DO ji = fs_2, fs_jpim1   ! vector opt. 
     220                 ze3ta = ( 1. - znvvl ) +  znvvl * fse3t_a(ji,jj,1)    ! after scale factor at T-point 
     221                 zwi(ji,jj,1) = 0.e0 
     222                 zwd(ji,jj,1) = ze3ta - zws(ji,jj,1) 
     223               END DO 
     224            END DO 
     225            ! 
     226         END IF 
     227 
     228         ! II.1. Vertical diffusion on tracer 
     229         ! --------------------------- 
     230 
     231         !! Matrix inversion from the first level 
     232         !!---------------------------------------------------------------------- 
     233         !   solve m.x = y  where m is a tri diagonal matrix ( jpk*jpk ) 
     234         ! 
     235         !        ( zwd1 zws1   0    0    0  )( zwx1 ) ( zwy1 ) 
     236         !        ( zwi2 zwd2 zws2   0    0  )( zwx2 ) ( zwy2 ) 
     237         !        (  0   zwi3 zwd3 zws3   0  )( zwx3 )=( zwy3 ) 
     238         !        (        ...               )( ...  ) ( ...  ) 
     239         !        (  0    0    0   zwik zwdk )( zwxk ) ( zwyk ) 
     240         ! 
     241         !   m is decomposed in the product of an upper and lower triangular matrix 
     242         !   The 3 diagonal terms are in 2d arrays: zwd, zws, zwi 
     243         !   The second member is in 2d array zwy 
     244         !   The solution is in 2d array zwx 
     245         !   The 3d arry zwt is a work space array 
     246         !   zwy is used and then used as a work space array : its value is modified! 
     247          
     248         ! first recurrence:   Tk = Dk - Ik Sk-1 / Tk-1   (increasing k) 
    220249         DO jj = 2, jpjm1 
    221250            DO ji = fs_2, fs_jpim1 
    222                zwt(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1)  /zwt(ji,jj,jk-1) 
    223             END DO 
    224          END DO 
    225       END DO 
    226  
    227       ! second recurrence:    Zk = Yk - Ik / Tk-1  Zk-1 
    228       DO jj = 2, jpjm1 
    229          DO ji = fs_2, fs_jpim1 
    230             ze3tb = ( 1. - znvvl ) + znvvl * fse3t_b(ji,jj,1) 
    231             ze3tn = ( 1. - znvvl ) + znvvl * fse3t(ji,jj,1) 
    232             ta(ji,jj,1) = ze3tb * tb(ji,jj,1) + p2dt(1) * ze3tn * ta(ji,jj,1) 
    233          END DO 
    234       END DO 
    235       DO jk = 2, jpkm1 
     251               zwt(ji,jj,1) = zwd(ji,jj,1) 
     252            END DO 
     253         END DO 
     254         DO jk = 2, jpkm1 
     255            DO jj = 2, jpjm1 
     256               DO ji = fs_2, fs_jpim1 
     257                  zwt(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1)  /zwt(ji,jj,jk-1) 
     258               END DO 
     259            END DO 
     260         END DO 
     261          
     262         ! second recurrence:    Zk = Yk - Ik / Tk-1  Zk-1 
    236263         DO jj = 2, jpjm1 
    237264            DO ji = fs_2, fs_jpim1 
    238                ze3tb = ( 1. - znvvl ) + znvvl * fse3t_b(ji,jj,jk) 
    239                ze3tn = ( 1. - znvvl ) + znvvl * fse3t  (ji,jj,jk) 
    240                zrhs = ze3tb * tb(ji,jj,jk) + p2dt(jk) * ze3tn * ta(ji,jj,jk)   ! zrhs=right hand side  
    241                ta(ji,jj,jk) = zrhs - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) * ta(ji,jj,jk-1) 
    242             END DO 
    243          END DO 
    244       END DO 
    245  
    246       ! third recurrence: Xk = (Zk - Sk Xk+1 ) / Tk 
    247       ! Save the masked temperature after in ta 
    248       ! (c a u t i o n:  temperature not its trend, Leap-frog scheme done it will not be done in tranxt) 
    249       DO jj = 2, jpjm1 
    250          DO ji = fs_2, fs_jpim1 
    251             ta(ji,jj,jpkm1) = ta(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) * tmask(ji,jj,jpkm1) 
    252          END DO 
    253       END DO 
    254       DO jk = jpk-2, 1, -1 
     265               ze3tb = ( 1. - znvvl ) + znvvl * fse3t_b(ji,jj,1) 
     266               ze3tn = ( 1. - znvvl ) + znvvl * fse3t(ji,jj,1) 
     267               ptraa(ji,jj,1,jn) = ze3tb * ptrab(ji,jj,1,jn) + p2dt(1) * ze3tn * ptraa(ji,jj,1,jn) 
     268            END DO 
     269         END DO 
     270         DO jk = 2, jpkm1 
     271            DO jj = 2, jpjm1 
     272               DO ji = fs_2, fs_jpim1 
     273                  ze3tb = ( 1. - znvvl ) + znvvl * fse3t_b(ji,jj,jk) 
     274                  ze3tn = ( 1. - znvvl ) + znvvl * fse3t  (ji,jj,jk) 
     275                  zrhs = ze3tb * ptrab(ji,jj,jk,jn) + p2dt(jk) * ze3tn * ptraa(ji,jj,jk,jn)   ! zrhs=right hand side  
     276                  ptraa(ji,jj,jk,jn) = zrhs - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) * ptraa(ji,jj,jk-1,jn) 
     277               END DO 
     278            END DO 
     279         END DO 
     280          
     281         ! third recurrence: Xk = (Zk - Sk Xk+1 ) / Tk 
     282         ! Save the masked temperature after in ta 
     283         ! (c a u t i o n:  temperature not its trend, Leap-frog scheme done it will not be done in tranxt) 
    255284         DO jj = 2, jpjm1 
    256285            DO ji = fs_2, fs_jpim1 
    257                ta(ji,jj,jk) = ( ta(ji,jj,jk) - zws(ji,jj,jk) * ta(ji,jj,jk+1) ) / zwt(ji,jj,jk) * tmask(ji,jj,jk) 
    258             END DO 
    259          END DO 
    260       END DO 
    261  
    262       ! II.2 Vertical diffusion on salinity 
    263       ! ----------------------------------- 
    264  
    265 #if defined key_zdfddm 
    266       ! Rebuild the Matrix as avt /= avs 
    267  
    268       ! Diagonal, inferior, superior  (including the bottom boundary condition via avs masked) 
    269       DO jk = 1, jpkm1 
    270          DO jj = 2, jpjm1 
    271             DO ji = fs_2, fs_jpim1   ! vector opt. 
    272                ze3ta =  ( 1. - znvvl )                        &         ! after scale factor at T-point 
    273                   &   +        znvvl   * fse3t_a(ji,jj,jk)            
    274                ze3tn =    znvvl                               &         ! now   scale factor at T-point 
    275                   &   + ( 1. - znvvl ) * fse3t_n(ji,jj,jk) 
    276                zwi(ji,jj,jk) = - p2dt(jk) * zavsi(ji,jj,jk  ) / ( ze3tn * fse3w(ji,jj,jk  ) ) 
    277                zws(ji,jj,jk) = - p2dt(jk) * zavsi(ji,jj,jk+1) / ( ze3tn * fse3w(ji,jj,jk+1) ) 
    278                zwd(ji,jj,jk) = ze3ta - zwi(ji,jj,jk) - zws(ji,jj,jk) 
    279             END DO 
    280          END DO 
    281       END DO 
    282  
    283       ! Surface boudary conditions 
    284       DO jj = 2, jpjm1 
    285          DO ji = fs_2, fs_jpim1   ! vector opt. 
    286             ze3ta = ( 1. - znvvl ) + znvvl * fse3t_a(ji,jj,1) 
    287             zwi(ji,jj,1) = 0.e0 
    288             zwd(ji,jj,1) = ze3ta - zws(ji,jj,1) 
    289          END DO 
    290       END DO 
    291 #endif 
    292  
    293  
    294       !! Matrix inversion from the first level 
    295       !!---------------------------------------------------------------------- 
    296       !   solve m.x = y  where m is a tri diagonal matrix ( jpk*jpk ) 
    297       ! 
    298       !        ( zwd1 zws1   0    0    0  )( zwx1 ) ( zwy1 ) 
    299       !        ( zwi2 zwd2 zws2   0    0  )( zwx2 ) ( zwy2 ) 
    300       !        (  0   zwi3 zwd3 zws3   0  )( zwx3 )=( zwy3 ) 
    301       !        (        ...               )( ...  ) ( ...  ) 
    302       !        (  0    0    0   zwik zwdk )( zwxk ) ( zwyk ) 
    303       ! 
    304       !   m is decomposed in the product of an upper and lower triangular 
    305       !   matrix 
    306       !   The 3 diagonal terms are in 2d arrays: zwd, zws, zwi 
    307       !   The second member is in 2d array zwy 
    308       !   The solution is in 2d array zwx 
    309       !   The 3d arry zwt is a work space array 
    310       !   zwy is used and then used as a work space array : its value is modified! 
    311  
    312       ! first recurrence:   Tk = Dk - Ik Sk-1 / Tk-1   (increasing k) 
    313       DO jj = 2, jpjm1 
    314          DO ji = fs_2, fs_jpim1 
    315             zwt(ji,jj,1) = zwd(ji,jj,1) 
    316          END DO 
    317       END DO 
    318       DO jk = 2, jpkm1 
    319          DO jj = 2, jpjm1 
    320             DO ji = fs_2, fs_jpim1 
    321                zwt(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1)  /zwt(ji,jj,jk-1) 
    322             END DO 
    323          END DO 
    324       END DO 
    325  
    326       ! second recurrence:    Zk = Yk - Ik / Tk-1  Zk-1 
    327       DO jj = 2, jpjm1 
    328          DO ji = fs_2, fs_jpim1 
    329             ze3tb = ( 1. - znvvl )   &                                           ! before scale factor at T-point 
    330                &   +  znvvl       * fse3t_b(ji,jj,1) 
    331             ze3tn = ( 1. - znvvl ) + znvvl * fse3t  (ji,jj,1)                    ! now    scale factor at T-point 
    332             sa(ji,jj,1) = ze3tb * sb(ji,jj,1) + p2dt(1) * ze3tn * sa(ji,jj,1) 
    333          END DO 
    334       END DO 
    335       DO jk = 2, jpkm1 
    336          DO jj = 2, jpjm1 
    337             DO ji = fs_2, fs_jpim1 
    338                ze3tb = ( 1. - znvvl )   &                                        ! before scale factor at T-point 
    339                   &   +  znvvl       * fse3t_b(ji,jj,jk) 
    340                ze3tn = ( 1. - znvvl ) + znvvl * fse3t  (ji,jj,jk)                ! now    scale factor at T-point 
    341                zrhs = ze3tb * sb(ji,jj,jk) + p2dt(jk) * ze3tn * sa(ji,jj,jk)     ! zrhs=right hand side 
    342                sa(ji,jj,jk) = zrhs - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) *sa(ji,jj,jk-1) 
    343             END DO 
    344          END DO 
    345       END DO 
    346  
    347       ! third recurrence: Xk = (Zk - Sk Xk+1 ) / Tk 
    348       ! Save the masked temperature after in ta 
    349       ! (c a u t i o n:  temperature not its trend, Leap-frog scheme done it will not be done in tranxt) 
    350       DO jj = 2, jpjm1 
    351          DO ji = fs_2, fs_jpim1 
    352             sa(ji,jj,jpkm1) = sa(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) * tmask(ji,jj,jpkm1) 
    353          END DO 
    354       END DO 
    355       DO jk = jpk-2, 1, -1 
    356          DO jj = 2, jpjm1 
    357             DO ji = fs_2, fs_jpim1 
    358                sa(ji,jj,jk) = ( sa(ji,jj,jk) - zws(ji,jj,jk) * sa(ji,jj,jk+1) ) / zwt(ji,jj,jk) * tmask(ji,jj,jk) 
    359             END DO 
    360          END DO 
     286               ptraa(ji,jj,jpkm1,jn) = ptraa(ji,jj,jpkm1,jn) / zwt(ji,jj,jpkm1) * tmask(ji,jj,jpkm1) 
     287            END DO 
     288         END DO 
     289         DO jk = jpk-2, 1, -1 
     290            DO jj = 2, jpjm1 
     291               DO ji = fs_2, fs_jpim1 
     292                  ptraa(ji,jj,jk,jn) = ( ptraa(ji,jj,jk,jn) - zws(ji,jj,jk) * ptraa(ji,jj,jk+1,jn) ) & 
     293                  &                    / zwt(ji,jj,jk) * tmask(ji,jj,jk) 
     294               END DO 
     295            END DO 
     296         END DO 
     297         ! 
    361298      END DO 
    362299      ! 

  • branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/zpshde.F90

    r1152 r2024  
    44   !! z-coordinate - partial step : Horizontal Derivative 
    55   !!============================================================================== 
     6   !! History : 
     7   !!       OPA   8.5  !  2002-04  (A. Bozec)  Original code 
     8   !!             8.5  !  2002-08  (G. Madec E. Durand)  Optimization and Free form 
     9   !!             9.0  !  2004-03  (C. Ethe)  adapted for passive tracers 
     10   !!      NEMO   3.3  !  2010-05  (C. Ethe, G. Madec)  merge TRC-TRA  
     11   !!============================================================================== 
    612    
    713   !!---------------------------------------------------------------------- 
    814   !!   zps_hde      :  Horizontal DErivative of T, S and rd at the last 
     15   !!                   ocean level (Z-coord. with Partial Steps) 
     16   !!   zps_hde_trc  :  Horizontal DErivative of passive tracers at the last 
    917   !!                   ocean level (Z-coord. with Partial Steps) 
    1018   !!---------------------------------------------------------------------- 
    … …  
    2230   !! * Routine accessibility 
    2331   PUBLIC zps_hde          ! routine called by step.F90 
     32   PUBLIC zps_hde_init     ! routine called by opa.F90 
     33#if defined key_top 
     34   PUBLIC zps_hde_trc  
     35#endif 
    2436 
    2537   !! * module variables 
    … …  
    3749   !!---------------------------------------------------------------------- 
    3850CONTAINS 
    39  
    4051   SUBROUTINE zps_hde ( kt, ptem, psal, prd ,   & 
    4152                            pgtu, pgsu, pgru,   & 
    … …  
    8495      !!              - pgtv, pgsv, pgrv: horizontal gradient of T, S 
    8596      !!                and rd at V-points  
    86       !! 
    87       !! History : 
    88       !!   8.5  !  02-04  (A. Bozec)  Original code 
    89       !!   8.5  !  02-08  (G. Madec E. Durand)  Optimization and Free form 
    9097      !!---------------------------------------------------------------------- 
    9198      !! * Arguments 
    9299      INTEGER, INTENT( in ) ::   kt ! ocean time-step index 
    93       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( in ) ::   & 
    94          ptem, psal, prd            ! 3D T, S and rd fields 
    95       REAL(wp), DIMENSION(jpi,jpj), INTENT( out ) ::   & 
    96          pgtu, pgsu, pgru,       &  ! horizontal grad. of T, S and rd at u-  
    97          pgtv, pgsv, pgrv           ! and v-points of the partial step level 
    98  
     100      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( in )  :: ptem, psal, prd  ! 3D T, S and rd fields 
     101      REAL(wp), DIMENSION(jpi,jpj)    , INTENT( out ) :: pgtu, pgsu, pgru !  horizontal grad. of T, S and rd at u-point  
     102      REAL(wp), DIMENSION(jpi,jpj)    , INTENT( out ) :: pgtv, pgsv, pgrv !  horizontal grad. of T, S and rd at v-point  
    99103      !! * Local declarations 
    100       INTEGER ::   ji, jj,       &  ! Dummy loop indices 
    101                    iku,ikv          ! partial step level at u- and v-points 
    102       REAL(wp), DIMENSION(jpi,jpj) ::   & 
    103          zti, ztj, zsi, zsj,     &  ! interpolated value of T, S  
    104          zri, zrj,               &  ! and rd 
    105          zhgi, zhgj                 ! depth of interpolation for eos2d 
    106       REAL(wp) ::   & 
    107          ze3wu, ze3wv,           &  ! temporary scalars 
    108          zmaxu1, zmaxu2,         &  !    "         " 
    109          zmaxv1, zmaxv2             !    "         " 
    110  
    111       ! Initialization (first time-step only): compute mbatu and mbatv 
    112       IF( kt == nit000 ) THEN 
    113          mbatu(:,:) = 0 
    114          mbatv(:,:) = 0 
    115          DO jj = 1, jpjm1 
    116             DO ji = 1, fs_jpim1   ! vector opt. 
    117                mbatu(ji,jj) = MAX( MIN( mbathy(ji,jj), mbathy(ji+1,jj  ) ) - 1, 2 ) 
    118                mbatv(ji,jj) = MAX( MIN( mbathy(ji,jj), mbathy(ji  ,jj+1) ) - 1, 2 ) 
    119             END DO 
    120          END DO 
    121          zti(:,:) = FLOAT( mbatu(:,:) ) 
    122          ztj(:,:) = FLOAT( mbatv(:,:) ) 
    123          ! lateral boundary conditions: T-point, sign unchanged 
    124          CALL lbc_lnk( zti , 'U', 1. ) 
    125          CALL lbc_lnk( ztj , 'V', 1. ) 
    126          mbatu(:,:) = MAX( INT( zti(:,:) ), 2 ) 
    127          mbatv(:,:) = MAX( INT( ztj(:,:) ), 2 ) 
    128       ENDIF 
    129        
     104      INTEGER ::   ji , jj          ! Dummy loop indices 
     105      INTEGER ::   iku, ikv         ! partial step level at u- and v-points 
     106      REAL(wp), DIMENSION(jpi,jpj) ::   zti, ztj, zsi, zsj   ! interpolated value of T, S 
     107      REAL(wp), DIMENSION(jpi,jpj) ::   zri, zrj             ! interpolated value of rd 
     108      REAL(wp), DIMENSION(jpi,jpj) ::   zhgi, zhgj           ! depth of interpolation for eos2d 
     109      REAL(wp) :: ze3wu, ze3wv, zmaxu, zmaxv                 ! temporary scalars 
     110 
    130111 
    131112      ! Interpolation of T and S at the last ocean level 
    … …  
    140121            iku = mbatu(ji,jj) 
    141122            ikv = mbatv(ji,jj) 
    142  
    143123            ze3wu  = fse3w(ji+1,jj  ,iku) - fse3w(ji,jj,iku) 
    144124            ze3wv  = fse3w(ji  ,jj+1,ikv) - fse3w(ji,jj,ikv) 
    145             zmaxu1 =  ze3wu / fse3w(ji+1,jj  ,iku) 
    146             zmaxu2 = -ze3wu / fse3w(ji  ,jj  ,iku) 
    147             zmaxv1 =  ze3wv / fse3w(ji  ,jj+1,ikv) 
    148             zmaxv2 = -ze3wv / fse3w(ji  ,jj  ,ikv) 
    149125 
    150126            ! i- direction 
    151  
    152127            IF( ze3wu >= 0. ) THEN      ! case 1 
    153128               ! interpolated values of T and S 
    154                zti(ji,jj) = ptem(ji+1,jj,iku) + zmaxu1 * ( ptem(ji+1,jj,iku-1) - ptem(ji+1,jj,iku) ) 
    155                zsi(ji,jj) = psal(ji+1,jj,iku) + zmaxu1 * ( psal(ji+1,jj,iku-1) - psal(ji+1,jj,iku) ) 
     129               zmaxu =  ze3wu / fse3w(ji+1,jj,iku) 
     130               zti(ji,jj) = ptem(ji+1,jj,iku) + zmaxu * ( ptem(ji+1,jj,iku-1) - ptem(ji+1,jj,iku) ) 
     131               zsi(ji,jj) = psal(ji+1,jj,iku) + zmaxu * ( psal(ji+1,jj,iku-1) - psal(ji+1,jj,iku) ) 
    156132               ! depth of the partial step level 
    157133               zhgi(ji,jj) = fsdept(ji,jj,iku) 
    … …  
    162138            ELSE                        ! case 2 
    163139               ! interpolated values of T and S 
    164                zti(ji,jj) = ptem(ji,jj,iku) + zmaxu2 * ( ptem(ji,jj,iku-1) - ptem(ji,jj,iku) ) 
    165                zsi(ji,jj) = psal(ji,jj,iku) + zmaxu2 * ( psal(ji,jj,iku-1) - psal(ji,jj,iku) ) 
     140               zmaxu =  -ze3wu / fse3w(ji,jj,iku) 
     141               zti(ji,jj) = ptem(ji,jj,iku) + zmaxu * ( ptem(ji,jj,iku-1) - ptem(ji,jj,iku) ) 
     142               zsi(ji,jj) = psal(ji,jj,iku) + zmaxu * ( psal(ji,jj,iku-1) - psal(ji,jj,iku) ) 
    166143               ! depth of the partial step level 
    167144               zhgi(ji,jj) = fsdept(ji+1,jj,iku) 
    … …  
    172149 
    173150            ! j- direction 
    174  
    175151            IF( ze3wv >= 0. ) THEN      ! case 1 
    176152               ! interpolated values of T and S 
    177                ztj(ji,jj) = ptem(ji,jj+1,ikv) + zmaxv1 * ( ptem(ji,jj+1,ikv-1) - ptem(ji,jj+1,ikv) ) 
    178                zsj(ji,jj) = psal(ji,jj+1,ikv) + zmaxv1 * ( psal(ji,jj+1,ikv-1) - psal(ji,jj+1,ikv) ) 
     153               zmaxv =  ze3wv / fse3w(ji,jj+1,ikv) 
     154               ztj(ji,jj) = ptem(ji,jj+1,ikv) + zmaxv * ( ptem(ji,jj+1,ikv-1) - ptem(ji,jj+1,ikv) ) 
     155               zsj(ji,jj) = psal(ji,jj+1,ikv) + zmaxv * ( psal(ji,jj+1,ikv-1) - psal(ji,jj+1,ikv) ) 
    179156               ! depth of the partial step level 
    180157               zhgj(ji,jj) = fsdept(ji,jj,ikv)  
    … …  
    185162            ELSE                        ! case 2 
    186163               ! interpolated values of T and S 
    187                ztj(ji,jj) = ptem(ji,jj,ikv) + zmaxv2 * ( ptem(ji,jj,ikv-1) - ptem(ji,jj,ikv) ) 
    188                zsj(ji,jj) = psal(ji,jj,ikv) + zmaxv2 * ( psal(ji,jj,ikv-1) - psal(ji,jj,ikv) )  
     164               zmaxv =  -ze3wv / fse3w(ji,jj,ikv) 
     165               ztj(ji,jj) = ptem(ji,jj,ikv) + zmaxv * ( ptem(ji,jj,ikv-1) - ptem(ji,jj,ikv) ) 
     166               zsj(ji,jj) = psal(ji,jj,ikv) + zmaxv * ( psal(ji,jj,ikv-1) - psal(ji,jj,ikv) )  
    189167               ! depth of the partial step level 
    190168               zhgj(ji,jj) = fsdept(ji,jj+1,ikv)  
    … …  
    238216   END SUBROUTINE zps_hde 
    239217 
     218#if defined key_top 
     219   !!---------------------------------------------------------------------- 
     220   !!   'key_top'                                                TOP models 
     221   !!---------------------------------------------------------------------- 
     222   SUBROUTINE zps_hde_trc ( kt, kjpt, ptra, pgtru, pgtrv ) 
     223      !!---------------------------------------------------------------------- 
     224      !!                     ***  ROUTINE zps_hde_trc  *** 
     225      !!                     
     226      !! ** Purpose :   Compute the horizontal derivative of passive tracers 
     227      !!      TRA at u- and v-points with a linear interpolation for z-coordinate 
     228      !!      with partial steps. 
     229      !! 
     230      !! ** Method  :   the same for T & S 
     231      !! 
     232      !! ** Action  : - pgtru : horizontal gradient of TRA at U-points  
     233      !!              - pgtrv : horizontal gradient of TRA at V-points  
     234      !!---------------------------------------------------------------------- 
     235      !! * Arguments 
     236      INTEGER                              , INTENT( in )  ::  kt    ! ocean time-step index 
     237      INTEGER                              , INTENT( in )  ::  kjpt  ! number of tracers 
     238      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT( in )  ::  ptra  ! 4D tracers fields 
     239      REAL(wp), DIMENSION(jpi,jpj,    kjpt), INTENT( out ) ::  pgtru, pgtrv  ! horizontal grad. of TRA u- and v-points  
     240      !! * Local declarations 
     241      INTEGER  ::   ji, jj, jn      ! Dummy loop indices 
     242      INTEGER  ::   iku, ikv        ! partial step level at u- and v-points 
     243      REAL(wp) ::   ztrai, ztraj, ze3wu, ze3wv, zmaxu, zmaxv  ! temporary scalars 
     244      !!---------------------------------------------------------------------- 
     245 
     246      DO jn = 1, kjpt 
     247         ! Interpolation of passive tracers at the last ocean level 
     248# if defined key_vectopt_loop 
     249         jj = 1 
     250         DO ji = 1, jpij-jpi   ! vector opt. (forced unrolled) 
     251# else 
     252         DO jj = 1, jpjm1 
     253            DO ji = 1, jpim1 
     254# endif 
     255               ! last level 
     256               iku = mbatu(ji,jj) 
     257               ikv = mbatv(ji,jj) 
     258               ze3wu  = fse3w(ji+1,jj  ,iku) - fse3w(ji,jj,iku) 
     259               ze3wv  = fse3w(ji  ,jj+1,ikv) - fse3w(ji,jj,ikv) 
     260 
     261               ! i- direction 
     262               IF( ze3wu >= 0. ) THEN      ! case 1 
     263                  zmaxu =  ze3wu / fse3w(ji+1,jj,iku) 
     264                  ! interpolated values of passive tracers 
     265                  ztrai = ptra(ji+1,jj,iku,jn) + zmaxu * ( ptra(ji+1,jj,iku-1,jn) - ptra(ji+1,jj,iku,jn) ) 
     266                  ! gradient of passive tracers 
     267                  pgtru(ji,jj,jn) = umask(ji,jj,1) * ( ztrai - ptra(ji,jj,iku,jn) ) 
     268               ELSE                        ! case 2 
     269                  zmaxu = -ze3wu / fse3w(ji,jj,iku) 
     270                  ! interpolated values of passive tracers 
     271                  ztrai = ptra(ji,jj,iku,jn) + zmaxu * ( ptra(ji,jj,iku-1,jn) - ptra(ji,jj,iku,jn) ) 
     272                  ! gradient of passive tracers 
     273                  pgtru(ji,jj,jn) = umask(ji,jj,1) * ( ptra(ji+1,jj,iku,jn) - ztrai ) 
     274               ENDIF 
     275 
     276               ! j- direction 
     277               IF( ze3wv >= 0. ) THEN      ! case 1 
     278                  zmaxv =  ze3wv / fse3w(ji,jj+1,ikv) 
     279                  ! interpolated values of passive tracers 
     280                  ztraj = ptra(ji,jj+1,ikv,jn) + zmaxv * ( ptra(ji,jj+1,ikv-1,jn) - ptra(ji,jj+1,ikv,jn) ) 
     281                  ! gradient of passive tracers 
     282                  pgtrv(ji,jj,jn) = vmask(ji,jj,1) * ( ztraj - ptra(ji,jj,ikv,jn) ) 
     283               ELSE                        ! case 2 
     284                  zmaxv =  -ze3wv / fse3w(ji,jj,ikv) 
     285                  ! interpolated values of passive tracers 
     286                  ztraj = ptra(ji,jj,ikv,jn) + zmaxv * ( ptra(ji,jj,ikv-1,jn) - ptra(ji,jj,ikv,jn) ) 
     287                  ! gradient of passive tracers 
     288                  pgtrv(ji,jj,jn) = vmask(ji,jj,1) * ( ptra(ji,jj+1,ikv,jn) - ztraj ) 
     289               ENDIF 
     290# if ! defined key_vectopt_loop 
     291            END DO 
     292# endif 
     293         END DO 
     294 
     295         ! Lateral boundary conditions on each gradient 
     296         CALL lbc_lnk( pgtru(:,:,jn) , 'U', -1. ) 
     297         CALL lbc_lnk( pgtrv(:,:,jn) , 'V', -1. ) 
     298 
     299      END DO 
     300 
     301   END SUBROUTINE zps_hde_trc 
     302#endif 
     303 
     304   SUBROUTINE zps_hde_init 
     305      !!---------------------------------------------------------------------- 
     306      !!                     ***  ROUTINE zps_hde_init  *** 
     307      !! 
     308      !! ** Purpose : Computation of bottom ocean level index at U- and V-points  
     309      !!                     
     310      !!---------------------------------------------------------------------- 
     311      !! * Local declarations 
     312      INTEGER ::   ji, jj           ! Dummy loop indices 
     313      REAL(wp), DIMENSION(jpi,jpj) :: zti, ztj     !  temporary arrays  
     314      !!---------------------------------------------------------------------- 
     315 
     316      mbatu(:,:) = 0 
     317      mbatv(:,:) = 0 
     318      DO jj = 1, jpjm1 
     319         DO ji = 1, fs_jpim1   ! vector opt. 
     320            mbatu(ji,jj) = MAX( MIN( mbathy(ji,jj), mbathy(ji+1,jj  ) ) - 1, 2 ) 
     321            mbatv(ji,jj) = MAX( MIN( mbathy(ji,jj), mbathy(ji  ,jj+1) ) - 1, 2 ) 
     322         END DO 
     323      END DO 
     324      zti(:,:) = FLOAT( mbatu(:,:) ) 
     325      ztj(:,:) = FLOAT( mbatv(:,:) ) 
     326      ! lateral boundary conditions: T-point, sign unchanged 
     327      CALL lbc_lnk( zti , 'U', 1. ) 
     328      CALL lbc_lnk( ztj , 'V', 1. ) 
     329      mbatu(:,:) = MAX( INT( zti(:,:) ), 2 ) 
     330      mbatv(:,:) = MAX( INT( ztj(:,:) ), 2 ) 
     331 
     332   END SUBROUTINE zps_hde_init 
    240333   !!====================================================================== 
    241334END MODULE zpshde 
Note: See TracChangeset for help on using the changeset viewer.