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 6808 for branches/NERC/dev_r5549_BDY_ZEROGRAD/NEMOGCM/NEMO/OPA_SRC/TRA – NEMO

Ignore:
Timestamp:
2016-07-19T10:38:35+02:00 (8 years ago)
Author:
jamesharle
Message:

merge with trunk@6232 for consistency with SSB code

Location:
branches/NERC/dev_r5549_BDY_ZEROGRAD/NEMOGCM/NEMO/OPA_SRC/TRA
Files:
9 deleted
18 edited
5 copied

Legend:

Unmodified
Added
Removed

  • branches/NERC/dev_r5549_BDY_ZEROGRAD/NEMOGCM/NEMO/OPA_SRC/TRA/eosbn2.F90

    r5541 r6808  
    22   !!============================================================================== 
    33   !!                       ***  MODULE  eosbn2  *** 
    4    !! Ocean diagnostic variable : equation of state - in situ and potential density 
    5    !!                                               - Brunt-Vaisala frequency 
     4   !! Equation Of Seawater : in situ density - Brunt-Vaisala frequency 
    65   !!============================================================================== 
    76   !! History :  OPA  ! 1989-03  (O. Marti)  Original code 
    … …  
    2625 
    2726   !!---------------------------------------------------------------------- 
    28    !!   eos            : generic interface of the equation of state 
    29    !!   eos_insitu     : Compute the in situ density 
    30    !!   eos_insitu_pot : Compute the insitu and surface referenced potential volumic mass 
    31    !!   eos_insitu_2d  : Compute the in situ density for 2d fields 
    32    !!   bn2            : Compute the Brunt-Vaisala frequency 
    33    !!   eos_rab        : generic interface of in situ thermal/haline expansion ratio  
    34    !!   eos_rab_3d     : compute in situ thermal/haline expansion ratio 
    35    !!   eos_rab_2d     : compute in situ thermal/haline expansion ratio for 2d fields 
    36    !!   eos_fzp_2d     : freezing temperature for 2d fields 
    37    !!   eos_fzp_0d     : freezing temperature for scalar 
    38    !!   eos_init       : set eos parameters (namelist) 
     27   !!   eos           : generic interface of the equation of state 
     28   !!   eos_insitu    : Compute the in situ density 
     29   !!   eos_insitu_pot: Compute the insitu and surface referenced potential volumic mass 
     30   !!   eos_insitu_2d : Compute the in situ density for 2d fields 
     31   !!   bn2           : Compute the Brunt-Vaisala frequency 
     32   !!   eos_rab       : generic interface of in situ thermal/haline expansion ratio  
     33   !!   eos_rab_3d    : compute in situ thermal/haline expansion ratio 
     34   !!   eos_rab_2d    : compute in situ thermal/haline expansion ratio for 2d fields 
     35   !!   eos_fzp_2d    : freezing temperature for 2d fields 
     36   !!   eos_fzp_0d    : freezing temperature for scalar 
     37   !!   eos_init      : set eos parameters (namelist) 
    3938   !!---------------------------------------------------------------------- 
    40    USE dom_oce         ! ocean space and time domain 
    41    USE phycst          ! physical constants 
     39   USE dom_oce        ! ocean space and time domain 
     40   USE phycst         ! physical constants 
     41   USE stopar         ! Stochastic T/S fluctuations 
     42   USE stopts         ! Stochastic T/S fluctuations 
    4243   ! 
    43    USE in_out_manager  ! I/O manager 
    44    USE lib_mpp         ! MPP library 
    45    USE lib_fortran     ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)   
    46    USE prtctl          ! Print control 
    47    USE wrk_nemo        ! Memory Allocation 
     44   USE in_out_manager ! I/O manager 
     45   USE lib_mpp        ! MPP library 
     46   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)   
     47   USE prtctl         ! Print control 
     48   USE wrk_nemo       ! Memory Allocation 
    4849   USE lbclnk         ! ocean lateral boundary conditions 
    49    USE timing          ! Timing 
    50    USE stopar          ! Stochastic T/S fluctuations 
    51    USE stopts          ! Stochastic T/S fluctuations 
     50   USE timing         ! Timing 
    5251 
    5352   IMPLICIT NONE 
    5453   PRIVATE 
    5554 
    56    !                   !! * Interface 
     55   !                  !! * Interface 
    5756   INTERFACE eos 
    5857      MODULE PROCEDURE eos_insitu, eos_insitu_pot, eos_insitu_2d 
    … …  
    7574   PUBLIC   eos_init       ! called by istate module 
    7675 
    77    !                                !!* Namelist (nameos) * 
     76   !                               !!** Namelist nameos ** 
    7877   INTEGER , PUBLIC ::   nn_eos     ! = 0/1/2 type of eq. of state and Brunt-Vaisala frequ. 
    7978   LOGICAL , PUBLIC ::   ln_useCT   ! determine if eos_pt_from_ct is used to compute sst_m 
    8079 
    81    !                                   !!!  simplified eos coefficients 
    82    ! default value: Vallis 2006 
     80   !                               !!!  simplified eos coefficients (default value: Vallis 2006) 
    8381   REAL(wp) ::   rn_a0      = 1.6550e-1_wp     ! thermal expansion coeff.  
    8482   REAL(wp) ::   rn_b0      = 7.6554e-1_wp     ! saline  expansion coeff.  
    … …  
    172170 
    173171   !! * Substitutions 
    174 #  include "domzgr_substitute.h90" 
    175172#  include "vectopt_loop_substitute.h90" 
    176173   !!---------------------------------------------------------------------- 
    … …  
    587584               DO ji = 1, jpi 
    588585                  ! 
    589                   zh  = fsdept(ji,jj,jk) * r1_Z0                                ! depth 
     586                  zh  = gdept_n(ji,jj,jk) * r1_Z0                                ! depth 
    590587                  zt  = pts (ji,jj,jk,jp_tem) * r1_T0                           ! temperature 
    591588                  zs  = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity 
    … …  
    645642                  zt  = pts (ji,jj,jk,jp_tem) - 10._wp   ! pot. temperature anomaly (t-T0) 
    646643                  zs  = pts (ji,jj,jk,jp_sal) - 35._wp   ! abs. salinity anomaly (s-S0) 
    647                   zh  = fsdept(ji,jj,jk)                 ! depth in meters at t-point 
     644                  zh  = gdept_n(ji,jj,jk)                ! depth in meters at t-point 
    648645                  ztm = tmask(ji,jj,jk)                  ! land/sea bottom mask = surf. mask 
    649646                  ! 
    … …  
    913910         DO jj = 1, jpj          ! surface and bottom value set to zero one for all in istate.F90 
    914911            DO ji = 1, jpi 
    915                zrw =   ( fsdepw(ji,jj,jk  ) - fsdept(ji,jj,jk) )   & 
    916                   &  / ( fsdept(ji,jj,jk-1) - fsdept(ji,jj,jk) )  
     912               zrw =   ( gdepw_n(ji,jj,jk  ) - gdept_n(ji,jj,jk) )   & 
     913                  &  / ( gdept_n(ji,jj,jk-1) - gdept_n(ji,jj,jk) )  
    917914                  ! 
    918915               zaw = pab(ji,jj,jk,jp_tem) * (1. - zrw) + pab(ji,jj,jk-1,jp_tem) * zrw  
    … …  
    921918               pn2(ji,jj,jk) = grav * (  zaw * ( pts(ji,jj,jk-1,jp_tem) - pts(ji,jj,jk,jp_tem) )     & 
    922919                  &                    - zbw * ( pts(ji,jj,jk-1,jp_sal) - pts(ji,jj,jk,jp_sal) )  )  & 
    923                   &            / fse3w(ji,jj,jk) * tmask(ji,jj,jk) 
     920                  &            / e3w_n(ji,jj,jk) * tmask(ji,jj,jk) 
    924921            END DO 
    925922         END DO 
    … …  
    11291126               DO ji = 1, jpi 
    11301127                  ! 
    1131                   zh  = fsdept(ji,jj,jk) * r1_Z0                                ! depth 
     1128                  zh  = gdept_n(ji,jj,jk) * r1_Z0                                ! depth 
    11321129                  zt  = pts (ji,jj,jk,jp_tem) * r1_T0                           ! temperature 
    11331130                  zs  = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity 
    … …  
    11931190                  zt  = pts(ji,jj,jk,jp_tem) - 10._wp  ! temperature anomaly (t-T0) 
    11941191                  zs = pts (ji,jj,jk,jp_sal) - 35._wp  ! abs. salinity anomaly (s-S0) 
    1195                   zh  = fsdept(ji,jj,jk)               ! depth in meters  at t-point 
     1192                  zh  = gdept_n(ji,jj,jk)              ! depth in meters  at t-point 
    11961193                  ztm = tmask(ji,jj,jk)                ! tmask 
    11971194                  zn  = 0.5_wp * zh * r1_rau0 * ztm 

  • branches/NERC/dev_r5549_BDY_ZEROGRAD/NEMOGCM/NEMO/OPA_SRC/TRA/traadv.F90

    r5147 r6808  
    66   !! History :  2.0  !  2005-11  (G. Madec)  Original code 
    77   !!            3.3  !  2010-09  (C. Ethe, G. Madec)  merge TRC-TRA + switch from velocity to transport 
    8    !!            4.0  !  2011-06  (G. Madec)  Addition of Mixed Layer Eddy parameterisation 
    9    !!---------------------------------------------------------------------- 
    10  
    11    !!---------------------------------------------------------------------- 
    12    !!   tra_adv      : compute ocean tracer advection trend 
    13    !!   tra_adv_ctl  : control the different options of advection scheme 
    14    !!---------------------------------------------------------------------- 
    15    USE oce             ! ocean dynamics and active tracers 
    16    USE dom_oce         ! ocean space and time domain 
    17    USE domvvl          ! variable vertical scale factors 
    18    USE traadv_cen2     ! 2nd order centered scheme (tra_adv_cen2   routine) 
    19    USE traadv_tvd      ! TVD      scheme           (tra_adv_tvd    routine) 
    20    USE traadv_muscl    ! MUSCL    scheme           (tra_adv_muscl  routine) 
    21    USE traadv_muscl2   ! MUSCL2   scheme           (tra_adv_muscl2 routine) 
    22    USE traadv_ubs      ! UBS      scheme           (tra_adv_ubs    routine) 
    23    USE traadv_qck      ! QUICKEST scheme           (tra_adv_qck    routine) 
    24    USE traadv_eiv      ! eddy induced velocity     (tra_adv_eiv    routine) 
    25    USE traadv_mle      ! ML eddy induced velocity  (tra_adv_mle    routine) 
    26    USE cla             ! cross land advection      (cla_traadv     routine) 
    27    USE ldftra_oce      ! lateral diffusion coefficient on tracers 
     8   !!            3.6  !  2011-06  (G. Madec)  Addition of Mixed Layer Eddy parameterisation 
     9   !!            3.7  !  2014-05  (G. Madec)  Add 2nd/4th order cases for CEN and FCT schemes  
     10   !!             -   !  2014-12  (G. Madec) suppression of cross land advection option 
     11   !!---------------------------------------------------------------------- 
     12 
     13   !!---------------------------------------------------------------------- 
     14   !!   tra_adv       : compute ocean tracer advection trend 
     15   !!   tra_adv_ctl   : control the different options of advection scheme 
     16   !!---------------------------------------------------------------------- 
     17   USE oce            ! ocean dynamics and active tracers 
     18   USE dom_oce        ! ocean space and time domain 
     19   USE domvvl         ! variable vertical scale factors 
     20   USE traadv_cen     ! centered scheme           (tra_adv_cen  routine) 
     21   USE traadv_fct     ! FCT      scheme           (tra_adv_fct routine) 
     22   USE traadv_mus     ! MUSCL    scheme           (tra_adv_mus  routine) 
     23   USE traadv_ubs     ! UBS      scheme           (tra_adv_ubs  routine) 
     24   USE traadv_qck     ! QUICKEST scheme           (tra_adv_qck  routine) 
     25   USE traadv_mle     ! ML eddy induced velocity  (tra_adv_mle  routine) 
     26   USE ldftra         ! lateral diffusion: eddy diffusivity & EIV coeff. 
     27   USE ldfslp         ! Lateral diffusion: slopes of neutral surfaces 
    2828   ! 
    29    USE in_out_manager  ! I/O manager 
    30    USE iom             ! I/O module 
    31    USE prtctl          ! Print control 
    32    USE lib_mpp         ! MPP library 
    33    USE wrk_nemo        ! Memory Allocation 
    34    USE timing          ! Timing 
    35    USE sbc_oce 
     29   USE in_out_manager ! I/O manager 
     30   USE iom            ! I/O module 
     31   USE prtctl         ! Print control 
     32   USE lib_mpp        ! MPP library 
     33   USE wrk_nemo       ! Memory Allocation 
     34   USE timing         ! Timing 
     35 
    3636   USE diaptr          ! Poleward heat transport  
    37  
    3837 
    3938   IMPLICIT NONE 
    … …  
    4342   PUBLIC   tra_adv_init   ! routine called by opa module 
    4443 
    45    !                              !!* Namelist namtra_adv * 
    46    LOGICAL ::   ln_traadv_cen2     ! 2nd order centered scheme flag 
    47    LOGICAL ::   ln_traadv_tvd      ! TVD scheme flag 
    48    LOGICAL ::   ln_traadv_tvd_zts  ! TVD scheme flag with vertical sub time-stepping 
    49    LOGICAL ::   ln_traadv_muscl    ! MUSCL scheme flag 
    50    LOGICAL ::   ln_traadv_muscl2   ! MUSCL2 scheme flag 
    51    LOGICAL ::   ln_traadv_ubs      ! UBS scheme flag 
    52    LOGICAL ::   ln_traadv_qck      ! QUICKEST scheme flag 
    53    LOGICAL ::   ln_traadv_msc_ups  ! use upstream scheme within muscl 
    54  
    55  
    56    INTEGER ::   nadv   ! choice of the type of advection scheme 
    57  
     44   !                            !!* Namelist namtra_adv * 
     45   LOGICAL ::   ln_traadv_cen    ! centered scheme flag 
     46   INTEGER ::      nn_cen_h, nn_cen_v   ! =2/4 : horizontal and vertical choices of the order of CEN scheme 
     47   LOGICAL ::   ln_traadv_fct    ! FCT scheme flag 
     48   INTEGER ::      nn_fct_h, nn_fct_v   ! =2/4 : horizontal and vertical choices of the order of FCT scheme 
     49   INTEGER ::      nn_fct_zts           ! >=1 : 2nd order FCT with vertical sub-timestepping 
     50   LOGICAL ::   ln_traadv_mus    ! MUSCL scheme flag 
     51   LOGICAL ::      ln_mus_ups           ! use upstream scheme in vivcinity of river mouths 
     52   LOGICAL ::   ln_traadv_ubs    ! UBS scheme flag 
     53   INTEGER ::      nn_ubs_v             ! =2/4 : vertical choice of the order of UBS scheme 
     54   LOGICAL ::   ln_traadv_qck    ! QUICKEST scheme flag 
     55 
     56   INTEGER ::              nadv             ! choice of the type of advection scheme 
     57   ! 
     58   !                                        ! associated indices: 
     59   INTEGER, PARAMETER ::   np_NO_adv  = 0   ! no T-S advection 
     60   INTEGER, PARAMETER ::   np_CEN     = 1   ! 2nd/4th order centered scheme 
     61   INTEGER, PARAMETER ::   np_FCT     = 2   ! 2nd/4th order Flux Corrected Transport scheme 
     62   INTEGER, PARAMETER ::   np_FCT_zts = 3   ! 2nd order FCT scheme with vertical sub-timestepping 
     63   INTEGER, PARAMETER ::   np_MUS     = 4   ! MUSCL scheme 
     64   INTEGER, PARAMETER ::   np_UBS     = 5   ! 3rd order Upstream Biased Scheme 
     65   INTEGER, PARAMETER ::   np_QCK     = 6   ! QUICK scheme 
     66    
    5867   !! * Substitutions 
    59 #  include "domzgr_substitute.h90" 
    6068#  include "vectopt_loop_substitute.h90" 
    6169   !!---------------------------------------------------------------------- 
    62    !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
     70   !! NEMO/OPA 3.7 , NEMO Consortium (2014) 
    6371   !! $Id$ 
    6472   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    … …  
    7482      !! ** Method  : - Update (ua,va) with the advection term following nadv 
    7583      !!---------------------------------------------------------------------- 
    76       ! 
    7784      INTEGER, INTENT( in ) ::   kt   ! ocean time-step index 
    7885      ! 
    … …  
    8390      IF( nn_timing == 1 )  CALL timing_start('tra_adv') 
    8491      ! 
    85       CALL wrk_alloc( jpi, jpj, jpk, zun, zvn, zwn ) 
     92      CALL wrk_alloc( jpi,jpj,jpk,   zun, zvn, zwn ) 
     93      ! 
    8694      !                                          ! set time step 
    8795      IF( neuler == 0 .AND. kt == nit000 ) THEN     ! at nit000 
    88          r2dtra(:) =  rdttra(:)                          ! = rdtra (restarting with Euler time stepping) 
     96         r2dt = rdt                                 ! = rdt (restarting with Euler time stepping) 
    8997      ELSEIF( kt <= nit000 + 1) THEN                ! at nit000 or nit000+1 
    90          r2dtra(:) = 2._wp * rdttra(:)                   ! = 2 rdttra (leapfrog) 
    91       ENDIF 
    92       ! 
    93       IF( nn_cla == 1 .AND. cp_cfg == 'orca' .AND. jp_cfg == 2 )   CALL cla_traadv( kt )       !==  Cross Land Advection  ==! (hor. advection) 
    94       ! 
    95       !                                               !==  effective transport  ==! 
     98         r2dt = 2._wp * rdt                         ! = 2 rdt (leapfrog) 
     99      ENDIF 
     100      ! 
     101      !                                         !==  effective transport  ==! 
    96102      DO jk = 1, jpkm1 
    97          zun(:,:,jk) = e2u(:,:) * fse3u(:,:,jk) * un(:,:,jk)                  ! eulerian transport only 
    98          zvn(:,:,jk) = e1v(:,:) * fse3v(:,:,jk) * vn(:,:,jk) 
    99          zwn(:,:,jk) = e1t(:,:) * e2t(:,:)      * wn(:,:,jk) 
     103         zun(:,:,jk) = e2u  (:,:) * e3u_n(:,:,jk) * un(:,:,jk)                  ! eulerian transport only 
     104         zvn(:,:,jk) = e1v  (:,:) * e3v_n(:,:,jk) * vn(:,:,jk) 
     105         zwn(:,:,jk) = e1e2t(:,:)                 * wn(:,:,jk) 
    100106      END DO 
    101107      ! 
    102       IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN 
     108      IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN                                ! add z-tilde and/or vvl corrections 
    103109         zun(:,:,:) = zun(:,:,:) + un_td(:,:,:) 
    104110         zvn(:,:,:) = zvn(:,:,:) + vn_td(:,:,:) 
    105111      ENDIF 
    106112      ! 
    107       zun(:,:,jpk) = 0._wp                                                     ! no transport trough the bottom 
    108       zvn(:,:,jpk) = 0._wp                                                     ! no transport trough the bottom 
    109       zwn(:,:,jpk) = 0._wp                                                     ! no transport trough the bottom 
    110       ! 
    111       IF( lk_traldf_eiv .AND. .NOT. ln_traldf_grif )   & 
    112          &              CALL tra_adv_eiv( kt, nit000, zun, zvn, zwn, 'TRA' )    ! add the eiv transport (if necessary) 
    113       ! 
    114       IF( ln_mle    )   CALL tra_adv_mle( kt, nit000, zun, zvn, zwn, 'TRA' )    ! add the mle transport (if necessary) 
    115       ! 
    116       CALL iom_put( "uocetr_eff", zun )                                         ! output effective transport       
     113      zun(:,:,jpk) = 0._wp                                                      ! no transport trough the bottom 
     114      zvn(:,:,jpk) = 0._wp 
     115      zwn(:,:,jpk) = 0._wp 
     116      ! 
     117      IF( ln_ldfeiv .AND. .NOT. ln_traldf_triad )   & 
     118         &              CALL ldf_eiv_trp( kt, nit000, zun, zvn, zwn, 'TRA' )   ! add the eiv transport (if necessary) 
     119      ! 
     120      IF( ln_mle    )   CALL tra_adv_mle( kt, nit000, zun, zvn, zwn, 'TRA' )   ! add the mle transport (if necessary) 
     121      ! 
     122      CALL iom_put( "uocetr_eff", zun )                                        ! output effective transport       
    117123      CALL iom_put( "vocetr_eff", zvn ) 
    118124      CALL iom_put( "wocetr_eff", zwn ) 
    119125      ! 
    120       IF( ln_diaptr )   CALL dia_ptr( zvn )                                     ! diagnose the effective MSF  
    121       ! 
    122     
    123       SELECT CASE ( nadv )                            !==  compute advection trend and add it to general trend  ==! 
    124       CASE ( 1 )   ;    CALL tra_adv_cen2   ( kt, nit000, 'TRA',         zun, zvn, zwn, tsb, tsn, tsa, jpts )   !  2nd order centered 
    125       CASE ( 2 )   ;    CALL tra_adv_tvd    ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts )   !  TVD  
    126       CASE ( 3 )   ;    CALL tra_adv_muscl  ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb,      tsa, jpts, ln_traadv_msc_ups )   !  MUSCL  
    127       CASE ( 4 )   ;    CALL tra_adv_muscl2 ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts )   !  MUSCL2  
    128       CASE ( 5 )   ;    CALL tra_adv_ubs    ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts )   !  UBS  
    129       CASE ( 6 )   ;    CALL tra_adv_qck    ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts )   !  QUICKEST  
    130       CASE ( 7 )   ;    CALL tra_adv_tvd_zts( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts )   !  TVD ZTS 
    131       ! 
    132       CASE (-1 )                                      !==  esopa: test all possibility with control print  ==! 
    133          CALL tra_adv_cen2  ( kt, nit000, 'TRA',         zun, zvn, zwn, tsb, tsn, tsa, jpts )           
    134          CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' adv0 - Ta: ', mask1=tmask,               & 
    135             &          tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    136          CALL tra_adv_tvd   ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts )           
    137          CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' adv1 - Ta: ', mask1=tmask,               & 
    138             &          tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    139          CALL tra_adv_muscl ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb,      tsa, jpts, ln_traadv_msc_ups )           
    140          CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' adv3 - Ta: ', mask1=tmask,               & 
    141             &          tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    142          CALL tra_adv_muscl2( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts )           
    143          CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' adv4 - Ta: ', mask1=tmask,               & 
    144             &          tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    145          CALL tra_adv_ubs   ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts )           
    146          CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' adv5 - Ta: ', mask1=tmask,               & 
    147             &          tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    148          CALL tra_adv_qck   ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts )           
    149          CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' adv6 - Ta: ', mask1=tmask,               & 
    150             &          tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
     126!!gm ??? 
     127      IF( ln_diaptr )   CALL dia_ptr( zvn )                                    ! diagnose the effective MSF  
     128!!gm ??? 
     129      ! 
     130      SELECT CASE ( nadv )                      !==  compute advection trend and add it to general trend  ==! 
     131      ! 
     132      CASE ( np_CEN )                                    ! Centered scheme : 2nd / 4th order 
     133         CALL tra_adv_cen    ( kt, nit000, 'TRA',         zun, zvn, zwn     , tsn, tsa, jpts, nn_cen_h, nn_cen_v ) 
     134      CASE ( np_FCT )                                    ! FCT scheme      : 2nd / 4th order 
     135         CALL tra_adv_fct    ( kt, nit000, 'TRA', r2dt, zun, zvn, zwn, tsb, tsn, tsa, jpts, nn_fct_h, nn_fct_v ) 
     136      CASE ( np_FCT_zts )                                ! 2nd order FCT with vertical time-splitting 
     137         CALL tra_adv_fct_zts( kt, nit000, 'TRA', r2dt, zun, zvn, zwn, tsb, tsn, tsa, jpts        , nn_fct_zts ) 
     138      CASE ( np_MUS )                                    ! MUSCL 
     139         CALL tra_adv_mus    ( kt, nit000, 'TRA', r2dt, zun, zvn, zwn, tsb,      tsa, jpts        , ln_mus_ups )  
     140      CASE ( np_UBS )                                    ! UBS 
     141         CALL tra_adv_ubs    ( kt, nit000, 'TRA', r2dt, zun, zvn, zwn, tsb, tsn, tsa, jpts        , nn_ubs_v   ) 
     142      CASE ( np_QCK )                                    ! QUICKEST 
     143         CALL tra_adv_qck    ( kt, nit000, 'TRA', r2dt, zun, zvn, zwn, tsb, tsn, tsa, jpts                     ) 
     144      ! 
    151145      END SELECT 
    152146      ! 
    153       !                                              ! print mean trends (used for debugging) 
     147      !                                         ! print mean trends (used for debugging) 
    154148      IF(ln_ctl)   CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' adv  - Ta: ', mask1=tmask,               & 
    155149         &                       tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    … …  
    157151      IF( nn_timing == 1 )  CALL timing_stop( 'tra_adv' ) 
    158152      ! 
    159       CALL wrk_dealloc( jpi, jpj, jpk, zun, zvn, zwn ) 
     153      CALL wrk_dealloc( jpi,jpj,jpk,  zun, zvn, zwn ) 
    160154      !                                           
    161155   END SUBROUTINE tra_adv 
    … …  
    169163      !!              tracer advection schemes and set nadv 
    170164      !!---------------------------------------------------------------------- 
    171       INTEGER ::   ioptio 
    172       INTEGER ::   ios                 ! Local integer output status for namelist read 
    173       !! 
    174       NAMELIST/namtra_adv/ ln_traadv_cen2 , ln_traadv_tvd,     & 
    175          &                 ln_traadv_muscl, ln_traadv_muscl2,  & 
    176          &                 ln_traadv_ubs  , ln_traadv_qck,     & 
    177          &                 ln_traadv_msc_ups, ln_traadv_tvd_zts 
    178       !!---------------------------------------------------------------------- 
    179  
    180       REWIND( numnam_ref )              ! Namelist namtra_adv in reference namelist : Tracer advection scheme 
     165      INTEGER ::   ioptio, ios   ! Local integers 
     166      ! 
     167      NAMELIST/namtra_adv/ ln_traadv_cen, nn_cen_h, nn_cen_v,               &   ! CEN 
     168         &                 ln_traadv_fct, nn_fct_h, nn_fct_v, nn_fct_zts,   &   ! FCT 
     169         &                 ln_traadv_mus,                     ln_mus_ups,   &   ! MUSCL 
     170         &                 ln_traadv_ubs,           nn_ubs_v,               &   ! UBS 
     171         &                 ln_traadv_qck                                        ! QCK 
     172      !!---------------------------------------------------------------------- 
     173      ! 
     174      !                                !==  Namelist  ==! 
     175      REWIND( numnam_ref )                   ! Namelist namtra_adv in reference namelist : Tracer advection scheme 
    181176      READ  ( numnam_ref, namtra_adv, IOSTAT = ios, ERR = 901) 
    182 901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_adv in reference namelist', lwp ) 
    183  
    184       REWIND( numnam_cfg )              ! Namelist namtra_adv in configuration namelist : Tracer advection scheme 
     177901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtra_adv in reference namelist', lwp ) 
     178      ! 
     179      REWIND( numnam_cfg )                   ! Namelist namtra_adv in configuration namelist : Tracer advection scheme 
    185180      READ  ( numnam_cfg, namtra_adv, IOSTAT = ios, ERR = 902 ) 
    186 902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_adv in configuration namelist', lwp ) 
    187       IF(lwm) WRITE ( numond, namtra_adv ) 
    188  
    189       IF(lwp) THEN                    ! Namelist print 
     181902   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtra_adv in configuration namelist', lwp ) 
     182      IF(lwm) WRITE( numond, namtra_adv ) 
     183      ! 
     184      IF(lwp) THEN                           ! Namelist print 
    190185         WRITE(numout,*) 
    191186         WRITE(numout,*) 'tra_adv_init : choice/control of the tracer advection scheme' 
    192187         WRITE(numout,*) '~~~~~~~~~~~' 
    193188         WRITE(numout,*) '   Namelist namtra_adv : chose a advection scheme for tracers' 
    194          WRITE(numout,*) '      2nd order advection scheme     ln_traadv_cen2    = ', ln_traadv_cen2 
    195          WRITE(numout,*) '      TVD advection scheme           ln_traadv_tvd     = ', ln_traadv_tvd 
    196          WRITE(numout,*) '      MUSCL  advection scheme        ln_traadv_muscl   = ', ln_traadv_muscl 
    197          WRITE(numout,*) '      MUSCL2 advection scheme        ln_traadv_muscl2  = ', ln_traadv_muscl2 
    198          WRITE(numout,*) '      UBS    advection scheme        ln_traadv_ubs     = ', ln_traadv_ubs 
    199          WRITE(numout,*) '      QUICKEST advection scheme      ln_traadv_qck     = ', ln_traadv_qck 
    200          WRITE(numout,*) '      upstream scheme within muscl   ln_traadv_msc_ups = ', ln_traadv_msc_ups 
    201          WRITE(numout,*) '      TVD advection scheme with zts  ln_traadv_tvd_zts = ', ln_traadv_tvd_zts 
    202       ENDIF 
    203  
    204       ioptio = 0                      ! Parameter control 
    205       IF( ln_traadv_cen2   )   ioptio = ioptio + 1 
    206       IF( ln_traadv_tvd    )   ioptio = ioptio + 1 
    207       IF( ln_traadv_muscl  )   ioptio = ioptio + 1 
    208       IF( ln_traadv_muscl2 )   ioptio = ioptio + 1 
    209       IF( ln_traadv_ubs    )   ioptio = ioptio + 1 
    210       IF( ln_traadv_qck    )   ioptio = ioptio + 1 
    211       IF( ln_traadv_tvd_zts)   ioptio = ioptio + 1 
    212       IF( lk_esopa         )   ioptio =          1 
    213  
    214       IF( ( ln_traadv_muscl .OR. ln_traadv_muscl2 .OR. ln_traadv_ubs .OR. ln_traadv_qck .OR. ln_traadv_tvd_zts )   & 
    215          .AND. ln_isfcav )   CALL ctl_stop( 'Only traadv_cen2 and traadv_tvd is compatible with ice shelf cavity') 
    216  
    217       IF( ioptio /= 1 )   CALL ctl_stop( 'Choose ONE advection scheme in namelist namtra_adv' ) 
    218  
    219       !                              ! Set nadv 
    220       IF( ln_traadv_cen2   )   nadv =  1 
    221       IF( ln_traadv_tvd    )   nadv =  2 
    222       IF( ln_traadv_muscl  )   nadv =  3 
    223       IF( ln_traadv_muscl2 )   nadv =  4 
    224       IF( ln_traadv_ubs    )   nadv =  5 
    225       IF( ln_traadv_qck    )   nadv =  6 
    226       IF( ln_traadv_tvd_zts)   nadv =  7 
    227       IF( lk_esopa         )   nadv = -1 
    228  
    229       IF(lwp) THEN                   ! Print the choice 
     189         WRITE(numout,*) '      centered scheme                           ln_traadv_cen = ', ln_traadv_cen 
     190         WRITE(numout,*) '            horizontal 2nd/4th order               nn_cen_h   = ', nn_fct_h 
     191         WRITE(numout,*) '            vertical   2nd/4th order               nn_cen_v   = ', nn_fct_v 
     192         WRITE(numout,*) '      Flux Corrected Transport scheme           ln_traadv_fct = ', ln_traadv_fct 
     193         WRITE(numout,*) '            horizontal 2nd/4th order               nn_fct_h   = ', nn_fct_h 
     194         WRITE(numout,*) '            vertical   2nd/4th order               nn_fct_v   = ', nn_fct_v 
     195         WRITE(numout,*) '            2nd order + vertical sub-timestepping  nn_fct_zts = ', nn_fct_zts 
     196         WRITE(numout,*) '      MUSCL scheme                              ln_traadv_mus = ', ln_traadv_mus 
     197         WRITE(numout,*) '            + upstream scheme near river mouths    ln_mus_ups = ', ln_mus_ups 
     198         WRITE(numout,*) '      UBS scheme                                ln_traadv_ubs = ', ln_traadv_ubs 
     199         WRITE(numout,*) '            vertical   2nd/4th order               nn_ubs_v   = ', nn_ubs_v 
     200         WRITE(numout,*) '      QUICKEST scheme                           ln_traadv_qck = ', ln_traadv_qck 
     201      ENDIF 
     202      ! 
     203      ioptio = 0                       !==  Parameter control  ==! 
     204      IF( ln_traadv_cen )   ioptio = ioptio + 1 
     205      IF( ln_traadv_fct )   ioptio = ioptio + 1 
     206      IF( ln_traadv_mus )   ioptio = ioptio + 1 
     207      IF( ln_traadv_ubs )   ioptio = ioptio + 1 
     208      IF( ln_traadv_qck )   ioptio = ioptio + 1 
     209      ! 
     210      IF( ioptio == 0 ) THEN 
     211         nadv = np_NO_adv 
     212         CALL ctl_warn( 'tra_adv_init: You are running without tracer advection.' ) 
     213      ENDIF 
     214      IF( ioptio /= 1 )   CALL ctl_stop( 'tra_adv_init: Choose ONE advection scheme in namelist namtra_adv' ) 
     215      ! 
     216      IF( ln_traadv_cen .AND. ( nn_cen_h /= 2 .AND. nn_cen_h /= 4 )   &          ! Centered 
     217                        .AND. ( nn_cen_v /= 2 .AND. nn_cen_v /= 4 )   ) THEN 
     218        CALL ctl_stop( 'tra_adv_init: CEN scheme, choose 2nd or 4th order' ) 
     219      ENDIF 
     220      IF( ln_traadv_fct .AND. ( nn_fct_h /= 2 .AND. nn_fct_h /= 4 )   &          ! FCT 
     221                        .AND. ( nn_fct_v /= 2 .AND. nn_fct_v /= 4 )   ) THEN 
     222        CALL ctl_stop( 'tra_adv_init: FCT scheme, choose 2nd or 4th order' ) 
     223      ENDIF 
     224      IF( ln_traadv_fct .AND. nn_fct_zts > 0 ) THEN 
     225         IF( nn_fct_h == 4 ) THEN 
     226            nn_fct_h = 2 
     227            CALL ctl_stop( 'tra_adv_init: force 2nd order FCT scheme, 4th order does not exist with sub-timestepping' ) 
     228         ENDIF 
     229         IF( .NOT.ln_linssh ) THEN 
     230            CALL ctl_stop( 'tra_adv_init: vertical sub-timestepping not allow in non-linear free surface' ) 
     231         ENDIF 
     232         IF( nn_fct_zts == 1 )   CALL ctl_warn( 'tra_adv_init: FCT with ONE sub-timestep = FCT without sub-timestep' ) 
     233      ENDIF 
     234      IF( ln_traadv_ubs .AND. ( nn_ubs_v /= 2 .AND. nn_ubs_v /= 4 )   ) THEN     ! UBS 
     235        CALL ctl_stop( 'tra_adv_init: UBS scheme, choose 2nd or 4th order' ) 
     236      ENDIF 
     237      IF( ln_traadv_ubs .AND. nn_ubs_v == 4 ) THEN 
     238         CALL ctl_warn( 'tra_adv_init: UBS scheme, only 2nd FCT scheme available on the vertical. It will be used' ) 
     239      ENDIF 
     240      IF( ln_isfcav ) THEN                                                       ! ice-shelf cavities 
     241         IF(  ln_traadv_cen .AND. nn_cen_v == 4    .OR.   &                            ! NO 4th order with ISF 
     242            & ln_traadv_fct .AND. nn_fct_v == 4   )   CALL ctl_stop( 'tra_adv_init: 4th order COMPACT scheme not allowed with ISF' ) 
     243      ENDIF 
     244      ! 
     245      !                                !==  used advection scheme  ==!   
     246      !                                      ! set nadv 
     247      IF( ln_traadv_cen                      )   nadv = np_CEN 
     248      IF( ln_traadv_fct                      )   nadv = np_FCT 
     249      IF( ln_traadv_fct .AND. nn_fct_zts > 0 )   nadv = np_FCT_zts 
     250      IF( ln_traadv_mus                      )   nadv = np_MUS 
     251      IF( ln_traadv_ubs                      )   nadv = np_UBS 
     252      IF( ln_traadv_qck                      )   nadv = np_QCK 
     253      ! 
     254      IF(lwp) THEN                           ! Print the choice 
    230255         WRITE(numout,*) 
    231          IF( nadv ==  1 )   WRITE(numout,*) '         2nd order scheme is used' 
    232          IF( nadv ==  2 )   WRITE(numout,*) '         TVD       scheme is used' 
    233          IF( nadv ==  3 )   WRITE(numout,*) '         MUSCL     scheme is used' 
    234          IF( nadv ==  4 )   WRITE(numout,*) '         MUSCL2    scheme is used' 
    235          IF( nadv ==  5 )   WRITE(numout,*) '         UBS       scheme is used' 
    236          IF( nadv ==  6 )   WRITE(numout,*) '         QUICKEST  scheme is used' 
    237          IF( nadv ==  7 )   WRITE(numout,*) '         TVD ZTS   scheme is used' 
    238          IF( nadv == -1 )   WRITE(numout,*) '         esopa test: use all advection scheme' 
    239       ENDIF 
    240       ! 
    241       CALL tra_adv_mle_init          ! initialisation of the Mixed Layer Eddy parametrisation (MLE) 
     256         SELECT CASE ( nadv ) 
     257         CASE( np_NO_adv  )   ;   WRITE(numout,*) '         NO T-S advection' 
     258         CASE( np_CEN     )   ;   WRITE(numout,*) '         CEN      scheme is used. Horizontal order: ', nn_cen_h,   & 
     259            &                                                                     ' Vertical   order: ', nn_cen_v 
     260         CASE( np_FCT     )   ;   WRITE(numout,*) '         FCT      scheme is used. Horizontal order: ', nn_fct_h,   & 
     261            &                                                                      ' Vertical   order: ', nn_fct_v 
     262         CASE( np_FCT_zts )   ;   WRITE(numout,*) '         use 2nd order FCT with ', nn_fct_zts,'vertical sub-timestepping' 
     263         CASE( np_MUS     )   ;   WRITE(numout,*) '         MUSCL    scheme is used' 
     264         CASE( np_UBS     )   ;   WRITE(numout,*) '         UBS      scheme is used' 
     265         CASE( np_QCK     )   ;   WRITE(numout,*) '         QUICKEST scheme is used' 
     266         END SELECT 
     267      ENDIF 
     268      ! 
     269      CALL tra_adv_mle_init            !== initialisation of the Mixed Layer Eddy parametrisation (MLE)  ==! 
    242270      ! 
    243271   END SUBROUTINE tra_adv_init 

  • branches/NERC/dev_r5549_BDY_ZEROGRAD/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_mle.F90

    r5215 r6808  
    2828   PUBLIC   tra_adv_mle_init   ! routine called in traadv.F90 
    2929 
    30    !                                               !!* namelist namtra_adv_mle * 
     30   !                                       !!* namelist namtra_adv_mle * 
    3131   LOGICAL, PUBLIC ::   ln_mle              ! flag to activate the Mixed Layer Eddy (MLE) parameterisation 
    3232   INTEGER         ::   nn_mle              ! MLE type: =0 standard Fox-Kemper ; =1 new formulation 
    … …  
    3434   INTEGER         ::   nn_conv             ! =1 no MLE in case of convection ; =0 always MLE 
    3535   REAL(wp)        ::   rn_ce               ! MLE coefficient 
    36    !                                           ! parameters used in nn_mle = 0 case 
     36   !                                        ! parameters used in nn_mle = 0 case 
    3737   REAL(wp)        ::   rn_lf                  ! typical scale of mixed layer front 
    38    REAL(wp)        ::   rn_time             ! time scale for mixing momentum across the mixed layer 
    39    !                                             ! parameters used in nn_mle = 1 case 
    40    REAL(wp)        ::   rn_lat                   ! reference latitude for a 5 km scale of ML front 
    41    REAL(wp)        ::   rn_rho_c_mle         ! Density criterion for definition of MLD used by FK 
     38   REAL(wp)        ::   rn_time                ! time scale for mixing momentum across the mixed layer 
     39   !                                        ! parameters used in nn_mle = 1 case 
     40   REAL(wp)        ::   rn_lat                 ! reference latitude for a 5 km scale of ML front 
     41   REAL(wp)        ::   rn_rho_c_mle           ! Density criterion for definition of MLD used by FK 
    4242 
    4343   REAL(wp) ::   r5_21 = 5.e0 / 21.e0   ! factor used in mle streamfunction computation 
    … …  
    4949 
    5050   !! * Substitutions 
    51 #  include "domzgr_substitute.h90" 
    5251#  include "vectopt_loop_substitute.h90" 
    5352   !!---------------------------------------------------------------------- 
    54    !! NEMO/OPA 4.0 , NEMO Consortium (2011) 
     53   !! NEMO/OPA 4.0 , NEMO Consortium (2015) 
    5554   !! $Id$ 
    5655   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 
    … …  
    8079      !!             Fox-Kemper and Ferrari, JPO, 38, 1166-1179, 2008 
    8180      !!---------------------------------------------------------------------- 
    82       ! 
    8381      INTEGER                         , INTENT(in   ) ::   kt         ! ocean time-step index 
    8482      INTEGER                         , INTENT(in   ) ::   kit000     ! first time step index 
    … …  
    9391      REAL(wp) ::   zcvw, zmvw   !   -      - 
    9492      REAL(wp) ::   zc                                     !   -      - 
    95  
     93      ! 
    9694      INTEGER  ::   ii, ij, ik              ! local integers 
    9795      INTEGER, DIMENSION(3) ::   ilocu      ! 
    … …  
    10199      INTEGER, POINTER, DIMENSION(:,:) :: inml_mle 
    102100      !!---------------------------------------------------------------------- 
    103  
     101      ! 
    104102      IF( nn_timing == 1 )  CALL timing_start('tra_adv_mle') 
    105103      CALL wrk_alloc( jpi, jpj, zpsim_u, zpsim_v, zmld, zbm, zhu, zhv, zn2, zLf_NH, zLf_MH) 
    … …  
    126124         DO jj = 1, jpj 
    127125            DO ji = 1, jpi 
    128                zc = fse3t(ji,jj,jk) * REAL( MIN( MAX( 0, inml_mle(ji,jj)-jk ) , 1  )  )    ! zc being 0 outside the ML t-points 
     126               zc = e3t_n(ji,jj,jk) * REAL( MIN( MAX( 0, inml_mle(ji,jj)-jk ) , 1  )  )    ! zc being 0 outside the ML t-points 
    129127               zmld(ji,jj) = zmld(ji,jj) + zc 
    130128               zbm (ji,jj) = zbm (ji,jj) + zc * (rau0 - rhop(ji,jj,jk) ) * r1_rau0 
    … …  
    158156      END SELECT 
    159157      !                                                ! convert density into buoyancy 
    160       zbm(:,:) = + grav * zbm(:,:) / MAX( fse3t(:,:,1), zmld(:,:) ) 
     158      zbm(:,:) = + grav * zbm(:,:) / MAX( e3t_n(:,:,1), zmld(:,:) ) 
    161159      ! 
    162160      ! 
    … …  
    171169         DO jj = 1, jpjm1 
    172170            DO ji = 1, fs_jpim1   ! vector opt. 
    173                zpsim_u(ji,jj) = rn_ce * zhu(ji,jj) * zhu(ji,jj)  * e2u(ji,jj)                                            & 
    174                   &           * ( zbm(ji+1,jj) - zbm(ji,jj) ) * MIN( 111.e3_wp          , e1u(ji,jj)                )   & 
    175                   &           / (         e1u(ji,jj)          * MAX( rn_lf * rfu(ji,jj) , SQRT( rb_c * zhu(ji,jj) ) )   ) 
     171               zpsim_u(ji,jj) = rn_ce * zhu(ji,jj) * zhu(ji,jj)  * e2_e1u(ji,jj)                                            & 
     172                  &           * ( zbm(ji+1,jj) - zbm(ji,jj) ) * MIN( 111.e3_wp , e1u(ji,jj) )   & 
     173                  &           / (  MAX( rn_lf * rfu(ji,jj) , SQRT( rb_c * zhu(ji,jj) ) )   ) 
    176174                  ! 
    177                zpsim_v(ji,jj) = rn_ce * zhv(ji,jj) * zhv(ji,jj)  * e1v(ji,jj)                                            & 
    178                   &           * ( zbm(ji,jj+1) - zbm(ji,jj) ) * MIN( 111.e3_wp          , e2v(ji,jj)                )   & 
    179                   &           / (         e2v(ji,jj)          * MAX( rn_lf * rfv(ji,jj) , SQRT( rb_c * zhv(ji,jj) ) )   ) 
     175               zpsim_v(ji,jj) = rn_ce * zhv(ji,jj) * zhv(ji,jj)  * e1_e2v(ji,jj)                                            & 
     176                  &           * ( zbm(ji,jj+1) - zbm(ji,jj) ) * MIN( 111.e3_wp , e2v(ji,jj) )   & 
     177                  &           / (  MAX( rn_lf * rfv(ji,jj) , SQRT( rb_c * zhv(ji,jj) ) )   ) 
    180178            END DO 
    181179         END DO 
    … …  
    184182         DO jj = 1, jpjm1 
    185183            DO ji = 1, fs_jpim1   ! vector opt. 
    186                zpsim_u(ji,jj) = rc_f *   zhu(ji,jj)   * zhu(ji,jj)   * e2u(ji,jj) / e1u(ji,jj)          & 
     184               zpsim_u(ji,jj) = rc_f *   zhu(ji,jj)   * zhu(ji,jj)   * e2_e1u(ji,jj)               & 
    187185                  &                  * ( zbm(ji+1,jj) - zbm(ji,jj) ) * MIN( 111.e3_wp , e1u(ji,jj) ) 
    188186                  ! 
    189                zpsim_v(ji,jj) = rc_f *   zhv(ji,jj)   * zhv(ji,jj)   * e1v(ji,jj) / e2v(ji,jj)          & 
     187               zpsim_v(ji,jj) = rc_f *   zhv(ji,jj)   * zhv(ji,jj)   * e1_e2v(ji,jj)               & 
    190188                  &                  * ( zbm(ji,jj+1) - zbm(ji,jj) ) * MIN( 111.e3_wp , e2v(ji,jj) ) 
    191189            END DO 
    … …  
    216214         DO jj = 1, jpjm1 
    217215            DO ji = 1, fs_jpim1   ! vector opt. 
    218                zcuw = 1._wp - ( fsdepw(ji+1,jj,jk) + fsdepw(ji,jj,jk) ) * zhu(ji,jj) 
    219                zcvw = 1._wp - ( fsdepw(ji,jj+1,jk) + fsdepw(ji,jj,jk) ) * zhv(ji,jj) 
     216               zcuw = 1._wp - ( gdepw_n(ji+1,jj,jk) + gdepw_n(ji,jj,jk) ) * zhu(ji,jj) 
     217               zcvw = 1._wp - ( gdepw_n(ji,jj+1,jk) + gdepw_n(ji,jj,jk) ) * zhv(ji,jj) 
    220218               zcuw = zcuw * zcuw 
    221219               zcvw = zcvw * zcvw 
    … …  
    252250         ! divide by cross distance to give streamfunction with dimensions m^2/s 
    253251         DO jk = 1, ikmax+1 
    254             zpsi_uw(:,:,jk) = zpsi_uw(:,:,jk)/e2u(:,:) 
    255             zpsi_vw(:,:,jk) = zpsi_vw(:,:,jk)/e1v(:,:) 
     252            zpsi_uw(:,:,jk) = zpsi_uw(:,:,jk) * r1_e2u(:,:) 
     253            zpsi_vw(:,:,jk) = zpsi_vw(:,:,jk) * r1_e1v(:,:) 
    256254         END DO 
    257255         CALL iom_put( "psiu_mle", zpsi_uw )    ! i-mle streamfunction 
    … …  
    281279      NAMELIST/namtra_adv_mle/ ln_mle , nn_mle, rn_ce, rn_lf, rn_time, rn_lat, nn_mld_uv, nn_conv, rn_rho_c_mle 
    282280      !!---------------------------------------------------------------------- 
    283  
    284281 
    285282      REWIND( numnam_ref )              ! Namelist namtra_adv_mle in reference namelist : Tracer advection scheme 

  • branches/NERC/dev_r5549_BDY_ZEROGRAD/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_qck.F90

    r5147 r6808  
    2020   USE trd_oce         ! trends: ocean variables 
    2121   USE trdtra          ! trends manager: tracers  
    22    USE dynspg_oce      ! surface pressure gradient variables 
    2322   USE diaptr          ! poleward transport diagnostics 
    2423   ! 
    … …  
    3938 
    4039   !! * Substitutions 
    41 #  include "domzgr_substitute.h90" 
    4240#  include "vectopt_loop_substitute.h90" 
    4341   !!---------------------------------------------------------------------- 
    … …  
    7977      !!            prevent the appearance of spurious numerical oscillations 
    8078      !! 
    81       !! ** Action : - update (pta) with the now advective tracer trends 
    82       !!             - save the trends  
     79      !! ** Action : - update pta  with the now advective tracer trends 
     80      !!             - send trends to trdtra module for further diagnostcs (l_trdtra=T) 
     81      !!             - htr_adv, str_adv : poleward advective heat and salt transport (ln_diaptr=T) 
    8382      !! 
    8483      !! ** Reference : Leonard (1979, 1991) 
    … …  
    8887      CHARACTER(len=3)                     , INTENT(in   ) ::   cdtype          ! =TRA or TRC (tracer indicator) 
    8988      INTEGER                              , INTENT(in   ) ::   kjpt            ! number of tracers 
    90       REAL(wp), DIMENSION(        jpk     ), INTENT(in   ) ::   p2dt            ! vertical profile of tracer time-step 
     89      REAL(wp)                             , INTENT(in   ) ::   p2dt            ! tracer time-step 
    9190      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pun, pvn, pwn   ! 3 ocean velocity components 
    9291      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb, ptn        ! before and now tracer fields 
    … …  
    102101         IF(lwp) WRITE(numout,*) 
    103102      ENDIF 
     103      ! 
    104104      l_trd = .FALSE. 
    105105      IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) )   l_trd = .TRUE. 
    106106      ! 
    107       ! I. The horizontal fluxes are computed with the QUICKEST + ULTIMATE scheme 
     107      !        ! horizontal fluxes are computed with the QUICKEST + ULTIMATE scheme 
    108108      CALL tra_adv_qck_i( kt, cdtype, p2dt, pun, ptb, ptn, pta, kjpt )  
    109109      CALL tra_adv_qck_j( kt, cdtype, p2dt, pvn, ptb, ptn, pta, kjpt )  
    110110 
    111       ! II. The vertical fluxes are computed with the 2nd order centered scheme 
     111      !        ! vertical fluxes are computed with the 2nd order centered scheme 
    112112      CALL tra_adv_cen2_k( kt, cdtype, pwn,         ptn, pta, kjpt ) 
    113113      ! 
    … …  
    125125      CHARACTER(len=3)                     , INTENT(in   ) ::   cdtype     ! =TRA or TRC (tracer indicator) 
    126126      INTEGER                              , INTENT(in   ) ::   kjpt       ! number of tracers 
    127       REAL(wp), DIMENSION(        jpk     ), INTENT(in   ) ::   p2dt       ! vertical profile of tracer time-step 
     127      REAL(wp)                             , INTENT(in   ) ::   p2dt       ! tracer time-step 
    128128      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pun        ! i-velocity components 
    129129      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb, ptn   ! before and now tracer fields 
    130130      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta        ! tracer trend  
    131131      !! 
    132       INTEGER  :: ji, jj, jk, jn   ! dummy loop indices 
    133       REAL(wp) :: ztra, zbtr, zdir, zdx, zdt, zmsk   ! local scalars 
    134       REAL(wp), POINTER, DIMENSION(:,:,:) :: zwx, zfu, zfc, zfd 
     132      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
     133      REAL(wp) ::   ztra, zbtr, zdir, zdx, zmsk   ! local scalars 
     134      REAL(wp), POINTER, DIMENSION(:,:,:) ::   zwx, zfu, zfc, zfd 
    135135      !---------------------------------------------------------------------- 
    136136      ! 
    … …  
    139139      DO jn = 1, kjpt                                            ! tracer loop 
    140140         !                                                       ! =========== 
    141          zfu(:,:,:) = 0.0     ;   zfc(:,:,:) = 0.0   
    142          zfd(:,:,:) = 0.0     ;   zwx(:,:,:) = 0.0      
    143          !                                                   
    144          DO jk = 1, jpkm1                                 
    145             !                                              
    146             !--- Computation of the ustream and downstream value of the tracer and the mask 
     141         zfu(:,:,:) = 0._wp     ;   zfc(:,:,:) = 0._wp  
     142         zfd(:,:,:) = 0._wp     ;   zwx(:,:,:) = 0._wp    
     143         ! 
     144!!gm why not using a SHIFT instruction... 
     145         DO jk = 1, jpkm1     !--- Computation of the ustream and downstream value of the tracer and the mask 
    147146            DO jj = 2, jpjm1 
    148147               DO ji = fs_2, fs_jpim1   ! vector opt. 
    149                   ! Upstream in the x-direction for the tracer 
    150                   zfc(ji,jj,jk) = ptb(ji-1,jj,jk,jn) 
    151                   ! Downstream in the x-direction for the tracer 
    152                   zfd(ji,jj,jk) = ptb(ji+1,jj,jk,jn) 
     148                  zfc(ji,jj,jk) = ptb(ji-1,jj,jk,jn)        ! Upstream   in the x-direction for the tracer 
     149                  zfd(ji,jj,jk) = ptb(ji+1,jj,jk,jn)        ! Downstream in the x-direction for the tracer 
    153150               END DO 
    154151            END DO 
    … …  
    159156         ! Horizontal advective fluxes 
    160157         ! --------------------------- 
    161          ! 
    162158         DO jk = 1, jpkm1                              
    163159            DO jj = 2, jpjm1 
    … …  
    170166         ! 
    171167         DO jk = 1, jpkm1   
    172             zdt =  p2dt(jk) 
    173168            DO jj = 2, jpjm1 
    174169               DO ji = fs_2, fs_jpim1   ! vector opt.    
    175170                  zdir = 0.5 + SIGN( 0.5, pun(ji,jj,jk) )   ! if pun > 0 : zdir = 1 otherwise zdir = 0  
    176                   zdx = ( zdir * e1t(ji,jj) + ( 1. - zdir ) * e1t(ji+1,jj) ) * e2u(ji,jj) * fse3u(ji,jj,jk) 
    177                   zwx(ji,jj,jk)  = ABS( pun(ji,jj,jk) ) * zdt / zdx    ! (0<zc_cfl<1 : Courant number on x-direction) 
     171                  zdx = ( zdir * e1t(ji,jj) + ( 1. - zdir ) * e1t(ji+1,jj) ) * e2u(ji,jj) * e3u_n(ji,jj,jk) 
     172                  zwx(ji,jj,jk)  = ABS( pun(ji,jj,jk) ) * p2dt / zdx    ! (0<zc_cfl<1 : Courant number on x-direction) 
    178173                  zfc(ji,jj,jk)  = zdir * ptb(ji  ,jj,jk,jn) + ( 1. - zdir ) * ptb(ji+1,jj,jk,jn)  ! FC in the x-direction for T 
    179174                  zfd(ji,jj,jk)  = zdir * ptb(ji+1,jj,jk,jn) + ( 1. - zdir ) * ptb(ji  ,jj,jk,jn)  ! FD in the x-direction for T 
    … …  
    220215            DO jj = 2, jpjm1 
    221216               DO ji = fs_2, fs_jpim1   ! vector opt.   
    222                   zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
     217                  zbtr = r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 
    223218                  ! horizontal advective trends 
    224219                  ztra = - zbtr * ( zwx(ji,jj,jk) - zwx(ji-1,jj,jk) ) 
    … …  
    228223            END DO 
    229224         END DO 
    230          !                                 ! trend diagnostics (contribution of upstream fluxes) 
     225         !                                 ! trend diagnostics 
    231226         IF( l_trd )   CALL trd_tra( kt, cdtype, jn, jptra_xad, zwx, pun, ptn(:,:,:,jn) ) 
    232227         ! 
    … …  
    246241      CHARACTER(len=3)                     , INTENT(in   ) ::   cdtype     ! =TRA or TRC (tracer indicator) 
    247242      INTEGER                              , INTENT(in   ) ::   kjpt       ! number of tracers 
    248       REAL(wp), DIMENSION(        jpk     ), INTENT(in   ) ::   p2dt       ! vertical profile of tracer time-step 
     243      REAL(wp)                             , INTENT(in   ) ::   p2dt       ! tracer time-step 
    249244      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pvn        ! j-velocity components 
    250245      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb, ptn   ! before and now tracer fields 
    … …  
    252247      !! 
    253248      INTEGER  :: ji, jj, jk, jn   ! dummy loop indices 
    254       REAL(wp) :: ztra, zbtr, zdir, zdx, zdt, zmsk   ! local scalars 
     249      REAL(wp) :: ztra, zbtr, zdir, zdx, zmsk   ! local scalars 
    255250      REAL(wp), POINTER, DIMENSION(:,:,:) :: zwy, zfu, zfc, zfd 
    256251      !---------------------------------------------------------------------- 
    … …  
    293288         ! 
    294289         DO jk = 1, jpkm1   
    295             zdt =  p2dt(jk) 
    296290            DO jj = 2, jpjm1 
    297291               DO ji = fs_2, fs_jpim1   ! vector opt.    
    298292                  zdir = 0.5 + SIGN( 0.5, pvn(ji,jj,jk) )   ! if pun > 0 : zdir = 1 otherwise zdir = 0  
    299                   zdx = ( zdir * e2t(ji,jj) + ( 1. - zdir ) * e2t(ji,jj+1) ) * e1v(ji,jj) * fse3v(ji,jj,jk) 
    300                   zwy(ji,jj,jk)  = ABS( pvn(ji,jj,jk) ) * zdt / zdx    ! (0<zc_cfl<1 : Courant number on x-direction) 
     293                  zdx = ( zdir * e2t(ji,jj) + ( 1. - zdir ) * e2t(ji,jj+1) ) * e1v(ji,jj) * e3v_n(ji,jj,jk) 
     294                  zwy(ji,jj,jk)  = ABS( pvn(ji,jj,jk) ) * p2dt / zdx    ! (0<zc_cfl<1 : Courant number on x-direction) 
    301295                  zfc(ji,jj,jk)  = zdir * ptb(ji,jj  ,jk,jn) + ( 1. - zdir ) * ptb(ji,jj+1,jk,jn)  ! FC in the x-direction for T 
    302296                  zfd(ji,jj,jk)  = zdir * ptb(ji,jj+1,jk,jn) + ( 1. - zdir ) * ptb(ji,jj  ,jk,jn)  ! FD in the x-direction for T 
    … …  
    344338            DO jj = 2, jpjm1 
    345339               DO ji = fs_2, fs_jpim1   ! vector opt.   
    346                   zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
     340                  zbtr = r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 
    347341                  ! horizontal advective trends 
    348342                  ztra = - zbtr * ( zwy(ji,jj,jk) - zwy(ji,jj-1,jk) ) 
    … …  
    352346            END DO 
    353347         END DO 
    354          !                                 ! trend diagnostics (contribution of upstream fluxes) 
     348         !                                 ! trend diagnostics 
    355349         IF( l_trd )   CALL trd_tra( kt, cdtype, jn, jptra_yad, zwy, pvn, ptn(:,:,:,jn) ) 
    356350         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    … …  
    380374      ! 
    381375      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    382       REAL(wp) ::   zbtr , ztra      ! local scalars 
    383376      REAL(wp), POINTER, DIMENSION(:,:,:) :: zwz 
    384377      !!---------------------------------------------------------------------- 
    385378      ! 
    386       CALL wrk_alloc( jpi, jpj, jpk, zwz ) 
     379      CALL wrk_alloc( jpi,jpj,jpk,   zwz ) 
     380      ! 
     381      zwz(:,:, 1 ) = 0._wp       ! surface & bottom values set to zero for all tracers 
     382      zwz(:,:,jpk) = 0._wp 
     383      ! 
    387384      !                                                          ! =========== 
    388385      DO jn = 1, kjpt                                            ! tracer loop 
    389386         !                                                       ! =========== 
    390          ! 1. Bottom value : flux set to zero 
    391          zwz(:,:,jpk) = 0.e0             ! Bottom value : flux set to zero 
    392          ! 
    393          !                                 ! Surface value 
    394          IF( lk_vvl ) THEN   ;   zwz(:,:, 1 ) = 0.e0                      ! Variable volume : flux set to zero 
    395          ELSE                ;   zwz(:,:, 1 ) = pwn(:,:,1) * ptn(:,:,1,jn)   ! Constant volume : advective flux through the surface 
     387         ! 
     388         DO jk = 2, jpkm1                    !* Interior point   (w-masked 2nd order centered flux) 
     389            DO jj = 2, jpjm1 
     390               DO ji = fs_2, fs_jpim1   ! vector opt. 
     391                  zwz(ji,jj,jk) = 0.5 * pwn(ji,jj,jk) * ( ptn(ji,jj,jk-1,jn) + ptn(ji,jj,jk,jn) ) * wmask(ji,jj,jk) 
     392               END DO 
     393            END DO 
     394         END DO 
     395         IF( ln_linssh ) THEN                !* top value   (only in linear free surf. as zwz is multiplied by wmask) 
     396            IF( ln_isfcav ) THEN                  ! ice-shelf cavities (top of the ocean) 
     397               DO jj = 1, jpj 
     398                  DO ji = 1, jpi 
     399                     zwz(ji,jj, mikt(ji,jj) ) = pwn(ji,jj,mikt(ji,jj)) * ptn(ji,jj,mikt(ji,jj),jn)   ! linear free surface  
     400                  END DO 
     401               END DO    
     402            ELSE                                   ! no ocean cavities (only ocean surface) 
     403               zwz(:,:,1) = pwn(:,:,1) * ptn(:,:,1,jn) 
     404            ENDIF 
    396405         ENDIF 
    397406         ! 
    398          DO jk = 2, jpkm1                  ! Interior point: second order centered tracer flux at w-point 
     407         DO jk = 1, jpkm1          !==  Tracer flux divergence added to the general trend  ==! 
    399408            DO jj = 2, jpjm1 
    400409               DO ji = fs_2, fs_jpim1   ! vector opt. 
    401                   zwz(ji,jj,jk) = 0.5 * pwn(ji,jj,jk) * ( ptn(ji,jj,jk-1,jn) + ptn(ji,jj,jk,jn) ) 
    402                END DO 
    403             END DO 
    404          END DO 
    405          ! 
    406          DO jk = 1, jpkm1          !==  Tracer flux divergence added to the general trend  ==! 
    407             DO jj = 2, jpjm1 
    408                DO ji = fs_2, fs_jpim1   ! vector opt. 
    409                   zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    410                   ! k- vertical advective trends  
    411                   ztra = - zbtr * ( zwz(ji,jj,jk) - zwz(ji,jj,jk+1) )  
    412                   ! added to the general tracer trends 
    413                   pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra 
    414                END DO 
    415             END DO 
    416          END DO 
    417          !                                 ! Save the vertical advective trends for diagnostic 
     410                  pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) - ( zwz(ji,jj,jk) - zwz(ji,jj,jk+1) )   & 
     411                     &                                * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 
     412               END DO 
     413            END DO 
     414         END DO 
     415         !                                 ! Send trends for diagnostic 
    418416         IF( l_trd )  CALL trd_tra( kt, cdtype, jn, jptra_zad, zwz, pwn, ptn(:,:,:,jn) ) 
    419417         ! 
    420418      END DO 
    421419      ! 
    422       CALL wrk_dealloc( jpi, jpj, jpk, zwz ) 
     420      CALL wrk_dealloc( jpi,jpj,jpk,  zwz ) 
    423421      ! 
    424422   END SUBROUTINE tra_adv_cen2_k 

  • branches/NERC/dev_r5549_BDY_ZEROGRAD/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_ubs.F90

    r5147 r6808  
    1616   USE trc_oce        ! share passive tracers/Ocean variables 
    1717   USE trd_oce        ! trends: ocean variables 
     18   USE traadv_fct      ! acces to routine interp_4th_cpt  
    1819   USE trdtra         ! trends manager: tracers  
    19    USE dynspg_oce     ! choice/control of key cpp for surface pressure gradient 
    2020   USE diaptr         ! poleward transport diagnostics 
    2121   ! 
    … …  
    3535 
    3636   !! * Substitutions 
    37 #  include "domzgr_substitute.h90" 
    3837#  include "vectopt_loop_substitute.h90" 
    3938   !!---------------------------------------------------------------------- 
    40    !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
     39   !! NEMO/OPA 3.7 , NEMO Consortium (2015) 
    4140   !! $Id$ 
    4241   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    … …  
    4443CONTAINS 
    4544 
    46    SUBROUTINE tra_adv_ubs ( kt, kit000, cdtype, p2dt, pun, pvn, pwn,      & 
    47       &                                       ptb, ptn, pta, kjpt ) 
     45   SUBROUTINE tra_adv_ubs( kt, kit000, cdtype, p2dt, pun, pvn, pwn,          & 
     46      &                                                ptb, ptn, pta, kjpt, kn_ubs_v ) 
    4847      !!---------------------------------------------------------------------- 
    4948      !!                  ***  ROUTINE tra_adv_ubs  *** 
    … …  
    5251      !!      and add it to the general trend of passive tracer equations. 
    5352      !! 
    54       !! ** Method  :   The upstream biased scheme (UBS) is based on a 3rd order 
     53      !! ** Method  :   The 3rd order Upstream Biased Scheme (UBS) is based on an 
    5554      !!      upstream-biased parabolic interpolation (Shchepetkin and McWilliams 2005) 
    5655      !!      It is only used in the horizontal direction. 
    … …  
    6160      !!      where zltu is the second derivative of the before temperature field: 
    6261      !!          zltu = 1/e3t di[ e2u e3u / e1u di[Tb] ] 
    63       !!      This results in a dissipatively dominant (i.e. hyper-diffusive)  
     62      !!        This results in a dissipatively dominant (i.e. hyper-diffusive)  
    6463      !!      truncation error. The overall performance of the advection scheme  
    6564      !!      is similar to that reported in (Farrow and Stevens, 1995).  
    66       !!      For stability reasons, the first term of the fluxes which corresponds 
     65      !!        For stability reasons, the first term of the fluxes which corresponds 
    6766      !!      to a second order centered scheme is evaluated using the now velocity  
    6867      !!      (centered in time) while the second term which is the diffusive part  
    6968      !!      of the scheme, is evaluated using the before velocity (forward in time).  
    7069      !!      Note that UBS is not positive. Do not use it on passive tracers. 
    71       !!                On the vertical, the advection is evaluated using a TVD scheme, 
    72       !!      as the UBS have been found to be too diffusive. 
     70      !!                On the vertical, the advection is evaluated using a FCT scheme, 
     71      !!      as the UBS have been found to be too diffusive.  
     72      !!                kn_ubs_v argument controles whether the FCT is based on  
     73      !!      a 2nd order centrered scheme (kn_ubs_v=2) or on a 4th order compact  
     74      !!      scheme (kn_ubs_v=4). 
    7375      !! 
    74       !! ** Action : - update (pta) with the now advective tracer trends 
     76      !! ** Action : - update pta  with the now advective tracer trends 
     77      !!             - send trends to trdtra module for further diagnostcs (l_trdtra=T) 
     78      !!             - htr_adv, str_adv : poleward advective heat and salt transport (ln_diaptr=T) 
    7579      !! 
    7680      !! Reference : Shchepetkin, A. F., J. C. McWilliams, 2005, Ocean Modelling, 9, 347-404.  
    … …  
    8185      CHARACTER(len=3)                     , INTENT(in   ) ::   cdtype          ! =TRA or TRC (tracer indicator) 
    8286      INTEGER                              , INTENT(in   ) ::   kjpt            ! number of tracers 
    83       REAL(wp), DIMENSION(        jpk     ), INTENT(in   ) ::   p2dt            ! vertical profile of tracer time-step 
     87      INTEGER                              , INTENT(in   ) ::   kn_ubs_v        ! number of tracers 
     88      REAL(wp)                             , INTENT(in   ) ::   p2dt            ! tracer time-step 
    8489      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pun, pvn, pwn   ! 3 ocean transport components 
    8590      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb, ptn        ! before and now tracer fields 
    … …  
    8792      ! 
    8893      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    89       REAL(wp) ::   ztra, zbtr, zcoef, z2dtt                       ! local scalars 
     94      REAL(wp) ::   ztra, zbtr, zcoef                       ! local scalars 
    9095      REAL(wp) ::   zfp_ui, zfm_ui, zcenut, ztak, zfp_wk, zfm_wk   !   -      - 
    9196      REAL(wp) ::   zfp_vj, zfm_vj, zcenvt, zeeu, zeev, z_hdivn    !   -      - 
    … …  
    95100      IF( nn_timing == 1 )  CALL timing_start('tra_adv_ubs') 
    96101      ! 
    97       CALL wrk_alloc( jpi, jpj, jpk, ztu, ztv, zltu, zltv, zti, ztw ) 
     102      CALL wrk_alloc( jpi,jpj,jpk,  ztu, ztv, zltu, zltv, zti, ztw ) 
    98103      ! 
    99104      IF( kt == kit000 )  THEN 
    … …  
    106111      IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 
    107112      ! 
     113      ztw (:,:, 1 ) = 0._wp      ! surface & bottom value : set to zero for all tracers 
     114      zltu(:,:,jpk) = 0._wp   ;   zltv(:,:,jpk) = 0._wp 
     115      ztw (:,:,jpk) = 0._wp   ;   zti (:,:,jpk) = 0._wp 
     116      ! 
    108117      !                                                          ! =========== 
    109118      DO jn = 1, kjpt                                            ! tracer loop 
    110119         !                                                       ! =========== 
    111          ! 1. Bottom value : flux set to zero 
    112          ! ---------------------------------- 
    113          zltu(:,:,jpk) = 0.e0       ;      zltv(:,:,jpk) = 0.e0 
    114120         !                                               
    115          DO jk = 1, jpkm1                                 ! Horizontal slab 
    116             !                                    
    117             !  Laplacian 
    118             DO jj = 1, jpjm1            ! First derivative (gradient) 
     121         DO jk = 1, jpkm1        !==  horizontal laplacian of before tracer ==! 
     122            DO jj = 1, jpjm1              ! First derivative (masked gradient) 
    119123               DO ji = 1, fs_jpim1   ! vector opt. 
    120                   zeeu = e2u(ji,jj) * fse3u(ji,jj,jk) / e1u(ji,jj) * umask(ji,jj,jk) 
    121                   zeev = e1v(ji,jj) * fse3v(ji,jj,jk) / e2v(ji,jj) * vmask(ji,jj,jk) 
     124                  zeeu = e2_e1u(ji,jj) * e3u_n(ji,jj,jk) * umask(ji,jj,jk) 
     125                  zeev = e1_e2v(ji,jj) * e3v_n(ji,jj,jk) * vmask(ji,jj,jk) 
    122126                  ztu(ji,jj,jk) = zeeu * ( ptb(ji+1,jj  ,jk,jn) - ptb(ji,jj,jk,jn) ) 
    123127                  ztv(ji,jj,jk) = zeev * ( ptb(ji  ,jj+1,jk,jn) - ptb(ji,jj,jk,jn) ) 
    124128               END DO 
    125129            END DO 
    126             DO jj = 2, jpjm1            ! Second derivative (divergence) 
     130            DO jj = 2, jpjm1              ! Second derivative (divergence) 
    127131               DO ji = fs_2, fs_jpim1   ! vector opt. 
    128                   zcoef = 1. / ( 6. * fse3t(ji,jj,jk) ) 
     132                  zcoef = 1._wp / ( 6._wp * e3t_n(ji,jj,jk) ) 
    129133                  zltu(ji,jj,jk) = (  ztu(ji,jj,jk) - ztu(ji-1,jj,jk)  ) * zcoef 
    130134                  zltv(ji,jj,jk) = (  ztv(ji,jj,jk) - ztv(ji,jj-1,jk)  ) * zcoef 
    … …  
    132136            END DO 
    133137            !                                     
    134          END DO                                           ! End of slab          
     138         END DO          
    135139         CALL lbc_lnk( zltu, 'T', 1. )   ;    CALL lbc_lnk( zltv, 'T', 1. )   ! Lateral boundary cond. (unchanged sgn) 
    136  
    137140         !     
    138          !  Horizontal advective fluxes                
    139          DO jk = 1, jpkm1                                 ! Horizontal slab 
     141         DO jk = 1, jpkm1        !==  Horizontal advective fluxes  ==!     (UBS) 
    140142            DO jj = 1, jpjm1 
    141143               DO ji = 1, fs_jpim1   ! vector opt. 
    142                   ! upstream transport (x2) 
    143                   zfp_ui = pun(ji,jj,jk) + ABS( pun(ji,jj,jk) ) 
     144                  zfp_ui = pun(ji,jj,jk) + ABS( pun(ji,jj,jk) )      ! upstream transport (x2) 
    144145                  zfm_ui = pun(ji,jj,jk) - ABS( pun(ji,jj,jk) ) 
    145146                  zfp_vj = pvn(ji,jj,jk) + ABS( pvn(ji,jj,jk) ) 
    146147                  zfm_vj = pvn(ji,jj,jk) - ABS( pvn(ji,jj,jk) ) 
    147                   ! 2nd order centered advective fluxes (x2) 
     148                  !                                                  ! 2nd order centered advective fluxes (x2) 
    148149                  zcenut = pun(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji+1,jj  ,jk,jn) ) 
    149150                  zcenvt = pvn(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji  ,jj+1,jk,jn) ) 
    150                   ! UBS advective fluxes 
     151                  !                                                  ! UBS advective fluxes 
    151152                  ztu(ji,jj,jk) = 0.5 * ( zcenut - zfp_ui * zltu(ji,jj,jk) - zfm_ui * zltu(ji+1,jj,jk) ) 
    152153                  ztv(ji,jj,jk) = 0.5 * ( zcenvt - zfp_vj * zltv(ji,jj,jk) - zfm_vj * zltv(ji,jj+1,jk) ) 
    153154               END DO 
    154155            END DO 
    155          END DO                                           ! End of slab          
    156  
    157          zltu(:,:,:) = pta(:,:,:,jn)      ! store pta trends 
    158  
    159          DO jk = 1, jpkm1                 ! Horizontal advective trends 
     156         END DO          
     157         ! 
     158         zltu(:,:,:) = pta(:,:,:,jn)      ! store the initial trends before its update 
     159         ! 
     160         DO jk = 1, jpkm1        !==  add the horizontal advective trend  ==! 
    160161            DO jj = 2, jpjm1 
    161162               DO ji = fs_2, fs_jpim1   ! vector opt. 
    162163                  pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn)                        & 
    163164                     &             - (  ztu(ji,jj,jk) - ztu(ji-1,jj  ,jk)    & 
    164                      &                + ztv(ji,jj,jk) - ztv(ji  ,jj-1,jk)  ) / ( e1e2t(ji,jj) * fse3t(ji,jj,jk) ) 
     165                     &                + ztv(ji,jj,jk) - ztv(ji  ,jj-1,jk)  ) * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 
    165166               END DO 
    166167            END DO 
    167168            !                                              
    168          END DO                                           !   End of slab 
    169  
    170          ! Horizontal trend used in tra_adv_ztvd subroutine 
    171          zltu(:,:,:) = pta(:,:,:,jn) - zltu(:,:,:) 
    172  
     169         END DO 
     170         ! 
     171         zltu(:,:,:) = pta(:,:,:,jn) - zltu(:,:,:)    ! Horizontal advective trend used in vertical 2nd order FCT case 
     172         !                                            ! and/or in trend diagnostic (l_trd=T)  
    173173         !                 
    174174         IF( l_trd ) THEN                  ! trend diagnostics 
    … …  
    181181            IF( jn == jp_sal )  str_adv(:) = ptr_sj( ztv(:,:,:) ) 
    182182         ENDIF 
    183           
    184          ! TVD scheme for the vertical direction   
    185          ! ---------------------- 
    186          IF( l_trd )   zltv(:,:,:) = pta(:,:,:,jn)          ! store pta if trend diag. 
    187  
    188          !  Bottom value : flux set to zero 
    189          ztw(:,:,jpk) = 0.e0   ;   zti(:,:,jpk) = 0.e0 
    190  
    191          ! Surface value 
    192          IF( lk_vvl ) THEN   ;   ztw(:,:,1) = 0.e0                      ! variable volume : flux set to zero 
    193          ELSE                ;   ztw(:,:,1) = pwn(:,:,1) * ptb(:,:,1,jn)   ! free constant surface  
    194          ENDIF 
    195          !  upstream advection with initial mass fluxes & intermediate update 
    196          ! ------------------------------------------------------------------- 
    197          ! Interior value 
    198          DO jk = 2, jpkm1 
    199             DO jj = 1, jpj 
    200                DO ji = 1, jpi 
    201                    zfp_wk = pwn(ji,jj,jk) + ABS( pwn(ji,jj,jk) ) 
    202                    zfm_wk = pwn(ji,jj,jk) - ABS( pwn(ji,jj,jk) ) 
    203                    ztw(ji,jj,jk) = 0.5 * (  zfp_wk * ptb(ji,jj,jk,jn) + zfm_wk * ptb(ji,jj,jk-1,jn)  ) 
    204                END DO 
    205             END DO 
    206          END DO  
    207          ! update and guess with monotonic sheme 
    208          DO jk = 1, jpkm1 
    209             z2dtt = p2dt(jk) 
    210             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                   ztak = - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) * zbtr 
    214                   pta(ji,jj,jk,jn) =   pta(ji,jj,jk,jn) +  ztak  
    215                   zti(ji,jj,jk)    = ( ptb(ji,jj,jk,jn) + z2dtt * ( ztak + zltu(ji,jj,jk) ) ) * tmask(ji,jj,jk) 
    216                END DO 
    217             END DO 
    218          END DO 
    219          ! 
    220          CALL lbc_lnk( zti, 'T', 1. )      ! Lateral boundary conditions on zti, zsi   (unchanged sign) 
    221  
    222          !  antidiffusive flux : high order minus low order 
    223          ztw(:,:,1) = 0.e0       ! Surface value 
    224          DO jk = 2, jpkm1        ! Interior value 
    225             DO jj = 1, jpj 
    226                DO ji = 1, jpi 
    227                   ztw(ji,jj,jk) = 0.5 * pwn(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji,jj,jk-1,jn) ) - ztw(ji,jj,jk) 
    228                END DO 
    229             END DO 
    230          END DO 
    231          ! 
    232          CALL nonosc_z( ptb(:,:,:,jn), ztw, zti, p2dt )      !  monotonicity algorithm 
    233  
    234          !  final trend with corrected fluxes 
    235          DO jk = 1, jpkm1 
     183         ! 
     184         !                       !== vertical advective trend  ==! 
     185         ! 
     186         SELECT CASE( kn_ubs_v )       ! select the vertical advection scheme 
     187         ! 
     188         CASE(  2  )                   ! 2nd order FCT  
     189            !          
     190            IF( l_trd )   zltv(:,:,:) = pta(:,:,:,jn)          ! store pta if trend diag. 
     191            ! 
     192            !                          !*  upstream advection with initial mass fluxes & intermediate update  ==! 
     193            DO jk = 2, jpkm1                 ! Interior value (w-masked) 
     194               DO jj = 1, jpj 
     195                  DO ji = 1, jpi 
     196                     zfp_wk = pwn(ji,jj,jk) + ABS( pwn(ji,jj,jk) ) 
     197                     zfm_wk = pwn(ji,jj,jk) - ABS( pwn(ji,jj,jk) ) 
     198                     ztw(ji,jj,jk) = 0.5_wp * (  zfp_wk * ptb(ji,jj,jk,jn) + zfm_wk * ptb(ji,jj,jk-1,jn)  ) * wmask(ji,jj,jk) 
     199                  END DO 
     200               END DO 
     201            END DO  
     202            IF( ln_linssh ) THEN             ! top ocean value (only in linear free surface as ztw has been w-masked) 
     203               IF( ln_isfcav ) THEN                ! top of the ice-shelf cavities and at the ocean surface 
     204                  DO jj = 1, jpj 
     205                     DO ji = 1, jpi 
     206                        ztw(ji,jj, mikt(ji,jj) ) = pwn(ji,jj,mikt(ji,jj)) * ptb(ji,jj,mikt(ji,jj),jn)   ! linear free surface  
     207                     END DO 
     208                  END DO    
     209               ELSE                                ! no cavities: only at the ocean surface 
     210                  ztw(:,:,1) = pwn(:,:,1) * ptb(:,:,1,jn) 
     211               ENDIF 
     212            ENDIF 
     213            ! 
     214            DO jk = 1, jpkm1           !* trend and after field with monotonic scheme 
     215               DO jj = 2, jpjm1 
     216                  DO ji = fs_2, fs_jpim1   ! vector opt. 
     217                     ztak = - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 
     218                     pta(ji,jj,jk,jn) =   pta(ji,jj,jk,jn) +  ztak  
     219                     zti(ji,jj,jk)    = ( ptb(ji,jj,jk,jn) + p2dt * ( ztak + zltu(ji,jj,jk) ) ) * tmask(ji,jj,jk) 
     220                  END DO 
     221               END DO 
     222            END DO 
     223            CALL lbc_lnk( zti, 'T', 1. )      ! Lateral boundary conditions on zti, zsi   (unchanged sign) 
     224            ! 
     225            !                          !*  anti-diffusive flux : high order minus low order 
     226            DO jk = 2, jpkm1        ! Interior value  (w-masked) 
     227               DO jj = 1, jpj 
     228                  DO ji = 1, jpi 
     229                     ztw(ji,jj,jk) = (   0.5_wp * pwn(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji,jj,jk-1,jn) )   & 
     230                        &              - ztw(ji,jj,jk)   ) * wmask(ji,jj,jk) 
     231                  END DO 
     232               END DO 
     233            END DO 
     234            !                                            ! top ocean value: high order == upstream  ==>>  zwz=0 
     235            IF( ln_linssh )   ztw(:,:, 1 ) = 0._wp       ! only ocean surface as interior zwz values have been w-masked 
     236            ! 
     237            CALL nonosc_z( ptb(:,:,:,jn), ztw, zti, p2dt )      !  monotonicity algorithm 
     238            ! 
     239         CASE(  4  )                               ! 4th order COMPACT 
     240            CALL interp_4th_cpt( ptn(:,:,:,jn) , ztw )         ! 4th order compact interpolation of T at w-point 
     241            DO jk = 2, jpkm1 
     242               DO jj = 2, jpjm1 
     243                  DO ji = fs_2, fs_jpim1 
     244                     ztw(ji,jj,jk) = pwn(ji,jj,jk) * ztw(ji,jj,jk) * wmask(ji,jj,jk) 
     245                  END DO 
     246               END DO 
     247            END DO 
     248            IF( ln_linssh )   ztw(:,:, 1 ) = pwn(:,:,1) * ptn(:,:,1,jn)     !!gm ISF & 4th COMPACT doesn't work 
     249            ! 
     250         END SELECT 
     251         ! 
     252         DO jk = 1, jpkm1        !  final trend with corrected fluxes 
    236253            DO jj = 2, jpjm1  
    237254               DO ji = fs_2, fs_jpim1   ! vector opt.    
    238                   zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    239                   ! k- vertical advective trends   
    240                   ztra = - zbtr * ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) 
    241                   ! added to the general tracer trends 
    242                   pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra 
    243                END DO 
    244             END DO 
    245          END DO 
    246  
    247          !  Save the final vertical advective trends 
    248          IF( l_trd )  THEN                        ! vertical advective trend diagnostics 
     255                  pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 
     256               END DO 
     257            END DO 
     258         END DO 
     259         ! 
     260         IF( l_trd )  THEN       ! vertical advective trend diagnostics 
    249261            DO jk = 1, jpkm1                       ! (compute -w.dk[ptn]= -dk[w.ptn] + ptn.dk[w]) 
    250262               DO jj = 2, jpjm1 
    251263                  DO ji = fs_2, fs_jpim1   ! vector opt. 
    252                      zbtr = 1.e0 / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    253                      z_hdivn = (  pwn(ji,jj,jk) - pwn(ji,jj,jk+1)  ) * zbtr 
    254                      zltv(ji,jj,jk) = pta(ji,jj,jk,jn) - zltv(ji,jj,jk) + ptn(ji,jj,jk,jn) * z_hdivn 
     264                     zltv(ji,jj,jk) = pta(ji,jj,jk,jn) - zltv(ji,jj,jk)                          & 
     265                        &           + ptn(ji,jj,jk,jn) * (  pwn(ji,jj,jk) - pwn(ji,jj,jk+1)  )   & 
     266                        &                              * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 
    255267                  END DO 
    256268               END DO 
    … …  
    261273      END DO 
    262274      ! 
    263       CALL wrk_dealloc( jpi, jpj, jpk, ztu, ztv, zltu, zltv, zti, ztw ) 
     275      CALL wrk_dealloc( jpi,jpj,jpk,  ztu, ztv, zltu, zltv, zti, ztw ) 
    264276      ! 
    265277      IF( nn_timing == 1 )  CALL timing_stop('tra_adv_ubs') 
    … …  
    281293      !!       in-space based differencing for fluid 
    282294      !!---------------------------------------------------------------------- 
    283       REAL(wp), INTENT(in   ), DIMENSION(jpk)          ::   p2dt   ! vertical profile of tracer time-step 
     295      REAL(wp), INTENT(in   )                          ::   p2dt   ! tracer time-step 
    284296      REAL(wp),                DIMENSION (jpi,jpj,jpk) ::   pbef   ! before field 
    285297      REAL(wp), INTENT(inout), DIMENSION (jpi,jpj,jpk) ::   paft   ! after field 
    … …  
    288300      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    289301      INTEGER  ::   ikm1         ! local integer 
    290       REAL(wp) ::   zpos, zneg, zbt, za, zb, zc, zbig, zrtrn, z2dtt   ! local scalars 
     302      REAL(wp) ::   zpos, zneg, zbt, za, zb, zc, zbig, zrtrn   ! local scalars 
    291303      REAL(wp), POINTER, DIMENSION(:,:,:) :: zbetup, zbetdo 
    292304      !!---------------------------------------------------------------------- 
    … …  
    294306      IF( nn_timing == 1 )  CALL timing_start('nonosc_z') 
    295307      ! 
    296       CALL wrk_alloc( jpi, jpj, jpk, zbetup, zbetdo ) 
     308      CALL wrk_alloc( jpi,jpj,jpk,  zbetup, zbetdo ) 
    297309      ! 
    298310      zbig  = 1.e+40_wp 
    299311      zrtrn = 1.e-15_wp 
    300312      zbetup(:,:,:) = 0._wp   ;   zbetdo(:,:,:) = 0._wp 
    301  
     313      ! 
    302314      ! Search local extrema 
    303315      ! -------------------- 
    304       ! large negative value (-zbig) inside land 
     316      !                    ! large negative value (-zbig) inside land 
    305317      pbef(:,:,:) = pbef(:,:,:) * tmask(:,:,:) - zbig * ( 1.e0 - tmask(:,:,:) ) 
    306318      paft(:,:,:) = paft(:,:,:) * tmask(:,:,:) - zbig * ( 1.e0 - tmask(:,:,:) ) 
    307       ! search maximum in neighbourhood 
    308       DO jk = 1, jpkm1 
     319      ! 
     320      DO jk = 1, jpkm1     ! search maximum in neighbourhood 
    309321         ikm1 = MAX(jk-1,1) 
    310322         DO jj = 2, jpjm1 
    … …  
    316328         END DO 
    317329      END DO 
    318       ! large positive value (+zbig) inside land 
     330      !                    ! large positive value (+zbig) inside land 
    319331      pbef(:,:,:) = pbef(:,:,:) * tmask(:,:,:) + zbig * ( 1.e0 - tmask(:,:,:) ) 
    320332      paft(:,:,:) = paft(:,:,:) * tmask(:,:,:) + zbig * ( 1.e0 - tmask(:,:,:) ) 
    321       ! search minimum in neighbourhood 
    322       DO jk = 1, jpkm1 
     333      ! 
     334      DO jk = 1, jpkm1     ! search minimum in neighbourhood 
    323335         ikm1 = MAX(jk-1,1) 
    324336         DO jj = 2, jpjm1 
    … …  
    330342         END DO 
    331343      END DO 
    332  
    333       ! restore masked values to zero 
     344      !                    ! restore masked values to zero 
    334345      pbef(:,:,:) = pbef(:,:,:) * tmask(:,:,:) 
    335346      paft(:,:,:) = paft(:,:,:) * tmask(:,:,:) 
    336  
    337  
    338       ! 2. Positive and negative part of fluxes and beta terms 
    339       ! ------------------------------------------------------ 
    340  
     347      ! 
     348      ! Positive and negative part of fluxes and beta terms 
     349      ! --------------------------------------------------- 
    341350      DO jk = 1, jpkm1 
    342          z2dtt = p2dt(jk) 
    343351         DO jj = 2, jpjm1 
    344352            DO ji = fs_2, fs_jpim1   ! vector opt. 
    … …  
    347355               zneg = MAX( 0., pcc(ji  ,jj  ,jk  ) ) - MIN( 0., pcc(ji  ,jj  ,jk+1) ) 
    348356               ! up & down beta terms 
    349                zbt = e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) / z2dtt 
     357               zbt = e1e2t(ji,jj) * e3t_n(ji,jj,jk) / p2dt 
    350358               zbetup(ji,jj,jk) = ( zbetup(ji,jj,jk) - paft(ji,jj,jk) ) / (zpos+zrtrn) * zbt 
    351359               zbetdo(ji,jj,jk) = ( paft(ji,jj,jk) - zbetdo(ji,jj,jk) ) / (zneg+zrtrn) * zbt 
    … …  
    353361         END DO 
    354362      END DO 
     363      ! 
    355364      ! monotonic flux in the k direction, i.e. pcc 
    356365      ! ------------------------------------------- 
    … …  
    366375      END DO 
    367376      ! 
    368       CALL wrk_dealloc( jpi, jpj, jpk, zbetup, zbetdo ) 
     377      CALL wrk_dealloc( jpi,jpj,jpk,  zbetup, zbetdo ) 
    369378      ! 
    370379      IF( nn_timing == 1 )  CALL timing_stop('nonosc_z') 

  • branches/NERC/dev_r5549_BDY_ZEROGRAD/NEMOGCM/NEMO/OPA_SRC/TRA/trabbc.F90

    r5397 r6808  
    1212 
    1313   !!---------------------------------------------------------------------- 
    14    !!   tra_bbc      : update the tracer trend at ocean bottom  
    15    !!   tra_bbc_init : initialization of geothermal heat flux trend 
     14   !!   tra_bbc       : update the tracer trend at ocean bottom  
     15   !!   tra_bbc_init  : initialization of geothermal heat flux trend 
    1616   !!---------------------------------------------------------------------- 
    17    USE oce             ! ocean variables 
    18    USE dom_oce         ! domain: ocean 
    19    USE phycst          ! physical constants 
    20    USE trd_oce         ! trends: ocean variables 
    21    USE trdtra          ! trends manager: tracers  
    22    USE in_out_manager  ! I/O manager 
    23    USE iom             ! I/O manager 
    24    USE fldread         ! read input fields 
    25    USE lbclnk            ! ocean lateral boundary conditions (or mpp link) 
    26    USE lib_mpp           ! distributed memory computing library 
    27    USE prtctl          ! Print control 
    28    USE wrk_nemo        ! Memory Allocation 
    29    USE timing          ! Timing 
     17   USE oce            ! ocean variables 
     18   USE dom_oce        ! domain: ocean 
     19   USE phycst         ! physical constants 
     20   USE trd_oce        ! trends: ocean variables 
     21   USE trdtra         ! trends manager: tracers  
     22   ! 
     23   USE in_out_manager ! I/O manager 
     24   USE iom            ! xIOS  
     25   USE fldread        ! read input fields 
     26   USE lbclnk         ! ocean lateral boundary conditions (or mpp link) 
     27   USE lib_mpp        ! distributed memory computing library 
     28   USE prtctl         ! Print control 
     29   USE wrk_nemo       ! Memory Allocation 
     30   USE timing         ! Timing 
    3031 
    3132   IMPLICIT NONE 
    … …  
    4041   REAL(wp)        ::   rn_geoflx_cst !  Constant value of geothermal heat flux 
    4142 
    42    REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE ::   qgh_trd0   ! geothermal heating trend 
    43    TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_qgh              ! structure of input qgh (file informations, fields read) 
     43   REAL(wp), PUBLIC , ALLOCATABLE, DIMENSION(:,:) ::   qgh_trd0   ! geothermal heating trend 
     44 
     45   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_qgh   ! structure of input qgh (file informations, fields read) 
    4446  
    45    !! * Substitutions 
    46 #  include "domzgr_substitute.h90" 
    4747   !!---------------------------------------------------------------------- 
    4848   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    … …  
    6868      !!       Where Qsf is the geothermal heat flux. 
    6969      !! 
    70       !! ** Action  : - update the temperature trends (ta) with the trend of 
    71       !!                the ocean bottom boundary condition 
     70      !! ** Action  : - update the temperature trends with geothermal heating trend 
     71      !!              - send the trend for further diagnostics (ln_trdtra=T) 
    7272      !! 
    7373      !! References : Stein, C. A., and S. Stein, 1992, Nature, 359, 123-129. 
    … …  
    7575      !!---------------------------------------------------------------------- 
    7676      INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
    77       !! 
    78       INTEGER  ::   ji, jj, ik    ! dummy loop indices 
    79       REAL(wp) ::   zqgh_trd      ! geothermal heat flux trend 
     77      ! 
     78      INTEGER  ::   ji, jj    ! dummy loop indices 
    8079      REAL(wp), POINTER, DIMENSION(:,:,:) ::   ztrdt 
    8180      !!---------------------------------------------------------------------- 
    … …  
    8382      IF( nn_timing == 1 )  CALL timing_start('tra_bbc') 
    8483      ! 
    85       IF( l_trdtra )   THEN         ! Save ta and sa trends 
    86          CALL wrk_alloc( jpi, jpj, jpk, ztrdt ) 
     84      IF( l_trdtra )   THEN         ! Save the input temperature trend 
     85         CALL wrk_alloc( jpi,jpj,jpk,  ztrdt ) 
    8786         ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 
    8887      ENDIF 
    89       ! 
    90       !                             !  Add the geothermal heat flux trend on temperature 
     88      !                             !  Add the geothermal trend on temperature 
    9189      DO jj = 2, jpjm1 
    9290         DO ji = 2, jpim1 
    93             ik = mbkt(ji,jj) 
    94             zqgh_trd = qgh_trd0(ji,jj) / fse3t(ji,jj,ik) 
    95             tsa(ji,jj,ik,jp_tem) = tsa(ji,jj,ik,jp_tem) + zqgh_trd 
     91            tsa(ji,jj,mbkt(ji,jj),jp_tem) = tsa(ji,jj,mbkt(ji,jj),jp_tem) + qgh_trd0(ji,jj) / e3t_n(ji,jj,mbkt(ji,jj)) 
    9692         END DO 
    9793      END DO 
    … …  
    9995      CALL lbc_lnk( tsa(:,:,:,jp_tem) , 'T', 1. ) 
    10096      ! 
    101       IF( l_trdtra ) THEN        ! Save the geothermal heat flux trend for diagnostics 
     97      IF( l_trdtra ) THEN        ! Send the trend for diagnostics 
    10298         ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 
    10399         CALL trd_tra( kt, 'TRA', jp_tem, jptra_bbc, ztrdt ) 
    104          CALL wrk_dealloc( jpi, jpj, jpk, ztrdt ) 
     100         CALL wrk_dealloc( jpi,jpj,jpk,  ztrdt ) 
    105101      ENDIF 
    106102      ! 
    … …  
    127123      !! ** Action  : - read/fix the geothermal heat qgh_trd0 
    128124      !!---------------------------------------------------------------------- 
    129       USE iom 
    130       !! 
    131125      INTEGER  ::   ji, jj              ! dummy loop indices 
    132126      INTEGER  ::   inum                ! temporary logical unit 
    … …  
    139133      NAMELIST/nambbc/ln_trabbc, nn_geoflx, rn_geoflx_cst, sn_qgh, cn_dir  
    140134      !!---------------------------------------------------------------------- 
    141  
     135      ! 
    142136      REWIND( numnam_ref )              ! Namelist nambbc in reference namelist : Bottom momentum boundary condition 
    143137      READ  ( numnam_ref, nambbc, IOSTAT = ios, ERR = 901) 
    144 901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambbc in reference namelist', lwp ) 
    145  
     138901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nambbc in reference namelist', lwp ) 
     139      ! 
    146140      REWIND( numnam_cfg )              ! Namelist nambbc in configuration namelist : Bottom momentum boundary condition 
    147141      READ  ( numnam_cfg, nambbc, IOSTAT = ios, ERR = 902 ) 
    148 902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambbc in configuration namelist', lwp ) 
     142902   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nambbc in configuration namelist', lwp ) 
    149143      IF(lwm) WRITE ( numond, nambbc ) 
    150  
     144      ! 
    151145      IF(lwp) THEN                     ! Control print 
    152146         WRITE(numout,*) 
    … …  
    159153         WRITE(numout,*) 
    160154      ENDIF 
    161  
     155      ! 
    162156      IF( ln_trabbc ) THEN             !==  geothermal heating  ==! 
    163157         ! 
    … …  
    190184            WRITE(ctmp1,*) '     bad flag value for nn_geoflx = ', nn_geoflx 
    191185            CALL ctl_stop( ctmp1 ) 
    192             ! 
    193186         END SELECT 
    194187         ! 

  • branches/NERC/dev_r5549_BDY_ZEROGRAD/NEMOGCM/NEMO/OPA_SRC/TRA/trabbl.F90

    r4990 r6808  
    1414   !!             -   ! 2013-04  (F. Roquet, G. Madec)  use of eosbn2 instead of local hard coded alpha and beta 
    1515   !!---------------------------------------------------------------------- 
    16 #if   defined key_trabbl   ||   defined key_esopa 
     16#if   defined key_trabbl 
    1717   !!---------------------------------------------------------------------- 
    1818   !!   'key_trabbl'   or                             bottom boundary layer 
    … …  
    2929   USE phycst         ! physical constant 
    3030   USE eosbn2         ! equation of state 
    31    USE trd_oce     ! trends: ocean variables 
     31   USE trd_oce        ! trends: ocean variables 
    3232   USE trdtra         ! trends: active tracers 
    3333   ! 
    … …  
    7070 
    7171   !! * Substitutions 
    72 #  include "domzgr_substitute.h90" 
    7372#  include "vectopt_loop_substitute.h90" 
    7473   !!---------------------------------------------------------------------- 
    … …  
    112111      IF( nn_timing == 1 )  CALL timing_start( 'tra_bbl') 
    113112      ! 
    114       IF( l_trdtra )   THEN                         !* Save ta and sa trends 
     113      IF( l_trdtra )   THEN                         !* Save the input trends 
    115114         CALL wrk_alloc( jpi, jpj, jpk, ztrdt, ztrds ) 
    116115         ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 
    … …  
    132131         ! 
    133132      END IF 
    134  
     133      ! 
    135134      IF( nn_bbl_adv /= 0 ) THEN                    !* Advective bbl 
    136135         ! 
    … …  
    146145      END IF 
    147146 
    148       IF( l_trdtra )   THEN                      ! save the horizontal diffusive trends for further diagnostics 
     147      IF( l_trdtra )   THEN                      ! send the trends for further diagnostics 
    149148         ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 
    150149         ztrds(:,:,:) = tsa(:,:,:,jp_sal) - ztrds(:,:,:) 
    … …  
    198197         DO jj = 1, jpj 
    199198            DO ji = 1, jpi 
    200                ik = mbkt(ji,jj)                              ! bottom T-level index 
    201                zptb(ji,jj) = ptb(ji,jj,ik,jn)       ! bottom before T and S 
     199               ik = mbkt(ji,jj)                             ! bottom T-level index 
     200               zptb(ji,jj) = ptb(ji,jj,ik,jn)               ! bottom before T and S 
    202201            END DO 
    203202         END DO 
    … …  
    205204         DO jj = 2, jpjm1                                    ! Compute the trend 
    206205            DO ji = 2, jpim1 
    207                ik = mbkt(ji,jj)                              ! bottom T-level index 
    208                zbtr = r1_e12t(ji,jj)  / fse3t(ji,jj,ik) 
    209                pta(ji,jj,ik,jn) = pta(ji,jj,ik,jn)                                                         & 
    210                   &               + (   ahu_bbl(ji  ,jj  ) * ( zptb(ji+1,jj  ) - zptb(ji  ,jj  ) )   & 
    211                   &                   - ahu_bbl(ji-1,jj  ) * ( zptb(ji  ,jj  ) - zptb(ji-1,jj  ) )   & 
    212                   &                   + ahv_bbl(ji  ,jj  ) * ( zptb(ji  ,jj+1) - zptb(ji  ,jj  ) )   & 
    213                   &                   - ahv_bbl(ji  ,jj-1) * ( zptb(ji  ,jj  ) - zptb(ji  ,jj-1) )   ) * zbtr 
     206               ik = mbkt(ji,jj)                            ! bottom T-level index 
     207               pta(ji,jj,ik,jn) = pta(ji,jj,ik,jn)                                                  & 
     208                  &             + (  ahu_bbl(ji  ,jj  ) * ( zptb(ji+1,jj  ) - zptb(ji  ,jj  ) )     & 
     209                  &                - ahu_bbl(ji-1,jj  ) * ( zptb(ji  ,jj  ) - zptb(ji-1,jj  ) )     & 
     210                  &                + ahv_bbl(ji  ,jj  ) * ( zptb(ji  ,jj+1) - zptb(ji  ,jj  ) )     & 
     211                  &                - ahv_bbl(ji  ,jj-1) * ( zptb(ji  ,jj  ) - zptb(ji  ,jj-1) )  )  & 
     212                  &             * r1_e1e2t(ji,jj) / e3t_n(ji,jj,ik) 
    214213            END DO 
    215214         END DO 
    … …  
    263262                  ! 
    264263                  !                                               ! up  -slope T-point (shelf bottom point) 
    265                   zbtr = r1_e12t(iis,jj) / fse3t(iis,jj,ikus) 
     264                  zbtr = r1_e1e2t(iis,jj) / e3t_n(iis,jj,ikus) 
    266265                  ztra = zu_bbl * ( ptb(iid,jj,ikus,jn) - ptb(iis,jj,ikus,jn) ) * zbtr 
    267266                  pta(iis,jj,ikus,jn) = pta(iis,jj,ikus,jn) + ztra 
    268267                  ! 
    269268                  DO jk = ikus, ikud-1                            ! down-slope upper to down T-point (deep column) 
    270                      zbtr = r1_e12t(iid,jj) / fse3t(iid,jj,jk) 
     269                     zbtr = r1_e1e2t(iid,jj) / e3t_n(iid,jj,jk) 
    271270                     ztra = zu_bbl * ( ptb(iid,jj,jk+1,jn) - ptb(iid,jj,jk,jn) ) * zbtr 
    272271                     pta(iid,jj,jk,jn) = pta(iid,jj,jk,jn) + ztra 
    273272                  END DO 
    274273                  ! 
    275                   zbtr = r1_e12t(iid,jj) / fse3t(iid,jj,ikud) 
     274                  zbtr = r1_e1e2t(iid,jj) / e3t_n(iid,jj,ikud) 
    276275                  ztra = zu_bbl * ( ptb(iis,jj,ikus,jn) - ptb(iid,jj,ikud,jn) ) * zbtr 
    277276                  pta(iid,jj,ikud,jn) = pta(iid,jj,ikud,jn) + ztra 
    … …  
    285284                  ! 
    286285                  ! up  -slope T-point (shelf bottom point) 
    287                   zbtr = r1_e12t(ji,ijs) / fse3t(ji,ijs,ikvs) 
     286                  zbtr = r1_e1e2t(ji,ijs) / e3t_n(ji,ijs,ikvs) 
    288287                  ztra = zv_bbl * ( ptb(ji,ijd,ikvs,jn) - ptb(ji,ijs,ikvs,jn) ) * zbtr 
    289288                  pta(ji,ijs,ikvs,jn) = pta(ji,ijs,ikvs,jn) + ztra 
    290289                  ! 
    291290                  DO jk = ikvs, ikvd-1                            ! down-slope upper to down T-point (deep column) 
    292                      zbtr = r1_e12t(ji,ijd) / fse3t(ji,ijd,jk) 
     291                     zbtr = r1_e1e2t(ji,ijd) / e3t_n(ji,ijd,jk) 
    293292                     ztra = zv_bbl * ( ptb(ji,ijd,jk+1,jn) - ptb(ji,ijd,jk,jn) ) * zbtr 
    294293                     pta(ji,ijd,jk,jn) = pta(ji,ijd,jk,jn)  + ztra 
    295294                  END DO 
    296295                  !                                               ! down-slope T-point (deep bottom point) 
    297                   zbtr = r1_e12t(ji,ijd) / fse3t(ji,ijd,ikvd) 
     296                  zbtr = r1_e1e2t(ji,ijd) / e3t_n(ji,ijd,ikvd) 
    298297                  ztra = zv_bbl * ( ptb(ji,ijs,ikvs,jn) - ptb(ji,ijd,ikvd,jn) ) * zbtr 
    299298                  pta(ji,ijd,ikvd,jn) = pta(ji,ijd,ikvd,jn) + ztra 
    … …  
    302301            ! 
    303302         END DO 
    304          !                                                  ! =========== 
    305       END DO                                                ! end tracer 
    306       !                                                     ! =========== 
    307       ! 
     303         !                                                       ! =========== 
     304      END DO                                                     ! end tracer 
     305      !                                                          ! =========== 
    308306      IF( nn_timing == 1 )  CALL timing_stop( 'tra_bbl_adv') 
    309307      ! 
    … …  
    340338      INTEGER         , INTENT(in   ) ::   kit000   ! first time step index 
    341339      CHARACTER(len=3), INTENT(in   ) ::   cdtype   ! =TRA or TRC (tracer indicator) 
    342       !! 
     340      ! 
    343341      INTEGER  ::   ji, jj                    ! dummy loop indices 
    344342      INTEGER  ::   ik                        ! local integers 
    … …  
    365363            zts (ji,jj,jp_sal) = tsb(ji,jj,ik,jp_sal) 
    366364            ! 
    367             zdep(ji,jj) = fsdept(ji,jj,ik)               ! bottom T-level reference depth 
     365            zdep(ji,jj) = gdept_n(ji,jj,ik)              ! bottom T-level reference depth 
    368366            zub (ji,jj) = un(ji,jj,mbku(ji,jj))          ! bottom velocity 
    369367            zvb (ji,jj) = vn(ji,jj,mbkv(ji,jj)) 
    … …  
    401399         ! 
    402400      ENDIF 
    403  
     401      ! 
    404402      !                                   !-------------------! 
    405403      IF( nn_bbl_adv /= 0 ) THEN          !   advective bbl   ! 
    … …  
    500498      INTEGER ::   ios                  !   -      - 
    501499      REAL(wp), POINTER, DIMENSION(:,:) :: zmbk 
    502       !! 
     500      ! 
    503501      NAMELIST/nambbl/ nn_bbl_ldf, nn_bbl_adv, rn_ahtbbl, rn_gambbl 
    504502      !!---------------------------------------------------------------------- 
    … …  
    506504      IF( nn_timing == 1 )  CALL timing_start( 'tra_bbl_init') 
    507505      ! 
    508       CALL wrk_alloc( jpi, jpj, zmbk ) 
    509       ! 
    510  
    511506      REWIND( numnam_ref )              ! Namelist nambbl in reference namelist : Bottom boundary layer scheme 
    512507      READ  ( numnam_ref, nambbl, IOSTAT = ios, ERR = 901) 
    513 901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambbl in reference namelist', lwp ) 
    514  
     508901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nambbl in reference namelist', lwp ) 
     509      ! 
    515510      REWIND( numnam_cfg )              ! Namelist nambbl in configuration namelist : Bottom boundary layer scheme 
    516511      READ  ( numnam_cfg, nambbl, IOSTAT = ios, ERR = 902 ) 
    517 902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambbl in configuration namelist', lwp ) 
     512902   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nambbl in configuration namelist', lwp ) 
    518513      IF(lwm) WRITE ( numond, nambbl ) 
    519514      ! 
    … …  
    545540      END DO 
    546541      ! converte into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk 
     542      CALL wrk_alloc( jpi, jpj, zmbk ) 
    547543      zmbk(:,:) = REAL( mbku_d(:,:), wp )   ;   CALL lbc_lnk(zmbk,'U',1.)   ;   mbku_d(:,:) = MAX( INT( zmbk(:,:) ), 1 ) 
    548544      zmbk(:,:) = REAL( mbkv_d(:,:), wp )   ;   CALL lbc_lnk(zmbk,'V',1.)   ;   mbkv_d(:,:) = MAX( INT( zmbk(:,:) ), 1 ) 
     545      CALL wrk_dealloc( jpi, jpj, zmbk ) 
    549546 
    550547                                        !* sign of grad(H) at u- and v-points 
    … …  
    566563 
    567564      !                             !* masked diffusive flux coefficients 
    568       ahu_bbl_0(:,:) = rn_ahtbbl * e2u(:,:) * e3u_bbl_0(:,:) / e1u(:,:) * umask(:,:,1) 
    569       ahv_bbl_0(:,:) = rn_ahtbbl * e1v(:,:) * e3v_bbl_0(:,:) / e2v(:,:) * vmask(:,:,1) 
     565      ahu_bbl_0(:,:) = rn_ahtbbl * e2_e1u(:,:) * e3u_bbl_0(:,:) * umask(:,:,1) 
     566      ahv_bbl_0(:,:) = rn_ahtbbl * e1_e2v(:,:) * e3v_bbl_0(:,:) * vmask(:,:,1) 
    570567 
    571568 
    … …  
    593590      ENDIF 
    594591      ! 
    595       CALL wrk_dealloc( jpi, jpj, zmbk ) 
    596       ! 
    597592      IF( nn_timing == 1 )  CALL timing_stop( 'tra_bbl_init') 
    598593      ! 

  • branches/NERC/dev_r5549_BDY_ZEROGRAD/NEMOGCM/NEMO/OPA_SRC/TRA/tradmp.F90

    r5102 r6808  
    66   !! History :  OPA  ! 1991-03  (O. Marti, G. Madec)  Original code 
    77   !!                 ! 1992-06  (M. Imbard)  doctor norme 
    8    !!                 ! 1996-01  (G. Madec)  statement function for e3 
    9    !!                 ! 1997-05  (G. Madec)  macro-tasked on jk-slab 
    108   !!                 ! 1998-07  (M. Imbard, G. Madec) ORCA version 
    11    !!            7.0  ! 2001-02  (M. Imbard)  cofdis, Original code 
     9   !!            7.0  ! 2001-02  (M. Imbard)  add distance to coast, Original code 
    1210   !!            8.1  ! 2001-02  (G. Madec, E. Durand)  cleaning 
    1311   !!  NEMO      1.0  ! 2002-08  (G. Madec, E. Durand)  free form + modules 
    … …  
    1513   !!            3.3  ! 2010-06  (C. Ethe, G. Madec) merge TRA-TRC  
    1614   !!            3.4  ! 2011-04  (G. Madec, C. Ethe) Merge of dtatem and dtasal + suppression of CPP keys 
     15   !!            3.6  ! 2015-06  (T. Graham)  read restoring coefficient in a file 
     16   !!            3.7  ! 2015-10  (G. Madec)  remove useless trends arrays 
    1717   !!---------------------------------------------------------------------- 
    1818 
    … …  
    3131   USE dtatsd         ! data: temperature & salinity 
    3232   USE zdfmxl         ! vertical physics: mixed layer depth 
     33   ! 
    3334   USE in_out_manager ! I/O manager 
    3435   USE lib_mpp        ! MPP library 
    … …  
    4142   PRIVATE 
    4243 
    43    PUBLIC   tra_dmp      ! routine called by step.F90 
    44    PUBLIC   tra_dmp_init ! routine called by opa.F90 
    45  
    46    !                               !!* Namelist namtra_dmp : T & S newtonian damping * 
    47    ! nn_zdmp and cn_resto are public as they are used by C1D/dyndmp.F90 
    48    LOGICAL , PUBLIC ::   ln_tradmp   !: internal damping flag 
    49    INTEGER , PUBLIC ::   nn_zdmp     ! = 0/1/2 flag for damping in the mixed layer 
    50    CHARACTER(LEN=200) , PUBLIC :: cn_resto      ! name of netcdf file containing restoration coefficient field 
     44   PUBLIC   tra_dmp        ! called by step.F90 
     45   PUBLIC   tra_dmp_init   ! called by nemogcm.F90 
     46 
     47   !                                           !!* Namelist namtra_dmp : T & S newtonian damping * 
     48   LOGICAL            , PUBLIC ::   ln_tradmp   !: internal damping flag 
     49   INTEGER            , PUBLIC ::   nn_zdmp     !: = 0/1/2 flag for damping in the mixed layer 
     50   CHARACTER(LEN=200) , PUBLIC ::   cn_resto    !: name of netcdf file containing restoration coefficient field 
    5151   ! 
    52  
    53  
    54    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   strdmp   !: damping salinity trend (psu/s) 
    55    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ttrdmp   !: damping temperature trend (Celcius/s) 
    5652   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   resto    !: restoring coeff. on T and S (s-1) 
    5753 
    5854   !! * Substitutions 
    59 #  include "domzgr_substitute.h90" 
    6055#  include "vectopt_loop_substitute.h90" 
    6156   !!---------------------------------------------------------------------- 
    … …  
    7065      !!                ***  FUNCTION tra_dmp_alloc  *** 
    7166      !!---------------------------------------------------------------------- 
    72       ALLOCATE( strdmp(jpi,jpj,jpk) , ttrdmp(jpi,jpj,jpk), resto(jpi,jpj,jpk), STAT= tra_dmp_alloc ) 
     67      ALLOCATE( resto(jpi,jpj,jpk), STAT= tra_dmp_alloc ) 
    7368      ! 
    7469      IF( lk_mpp            )   CALL mpp_sum ( tra_dmp_alloc ) 
    … …  
    9489      !!      below the well mixed layer (nlmdmp=2) 
    9590      !! 
    96       !! ** Action  : - (ta,sa)   tracer trends updated with the damping trend 
    97       !!---------------------------------------------------------------------- 
    98       ! 
     91      !! ** Action  : - tsa: tracer trends updated with the damping trend 
     92      !!---------------------------------------------------------------------- 
    9993      INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
    100       !! 
    101       INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    102       REAL(wp) ::   zta, zsa             ! local scalars 
    103       REAL(wp), POINTER, DIMENSION(:,:,:,:) ::  zts_dta  
    104       !!---------------------------------------------------------------------- 
    105       ! 
    106       IF( nn_timing == 1 )  CALL timing_start( 'tra_dmp') 
    107       ! 
    108       CALL wrk_alloc( jpi, jpj, jpk, jpts,  zts_dta ) 
    109       ! 
    110       !                           !==   input T-S data at kt   ==! 
     94      ! 
     95      INTEGER ::   ji, jj, jk, jn   ! dummy loop indices 
     96      REAL(wp), POINTER, DIMENSION(:,:,:,:) ::  zts_dta, ztrdts 
     97      !!---------------------------------------------------------------------- 
     98      ! 
     99      IF( nn_timing == 1 )   CALL timing_start('tra_dmp') 
     100      ! 
     101      CALL wrk_alloc( jpi,jpj,jpk,jpts,   zts_dta ) 
     102      IF( l_trdtra )   THEN                    !* Save ta and sa trends 
     103         CALL wrk_alloc( jpi,jpj,jpk,jpts,   ztrdts )  
     104         ztrdts(:,:,:,:) = tsa(:,:,:,:)  
     105      ENDIF 
     106      !                           !==  input T-S data at kt  ==! 
    111107      CALL dta_tsd( kt, zts_dta )            ! read and interpolates T-S data at kt 
    112108      ! 
    113       SELECT CASE ( nn_zdmp )     !==    type of damping   ==! 
    114       ! 
    115       CASE( 0 )                   !==  newtonian damping throughout the water column  ==! 
    116          DO jk = 1, jpkm1 
    117             DO jj = 2, jpjm1 
    118                DO ji = fs_2, fs_jpim1   ! vector opt. 
    119                   zta = resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_tem) - tsb(ji,jj,jk,jp_tem) ) 
    120                   zsa = resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_sal) - tsb(ji,jj,jk,jp_sal) ) 
    121                   tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) + zta 
    122                   tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal) + zsa 
    123                   strdmp(ji,jj,jk) = zsa           ! save the trend (used in asmtrj) 
    124                   ttrdmp(ji,jj,jk) = zta       
     109      SELECT CASE ( nn_zdmp )     !==  type of damping  ==! 
     110      ! 
     111      CASE( 0 )                        !*  newtonian damping throughout the water column  *! 
     112         DO jn = 1, jpts 
     113            DO jk = 1, jpkm1 
     114               DO jj = 2, jpjm1 
     115                  DO ji = fs_2, fs_jpim1   ! vector opt. 
     116                     tsa(ji,jj,jk,jn) = tsa(ji,jj,jk,jn) + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jn) - tsb(ji,jj,jk,jn) ) 
     117                  END DO 
    125118               END DO 
    126119            END DO 
    127120         END DO 
    128121         ! 
    129       CASE ( 1 )                  !==  no damping in the turbocline (avt > 5 cm2/s)  ==! 
     122      CASE ( 1 )                       !*  no damping in the turbocline (avt > 5 cm2/s)  *! 
    130123         DO jk = 1, jpkm1 
    131124            DO jj = 2, jpjm1 
    132125               DO ji = fs_2, fs_jpim1   ! vector opt. 
    133126                  IF( avt(ji,jj,jk) <= 5.e-4_wp ) THEN 
    134                      zta = resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_tem) - tsb(ji,jj,jk,jp_tem) ) 
    135                      zsa = resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_sal) - tsb(ji,jj,jk,jp_sal) ) 
    136                   ELSE 
    137                      zta = 0._wp 
    138                      zsa = 0._wp   
     127                     tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem)   & 
     128                        &                 + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_tem) - tsb(ji,jj,jk,jp_tem) ) 
     129                     tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal)   & 
     130                        &                 + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_sal) - tsb(ji,jj,jk,jp_sal) ) 
    139131                  ENDIF 
    140                   tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) + zta 
    141                   tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal) + zsa 
    142                   strdmp(ji,jj,jk) = zsa           ! save the salinity trend (used in asmtrj) 
    143                   ttrdmp(ji,jj,jk) = zta 
    144132               END DO 
    145133            END DO 
    146134         END DO 
    147135         ! 
    148       CASE ( 2 )                  !==  no damping in the mixed layer   ==! 
     136      CASE ( 2 )                       !*  no damping in the mixed layer   *! 
    149137         DO jk = 1, jpkm1 
    150138            DO jj = 2, jpjm1 
    151139               DO ji = fs_2, fs_jpim1   ! vector opt. 
    152                   IF( fsdept(ji,jj,jk) >= hmlp (ji,jj) ) THEN 
    153                      zta = resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_tem) - tsb(ji,jj,jk,jp_tem) ) 
    154                      zsa = resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_sal) - tsb(ji,jj,jk,jp_sal) ) 
    155                   ELSE 
    156                      zta = 0._wp 
    157                      zsa = 0._wp   
     140                  IF( gdept_n(ji,jj,jk) >= hmlp (ji,jj) ) THEN 
     141                     tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem)   & 
     142                        &                 + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_tem) - tsb(ji,jj,jk,jp_tem) ) 
     143                     tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal)   & 
     144                        &                 + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_sal) - tsb(ji,jj,jk,jp_sal) ) 
    158145                  ENDIF 
    159                   tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) + zta 
    160                   tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal) + zsa 
    161                   strdmp(ji,jj,jk) = zsa           ! save the salinity trend (used in asmtrj) 
    162                   ttrdmp(ji,jj,jk) = zta 
    163146               END DO 
    164147            END DO 
    … …  
    168151      ! 
    169152      IF( l_trdtra )   THEN       ! trend diagnostic 
    170          CALL trd_tra( kt, 'TRA', jp_tem, jptra_dmp, ttrdmp ) 
    171          CALL trd_tra( kt, 'TRA', jp_sal, jptra_dmp, strdmp ) 
     153         ztrdts(:,:,:,:) = tsa(:,:,:,:) - ztrdts(:,:,:,:) 
     154         CALL trd_tra( kt, 'TRA', jp_tem, jptra_dmp, ztrdts(:,:,:,jp_tem) ) 
     155         CALL trd_tra( kt, 'TRA', jp_sal, jptra_dmp, ztrdts(:,:,:,jp_sal) ) 
     156         CALL wrk_dealloc( jpi,jpj,jpk,jpts,   ztrdts )  
    172157      ENDIF 
    173158      !                           ! Control print 
    … …  
    175160         &                       tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    176161      ! 
    177       CALL wrk_dealloc( jpi, jpj, jpk, jpts,  zts_dta ) 
    178       ! 
    179       IF( nn_timing == 1 )  CALL timing_stop( 'tra_dmp') 
     162      CALL wrk_dealloc( jpi,jpj,jpk,jpts,   zts_dta ) 
     163      ! 
     164      IF( nn_timing == 1 )   CALL timing_stop('tra_dmp') 
    180165      ! 
    181166   END SUBROUTINE tra_dmp 
    … …  
    190175      !! ** Method  :   read the namtra_dmp namelist and check the parameters 
    191176      !!---------------------------------------------------------------------- 
     177      INTEGER ::   ios, imask   ! local integers  
     178      ! 
    192179      NAMELIST/namtra_dmp/ ln_tradmp, nn_zdmp, cn_resto 
    193       INTEGER ::  ios         ! Local integer for output status of namelist read 
    194       INTEGER :: imask        ! File handle  
    195       !! 
    196180      !!---------------------------------------------------------------------- 
    197181      ! 
    … …  
    204188902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_dmp in configuration namelist', lwp ) 
    205189      IF(lwm) WRITE ( numond, namtra_dmp ) 
    206  
    207       IF(lwp) THEN                 !Namelist print 
     190      ! 
     191      IF(lwp) THEN                  ! Namelist print 
    208192         WRITE(numout,*) 
    209193         WRITE(numout,*) 'tra_dmp_init : T and S newtonian relaxation' 
    210          WRITE(numout,*) '~~~~~~~' 
     194         WRITE(numout,*) '~~~~~~~~~~~' 
    211195         WRITE(numout,*) '   Namelist namtra_dmp : set relaxation parameters' 
    212196         WRITE(numout,*) '      Apply relaxation   or not       ln_tradmp = ', ln_tradmp 
    … …  
    215199         WRITE(numout,*) 
    216200      ENDIF 
    217  
     201      ! 
    218202      IF( ln_tradmp) THEN 
    219          ! 
    220          !Allocate arrays 
     203         !                          ! Allocate arrays 
    221204         IF( tra_dmp_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'tra_dmp_init: unable to allocate arrays' ) 
    222  
    223          !Check values of nn_zdmp 
    224          SELECT CASE (nn_zdmp) 
    225          CASE ( 0 )  ; IF(lwp) WRITE(numout,*) '   tracer damping as specified by mask' 
    226          CASE ( 1 )  ; IF(lwp) WRITE(numout,*) '   no tracer damping in the turbocline' 
    227          CASE ( 2 )  ; IF(lwp) WRITE(numout,*) '   no tracer damping in the mixed layer' 
     205         ! 
     206         SELECT CASE (nn_zdmp)      ! Check values of nn_zdmp 
     207         CASE ( 0 )   ;   IF(lwp) WRITE(numout,*) '   tracer damping as specified by mask' 
     208         CASE ( 1 )   ;   IF(lwp) WRITE(numout,*) '   no tracer damping in the mixing layer (kz > 5 cm2/s)' 
     209         CASE ( 2 )   ;   IF(lwp) WRITE(numout,*) '   no tracer damping in the mixed  layer' 
     210         CASE DEFAULT 
     211            CALL ctl_stop('tra_dmp_init : wrong value of nn_zdmp') 
    228212         END SELECT 
    229  
    230          !TG: Initialisation of dtatsd - Would it be better to have dmpdta routine 
    231          !so can damp to something other than intitial conditions files? 
     213         ! 
     214         !!TG: Initialisation of dtatsd - Would it be better to have dmpdta routine 
     215         !    so can damp to something other than intitial conditions files? 
     216         !!gm: In principle yes. Nevertheless, we can't anticipate demands that have never been formulated. 
    232217         IF( .NOT.ln_tsd_tradmp ) THEN 
    233             CALL ctl_warn( 'tra_dmp_init: read T-S data not initialized, we force ln_tsd_tradmp=T' ) 
     218            IF(lwp) WRITE(numout,*) 
     219            IF(lwp) WRITE(numout, *)  '   read T-S data not initialized, we force ln_tsd_tradmp=T' 
    234220            CALL dta_tsd_init( ld_tradmp=ln_tradmp )        ! forces the initialisation of T-S data 
    235221         ENDIF 
    236  
    237          !initialise arrays - Are these actually used anywhere else? 
    238          strdmp(:,:,:) = 0._wp 
    239          ttrdmp(:,:,:) = 0._wp 
    240  
    241          !Read in mask from file 
     222         !                          ! Read in mask from file 
    242223         CALL iom_open ( cn_resto, imask) 
    243          CALL iom_get  ( imask, jpdom_autoglo, 'resto', resto) 
     224         CALL iom_get  ( imask, jpdom_autoglo, 'resto', resto ) 
    244225         CALL iom_close( imask ) 
    245        ENDIF 
    246  
     226      ENDIF 
     227      ! 
    247228   END SUBROUTINE tra_dmp_init 
    248229 
     230   !!====================================================================== 
    249231END MODULE tradmp 

  • branches/NERC/dev_r5549_BDY_ZEROGRAD/NEMOGCM/NEMO/OPA_SRC/TRA/traldf.F90

    r5120 r6808  
    44   !! Ocean Active tracers : lateral diffusive trends  
    55   !!===================================================================== 
    6    !! History :  9.0  ! 2005-11 (G. Madec)  Original code 
    7    !!       NEMO 3.0  ! 2008-01  (C. Ethe, G. Madec)  merge TRC-TRA  
    8    !!---------------------------------------------------------------------- 
    9  
    10    !!---------------------------------------------------------------------- 
    11    !!   tra_ldf      : update the tracer trend with the lateral diffusion 
    12    !!   tra_ldf_init : initialization, namelist read, and parameters control 
    13    !!       ldf_ano  : compute lateral diffusion for constant T-S profiles 
    14    !!---------------------------------------------------------------------- 
    15    USE oce             ! ocean dynamics and tracers 
    16    USE dom_oce         ! ocean space and time domain 
    17    USE phycst          ! physical constants 
    18    USE ldftra_oce      ! ocean tracer   lateral physics 
    19    USE ldfslp          ! ??? 
    20    USE traldf_bilapg   ! lateral mixing            (tra_ldf_bilapg routine) 
    21    USE traldf_bilap    ! lateral mixing             (tra_ldf_bilap routine) 
    22    USE traldf_iso      ! lateral mixing               (tra_ldf_iso routine) 
    23    USE traldf_iso_grif ! lateral mixing          (tra_ldf_iso_grif routine) 
    24    USE traldf_lap      ! lateral mixing               (tra_ldf_lap routine) 
    25    USE trd_oce         ! trends: ocean variables 
    26    USE trdtra          ! trends manager: tracers  
     6   !! History :  9.0  ! 2005-11  (G. Madec)  Original code 
     7   !!  NEMO      3.0  ! 2008-01  (C. Ethe, G. Madec)  merge TRC-TRA  
     8   !!            3.7  ! 2013-12  (G. Madec) remove the optional computation from T & S anomaly profiles and traldf_bilapg 
     9   !!             -   ! 2013-12  (F. Lemarie, G. Madec)  triad operator (Griffies) + Method of Stabilizing Correction 
     10   !!             -   ! 2014-01  (G. Madec, S. Masson)  restructuration/simplification of lateral diffusive operators 
     11   !!---------------------------------------------------------------------- 
     12 
     13   !!---------------------------------------------------------------------- 
     14   !!   tra_ldf       : update the tracer trend with the lateral diffusion trend 
     15   !!   tra_ldf_init  : initialization, namelist read, and parameters control 
     16   !!---------------------------------------------------------------------- 
     17   USE oce            ! ocean dynamics and tracers 
     18   USE dom_oce        ! ocean space and time domain 
     19   USE phycst         ! physical constants 
     20   USE ldftra         ! lateral diffusion: eddy diffusivity & EIV coeff. 
     21   USE ldfslp         ! lateral diffusion: iso-neutral slope 
     22   USE traldf_lap_blp ! lateral diffusion: laplacian iso-level            operator  (tra_ldf_lap/_blp   routines) 
     23   USE traldf_iso     ! lateral diffusion: laplacian iso-neutral standard operator  (tra_ldf_iso        routine ) 
     24   USE traldf_triad   ! lateral diffusion: laplacian iso-neutral triad    operator  (tra_ldf_triad      routine ) 
     25   USE trd_oce        ! trends: ocean variables 
     26   USE trdtra         ! ocean active tracers trends 
    2727   ! 
    28    USE prtctl          ! Print control 
    29    USE in_out_manager  ! I/O manager 
    30    USE lib_mpp         ! distribued memory computing library 
    31    USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    32    USE wrk_nemo        ! Memory allocation 
    33    USE timing          ! Timing 
     28   USE prtctl         ! Print control 
     29   USE in_out_manager ! I/O manager 
     30   USE lib_mpp        ! distribued memory computing library 
     31   USE lbclnk         ! ocean lateral boundary conditions (or mpp link) 
     32   USE wrk_nemo       ! Memory allocation 
     33   USE timing         ! Timing 
    3434 
    3535   IMPLICIT NONE 
    … …  
    3737 
    3838   PUBLIC   tra_ldf        ! called by step.F90  
    39    PUBLIC   tra_ldf_init   ! called by opa.F90  
     39   PUBLIC   tra_ldf_init   ! called by nemogcm.F90  
    4040   ! 
    41    INTEGER ::   nldf = 0   ! type of lateral diffusion used defined from ln_traldf_... namlist logicals) 
    42  
    43    REAL, SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::   t0_ldf, s0_ldf   !: lateral diffusion trends of T & S for a cst profile 
    44    !                                                               !  (key_traldf_ano only) 
    45  
     41   INTEGER ::   nldf = 0   ! type of lateral diffusion used defined from ln_traldf_... (namlist logicals) 
     42    
    4643   !! * Substitutions 
    47 #  include "domzgr_substitute.h90" 
    4844#  include "vectopt_loop_substitute.h90" 
    4945   !!---------------------------------------------------------------------- 
    50    !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
     46   !! NEMO/OPA 3.7 , NEMO Consortium (2015) 
    5147   !! $Id$  
    5248   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    … …  
    6561      !!---------------------------------------------------------------------- 
    6662      ! 
    67       IF( nn_timing == 1 )  CALL timing_start('tra_ldf') 
    68       ! 
    69       rldf = 1     ! For active tracers the  
    70  
     63      IF( nn_timing == 1 )   CALL timing_start('tra_ldf') 
     64      ! 
    7165      IF( l_trdtra )   THEN                    !* Save ta and sa trends 
    72          CALL wrk_alloc( jpi, jpj, jpk, ztrdt, ztrds )  
     66         CALL wrk_alloc( jpi,jpj,jpk,  ztrdt, ztrds )  
    7367         ztrdt(:,:,:) = tsa(:,:,:,jp_tem)  
    7468         ztrds(:,:,:) = tsa(:,:,:,jp_sal) 
    7569      ENDIF 
    76  
    77       SELECT CASE ( nldf )                       ! compute lateral mixing trend and add it to the general trend 
    78       CASE ( 0 )   ;   CALL tra_ldf_lap     ( kt, nit000, 'TRA', gtsu, gtsv, gtui, gtvi,        & 
    79                                &                                   tsb, tsa, jpts        )  ! iso-level laplacian 
    80       CASE ( 1 )                                                                              ! rotated laplacian 
    81          IF( ln_traldf_grif ) THEN                                                           
    82                        CALL tra_ldf_iso_grif( kt, nit000,'TRA', gtsu, gtsv, tsb, tsa, jpts, ahtb0 )      ! Griffies operator 
    83          ELSE                                                                                 
    84                        CALL tra_ldf_iso     ( kt, nit000, 'TRA', gtsu, gtsv, gtui, gtvi,        & 
    85                                &                                  tsb, tsa, jpts, ahtb0 )      ! Madec operator 
    86          ENDIF 
    87       CASE ( 2 )   ;   CALL tra_ldf_bilap   ( kt, nit000, 'TRA', gtsu, gtsv, gtui, gtvi,        & 
    88                                &                                   tsb, tsa, jpts        )  ! iso-level bilaplacian 
    89       CASE ( 3 )   ;   CALL tra_ldf_bilapg  ( kt, nit000, 'TRA',             tsb, tsa, jpts        )  ! s-coord. geopot. bilap. 
    90          ! 
    91       CASE ( -1 )                                ! esopa: test all possibility with control print 
    92          CALL tra_ldf_lap   ( kt, nit000, 'TRA', gtsu, gtsv, gtui, gtvi,        & 
    93          &                                       tsb, tsa, jpts        )  
    94          CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' ldf0 - Ta: ', mask1=tmask,               & 
    95          &             tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    96          IF( ln_traldf_grif ) THEN 
    97             CALL tra_ldf_iso_grif( kt, nit000, 'TRA', gtsu, gtsv, tsb, tsa, jpts, ahtb0 ) 
    98          ELSE 
    99             CALL tra_ldf_iso     ( kt, nit000, 'TRA', gtsu, gtsv, gtui, gtvi,        & 
    100             &                                               tsb, tsa, jpts, ahtb0 )   
    101          ENDIF 
    102          CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' ldf1 - Ta: ', mask1=tmask,               & 
    103          &             tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    104          CALL tra_ldf_bilap ( kt, nit000, 'TRA', gtsu, gtsv, gtui, gtvi,        & 
    105          &                                       tsb, tsa, jpts        )  
    106          CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' ldf2 - Ta: ', mask1=tmask,               & 
    107          &             tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    108          CALL tra_ldf_bilapg( kt, nit000, 'TRA',             tsb, tsa, jpts        )  
    109          CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' ldf3 - Ta: ', mask1=tmask,               & 
    110          &             tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
     70      ! 
     71      SELECT CASE ( nldf )                     !* compute lateral mixing trend and add it to the general trend 
     72      CASE ( np_lap   )                                  ! laplacian: iso-level operator 
     73         CALL tra_ldf_lap  ( kt, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, tsb,      tsa, jpts,  1   ) 
     74      CASE ( np_lap_i )                                  ! laplacian: standard iso-neutral operator (Madec) 
     75         CALL tra_ldf_iso  ( kt, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, tsb, tsb, tsa, jpts,  1   ) 
     76      CASE ( np_lap_it )                                 ! laplacian: triad iso-neutral operator (griffies) 
     77         CALL tra_ldf_triad( kt, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, tsb, tsb, tsa, jpts,  1   ) 
     78      CASE ( np_blp , np_blp_i , np_blp_it )             ! bilaplacian: iso-level & iso-neutral operators 
     79         CALL tra_ldf_blp  ( kt, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, tsb      , tsa, jpts, nldf ) 
    11180      END SELECT 
    112  
    113 #if defined key_traldf_ano 
    114       tsa(:,:,:,jp_tem) = tsa(:,:,:,jp_tem) - t0_ldf(:,:,:)      ! anomaly: substract the reference diffusivity 
    115       tsa(:,:,:,jp_sal) = tsa(:,:,:,jp_sal) - s0_ldf(:,:,:) 
    116 #endif 
    117  
    118       IF( l_trdtra )   THEN                      ! save the horizontal diffusive trends for further diagnostics 
     81      ! 
     82      IF( l_trdtra )   THEN                    !* save the horizontal diffusive trends for further diagnostics 
    11983         ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 
    12084         ztrds(:,:,:) = tsa(:,:,:,jp_sal) - ztrds(:,:,:) 
    12185         CALL trd_tra( kt, 'TRA', jp_tem, jptra_ldf, ztrdt ) 
    12286         CALL trd_tra( kt, 'TRA', jp_sal, jptra_ldf, ztrds ) 
    123          CALL wrk_dealloc( jpi, jpj, jpk, ztrdt, ztrds )  
    124       ENDIF 
    125       !                                          ! print mean trends (used for debugging) 
     87         CALL wrk_dealloc( jpi,jpj,jpk,  ztrdt, ztrds )  
     88      ENDIF 
     89      !                                        !* print mean trends (used for debugging) 
    12690      IF(ln_ctl)   CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' ldf  - Ta: ', mask1=tmask,               & 
    12791         &                       tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    12892      ! 
    129       IF( nn_timing == 1 )  CALL timing_stop('tra_ldf') 
     93      IF( nn_timing == 1 )   CALL timing_stop('tra_ldf') 
    13094      ! 
    13195   END SUBROUTINE tra_ldf 
    … …  
    139103      !! 
    140104      !! ** Method  :   set nldf from the namtra_ldf logicals 
    141       !!      nldf == -1   ESOPA test: ALL operators are used 
    142       !!      nldf ==  0   laplacian operator 
    143       !!      nldf ==  1   Rotated laplacian operator 
    144       !!      nldf ==  2   bilaplacian operator 
    145       !!      nldf ==  3   Rotated bilaplacian 
    146       !!---------------------------------------------------------------------- 
    147       INTEGER ::   ioptio, ierr         ! temporary integers  
    148       !!---------------------------------------------------------------------- 
    149  
    150       !  Define the lateral mixing oparator for tracers 
    151       ! =============================================== 
    152      
    153       IF(lwp) THEN                    ! Namelist print 
     105      !!---------------------------------------------------------------------- 
     106      INTEGER ::   ioptio, ierr   ! temporary integers  
     107      !!---------------------------------------------------------------------- 
     108      ! 
     109      IF(lwp) THEN                     ! Namelist print 
    154110         WRITE(numout,*) 
    155111         WRITE(numout,*) 'tra_ldf_init : lateral tracer diffusive operator' 
    156112         WRITE(numout,*) '~~~~~~~~~~~' 
    157          WRITE(numout,*) '   Namelist namtra_ldf already read in ldftra module' 
    158          WRITE(numout,*) '   see ldf_tra_init report for lateral mixing parameters' 
     113         WRITE(numout,*) '   Namelist namtra_ldf: already read in ldftra module' 
     114         WRITE(numout,*) '      see ldf_tra_init report for lateral mixing parameters' 
    159115         WRITE(numout,*) 
    160116      ENDIF 
    161  
    162       !                               ! control the input 
     117      !                                   ! use of lateral operator or not 
     118      nldf   = np_ERROR 
    163119      ioptio = 0 
    164       IF( ln_traldf_lap   )   ioptio = ioptio + 1 
    165       IF( ln_traldf_bilap )   ioptio = ioptio + 1 
    166       IF( ioptio >  1 )   CALL ctl_stop( '          use ONE or NONE of the 2 lap/bilap operator type on tracer' ) 
    167       IF( ioptio == 0 )   nldf = -2   ! No lateral diffusion 
    168       ioptio = 0 
    169       IF( ln_traldf_level )   ioptio = ioptio + 1 
    170       IF( ln_traldf_hor   )   ioptio = ioptio + 1 
    171       IF( ln_traldf_iso   )   ioptio = ioptio + 1 
    172       IF( ioptio >  1 )   CALL ctl_stop( '          use only ONE direction (level/hor/iso)' ) 
    173  
    174       ! defined the type of lateral diffusion from ln_traldf_... logicals 
    175       ! CAUTION : nldf = 1 is used in trazdf_imp, change it carefully 
    176       ierr = 0 
    177       IF( ln_traldf_lap ) THEN       ! laplacian operator 
    178          IF ( ln_zco ) THEN                ! z-coordinate 
    179             IF ( ln_traldf_level )   nldf = 0      ! iso-level  (no rotation) 
    180             IF ( ln_traldf_hor   )   nldf = 0      ! horizontal (no rotation) 
    181             IF ( ln_traldf_iso   )   nldf = 1      ! isoneutral (   rotation) 
     120      IF( ln_traldf_lap )   ioptio = ioptio + 1 
     121      IF( ln_traldf_blp )   ioptio = ioptio + 1 
     122      IF( ioptio >  1   )   CALL ctl_stop( 'tra_ldf_init: use ONE or NONE of the 2 lap/bilap operator type on tracer' ) 
     123      IF( ioptio == 0   )   nldf = np_no_ldf     ! No lateral diffusion 
     124      ! 
     125      IF( nldf /= np_no_ldf ) THEN        ! direction ==>> type of operator   
     126         ioptio = 0 
     127         IF( ln_traldf_lev )   ioptio = ioptio + 1 
     128         IF( ln_traldf_hor )   ioptio = ioptio + 1 
     129         IF( ln_traldf_iso )   ioptio = ioptio + 1 
     130         IF( ioptio >  1 )   CALL ctl_stop( 'tra_ldf_init: use only ONE direction (level/hor/iso)' ) 
     131         ! 
     132         !                                ! defined the type of lateral diffusion from ln_traldf_... logicals 
     133         ierr = 0 
     134         IF( ln_traldf_lap ) THEN         ! laplacian operator 
     135            IF ( ln_zco ) THEN               ! z-coordinate 
     136               IF ( ln_traldf_lev   )   nldf = np_lap     ! iso-level = horizontal (no rotation) 
     137               IF ( ln_traldf_hor   )   nldf = np_lap     ! iso-level = horizontal (no rotation) 
     138               IF ( ln_traldf_iso   )   nldf = np_lap_i   ! iso-neutral: standard  (   rotation) 
     139               IF ( ln_traldf_triad )   nldf = np_lap_it  ! iso-neutral: triad     (   rotation) 
     140            ENDIF 
     141            IF ( ln_zps ) THEN               ! z-coordinate with partial step 
     142               IF ( ln_traldf_lev   )   ierr = 1          ! iso-level not allowed  
     143               IF ( ln_traldf_hor   )   nldf = np_lap     ! horizontal             (no rotation) 
     144               IF ( ln_traldf_iso   )   nldf = np_lap_i   ! iso-neutral: standard     (rotation) 
     145               IF ( ln_traldf_triad )   nldf = np_lap_it  ! iso-neutral: triad        (rotation) 
     146            ENDIF 
     147            IF ( ln_sco ) THEN               ! s-coordinate 
     148               IF ( ln_traldf_lev   )   nldf = np_lap     ! iso-level              (no rotation) 
     149               IF ( ln_traldf_hor   )   nldf = np_lap_i   ! horizontal             (   rotation) 
     150               IF ( ln_traldf_iso   )   nldf = np_lap_i   ! iso-neutral: standard  (   rotation) 
     151               IF ( ln_traldf_triad )   nldf = np_lap_it  ! iso-neutral: triad     (   rotation) 
     152            ENDIF 
    182153         ENDIF 
    183          IF ( ln_zps ) THEN             ! zps-coordinate 
    184             IF ( ln_traldf_level )   ierr = 1      ! iso-level not allowed 
    185             IF ( ln_traldf_hor   )   nldf = 0      ! horizontal (no rotation) 
    186             IF ( ln_traldf_iso   )   nldf = 1      ! isoneutral (   rotation) 
     154         ! 
     155         IF( ln_traldf_blp ) THEN         ! bilaplacian operator 
     156            IF ( ln_zco ) THEN               ! z-coordinate 
     157               IF ( ln_traldf_lev   )   nldf = np_blp     ! iso-level = horizontal (no rotation) 
     158               IF ( ln_traldf_hor   )   nldf = np_blp     ! iso-level = horizontal (no rotation) 
     159               IF ( ln_traldf_iso   )   nldf = np_blp_i   ! iso-neutral: standard  (   rotation) 
     160               IF ( ln_traldf_triad )   nldf = np_blp_it  ! iso-neutral: triad     (   rotation) 
     161            ENDIF 
     162            IF ( ln_zps ) THEN               ! z-coordinate with partial step 
     163               IF ( ln_traldf_lev   )   ierr = 1          ! iso-level not allowed  
     164               IF ( ln_traldf_hor   )   nldf = np_blp     ! horizontal             (no rotation) 
     165               IF ( ln_traldf_iso   )   nldf = np_blp_i   ! iso-neutral: standard  (   rotation) 
     166               IF ( ln_traldf_triad )   nldf = np_blp_it  ! iso-neutral: triad     (   rotation) 
     167            ENDIF 
     168            IF ( ln_sco ) THEN               ! s-coordinate 
     169               IF ( ln_traldf_lev   )   nldf = np_blp     ! iso-level              (no rotation) 
     170               IF ( ln_traldf_hor   )   nldf = np_blp_it  ! horizontal             (   rotation) 
     171               IF ( ln_traldf_iso   )   nldf = np_blp_i   ! iso-neutral: standard  (   rotation) 
     172               IF ( ln_traldf_triad )   nldf = np_blp_it  ! iso-neutral: triad     (   rotation) 
     173            ENDIF 
    187174         ENDIF 
    188          IF ( ln_sco ) THEN             ! s-coordinate 
    189             IF ( ln_traldf_level )   nldf = 0      ! iso-level  (no rotation) 
    190             IF ( ln_traldf_hor   )   nldf = 1      ! horizontal (   rotation) 
    191             IF ( ln_traldf_iso   )   nldf = 1      ! isoneutral (   rotation) 
    192          ENDIF 
    193       ENDIF 
    194  
    195       IF( ln_traldf_bilap ) THEN      ! bilaplacian operator 
    196          IF ( ln_zco ) THEN                ! z-coordinate 
    197             IF ( ln_traldf_level )   nldf = 2      ! iso-level  (no rotation) 
    198             IF ( ln_traldf_hor   )   nldf = 2      ! horizontal (no rotation) 
    199             IF ( ln_traldf_iso   )   ierr = 2      ! isoneutral (   rotation) 
    200          ENDIF 
    201          IF ( ln_zps ) THEN             ! zps-coordinate 
    202             IF ( ln_traldf_level )   ierr = 1      ! iso-level not allowed  
    203             IF ( ln_traldf_hor   )   nldf = 2      ! horizontal (no rotation) 
    204             IF ( ln_traldf_iso   )   ierr = 2      ! isoneutral (   rotation) 
    205          ENDIF 
    206          IF ( ln_sco ) THEN             ! s-coordinate 
    207             IF ( ln_traldf_level )   nldf = 2      ! iso-level  (no rotation) 
    208             IF ( ln_traldf_hor   )   nldf = 3      ! horizontal (   rotation) 
    209             IF ( ln_traldf_iso   )   ierr = 2      ! isoneutral (   rotation) 
    210          ENDIF 
    211       ENDIF 
    212  
    213       IF( nldf == 3 )   CALL ctl_warn( 'geopotential bilaplacian tracer diffusion in s-coords not thoroughly tested' ) 
    214       IF( ierr == 1 )   CALL ctl_stop( ' iso-level in z-coordinate - partial step, not allowed' ) 
    215       IF( ierr == 2 )   CALL ctl_stop( ' isoneutral bilaplacian operator does not exist' ) 
    216       IF( lk_traldf_eiv .AND. .NOT.ln_traldf_iso )   & 
    217            CALL ctl_stop( '          eddy induced velocity on tracers',   & 
    218            &              ' the eddy induced velocity on tracers requires isopycnal laplacian diffusion' ) 
    219       IF( nldf == 1 .OR. nldf == 3 ) THEN      ! rotation 
    220          IF( .NOT.lk_ldfslp )   CALL ctl_stop( '          the rotation of the diffusive tensor require key_ldfslp' ) 
    221          l_traldf_rot = .TRUE.                 ! needed for trazdf_imp 
    222       ENDIF 
    223  
    224       IF( lk_esopa ) THEN 
    225          IF(lwp) WRITE(numout,*) '          esopa control: use all lateral physics options' 
    226          nldf = -1 
    227       ENDIF 
    228  
     175      ENDIF 
     176      ! 
     177      IF( ierr == 1 )   CALL ctl_stop( 'iso-level in z-partial step, not allowed' ) 
     178      IF( ln_ldfeiv .AND. .NOT.( ln_traldf_iso .OR. ln_traldf_triad ) )                                    & 
     179           &            CALL ctl_stop( 'eddy induced velocity on tracers requires iso-neutral laplacian diffusion' ) 
     180           ! 
     181      IF(  nldf == np_lap_i .OR. nldf == np_lap_it .OR. & 
     182         & nldf == np_blp_i .OR. nldf == np_blp_it  )   l_ldfslp = .TRUE.    ! slope of neutral surfaces required  
     183      ! 
    229184      IF(lwp) THEN 
    230185         WRITE(numout,*) 
    231          IF( nldf == -2 )   WRITE(numout,*) '          NO lateral diffusion' 
    232          IF( nldf == -1 )   WRITE(numout,*) '          ESOPA test All scheme used' 
    233          IF( nldf ==  0 )   WRITE(numout,*) '          laplacian operator' 
    234          IF( nldf ==  1 )   WRITE(numout,*) '          Rotated laplacian operator' 
    235          IF( nldf ==  2 )   WRITE(numout,*) '          bilaplacian operator' 
    236          IF( nldf ==  3 )   WRITE(numout,*) '          Rotated bilaplacian' 
    237       ENDIF 
    238  
    239       ! Reference T & S diffusivity (if necessary) 
    240       ! =========================== 
    241       CALL ldf_ano 
     186         SELECT CASE( nldf ) 
     187         CASE( np_no_ldf )   ;   WRITE(numout,*) '   NO lateral diffusion' 
     188         CASE( np_lap    )   ;   WRITE(numout,*) '   laplacian iso-level operator' 
     189         CASE( np_lap_i  )   ;   WRITE(numout,*) '   Rotated laplacian operator (standard)' 
     190         CASE( np_lap_it )   ;   WRITE(numout,*) '   Rotated laplacian operator (triad)' 
     191         CASE( np_blp    )   ;   WRITE(numout,*) '   bilaplacian iso-level operator' 
     192         CASE( np_blp_i  )   ;   WRITE(numout,*) '   Rotated bilaplacian operator (standard)' 
     193         CASE( np_blp_it )   ;   WRITE(numout,*) '   Rotated bilaplacian operator (triad)' 
     194         END SELECT 
     195      ENDIF 
    242196      ! 
    243197   END SUBROUTINE tra_ldf_init 
    244  
    245 #if defined key_traldf_ano 
    246    !!---------------------------------------------------------------------- 
    247    !!   'key_traldf_ano'               T & S lateral diffusion on anomalies 
    248    !!---------------------------------------------------------------------- 
    249  
    250    SUBROUTINE ldf_ano 
    251       !!---------------------------------------------------------------------- 
    252       !!                  ***  ROUTINE ldf_ano  *** 
    253       !! 
    254       !! ** Purpose :   initializations of  
    255       !!---------------------------------------------------------------------- 
    256       ! 
    257       USE zdf_oce         ! vertical mixing 
    258       USE trazdf          ! vertical mixing: double diffusion 
    259       USE zdfddm          ! vertical mixing: double diffusion 
    260       ! 
    261       INTEGER  ::   jk              ! Dummy loop indice 
    262       INTEGER  ::   ierr            ! local integer 
    263       LOGICAL  ::   llsave          ! local logical 
    264       REAL(wp) ::   zt0, zs0, z12   ! local scalar 
    265       REAL(wp), POINTER, DIMENSION(:,:,:) :: zt_ref, zs_ref, ztb, zsb, zavt      
    266       !!---------------------------------------------------------------------- 
    267       ! 
    268       IF( nn_timing == 1 )  CALL timing_start('ldf_ano') 
    269       ! 
    270       CALL wrk_alloc( jpi, jpj, jpk, zt_ref, zs_ref, ztb, zsb, zavt )  
    271       ! 
    272  
    273       IF(lwp) THEN 
    274          WRITE(numout,*) 
    275          WRITE(numout,*) 'tra:ldf_ano : lateral diffusion acting on anomalies' 
    276          WRITE(numout,*) '~~~~~~~~~~~' 
    277       ENDIF 
    278  
    279       !                              ! allocate trabbl arrays 
    280       ALLOCATE( t0_ldf(jpi,jpj,jpk) , s0_ldf(jpi,jpj,jpk) , STAT=ierr ) 
    281       IF( lk_mpp    )   CALL mpp_sum( ierr ) 
    282       IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'ldf_ano: unable to allocate arrays' ) 
    283  
    284       ! defined the T & S reference profiles 
    285       ! ------------------------------------ 
    286       zt0 =10.e0                               ! homogeneous ocean 
    287       zs0 =35.e0 
    288       zt_ref(:,:,:) = 10.0 * tmask(:,:,:) 
    289       zs_ref(:,:,:) = 35.0 * tmask(:,:,:) 
    290       IF(lwp) WRITE(numout,*) '              homogeneous ocean T = ', zt0, ' S = ',zs0 
    291  
    292       ! Initialisation of gtui/gtvi in case of no cavity 
    293       IF ( .NOT. ln_isfcav ) THEN 
    294          gtui(:,:,:) = 0.0_wp 
    295          gtvi(:,:,:) = 0.0_wp 
    296       END IF 
    297       !                                        ! T & S profile (to be coded +namelist parameter 
    298  
    299       ! prepare the ldf computation 
    300       ! --------------------------- 
    301       llsave = l_trdtra 
    302       l_trdtra = .false.      ! desactivate trend computation 
    303       t0_ldf(:,:,:) = 0.e0 
    304       s0_ldf(:,:,:) = 0.e0 
    305       ztb   (:,:,:) = tsb (:,:,:,jp_tem) 
    306       zsb   (:,:,:) = tsb (:,:,:,jp_sal) 
    307       ua    (:,:,:) = tsa (:,:,:,jp_tem) 
    308       va    (:,:,:) = tsa (:,:,:,jp_sal) 
    309       zavt  (:,:,:) = avt(:,:,:) 
    310       IF( lk_zdfddm ) THEN CALL ctl_stop( ' key_traldf_ano with key_zdfddm not implemented' ) 
    311       ! set tb, sb to reference values and avr to zero 
    312       tsb (:,:,:,jp_tem) = zt_ref(:,:,:) 
    313       tsb (:,:,:,jp_sal) = zs_ref(:,:,:) 
    314       tsa (:,:,:,jp_tem) = 0.e0 
    315       tsa (:,:,:,jp_sal) = 0.e0 
    316       avt(:,:,:)         = 0.e0 
    317  
    318       ! Compute the ldf trends 
    319       ! ---------------------- 
    320       CALL tra_ldf( nit000 + 1 )      ! horizontal components (+1: no more init) 
    321       CALL tra_zdf( nit000     )      ! vertical component (if necessary nit000 to performed the init) 
    322  
    323       ! finalise the computation and recover all arrays 
    324       ! ----------------------------------------------- 
    325       l_trdtra = llsave 
    326       z12 = 2.e0 
    327       IF( neuler == 1)   z12 = 1.e0 
    328       IF( ln_zdfexp ) THEN      ! ta,sa are the trends 
    329          t0_ldf(:,:,:) = tsa(:,:,:,jp_tem) 
    330          s0_ldf(:,:,:) = tsa(:,:,:,jp_sal) 
    331       ELSE 
    332          DO jk = 1, jpkm1 
    333             t0_ldf(:,:,jk) = ( tsa(:,:,jk,jp_tem) - tsb(:,:,jk,jp_tem) ) / ( z12 *rdttra(jk) ) 
    334             s0_ldf(:,:,jk) = ( tsa(:,:,jk,jp_sal) - tsb(:,:,jk,jp_sal) ) / ( z12 *rdttra(jk) ) 
    335          END DO 
    336       ENDIF 
    337       tsb(:,:,:,jp_tem) = ztb (:,:,:) 
    338       tsb(:,:,:,jp_sal) = zsb (:,:,:) 
    339       tsa(:,:,:,jp_tem) = ua  (:,:,:) 
    340       tsa(:,:,:,jp_sal) = va  (:,:,:) 
    341       avt(:,:,:)        = zavt(:,:,:) 
    342       ! 
    343       CALL wrk_dealloc( jpi, jpj, jpk, zt_ref, zs_ref, ztb, zsb, zavt )  
    344       ! 
    345       IF( nn_timing == 1 )  CALL timing_stop('ldf_ano') 
    346       ! 
    347    END SUBROUTINE ldf_ano 
    348  
    349 #else 
    350    !!---------------------------------------------------------------------- 
    351    !!   default option :   Dummy code   NO T & S background profiles 
    352    !!---------------------------------------------------------------------- 
    353    SUBROUTINE ldf_ano 
    354       IF(lwp) THEN 
    355          WRITE(numout,*) 
    356          WRITE(numout,*) 'tra:ldf_ano : lateral diffusion acting on the full fields' 
    357          WRITE(numout,*) '~~~~~~~~~~~' 
    358       ENDIF 
    359    END SUBROUTINE ldf_ano 
    360 #endif 
    361198 
    362199   !!====================================================================== 

  • branches/NERC/dev_r5549_BDY_ZEROGRAD/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_iso.F90

    r5149 r6808  
    44   !! Ocean  tracers:  horizontal component of the lateral tracer mixing trend 
    55   !!====================================================================== 
    6    !! History :  OPA  !  1994-08  (G. Madec, M. Imbard) 
    7    !!            8.0  !  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.3  !  2010-09  (C. Ethe, G. Madec) Merge TRA-TRC 
     6   !! History :  OPA  ! 1994-08  (G. Madec, M. Imbard) 
     7   !!            8.0  ! 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.3  ! 2010-09  (C. Ethe, G. Madec) Merge TRA-TRC 
     11   !!            3.7  ! 2014-01  (G. Madec, S. Masson)  restructuration/simplification of aht/aeiv specification 
     12   !!             -   ! 2014-02  (F. Lemarie, G. Madec)  triad operator (Griffies) + Method of Stabilizing Correction 
    1113   !!---------------------------------------------------------------------- 
    12 #if   defined key_ldfslp   ||   defined key_esopa 
     14 
    1315   !!---------------------------------------------------------------------- 
    14    !!   'key_ldfslp'               slope of the lateral diffusive direction 
     16   !!   tra_ldf_iso   : update the tracer trend with the horizontal component of a iso-neutral laplacian operator 
     17   !!                   and with the vertical part of the isopycnal or geopotential s-coord. operator  
    1518   !!---------------------------------------------------------------------- 
    16    !!   tra_ldf_iso  : update the tracer trend with the horizontal  
    17    !!                  component of a iso-neutral laplacian operator 
    18    !!                  and with the vertical part of 
    19    !!                  the isopycnal or geopotential s-coord. operator  
    20    !!---------------------------------------------------------------------- 
    21    USE oce             ! ocean dynamics and active tracers 
    22    USE dom_oce         ! ocean space and time domain 
    23    USE trc_oce         ! share passive tracers/Ocean variables 
    24    USE zdf_oce         ! ocean vertical physics 
    25    USE ldftra_oce      ! ocean active tracers: lateral physics 
    26    USE ldfslp          ! iso-neutral slopes 
    27    USE diaptr          ! poleward transport diagnostics 
    28    USE in_out_manager  ! I/O manager 
    29    USE iom             ! I/O library 
    30    USE phycst          ! physical constants 
    31    USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    32    USE wrk_nemo        ! Memory Allocation 
    33    USE timing          ! Timing 
     19   USE oce            ! ocean dynamics and active tracers 
     20   USE dom_oce        ! ocean space and time domain 
     21   USE trc_oce        ! share passive tracers/Ocean variables 
     22   USE zdf_oce        ! ocean vertical physics 
     23   USE ldftra         ! lateral diffusion: tracer eddy coefficients 
     24   USE ldfslp         ! iso-neutral slopes 
     25   USE diaptr         ! poleward transport diagnostics 
     26   ! 
     27   USE in_out_manager ! I/O manager 
     28   USE iom            ! I/O library 
     29   USE phycst         ! physical constants 
     30   USE lbclnk         ! ocean lateral boundary conditions (or mpp link) 
     31   USE wrk_nemo       ! Memory Allocation 
     32   USE timing         ! Timing 
    3433 
    3534   IMPLICIT NONE 
    … …  
    3938 
    4039   !! * Substitutions 
    41 #  include "domzgr_substitute.h90" 
    42 #  include "ldftra_substitute.h90" 
    4340#  include "vectopt_loop_substitute.h90" 
    4441   !!---------------------------------------------------------------------- 
    45    !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
     42   !! NEMO/OPA 3.7 , NEMO Consortium (2015) 
    4643   !! $Id$ 
    4744   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    … …  
    4946CONTAINS 
    5047 
    51    SUBROUTINE tra_ldf_iso( kt, kit000, cdtype, pgu, pgv,              & 
    52       &                                pgui, pgvi,                    & 
    53       &                                ptb, pta, kjpt, pahtb0 ) 
     48  SUBROUTINE tra_ldf_iso( kt, kit000, cdtype, pahu, pahv, pgu , pgv ,   & 
     49      &                                                   pgui, pgvi,   & 
     50      &                                       ptb , ptbb, pta , kjpt, kpass ) 
    5451      !!---------------------------------------------------------------------- 
    5552      !!                  ***  ROUTINE tra_ldf_iso  *** 
    … …  
    6663      !! 
    6764      !!      1st part :  masked horizontal derivative of T  ( di[ t ] ) 
    68       !!      ========    with partial cell update if ln_zps=T. 
     65      !!      ========    with partial cell update if ln_zps=T 
     66      !!                  with top     cell update if ln_isfcav 
    6967      !! 
    7068      !!      2nd part :  horizontal fluxes of the lateral mixing operator 
    7169      !!      ========     
    72       !!         zftu = (aht+ahtb0) e2u*e3u/e1u di[ tb ] 
    73       !!               - aht      e2u*uslp    dk[ mi(mk(tb)) ] 
    74       !!         zftv = (aht+ahtb0) e1v*e3v/e2v dj[ tb ] 
    75       !!               - aht      e2u*vslp    dk[ mj(mk(tb)) ] 
     70      !!         zftu =  pahu e2u*e3u/e1u di[ tb ] 
     71      !!               - pahu e2u*uslp    dk[ mi(mk(tb)) ] 
     72      !!         zftv =  pahv e1v*e3v/e2v dj[ tb ] 
     73      !!               - pahv e2u*vslp    dk[ mj(mk(tb)) ] 
    7674      !!      take the horizontal divergence of the fluxes: 
    77       !!         difft = 1/(e1t*e2t*e3t) {  di-1[ zftu ] +  dj-1[ zftv ]  } 
     75      !!         difft = 1/(e1e2t*e3t) {  di-1[ zftu ] +  dj-1[ zftv ]  } 
    7876      !!      Add this trend to the general trend (ta,sa): 
    7977      !!         ta = ta + difft 
    … …  
    8280      !!      ========  (excluding the vertical flux proportional to dk[t] ) 
    8381      !!      vertical fluxes associated with the rotated lateral mixing: 
    84       !!         zftw =-aht { e2t*wslpi di[ mi(mk(tb)) ] 
    85       !!                     + e1t*wslpj dj[ mj(mk(tb)) ]  } 
     82      !!         zftw = - {  mi(mk(pahu)) * e2t*wslpi di[ mi(mk(tb)) ] 
     83      !!                   + mj(mk(pahv)) * e1t*wslpj dj[ mj(mk(tb)) ]  } 
    8684      !!      take the horizontal divergence of the fluxes: 
    87       !!         difft = 1/(e1t*e2t*e3t) dk[ zftw ] 
     85      !!         difft = 1/(e1e2t*e3t) dk[ zftw ] 
    8886      !!      Add this trend to the general trend (ta,sa): 
    8987      !!         pta = pta + difft 
    … …  
    9189      !! ** Action :   Update pta arrays with the before rotated diffusion 
    9290      !!---------------------------------------------------------------------- 
    93       USE oce     , ONLY:   zftu => ua       , zftv  => va         ! (ua,va) used as workspace 
    94       ! 
    9591      INTEGER                              , INTENT(in   ) ::   kt         ! ocean time-step index 
    96       INTEGER                              , INTENT(in   ) ::   kit000          ! first time step index 
     92      INTEGER                              , INTENT(in   ) ::   kit000     ! first time step index 
    9793      CHARACTER(len=3)                     , INTENT(in   ) ::   cdtype     ! =TRA or TRC (tracer indicator) 
    9894      INTEGER                              , INTENT(in   ) ::   kjpt       ! number of tracers 
    99       REAL(wp), DIMENSION(jpi,jpj    ,kjpt), INTENT(in   ) ::   pgu , pgv    ! tracer gradient at pstep levels 
    100       REAL(wp), DIMENSION(jpi,jpj    ,kjpt), INTENT(in   ) ::   pgui, pgvi   ! tracer gradient at pstep levels 
    101       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb        ! before and now tracer fields 
    102       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta        ! tracer trend  
    103       REAL(wp)                             , INTENT(in   ) ::   pahtb0     ! background diffusion coef 
     95      INTEGER                              , INTENT(in   ) ::   kpass      ! =1/2 first or second passage 
     96      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(in   ) ::   pahu, pahv ! eddy diffusivity at u- and v-points  [m2/s] 
     97      REAL(wp), DIMENSION(jpi,jpj    ,kjpt), INTENT(in   ) ::   pgu, pgv   ! tracer gradient at pstep levels 
     98      REAL(wp), DIMENSION(jpi,jpj,    kjpt), INTENT(in   ) ::   pgui, pgvi ! tracer gradient at top   levels 
     99      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb        ! tracer (kpass=1) or laplacian of tracer (kpass=2) 
     100      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptbb       ! tracer (only used in kpass=2) 
     101      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta        ! tracer trend 
    104102      ! 
    105103      INTEGER  ::  ji, jj, jk, jn   ! dummy loop indices 
    106104      INTEGER  ::  ikt 
    107       REAL(wp) ::  zmsku, zabe1, zcof1, zcoef3   ! local scalars 
    108       REAL(wp) ::  zmskv, zabe2, zcof2, zcoef4   !   -      - 
    109       REAL(wp) ::  zcoef0, zbtr, ztra            !   -      - 
    110       REAL(wp), POINTER, DIMENSION(:,:  ) ::  z2d 
    111       REAL(wp), POINTER, DIMENSION(:,:,:) ::  zdkt, zdk1t, zdit, zdjt, ztfw  
     105      INTEGER  ::  ierr             ! local integer 
     106      REAL(wp) ::  zmsku, zahu_w, zabe1, zcof1, zcoef3   ! local scalars 
     107      REAL(wp) ::  zmskv, zahv_w, zabe2, zcof2, zcoef4   !   -      - 
     108      REAL(wp) ::  zcoef0, ze3w_2, zsign, z2dt, z1_2dt   !   -      - 
     109#if defined key_diaar5 
     110      REAL(wp) ::   zztmp   ! local scalar 
     111#endif 
     112      REAL(wp), POINTER, DIMENSION(:,:)   ::   zdkt, zdk1t, z2d 
     113      REAL(wp), POINTER, DIMENSION(:,:,:) ::   zdit, zdjt, zftu, zftv, ztfw  
    112114      !!---------------------------------------------------------------------- 
    113115      ! 
    114116      IF( nn_timing == 1 )  CALL timing_start('tra_ldf_iso') 
    115117      ! 
    116       CALL wrk_alloc( jpi, jpj,      z2d )  
    117       CALL wrk_alloc( jpi, jpj, jpk, zdit, zdjt, ztfw, zdkt, zdk1t )  
    118       ! 
    119  
     118      CALL wrk_alloc( jpi,jpj,       zdkt, zdk1t, z2d )  
     119      CALL wrk_alloc( jpi,jpj,jpk,   zdit, zdjt , zftu, zftv, ztfw  )  
     120      ! 
    120121      IF( kt == kit000 )  THEN 
    121122         IF(lwp) WRITE(numout,*) 
    122123         IF(lwp) WRITE(numout,*) 'tra_ldf_iso : rotated laplacian diffusion operator on ', cdtype 
    123124         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 
     125         ! 
     126         akz     (:,:,:) = 0._wp       
     127         ah_wslp2(:,:,:) = 0._wp 
     128      ENDIF 
     129      !                                               ! set time step size (Euler/Leapfrog) 
     130      IF( neuler == 0 .AND. kt == nit000 ) THEN   ;   z2dt =     rdt      ! at nit000   (Euler) 
     131      ELSE                                        ;   z2dt = 2.* rdt      !             (Leapfrog) 
     132      ENDIF 
     133      z1_2dt = 1._wp / z2dt 
     134      ! 
     135      IF( kpass == 1 ) THEN   ;   zsign =  1._wp      ! bilaplacian operator require a minus sign (eddy diffusivity >0) 
     136      ELSE                    ;   zsign = -1._wp 
     137      ENDIF 
     138          
     139      !!---------------------------------------------------------------------- 
     140      !!   0 - calculate  ah_wslp2 and akz 
     141      !!---------------------------------------------------------------------- 
     142      ! 
     143      IF( kpass == 1 ) THEN                  !==  first pass only  ==! 
     144         ! 
     145         DO jk = 2, jpkm1 
     146            DO jj = 2, jpjm1 
     147               DO ji = fs_2, fs_jpim1   ! vector opt. 
     148                  ! 
     149                  zmsku = wmask(ji,jj,jk) / MAX(   umask(ji  ,jj,jk-1) + umask(ji-1,jj,jk)          & 
     150                     &                           + umask(ji-1,jj,jk-1) + umask(ji  ,jj,jk) , 1._wp  ) 
     151                  zmskv = wmask(ji,jj,jk) / MAX(   vmask(ji,jj  ,jk-1) + vmask(ji,jj-1,jk)          & 
     152                     &                           + vmask(ji,jj-1,jk-1) + vmask(ji,jj  ,jk) , 1._wp  ) 
     153                     ! 
     154                  zahu_w = (   pahu(ji  ,jj,jk-1) + pahu(ji-1,jj,jk)    & 
     155                     &       + pahu(ji-1,jj,jk-1) + pahu(ji  ,jj,jk)  ) * zmsku 
     156                  zahv_w = (   pahv(ji,jj  ,jk-1) + pahv(ji,jj-1,jk)    & 
     157                     &       + pahv(ji,jj-1,jk-1) + pahv(ji,jj  ,jk)  ) * zmskv 
     158                     ! 
     159                  ah_wslp2(ji,jj,jk) = zahu_w * wslpi(ji,jj,jk) * wslpi(ji,jj,jk)   & 
     160                     &               + zahv_w * wslpj(ji,jj,jk) * wslpj(ji,jj,jk) 
     161               END DO 
     162            END DO 
     163         END DO 
     164         ! 
     165         IF( ln_traldf_msc ) THEN                ! stabilizing vertical diffusivity coefficient 
     166            DO jk = 2, jpkm1 
     167               DO jj = 2, jpjm1 
     168                  DO ji = fs_2, fs_jpim1 
     169                     akz(ji,jj,jk) = 0.25_wp * (                                                                     & 
     170                        &              ( pahu(ji  ,jj,jk) + pahu(ji  ,jj,jk-1) ) / ( e1u(ji  ,jj) * e1u(ji  ,jj) )   & 
     171                        &            + ( pahu(ji-1,jj,jk) + pahu(ji-1,jj,jk-1) ) / ( e1u(ji-1,jj) * e1u(ji-1,jj) )   & 
     172                        &            + ( pahv(ji,jj  ,jk) + pahv(ji,jj  ,jk-1) ) / ( e2v(ji,jj  ) * e2v(ji,jj  ) )   & 
     173                        &            + ( pahv(ji,jj-1,jk) + pahv(ji,jj-1,jk-1) ) / ( e2v(ji,jj-1) * e2v(ji,jj-1) )   ) 
     174                  END DO 
     175               END DO 
     176            END DO 
     177            ! 
     178            IF( ln_traldf_blp ) THEN                ! bilaplacian operator 
     179               DO jk = 2, jpkm1 
     180                  DO jj = 1, jpjm1 
     181                     DO ji = 1, fs_jpim1 
     182                        akz(ji,jj,jk) = 16._wp * ah_wslp2(ji,jj,jk)   & 
     183                           &          * (  akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ( e3w_n(ji,jj,jk) * e3w_n(ji,jj,jk) )  ) 
     184                     END DO 
     185                  END DO 
     186               END DO 
     187            ELSEIF( ln_traldf_lap ) THEN              ! laplacian operator 
     188               DO jk = 2, jpkm1 
     189                  DO jj = 1, jpjm1 
     190                     DO ji = 1, fs_jpim1 
     191                        ze3w_2 = e3w_n(ji,jj,jk) * e3w_n(ji,jj,jk) 
     192                        zcoef0 = z2dt * (  akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ze3w_2  ) 
     193                        akz(ji,jj,jk) = MAX( zcoef0 - 0.5_wp , 0._wp ) * ze3w_2 * z1_2dt 
     194                     END DO 
     195                  END DO 
     196               END DO 
     197           ENDIF 
     198           ! 
     199         ELSE                                    ! 33 flux set to zero with akz=ah_wslp2 ==>> computed in full implicit 
     200            akz(:,:,:) = ah_wslp2(:,:,:)       
     201         ENDIF 
    124202      ENDIF 
    125203      ! 
    … …  
    131209         !!   I - masked horizontal derivative  
    132210         !!---------------------------------------------------------------------- 
    133          !!bug ajout.... why?   ( 1,jpj,:) and (jpi,1,:) should be sufficient.... 
    134          zdit (1,:,:) = 0.e0     ;     zdit (jpi,:,:) = 0.e0 
    135          zdjt (1,:,:) = 0.e0     ;     zdjt (jpi,:,:) = 0.e0 
     211!!gm : bug.... why (x,:,:)?   (1,jpj,:) and (jpi,1,:) should be sufficient.... 
     212         zdit (1,:,:) = 0._wp     ;     zdit (jpi,:,:) = 0._wp 
     213         zdjt (1,:,:) = 0._wp     ;     zdjt (jpi,:,:) = 0._wp 
    136214         !!end 
    137215 
    … …  
    145223            END DO 
    146224         END DO 
    147  
    148          ! partial cell correction 
    149          IF( ln_zps ) THEN      ! partial steps correction at the last ocean level  
    150             DO jj = 1, jpjm1 
     225         IF( ln_zps ) THEN      ! botton and surface ocean correction of the horizontal gradient 
     226            DO jj = 1, jpjm1              ! bottom correction (partial bottom cell) 
    151227               DO ji = 1, fs_jpim1   ! vector opt. 
    152 ! IF useless if zpshde defines pgu everywhere 
    153228                  zdit(ji,jj,mbku(ji,jj)) = pgu(ji,jj,jn)           
    154229                  zdjt(ji,jj,mbkv(ji,jj)) = pgv(ji,jj,jn) 
    155230               END DO 
    156231            END DO 
     232            IF( ln_isfcav ) THEN      ! first wet level beneath a cavity 
     233               DO jj = 1, jpjm1 
     234                  DO ji = 1, fs_jpim1   ! vector opt. 
     235                     IF( miku(ji,jj) > 1 )   zdit(ji,jj,miku(ji,jj)) = pgui(ji,jj,jn)           
     236                     IF( mikv(ji,jj) > 1 )   zdjt(ji,jj,mikv(ji,jj)) = pgvi(ji,jj,jn)      
     237                  END DO 
     238               END DO 
     239            ENDIF 
    157240         ENDIF 
    158          IF( ln_zps .AND. ln_isfcav ) THEN      ! partial steps correction at the first wet level beneath a cavity 
    159             DO jj = 1, jpjm1 
     241         ! 
     242         !!---------------------------------------------------------------------- 
     243         !!   II - horizontal trend  (full) 
     244         !!---------------------------------------------------------------------- 
     245         ! 
     246         DO jk = 1, jpkm1                                 ! Horizontal slab 
     247            ! 
     248            !                             !== Vertical tracer gradient 
     249            zdk1t(:,:) = ( ptb(:,:,jk,jn) - ptb(:,:,jk+1,jn) ) * wmask(:,:,jk+1)     ! level jk+1 
     250            ! 
     251            IF( jk == 1 ) THEN   ;   zdkt(:,:) = zdk1t(:,:)                          ! surface: zdkt(jk=1)=zdkt(jk=2) 
     252            ELSE                 ;   zdkt(:,:) = ( ptb(:,:,jk-1,jn) - ptb(:,:,jk,jn) ) * wmask(:,:,jk) 
     253            ENDIF 
     254            DO jj = 1 , jpjm1            !==  Horizontal fluxes 
    160255               DO ji = 1, fs_jpim1   ! vector opt. 
    161                   IF (miku(ji,jj) > 1) zdit(ji,jj,miku(ji,jj)) = pgui(ji,jj,jn)           
    162                   IF (mikv(ji,jj) > 1) zdjt(ji,jj,mikv(ji,jj)) = pgvi(ji,jj,jn)      
    163                END DO 
    164             END DO 
    165          END IF 
    166  
    167          !!---------------------------------------------------------------------- 
    168          !!   II - horizontal trend  (full) 
    169          !!---------------------------------------------------------------------- 
    170 !!!!!!!!!!CDIR PARALLEL DO PRIVATE( zdk1t )  
    171             ! 1. Vertical tracer gradient at level jk and jk+1 
    172             ! ------------------------------------------------ 
    173          !  
    174          ! interior value  
    175          DO jk = 2, jpkm1                
    176             DO jj = 1, jpj 
    177                DO ji = 1, jpi   ! vector opt. 
    178                   zdk1t(ji,jj,jk) = ( ptb(ji,jj,jk,jn  ) - ptb(ji,jj,jk+1,jn) ) * wmask(ji,jj,jk+1) 
    179                   ! 
    180                   zdkt(ji,jj,jk)  = ( ptb(ji,jj,jk-1,jn) - ptb(ji,jj,jk,jn  ) ) * wmask(ji,jj,jk) 
    181                END DO 
    182             END DO 
    183          END DO 
    184          ! surface boundary condition: zdkt(jk=1)=zdkt(jk=2) 
    185          zdk1t(:,:,1) = ( ptb(:,:,1,jn  ) - ptb(:,:,2,jn) ) * wmask(:,:,2) 
    186          zdkt (:,:,1) = zdk1t(:,:,1) 
    187          IF ( ln_isfcav ) THEN 
    188             DO jj = 1, jpj 
    189                DO ji = 1, jpi   ! vector opt. 
    190                   ikt = mikt(ji,jj) ! surface level 
    191                   zdk1t(ji,jj,ikt) = ( ptb(ji,jj,ikt,jn  ) - ptb(ji,jj,ikt+1,jn) ) * wmask(ji,jj,ikt+1) 
    192                   zdkt (ji,jj,ikt) = zdk1t(ji,jj,ikt) 
    193                END DO 
    194             END DO 
    195          END IF 
    196  
    197          ! 2. Horizontal fluxes 
    198          ! --------------------    
    199          DO jk = 1, jpkm1 
    200             DO jj = 1 , jpjm1 
    201                DO ji = 1, fs_jpim1   ! vector opt. 
    202                   zabe1 = ( fsahtu(ji,jj,jk) + pahtb0 ) * re2u_e1u(ji,jj) * fse3u_n(ji,jj,jk) 
    203                   zabe2 = ( fsahtv(ji,jj,jk) + pahtb0 ) * re1v_e2v(ji,jj) * fse3v_n(ji,jj,jk) 
    204                   ! 
    205                   zmsku = 1. / MAX(  tmask(ji+1,jj,jk  ) + tmask(ji,jj,jk+1)   & 
    206                      &             + tmask(ji+1,jj,jk+1) + tmask(ji,jj,jk  ), 1. ) 
    207                   ! 
    208                   zmskv = 1. / MAX(  tmask(ji,jj+1,jk  ) + tmask(ji,jj,jk+1)   & 
    209                      &             + tmask(ji,jj+1,jk+1) + tmask(ji,jj,jk  ), 1. ) 
    210                   ! 
    211                   zcof1 = - fsahtu(ji,jj,jk) * e2u(ji,jj) * uslp(ji,jj,jk) * zmsku 
    212                   zcof2 = - fsahtv(ji,jj,jk) * e1v(ji,jj) * vslp(ji,jj,jk) * zmskv 
     256                  zabe1 = pahu(ji,jj,jk) * e2_e1u(ji,jj) * e3u_n(ji,jj,jk) 
     257                  zabe2 = pahv(ji,jj,jk) * e1_e2v(ji,jj) * e3v_n(ji,jj,jk) 
     258                  ! 
     259                  zmsku = 1. / MAX(  wmask(ji+1,jj,jk  ) + wmask(ji,jj,jk+1)   & 
     260                     &             + wmask(ji+1,jj,jk+1) + wmask(ji,jj,jk  ), 1. ) 
     261                  ! 
     262                  zmskv = 1. / MAX(  wmask(ji,jj+1,jk  ) + wmask(ji,jj,jk+1)   & 
     263                     &             + wmask(ji,jj+1,jk+1) + wmask(ji,jj,jk  ), 1. ) 
     264                  ! 
     265                  zcof1 = - pahu(ji,jj,jk) * e2u(ji,jj) * uslp(ji,jj,jk) * zmsku 
     266                  zcof2 = - pahv(ji,jj,jk) * e1v(ji,jj) * vslp(ji,jj,jk) * zmskv 
    213267                  ! 
    214268                  zftu(ji,jj,jk ) = (  zabe1 * zdit(ji,jj,jk)   & 
    215                      &              + zcof1 * (  zdkt (ji+1,jj,jk) + zdk1t(ji,jj,jk)      & 
    216                      &                         + zdk1t(ji+1,jj,jk) + zdkt (ji,jj,jk)  )  ) * umask(ji,jj,jk) 
     269                     &               + zcof1 * (  zdkt (ji+1,jj) + zdk1t(ji,jj)      & 
     270                     &                          + zdk1t(ji+1,jj) + zdkt (ji,jj)  )  ) * umask(ji,jj,jk) 
    217271                  zftv(ji,jj,jk) = (  zabe2 * zdjt(ji,jj,jk)   & 
    218                      &              + zcof2 * (  zdkt (ji,jj+1,jk) + zdk1t(ji,jj,jk)      & 
    219                      &                         + zdk1t(ji,jj+1,jk) + zdkt (ji,jj,jk)  )  ) * vmask(ji,jj,jk)                   
    220                END DO 
    221             END DO 
    222  
    223             ! II.4 Second derivative (divergence) and add to the general trend 
    224             ! ---------------------------------------------------------------- 
    225             DO jj = 2 , jpjm1 
     272                     &               + zcof2 * (  zdkt (ji,jj+1) + zdk1t(ji,jj)      & 
     273                     &                          + zdk1t(ji,jj+1) + zdkt (ji,jj)  )  ) * vmask(ji,jj,jk)                   
     274               END DO 
     275            END DO 
     276            ! 
     277            DO jj = 2 , jpjm1          !== horizontal divergence and add to pta 
    226278               DO ji = fs_2, fs_jpim1   ! vector opt. 
    227                   zbtr = 1.0 / ( e12t(ji,jj) * fse3t_n(ji,jj,jk) ) 
    228                   ztra = zbtr * ( zftu(ji,jj,jk) - zftu(ji-1,jj,jk) + zftv(ji,jj,jk) - zftv(ji,jj-1,jk)  ) 
    229                   pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra 
    230                END DO 
    231             END DO 
    232             !                                          ! =============== 
     279                  pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + zsign * (  zftu(ji,jj,jk) - zftu(ji-1,jj,jk)      & 
     280                     &                                           + zftv(ji,jj,jk) - zftv(ji,jj-1,jk)  )   & 
     281                     &                                        * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 
     282               END DO 
     283            END DO 
    233284         END DO                                        !   End of slab   
    234          !                                             ! =============== 
    235          ! 
    236          ! "Poleward" diffusive heat or salt transports (T-S case only) 
    237          IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 
    238             ! note sign is reversed to give down-gradient diffusive transports (#1043) 
    239             IF( jn == jp_tem)   htr_ldf(:) = ptr_sj( -zftv(:,:,:) ) 
    240             IF( jn == jp_sal)   str_ldf(:) = ptr_sj( -zftv(:,:,:) ) 
    241          ENDIF 
    242   
    243          IF( iom_use("udiff_heattr") .OR. iom_use("vdiff_heattr") ) THEN 
    244            ! 
    245            IF( cdtype == 'TRA' .AND. jn == jp_tem  ) THEN 
    246                z2d(:,:) = 0._wp  
    247                DO jk = 1, jpkm1 
    248                   DO jj = 2, jpjm1 
    249                      DO ji = fs_2, fs_jpim1   ! vector opt. 
    250                         z2d(ji,jj) = z2d(ji,jj) + zftu(ji,jj,jk)  
    251                      END DO 
    252                   END DO 
    253                END DO 
    254                z2d(:,:) = - rau0_rcp * z2d(:,:)     ! note sign is reversed to give down-gradient diffusive transports (#1043) 
    255                CALL lbc_lnk( z2d, 'U', -1. ) 
    256                CALL iom_put( "udiff_heattr", z2d )                  ! heat transport in i-direction 
    257                ! 
    258                z2d(:,:) = 0._wp  
    259                DO jk = 1, jpkm1 
    260                   DO jj = 2, jpjm1 
    261                      DO ji = fs_2, fs_jpim1   ! vector opt. 
    262                         z2d(ji,jj) = z2d(ji,jj) + zftv(ji,jj,jk)  
    263                      END DO 
    264                   END DO 
    265                END DO 
    266                z2d(:,:) = - rau0_rcp * z2d(:,:)     ! note sign is reversed to give down-gradient diffusive transports (#1043) 
    267                CALL lbc_lnk( z2d, 'V', -1. ) 
    268                CALL iom_put( "vdiff_heattr", z2d )                  !  heat transport in i-direction 
    269             END IF 
    270             ! 
    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           
     285 
     286         !!---------------------------------------------------------------------- 
     287         !!   III - vertical trend (full) 
     288         !!---------------------------------------------------------------------- 
     289         ! 
     290         ztfw(1,:,:) = 0._wp     ;     ztfw(jpi,:,:) = 0._wp 
     291         ! 
    281292         ! Vertical fluxes 
    282293         ! --------------- 
     294         !                          ! Surface and bottom vertical fluxes set to zero 
     295         ztfw(:,:, 1 ) = 0._wp      ;      ztfw(:,:,jpk) = 0._wp 
    283296          
    284          ! Surface and bottom vertical fluxes set to zero 
    285          ztfw(:,:, 1 ) = 0.e0      ;      ztfw(:,:,jpk) = 0.e0 
    286           
    287          ! interior (2=<jk=<jpk-1) 
    288          DO jk = 2, jpkm1 
     297         DO jk = 2, jpkm1           ! interior (2=<jk=<jpk-1) 
    289298            DO jj = 2, jpjm1 
    290299               DO ji = fs_2, fs_jpim1   ! vector opt. 
    291                   zcoef0 = - fsahtw(ji,jj,jk) * wmask(ji,jj,jk) 
    292                   ! 
    293                   zmsku = 1./MAX(   umask(ji  ,jj,jk-1) + umask(ji-1,jj,jk)      & 
    294                      &            + umask(ji-1,jj,jk-1) + umask(ji  ,jj,jk), 1.  ) 
    295                   zmskv = 1./MAX(   vmask(ji,jj  ,jk-1) + vmask(ji,jj-1,jk)      & 
    296                      &            + vmask(ji,jj-1,jk-1) + vmask(ji,jj  ,jk), 1.  ) 
    297                   ! 
    298                   zcoef3 = zcoef0 * e2t(ji,jj) * zmsku * wslpi (ji,jj,jk) 
    299                   zcoef4 = zcoef0 * e1t(ji,jj) * zmskv * wslpj (ji,jj,jk) 
     300                  ! 
     301                  zmsku = wmask(ji,jj,jk) / MAX(   umask(ji  ,jj,jk-1) + umask(ji-1,jj,jk)          & 
     302                     &                           + umask(ji-1,jj,jk-1) + umask(ji  ,jj,jk) , 1._wp  ) 
     303                  zmskv = wmask(ji,jj,jk) / MAX(   vmask(ji,jj  ,jk-1) + vmask(ji,jj-1,jk)          & 
     304                     &                           + vmask(ji,jj-1,jk-1) + vmask(ji,jj  ,jk) , 1._wp  ) 
     305                     ! 
     306                  zahu_w = (   pahu(ji  ,jj,jk-1) + pahu(ji-1,jj,jk)    & 
     307                     &       + pahu(ji-1,jj,jk-1) + pahu(ji  ,jj,jk)  ) * zmsku 
     308                  zahv_w = (   pahv(ji,jj  ,jk-1) + pahv(ji,jj-1,jk)    & 
     309                     &       + pahv(ji,jj-1,jk-1) + pahv(ji,jj  ,jk)  ) * zmskv 
     310                     ! 
     311                  zcoef3 = - zahu_w * e2t(ji,jj) * zmsku * wslpi (ji,jj,jk)   !wslpi & j are already w-masked 
     312                  zcoef4 = - zahv_w * e1t(ji,jj) * zmskv * wslpj (ji,jj,jk) 
    300313                  ! 
    301314                  ztfw(ji,jj,jk) = zcoef3 * (   zdit(ji  ,jj  ,jk-1) + zdit(ji-1,jj  ,jk)      & 
    … …  
    306319            END DO 
    307320         END DO 
    308           
    309           
    310          ! I.5 Divergence of vertical fluxes added to the general tracer trend 
    311          ! ------------------------------------------------------------------- 
    312          DO jk = 1, jpkm1 
     321         !                                !==  add the vertical 33 flux  ==! 
     322         IF( ln_traldf_lap ) THEN               ! laplacian case: eddy coef = ah_wslp2 - akz 
     323            DO jk = 2, jpkm1        
     324               DO jj = 1, jpjm1 
     325                  DO ji = fs_2, fs_jpim1 
     326                     ztfw(ji,jj,jk) = ztfw(ji,jj,jk) + e1e2t(ji,jj) / e3w_n(ji,jj,jk) * wmask(ji,jj,jk)   & 
     327                        &                            * ( ah_wslp2(ji,jj,jk) - akz(ji,jj,jk) )             & 
     328                        &                            * ( ptb(ji,jj,jk-1,jn) - ptb(ji,jj,jk,jn) ) 
     329                  END DO 
     330               END DO 
     331            END DO 
     332            ! 
     333         ELSE                                   ! bilaplacian  
     334            SELECT CASE( kpass ) 
     335            CASE(  1  )                            ! 1st pass : eddy coef = ah_wslp2 
     336               DO jk = 2, jpkm1  
     337                  DO jj = 1, jpjm1 
     338                     DO ji = fs_2, fs_jpim1 
     339                        ztfw(ji,jj,jk) = ztfw(ji,jj,jk)    & 
     340                           &           + ah_wslp2(ji,jj,jk) * e1e2t(ji,jj)   & 
     341                           &           * ( ptb(ji,jj,jk-1,jn) - ptb(ji,jj,jk,jn) ) / e3w_n(ji,jj,jk) * wmask(ji,jj,jk) 
     342                     END DO 
     343                  END DO 
     344               END DO  
     345            CASE(  2  )                         ! 2nd pass : eddy flux = ah_wslp2 and akz applied on ptb  and ptbb gradients, resp. 
     346               DO jk = 2, jpkm1  
     347                  DO jj = 1, jpjm1 
     348                     DO ji = fs_2, fs_jpim1 
     349                        ztfw(ji,jj,jk) = ztfw(ji,jj,jk) + e1e2t(ji,jj) / e3w_n(ji,jj,jk) * wmask(ji,jj,jk)                      & 
     350                           &                            * (  ah_wslp2(ji,jj,jk) * ( ptb (ji,jj,jk-1,jn) - ptb (ji,jj,jk,jn) )   & 
     351                           &                               + akz     (ji,jj,jk) * ( ptbb(ji,jj,jk-1,jn) - ptbb(ji,jj,jk,jn) )   ) 
     352                     END DO 
     353                  END DO 
     354               END DO 
     355            END SELECT 
     356         ENDIF 
     357         !          
     358         DO jk = 1, jpkm1                 !==  Divergence of vertical fluxes added to pta  ==! 
    313359            DO jj = 2, jpjm1 
    314360               DO ji = fs_2, fs_jpim1   ! vector opt. 
    315                   zbtr = 1.0 / ( e12t(ji,jj) * fse3t_n(ji,jj,jk) ) 
    316                   ztra = (  ztfw(ji,jj,jk) - ztfw(ji,jj,jk+1)  ) * zbtr 
    317                   pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra 
     361                  pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + zsign * (  ztfw (ji,jj,jk) - ztfw(ji,jj,jk+1)  )   & 
     362                     &                                        * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 
    318363               END DO 
    319364            END DO 
    320365         END DO 
    321366         ! 
    322       END DO 
    323       ! 
    324       CALL wrk_dealloc( jpi, jpj, z2d )  
    325       CALL wrk_dealloc( jpi, jpj, jpk, zdit, zdjt, ztfw, zdkt, zdk1t )  
     367         IF( ( kpass == 1 .AND. ln_traldf_lap ) .OR.  &     !==  first pass only (  laplacian)  ==! 
     368             ( kpass == 2 .AND. ln_traldf_blp ) ) THEN      !==  2nd   pass      (bilaplacian)  ==! 
     369            ! 
     370            !                             ! "Poleward" diffusive heat or salt transports (T-S case only) 
     371            IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 
     372               ! note sign is reversed to give down-gradient diffusive transports (#1043) 
     373               IF( jn == jp_tem)   htr_ldf(:) = ptr_sj( -zftv(:,:,:) ) 
     374               IF( jn == jp_sal)   str_ldf(:) = ptr_sj( -zftv(:,:,:) ) 
     375            ENDIF 
     376            ! 
     377            IF( iom_use("udiff_heattr") .OR. iom_use("vdiff_heattr") ) THEN 
     378              ! 
     379              IF( cdtype == 'TRA' .AND. jn == jp_tem  ) THEN 
     380                  z2d(:,:) = zftu(ji,jj,1)  
     381                  DO jk = 2, jpkm1 
     382                     DO jj = 2, jpjm1 
     383                        DO ji = fs_2, fs_jpim1   ! vector opt. 
     384                           z2d(ji,jj) = z2d(ji,jj) + zftu(ji,jj,jk)  
     385                        END DO 
     386                     END DO 
     387                  END DO 
     388!!gm CAUTION I think there is an error of sign when using BLP operator.... 
     389!!gm         a multiplication by zsign is required (to be checked twice !) 
     390                  z2d(:,:) = - rau0_rcp * z2d(:,:)     ! note sign is reversed to give down-gradient diffusive transports (#1043) 
     391                  CALL lbc_lnk( z2d, 'U', -1. ) 
     392                  CALL iom_put( "udiff_heattr", z2d )                  ! heat transport in i-direction 
     393                  ! 
     394                  z2d(:,:) = zftv(ji,jj,1)  
     395                  DO jk = 2, jpkm1 
     396                     DO jj = 2, jpjm1 
     397                        DO ji = fs_2, fs_jpim1   ! vector opt. 
     398                           z2d(ji,jj) = z2d(ji,jj) + zftv(ji,jj,jk)  
     399                        END DO 
     400                     END DO 
     401                  END DO 
     402                  z2d(:,:) = - rau0_rcp * z2d(:,:)     ! note sign is reversed to give down-gradient diffusive transports (#1043) 
     403                  CALL lbc_lnk( z2d, 'V', -1. ) 
     404                  CALL iom_put( "vdiff_heattr", z2d )                  !  heat transport in i-direction 
     405               END IF 
     406               ! 
     407            ENDIF 
     408            ! 
     409         ENDIF                                                    !== end pass selection  ==! 
     410         ! 
     411         !                                                        ! =============== 
     412      END DO                                                      ! end tracer loop 
     413      !                                                           ! =============== 
     414      ! 
     415      CALL wrk_dealloc( jpi, jpj,      zdkt, zdk1t, z2d )  
     416      CALL wrk_dealloc( jpi, jpj, jpk, zdit, zdjt , zftu, zftv, ztfw  )  
    326417      ! 
    327418      IF( nn_timing == 1 )  CALL timing_stop('tra_ldf_iso') 
    328419      ! 
    329420   END SUBROUTINE tra_ldf_iso 
    330  
    331 #else 
    332    !!---------------------------------------------------------------------- 
    333    !!   default option :   Dummy code   NO rotation of the diffusive tensor 
    334    !!---------------------------------------------------------------------- 
    335 CONTAINS 
    336    SUBROUTINE tra_ldf_iso( kt, kit000,cdtype, pgu, pgv, pgui, pgvi, ptb, pta, kjpt, pahtb0 )      ! Empty routine 
    337       INTEGER:: kt, kit000 
    338       CHARACTER(len=3) ::   cdtype 
    339       REAL, DIMENSION(:,:,:) ::   pgu, pgv, pgui, pgvi    ! tracer gradient at pstep levels 
    340       REAL, DIMENSION(:,:,:,:) ::   ptb, pta 
    341       WRITE(*,*) 'tra_ldf_iso: You should not have seen this print! error?', kt, kit000, cdtype,   & 
    342          &                       pgu(1,1,1), pgv(1,1,1), ptb(1,1,1,1), pta(1,1,1,1), kjpt, pahtb0 
    343    END SUBROUTINE tra_ldf_iso 
    344 #endif 
    345421 
    346422   !!============================================================================== 

  • branches/NERC/dev_r5549_BDY_ZEROGRAD/NEMOGCM/NEMO/OPA_SRC/TRA/tranpc.F90

    r5386 r6808  
    1313 
    1414   !!---------------------------------------------------------------------- 
    15    !!   tra_npc : apply the non penetrative convection scheme 
    16    !!---------------------------------------------------------------------- 
    17    USE oce             ! ocean dynamics and active tracers 
    18    USE dom_oce         ! ocean space and time domain 
    19    USE phycst          ! physical constants 
    20    USE zdf_oce         ! ocean vertical physics 
    21    USE trd_oce         ! ocean active tracer trends 
    22    USE trdtra          ! ocean active tracer trends 
    23    USE eosbn2          ! equation of state (eos routine) 
     15   !!   tra_npc       : apply the non penetrative convection scheme 
     16   !!---------------------------------------------------------------------- 
     17   USE oce            ! ocean dynamics and active tracers 
     18   USE dom_oce        ! ocean space and time domain 
     19   USE phycst         ! physical constants 
     20   USE zdf_oce        ! ocean vertical physics 
     21   USE trd_oce        ! ocean active tracer trends 
     22   USE trdtra         ! ocean active tracer trends 
     23   USE eosbn2         ! equation of state (eos routine) 
    2424   ! 
    25    USE lbclnk          ! lateral boundary conditions (or mpp link) 
    26    USE in_out_manager  ! I/O manager 
    27    USE lib_mpp         ! MPP library 
    28    USE wrk_nemo        ! Memory Allocation 
    29    USE timing          ! Timing 
     25   USE lbclnk         ! lateral boundary conditions (or mpp link) 
     26   USE in_out_manager ! I/O manager 
     27   USE lib_mpp        ! MPP library 
     28   USE wrk_nemo       ! Memory Allocation 
     29   USE timing         ! Timing 
    3030 
    3131   IMPLICIT NONE 
    … …  
    3535 
    3636   !! * Substitutions 
    37 #  include "domzgr_substitute.h90" 
    3837#  include "vectopt_loop_substitute.h90" 
    3938   !!---------------------------------------------------------------------- 
    … …  
    5554      !!              (i.e. static stability computed locally) 
    5655      !! 
    57       !! ** Action  : - (ta,sa) after the application od the npc scheme 
     56      !! ** Action  : - tsa: after tracers with the application of the npc scheme 
    5857      !!              - send the associated trends for on-line diagnostics (l_trdtra=T) 
    5958      !! 
    … …  
    115114                  zvts(:,jp_tem) = tsa(ji,jj,:,jp_tem)      ! temperature 
    116115                  zvts(:,jp_sal) = tsa(ji,jj,:,jp_sal)      ! salinity 
    117  
     116                  ! 
    118117                  zvab(:,jp_tem)  = zab(ji,jj,:,jp_tem)     ! Alpha  
    119118                  zvab(:,jp_sal)  = zab(ji,jj,:,jp_sal)     ! Beta   
    120119                  zvn2(:)         = zn2(ji,jj,:)            ! N^2  
    121                   
     120                  ! 
    122121                  IF( l_LB_debug ) THEN                  !LB debug: 
    123122                     lp_monitor_point = .FALSE. 
    … …  
    126125                     lp_monitor_point = (narea == nncpu).AND.lp_monitor_point                       
    127126                  ENDIF                                  !LB debug  end 
    128  
     127                  ! 
    129128                  ikbot = mbkt(ji,jj)   ! ikbot: ocean bottom T-level 
    130129                  ikp = 1                  ! because N2 is irrelevant at the surface level (will start at ikp=2) 
    … …  
    132131                  jiter  = 0 
    133132                  l_column_treated = .FALSE. 
    134                   
     133                  ! 
    135134                  DO WHILE ( .NOT. l_column_treated ) 
    136135                     ! 
    137136                     jiter = jiter + 1 
    138                      
     137                     !  
    139138                     IF( jiter >= 400 ) EXIT 
    140                      
     139                     ! 
    141140                     l_bottom_reached = .FALSE. 
    142  
     141                     ! 
    143142                     DO WHILE ( .NOT. l_bottom_reached ) 
    144  
     143                        ! 
    145144                        ikp = ikp + 1 
    146                         
     145                        ! 
    147146                        !! Testing level ikp for instability 
    148147                        !! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
    149148                        IF( zvn2(ikp) <  -zn2_zero ) THEN ! Instability found! 
    150  
     149                           ! 
    151150                           ilayer = ilayer + 1    ! yet another instable portion of the water column found.... 
    152  
     151                           ! 
    153152                           IF( lp_monitor_point ) THEN  
    154153                              WRITE(numout,*) 
    … …  
    165164                              WRITE(numout,*) 
    166165                           ENDIF 
    167                             
    168  
     166                           ! 
    169167                           IF( jiter == 1 )   inpcc = inpcc + 1  
    170  
     168                           ! 
    171169                           IF( lp_monitor_point )   WRITE(numout, *) 'Negative N2 at ikp =',ikp,' for layer #', ilayer 
    172  
     170                           ! 
    173171                           !! ikup is the uppermost point where mixing will start: 
    174172                           ikup = ikp - 1 ! ikup is always "at most at ikp-1", less if neutral levels overlying 
    175                             
     173                           ! 
    176174                           !! If the points above ikp-1 have N2 == 0 they must also be mixed: 
    177175                           IF( ikp > 2 ) THEN 
    … …  
    184182                              END DO 
    185183                           ENDIF 
    186                             
     184                           ! 
    187185                           IF( ikup < 1 )   CALL ctl_stop( 'tra_npc :  PROBLEM #1') 
    188  
     186                           ! 
    189187                           zsum_temp = 0._wp 
    190188                           zsum_sali = 0._wp 
    … …  
    195193                           DO jk = ikup, ikbot      ! Inside the instable (and overlying neutral) portion of the column 
    196194                              ! 
    197                               zdz       = fse3t(ji,jj,jk) 
     195                              zdz       = e3t_n(ji,jj,jk) 
    198196                              zsum_temp = zsum_temp + zvts(jk,jp_tem)*zdz 
    199197                              zsum_sali = zsum_sali + zvts(jk,jp_sal)*zdz 
    … …  
    244242 
    245243                              !! Interpolating alfa and beta at W point: 
    246                               zrw =  (fsdepw(ji,jj,jk  ) - fsdept(ji,jj,jk)) & 
    247                                  & / (fsdept(ji,jj,jk-1) - fsdept(ji,jj,jk)) 
     244                              zrw =  (gdepw_n(ji,jj,jk  ) - gdept_n(ji,jj,jk)) & 
     245                                 & / (gdept_n(ji,jj,jk-1) - gdept_n(ji,jj,jk)) 
    248246                              zaw = zvab(jk,jp_tem) * (1._wp - zrw) + zvab(jk-1,jp_tem) * zrw 
    249247                              zbw = zvab(jk,jp_sal) * (1._wp - zrw) + zvab(jk-1,jp_sal) * zrw 
    … …  
    252250                              zvn2(jk) = grav*( zaw * ( zvts(jk-1,jp_tem) - zvts(jk,jp_tem) )     & 
    253251                                 &            - zbw * ( zvts(jk-1,jp_sal) - zvts(jk,jp_sal) )  )  & 
    254                                  &       / fse3w(ji,jj,jk) * tmask(ji,jj,jk) 
     252                                 &       / e3w_n(ji,jj,jk) * tmask(ji,jj,jk) 
    255253 
    256254                              !! OR, faster  => just considering the vertical gradient of density 

  • branches/NERC/dev_r5549_BDY_ZEROGRAD/NEMOGCM/NEMO/OPA_SRC/TRA/tranxt.F90

    r5467 r6808  
    2828   USE sbc_oce         ! surface boundary condition: ocean 
    2929   USE sbcrnf          ! river runoffs 
     30   USE sbcisf          ! ice shelf melting 
    3031   USE zdf_oce         ! ocean vertical mixing 
    3132   USE domvvl          ! variable volume 
    32    USE dynspg_oce      ! surface     pressure gradient variables 
    33    USE dynhpg          ! hydrostatic pressure gradient  
    3433   USE trd_oce         ! trends: ocean variables 
    3534   USE trdtra          ! trends manager: tracers  
    3635   USE traqsr          ! penetrative solar radiation (needed for nksr) 
    3736   USE phycst          ! physical constant 
    38    USE ldftra_oce      ! lateral physics on tracers 
     37   USE ldftra          ! lateral physics on tracers 
     38   USE ldfslp 
    3939   USE bdy_oce         ! BDY open boundary condition variables 
    4040   USE bdytra          ! open boundary condition (bdy_tra routine) 
    … …  
    4646   USE timing          ! Timing 
    4747#if defined key_agrif 
    48    USE agrif_opa_update 
    4948   USE agrif_opa_interp 
    5049#endif 
    … …  
    5756   PUBLIC   tra_nxt_vvl   ! to be used in trcnxt 
    5857 
    59    REAL(wp) ::   rbcp   ! Brown & Campana parameters for semi-implicit hpg 
    60  
    6158   !! * Substitutions 
    62 #  include "domzgr_substitute.h90" 
     59#  include "vectopt_loop_substitute.h90" 
    6360   !!---------------------------------------------------------------------- 
    6461   !! NEMO/OPA 3.3 , NEMO-Consortium (2010)  
    … …  
    8885      !!             domains (lk_agrif=T) 
    8986      !! 
    90       !! ** Action  : - (tb,sb) and (tn,sn) ready for the next time step 
    91       !!              - (ta,sa) time averaged (t,s)   (ln_dynhpg_imp = T) 
     87      !! ** Action  : - tsb & tsn ready for the next time step 
    9288      !!---------------------------------------------------------------------- 
    9389      INTEGER, INTENT(in) ::   kt    ! ocean time-step index 
    9490      !! 
    95       INTEGER  ::   jk, jn    ! dummy loop indices 
    96       REAL(wp) ::   zfact     ! local scalars 
     91      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
     92      REAL(wp) ::   zfact            ! local scalars 
    9793      REAL(wp), POINTER, DIMENSION(:,:,:) ::  ztrdt, ztrds 
    9894      !!---------------------------------------------------------------------- 
    … …  
    104100         IF(lwp) WRITE(numout,*) 'tra_nxt : achieve the time stepping by Asselin filter and array swap' 
    105101         IF(lwp) WRITE(numout,*) '~~~~~~~' 
    106          ! 
    107          rbcp = 0.25_wp * (1._wp + atfp) * (1._wp + atfp) * ( 1._wp - atfp)      ! Brown & Campana parameter for semi-implicit hpg 
    108102      ENDIF 
    109103 
    110104      ! Update after tracer on domain lateral boundaries 
    111105      !  
     106#if defined key_agrif 
     107      CALL Agrif_tra                     ! AGRIF zoom boundaries 
     108#endif 
     109      ! 
    112110      CALL lbc_lnk( tsa(:,:,:,jp_tem), 'T', 1._wp )      ! local domain boundaries  (T-point, unchanged sign) 
    113111      CALL lbc_lnk( tsa(:,:,:,jp_sal), 'T', 1._wp ) 
    … …  
    116114      IF( lk_bdy )   CALL bdy_tra( kt )  ! BDY open boundaries 
    117115#endif 
    118 #if defined key_agrif 
    119       CALL Agrif_tra                     ! AGRIF zoom boundaries 
    120 #endif 
    121116  
    122117      ! set time step size (Euler/Leapfrog) 
    123       IF( neuler == 0 .AND. kt == nit000 ) THEN   ;   r2dtra(:) =     rdttra(:)      ! at nit000             (Euler) 
    124       ELSEIF( kt <= nit000 + 1 )           THEN   ;   r2dtra(:) = 2._wp* rdttra(:)      ! at nit000 or nit000+1 (Leapfrog) 
     118      IF( neuler == 0 .AND. kt == nit000 ) THEN   ;   r2dt =     rdt      ! at nit000             (Euler) 
     119      ELSEIF( kt <= nit000 + 1 )           THEN   ;   r2dt = 2._wp* rdt   ! at nit000 or nit000+1 (Leapfrog) 
    125120      ENDIF 
    126121 
    … …  
    142137            END DO 
    143138         END DO 
     139         ! 
    144140      ELSE                                            ! Leap-Frog + Asselin filter time stepping 
    145141         ! 
    146          IF( lk_vvl )  THEN   ;   CALL tra_nxt_vvl( kt, nit000, rdttra, 'TRA', tsb, tsn, tsa,   & 
    147            &                                                              sbc_tsc, sbc_tsc_b, jpts )  ! variable volume level (vvl)  
    148          ELSE                 ;   CALL tra_nxt_fix( kt, nit000,         'TRA', tsb, tsn, tsa, jpts )  ! fixed    volume level  
     142         IF( ln_linssh ) THEN   ;   CALL tra_nxt_fix( kt, nit000,      'TRA', tsb, tsn, tsa, jpts )  ! linear free surface  
     143         ELSE                   ;   CALL tra_nxt_vvl( kt, nit000, rdt, 'TRA', tsb, tsn, tsa,   & 
     144           &                                                                sbc_tsc, sbc_tsc_b, jpts )  ! non-linear free surface 
    149145         ENDIF 
    150       ENDIF  
    151       ! 
    152 #if defined key_agrif 
    153       ! Update tracer at AGRIF zoom boundaries 
    154       IF( .NOT.Agrif_Root() )    CALL Agrif_Update_Tra( kt )      ! children only 
    155 #endif       
    156       ! 
    157       ! trends computation 
     146         ! 
     147         DO jn = 1, jpts 
     148            CALL lbc_lnk( tsb(:,:,:,jn), 'T', 1._wp )  
     149            CALL lbc_lnk( tsn(:,:,:,jn), 'T', 1._wp ) 
     150            CALL lbc_lnk( tsa(:,:,:,jn), 'T', 1._wp ) 
     151         END DO 
     152      ENDIF      
     153      ! 
    158154      IF( l_trdtra ) THEN      ! trend of the Asselin filter (tb filtered - tb)/dt      
    159155         DO jk = 1, jpkm1 
    160             zfact = 1._wp / r2dtra(jk)              
     156            zfact = 1._wp / r2dt              
    161157            ztrdt(:,:,jk) = ( tsb(:,:,jk,jp_tem) - ztrdt(:,:,jk) ) * zfact 
    162158            ztrds(:,:,jk) = ( tsb(:,:,jk,jp_sal) - ztrds(:,:,jk) ) * zfact 
    … …  
    184180      !!  
    185181      !! ** Method  : - Apply a Asselin time filter on now fields. 
    186       !!              - save in (ta,sa) an average over the three time levels  
    187       !!             which will be used to compute rdn and thus the semi-implicit 
    188       !!             hydrostatic pressure gradient (ln_dynhpg_imp = T) 
    189182      !!              - swap tracer fields to prepare the next time_step. 
    190       !!                This can be summurized for tempearture as: 
    191       !!             ztm = tn + rbcp * [ta -2 tn + tb ]       ln_dynhpg_imp = T 
    192       !!             ztm = 0                                   otherwise 
    193       !!                   with rbcp=1/4 * (1-atfp^4) / (1-atfp) 
    194       !!             tb  = tn + atfp*[ tb - 2 tn + ta ] 
    195       !!             tn  = ta   
    196       !!             ta  = ztm       (NB: reset to 0 after eos_bn2 call) 
    197       !! 
    198       !! ** Action  : - (tb,sb) and (tn,sn) ready for the next time step 
    199       !!              - (ta,sa) time averaged (t,s)   (ln_dynhpg_imp = T) 
    200       !!---------------------------------------------------------------------- 
    201       INTEGER         , INTENT(in   )                               ::   kt       ! ocean time-step index 
    202       INTEGER         , INTENT(in   )                               ::   kit000   ! first time step index 
    203       CHARACTER(len=3), INTENT(in   )                               ::   cdtype   ! =TRA or TRC (tracer indicator) 
    204       INTEGER         , INTENT(in   )                               ::   kjpt     ! number of tracers 
    205       REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::   ptb      ! before tracer fields 
    206       REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::   ptn      ! now tracer fields 
    207       REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::   pta      ! tracer trend 
     183      !! 
     184      !! ** Action  : - tsb & tsn ready for the next time step 
     185      !!---------------------------------------------------------------------- 
     186      INTEGER                              , INTENT(in   ) ::  kt        ! ocean time-step index 
     187      INTEGER                              , INTENT(in   ) ::  kit000    ! first time step index 
     188      CHARACTER(len=3)                     , INTENT(in   ) ::  cdtype    ! =TRA or TRC (tracer indicator) 
     189      INTEGER                              , INTENT(in   ) ::  kjpt      ! number of tracers 
     190      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::  ptb       ! before tracer fields 
     191      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::  ptn       ! now tracer fields 
     192      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::  pta       ! tracer trend 
    208193      ! 
    209194      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    210       LOGICAL  ::   ll_tra_hpg       ! local logical 
    211195      REAL(wp) ::   ztn, ztd         ! local scalars 
    212196      !!---------------------------------------------------------------------- 
    213  
     197      ! 
    214198      IF( kt == kit000 )  THEN 
    215199         IF(lwp) WRITE(numout,*) 
    … …  
    218202      ENDIF 
    219203      ! 
    220       IF( cdtype == 'TRA' )  THEN   ;   ll_tra_hpg = ln_dynhpg_imp    ! active  tracers case  and  semi-implicit hpg     
    221       ELSE                          ;   ll_tra_hpg = .FALSE.          ! passive tracers case or NO semi-implicit hpg 
    222       ENDIF 
    223       ! 
    224204      DO jn = 1, kjpt 
    225205         ! 
    226206         DO jk = 1, jpkm1 
    227             DO jj = 1, jpj 
    228                DO ji = 1, jpi 
     207            DO jj = 2, jpjm1 
     208               DO ji = fs_2, fs_jpim1 
    229209                  ztn = ptn(ji,jj,jk,jn)                                     
    230                   ztd = pta(ji,jj,jk,jn) - 2. * ztn + ptb(ji,jj,jk,jn)      !  time laplacian on tracers 
    231                   ! 
    232                   ptb(ji,jj,jk,jn) = ztn + atfp * ztd                       ! ptb <-- filtered ptn  
    233                   ptn(ji,jj,jk,jn) = pta(ji,jj,jk,jn)                       ! ptn <-- pta 
    234                   ! 
    235                   IF( ll_tra_hpg )   pta(ji,jj,jk,jn) = ztn + rbcp * ztd    ! pta <-- Brown & Campana average 
     210                  ztd = pta(ji,jj,jk,jn) - 2._wp * ztn + ptb(ji,jj,jk,jn)  ! time laplacian on tracers 
     211                  ! 
     212                  ptb(ji,jj,jk,jn) = ztn + atfp * ztd                      ! ptb <-- filtered ptn  
     213                  ptn(ji,jj,jk,jn) = pta(ji,jj,jk,jn)                      ! ptn <-- pta 
    236214               END DO 
    237215           END DO 
    … …  
    251229      !!  
    252230      !! ** Method  : - Apply a thickness weighted Asselin time filter on now fields. 
    253       !!              - save in (ta,sa) a thickness weighted average over the three  
    254       !!             time levels which will be used to compute rdn and thus the semi- 
    255       !!             implicit hydrostatic pressure gradient (ln_dynhpg_imp = T) 
    256231      !!              - swap tracer fields to prepare the next time_step. 
    257       !!                This can be summurized for tempearture as: 
    258       !!             ztm = ( e3t_n*tn + rbcp*[ e3t_b*tb - 2 e3t_n*tn + e3t_a*ta ] )   ln_dynhpg_imp = T 
    259       !!                  /( e3t_n    + rbcp*[ e3t_b    - 2 e3t_n    + e3t_a    ] )    
    260       !!             ztm = 0                                                       otherwise 
    261232      !!             tb  = ( e3t_n*tn + atfp*[ e3t_b*tb - 2 e3t_n*tn + e3t_a*ta ] ) 
    262233      !!                  /( e3t_n    + atfp*[ e3t_b    - 2 e3t_n    + e3t_a    ] ) 
    263234      !!             tn  = ta  
    264       !!             ta  = zt        (NB: reset to 0 after eos_bn2 call) 
    265       !! 
    266       !! ** Action  : - (tb,sb) and (tn,sn) ready for the next time step 
    267       !!              - (ta,sa) time averaged (t,s)   (ln_dynhpg_imp = T) 
    268       !!---------------------------------------------------------------------- 
    269       INTEGER         , INTENT(in   )                               ::  kt       ! ocean time-step index 
    270       INTEGER         , INTENT(in   )                               ::  kit000   ! first time step index 
    271       REAL(wp)        , INTENT(in   ), DIMENSION(jpk)               ::  p2dt     ! time-step 
    272       CHARACTER(len=3), INTENT(in   )                               ::  cdtype   ! =TRA or TRC (tracer indicator) 
    273       INTEGER         , INTENT(in   )                               ::  kjpt     ! number of tracers 
    274       REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::  ptb      ! before tracer fields 
    275       REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::  ptn      ! now tracer fields 
    276       REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::  pta      ! tracer trend 
    277       REAL(wp)        , INTENT(in   ), DIMENSION(jpi,jpj,kjpt)      ::  psbc_tc   ! surface tracer content 
    278       REAL(wp)        , INTENT(in   ), DIMENSION(jpi,jpj,kjpt)      ::  psbc_tc_b ! before surface tracer content 
    279  
    280       !!      
    281       LOGICAL  ::   ll_tra_hpg, ll_traqsr, ll_rnf   ! local logical 
     235      !! 
     236      !! ** Action  : - tsb & tsn ready for the next time step 
     237      !!---------------------------------------------------------------------- 
     238      INTEGER                              , INTENT(in   ) ::  kt        ! ocean time-step index 
     239      INTEGER                              , INTENT(in   ) ::  kit000    ! first time step index 
     240      REAL(wp)                             , INTENT(in   ) ::  p2dt      ! time-step 
     241      CHARACTER(len=3)                     , INTENT(in   ) ::  cdtype    ! =TRA or TRC (tracer indicator) 
     242      INTEGER                              , INTENT(in   ) ::  kjpt      ! number of tracers 
     243      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::  ptb       ! before tracer fields 
     244      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::  ptn       ! now tracer fields 
     245      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::  pta       ! tracer trend 
     246      REAL(wp), DIMENSION(jpi,jpj    ,kjpt), INTENT(in   ) ::  psbc_tc   ! surface tracer content 
     247      REAL(wp), DIMENSION(jpi,jpj    ,kjpt), INTENT(in   ) ::  psbc_tc_b ! before surface tracer content 
     248      ! 
     249      LOGICAL  ::   ll_traqsr, ll_rnf, ll_isf   ! local logical 
    282250      INTEGER  ::   ji, jj, jk, jn              ! dummy loop indices 
    283251      REAL(wp) ::   zfact1, ztc_a , ztc_n , ztc_b , ztc_f , ztc_d    ! local scalar 
    … …  
    292260      ! 
    293261      IF( cdtype == 'TRA' )  THEN    
    294          ll_tra_hpg = ln_dynhpg_imp    ! active  tracers case  and  semi-implicit hpg 
    295262         ll_traqsr  = ln_traqsr        ! active  tracers case  and  solar penetration 
    296263         ll_rnf     = ln_rnf           ! active  tracers case  and  river runoffs 
    297       ELSE                           
    298          ll_tra_hpg = .FALSE.          ! passive tracers case or NO semi-implicit hpg 
    299          ll_traqsr  = .FALSE.          ! active  tracers case and NO solar penetration 
    300          ll_rnf     = .FALSE.          ! passive tracers or NO river runoffs 
     264         ll_isf     = ln_isf           ! active  tracers case  and  ice shelf melting 
     265      ELSE                          ! passive tracers case 
     266         ll_traqsr  = .FALSE.          ! NO solar penetration 
     267         ll_rnf     = .FALSE.          ! NO river runoffs ????          !!gm BUG ?   
     268         ll_isf     = .FALSE.          ! NO ice shelf melting/freezing  !!gm BUG ??  
    301269      ENDIF 
    302270      ! 
    303271      DO jn = 1, kjpt       
    304272         DO jk = 1, jpkm1 
    305             zfact1 = atfp * p2dt(jk) 
    306             zfact2 = zfact1 / rau0 
    307             DO jj = 1, jpj 
    308                DO ji = 1, jpi 
    309                   ze3t_b = fse3t_b(ji,jj,jk) 
    310                   ze3t_n = fse3t_n(ji,jj,jk) 
    311                   ze3t_a = fse3t_a(ji,jj,jk) 
     273            zfact1 = atfp * p2dt 
     274            zfact2 = zfact1 * r1_rau0 
     275            DO jj = 2, jpjm1 
     276               DO ji = fs_2, fs_jpim1 
     277                  ze3t_b = e3t_b(ji,jj,jk) 
     278                  ze3t_n = e3t_n(ji,jj,jk) 
     279                  ze3t_a = e3t_a(ji,jj,jk) 
    312280                  !                                         ! tracer content at Before, now and after 
    313281                  ztc_b  = ptb(ji,jj,jk,jn) * ze3t_b 
    … …  
    321289                  ztc_f  = ztc_n  + atfp * ztc_d 
    322290                  ! 
    323                   IF( jk == 1 ) THEN           ! first level  
    324                      ze3t_f = ze3t_f - zfact2 * ( emp_b(ji,jj) - emp(ji,jj) + rnf(ji,jj) - rnf_b(ji,jj) ) 
     291                  IF( jk == mikt(ji,jj) ) THEN           ! first level  
     292                     ze3t_f = ze3t_f - zfact2 * ( (emp_b(ji,jj)    - emp(ji,jj)   )  & 
     293                            &                   - (rnf_b(ji,jj)    - rnf(ji,jj)   )  & 
     294                            &                   + (fwfisf_b(ji,jj) - fwfisf(ji,jj))  ) 
    325295                     ztc_f  = ztc_f  - zfact1 * ( psbc_tc(ji,jj,jn) - psbc_tc_b(ji,jj,jn) ) 
    326296                  ENDIF 
    327  
    328                   IF( ll_traqsr .AND. jn == jp_tem .AND. jk <= nksr )   &     ! solar penetration (temperature only) 
     297                  ! 
     298                  ! solar penetration (temperature only) 
     299                  IF( ll_traqsr .AND. jn == jp_tem .AND. jk <= nksr )                            &  
    329300                     &     ztc_f  = ztc_f  - zfact1 * ( qsr_hc(ji,jj,jk) - qsr_hc_b(ji,jj,jk) )  
    330  
    331                   IF( ll_rnf .AND. jk <= nk_rnf(ji,jj) )   &            ! river runoffs 
     301                     ! 
     302                  ! river runoff 
     303                  IF( ll_rnf .AND. jk <= nk_rnf(ji,jj) )                                          & 
    332304                     &     ztc_f  = ztc_f  - zfact1 * ( rnf_tsc(ji,jj,jn) - rnf_tsc_b(ji,jj,jn) ) &  
    333                      &                              * fse3t_n(ji,jj,jk) / h_rnf(ji,jj) 
    334  
     305                     &                              * e3t_n(ji,jj,jk) / h_rnf(ji,jj) 
     306                     ! 
     307                  ! ice shelf 
     308                  IF( ll_isf ) THEN 
     309                     ! level fully include in the Losch_2008 ice shelf boundary layer 
     310                     IF ( jk >= misfkt(ji,jj) .AND. jk < misfkb(ji,jj) )                          & 
     311                        ztc_f  = ztc_f  - zfact1 * ( risf_tsc(ji,jj,jn) - risf_tsc_b(ji,jj,jn) )  & 
     312                               &                 * e3t_n(ji,jj,jk) * r1_hisf_tbl (ji,jj) 
     313                     ! level partially include in Losch_2008 ice shelf boundary layer  
     314                     IF ( jk == misfkb(ji,jj) )                                                   & 
     315                        ztc_f  = ztc_f  - zfact1 * ( risf_tsc(ji,jj,jn) - risf_tsc_b(ji,jj,jn) )  & 
     316                               &                 * e3t_n(ji,jj,jk) * r1_hisf_tbl (ji,jj) * ralpha(ji,jj) 
     317                  END IF 
     318                  ! 
    335319                  ze3t_f = 1.e0 / ze3t_f 
    336320                  ptb(ji,jj,jk,jn) = ztc_f * ze3t_f       ! ptb <-- ptn filtered 
    337321                  ptn(ji,jj,jk,jn) = pta(ji,jj,jk,jn)     ! ptn <-- pta 
    338322                  ! 
    339                   IF( ll_tra_hpg ) THEN        ! semi-implicit hpg (T & S only) 
    340                      ze3t_d           = 1.e0   / ( ze3t_n + rbcp * ze3t_d ) 
    341                      pta(ji,jj,jk,jn) = ze3t_d * ( ztc_n  + rbcp * ztc_d  )   ! ta <-- Brown & Campana average 
    342                   ENDIF 
    343323               END DO 
    344324            END DO 

  • branches/NERC/dev_r5549_BDY_ZEROGRAD/NEMOGCM/NEMO/OPA_SRC/TRA/traqsr.F90

    r5407 r6808  
    22   !!====================================================================== 
    33   !!                       ***  MODULE  traqsr  *** 
    4    !! Ocean physics: solar radiation penetration in the top ocean levels 
     4   !! Ocean physics:   solar radiation penetration in the top ocean levels 
    55   !!====================================================================== 
    66   !! History :  OPA  !  1990-10  (B. Blanke)  Original code 
    … …  
    1010   !!             -   !  2005-11  (G. Madec) zco, zps, sco coordinate 
    1111   !!            3.2  !  2009-04  (G. Madec & NEMO team)  
    12    !!            4.0  !  2012-05  (C. Rousset) store attenuation coef for use in ice model  
     12   !!            3.6  !  2012-05  (C. Rousset) store attenuation coef for use in ice model  
     13   !!            3.7  !  2015-11  (G. Madec, A. Coward)  remove optimisation for fix volume  
    1314   !!---------------------------------------------------------------------- 
    1415 
    1516   !!---------------------------------------------------------------------- 
    16    !!   tra_qsr      : trend due to the solar radiation penetration 
    17    !!   tra_qsr_init : solar radiation penetration initialization 
     17   !!   tra_qsr       : temperature trend due to the penetration of solar radiation  
     18   !!   tra_qsr_init  : initialization of the qsr penetration  
    1819   !!---------------------------------------------------------------------- 
    19    USE oce             ! ocean dynamics and active tracers 
    20    USE dom_oce         ! ocean space and time domain 
    21    USE sbc_oce         ! surface boundary condition: ocean 
    22    USE trc_oce         ! share SMS/Ocean variables 
     20   USE oce            ! ocean dynamics and active tracers 
     21   USE phycst         ! physical constants 
     22   USE dom_oce        ! ocean space and time domain 
     23   USE sbc_oce        ! surface boundary condition: ocean 
     24   USE trc_oce        ! share SMS/Ocean variables 
    2325   USE trd_oce        ! trends: ocean variables 
    2426   USE trdtra         ! trends manager: tracers 
    25    USE in_out_manager  ! I/O manager 
    26    USE phycst          ! physical constants 
    27    USE prtctl          ! Print control 
    28    USE iom             ! I/O manager 
    29    USE fldread         ! read input fields 
    30    USE restart         ! ocean restart 
    31    USE lib_mpp         ! MPP library 
     27   ! 
     28   USE in_out_manager ! I/O manager 
     29   USE prtctl         ! Print control 
     30   USE iom            ! I/O manager 
     31   USE fldread        ! read input fields 
     32   USE restart        ! ocean restart 
     33   USE lib_mpp        ! MPP library 
     34   USE lbclnk         ! ocean lateral boundary conditions (or mpp link) 
    3235   USE wrk_nemo       ! Memory Allocation 
    3336   USE timing         ! Timing 
    … …  
    4952   REAL(wp), PUBLIC ::   rn_si0       !: very near surface depth of extinction      (RGB & 2 bands) 
    5053   REAL(wp), PUBLIC ::   rn_si1       !: deepest depth of extinction (water type I)       (2 bands) 
     54   ! 
     55   INTEGER , PUBLIC ::   nksr         !: levels below which the light cannot penetrate (depth larger than 391 m) 
    5156  
    52    ! Module variables 
    53    REAL(wp) ::   xsi0r                           !: inverse of rn_si0 
    54    REAL(wp) ::   xsi1r                           !: inverse of rn_si1 
     57   INTEGER, PARAMETER ::   np_RGB  = 1   ! R-G-B     light penetration with constant Chlorophyll 
     58   INTEGER, PARAMETER ::   np_RGBc = 2   ! R-G-B     light penetration with Chlorophyll data 
     59   INTEGER, PARAMETER ::   np_2BD  = 3   ! 2 bands   light penetration 
     60   INTEGER, PARAMETER ::   np_BIO  = 4   ! bio-model light penetration 
     61   ! 
     62   INTEGER  ::   nqsr    ! user choice of the type of light penetration 
     63   REAL(wp) ::   xsi0r   ! inverse of rn_si0 
     64   REAL(wp) ::   xsi1r   ! inverse of rn_si1 
     65   ! 
     66   REAL(wp) , DIMENSION(3,61)           ::   rkrgb    ! tabulated attenuation coefficients for RGB absorption 
    5567   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_chl   ! structure of input Chl (file informations, fields read) 
    56    INTEGER, PUBLIC ::   nksr              ! levels below which the light cannot penetrate ( depth larger than 391 m) 
    57    REAL(wp), DIMENSION(3,61) ::   rkrgb   !: tabulated attenuation coefficients for RGB absorption 
    5868 
    5969   !! * Substitutions 
    60 #  include "domzgr_substitute.h90" 
    6170#  include "vectopt_loop_substitute.h90" 
    6271   !!---------------------------------------------------------------------- 
    … …  
    7281      !! 
    7382      !! ** Purpose :   Compute the temperature trend due to the solar radiation 
    74       !!      penetration and add it to the general temperature trend. 
     83      !!              penetration and add it to the general temperature trend. 
    7584      !! 
    7685      !! ** Method  : The profile of the solar radiation within the ocean is defined 
    … …  
    8392      !!      all heat which has not been absorbed in the above levels is put 
    8493      !!      in the last ocean level. 
    85       !!         In z-coordinate case, the computation is only done down to the 
    86       !!      level where I(k) < 1.e-15 W/m2. In addition, the coefficients  
    87       !!      used for the computation are calculated one for once as they 
    88       !!      depends on k only. 
     94      !!         The computation is only done down to the level where  
     95      !!      I(k) < 1.e-15 W/m2 (i.e. over the top nksr levels) .  
    8996      !! 
    9097      !! ** Action  : - update ta with the penetrative solar radiation trend 
    91       !!              - save the trend in ttrd ('key_trdtra') 
     98      !!              - send  trend for further diagnostics (l_trdtra=T) 
    9299      !! 
    93100      !! Reference  : Jerlov, N. G., 1968 Optical Oceanography, Elsevier, 194pp. 
    94101      !!              Lengaigne et al. 2007, Clim. Dyn., V28, 5, 503-516. 
    95102      !!---------------------------------------------------------------------- 
    96       ! 
    97103      INTEGER, INTENT(in) ::   kt     ! ocean time-step 
    98104      ! 
    99       INTEGER  ::   ji, jj, jk           ! dummy loop indices 
    100       INTEGER  ::   irgb                 ! local integers 
    101       REAL(wp) ::   zchl, zcoef, zfact   ! local scalars 
    102       REAL(wp) ::   zc0, zc1, zc2, zc3   !    -         - 
     105      INTEGER  ::   ji, jj, jk               ! dummy loop indices 
     106      INTEGER  ::   irgb                     ! local integers 
     107      REAL(wp) ::   zchl, zcoef, z1_2        ! local scalars 
     108      REAL(wp) ::   zc0 , zc1 , zc2 , zc3    !    -         - 
    103109      REAL(wp) ::   zzc0, zzc1, zzc2, zzc3   !    -         - 
    104       REAL(wp) ::   zz0, zz1, z1_e3t     !    -         - 
    105       REAL(wp), POINTER, DIMENSION(:,:  ) :: zekb, zekg, zekr 
     110      REAL(wp) ::   zz0 , zz1                !    -         - 
     111      REAL(wp), POINTER, DIMENSION(:,:)  :: zekb, zekg, zekr 
    106112      REAL(wp), POINTER, DIMENSION(:,:,:) :: ze0, ze1, ze2, ze3, zea, ztrdt 
     113      REAL(wp), POINTER, DIMENSION(:,:,:) :: zetot 
    107114      !!---------------------------------------------------------------------- 
    108115      ! 
    109116      IF( nn_timing == 1 )  CALL timing_start('tra_qsr') 
    110       ! 
    111       CALL wrk_alloc( jpi, jpj,      zekb, zekg, zekr        )  
    112       CALL wrk_alloc( jpi, jpj, jpk, ze0, ze1, ze2, ze3, zea )  
    113117      ! 
    114118      IF( kt == nit000 ) THEN 
    … …  
    116120         IF(lwp) WRITE(numout,*) 'tra_qsr : penetration of the surface solar radiation' 
    117121         IF(lwp) WRITE(numout,*) '~~~~~~~' 
    118          IF( .NOT.ln_traqsr )   RETURN 
    119       ENDIF 
    120  
    121       IF( l_trdtra ) THEN      ! Save ta and sa trends 
    122          CALL wrk_alloc( jpi, jpj, jpk, ztrdt )  
     122      ENDIF 
     123      ! 
     124      IF( l_trdtra ) THEN      ! trends diagnostic: save the input temperature trend 
     125         CALL wrk_alloc( jpi,jpj,jpk,   ztrdt )  
    123126         ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 
    124127      ENDIF 
    125  
    126       !                                        Set before qsr tracer content field 
    127       !                                        *********************************** 
    128       IF( kt == nit000 ) THEN                     ! Set the forcing field at nit000 - 1 
    129          !                                        ! ----------------------------------- 
    130          qsr_hc(:,:,:) = 0.e0 
    131          ! 
    132          IF( ln_rstart .AND.    &                    ! Restart: read in restart file 
    133               & iom_varid( numror, 'qsr_hc_b', ldstop = .FALSE. ) > 0 ) THEN 
    134             IF(lwp) WRITE(numout,*) '          nit000-1 qsr tracer content forcing field red in the restart file' 
    135             zfact = 0.5e0 
     128      ! 
     129      !                         !-----------------------------------! 
     130      !                         !  before qsr induced heat content  ! 
     131      !                         !-----------------------------------! 
     132      IF( kt == nit000 ) THEN          !==  1st time step  ==! 
     133!!gm case neuler  not taken into account.... 
     134         IF( ln_rstart .AND. iom_varid( numror, 'qsr_hc_b', ldstop = .FALSE. ) > 0 ) THEN    ! read in restart 
     135            IF(lwp) WRITE(numout,*) '          nit000-1 qsr tracer content forcing field read in the restart file' 
     136            z1_2 = 0.5_wp 
    136137            CALL iom_get( numror, jpdom_autoglo, 'qsr_hc_b', qsr_hc_b )   ! before heat content trend due to Qsr flux 
    137138         ELSE                                           ! No restart or restart not found: Euler forward time stepping 
    138             zfact = 1.e0 
    139             qsr_hc_b(:,:,:) = 0.e0 
     139            z1_2 = 1._wp 
     140            qsr_hc_b(:,:,:) = 0._wp 
    140141         ENDIF 
    141       ELSE                                        ! Swap of forcing field 
    142          !                                        ! --------------------- 
    143          zfact = 0.5e0 
     142      ELSE                             !==  Swap of qsr heat content  ==! 
     143         z1_2 = 0.5_wp 
    144144         qsr_hc_b(:,:,:) = qsr_hc(:,:,:) 
    145145      ENDIF 
    146       !                                        Compute now qsr tracer content field 
    147       !                                        ************************************ 
    148        
    149       !                                           ! ============================================== ! 
    150       IF( lk_qsr_bio .AND. ln_qsr_bio ) THEN      !  bio-model fluxes  : all vertical coordinates  ! 
    151          !                                        ! ============================================== ! 
    152          DO jk = 1, jpkm1 
     146      ! 
     147      !                         !--------------------------------! 
     148      SELECT CASE( nqsr )       !  now qsr induced heat content  ! 
     149      !                         !--------------------------------! 
     150      ! 
     151      CASE( np_BIO )                   !==  bio-model fluxes  ==! 
     152         ! 
     153         DO jk = 1, nksr 
    153154            qsr_hc(:,:,jk) = r1_rau0_rcp * ( etot3(:,:,jk) - etot3(:,:,jk+1) ) 
    154155         END DO 
    155          !                                        Add to the general trend 
    156          DO jk = 1, jpkm1 
    157             DO jj = 2, jpjm1  
    158                DO ji = fs_2, fs_jpim1   ! vector opt. 
    159                   z1_e3t = zfact / fse3t(ji,jj,jk) 
    160                   tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) + ( qsr_hc_b(ji,jj,jk) + qsr_hc(ji,jj,jk) ) * z1_e3t 
     156         ! 
     157      CASE( np_RGB , np_RGBc )         !==  R-G-B fluxes  ==! 
     158         ! 
     159         CALL wrk_alloc( jpi,jpj,       zekb, zekg, zekr        )  
     160         CALL wrk_alloc( jpi,jpj,jpk,   ze0, ze1, ze2, ze3, zea )  
     161         ! 
     162         IF( nqsr == np_RGBc ) THEN          !*  Variable Chlorophyll 
     163            CALL fld_read( kt, 1, sf_chl )         ! Read Chl data and provides it at the current time step 
     164            DO jj = 2, jpjm1                       ! Separation in R-G-B depending of the surface Chl 
     165               DO ji = fs_2, fs_jpim1 
     166                  zchl = MIN( 10. , MAX( 0.03, sf_chl(1)%fnow(ji,jj,1) ) ) 
     167                  irgb = NINT( 41 + 20.*LOG10(zchl) + 1.e-15 ) 
     168                  zekb(ji,jj) = rkrgb(1,irgb) 
     169                  zekg(ji,jj) = rkrgb(2,irgb) 
     170                  zekr(ji,jj) = rkrgb(3,irgb) 
    161171               END DO 
    162172            END DO 
    163          END DO 
    164          CALL iom_put( 'qsr3d', etot3 )   ! Shortwave Radiation 3D distribution 
    165          ! clem: store attenuation coefficient of the first ocean level 
    166          IF ( ln_qsr_ice ) THEN 
    167             DO jj = 1, jpj 
    168                DO ji = 1, jpi 
    169                   IF ( qsr(ji,jj) /= 0._wp ) THEN 
    170                      fraqsr_1lev(ji,jj) = ( qsr_hc(ji,jj,1) / ( r1_rau0_rcp * qsr(ji,jj) ) ) 
    171                   ELSE 
    172                      fraqsr_1lev(ji,jj) = 1. 
    173                   ENDIF 
     173         ELSE                                !* constant chrlorophyll 
     174            zchl = 0.05                            ! constant chlorophyll 
     175            !                                      ! Separation in R-G-B depending of the chlorophyll 
     176            irgb = NINT( 41 + 20.*LOG10( zchl ) + 1.e-15 ) 
     177            DO jj = 2, jpjm1 
     178               DO ji = fs_2, fs_jpim1 
     179                  zekb(ji,jj) = rkrgb(1,irgb)                       
     180                  zekg(ji,jj) = rkrgb(2,irgb) 
     181                  zekr(ji,jj) = rkrgb(3,irgb) 
    174182               END DO 
    175183            END DO 
    176184         ENDIF 
    177          !                                        ! ============================================== ! 
    178       ELSE                                        !  Ocean alone :  
    179          !                                        ! ============================================== ! 
    180          ! 
    181          !                                                ! ------------------------- ! 
    182          IF( ln_qsr_rgb) THEN                             !  R-G-B  light penetration ! 
    183             !                                             ! ------------------------- ! 
    184             ! Set chlorophyl concentration 
    185             IF( nn_chldta == 1 .OR. lk_vvl ) THEN            !*  Variable Chlorophyll or ocean volume 
    186                ! 
    187                IF( nn_chldta == 1 ) THEN                             !*  Variable Chlorophyll 
    188                   ! 
    189                   CALL fld_read( kt, 1, sf_chl )                         ! Read Chl data and provides it at the current time step 
    190                   !          
    191 !CDIR COLLAPSE 
    192 !CDIR NOVERRCHK 
    193                   DO jj = 1, jpj                                         ! Separation in R-G-B depending of the surface Chl 
    194 !CDIR NOVERRCHK 
    195                      DO ji = 1, jpi 
    196                         zchl = MIN( 10. , MAX( 0.03, sf_chl(1)%fnow(ji,jj,1) ) ) 
    197                         irgb = NINT( 41 + 20.*LOG10(zchl) + 1.e-15 ) 
    198                         zekb(ji,jj) = rkrgb(1,irgb) 
    199                         zekg(ji,jj) = rkrgb(2,irgb) 
    200                         zekr(ji,jj) = rkrgb(3,irgb) 
    201                      END DO 
    202                   END DO 
    203                ELSE                                            ! Variable ocean volume but constant chrlorophyll 
    204                   zchl = 0.05                                     ! constant chlorophyll 
    205                   irgb = NINT( 41 + 20.*LOG10( zchl ) + 1.e-15 ) 
    206                   zekb(:,:) = rkrgb(1,irgb)                       ! Separation in R-G-B depending of the chlorophyll  
    207                   zekg(:,:) = rkrgb(2,irgb) 
    208                   zekr(:,:) = rkrgb(3,irgb) 
     185         ! 
     186         zcoef  = ( 1. - rn_abs ) / 3._wp    !* surface equi-partition in R-G-B 
     187         DO jj = 2, jpjm1 
     188            DO ji = fs_2, fs_jpim1 
     189               ze0(ji,jj,1) = rn_abs * qsr(ji,jj) 
     190               ze1(ji,jj,1) = zcoef  * qsr(ji,jj) 
     191               ze2(ji,jj,1) = zcoef  * qsr(ji,jj) 
     192               ze3(ji,jj,1) = zcoef  * qsr(ji,jj) 
     193               zea(ji,jj,1) =          qsr(ji,jj) 
     194            END DO 
     195         END DO 
     196         ! 
     197         DO jk = 2, nksr+1                   !* interior equi-partition in R-G-B 
     198            DO jj = 2, jpjm1 
     199               DO ji = fs_2, fs_jpim1 
     200                  zc0 = ze0(ji,jj,jk-1) * EXP( - e3t_n(ji,jj,jk-1) * xsi0r       ) 
     201                  zc1 = ze1(ji,jj,jk-1) * EXP( - e3t_n(ji,jj,jk-1) * zekb(ji,jj) ) 
     202                  zc2 = ze2(ji,jj,jk-1) * EXP( - e3t_n(ji,jj,jk-1) * zekg(ji,jj) ) 
     203                  zc3 = ze3(ji,jj,jk-1) * EXP( - e3t_n(ji,jj,jk-1) * zekr(ji,jj) ) 
     204                  ze0(ji,jj,jk) = zc0 
     205                  ze1(ji,jj,jk) = zc1 
     206                  ze2(ji,jj,jk) = zc2 
     207                  ze3(ji,jj,jk) = zc3 
     208                  zea(ji,jj,jk) = ( zc0 + zc1 + zc2 + zc3 ) * wmask(ji,jj,jk) 
     209               END DO 
     210            END DO 
     211         END DO 
     212         ! 
     213         DO jk = 1, nksr                     !* now qsr induced heat content 
     214            DO jj = 2, jpjm1 
     215               DO ji = fs_2, fs_jpim1 
     216                  qsr_hc(ji,jj,jk) = r1_rau0_rcp * ( zea(ji,jj,jk) - zea(ji,jj,jk+1) ) 
     217               END DO 
     218            END DO 
     219         END DO 
     220         ! 
     221         CALL wrk_dealloc( jpi,jpj,        zekb, zekg, zekr        )  
     222         CALL wrk_dealloc( jpi,jpj,jpk,   ze0, ze1, ze2, ze3, zea )  
     223         ! 
     224      CASE( np_2BD  )            !==  2-bands fluxes  ==! 
     225         ! 
     226         zz0 =        rn_abs   * r1_rau0_rcp      ! surface equi-partition in 2-bands 
     227         zz1 = ( 1. - rn_abs ) * r1_rau0_rcp 
     228         DO jk = 1, nksr                          ! solar heat absorbed at T-point in the top 400m  
     229            DO jj = 2, jpjm1 
     230               DO ji = fs_2, fs_jpim1 
     231                  zc0 = zz0 * EXP( -gdepw_n(ji,jj,jk  )*xsi0r ) + zz1 * EXP( -gdepw_n(ji,jj,jk  )*xsi1r ) 
     232                  zc1 = zz0 * EXP( -gdepw_n(ji,jj,jk+1)*xsi0r ) + zz1 * EXP( -gdepw_n(ji,jj,jk+1)*xsi1r ) 
     233                  qsr_hc(ji,jj,jk) = qsr(ji,jj) * ( zc0 * wmask(ji,jj,jk) - zc1 * wmask(ji,jj,jk+1) )  
     234               END DO 
     235            END DO 
     236         END DO 
     237         ! 
     238      END SELECT 
     239      ! 
     240      !                          !-----------------------------! 
     241      DO jk = 1, nksr            !  update to the temp. trend  ! 
     242         DO jj = 2, jpjm1        !-----------------------------! 
     243            DO ji = fs_2, fs_jpim1   ! vector opt. 
     244               tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem)   & 
     245                  &                 + z1_2 * ( qsr_hc_b(ji,jj,jk) + qsr_hc(ji,jj,jk) ) / e3t_n(ji,jj,jk) 
     246            END DO 
     247         END DO 
     248      END DO 
     249      ! 
     250      IF( ln_qsr_ice ) THEN      ! sea-ice: store the 1st ocean level attenuation coefficient 
     251         DO jj = 2, jpjm1  
     252            DO ji = fs_2, fs_jpim1   ! vector opt. 
     253               IF( qsr(ji,jj) /= 0._wp ) THEN   ;   fraqsr_1lev(ji,jj) = qsr_hc(ji,jj,1) / ( r1_rau0_rcp * qsr(ji,jj) ) 
     254               ELSE                             ;   fraqsr_1lev(ji,jj) = 1._wp 
    209255               ENDIF 
    210                ! 
    211                zcoef  = ( 1. - rn_abs ) / 3.e0                        ! equi-partition in R-G-B 
    212                ze0(:,:,1) = rn_abs  * qsr(:,:) 
    213                ze1(:,:,1) = zcoef * qsr(:,:) 
    214                ze2(:,:,1) = zcoef * qsr(:,:) 
    215                ze3(:,:,1) = zcoef * qsr(:,:) 
    216                zea(:,:,1) =         qsr(:,:) 
    217                ! 
    218                DO jk = 2, nksr+1 
    219 !CDIR NOVERRCHK 
    220                   DO jj = 1, jpj 
    221 !CDIR NOVERRCHK    
    222                      DO ji = 1, jpi 
    223                         zc0 = ze0(ji,jj,jk-1) * EXP( - fse3t(ji,jj,jk-1) * xsi0r     ) 
    224                         zc1 = ze1(ji,jj,jk-1) * EXP( - fse3t(ji,jj,jk-1) * zekb(ji,jj) ) 
    225                         zc2 = ze2(ji,jj,jk-1) * EXP( - fse3t(ji,jj,jk-1) * zekg(ji,jj) ) 
    226                         zc3 = ze3(ji,jj,jk-1) * EXP( - fse3t(ji,jj,jk-1) * zekr(ji,jj) ) 
    227                         ze0(ji,jj,jk) = zc0 
    228                         ze1(ji,jj,jk) = zc1 
    229                         ze2(ji,jj,jk) = zc2 
    230                         ze3(ji,jj,jk) = zc3 
    231                         zea(ji,jj,jk) = ( zc0 + zc1 + zc2 + zc3 ) * tmask(ji,jj,jk) 
    232                      END DO 
    233                   END DO 
    234                END DO 
    235                ! clem: store attenuation coefficient of the first ocean level 
    236                IF ( ln_qsr_ice ) THEN 
    237                   DO jj = 1, jpj 
    238                      DO ji = 1, jpi 
    239                         zzc0 = rn_abs * EXP( - fse3t(ji,jj,1) * xsi0r     ) 
    240                         zzc1 = zcoef  * EXP( - fse3t(ji,jj,1) * zekb(ji,jj) ) 
    241                         zzc2 = zcoef  * EXP( - fse3t(ji,jj,1) * zekg(ji,jj) ) 
    242                         zzc3 = zcoef  * EXP( - fse3t(ji,jj,1) * zekr(ji,jj) ) 
    243                         fraqsr_1lev(ji,jj) = 1.0 - ( zzc0 + zzc1 + zzc2  + zzc3  ) * tmask(ji,jj,2)  
    244                      END DO 
    245                   END DO 
    246                ENDIF 
    247                ! 
    248                DO jk = 1, nksr                                        ! compute and add qsr trend to ta 
    249                   qsr_hc(:,:,jk) = r1_rau0_rcp * ( zea(:,:,jk) - zea(:,:,jk+1) ) 
    250                END DO 
    251                zea(:,:,nksr+1:jpk) = 0.e0     ! below 400m set to zero 
    252                CALL iom_put( 'qsr3d', zea )   ! Shortwave Radiation 3D distribution 
    253                ! 
    254             ELSE                                                 !*  Constant Chlorophyll 
    255                DO jk = 1, nksr 
    256                   qsr_hc(:,:,jk) =  etot3(:,:,jk) * qsr(:,:) 
    257                END DO 
    258                ! clem: store attenuation coefficient of the first ocean level 
    259                IF ( ln_qsr_ice ) THEN 
    260                   fraqsr_1lev(:,:) = etot3(:,:,1) / r1_rau0_rcp 
    261                ENDIF 
    262            ENDIF 
    263  
    264          ENDIF 
    265          !                                                ! ------------------------- ! 
    266          IF( ln_qsr_2bd ) THEN                            !  2 band light penetration ! 
    267             !                                             ! ------------------------- ! 
    268             ! 
    269             IF( lk_vvl ) THEN                                  !* variable volume 
    270                zz0   =        rn_abs   * r1_rau0_rcp 
    271                zz1   = ( 1. - rn_abs ) * r1_rau0_rcp 
    272                DO jk = 1, nksr                    ! solar heat absorbed at T-point in the top 400m  
    273                   DO jj = 1, jpj 
    274                      DO ji = 1, jpi 
    275                         zc0 = zz0 * EXP( -fsdepw(ji,jj,jk  )*xsi0r ) + zz1 * EXP( -fsdepw(ji,jj,jk  )*xsi1r ) 
    276                         zc1 = zz0 * EXP( -fsdepw(ji,jj,jk+1)*xsi0r ) + zz1 * EXP( -fsdepw(ji,jj,jk+1)*xsi1r ) 
    277                         qsr_hc(ji,jj,jk) = qsr(ji,jj) * ( zc0*tmask(ji,jj,jk) - zc1*tmask(ji,jj,jk+1) )  
    278                      END DO 
    279                   END DO 
    280                END DO 
    281                ! clem: store attenuation coefficient of the first ocean level 
    282                IF ( ln_qsr_ice ) THEN 
    283                   DO jj = 1, jpj 
    284                      DO ji = 1, jpi 
    285                         zc0 = zz0 * EXP( -fsdepw(ji,jj,1)*xsi0r ) + zz1 * EXP( -fsdepw(ji,jj,1)*xsi1r ) 
    286                         zc1 = zz0 * EXP( -fsdepw(ji,jj,2)*xsi0r ) + zz1 * EXP( -fsdepw(ji,jj,2)*xsi1r ) 
    287                         fraqsr_1lev(ji,jj) = ( zc0*tmask(ji,jj,1) - zc1*tmask(ji,jj,2) ) / r1_rau0_rcp 
    288                      END DO 
    289                   END DO 
    290                ENDIF 
    291             ELSE                                               !* constant volume: coef. computed one for all 
    292                DO jk = 1, nksr 
    293                   DO jj = 2, jpjm1 
    294                      DO ji = fs_2, fs_jpim1   ! vector opt. 
    295                         ! (ISF) no light penetration below the ice shelves          
    296                         qsr_hc(ji,jj,jk) =  etot3(ji,jj,jk) * qsr(ji,jj) * tmask(ji,jj,1) 
    297                      END DO 
    298                   END DO 
    299                END DO 
    300                ! clem: store attenuation coefficient of the first ocean level 
    301                IF ( ln_qsr_ice ) THEN 
    302                   fraqsr_1lev(:,:) = etot3(:,:,1) / r1_rau0_rcp 
    303                ENDIF 
    304                ! 
    305             ENDIF 
    306             ! 
    307          ENDIF 
    308          ! 
    309          !                                        Add to the general trend 
    310          DO jk = 1, nksr 
    311             DO jj = 2, jpjm1  
    312                DO ji = fs_2, fs_jpim1   ! vector opt. 
    313                   z1_e3t = zfact / fse3t(ji,jj,jk) 
    314                   tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) + ( qsr_hc_b(ji,jj,jk) + qsr_hc(ji,jj,jk) ) * z1_e3t 
    315                END DO 
    316             END DO 
    317          END DO 
    318          ! 
    319       ENDIF 
    320       ! 
    321       IF( lrst_oce ) THEN   !                  Write in the ocean restart file 
    322          !                                     ******************************* 
    323          IF(lwp) WRITE(numout,*) 
    324          IF(lwp) WRITE(numout,*) 'qsr tracer content forcing field written in ocean restart file ',   & 
    325             &                    'at it= ', kt,' date= ', ndastp 
    326          IF(lwp) WRITE(numout,*) '~~~~' 
     256            END DO 
     257         END DO 
     258         ! Update haloes since lim_thd needs fraqsr_1lev to be defined everywhere 
     259         CALL lbc_lnk( fraqsr_1lev(:,:), 'T', 1._wp ) 
     260      ENDIF 
     261      ! 
     262      IF( iom_use('qsr3d') ) THEN      ! output the shortwave Radiation distribution 
     263         CALL wrk_alloc( jpi,jpj,jpk,   zetot ) 
     264         ! 
     265         zetot(:,:,nksr+1:jpk) = 0._wp     ! below ~400m set to zero 
     266         DO jk = nksr, 1, -1 
     267            zetot(:,:,jk) = zetot(:,:,jk+1) + qsr_hc(:,:,jk) / r1_rau0_rcp 
     268         END DO          
     269         CALL iom_put( 'qsr3d', zetot )   ! 3D distribution of shortwave Radiation 
     270         ! 
     271         CALL wrk_dealloc( jpi,jpj,jpk,   zetot )  
     272      ENDIF 
     273      ! 
     274      IF( lrst_oce ) THEN     ! write in the ocean restart file 
    327275         CALL iom_rstput( kt, nitrst, numrow, 'qsr_hc_b'   , qsr_hc      ) 
    328          CALL iom_rstput( kt, nitrst, numrow, 'fraqsr_1lev', fraqsr_1lev )   ! default definition in sbcssm  
    329          ! 
    330       ENDIF 
    331  
     276         CALL iom_rstput( kt, nitrst, numrow, 'fraqsr_1lev', fraqsr_1lev )  
     277      ENDIF 
     278      ! 
    332279      IF( l_trdtra ) THEN     ! qsr tracers trends saved for diagnostics 
    333280         ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 
    334281         CALL trd_tra( kt, 'TRA', jp_tem, jptra_qsr, ztrdt ) 
    335          CALL wrk_dealloc( jpi, jpj, jpk, ztrdt )  
     282         CALL wrk_dealloc( jpi,jpj,jpk,  ztrdt )  
    336283      ENDIF 
    337284      !                       ! print mean trends (used for debugging) 
    338285      IF(ln_ctl)   CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' qsr  - Ta: ', mask1=tmask, clinfo3='tra-ta' ) 
    339       ! 
    340       CALL wrk_dealloc( jpi, jpj,      zekb, zekg, zekr        )  
    341       CALL wrk_dealloc( jpi, jpj, jpk, ze0, ze1, ze2, ze3, zea )  
    342286      ! 
    343287      IF( nn_timing == 1 )  CALL timing_stop('tra_qsr') 
    … …  
    363307      !! Reference : Jerlov, N. G., 1968 Optical Oceanography, Elsevier, 194pp. 
    364308      !!---------------------------------------------------------------------- 
    365       ! 
    366       INTEGER  ::   ji, jj, jk                   ! dummy loop indices 
    367       INTEGER  ::   irgb, ierror, ioptio, nqsr   ! local integer 
    368       INTEGER  ::   ios                          ! Local integer output status for namelist read 
    369       REAL(wp) ::   zz0, zc0  , zc1, zcoef       ! local scalars 
    370       REAL(wp) ::   zz1, zc2  , zc3, zchl        !   -      - 
    371       REAL(wp), POINTER, DIMENSION(:,:  ) :: zekb, zekg, zekr 
    372       REAL(wp), POINTER, DIMENSION(:,:,:) :: ze0, ze1, ze2, ze3, zea 
     309      INTEGER  ::   ji, jj, jk                  ! dummy loop indices 
     310      INTEGER  ::   ios, irgb, ierror, ioptio   ! local integer 
     311      REAL(wp) ::   zz0, zc0 , zc1, zcoef      ! local scalars 
     312      REAL(wp) ::   zz1, zc2 , zc3, zchl       !   -      - 
    373313      ! 
    374314      CHARACTER(len=100) ::   cn_dir   ! Root directory for location of ssr files 
    375315      TYPE(FLD_N)        ::   sn_chl   ! informations about the chlorofyl field to be read 
    376316      !! 
    377       NAMELIST/namtra_qsr/  sn_chl, cn_dir, ln_traqsr, ln_qsr_rgb, ln_qsr_2bd, ln_qsr_bio, ln_qsr_ice,  & 
     317      NAMELIST/namtra_qsr/  sn_chl, cn_dir, ln_qsr_rgb, ln_qsr_2bd, ln_qsr_bio, ln_qsr_ice,  & 
    378318         &                  nn_chldta, rn_abs, rn_si0, rn_si1 
    379319      !!---------------------------------------------------------------------- 
    380  
    381       ! 
    382       IF( nn_timing == 1 )  CALL timing_start('tra_qsr_init') 
    383       ! 
    384       CALL wrk_alloc( jpi, jpj,      zekb, zekg, zekr        )  
    385       CALL wrk_alloc( jpi, jpj, jpk, ze0, ze1, ze2, ze3, zea )  
    386       ! 
    387  
    388       REWIND( numnam_ref )              ! Namelist namtra_qsr in reference namelist : Ratio and length of penetration 
     320      ! 
     321      IF( nn_timing == 1 )   CALL timing_start('tra_qsr_init') 
     322      ! 
     323      REWIND( numnam_ref )              ! Namelist namtra_qsr in reference     namelist 
    389324      READ  ( numnam_ref, namtra_qsr, IOSTAT = ios, ERR = 901) 
    390 901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_qsr in reference namelist', lwp ) 
    391  
    392       REWIND( numnam_cfg )              !  Namelist namtra_qsr in configuration namelist : Ratio and length of penetration 
     325901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtra_qsr in reference namelist', lwp ) 
     326      ! 
     327      REWIND( numnam_cfg )              ! Namelist namtra_qsr in configuration namelist 
    393328      READ  ( numnam_cfg, namtra_qsr, IOSTAT = ios, ERR = 902 ) 
    394 902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_qsr in configuration namelist', lwp ) 
     329902   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtra_qsr in configuration namelist', lwp ) 
    395330      IF(lwm) WRITE ( numond, namtra_qsr ) 
    396331      ! 
    … …  
    400335         WRITE(numout,*) '~~~~~~~~~~~~' 
    401336         WRITE(numout,*) '   Namelist namtra_qsr : set the parameter of penetration' 
    402          WRITE(numout,*) '      Light penetration (T) or not (F)         ln_traqsr  = ', ln_traqsr 
    403          WRITE(numout,*) '      RGB (Red-Green-Blue) light penetration   ln_qsr_rgb = ', ln_qsr_rgb 
    404          WRITE(numout,*) '      2 band               light penetration   ln_qsr_2bd = ', ln_qsr_2bd 
    405          WRITE(numout,*) '      bio-model            light penetration   ln_qsr_bio = ', ln_qsr_bio 
    406          WRITE(numout,*) '      light penetration for ice-model LIM3     ln_qsr_ice = ', ln_qsr_ice 
    407          WRITE(numout,*) '      RGB : Chl data (=1) or cst value (=0)    nn_chldta  = ', nn_chldta 
    408          WRITE(numout,*) '      RGB & 2 bands: fraction of light (rn_si1)    rn_abs = ', rn_abs 
    409          WRITE(numout,*) '      RGB & 2 bands: shortess depth of extinction  rn_si0 = ', rn_si0 
    410          WRITE(numout,*) '      2 bands: longest depth of extinction         rn_si1 = ', rn_si1 
    411       ENDIF 
    412  
    413       IF( ln_traqsr ) THEN     ! control consistency 
    414          !                       
    415          IF( .NOT.lk_qsr_bio .AND. ln_qsr_bio )   THEN 
    416             CALL ctl_warn( 'No bio model : force ln_qsr_bio = FALSE ' ) 
    417             ln_qsr_bio = .FALSE. 
     337         WRITE(numout,*) '      RGB (Red-Green-Blue) light penetration       ln_qsr_rgb = ', ln_qsr_rgb 
     338         WRITE(numout,*) '      2 band               light penetration       ln_qsr_2bd = ', ln_qsr_2bd 
     339         WRITE(numout,*) '      bio-model            light penetration       ln_qsr_bio = ', ln_qsr_bio 
     340         WRITE(numout,*) '      light penetration for ice-model (LIM3)       ln_qsr_ice = ', ln_qsr_ice 
     341         WRITE(numout,*) '      RGB : Chl data (=1) or cst value (=0)        nn_chldta  = ', nn_chldta 
     342         WRITE(numout,*) '      RGB & 2 bands: fraction of light (rn_si1)    rn_abs     = ', rn_abs 
     343         WRITE(numout,*) '      RGB & 2 bands: shortess depth of extinction  rn_si0     = ', rn_si0 
     344         WRITE(numout,*) '      2 bands: longest depth of extinction         rn_si1     = ', rn_si1 
     345         WRITE(numout,*) 
     346      ENDIF 
     347      ! 
     348      ioptio = 0                    ! Parameter control 
     349      IF( ln_qsr_rgb  )   ioptio = ioptio + 1 
     350      IF( ln_qsr_2bd  )   ioptio = ioptio + 1 
     351      IF( ln_qsr_bio  )   ioptio = ioptio + 1 
     352      ! 
     353      IF( ioptio /= 1 )   CALL ctl_stop( 'Choose ONE type of light penetration in namelist namtra_qsr',  & 
     354         &                               ' 2 bands, 3 RGB bands or bio-model light penetration' ) 
     355      ! 
     356      IF( ln_qsr_rgb .AND. nn_chldta == 0 )   nqsr = np_RGB  
     357      IF( ln_qsr_rgb .AND. nn_chldta == 1 )   nqsr = np_RGBc 
     358      IF( ln_qsr_2bd                      )   nqsr = np_2BD 
     359      IF( ln_qsr_bio                      )   nqsr = np_BIO 
     360      ! 
     361      !                             ! Initialisation 
     362      xsi0r = 1._wp / rn_si0 
     363      xsi1r = 1._wp / rn_si1 
     364      ! 
     365      SELECT CASE( nqsr ) 
     366      !                                
     367      CASE( np_RGB , np_RGBc )         !==  Red-Green-Blue light penetration  ==! 
     368         !                              
     369         IF(lwp)   WRITE(numout,*) '   R-G-B   light penetration ' 
     370         ! 
     371         CALL trc_oce_rgb( rkrgb )                 ! tabulated attenuation coef. 
     372         !                                    
     373         nksr = trc_oce_ext_lev( r_si2, 33._wp )   ! level of light extinction 
     374         ! 
     375         IF(lwp) WRITE(numout,*) '        level of light extinction = ', nksr, ' ref depth = ', gdepw_1d(nksr+1), ' m' 
     376         ! 
     377         IF( nqsr == np_RGBc ) THEN                ! Chl data : set sf_chl structure 
     378            IF(lwp) WRITE(numout,*) '        Chlorophyll read in a file' 
     379            ALLOCATE( sf_chl(1), STAT=ierror ) 
     380            IF( ierror > 0 ) THEN 
     381               CALL ctl_stop( 'tra_qsr_init: unable to allocate sf_chl structure' )   ;   RETURN 
     382            ENDIF 
     383            ALLOCATE( sf_chl(1)%fnow(jpi,jpj,1)   ) 
     384            IF( sn_chl%ln_tint )   ALLOCATE( sf_chl(1)%fdta(jpi,jpj,1,2) ) 
     385            !                                        ! fill sf_chl with sn_chl and control print 
     386            CALL fld_fill( sf_chl, (/ sn_chl /), cn_dir, 'tra_qsr_init',   & 
     387               &           'Solar penetration function of read chlorophyll', 'namtra_qsr' ) 
    418388         ENDIF 
    419          ! 
    420          ioptio = 0                      ! Parameter control 
    421          IF( ln_qsr_rgb  )   ioptio = ioptio + 1 
    422          IF( ln_qsr_2bd  )   ioptio = ioptio + 1 
    423          IF( ln_qsr_bio  )   ioptio = ioptio + 1 
    424          ! 
    425          IF( ioptio /= 1 ) & 
    426             CALL ctl_stop( '          Choose ONE type of light penetration in namelist namtra_qsr',  & 
    427             &              ' 2 bands, 3 RGB bands or bio-model light penetration' ) 
    428          ! 
    429          IF( ln_qsr_rgb .AND. nn_chldta == 0 )   nqsr =  1  
    430          IF( ln_qsr_rgb .AND. nn_chldta == 1 )   nqsr =  2 
    431          IF( ln_qsr_2bd                      )   nqsr =  3 
    432          IF( ln_qsr_bio                      )   nqsr =  4 
    433          ! 
    434          IF(lwp) THEN                   ! Print the choice 
    435             WRITE(numout,*) 
    436             IF( nqsr ==  1 )   WRITE(numout,*) '         R-G-B   light penetration - Constant Chlorophyll' 
    437             IF( nqsr ==  2 )   WRITE(numout,*) '         R-G-B   light penetration - Chl data ' 
    438             IF( nqsr ==  3 )   WRITE(numout,*) '         2 bands light penetration' 
    439             IF( nqsr ==  4 )   WRITE(numout,*) '         bio-model light penetration' 
     389         IF( nqsr == np_RGB ) THEN                 ! constant Chl 
     390            IF(lwp) WRITE(numout,*) '        Constant Chlorophyll concentration = 0.05' 
    440391         ENDIF 
    441392         ! 
    442       ENDIF 
    443       !                          ! ===================================== ! 
    444       IF( ln_traqsr  ) THEN      !  Initialisation of Light Penetration  !   
    445          !                       ! ===================================== ! 
    446          ! 
    447          xsi0r = 1.e0 / rn_si0 
    448          xsi1r = 1.e0 / rn_si1 
    449          !                                ! ---------------------------------- ! 
    450          IF( ln_qsr_rgb ) THEN            !  Red-Green-Blue light penetration  ! 
    451             !                             ! ---------------------------------- ! 
    452             ! 
    453             CALL trc_oce_rgb( rkrgb )           !* tabulated attenuation coef. 
    454             ! 
    455             !                                   !* level of light extinction 
    456             IF(  ln_sco ) THEN   ;   nksr = jpkm1 
    457             ELSE                 ;   nksr = trc_oce_ext_lev( r_si2, 0.33e2 ) 
    458             ENDIF 
    459  
    460             IF(lwp) WRITE(numout,*) '        level of light extinction = ', nksr, ' ref depth = ', gdepw_1d(nksr+1), ' m' 
    461             ! 
    462             IF( nn_chldta == 1 ) THEN           !* Chl data : set sf_chl structure 
    463                IF(lwp) WRITE(numout,*) 
    464                IF(lwp) WRITE(numout,*) '        Chlorophyll read in a file' 
    465                ALLOCATE( sf_chl(1), STAT=ierror ) 
    466                IF( ierror > 0 ) THEN 
    467                   CALL ctl_stop( 'tra_qsr_init: unable to allocate sf_chl structure' )   ;   RETURN 
    468                ENDIF 
    469                ALLOCATE( sf_chl(1)%fnow(jpi,jpj,1)   ) 
    470                IF( sn_chl%ln_tint )ALLOCATE( sf_chl(1)%fdta(jpi,jpj,1,2) ) 
    471                !                                        ! fill sf_chl with sn_chl and control print 
    472                CALL fld_fill( sf_chl, (/ sn_chl /), cn_dir, 'tra_qsr_init',   & 
    473                   &                                         'Solar penetration function of read chlorophyll', 'namtra_qsr' ) 
    474                ! 
    475             ELSE                                !* constant Chl : compute once for all the distribution of light (etot3) 
    476                IF(lwp) WRITE(numout,*) 
    477                IF(lwp) WRITE(numout,*) '        Constant Chlorophyll concentration = 0.05' 
    478                IF( lk_vvl ) THEN                   ! variable volume 
    479                   IF(lwp) WRITE(numout,*) '        key_vvl: light distribution will be computed at each time step' 
    480                ELSE                                ! constant volume: computes one for all 
    481                   IF(lwp) WRITE(numout,*) '        fixed volume: light distribution computed one for all' 
    482                   ! 
    483                   zchl = 0.05                                 ! constant chlorophyll 
    484                   irgb = NINT( 41 + 20.*LOG10(zchl) + 1.e-15 ) 
    485                   zekb(:,:) = rkrgb(1,irgb)                   ! Separation in R-G-B depending of the chlorophyll  
    486                   zekg(:,:) = rkrgb(2,irgb) 
    487                   zekr(:,:) = rkrgb(3,irgb) 
    488                   ! 
    489                   zcoef = ( 1. - rn_abs ) / 3.e0              ! equi-partition in R-G-B 
    490                   ze0(:,:,1) = rn_abs 
    491                   ze1(:,:,1) = zcoef 
    492                   ze2(:,:,1) = zcoef  
    493                   ze3(:,:,1) = zcoef 
    494                   zea(:,:,1) = tmask(:,:,1)                   ! = ( ze0+ze1+z2+ze3 ) * tmask 
    495                 
    496                   DO jk = 2, nksr+1 
    497 !CDIR NOVERRCHK 
    498                      DO jj = 1, jpj 
    499 !CDIR NOVERRCHK    
    500                         DO ji = 1, jpi 
    501                            zc0 = ze0(ji,jj,jk-1) * EXP( - e3t_0(ji,jj,jk-1) * xsi0r     ) 
    502                            zc1 = ze1(ji,jj,jk-1) * EXP( - e3t_0(ji,jj,jk-1) * zekb(ji,jj) ) 
    503                            zc2 = ze2(ji,jj,jk-1) * EXP( - e3t_0(ji,jj,jk-1) * zekg(ji,jj) ) 
    504                            zc3 = ze3(ji,jj,jk-1) * EXP( - e3t_0(ji,jj,jk-1) * zekr(ji,jj) ) 
    505                            ze0(ji,jj,jk) = zc0 
    506                            ze1(ji,jj,jk) = zc1 
    507                            ze2(ji,jj,jk) = zc2 
    508                            ze3(ji,jj,jk) = zc3 
    509                            zea(ji,jj,jk) = ( zc0 + zc1 + zc2 + zc3 ) * tmask(ji,jj,jk) 
    510                         END DO 
    511                      END DO 
    512                   END DO  
    513                   ! 
    514                   DO jk = 1, nksr 
    515                      ! (ISF) no light penetration below the ice shelves 
    516                      etot3(:,:,jk) = r1_rau0_rcp * ( zea(:,:,jk) - zea(:,:,jk+1) ) * tmask(:,:,1) 
    517                   END DO 
    518                   etot3(:,:,nksr+1:jpk) = 0.e0                ! below 400m set to zero 
    519                ENDIF 
    520             ENDIF 
    521             ! 
    522          ENDIF 
    523             !                             ! ---------------------------------- ! 
    524          IF( ln_qsr_2bd ) THEN            !    2 bands    light penetration    ! 
    525             !                             ! ---------------------------------- ! 
    526             ! 
    527             !                                ! level of light extinction 
    528             nksr = trc_oce_ext_lev( rn_si1, 1.e2 ) 
    529             IF(lwp) THEN 
    530                WRITE(numout,*) 
    531             IF(lwp) WRITE(numout,*) '        level of light extinction = ', nksr, ' ref depth = ', gdepw_1d(nksr+1), ' m' 
    532             ENDIF 
    533             ! 
    534             IF( lk_vvl ) THEN                   ! variable volume 
    535                IF(lwp) WRITE(numout,*) '        key_vvl: light distribution will be computed at each time step' 
    536             ELSE                                ! constant volume: computes one for all 
    537                zz0 =        rn_abs   * r1_rau0_rcp 
    538                zz1 = ( 1. - rn_abs ) * r1_rau0_rcp 
    539                DO jk = 1, nksr                    !*  solar heat absorbed at T-point computed once for all 
    540                   DO jj = 1, jpj                              ! top 400 meters 
    541                      DO ji = 1, jpi 
    542                         zc0 = zz0 * EXP( -fsdepw(ji,jj,jk  )*xsi0r ) + zz1 * EXP( -fsdepw(ji,jj,jk  )*xsi1r ) 
    543                         zc1 = zz0 * EXP( -fsdepw(ji,jj,jk+1)*xsi0r ) + zz1 * EXP( -fsdepw(ji,jj,jk+1)*xsi1r ) 
    544                         etot3(ji,jj,jk) = (  zc0 * tmask(ji,jj,jk) - zc1 * tmask(ji,jj,jk+1)  ) * tmask(ji,jj,1)  
    545                      END DO 
    546                   END DO 
    547                END DO 
    548                etot3(:,:,nksr+1:jpk) = 0.e0                   ! below 400m set to zero 
    549                ! 
    550             ENDIF 
    551          ENDIF 
    552          !                       ! ===================================== ! 
    553       ELSE                       !        No light penetration           !                    
    554          !                       ! ===================================== ! 
    555          IF(lwp) THEN 
    556             WRITE(numout,*) 
    557             WRITE(numout,*) 'tra_qsr_init : NO solar flux penetration' 
    558             WRITE(numout,*) '~~~~~~~~~~~~' 
    559          ENDIF 
    560       ENDIF 
    561       ! 
    562       ! initialisation of fraqsr_1lev used in sbcssm 
     393      CASE( np_2BD )                   !==  2 bands light penetration  ==! 
     394         ! 
     395         IF(lwp)  WRITE(numout,*) '   2 bands light penetration' 
     396         ! 
     397         nksr = trc_oce_ext_lev( rn_si1, 100._wp )    ! level of light extinction 
     398         IF(lwp) WRITE(numout,*) '        level of light extinction = ', nksr, ' ref depth = ', gdepw_1d(nksr+1), ' m' 
     399         ! 
     400      CASE( np_BIO )                   !==  BIO light penetration  ==! 
     401         ! 
     402         IF(lwp) WRITE(numout,*) '   bio-model light penetration' 
     403         IF( .NOT.lk_qsr_bio )   CALL ctl_stop( 'No bio model : ln_qsr_bio = true impossible ' ) 
     404         ! 
     405      END SELECT 
     406      ! 
     407      qsr_hc(:,:,:) = 0._wp     ! now qsr heat content set to zero where it will not be computed 
     408      ! 
     409      ! 1st ocean level attenuation coefficient (used in sbcssm) 
    563410      IF( iom_varid( numror, 'fraqsr_1lev', ldstop = .FALSE. ) > 0 ) THEN 
    564411         CALL iom_get( numror, jpdom_autoglo, 'fraqsr_1lev'  , fraqsr_1lev  ) 
    565412      ELSE 
    566          fraqsr_1lev(:,:) = 1._wp   ! default definition 
    567       ENDIF 
    568       ! 
    569       CALL wrk_dealloc( jpi, jpj,      zekb, zekg, zekr        )  
    570       CALL wrk_dealloc( jpi, jpj, jpk, ze0, ze1, ze2, ze3, zea )  
    571       ! 
    572       IF( nn_timing == 1 )  CALL timing_stop('tra_qsr_init') 
     413         fraqsr_1lev(:,:) = 1._wp   ! default : no penetration 
     414      ENDIF 
     415      ! 
     416      IF( nn_timing == 1 )   CALL timing_stop('tra_qsr_init') 
    573417      ! 
    574418   END SUBROUTINE tra_qsr_init 

  • branches/NERC/dev_r5549_BDY_ZEROGRAD/NEMOGCM/NEMO/OPA_SRC/TRA/trasbc.F90

    r5431 r6808  
    1313 
    1414   !!---------------------------------------------------------------------- 
    15    !!   tra_sbc      : update the tracer trend at ocean surface 
    16    !!---------------------------------------------------------------------- 
    17    USE oce             ! ocean dynamics and active tracers 
    18    USE sbc_oce         ! surface boundary condition: ocean 
    19    USE dom_oce         ! ocean space domain variables 
    20    USE phycst          ! physical constant 
    21    USE sbcmod          ! ln_rnf   
    22    USE sbcrnf          ! River runoff   
    23    USE sbcisf          ! Ice shelf    
    24    USE traqsr          ! solar radiation penetration 
    25    USE trd_oce         ! trends: ocean variables 
    26    USE trdtra          ! trends manager: tracers  
     15   !!   tra_sbc       : update the tracer trend at ocean surface 
     16   !!---------------------------------------------------------------------- 
     17   USE oce            ! ocean dynamics and active tracers 
     18   USE sbc_oce        ! surface boundary condition: ocean 
     19   USE dom_oce        ! ocean space domain variables 
     20   USE phycst         ! physical constant 
     21   USE eosbn2         ! Equation Of State 
     22   USE sbcmod         ! ln_rnf   
     23   USE sbcrnf         ! River runoff   
     24   USE sbcisf         ! Ice shelf    
     25   USE iscplini       ! Ice sheet coupling 
     26   USE traqsr         ! solar radiation penetration 
     27   USE trd_oce        ! trends: ocean variables 
     28   USE trdtra         ! trends manager: tracers  
    2729   ! 
    28    USE in_out_manager  ! I/O manager 
    29    USE prtctl          ! Print control 
    30    USE iom 
    31    USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    32    USE wrk_nemo        ! Memory Allocation 
    33    USE timing          ! Timing 
    34    USE eosbn2 
     30   USE in_out_manager ! I/O manager 
     31   USE prtctl         ! Print control 
     32   USE iom            ! xIOS server 
     33   USE lbclnk         ! ocean lateral boundary conditions (or mpp link) 
     34   USE wrk_nemo       ! Memory Allocation 
     35   USE timing         ! Timing 
    3536 
    3637   IMPLICIT NONE 
    3738   PRIVATE 
    3839 
    39    PUBLIC   tra_sbc    ! routine called by step.F90 
     40   PUBLIC   tra_sbc   ! routine called by step.F90 
    4041 
    4142   !! * Substitutions 
    42 #  include "domzgr_substitute.h90" 
    4343#  include "vectopt_loop_substitute.h90" 
    4444   !!---------------------------------------------------------------------- 
    … …  
    5757      !!      and add it to the general trend of tracer equations. 
    5858      !! 
    59       !! ** Method : 
    60       !!      Following Roullet and Madec (2000), the air-sea flux can be divided  
    61       !!      into three effects: (1) Fext, external forcing;  
    62       !!      (2) Fwi, concentration/dilution effect due to water exchanged  
    63       !!         at the surface by evaporation, precipitations and runoff (E-P-R);  
    64       !!      (3) Fwe, tracer carried with the water that is exchanged.  
    65       !!            - salinity    : salt flux only due to freezing/melting 
    66       !!            sa = sa +  sfx / rau0 / e3t  for k=1 
     59      !! ** Method :   The (air+ice)-sea flux has two components:  
     60      !!      (1) Fext, external forcing (i.e. flux through the (air+ice)-sea interface);  
     61      !!      (2) Fwe , tracer carried with the water that is exchanged with air+ice.  
     62      !!               The input forcing fields (emp, rnf, sfx, isf) contain Fext+Fwe, 
     63      !!             they are simply added to the tracer trend (tsa). 
     64      !!               In linear free surface case (ln_linssh=T), the volume of the 
     65      !!             ocean does not change with the water exchanges at the (air+ice)-sea 
     66      !!             interface. Therefore another term has to be added, to mimic the 
     67      !!             concentration/dilution effect associated with water exchanges. 
    6768      !! 
    68       !!      Fext, flux through the air-sea interface for temperature and salt:  
    69       !!            - temperature : heat flux q (w/m2). If penetrative solar 
    70       !!         radiation q is only the non solar part of the heat flux, the 
    71       !!         solar part is added in traqsr.F routine. 
    72       !!            ta = ta + q /(rau0 rcp e3t)  for k=1 
    73       !!            - salinity    : no salt flux 
    74       !! 
    75       !!      The formulation for Fwb and Fwi vary according to the free  
    76       !!      surface formulation (linear or variable volume).  
    77       !!      * Linear free surface 
    78       !!            The surface freshwater flux modifies the ocean volume 
    79       !!         and thus the concentration of a tracer and the temperature. 
    80       !!         First order of the effect of surface freshwater exchange  
    81       !!         for salinity, it can be neglected on temperature (especially 
    82       !!         as the temperature of precipitations and runoffs is usually 
    83       !!         unknown). 
    84       !!            - temperature : we assume that the temperature of both 
    85       !!         precipitations and runoffs is equal to the SST, thus there 
    86       !!         is no additional flux since in this case, the concentration 
    87       !!         dilution effect is balanced by the net heat flux associated 
    88       !!         to the freshwater exchange (Fwe+Fwi=0): 
    89       !!            (Tp P - Te E) + SST (P-E) = 0 when Tp=Te=SST 
    90       !!            - salinity    : evaporation, precipitation and runoff 
    91       !!         water has a zero salinity  but there is a salt flux due to  
    92       !!         freezing/melting, thus: 
    93       !!            sa = sa + emp * sn / rau0 / e3t   for k=1 
    94       !!                    + sfx    / rau0 / e3t 
    95       !!         where emp, the surface freshwater budget (evaporation minus 
    96       !!         precipitation minus runoff) given in kg/m2/s is divided 
    97       !!         by rau0 (density of sea water) to obtain m/s.     
    98       !!         Note: even though Fwe does not appear explicitly for  
    99       !!         temperature in this routine, the heat carried by the water 
    100       !!         exchanged through the surface is part of the total heat flux 
    101       !!         forcing and must be taken into account in the global heat 
    102       !!         balance). 
    103       !!      * nonlinear free surface (variable volume, lk_vvl) 
    104       !!         contrary to the linear free surface case, Fwi is properly  
    105       !!         taken into account by using the true layer thicknesses to        
    106       !!         calculate tracer content and advection. There is no need to  
    107       !!         deal with it in this routine. 
    108       !!           - temperature: Fwe=SST (P-E+R) is added to Fext. 
    109       !!           - salinity:  Fwe = 0, there is no surface flux of salt. 
    110       !! 
    111       !! ** Action  : - Update the 1st level of (ta,sa) with the trend associated 
    112       !!                with the tracer surface boundary condition  
    113       !!              - send trends to trdtra module (l_trdtra=T) 
     69      !! ** Action  : - Update tsa with the surface boundary condition trend  
     70      !!              - send trends to trdtra module for further diagnostics(l_trdtra=T) 
    11471      !!---------------------------------------------------------------------- 
    11572      INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
    116       !! 
    117       INTEGER  ::   ji, jj, jk, jn           ! dummy loop indices   
    118       INTEGER  ::   ikt, ikb  
    119       INTEGER  ::   nk_isf 
    120       REAL(wp) ::   zfact, z1_e3t, zdep 
    121       REAL(wp) ::   zalpha, zhk 
    122       REAL(wp) ::  zt_frz, zpress 
     73      ! 
     74      INTEGER  ::   ji, jj, jk, jn        ! dummy loop indices   
     75      INTEGER  ::   ikt, ikb              ! local integers 
     76      REAL(wp) ::   zfact, z1_e3t, zdep   ! local scalar 
    12377      REAL(wp), POINTER, DIMENSION(:,:,:) ::  ztrdt, ztrds 
    12478      !!---------------------------------------------------------------------- 
    … …  
    13185         IF(lwp) WRITE(numout,*) '~~~~~~~ ' 
    13286      ENDIF 
    133  
     87      ! 
    13488      IF( l_trdtra ) THEN                    !* Save ta and sa trends 
    13589         CALL wrk_alloc( jpi, jpj, jpk, ztrdt, ztrds )  
    … …  
    13791         ztrds(:,:,:) = tsa(:,:,:,jp_sal) 
    13892      ENDIF 
    139  
    140 !!gm      IF( .NOT.ln_traqsr )   qsr(:,:) = 0.e0   ! no solar radiation penetration 
     93      ! 
     94!!gm  This should be moved into sbcmod.F90 module ? (especially now that ln_traqsr is read in namsbc namelist) 
    14195      IF( .NOT.ln_traqsr ) THEN     ! no solar radiation penetration 
    14296         qns(:,:) = qns(:,:) + qsr(:,:)      ! total heat flux in qns 
    143          qsr(:,:) = 0.e0                     ! qsr set to zero 
     97         qsr(:,:) = 0._wp                     ! qsr set to zero 
    14498      ENDIF 
    14599 
    … …  
    147101      !        EMP, SFX and QNS effects 
    148102      !---------------------------------------- 
    149       !                                          Set before sbc tracer content fields 
    150       !                                          ************************************ 
    151       IF( kt == nit000 ) THEN                      ! Set the forcing field at nit000 - 1 
    152          !                                         ! ----------------------------------- 
    153          IF( ln_rstart .AND.    &                     ! Restart: read in restart file 
     103      !                             !==  Set before sbc tracer content fields  ==! 
     104      IF( kt == nit000 ) THEN             !* 1st time-step 
     105         IF( ln_rstart .AND.    &               ! Restart: read in restart file 
    154106              & iom_varid( numror, 'sbc_hc_b', ldstop = .FALSE. ) > 0 ) THEN 
    155             IF(lwp) WRITE(numout,*) '          nit000-1 surface tracer content forcing fields red in the restart file' 
     107            IF(lwp) WRITE(numout,*) '          nit000-1 sbc tracer content field read in the restart file' 
    156108            zfact = 0.5_wp 
    157109            CALL iom_get( numror, jpdom_autoglo, 'sbc_hc_b', sbc_tsc_b(:,:,jp_tem) )   ! before heat content sbc trend 
    158110            CALL iom_get( numror, jpdom_autoglo, 'sbc_sc_b', sbc_tsc_b(:,:,jp_sal) )   ! before salt content sbc trend 
    159          ELSE                                         ! No restart or restart not found: Euler forward time stepping 
     111         ELSE                                   ! No restart or restart not found: Euler forward time stepping 
    160112            zfact = 1._wp 
    161113            sbc_tsc_b(:,:,:) = 0._wp 
    162114         ENDIF 
    163       ELSE                                         ! Swap of forcing fields 
    164          !                                         ! ---------------------- 
     115      ELSE                                !* other time-steps: swap of forcing fields 
    165116         zfact = 0.5_wp 
    166117         sbc_tsc_b(:,:,:) = sbc_tsc(:,:,:) 
    167118      ENDIF 
    168       !                                          Compute now sbc tracer content fields 
    169       !                                          ************************************* 
    170  
    171                                                    ! Concentration dilution effect on (t,s) due to   
    172                                                    ! evaporation, precipitation and qns, but not river runoff  
    173                                                 
    174       IF( lk_vvl ) THEN                            ! Variable Volume case  ==>> heat content of mass flux is in qns 
    175          DO jj = 1, jpj 
    176             DO ji = 1, jpi  
    177                sbc_tsc(ji,jj,jp_tem) = r1_rau0_rcp * qns(ji,jj)                              ! non solar heat flux 
    178                sbc_tsc(ji,jj,jp_sal) = r1_rau0     * sfx(ji,jj)                              ! salt flux due to freezing/melting 
     119      !                             !==  Now sbc tracer content fields  ==! 
     120      DO jj = 2, jpj 
     121         DO ji = fs_2, fs_jpim1   ! vector opt. 
     122            sbc_tsc(ji,jj,jp_tem) = r1_rau0_rcp * qns(ji,jj)   ! non solar heat flux 
     123            sbc_tsc(ji,jj,jp_sal) = r1_rau0     * sfx(ji,jj)   ! salt flux due to freezing/melting 
     124         END DO 
     125      END DO 
     126      IF( ln_linssh ) THEN                !* linear free surface   
     127         DO jj = 2, jpj                         !==>> add concentration/dilution effect due to constant volume cell 
     128            DO ji = fs_2, fs_jpim1   ! vector opt. 
     129               sbc_tsc(ji,jj,jp_tem) = sbc_tsc(ji,jj,jp_tem) + r1_rau0 * emp(ji,jj) * tsn(ji,jj,1,jp_tem) 
     130               sbc_tsc(ji,jj,jp_sal) = sbc_tsc(ji,jj,jp_sal) + r1_rau0 * emp(ji,jj) * tsn(ji,jj,1,jp_sal) 
    179131            END DO 
    180          END DO 
    181       ELSE                                         ! Constant Volume case ==>> Concentration dilution effect 
     132         END DO                                 !==>> output c./d. term 
     133         IF( iom_use('emp_x_sst') )   CALL iom_put( "emp_x_sst", emp (:,:) * tsn(:,:,1,jp_tem) ) 
     134         IF( iom_use('emp_x_sss') )   CALL iom_put( "emp_x_sss", emp (:,:) * tsn(:,:,1,jp_sal) ) 
     135      ENDIF 
     136      ! 
     137      DO jn = 1, jpts               !==  update tracer trend  ==! 
    182138         DO jj = 2, jpj 
    183             DO ji = fs_2, fs_jpim1   ! vector opt. 
    184                ! temperature : heat flux 
    185                sbc_tsc(ji,jj,jp_tem) = r1_rau0_rcp * qns(ji,jj)                          &   ! non solar heat flux 
    186                   &                  + r1_rau0     * emp(ji,jj)  * tsn(ji,jj,1,jp_tem)       ! concent./dilut. effect 
    187                ! salinity    : salt flux + concent./dilut. effect (both in sfx) 
    188                sbc_tsc(ji,jj,jp_sal) = r1_rau0  * (  sfx(ji,jj)                          &   ! salt flux (freezing/melting) 
    189                   &                                + emp(ji,jj) * tsn(ji,jj,1,jp_sal) )      ! concent./dilut. effect 
     139            DO ji = fs_2, fs_jpim1   ! vector opt.   
     140               tsa(ji,jj,1,jn) = tsa(ji,jj,1,jn) + zfact * ( sbc_tsc_b(ji,jj,jn) + sbc_tsc(ji,jj,jn) ) / e3t_n(ji,jj,1) 
    190141            END DO 
    191142         END DO 
    192          IF( iom_use('emp_x_sst') )   CALL iom_put( "emp_x_sst", emp (:,:) * tsn(:,:,1,jp_tem) )   ! c/d term on sst 
    193          IF( iom_use('emp_x_sss') )   CALL iom_put( "emp_x_sss", emp (:,:) * tsn(:,:,1,jp_sal) )   ! c/d term on sss 
    194       ENDIF 
    195       ! Concentration dilution effect on (t,s) due to evapouration, precipitation and qns, but not river runoff   
    196       DO jn = 1, jpts 
    197          DO jj = 2, jpj 
    198             DO ji = fs_2, fs_jpim1   ! vector opt. 
    199                z1_e3t = zfact / fse3t(ji,jj,1) 
    200                tsa(ji,jj,1,jn) = tsa(ji,jj,1,jn) + ( sbc_tsc_b(ji,jj,jn) + sbc_tsc(ji,jj,jn) ) * z1_e3t 
    201             END DO 
    202          END DO 
    203143      END DO 
    204       !                                          Write in the ocean restart file 
    205       !                                          ******************************* 
    206       IF( lrst_oce ) THEN 
    207          IF(lwp) WRITE(numout,*) 
    208          IF(lwp) WRITE(numout,*) 'sbc : ocean surface tracer content forcing fields written in ocean restart file ',   & 
    209             &                    'at it= ', kt,' date= ', ndastp 
    210          IF(lwp) WRITE(numout,*) '~~~~' 
     144      !                   
     145      IF( lrst_oce ) THEN           !==  write sbc_tsc in the ocean restart file  ==! 
    211146         CALL iom_rstput( kt, nitrst, numrow, 'sbc_hc_b', sbc_tsc(:,:,jp_tem) ) 
    212147         CALL iom_rstput( kt, nitrst, numrow, 'sbc_sc_b', sbc_tsc(:,:,jp_sal) ) 
    213148      ENDIF 
    214149      ! 
    215       ! 
    216150      !---------------------------------------- 
    217151      !       Ice Shelf effects (ISF) 
    … …  
    219153      !---------------------------------------- 
    220154      ! 
    221       IF( nn_isf > 0 ) THEN 
    222          zfact = 0.5e0 
     155!!gm BUG ?   Why no differences between non-linear and linear free surface ? 
     156!!gm         probably taken into account in r1_hisf_tbl : to be verified 
     157      IF( ln_isf ) THEN 
     158         zfact = 0.5_wp 
    223159         DO jj = 2, jpj 
    224160            DO ji = fs_2, fs_jpim1 
    225           
     161               ! 
    226162               ikt = misfkt(ji,jj) 
    227163               ikb = misfkb(ji,jj) 
    228     
     164               ! 
    229165               ! level fully include in the ice shelf boundary layer 
    230                ! if isfdiv, we have to remove heat flux due to inflow at 0oC (as in rnf when you add rnf at sst) 
    231166               ! sign - because fwf sign of evapo (rnf sign of precip) 
    232167               DO jk = ikt, ikb - 1 
    233                ! compute tfreez for the temperature correction (we add water at freezing temperature) 
    234 !                  zpress = grav*rau0*fsdept(ji,jj,jk)*1.e-04 
    235                   zt_frz = -1.9 !eos_fzp( tsn(ji,jj,jk,jp_sal), zpress ) 
    236168               ! compute trend 
    237                   tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem)                                          & 
    238                      &           + zfact * (risf_tsc_b(ji,jj,jp_tem) + risf_tsc(ji,jj,jp_tem)          & 
    239                      &               - rdivisf * (fwfisf(ji,jj) + fwfisf_b(ji,jj)) * zt_frz * r1_rau0) & 
     169                  tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem)                                                & 
     170                     &           + zfact * ( risf_tsc_b(ji,jj,jp_tem) + risf_tsc(ji,jj,jp_tem) )             & 
    240171                     &           * r1_hisf_tbl(ji,jj) 
    241                   tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal)                                          & 
    242                      &           + zfact * (risf_tsc_b(ji,jj,jp_sal) + risf_tsc(ji,jj,jp_sal)) * r1_hisf_tbl(ji,jj) 
    243172               END DO 
    244173    
    245174               ! level partially include in ice shelf boundary layer  
    246                ! compute tfreez for the temperature correction (we add water at freezing temperature) 
    247 !               zpress = grav*rau0*fsdept(ji,jj,ikb)*1.e-04 
    248                zt_frz = -1.9 !eos_fzp( tsn(ji,jj,ikb,jp_sal), zpress ) 
    249175               ! compute trend 
    250                tsa(ji,jj,ikb,jp_tem) = tsa(ji,jj,ikb,jp_tem)                                           & 
    251                   &              + zfact * (risf_tsc_b(ji,jj,jp_tem) + risf_tsc(ji,jj,jp_tem)          & 
    252                   &                  - rdivisf * (fwfisf(ji,jj) + fwfisf_b(ji,jj)) * zt_frz * r1_rau0) &  
     176               tsa(ji,jj,ikb,jp_tem) = tsa(ji,jj,ikb,jp_tem)                                                 & 
     177                  &              + zfact * ( risf_tsc_b(ji,jj,jp_tem) + risf_tsc(ji,jj,jp_tem) )             & 
    253178                  &              * r1_hisf_tbl(ji,jj) * ralpha(ji,jj) 
    254                tsa(ji,jj,ikb,jp_sal) = tsa(ji,jj,ikb,jp_sal)                                           & 
    255                   &              + zfact * (risf_tsc_b(ji,jj,jp_sal) + risf_tsc(ji,jj,jp_sal)) * r1_hisf_tbl(ji,jj) * ralpha(ji,jj)  
     179 
    256180            END DO 
    257181         END DO 
    258182         IF( lrst_oce ) THEN 
    259             IF(lwp) WRITE(numout,*) 
    260             IF(lwp) WRITE(numout,*) 'sbc : isf surface tracer content forcing fields written in ocean restart file ',   & 
    261                &                    'at it= ', kt,' date= ', ndastp 
    262             IF(lwp) WRITE(numout,*) '~~~~' 
    263             CALL iom_rstput( kt, nitrst, numrow, 'fwf_isf_b', fwfisf(:,:)          ) 
     183            CALL iom_rstput( kt, nitrst, numrow, 'fwf_isf_b', fwfisf  (:,:)        ) 
    264184            CALL iom_rstput( kt, nitrst, numrow, 'isf_hc_b' , risf_tsc(:,:,jp_tem) ) 
    265185            CALL iom_rstput( kt, nitrst, numrow, 'isf_sc_b' , risf_tsc(:,:,jp_sal) ) 
    … …  
    278198                  zdep = zfact / h_rnf(ji,jj) 
    279199                  DO jk = 1, nk_rnf(ji,jj) 
    280                                         tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem)   & 
    281                                           &               +  ( rnf_tsc_b(ji,jj,jp_tem) + rnf_tsc(ji,jj,jp_tem) ) * zdep 
    282                      IF( ln_rnf_sal )   tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal)   & 
    283                                           &               +  ( rnf_tsc_b(ji,jj,jp_sal) + rnf_tsc(ji,jj,jp_sal) ) * zdep  
     200                                        tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem)                                 & 
     201                                           &                 +  ( rnf_tsc_b(ji,jj,jp_tem) + rnf_tsc(ji,jj,jp_tem) ) * zdep 
     202                     IF( ln_rnf_sal )   tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal)                                 & 
     203                                           &                 +  ( rnf_tsc_b(ji,jj,jp_sal) + rnf_tsc(ji,jj,jp_sal) ) * zdep  
    284204                  END DO 
    285205               ENDIF 
    … …  
    287207         END DO   
    288208      ENDIF 
    289   
    290       IF( l_trdtra )   THEN                      ! send trends for further diagnostics 
     209      ! 
     210      !---------------------------------------- 
     211      !        Ice Sheet coupling imbalance correction to have conservation 
     212      !---------------------------------------- 
     213      ! 
     214      IF( ln_iscpl .AND. ln_hsb) THEN         ! input of heat and salt due to river runoff  
     215         DO jk = 1,jpk 
     216            DO jj = 2, jpj  
     217               DO ji = fs_2, fs_jpim1 
     218                  zdep = 1._wp / e3t_n(ji,jj,jk)  
     219                  tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) - htsc_iscpl(ji,jj,jk,jp_tem)                       & 
     220                      &                                         * zdep 
     221                  tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal) - htsc_iscpl(ji,jj,jk,jp_sal)                       & 
     222                      &                                         * zdep   
     223               END DO   
     224            END DO   
     225         END DO 
     226      ENDIF 
     227 
     228      IF( l_trdtra )   THEN                      ! save the horizontal diffusive trends for further diagnostics 
    291229         ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 
    292230         ztrds(:,:,:) = tsa(:,:,:,jp_sal) - ztrds(:,:,:) 

  • branches/NERC/dev_r5549_BDY_ZEROGRAD/NEMOGCM/NEMO/OPA_SRC/TRA/trazdf.F90

    r5385 r6808  
    99 
    1010   !!---------------------------------------------------------------------- 
    11    !!   tra_zdf      : Update the tracer trend with the vertical diffusion 
    12    !!   tra_zdf_init : initialisation of the computation 
     11   !!   tra_zdf       : Update the tracer trend with the vertical diffusion 
     12   !!   tra_zdf_init  : initialisation of the computation 
    1313   !!---------------------------------------------------------------------- 
    14    USE oce             ! ocean dynamics and tracers variables 
    15    USE dom_oce         ! ocean space and time domain variables  
    16    USE domvvl          ! variable volume 
    17    USE phycst          ! physical constant 
    18    USE zdf_oce         ! ocean vertical physics variables 
    19    USE sbc_oce         ! surface boundary condition: ocean 
    20    USE dynspg_oce 
    21    USE trazdf_exp      ! vertical diffusion: explicit (tra_zdf_exp     routine) 
    22    USE trazdf_imp      ! vertical diffusion: implicit (tra_zdf_imp    routine) 
    23    USE ldftra_oce      ! ocean active tracers: lateral physics 
    24    USE trd_oce         ! trends: ocean variables 
    25    USE trdtra          ! trends manager: tracers  
     14   USE oce            ! ocean dynamics and tracers variables 
     15   USE dom_oce        ! ocean space and time domain variables  
     16   USE domvvl         ! variable volume 
     17   USE phycst         ! physical constant 
     18   USE zdf_oce        ! ocean vertical physics variables 
     19   USE sbc_oce        ! surface boundary condition: ocean 
     20   USE ldftra         ! lateral diffusion: eddy diffusivity 
     21   USE ldfslp         ! lateral diffusion: iso-neutral slope  
     22   USE trazdf_exp     ! vertical diffusion: explicit (tra_zdf_exp routine) 
     23   USE trazdf_imp     ! vertical diffusion: implicit (tra_zdf_imp routine) 
     24   USE trd_oce        ! trends: ocean variables 
     25   USE trdtra         ! trends: tracer trend manager 
    2626   ! 
    27    USE in_out_manager  ! I/O manager 
    28    USE prtctl          ! Print control 
    29    USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    30    USE lib_mpp         ! MPP library 
    31    USE wrk_nemo        ! Memory allocation 
    32    USE timing          ! Timing 
     27   USE in_out_manager ! I/O manager 
     28   USE prtctl         ! Print control 
     29   USE lbclnk         ! ocean lateral boundary conditions (or mpp link) 
     30   USE lib_mpp        ! MPP library 
     31   USE wrk_nemo       ! Memory allocation 
     32   USE timing         ! Timing 
    3333 
    3434   IMPLICIT NONE 
    … …  
    4141 
    4242   !! * Substitutions 
    43 #  include "domzgr_substitute.h90" 
    4443#  include "zdfddm_substitute.h90" 
    4544#  include "vectopt_loop_substitute.h90" 
    4645   !!---------------------------------------------------------------------- 
    47    !! NEMO/OPA 3.7 , NEMO Consortium (2014) 
     46   !! NEMO/OPA 3.7 , NEMO Consortium (2015) 
    4847   !! $Id$ 
    4948   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    … …  
    5857      !!--------------------------------------------------------------------- 
    5958      INTEGER, INTENT( in ) ::   kt      ! ocean time-step index 
    60       !! 
     59      ! 
    6160      INTEGER  ::   jk                   ! Dummy loop indices 
    6261      REAL(wp), POINTER, DIMENSION(:,:,:) ::   ztrdt, ztrds   ! 3D workspace 
    … …  
    6665      ! 
    6766      IF( neuler == 0 .AND. kt == nit000 ) THEN     ! at nit000 
    68          r2dtra(:) =  rdttra(:)                          ! = rdtra (restarting with Euler time stepping) 
     67         r2dt =  rdt                          ! = rdt (restarting with Euler time stepping) 
    6968      ELSEIF( kt <= nit000 + 1) THEN                ! at nit000 or nit000+1 
    70          r2dtra(:) = 2. * rdttra(:)                      ! = 2 rdttra (leapfrog) 
     69         r2dt = 2. * rdt                      ! = 2 rdt (leapfrog) 
    7170      ENDIF 
    72  
     71      ! 
    7372      IF( l_trdtra )   THEN                    !* Save ta and sa trends 
    7473         CALL wrk_alloc( jpi, jpj, jpk, ztrdt, ztrds ) 
    … …  
    7675         ztrds(:,:,:) = tsa(:,:,:,jp_sal) 
    7776      ENDIF 
    78  
     77      ! 
    7978      SELECT CASE ( nzdf )                       ! compute lateral mixing trend and add it to the general trend 
    80       CASE ( 0 )    ;    CALL tra_zdf_exp( kt, nit000, 'TRA', r2dtra, nn_zdfexp, tsb, tsa, jpts )  !   explicit scheme  
    81       CASE ( 1 )    ;    CALL tra_zdf_imp( kt, nit000, 'TRA', r2dtra,            tsb, tsa, jpts )  !   implicit scheme  
    82       CASE ( -1 )                                       ! esopa: test all possibility with control print 
    83          CALL tra_zdf_exp( kt, nit000, 'TRA', r2dtra, nn_zdfexp, tsb, tsa, jpts ) 
    84          CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' zdf0 - Ta: ', mask1=tmask,               & 
    85          &             tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    86          CALL tra_zdf_imp( kt, nit000, 'TRA', r2dtra,            tsb, tsa, jpts )  
    87          CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' zdf1 - Ta: ', mask1=tmask,               & 
    88          &             tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
     79      CASE ( 0 )    ;    CALL tra_zdf_exp( kt, nit000, 'TRA', r2dt, nn_zdfexp, tsb, tsa, jpts )  !   explicit scheme  
     80      CASE ( 1 )    ;    CALL tra_zdf_imp( kt, nit000, 'TRA', r2dt,            tsb, tsa, jpts )  !   implicit scheme  
    8981      END SELECT 
     82!!gm WHY here !   and I don't like that ! 
    9083      ! DRAKKAR SSS control { 
    9184      ! JMM avoid negative salinities near river outlet ! Ugly fix 
    9285      ! JMM : restore negative salinities to small salinities: 
    93       WHERE ( tsa(:,:,:,jp_sal) < 0._wp )   tsa(:,:,:,jp_sal) = 0.1_wp 
     86      WHERE( tsa(:,:,:,jp_sal) < 0._wp )   tsa(:,:,:,jp_sal) = 0.1_wp 
     87!!gm 
    9488 
    9589      IF( l_trdtra )   THEN                      ! save the vertical diffusive trends for further diagnostics 
    9690         DO jk = 1, jpkm1 
    97             ztrdt(:,:,jk) = ( ( tsa(:,:,jk,jp_tem) - tsb(:,:,jk,jp_tem) ) / r2dtra(jk) ) - ztrdt(:,:,jk) 
    98             ztrds(:,:,jk) = ( ( tsa(:,:,jk,jp_sal) - tsb(:,:,jk,jp_sal) ) / r2dtra(jk) ) - ztrds(:,:,jk) 
     91            ztrdt(:,:,jk) = ( ( tsa(:,:,jk,jp_tem) - tsb(:,:,jk,jp_tem) ) / r2dt ) - ztrdt(:,:,jk) 
     92            ztrds(:,:,jk) = ( ( tsa(:,:,jk,jp_sal) - tsb(:,:,jk,jp_sal) ) / r2dt ) - ztrds(:,:,jk) 
    9993         END DO 
     94!!gm this should be moved in trdtra.F90 and done on all trends 
    10095         CALL lbc_lnk( ztrdt, 'T', 1. ) 
    10196         CALL lbc_lnk( ztrds, 'T', 1. ) 
     97!!gm 
    10298         CALL trd_tra( kt, 'TRA', jp_tem, jptra_zdf, ztrdt ) 
    10399         CALL trd_tra( kt, 'TRA', jp_sal, jptra_zdf, ztrds ) 
    104100         CALL wrk_dealloc( jpi, jpj, jpk, ztrdt, ztrds ) 
    105101      ENDIF 
    106  
    107102      !                                          ! print mean trends (used for debugging) 
    108103      IF(ln_ctl)   CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' zdf  - Ta: ', mask1=tmask,               & 
    … …  
    123118      !!      nzdf = 0   explicit (time-splitting) scheme (ln_zdfexp=T) 
    124119      !!           = 1   implicit (euler backward) scheme (ln_zdfexp=F) 
    125       !!      NB: rotation of lateral mixing operator or TKE or KPP scheme, 
    126       !!      the implicit scheme is required. 
     120      !!      NB: rotation of lateral mixing operator or TKE & GLS schemes, 
     121      !!          an implicit scheme is required. 
    127122      !!---------------------------------------------------------------------- 
    128123      USE zdftke 
    129124      USE zdfgls 
    130       USE zdfkpp 
    131125      !!---------------------------------------------------------------------- 
    132  
     126      ! 
    133127      ! Choice from ln_zdfexp already read in namelist in zdfini module 
    134128      IF( ln_zdfexp ) THEN   ;   nzdf = 0           ! use explicit scheme 
    135129      ELSE                   ;   nzdf = 1           ! use implicit scheme 
    136130      ENDIF 
    137  
     131      ! 
    138132      ! Force implicit schemes 
    139       IF( lk_zdftke .OR. lk_zdfgls .OR. lk_zdfkpp )   nzdf = 1      ! TKE, GLS or KPP physics 
    140       IF( ln_traldf_iso                           )   nzdf = 1      ! iso-neutral lateral physics 
    141       IF( ln_traldf_hor .AND. ln_sco              )   nzdf = 1      ! horizontal lateral physics in s-coordinate 
     133      IF( lk_zdftke .OR. lk_zdfgls   )   nzdf = 1   ! TKE, or GLS physics 
     134      IF( ln_traldf_iso              )   nzdf = 1   ! iso-neutral lateral physics 
     135      IF( ln_traldf_hor .AND. ln_sco )   nzdf = 1   ! horizontal lateral physics in s-coordinate 
    142136      IF( ln_zdfexp .AND. nzdf == 1 )   CALL ctl_stop( 'tra_zdf : If using the rotation of lateral mixing operator',   & 
    143             &                         ' TKE or KPP scheme, the implicit scheme is required, set ln_zdfexp = .false.' ) 
    144  
    145       ! Test: esopa 
    146       IF( lk_esopa )    nzdf = -1                      ! All schemes used 
    147  
     137            &                         ' GLS or TKE scheme, the implicit scheme is required, set ln_zdfexp = .false.' ) 
     138            ! 
    148139      IF(lwp) THEN 
    149140         WRITE(numout,*) 
    150141         WRITE(numout,*) 'tra_zdf_init : vertical tracer physics scheme' 
    151142         WRITE(numout,*) '~~~~~~~~~~~' 
    152          IF( nzdf == -1 )   WRITE(numout,*) '              ESOPA test All scheme used' 
    153143         IF( nzdf ==  0 )   WRITE(numout,*) '              Explicit time-splitting scheme' 
    154144         IF( nzdf ==  1 )   WRITE(numout,*) '              Implicit (euler backward) scheme' 

  • branches/NERC/dev_r5549_BDY_ZEROGRAD/NEMOGCM/NEMO/OPA_SRC/TRA/trazdf_exp.F90

    r3294 r6808  
    2020 
    2121   !!---------------------------------------------------------------------- 
    22    !!   tra_zdf_exp  : compute the tracer the vertical diffusion trend using a 
    23    !!                  split-explicit time stepping and provide the after tracer 
     22   !!   tra_zdf_exp   : compute the tracer the vertical diffusion trend using a 
     23   !!                   split-explicit time stepping and provide the after tracer 
    2424   !!---------------------------------------------------------------------- 
    25    USE oce             ! ocean dynamics and active tracers  
    26    USE dom_oce         ! ocean space and time domain  
    27    USE domvvl          ! variable volume levels 
    28    USE zdf_oce         ! ocean vertical physics 
    29    USE zdfddm          ! ocean vertical physics: double diffusion 
    30    USE trc_oce         ! share passive tracers/Ocean variables 
    31    USE in_out_manager  ! I/O manager 
    32    USE lib_mpp         ! MPP library 
    33    USE wrk_nemo        ! Memory Allocation 
    34    USE timing          ! Timing 
     25   USE oce            ! ocean dynamics and active tracers  
     26   USE dom_oce        ! ocean space and time domain  
     27   USE domvvl         ! variable volume levels 
     28   USE zdf_oce        ! ocean vertical physics 
     29   USE zdfddm         ! ocean vertical physics: double diffusion 
     30   USE trc_oce        ! share passive tracers/Ocean variables 
     31   ! 
     32   USE in_out_manager ! I/O manager 
     33   USE lib_mpp        ! MPP library 
     34   USE wrk_nemo       ! Memory Allocation 
     35   USE timing         ! Timing 
    3536 
    3637   IMPLICIT NONE 
    … …  
    4041 
    4142   !! * Substitutions 
    42 #  include "domzgr_substitute.h90" 
    4343#  include "zdfddm_substitute.h90" 
    4444#  include "vectopt_loop_substitute.h90" 
    … …  
    5050CONTAINS 
    5151 
    52    SUBROUTINE tra_zdf_exp( kt, kit000, cdtype, p2dt, kn_zdfexp,   & 
    53       &                                ptb , pta      , kjpt ) 
     52   SUBROUTINE tra_zdf_exp( kt, kit000, cdtype, p2dt, ksts,   & 
     53      &                                        ptb , pta , kjpt ) 
    5454      !!---------------------------------------------------------------------- 
    5555      !!                  ***  ROUTINE tra_zdf_exp  *** 
    … …  
    6060      !! ** Method  : - The after tracer fields due to the vertical diffusion 
    6161      !!      of tracers alone is given by: 
    62       !!                zwx = ptb + p2dt difft 
     62      !!                ztb = ptb + p2dt difft 
    6363      !!      where difft = dz( avt dz(ptb) ) = 1/e3t dk+1( avt/e3w dk(ptb) ) 
    6464      !!           (if lk_zdfddm=T use avs on salinity and passive tracers instead of avt) 
    … …  
    6767      !!      (N.B. bottom condition is applied through the masked field avt). 
    6868      !!              - the after tracer fields due to the whole trend is  
    69       !!      obtained in leap-frog environment by : 
    70       !!          pta = zwx + p2dt pta 
    71       !!              - in case of variable level thickness (lk_vvl=T) the  
    72       !!     the leap-frog is applied on thickness weighted tracer. That is: 
    73       !!          pta = [ ptb*e3tb + e3tn*( zwx - ptb + p2dt pta ) ] / e3tn 
     69      !!      obtained in leap-frog environment applied on thickness weighted tracer by : 
     70      !!          pta = [ ptb*e3tb + e3tn*( ztb - ptb + p2dt pta ) ] / e3tn 
    7471      !! 
    7572      !! ** Action : - after tracer fields pta 
    7673      !!--------------------------------------------------------------------- 
     74      INTEGER                              , INTENT(in   ) ::   kt       ! ocean time-step index 
     75      INTEGER                              , INTENT(in   ) ::   kit000   ! first 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   ) ::   ksts     ! number of sub-time step 
     79      REAL(wp)                             , INTENT(in   ) ::   p2dt     ! vertical profile of tracer time-step 
     80      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb      ! before and now tracer fields 
     81      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta      ! in: tracer trend ; out: after tracer field  
    7782      ! 
    78       INTEGER                              , INTENT(in   ) ::   kt          ! ocean time-step index 
    79       INTEGER                              , INTENT(in   ) ::   kit000      ! first time step index 
    80       CHARACTER(len=3)                     , INTENT(in   ) ::   cdtype      ! =TRA or TRC (tracer indicator) 
    81       INTEGER                              , INTENT(in   ) ::   kjpt        ! number of tracers 
    82       INTEGER                              , INTENT(in   ) ::   kn_zdfexp   ! number of sub-time step 
    83       REAL(wp), DIMENSION(        jpk     ), INTENT(in   ) ::   p2dt        ! vertical profile of tracer time-step 
    84       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb         ! before and now tracer fields 
    85       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta         ! tracer trend  
    86       ! 
    87       INTEGER  ::  ji, jj, jk, jn, jl        ! dummy loop indices 
    88       REAL(wp) ::  zlavmr, zave3r, ze3tr     ! local scalars 
    89       REAL(wp) ::  ztra, ze3tb               !   -      - 
    90       REAL(wp), POINTER, DIMENSION(:,:,:) ::  zwx, zwy 
     83      INTEGER  ::  ji, jj, jk, jn, jl   ! dummy loop indices 
     84      REAL(wp) ::  z1_ksts, ze3tr       ! local scalars 
     85      REAL(wp) ::  ztra, ze3tb    !   -      - 
     86      REAL(wp), POINTER, DIMENSION(:,:,:) ::  ztb, zwf 
    9187      !!--------------------------------------------------------------------- 
    9288      ! 
    9389      IF( nn_timing == 1 )  CALL timing_start('tra_zdf_exp') 
    9490      ! 
    95       CALL wrk_alloc( jpi, jpj, jpk, zwx, zwy )  
     91      CALL wrk_alloc( jpi,jpj,jpk,   ztb, zwf )  
    9692      ! 
    97  
    9893      IF( kt == kit000 )  THEN 
    9994         IF(lwp) WRITE(numout,*) 
    … …  
    10499      ! Initializations 
    105100      ! --------------- 
    106       zlavmr = 1. / float( kn_zdfexp )         ! Local constant 
     101      z1_ksts = 1._wp / REAL( ksts, wp ) 
     102      zwf(:,:, 1 ) = 0._wp    ! no flux at the surface and at bottom level 
     103      zwf(:,:,jpk) = 0._wp 
    107104      ! 
    108105      ! 
    109       DO jn = 1, kjpt                          ! loop over tracers 
     106      DO jn = 1, kjpt         !==  loop over tracers  ==! 
    110107         ! 
    111          zwy(:,:, 1 ) = 0.e0     ! surface boundary conditions: no flux 
    112          zwy(:,:,jpk) = 0.e0     ! bottom  boundary conditions: no flux 
    113          ! 
    114          zwx(:,:,:)   = ptb(:,:,:,jn)  ! zwx array set to before tracer values 
    115  
    116          ! Split-explicit loop  (after tracer due to the vertical diffusion alone) 
    117          ! ------------------- 
    118          ! 
    119          DO jl = 1, kn_zdfexp 
    120             !                     ! first vertical derivative 
    121             DO jk = 2, jpk 
     108         ztb(:,:,:) = ptb(:,:,:,jn)    ! initial before value for tracer 
     109         !  
     110         DO jl = 1, ksts         !==  Split-explicit loop  ==! 
     111            !               
     112            DO jk = 2, jpk             ! 1st vertical derivative (w-flux) 
    122113               DO jj = 2, jpjm1  
    123114                  DO ji = fs_2, fs_jpim1   ! vector opt. 
    124                      zave3r = 1.e0 / fse3w_n(ji,jj,jk)  
    125115                     IF( cdtype == 'TRA' .AND. jn == jp_tem ) THEN  ! temperature : use of avt 
    126                         zwy(ji,jj,jk) =   avt(ji,jj,jk) * ( zwx(ji,jj,jk-1) - zwx(ji,jj,jk) ) * zave3r 
     116                        zwf(ji,jj,jk) =   avt(ji,jj,jk) * ( ztb(ji,jj,jk-1) - ztb(ji,jj,jk) ) / e3w_b(ji,jj,jk) 
    127117                     ELSE                                           ! salinity or pass. tracer : use of avs 
    128                         zwy(ji,jj,jk) = fsavs(ji,jj,jk) * ( zwx(ji,jj,jk-1) - zwx(ji,jj,jk) ) * zave3r 
     118                        zwf(ji,jj,jk) = fsavs(ji,jj,jk) * ( ztb(ji,jj,jk-1) - ztb(ji,jj,jk) ) / e3w_b(ji,jj,jk) 
    129119                     END IF 
    130120                  END DO 
    … …  
    132122            END DO 
    133123            ! 
    134             DO jk = 1, jpkm1      ! second vertical derivative   ==> tracer at kt+l*2*rdt/nn_zdfexp 
     124            DO jk = 1, jpkm1           ! 2nd vertical derivative   ==> tracer at kt+l*2*rdt/nn_zdfexp 
    135125               DO jj = 2, jpjm1  
    136126                  DO ji = fs_2, fs_jpim1   ! vector opt. 
    137                      ze3tr = zlavmr / fse3t_n(ji,jj,jk) 
    138                      zwx(ji,jj,jk) = zwx(ji,jj,jk) + p2dt(jk) * ( zwy(ji,jj,jk) - zwy(ji,jj,jk+1) ) * ze3tr 
     127                     ztb(ji,jj,jk) = ztb(ji,jj,jk) + p2dt * ( zwf(ji,jj,jk) - zwf(ji,jj,jk+1) ) / e3t_n(ji,jj,jk) 
    139128                  END DO 
    140129               END DO 
    141130            END DO 
    142131            ! 
    143          END DO 
     132         END DO                  ! end sub-time stepping 
    144133 
    145          ! After tracer due to all trends 
    146          ! ------------------------------ 
    147          IF( lk_vvl ) THEN          ! variable level thickness : leap-frog on tracer*e3t 
    148             DO jk = 1, jpkm1 
    149                DO jj = 2, jpjm1  
    150                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    151                      ze3tb = fse3t_b(ji,jj,jk) / fse3t(ji,jj,jk)                          ! before e3t 
    152                      ztra  = zwx(ji,jj,jk) - ptb(ji,jj,jk,jn) + p2dt(jk) * pta(ji,jj,jk,jn)       ! total trends * 2*rdt  
    153                      pta(ji,jj,jk,jn) = ( ze3tb * ptb(ji,jj,jk,jn) + ztra ) * tmask(ji,jj,jk) 
    154                   END DO 
     134         DO jk = 1, jpkm1        !==  After tracer due to all trends 
     135            DO jj = 2, jpjm1  
     136               DO ji = fs_2, fs_jpim1   ! vector opt. 
     137                  ze3tb = e3t_b(ji,jj,jk) / e3t_n(ji,jj,jk) 
     138                  ztra  = ( ztb(ji,jj,jk) - ptb(ji,jj,jk,jn) ) + p2dt * pta(ji,jj,jk,jn)  ! total trend * 2dt  
     139                  pta(ji,jj,jk,jn) = ( ze3tb * ptb(ji,jj,jk,jn) + ztra ) * tmask(ji,jj,jk)    ! after tracer 
    155140               END DO 
    156141            END DO 
    157          ELSE                       ! fixed level thickness : leap-frog on tracers 
    158             DO jk = 1, jpkm1 
    159                DO jj = 2, jpjm1  
    160                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    161                      pta(ji,jj,jk,jn) = ( zwx(ji,jj,jk) + p2dt(jk) * pta(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 
    162                   END DO 
    163                END DO 
    164             END DO 
    165          ENDIF 
     142         END DO 
    166143         ! 
    167       END DO 
     144      END DO                     ! end of tracer loop 
    168145      ! 
    169       CALL wrk_dealloc( jpi, jpj, jpk, zwx, zwy )  
     146      CALL wrk_dealloc( jpi,jpj,jpk,   ztb, zwf )  
    170147      ! 
    171148      IF( nn_timing == 1 )  CALL timing_stop('tra_zdf_exp') 

  • branches/NERC/dev_r5549_BDY_ZEROGRAD/NEMOGCM/NEMO/OPA_SRC/TRA/trazdf_imp.F90

    r5120 r6808  
    1616   !!            3.3  !  2010-06  (C. Ethe, G. Madec) Merge TRA-TRC 
    1717   !!             -   !  2011-02  (A. Coward, C. Ethe, G. Madec) improvment of surface boundary condition 
     18   !!            3.7  !  2015-11  (G. Madec, A. Coward)  non linear free surface by default  
    1819   !!---------------------------------------------------------------------- 
    1920   
    2021   !!---------------------------------------------------------------------- 
    21    !!   tra_zdf_imp : Update the tracer trend with the diagonal vertical   
    22    !!                 part of the mixing tensor. 
    23    !!---------------------------------------------------------------------- 
    24    USE oce             ! ocean dynamics and tracers variables 
    25    USE dom_oce         ! ocean space and time domain variables  
    26    USE zdf_oce         ! ocean vertical physics variables 
    27    USE trc_oce         ! share passive tracers/ocean variables 
    28    USE domvvl          ! variable volume 
    29    USE ldftra_oce      ! ocean active tracers: lateral physics 
    30    USE ldftra          ! lateral mixing type 
    31    USE ldfslp          ! lateral physics: slope of diffusion 
    32    USE zdfddm          ! ocean vertical physics: double diffusion 
    33    USE traldf_iso_grif ! active tracers: Griffies operator 
    34    USE in_out_manager  ! I/O manager 
    35    USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    36    USE lib_mpp         ! MPP library 
    37    USE wrk_nemo        ! Memory Allocation 
    38    USE timing          ! Timing 
     22   !!   tra_zdf_imp   : Update the tracer trend with vertical mixing, nad compute the after tracer field 
     23   !!---------------------------------------------------------------------- 
     24   USE oce            ! ocean dynamics and tracers variables 
     25   USE dom_oce        ! ocean space and time domain variables  
     26   USE zdf_oce        ! ocean vertical physics variables 
     27   USE trc_oce        ! share passive tracers/ocean variables 
     28   USE domvvl         ! variable volume 
     29   USE ldftra         ! lateral mixing type 
     30   USE ldfslp         ! lateral physics: slope of diffusion 
     31   USE zdfddm         ! ocean vertical physics: double diffusion 
     32   USE traldf_triad   ! active tracers: Method of Stabilizing Correction 
     33   ! 
     34   USE in_out_manager ! I/O manager 
     35   USE lbclnk         ! ocean lateral boundary conditions (or mpp link) 
     36   USE lib_mpp        ! MPP library 
     37   USE wrk_nemo       ! Memory Allocation 
     38   USE timing         ! Timing 
    3939 
    4040   IMPLICIT NONE 
    … …  
    4343   PUBLIC   tra_zdf_imp   !  routine called by step.F90 
    4444 
    45    REAL(wp) ::  r_vvl     ! variable volume indicator, =1 if lk_vvl=T, =0 otherwise  
    46  
    4745   !! * Substitutions 
    48 #  include "domzgr_substitute.h90" 
    49 #  include "ldftra_substitute.h90" 
    5046#  include "zdfddm_substitute.h90" 
    5147#  include "vectopt_loop_substitute.h90" 
    5248   !!---------------------------------------------------------------------- 
    53    !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
     49   !! NEMO/OPA 3.7 , NEMO Consortium (2015) 
    5450   !! $Id$ 
    5551   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    … …  
    6662      !!     it is already computed and add to the general trend in traldf)  
    6763      !! 
    68       !! ** Method  :  The vertical diffusion of the tracer t  is given by: 
    69       !!                  difft = dz( avt dz(t) ) = 1/e3t dk+1( avt/e3w dk(t) ) 
    70       !!      It is computed using a backward time scheme (t=ta). 
     64      !! ** Method  :  The vertical diffusion of a tracer ,t , is given by: 
     65      !!          difft = dz( avt dz(t) ) = 1/e3t dk+1( avt/e3w dk(t) ) 
     66      !!      It is computed using a backward time scheme (t=after field) 
     67      !!      which provide directly the after tracer field. 
    7168      !!      If lk_zdfddm=T, use avs for salinity or for passive tracers 
    7269      !!      Surface and bottom boundary conditions: no diffusive flux on 
    … …  
    7673      !! ** Action  : - pta  becomes the after tracer 
    7774      !!--------------------------------------------------------------------- 
    78       USE oce     , ONLY:   zwd => ua       , zws => va         ! (ua,va) used as 3D workspace 
    79       ! 
    8075      INTEGER                              , INTENT(in   ) ::   kt       ! ocean time-step index 
    81       INTEGER                              , INTENT(in   ) ::   kit000          ! first time step index 
     76      INTEGER                              , INTENT(in   ) ::   kit000   ! first time step index 
    8277      CHARACTER(len=3)                     , INTENT(in   ) ::   cdtype   ! =TRA or TRC (tracer indicator) 
    8378      INTEGER                              , INTENT(in   ) ::   kjpt     ! number of tracers 
    84       REAL(wp), DIMENSION(        jpk     ), INTENT(in   ) ::   p2dt     ! vertical profile of tracer time-step 
     79      REAL(wp)                             , INTENT(in   ) ::   p2dt     ! tracer time-step 
    8580      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb      ! before and now tracer fields 
    86       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta      ! tracer trend  
     81      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta      ! in: tracer trend ; out: after tracer field 
    8782      ! 
    8883      INTEGER  ::  ji, jj, jk, jn   ! dummy loop indices 
    89       REAL(wp) ::  zrhs, ze3tb, ze3tn, ze3ta   ! local scalars 
    90       REAL(wp), POINTER, DIMENSION(:,:,:) ::  zwi, zwt 
     84      REAL(wp) ::  zrhs             ! local scalars 
     85      REAL(wp), POINTER, DIMENSION(:,:,:) ::  zwi, zwt, zwd, zws 
    9186      !!--------------------------------------------------------------------- 
    9287      ! 
    9388      IF( nn_timing == 1 )  CALL timing_start('tra_zdf_imp') 
    9489      ! 
    95       CALL wrk_alloc( jpi, jpj, jpk, zwi, zwt )  
     90      CALL wrk_alloc( jpi,jpj,jpk,   zwi, zwt, zwd, zws )  
    9691      ! 
    9792      IF( kt == kit000 )  THEN 
    … …  
    9994         IF(lwp)WRITE(numout,*) 'tra_zdf_imp : implicit vertical mixing on ', cdtype 
    10095         IF(lwp)WRITE(numout,*) '~~~~~~~~~~~ ' 
    101          ! 
    102          IF( lk_vvl ) THEN   ;    r_vvl = 1._wp       ! Variable volume indicator 
    103          ELSE                ;    r_vvl = 0._wp        
    104          ENDIF 
    10596      ENDIF 
    106       ! 
    10797      !                                               ! ============= ! 
    10898      DO jn = 1, kjpt                                 !  tracer loop  ! 
    10999         !                                            ! ============= ! 
    110          ! 
    111100         !  Matrix construction 
    112101         ! -------------------- 
    … …  
    120109            ELSE                                            ;   zwt(:,:,2:jpk) = fsavs(:,:,2:jpk) 
    121110            ENDIF 
    122             DO jj=1, jpj 
    123                DO ji=1, jpi 
    124                   zwt(ji,jj,1) = 0._wp 
    125                END DO 
    126             END DO 
    127 ! 
    128 #if defined key_ldfslp 
    129             ! isoneutral diffusion: add the contribution  
    130             IF( ln_traldf_grif    ) THEN     ! Griffies isoneutral diff 
    131                DO jk = 2, jpkm1 
    132                   DO jj = 2, jpjm1 
    133                      DO ji = fs_2, fs_jpim1   ! vector opt. 
    134                         zwt(ji,jj,jk) = zwt(ji,jj,jk) + ah_wslp2(ji,jj,jk)        
     111            zwt(:,:,1) = 0._wp 
     112            ! 
     113            IF( l_ldfslp ) THEN            ! isoneutral diffusion: add the contribution  
     114               IF( ln_traldf_msc  ) THEN     ! MSC iso-neutral operator  
     115                  DO jk = 2, jpkm1 
     116                     DO jj = 2, jpjm1 
     117                        DO ji = fs_2, fs_jpim1   ! vector opt. 
     118                           zwt(ji,jj,jk) = zwt(ji,jj,jk) + akz(ji,jj,jk)   
     119                        END DO 
    135120                     END DO 
    136121                  END DO 
    137                END DO 
    138             ELSE IF( l_traldf_rot ) THEN     ! standard isoneutral diff 
    139                DO jk = 2, jpkm1 
    140                   DO jj = 2, jpjm1 
    141                      DO ji = fs_2, fs_jpim1   ! vector opt. 
    142                         zwt(ji,jj,jk) = zwt(ji,jj,jk) + fsahtw(ji,jj,jk)                       & 
    143                            &                          * (  wslpi(ji,jj,jk) * wslpi(ji,jj,jk)   & 
    144                            &                             + wslpj(ji,jj,jk) * wslpj(ji,jj,jk)  ) 
     122               ELSE                          ! standard or triad iso-neutral operator 
     123                  DO jk = 2, jpkm1 
     124                     DO jj = 2, jpjm1 
     125                        DO ji = fs_2, fs_jpim1   ! vector opt. 
     126                           zwt(ji,jj,jk) = zwt(ji,jj,jk) + ah_wslp2(ji,jj,jk) 
     127                        END DO 
    145128                     END DO 
    146129                  END DO 
    147                END DO 
     130               ENDIF 
    148131            ENDIF 
    149 #endif 
     132            ! 
    150133            ! Diagonal, lower (i), upper (s)  (including the bottom boundary condition since avt is masked) 
    151134            DO jk = 1, jpkm1 
    152135               DO jj = 2, jpjm1 
    153136                  DO ji = fs_2, fs_jpim1   ! vector opt. 
    154                      ze3ta =  ( 1. - r_vvl ) +        r_vvl   * fse3t_a(ji,jj,jk)   ! after scale factor at T-point 
    155                      ze3tn =         r_vvl   + ( 1. - r_vvl ) * fse3t_n(ji,jj,jk)   ! now   scale factor at T-point 
    156                      zwi(ji,jj,jk) = - p2dt(jk) * zwt(ji,jj,jk  ) / ( ze3tn * fse3w(ji,jj,jk  ) ) 
    157                      zws(ji,jj,jk) = - p2dt(jk) * zwt(ji,jj,jk+1) / ( ze3tn * fse3w(ji,jj,jk+1) ) 
    158                      zwd(ji,jj,jk) = ze3ta - zwi(ji,jj,jk) - zws(ji,jj,jk) 
     137!!gm BUG  I think, use e3w_a instead of e3w_n 
     138                     zwi(ji,jj,jk) = - p2dt * zwt(ji,jj,jk  ) / e3w_n(ji,jj,jk  ) 
     139                     zws(ji,jj,jk) = - p2dt * zwt(ji,jj,jk+1) / e3w_n(ji,jj,jk+1) 
     140                     zwd(ji,jj,jk) = e3t_a(ji,jj,jk) - zwi(ji,jj,jk) - zws(ji,jj,jk) 
    159141                 END DO 
    160142               END DO 
    … …  
    180162            !   used as a work space array: its value is modified. 
    181163            ! 
    182             ! first recurrence:   Tk = Dk - Ik Sk-1 / Tk-1   (increasing k) 
    183             ! done once for all passive tracers (so included in the IF instruction) 
    184             DO jj = 2, jpjm1 
    185                DO ji = fs_2, fs_jpim1 
     164            DO jj = 2, jpjm1        !* 1st recurrence:   Tk = Dk - Ik Sk-1 / Tk-1   (increasing k) 
     165               DO ji = fs_2, fs_jpim1            ! done one for all passive tracers (so included in the IF instruction) 
    186166                  zwt(ji,jj,1) = zwd(ji,jj,1) 
    187167               END DO 
    … …  
    195175            END DO 
    196176            ! 
    197          END IF  
     177         ENDIF  
    198178         !          
    199          ! second recurrence:    Zk = Yk - Ik / Tk-1  Zk-1 
    200          DO jj = 2, jpjm1 
     179         DO jj = 2, jpjm1           !* 2nd recurrence:    Zk = Yk - Ik / Tk-1  Zk-1 
    201180            DO ji = fs_2, fs_jpim1 
    202                ze3tb = ( 1. - r_vvl ) + r_vvl * fse3t_b(ji,jj,1) 
    203                ze3tn = ( 1. - r_vvl ) + r_vvl * fse3t(ji,jj,1) 
    204                pta(ji,jj,1,jn) = ze3tb * ptb(ji,jj,1,jn)                     & 
    205                   &                      + p2dt(1) * ze3tn * pta(ji,jj,1,jn) 
     181               pta(ji,jj,1,jn) = e3t_b(ji,jj,1) * ptb(ji,jj,1,jn) + p2dt * e3t_n(ji,jj,1) * pta(ji,jj,1,jn) 
    206182            END DO 
    207183         END DO 
    … …  
    209185            DO jj = 2, jpjm1 
    210186               DO ji = fs_2, fs_jpim1 
    211                   ze3tb = ( 1. - r_vvl ) + r_vvl * fse3t_b(ji,jj,jk) 
    212                   ze3tn = ( 1. - r_vvl ) + r_vvl * fse3t  (ji,jj,jk) 
    213                   zrhs = ze3tb * ptb(ji,jj,jk,jn) + p2dt(jk) * ze3tn * pta(ji,jj,jk,jn)   ! zrhs=right hand side  
     187                  zrhs = e3t_b(ji,jj,jk) * ptb(ji,jj,jk,jn) + p2dt * e3t_n(ji,jj,jk) * pta(ji,jj,jk,jn)   ! zrhs=right hand side 
    214188                  pta(ji,jj,jk,jn) = zrhs - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) * pta(ji,jj,jk-1,jn) 
    215189               END DO 
    216190            END DO 
    217191         END DO 
    218  
    219          ! third recurrence:    Xk = (Zk - Sk Xk+1 ) / Tk   (result is the after tracer) 
    220          DO jj = 2, jpjm1 
     192         ! 
     193         DO jj = 2, jpjm1           !* 3d recurrence:    Xk = (Zk - Sk Xk+1 ) / Tk   (result is the after tracer) 
    221194            DO ji = fs_2, fs_jpim1 
    222195               pta(ji,jj,jpkm1,jn) = pta(ji,jj,jpkm1,jn) / zwt(ji,jj,jpkm1) * tmask(ji,jj,jpkm1) 
    … …  
    235208      !                                               ! ================= ! 
    236209      ! 
    237       CALL wrk_dealloc( jpi, jpj, jpk, zwi, zwt )  
     210      CALL wrk_dealloc( jpi,jpj,jpk,   zwi, zwt, zwd, zws )  
    238211      ! 
    239212      IF( nn_timing == 1 )  CALL timing_stop('tra_zdf_imp') 

  • branches/NERC/dev_r5549_BDY_ZEROGRAD/NEMOGCM/NEMO/OPA_SRC/TRA/zpshde.F90

    r5120 r6808  
    3232 
    3333   !! * Substitutions 
    34 #  include "domzgr_substitute.h90" 
    3534#  include "vectopt_loop_substitute.h90" 
    3635   !!---------------------------------------------------------------------- 
    … …  
    9392      REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pgru, pgrv  ! hor. grad of prd at u- & v-pts (bottom) 
    9493      ! 
    95       INTEGER  ::   ji, jj, jn      ! Dummy loop indices 
    96       INTEGER  ::   iku, ikv, ikum1, ikvm1   ! partial step level (ocean bottom level) at u- and v-points 
    97       REAL(wp) ::  ze3wu, ze3wv, zmaxu, zmaxv  ! temporary scalars 
    98       REAL(wp), DIMENSION(jpi,jpj)      ::  zri, zrj, zhi, zhj   ! NB: 3rd dim=1 to use eos 
    99       REAL(wp), DIMENSION(jpi,jpj,kjpt) ::  zti, ztj             !  
    100       !!---------------------------------------------------------------------- 
    101       ! 
    102       IF( nn_timing == 1 )  CALL timing_start( 'zps_hde') 
    103       ! 
    104       pgtu(:,:,:)=0.0_wp ; pgtv(:,:,:)=0.0_wp ; 
    105       zti (:,:,:)=0.0_wp ; ztj (:,:,:)=0.0_wp ; 
    106       zhi (:,:  )=0.0_wp ; zhj (:,:  )=0.0_wp ; 
     94      INTEGER  ::   ji, jj, jn                  ! Dummy loop indices 
     95      INTEGER  ::   iku, ikv, ikum1, ikvm1      ! partial step level (ocean bottom level) at u- and v-points 
     96      REAL(wp) ::   ze3wu, ze3wv, zmaxu, zmaxv  ! local scalars 
     97      REAL(wp), DIMENSION(jpi,jpj)      ::   zri, zrj, zhi, zhj   ! NB: 3rd dim=1 to use eos 
     98      REAL(wp), DIMENSION(jpi,jpj,kjpt) ::   zti, ztj             !  
     99      !!---------------------------------------------------------------------- 
     100      ! 
     101      IF( nn_timing == 1 )   CALL timing_start( 'zps_hde') 
     102      ! 
     103      pgtu(:,:,:)=0._wp   ;   zti (:,:,:)=0._wp   ;   zhi (:,:  )=0._wp 
     104      pgtv(:,:,:)=0._wp   ;   ztj (:,:,:)=0._wp   ;   zhj (:,:  )=0._wp 
    107105      ! 
    108106      DO jn = 1, kjpt      !==   Interpolation of tracers at the last ocean level   ==! 
    … …  
    112110               iku = mbku(ji,jj)   ;   ikum1 = MAX( iku - 1 , 1 )    ! last and before last ocean level at u- & v-points 
    113111               ikv = mbkv(ji,jj)   ;   ikvm1 = MAX( ikv - 1 , 1 )    ! if level first is a p-step, ik.m1=1 
    114                ze3wu = fse3w(ji+1,jj  ,iku) - fse3w(ji,jj,iku) 
    115                ze3wv = fse3w(ji  ,jj+1,ikv) - fse3w(ji,jj,ikv) 
     112!!gm BUG ? when applied to before fields, e3w_b should be used.... 
     113               ze3wu = e3w_n(ji+1,jj  ,iku) - e3w_n(ji,jj,iku) 
     114               ze3wv = e3w_n(ji  ,jj+1,ikv) - e3w_n(ji,jj,ikv) 
    116115               ! 
    117116               ! i- direction 
    118117               IF( ze3wu >= 0._wp ) THEN      ! case 1 
    119                   zmaxu =  ze3wu / fse3w(ji+1,jj,iku) 
     118                  zmaxu =  ze3wu / e3w_n(ji+1,jj,iku) 
    120119                  ! interpolated values of tracers 
    121120                  zti (ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,ikum1,jn) - pta(ji+1,jj,iku,jn) ) 
    … …  
    123122                  pgtu(ji,jj,jn) = umask(ji,jj,1) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) ) 
    124123               ELSE                           ! case 2 
    125                   zmaxu = -ze3wu / fse3w(ji,jj,iku) 
     124                  zmaxu = -ze3wu / e3w_n(ji,jj,iku) 
    126125                  ! interpolated values of tracers 
    127126                  zti (ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,ikum1,jn) - pta(ji,jj,iku,jn) ) 
    … …  
    132131               ! j- direction 
    133132               IF( ze3wv >= 0._wp ) THEN      ! case 1 
    134                   zmaxv =  ze3wv / fse3w(ji,jj+1,ikv) 
     133                  zmaxv =  ze3wv / e3w_n(ji,jj+1,ikv) 
    135134                  ! interpolated values of tracers 
    136135                  ztj (ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikvm1,jn) - pta(ji,jj+1,ikv,jn) ) 
    … …  
    138137                  pgtv(ji,jj,jn) = vmask(ji,jj,1) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) ) 
    139138               ELSE                           ! case 2 
    140                   zmaxv =  -ze3wv / fse3w(ji,jj,ikv) 
     139                  zmaxv =  -ze3wv / e3w_n(ji,jj,ikv) 
    141140                  ! interpolated values of tracers 
    142141                  ztj (ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikvm1,jn) - pta(ji,jj,ikv,jn) ) 
    … …  
    149148         ! 
    150149      END DO 
    151  
    152       ! horizontal derivative of density anomalies (rd) 
    153       IF( PRESENT( prd ) ) THEN         ! depth of the partial step level 
    154          pgru(:,:)=0.0_wp   ; pgrv(:,:)=0.0_wp ;  
     150      !                 
     151      IF( PRESENT( prd ) ) THEN    !==  horizontal derivative of density anomalies (rd)  ==!    (optional part) 
     152         pgru(:,:) = 0._wp 
     153         pgrv(:,:) = 0._wp                ! depth of the partial step level 
    155154         DO jj = 1, jpjm1 
    156155            DO ji = 1, jpim1 
    157156               iku = mbku(ji,jj) 
    158157               ikv = mbkv(ji,jj) 
    159                ze3wu  = fse3w(ji+1,jj  ,iku) - fse3w(ji,jj,iku) 
    160                ze3wv  = fse3w(ji  ,jj+1,ikv) - fse3w(ji,jj,ikv) 
    161                IF( ze3wu >= 0._wp ) THEN   ;   zhi(ji,jj) = fsdept(ji  ,jj,iku)     ! i-direction: case 1 
    162                ELSE                        ;   zhi(ji,jj) = fsdept(ji+1,jj,iku)     ! -     -      case 2 
    163                ENDIF 
    164                IF( ze3wv >= 0._wp ) THEN   ;   zhj(ji,jj) = fsdept(ji,jj  ,ikv)     ! j-direction: case 1 
    165                ELSE                        ;   zhj(ji,jj) = fsdept(ji,jj+1,ikv)     ! -     -      case 2 
    166                ENDIF 
    167             END DO 
    168          END DO 
    169  
    170          ! Compute interpolated rd from zti, ztj for the 2 cases at the depth of the partial 
    171          ! step and store it in  zri, zrj for each  case 
    172          CALL eos( zti, zhi, zri )   
    173          CALL eos( ztj, zhj, zrj ) 
    174  
    175          ! Gradient of density at the last level  
    176          DO jj = 1, jpjm1 
     158               ze3wu  = e3w_n(ji+1,jj  ,iku) - e3w_n(ji,jj,iku) 
     159               ze3wv  = e3w_n(ji  ,jj+1,ikv) - e3w_n(ji,jj,ikv) 
     160               IF( ze3wu >= 0._wp ) THEN   ;   zhi(ji,jj) = gdept_n(ji  ,jj,iku)     ! i-direction: case 1 
     161               ELSE                        ;   zhi(ji,jj) = gdept_n(ji+1,jj,iku)     ! -     -      case 2 
     162               ENDIF 
     163               IF( ze3wv >= 0._wp ) THEN   ;   zhj(ji,jj) = gdept_n(ji,jj  ,ikv)     ! j-direction: case 1 
     164               ELSE                        ;   zhj(ji,jj) = gdept_n(ji,jj+1,ikv)     ! -     -      case 2 
     165               ENDIF 
     166            END DO 
     167         END DO 
     168         ! 
     169         CALL eos( zti, zhi, zri )        ! interpolated density from zti, ztj  
     170         CALL eos( ztj, zhj, zrj )        ! at the partial step depth output in  zri, zrj  
     171         ! 
     172         DO jj = 1, jpjm1                 ! Gradient of density at the last level  
    177173            DO ji = 1, jpim1 
    178174               iku = mbku(ji,jj) 
    179175               ikv = mbkv(ji,jj) 
    180                ze3wu  = fse3w(ji+1,jj  ,iku) - fse3w(ji,jj,iku) 
    181                ze3wv  = fse3w(ji  ,jj+1,ikv) - fse3w(ji,jj,ikv) 
     176               ze3wu  = e3w_n(ji+1,jj  ,iku) - e3w_n(ji,jj,iku) 
     177               ze3wv  = e3w_n(ji  ,jj+1,ikv) - e3w_n(ji,jj,ikv) 
    182178               IF( ze3wu >= 0._wp ) THEN   ;   pgru(ji,jj) = umask(ji,jj,1) * ( zri(ji  ,jj    ) - prd(ji,jj,iku) )   ! i: 1 
    183179               ELSE                        ;   pgru(ji,jj) = umask(ji,jj,1) * ( prd(ji+1,jj,iku) - zri(ji,jj    ) )   ! i: 2 
    … …  
    192188      END IF 
    193189      ! 
    194       IF( nn_timing == 1 )  CALL timing_stop( 'zps_hde') 
     190      IF( nn_timing == 1 )   CALL timing_stop( 'zps_hde') 
    195191      ! 
    196192   END SUBROUTINE zps_hde 
    197193   ! 
    198    SUBROUTINE zps_hde_isf( kt, kjpt, pta, pgtu, pgtv,   & 
    199       &                          prd, pgru, pgrv, pmru, pmrv, pgzu, pgzv, pge3ru, pge3rv,  & 
    200       &                   pgtui, pgtvi, pgrui, pgrvi, pmrui, pmrvi, pgzui, pgzvi, pge3rui, pge3rvi ) 
    201       !!---------------------------------------------------------------------- 
    202       !!                     ***  ROUTINE zps_hde  *** 
     194   SUBROUTINE zps_hde_isf( kt, kjpt, pta, pgtu, pgtv, pgtui, pgtvi,  & 
     195      &                          prd, pgru, pgrv, pgrui, pgrvi ) 
     196      !!---------------------------------------------------------------------- 
     197      !!                     ***  ROUTINE zps_hde_isf  *** 
    203198      !!                     
    204199      !! ** Purpose :   Compute the horizontal derivative of T, S and rho 
    205200      !!      at u- and v-points with a linear interpolation for z-coordinate 
    206       !!      with partial steps. 
     201      !!      with partial steps for top (ice shelf) and bottom. 
    207202      !! 
    208203      !! ** Method  :   In z-coord with partial steps, scale factors on last  
    209204      !!      levels are different for each grid point, so that T, S and rd  
    210205      !!      points are not at the same depth as in z-coord. To have horizontal 
    211       !!      gradients again, we interpolate T and S at the good depth :  
     206      !!      gradients again, we interpolate T and S at the good depth : 
     207      !!      For the bottom case: 
    212208      !!      Linear interpolation of T, S    
    213209      !!         Computation of di(tb) and dj(tb) by vertical interpolation: 
    … …  
    238234      !!          di(rho) = rd~ - rd(i,j,k)   or   rd(i+1,j,k) - rd~ 
    239235      !! 
     236      !!      For the top case (ice shelf): As for the bottom case but upside down 
     237      !! 
    240238      !! ** Action  : compute for top and bottom interfaces 
    241239      !!              - pgtu, pgtv, pgtui, pgtvi: horizontal gradient of tracer at u- & v-points 
    242240      !!              - pgru, pgrv, pgrui, pgtvi: horizontal gradient of rho (if present) at u- & v-points 
    243       !!              - pmru, pmrv, pmrui, pmrvi: horizontal sum of rho at u- & v- point (used in dynhpg with vvl) 
    244       !!              - pgzu, pgzv, pgzui, pgzvi: horizontal gradient of z at u- and v- point (used in dynhpg with vvl) 
    245       !!              - pge3ru, pge3rv, pge3rui, pge3rvi: horizontal gradient of rho weighted by local e3w at u- & v-points  
    246       !!---------------------------------------------------------------------- 
    247       INTEGER                              , INTENT(in   )           ::  kt          ! ocean time-step index 
    248       INTEGER                              , INTENT(in   )           ::  kjpt        ! number of tracers 
    249       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   )           ::  pta         ! 4D tracers fields 
    250       REAL(wp), DIMENSION(jpi,jpj,    kjpt), INTENT(  out)           ::  pgtu, pgtv  ! hor. grad. of ptra at u- & v-pts  
    251       REAL(wp), DIMENSION(jpi,jpj,    kjpt), INTENT(  out)           ::  pgtui, pgtvi  ! hor. grad. of stra at u- & v-pts (ISF) 
    252       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ), OPTIONAL ::  prd         ! 3D density anomaly fields 
    253       REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pgru, pgrv      ! hor. grad of prd at u- & v-pts (bottom) 
    254       REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pmru, pmrv      ! hor. sum  of prd at u- & v-pts (bottom) 
    255       REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pgzu, pgzv      ! hor. grad of z   at u- & v-pts (bottom) 
    256       REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pge3ru, pge3rv  ! hor. grad of prd weighted by local e3w at u- & v-pts (bottom) 
    257       REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pgrui, pgrvi      ! hor. grad of prd at u- & v-pts (top) 
    258       REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pmrui, pmrvi      ! hor. sum  of prd at u- & v-pts (top) 
    259       REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pgzui, pgzvi      ! hor. grad of z   at u- & v-pts (top) 
    260       REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pge3rui, pge3rvi  ! hor. grad of prd weighted by local e3w at u- & v-pts (top) 
     241      !!---------------------------------------------------------------------- 
     242      INTEGER                              , INTENT(in   )           ::  kt           ! ocean time-step index 
     243      INTEGER                              , INTENT(in   )           ::  kjpt         ! number of tracers 
     244      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   )           ::  pta          ! 4D tracers fields 
     245      REAL(wp), DIMENSION(jpi,jpj,    kjpt), INTENT(  out)           ::  pgtu, pgtv   ! hor. grad. of ptra at u- & v-pts  
     246      REAL(wp), DIMENSION(jpi,jpj,    kjpt), INTENT(  out)           ::  pgtui, pgtvi ! hor. grad. of stra at u- & v-pts (ISF) 
     247      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ), OPTIONAL ::  prd          ! 3D density anomaly fields 
     248      REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pgru, pgrv   ! hor. grad of prd at u- & v-pts (bottom) 
     249      REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pgrui, pgrvi ! hor. grad of prd at u- & v-pts (top) 
    261250      ! 
    262251      INTEGER  ::   ji, jj, jn      ! Dummy loop indices 
    263252      INTEGER  ::   iku, ikv, ikum1, ikvm1,ikup1, ikvp1   ! partial step level (ocean bottom level) at u- and v-points 
    264       REAL(wp) ::  ze3wu, ze3wv, zmaxu, zmaxv, zdzwu, zdzwv, zdzwuip1, zdzwvjp1  ! temporary scalars 
     253      REAL(wp) ::  ze3wu, ze3wv, zmaxu, zmaxv             ! temporary scalars 
    265254      REAL(wp), DIMENSION(jpi,jpj)      ::  zri, zrj, zhi, zhj   ! NB: 3rd dim=1 to use eos 
    266255      REAL(wp), DIMENSION(jpi,jpj,kjpt) ::  zti, ztj             !  
    … …  
    269258      IF( nn_timing == 1 )  CALL timing_start( 'zps_hde_isf') 
    270259      ! 
    271       pgtu(:,:,:)=0.0_wp ; pgtv(:,:,:)=0.0_wp ; 
    272       pgtui(:,:,:)=0.0_wp ; pgtvi(:,:,:)=0.0_wp ; 
    273       zti (:,:,:)=0.0_wp ; ztj (:,:,:)=0.0_wp ; 
    274       zhi (:,:  )=0.0_wp ; zhj (:,:  )=0.0_wp ; 
     260      pgtu (:,:,:) = 0._wp   ;   pgtv (:,:,:) =0._wp 
     261      pgtui(:,:,:) = 0._wp   ;   pgtvi(:,:,:) =0._wp 
     262      zti  (:,:,:) = 0._wp   ;   ztj  (:,:,:) =0._wp 
     263      zhi  (:,:  ) = 0._wp   ;   zhj  (:,:  ) =0._wp 
    275264      ! 
    276265      DO jn = 1, kjpt      !==   Interpolation of tracers at the last ocean level   ==! 
    … …  
    278267         DO jj = 1, jpjm1 
    279268            DO ji = 1, jpim1 
    280                iku = mbku(ji,jj)   ;   ikum1 = MAX( iku - 1 , 1 )    ! last and before last ocean level at u- & v-points 
    281                ikv = mbkv(ji,jj)   ;   ikvm1 = MAX( ikv - 1 , 1 )    ! if level first is a p-step, ik.m1=1 
     269 
     270               iku = mbku(ji,jj); ikum1 = MAX( iku - 1 , 1 )    ! last and before last ocean level at u- & v-points 
     271               ikv = mbkv(ji,jj); ikvm1 = MAX( ikv - 1 , 1 )    ! if level first is a p-step, ik.m1=1 
     272               ze3wu = gdept_n(ji+1,jj,iku) - gdept_n(ji,jj,iku) 
     273               ze3wv = gdept_n(ji,jj+1,ikv) - gdept_n(ji,jj,ikv) 
     274               ! 
     275               ! i- direction 
     276               IF( ze3wu >= 0._wp ) THEN      ! case 1 
     277                  zmaxu =  ze3wu / e3w_n(ji+1,jj,iku) 
     278                  ! interpolated values of tracers 
     279                  zti (ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,ikum1,jn) - pta(ji+1,jj,iku,jn) ) 
     280                  ! gradient of  tracers 
     281                  pgtu(ji,jj,jn) = ssumask(ji,jj) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) ) 
     282               ELSE                           ! case 2 
     283                  zmaxu = -ze3wu / e3w_n(ji,jj,iku) 
     284                  ! interpolated values of tracers 
     285                  zti (ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,ikum1,jn) - pta(ji,jj,iku,jn) ) 
     286                  ! gradient of tracers 
     287                  pgtu(ji,jj,jn) = ssumask(ji,jj) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) ) 
     288               ENDIF 
     289               ! 
     290               ! j- direction 
     291               IF( ze3wv >= 0._wp ) THEN      ! case 1 
     292                  zmaxv =  ze3wv / e3w_n(ji,jj+1,ikv) 
     293                  ! interpolated values of tracers 
     294                  ztj (ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikvm1,jn) - pta(ji,jj+1,ikv,jn) ) 
     295                  ! gradient of tracers 
     296                  pgtv(ji,jj,jn) = ssvmask(ji,jj) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) ) 
     297               ELSE                           ! case 2 
     298                  zmaxv =  -ze3wv / e3w_n(ji,jj,ikv) 
     299                  ! interpolated values of tracers 
     300                  ztj (ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikvm1,jn) - pta(ji,jj,ikv,jn) ) 
     301                  ! gradient of tracers 
     302                  pgtv(ji,jj,jn) = ssvmask(ji,jj) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) ) 
     303               ENDIF 
     304 
     305            END DO 
     306         END DO 
     307         CALL lbc_lnk( pgtu(:,:,jn), 'U', -1. )   ;   CALL lbc_lnk( pgtv(:,:,jn), 'V', -1. )   ! Lateral boundary cond. 
     308         ! 
     309      END DO 
     310 
     311      ! horizontal derivative of density anomalies (rd) 
     312      IF( PRESENT( prd ) ) THEN         ! depth of the partial step level 
     313         pgru(:,:)=0.0_wp   ; pgrv(:,:)=0.0_wp ;  
     314         ! 
     315         DO jj = 1, jpjm1 
     316            DO ji = 1, jpim1 
     317 
     318               iku = mbku(ji,jj) 
     319               ikv = mbkv(ji,jj) 
     320               ze3wu = gdept_n(ji+1,jj,iku) - gdept_n(ji,jj,iku) 
     321               ze3wv = gdept_n(ji,jj+1,ikv) - gdept_n(ji,jj,ikv) 
     322               ! 
     323               IF( ze3wu >= 0._wp ) THEN   ;   zhi(ji,jj) = gdept_n(ji  ,jj,iku)    ! i-direction: case 1 
     324               ELSE                        ;   zhi(ji,jj) = gdept_n(ji+1,jj,iku)    ! -     -      case 2 
     325               ENDIF 
     326               IF( ze3wv >= 0._wp ) THEN   ;   zhj(ji,jj) = gdept_n(ji,jj  ,ikv)    ! j-direction: case 1 
     327               ELSE                        ;   zhj(ji,jj) = gdept_n(ji,jj+1,ikv)    ! -     -      case 2 
     328               ENDIF 
     329 
     330            END DO 
     331         END DO 
     332 
     333         ! Compute interpolated rd from zti, ztj for the 2 cases at the depth of the partial 
     334         ! step and store it in  zri, zrj for each  case 
     335         CALL eos( zti, zhi, zri ) 
     336         CALL eos( ztj, zhj, zrj ) 
     337 
     338         DO jj = 1, jpjm1                 ! Gradient of density at the last level  
     339            DO ji = 1, jpim1 
     340               iku = mbku(ji,jj) 
     341               ikv = mbkv(ji,jj) 
     342               ze3wu = gdept_n(ji+1,jj,iku) - gdept_n(ji,jj,iku) 
     343               ze3wv = gdept_n(ji,jj+1,ikv) - gdept_n(ji,jj,ikv) 
     344 
     345               IF( ze3wu >= 0._wp ) THEN   ;   pgru(ji,jj) = ssumask(ji,jj) * ( zri(ji  ,jj    ) - prd(ji,jj,iku) )   ! i: 1 
     346               ELSE                        ;   pgru(ji,jj) = ssumask(ji,jj) * ( prd(ji+1,jj,iku) - zri(ji,jj    ) )   ! i: 2 
     347               ENDIF 
     348               IF( ze3wv >= 0._wp ) THEN   ;   pgrv(ji,jj) = ssvmask(ji,jj) * ( zrj(ji,jj      ) - prd(ji,jj,ikv) )   ! j: 1 
     349               ELSE                        ;   pgrv(ji,jj) = ssvmask(ji,jj) * ( prd(ji,jj+1,ikv) - zrj(ji,jj    ) )   ! j: 2 
     350               ENDIF 
     351 
     352            END DO 
     353         END DO 
     354 
     355         CALL lbc_lnk( pgru , 'U', -1. )   ;   CALL lbc_lnk( pgrv , 'V', -1. )   ! Lateral boundary conditions 
     356         ! 
     357      END IF 
     358      ! 
     359      !     !==  (ISH)  compute grui and gruvi  ==! 
     360      ! 
     361      DO jn = 1, kjpt      !==   Interpolation of tracers at the last ocean level   ==!            ! 
     362         DO jj = 1, jpjm1 
     363            DO ji = 1, jpim1 
     364               iku = miku(ji,jj); ikup1 = miku(ji,jj) + 1 
     365               ikv = mikv(ji,jj); ikvp1 = mikv(ji,jj) + 1 
     366               ! 
    282367               ! (ISF) case partial step top and bottom in adjacent cell in vertical 
    283368               ! cannot used e3w because if 2 cell water column, we have ps at top and bottom 
    284369               ! in this case e3w(i,j) - e3w(i,j+1) is not the distance between Tj~ and Tj 
    285370               ! the only common depth between cells (i,j) and (i,j+1) is gdepw_0 
    286                ze3wu  = (gdept_0(ji+1,jj,iku) - gdepw_0(ji+1,jj,iku)) - (gdept_0(ji,jj,iku) - gdepw_0(ji,jj,iku)) 
    287                ze3wv  = (gdept_0(ji,jj+1,ikv) - gdepw_0(ji,jj+1,ikv)) - (gdept_0(ji,jj,ikv) - gdepw_0(ji,jj,ikv)) 
    288                ! 
     371               ze3wu  =  gdept_n(ji,jj,iku) - gdept_n(ji+1,jj,iku) 
     372               ze3wv  =  gdept_n(ji,jj,ikv) - gdept_n(ji,jj+1,ikv)  
     373 
    289374               ! i- direction 
    290375               IF( ze3wu >= 0._wp ) THEN      ! case 1 
    291                   zmaxu =  ze3wu / fse3w(ji+1,jj,iku) 
    292                   ! interpolated values of tracers 
    293                   zti (ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,ikum1,jn) - pta(ji+1,jj,iku,jn) ) 
     376                  zmaxu = ze3wu / e3w_n(ji+1,jj,ikup1) 
     377                  ! interpolated values of tracers 
     378                  zti(ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,ikup1,jn) - pta(ji+1,jj,iku,jn) ) 
     379                  ! gradient of tracers 
     380                  pgtui(ji,jj,jn) = ssumask(ji,jj) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) ) 
     381               ELSE                           ! case 2 
     382                  zmaxu = - ze3wu / e3w_n(ji,jj,ikup1) 
     383                  ! interpolated values of tracers 
     384                  zti(ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,ikup1,jn) - pta(ji,jj,iku,jn) ) 
    294385                  ! gradient of  tracers 
    295                   pgtu(ji,jj,jn) = umask(ji,jj,iku) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) ) 
    296                ELSE                           ! case 2 
    297                   zmaxu = -ze3wu / fse3w(ji,jj,iku) 
    298                   ! interpolated values of tracers 
    299                   zti (ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,ikum1,jn) - pta(ji,jj,iku,jn) ) 
    300                   ! gradient of tracers 
    301                   pgtu(ji,jj,jn) = umask(ji,jj,iku) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) ) 
     386                  pgtui(ji,jj,jn) = ssumask(ji,jj) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) ) 
    302387               ENDIF 
    303388               ! 
    304389               ! j- direction 
    305390               IF( ze3wv >= 0._wp ) THEN      ! case 1 
    306                   zmaxv =  ze3wv / fse3w(ji,jj+1,ikv) 
    307                   ! interpolated values of tracers 
    308                   ztj (ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikvm1,jn) - pta(ji,jj+1,ikv,jn) ) 
    309                   ! gradient of tracers 
    310                   pgtv(ji,jj,jn) = vmask(ji,jj,ikv) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) ) 
    311                ELSE                           ! case 2 
    312                   zmaxv =  -ze3wv / fse3w(ji,jj,ikv) 
    313                   ! interpolated values of tracers 
    314                   ztj (ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikvm1,jn) - pta(ji,jj,ikv,jn) ) 
    315                   ! gradient of tracers 
    316                   pgtv(ji,jj,jn) = vmask(ji,jj,ikv) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) ) 
    317                ENDIF 
    318             END DO 
    319          END DO 
    320          CALL lbc_lnk( pgtu(:,:,jn), 'U', -1. )   ;   CALL lbc_lnk( pgtv(:,:,jn), 'V', -1. )   ! Lateral boundary cond. 
     391                  zmaxv =  ze3wv / e3w_n(ji,jj+1,ikvp1) 
     392                  ! interpolated values of tracers 
     393                  ztj(ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikvp1,jn) - pta(ji,jj+1,ikv,jn) ) 
     394                  ! gradient of tracers 
     395                  pgtvi(ji,jj,jn) = ssvmask(ji,jj) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) ) 
     396               ELSE                           ! case 2 
     397                  zmaxv =  - ze3wv / e3w_n(ji,jj,ikvp1) 
     398                  ! interpolated values of tracers 
     399                  ztj(ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikvp1,jn) - pta(ji,jj,ikv,jn) ) 
     400                  ! gradient of tracers 
     401                  pgtvi(ji,jj,jn) = ssvmask(ji,jj) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) ) 
     402               ENDIF 
     403 
     404            END DO 
     405         END DO 
     406         CALL lbc_lnk( pgtui(:,:,jn), 'U', -1. ); CALL lbc_lnk( pgtvi(:,:,jn), 'V', -1. )   ! Lateral boundary cond. 
    321407         ! 
    322408      END DO 
    323409 
    324       ! horizontal derivative of density anomalies (rd) 
    325       IF( PRESENT( prd ) ) THEN         ! depth of the partial step level 
    326          pgru(:,:)=0.0_wp   ; pgrv(:,:)=0.0_wp ;  
    327          pgzu(:,:)=0.0_wp   ; pgzv(:,:)=0.0_wp ; 
    328          pmru(:,:)=0.0_wp   ; pmru(:,:)=0.0_wp ; 
    329          pge3ru(:,:)=0.0_wp ; pge3rv(:,:)=0.0_wp ; 
    330          DO jj = 1, jpjm1 
    331             DO ji = 1, jpim1 
    332                iku = mbku(ji,jj) 
    333                ikv = mbkv(ji,jj) 
    334                ze3wu  = (gdept_0(ji+1,jj,iku) - gdepw_0(ji+1,jj,iku)) - (gdept_0(ji,jj,iku) - gdepw_0(ji,jj,iku)) 
    335                ze3wv  = (gdept_0(ji,jj+1,ikv) - gdepw_0(ji,jj+1,ikv)) - (gdept_0(ji,jj,ikv) - gdepw_0(ji,jj,ikv)) 
    336  
    337                IF( ze3wu >= 0._wp ) THEN   ;   zhi(ji,jj) = fsdept(ji+1,jj,iku) - ze3wu     ! i-direction: case 1 
    338                ELSE                        ;   zhi(ji,jj) = fsdept(ji  ,jj,iku) + ze3wu    ! -     -      case 2 
    339                ENDIF 
    340                IF( ze3wv >= 0._wp ) THEN   ;   zhj(ji,jj) = fsdept(ji,jj+1,ikv) - ze3wv    ! j-direction: case 1 
    341                ELSE                        ;   zhj(ji,jj) = fsdept(ji,jj  ,ikv) + ze3wv    ! -     -      case 2 
    342                ENDIF 
    343             END DO 
    344          END DO 
    345           
    346          ! Compute interpolated rd from zti, ztj for the 2 cases at the depth of the partial 
    347          ! step and store it in  zri, zrj for each  case 
    348          CALL eos( zti, zhi, zri )   
    349          CALL eos( ztj, zhj, zrj ) 
    350  
    351          ! Gradient of density at the last level  
    352          DO jj = 1, jpjm1 
    353             DO ji = 1, jpim1 
    354                iku = mbku(ji,jj) ; ikum1 = MAX( iku - 1 , 1 )    ! last and before last ocean level at u- & v-points 
    355                ikv = mbkv(ji,jj) ; ikvm1 = MAX( ikv - 1 , 1 )    ! last and before last ocean level at u- & v-points 
    356                ze3wu  = (gdept_0(ji+1,jj,iku) - gdepw_0(ji+1,jj,iku)) - (gdept_0(ji,jj,iku) - gdepw_0(ji,jj,iku)) 
    357                ze3wv  = (gdept_0(ji,jj+1,ikv) - gdepw_0(ji,jj+1,ikv)) - (gdept_0(ji,jj,ikv) - gdepw_0(ji,jj,ikv)) 
    358                IF( ze3wu >= 0._wp ) THEN  
    359                   pgzu(ji,jj) = (fsde3w(ji+1,jj,iku) - ze3wu) - fsde3w(ji,jj,iku) 
    360                   pgru(ji,jj) = umask(ji,jj,iku) * ( zri(ji  ,jj) - prd(ji,jj,iku) )   ! i: 1 
    361                   pmru(ji,jj) = umask(ji,jj,iku) * ( zri(ji  ,jj) + prd(ji,jj,iku) )   ! i: 1  
    362                   pge3ru(ji,jj) = umask(ji,jj,iku)                                                                  & 
    363                                 * ( (fse3w(ji+1,jj,iku) - ze3wu )* ( zri(ji  ,jj    ) + prd(ji+1,jj,ikum1) + 2._wp) & 
    364                                    - fse3w(ji  ,jj,iku)          * ( prd(ji  ,jj,iku) + prd(ji  ,jj,ikum1) + 2._wp) )  ! j: 2 
    365                ELSE   
    366                   pgzu(ji,jj) = fsde3w(ji+1,jj,iku) - (fsde3w(ji,jj,iku) + ze3wu) 
    367                   pgru(ji,jj) = umask(ji,jj,iku) * ( prd(ji+1,jj,iku) - zri(ji,jj) )   ! i: 2 
    368                   pmru(ji,jj) = umask(ji,jj,iku) * ( prd(ji+1,jj,iku) + zri(ji,jj) )   ! i: 2 
    369                   pge3ru(ji,jj) = umask(ji,jj,iku)                                                                  & 
    370                                 * (  fse3w(ji+1,jj,iku)          * ( prd(ji+1,jj,iku) + prd(ji+1,jj,ikum1) + 2._wp) & 
    371                                    -(fse3w(ji  ,jj,iku) + ze3wu) * ( zri(ji  ,jj    ) + prd(ji  ,jj,ikum1) + 2._wp) )  ! j: 2 
    372                ENDIF 
    373                IF( ze3wv >= 0._wp ) THEN 
    374                   pgzv(ji,jj) = (fsde3w(ji,jj+1,ikv) - ze3wv) - fsde3w(ji,jj,ikv)  
    375                   pgrv(ji,jj) = vmask(ji,jj,ikv) * ( zrj(ji,jj  ) - prd(ji,jj,ikv) )   ! j: 1 
    376                   pmrv(ji,jj) = vmask(ji,jj,ikv) * ( zrj(ji,jj  ) + prd(ji,jj,ikv) )   ! j: 1 
    377                   pge3rv(ji,jj) = vmask(ji,jj,ikv)                                                                  & 
    378                                 * ( (fse3w(ji,jj+1,ikv) - ze3wv )* ( zrj(ji,jj      ) + prd(ji,jj+1,ikvm1) + 2._wp) & 
    379                                    - fse3w(ji,jj  ,ikv)          * ( prd(ji,jj  ,ikv) + prd(ji,jj  ,ikvm1) + 2._wp) )  ! j: 2 
    380                ELSE  
    381                   pgzv(ji,jj) = fsde3w(ji,jj+1,ikv) - (fsde3w(ji,jj,ikv) + ze3wv) 
    382                   pgrv(ji,jj) = vmask(ji,jj,ikv) * ( prd(ji,jj+1,ikv) - zrj(ji,jj) )   ! j: 2 
    383                   pmrv(ji,jj) = vmask(ji,jj,ikv) * ( prd(ji,jj+1,ikv) + zrj(ji,jj) )   ! j: 2 
    384                   pge3rv(ji,jj) = vmask(ji,jj,ikv)                                                                  & 
    385                                 * (  fse3w(ji,jj+1,ikv)          * ( prd(ji,jj+1,ikv) + prd(ji,jj+1,ikvm1) + 2._wp) & 
    386                                    -(fse3w(ji,jj  ,ikv) + ze3wv) * ( zrj(ji,jj      ) + prd(ji,jj  ,ikvm1) + 2._wp) )  ! j: 2 
    387                ENDIF 
    388             END DO 
    389          END DO 
    390          CALL lbc_lnk( pgru   , 'U', -1. )   ;   CALL lbc_lnk( pgrv   , 'V', -1. )   ! Lateral boundary conditions 
    391          CALL lbc_lnk( pmru   , 'U',  1. )   ;   CALL lbc_lnk( pmrv   , 'V',  1. )   ! Lateral boundary conditions 
    392          CALL lbc_lnk( pgzu   , 'U', -1. )   ;   CALL lbc_lnk( pgzv   , 'V', -1. )   ! Lateral boundary conditions 
    393          CALL lbc_lnk( pge3ru , 'U', -1. )   ;   CALL lbc_lnk( pge3rv , 'V', -1. )   ! Lateral boundary conditions 
    394          ! 
    395       END IF 
    396          ! (ISH)  compute grui and gruvi 
    397       DO jn = 1, kjpt      !==   Interpolation of tracers at the last ocean level   ==!            ! 
    398          DO jj = 1, jpjm1 
    399             DO ji = 1, jpim1 
    400                iku = miku(ji,jj)   ;  ikup1 = miku(ji,jj) + 1 
    401                ikv = mikv(ji,jj)   ;  ikvp1 = mikv(ji,jj) + 1 
    402                ! 
    403                ! (ISF) case partial step top and bottom in adjacent cell in vertical 
    404                ! cannot used e3w because if 2 cell water column, we have ps at top and bottom 
    405                ! in this case e3w(i,j) - e3w(i,j+1) is not the distance between Tj~ and Tj 
    406                ! the only common depth between cells (i,j) and (i,j+1) is gdepw_0 
    407                ze3wu  = (gdepw_0(ji+1,jj,iku+1) - gdept_0(ji+1,jj,iku)) - (gdepw_0(ji,jj,iku+1) - gdept_0(ji,jj,iku))  
    408                ze3wv  = (gdepw_0(ji,jj+1,ikv+1) - gdept_0(ji,jj+1,ikv)) - (gdepw_0(ji,jj,ikv+1) - gdept_0(ji,jj,ikv)) 
    409                ! i- direction 
    410                IF( ze3wu >= 0._wp ) THEN      ! case 1 
    411                   zmaxu = ze3wu / fse3w(ji+1,jj,iku+1) 
    412                   ! interpolated values of tracers 
    413                   zti(ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,iku+1,jn) - pta(ji+1,jj,iku,jn) ) 
    414                   ! gradient of tracers 
    415                   pgtui(ji,jj,jn) = umask(ji,jj,iku) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) ) 
    416                ELSE                           ! case 2 
    417                   zmaxu = - ze3wu / fse3w(ji,jj,iku+1) 
    418                   ! interpolated values of tracers 
    419                   zti(ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,iku+1,jn) - pta(ji,jj,iku,jn) ) 
    420                   ! gradient of  tracers 
    421                   pgtui(ji,jj,jn) = umask(ji,jj,iku) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) ) 
    422                ENDIF 
    423                ! 
    424                ! j- direction 
    425                IF( ze3wv >= 0._wp ) THEN      ! case 1 
    426                   zmaxv =  ze3wv / fse3w(ji,jj+1,ikv+1) 
    427                   ! interpolated values of tracers 
    428                   ztj(ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikv+1,jn) - pta(ji,jj+1,ikv,jn) ) 
    429                   ! gradient of tracers 
    430                   pgtvi(ji,jj,jn) = vmask(ji,jj,ikv) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) ) 
    431                ELSE                           ! case 2 
    432                   zmaxv =  - ze3wv / fse3w(ji,jj,ikv+1) 
    433                   ! interpolated values of tracers 
    434                   ztj(ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikv+1,jn) - pta(ji,jj,ikv,jn) ) 
    435                   ! gradient of tracers 
    436                   pgtvi(ji,jj,jn) = vmask(ji,jj,ikv) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) ) 
    437                ENDIF 
    438             END DO!! 
    439          END DO!! 
    440          CALL lbc_lnk( pgtui(:,:,jn), 'U', -1. )   ;   CALL lbc_lnk( pgtvi(:,:,jn), 'V', -1. )   ! Lateral boundary cond. 
    441          ! 
    442       END DO 
    443  
    444       ! horizontal derivative of density anomalies (rd) 
    445       IF( PRESENT( prd ) ) THEN         ! depth of the partial step level 
    446          pgrui(:,:)  =0.0_wp ; pgrvi(:,:)  =0.0_wp ; 
    447          pgzui(:,:)  =0.0_wp ; pgzvi(:,:)  =0.0_wp ; 
    448          pmrui(:,:)  =0.0_wp ; pmrui(:,:)  =0.0_wp ; 
    449          pge3rui(:,:)=0.0_wp ; pge3rvi(:,:)=0.0_wp ; 
    450  
    451          DO jj = 1, jpjm1 
    452             DO ji = 1, jpim1 
     410      IF( PRESENT( prd ) ) THEN    !==  horizontal derivative of density anomalies (rd)  ==!    (optional part) 
     411         ! 
     412         pgrui(:,:)  =0.0_wp; pgrvi(:,:)  =0.0_wp; 
     413         DO jj = 1, jpjm1 
     414            DO ji = 1, jpim1 
     415 
    453416               iku = miku(ji,jj) 
    454417               ikv = mikv(ji,jj) 
    455                ze3wu  = (gdepw_0(ji+1,jj,iku+1) - gdept_0(ji+1,jj,iku)) - (gdepw_0(ji,jj,iku+1) - gdept_0(ji,jj,iku)) 
    456                ze3wv  = (gdepw_0(ji,jj+1,ikv+1) - gdept_0(ji,jj+1,ikv)) - (gdepw_0(ji,jj,ikv+1) - gdept_0(ji,jj,ikv)) 
    457  
    458                IF( ze3wu >= 0._wp ) THEN   ;   zhi(ji,jj) = fsdept(ji+1,jj,iku) + ze3wu    ! i-direction: case 1 
    459                ELSE                        ;   zhi(ji,jj) = fsdept(ji  ,jj,iku) - ze3wu    ! -     -      case 2 
    460                ENDIF 
    461                IF( ze3wv >= 0._wp ) THEN   ;   zhj(ji,jj) = fsdept(ji,jj+1,ikv) + ze3wv    ! j-direction: case 1 
    462                ELSE                        ;   zhj(ji,jj) = fsdept(ji,jj  ,ikv) - ze3wv    ! -     -      case 2 
    463                ENDIF 
    464             END DO 
    465          END DO 
    466  
    467          ! Compute interpolated rd from zti, ztj for the 2 cases at the depth of the partial 
    468          ! step and store it in  zri, zrj for each  case 
    469          CALL eos( zti, zhi, zri )   
    470          CALL eos( ztj, zhj, zrj ) 
    471  
    472          ! Gradient of density at the last level  
    473          DO jj = 1, jpjm1 
    474             DO ji = 1, jpim1 
    475                iku = miku(ji,jj) ; ikup1 = miku(ji,jj) + 1 
    476                ikv = mikv(ji,jj) ; ikvp1 = mikv(ji,jj) + 1 
    477                ze3wu  = (gdepw_0(ji+1,jj,iku+1) - gdept_0(ji+1,jj,iku)) - (gdepw_0(ji,jj,iku+1) - gdept_0(ji,jj,iku)) 
    478                ze3wv  = (gdepw_0(ji,jj+1,ikv+1) - gdept_0(ji,jj+1,ikv)) - (gdepw_0(ji,jj,ikv+1) - gdept_0(ji,jj,ikv)) 
    479                IF( ze3wu >= 0._wp ) THEN 
    480                  pgzui  (ji,jj) = (fsde3w(ji+1,jj,iku) + ze3wu) - fsde3w(ji,jj,iku) 
    481                  pgrui  (ji,jj) = umask(ji,jj,iku)   * ( zri(ji,jj) - prd(ji,jj,iku) )          ! i: 1 
    482                  pmrui  (ji,jj) = umask(ji,jj,iku)   * ( zri(ji,jj) + prd(ji,jj,iku) )          ! i: 1  
    483                  pge3rui(ji,jj) = umask(ji,jj,iku+1)                                                                  & 
    484                                 * ( (fse3w(ji+1,jj,iku+1) - ze3wu) * (zri(ji,jj    ) + prd(ji+1,jj,iku+1) + 2._wp)   & 
    485                                    - fse3w(ji  ,jj,iku+1)          * (prd(ji,jj,iku) + prd(ji  ,jj,iku+1) + 2._wp)   ) ! i: 1 
    486                ELSE 
    487                  pgzui  (ji,jj) = fsde3w(ji+1,jj,iku) - (fsde3w(ji,jj,iku) - ze3wu) 
    488                  pgrui  (ji,jj) = umask(ji,jj,iku)   * ( prd(ji+1,jj,iku) - zri(ji,jj) )      ! i: 2 
    489                  pmrui  (ji,jj) = umask(ji,jj,iku)   * ( prd(ji+1,jj,iku) + zri(ji,jj) )      ! i: 2 
    490                  pge3rui(ji,jj) = umask(ji,jj,iku+1)                                                                   & 
    491                                 * (  fse3w(ji+1,jj,iku+1)          * (prd(ji+1,jj,iku) + prd(ji+1,jj,iku+1) + 2._wp)  & 
    492                                    -(fse3w(ji  ,jj,iku+1) + ze3wu) * (zri(ji,jj      ) + prd(ji  ,jj,iku+1) + 2._wp)  )     ! i: 2 
    493                ENDIF 
    494                IF( ze3wv >= 0._wp ) THEN 
    495                  pgzvi  (ji,jj) = (fsde3w(ji,jj+1,ikv) + ze3wv) - fsde3w(ji,jj,ikv)  
    496                  pgrvi  (ji,jj) = vmask(ji,jj,ikv)   * ( zrj(ji,jj  ) - prd(ji,jj,ikv) )        ! j: 1 
    497                  pmrvi  (ji,jj) = vmask(ji,jj,ikv)   * ( zrj(ji,jj  ) + prd(ji,jj,ikv) )        ! j: 1 
    498                  pge3rvi(ji,jj) = vmask(ji,jj,ikv+1)                                                                  &  
    499                                 * ( (fse3w(ji,jj+1,ikv+1) - ze3wv) * ( zrj(ji,jj    ) + prd(ji,jj+1,ikv+1) + 2._wp)  & 
    500                                    - fse3w(ji,jj  ,ikv+1)          * ( prd(ji,jj,ikv) + prd(ji,jj  ,ikv+1) + 2._wp)  ) ! j: 1 
    501                                   ! + 2 due to the formulation in density and not in anomalie in hpg sco 
    502                ELSE 
    503                  pgzvi  (ji,jj) = fsde3w(ji,jj+1,ikv) - (fsde3w(ji,jj,ikv) - ze3wv) 
    504                  pgrvi  (ji,jj) = vmask(ji,jj,ikv)   * ( prd(ji,jj+1,ikv) - zrj(ji,jj) )     ! j: 2 
    505                  pmrvi  (ji,jj) = vmask(ji,jj,ikv)   * ( prd(ji,jj+1,ikv) + zrj(ji,jj) )     ! j: 2 
    506                  pge3rvi(ji,jj) = vmask(ji,jj,ikv+1)                                                                   & 
    507                                 * (  fse3w(ji,jj+1,ikv+1)          * ( prd(ji,jj+1,ikv) + prd(ji,jj+1,ikv+1) + 2._wp) & 
    508                                    -(fse3w(ji,jj  ,ikv+1) + ze3wv) * ( zrj(ji,jj      ) + prd(ji,jj  ,ikv+1) + 2._wp) )  ! j: 2 
    509                ENDIF 
    510             END DO 
    511          END DO 
    512          CALL lbc_lnk( pgrui   , 'U', -1. )   ;   CALL lbc_lnk( pgrvi   , 'V', -1. )   ! Lateral boundary conditions 
    513          CALL lbc_lnk( pmrui   , 'U',  1. )   ;   CALL lbc_lnk( pmrvi   , 'V',  1. )   ! Lateral boundary conditions 
    514          CALL lbc_lnk( pgzui   , 'U', -1. )   ;   CALL lbc_lnk( pgzvi   , 'V', -1. )   ! Lateral boundary conditions 
    515          CALL lbc_lnk( pge3rui , 'U', -1. )   ;   CALL lbc_lnk( pge3rvi , 'V', -1. )   ! Lateral boundary conditions 
     418               ze3wu  =  gdept_n(ji,jj,iku) - gdept_n(ji+1,jj,iku) 
     419               ze3wv  =  gdept_n(ji,jj,ikv) - gdept_n(ji,jj+1,ikv)  
     420               ! 
     421               IF( ze3wu >= 0._wp ) THEN   ;   zhi(ji,jj) = gdept_n(ji  ,jj,iku)    ! i-direction: case 1 
     422               ELSE                        ;   zhi(ji,jj) = gdept_n(ji+1,jj,iku)    ! -     -      case 2 
     423               ENDIF 
     424 
     425               IF( ze3wv >= 0._wp ) THEN   ;   zhj(ji,jj) = gdept_n(ji,jj  ,ikv)    ! j-direction: case 1 
     426               ELSE                        ;   zhj(ji,jj) = gdept_n(ji,jj+1,ikv)    ! -     -      case 2 
     427               ENDIF 
     428 
     429            END DO 
     430         END DO 
     431         ! 
     432         CALL eos( zti, zhi, zri )        ! interpolated density from zti, ztj  
     433         CALL eos( ztj, zhj, zrj )        ! at the partial step depth output in  zri, zrj  
     434         ! 
     435         DO jj = 1, jpjm1                 ! Gradient of density at the last level  
     436            DO ji = 1, jpim1 
     437               iku = miku(ji,jj)  
     438               ikv = mikv(ji,jj)  
     439               ze3wu  =  gdept_n(ji,jj,iku) - gdept_n(ji+1,jj,iku) 
     440               ze3wv  =  gdept_n(ji,jj,ikv) - gdept_n(ji,jj+1,ikv)  
     441 
     442               IF( ze3wu >= 0._wp ) THEN ; pgrui(ji,jj) = ssumask(ji,jj) * ( zri(ji  ,jj      ) - prd(ji,jj,iku) ) ! i: 1 
     443               ELSE                      ; pgrui(ji,jj) = ssumask(ji,jj) * ( prd(ji+1,jj  ,iku) - zri(ji,jj    ) ) ! i: 2 
     444               ENDIF 
     445               IF( ze3wv >= 0._wp ) THEN ; pgrvi(ji,jj) = ssvmask(ji,jj) * ( zrj(ji  ,jj      ) - prd(ji,jj,ikv) ) ! j: 1 
     446               ELSE                      ; pgrvi(ji,jj) = ssvmask(ji,jj) * ( prd(ji  ,jj+1,ikv) - zrj(ji,jj    ) ) ! j: 2 
     447               ENDIF 
     448 
     449            END DO 
     450         END DO 
     451         CALL lbc_lnk( pgrui   , 'U', -1. ); CALL lbc_lnk( pgrvi   , 'V', -1. )   ! Lateral boundary conditions 
    516452         ! 
    517453      END IF   
    518454      ! 
    519       IF( nn_timing == 1 )  CALL timing_stop( 'zps_hde_isf') 
     455      IF( nn_timing == 1 )   CALL timing_stop( 'zps_hde_isf') 
    520456      ! 
    521457   END SUBROUTINE zps_hde_isf 
Note: See TracChangeset for help on using the changeset viewer.