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 5965 for branches/2014/dev_r4650_UKMO14.5_SST_BIAS_CORRECTION/NEMOGCM/NEMO/OPA_SRC/TRA – NEMO

Ignore:
Timestamp:
2015-12-01T16:35:30+01:00 (9 years ago)
Author:
timgraham
Message:

Upgraded branch to r5518 of trunk (v3.6 stable revision)

Location:
branches/2014/dev_r4650_UKMO14.5_SST_BIAS_CORRECTION/NEMOGCM/NEMO/OPA_SRC/TRA
Files:
26 edited

Legend:

Unmodified
Added
Removed

  • branches/2014/dev_r4650_UKMO14.5_SST_BIAS_CORRECTION/NEMOGCM/NEMO/OPA_SRC/TRA/eosbn2.F90

    r4624 r5965  
    1515   !!             -   ! 2002-11  (G. Madec, A. Bozec)  partial step, eos_insitu_2d 
    1616   !!             -   ! 2003-08  (G. Madec)  F90, free form 
    17    !!            3.0  ! 2006-08  (G. Madec)  add tfreez function 
     17   !!            3.0  ! 2006-08  (G. Madec)  add tfreez function (now eos_fzp function) 
    1818   !!            3.3  ! 2010-05  (C. Ethe, G. Madec)  merge TRC-TRA 
    19    !!             -   ! 2010-10  (G. Nurser, G. Madec)  add eos_alpbet used in ldfslp 
     19   !!             -   ! 2010-10  (G. Nurser, G. Madec)  add alpha/beta used in ldfslp 
     20   !!            3.7  ! 2012-03  (F. Roquet, G. Madec)  add primitive of alpha and beta used in PE computation 
     21   !!             -   ! 2012-05  (F. Roquet)  add Vallis and original JM95 equation of state 
     22   !!             -   ! 2013-04  (F. Roquet, G. Madec)  add eos_rab, change bn2 computation and reorganize the module 
     23   !!             -   ! 2014-09  (F. Roquet)  add TEOS-10, S-EOS, and modify EOS-80 
    2024   !!---------------------------------------------------------------------- 
    2125 
    … …  
    2327   !!   eos            : generic interface of the equation of state 
    2428   !!   eos_insitu     : Compute the in situ density 
    25    !!   eos_insitu_pot : Compute the insitu and surface referenced potential 
    26    !!                    volumic mass 
     29   !!   eos_insitu_pot : Compute the insitu and surface referenced potential volumic mass 
    2730   !!   eos_insitu_2d  : Compute the in situ density for 2d fields 
    28    !!   eos_bn2        : Compute the Brunt-Vaisala frequency 
    29    !!   eos_alpbet     : calculates the in situ thermal/haline expansion ratio 
    30    !!   tfreez         : Compute the surface freezing temperature 
     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 
    3137   !!   eos_init       : set eos parameters (namelist) 
    3238   !!---------------------------------------------------------------------- 
    3339   USE dom_oce         ! ocean space and time domain 
    3440   USE phycst          ! physical constants 
    35    USE zdfddm          ! vertical physics: double diffusion 
     41   ! 
    3642   USE in_out_manager  ! I/O manager 
    3743   USE lib_mpp         ! MPP library 
     44   USE lib_fortran     ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)   
    3845   USE prtctl          ! Print control 
    3946   USE wrk_nemo        ! Memory Allocation 
     47   USE lbclnk         ! ocean lateral boundary conditions 
    4048   USE timing          ! Timing 
     49   USE stopar          ! Stochastic T/S fluctuations 
     50   USE stopts          ! Stochastic T/S fluctuations 
    4151 
    4252   IMPLICIT NONE 
    … …  
    4757      MODULE PROCEDURE eos_insitu, eos_insitu_pot, eos_insitu_2d 
    4858   END INTERFACE 
    49    INTERFACE bn2 
    50       MODULE PROCEDURE eos_bn2 
     59   ! 
     60   INTERFACE eos_rab 
     61      MODULE PROCEDURE rab_3d, rab_2d, rab_0d 
    5162   END INTERFACE 
    52  
    53    PUBLIC   eos        ! called by step, istate, tranpc and zpsgrd modules 
    54    PUBLIC   eos_init   ! called by istate module 
    55    PUBLIC   bn2        ! called by step module 
    56    PUBLIC   eos_alpbet ! called by ldfslp module 
    57    PUBLIC   tfreez     ! called by sbcice_... modules 
    58  
    59    !                                  !!* Namelist (nameos) * 
    60    INTEGER , PUBLIC ::   nn_eos       !: = 0/1/2 type of eq. of state and Brunt-Vaisala frequ. 
    61    REAL(wp), PUBLIC ::   rn_alpha     !: thermal expension coeff. (linear equation of state) 
    62    REAL(wp), PUBLIC ::   rn_beta      !: saline  expension coeff. (linear equation of state) 
    63  
    64    REAL(wp), PUBLIC ::   ralpbet              !: alpha / beta ratio 
     63   ! 
     64   INTERFACE eos_fzp  
     65      MODULE PROCEDURE eos_fzp_2d, eos_fzp_0d 
     66   END INTERFACE 
     67   ! 
     68   PUBLIC   eos            ! called by step, istate, tranpc and zpsgrd modules 
     69   PUBLIC   bn2            ! called by step module 
     70   PUBLIC   eos_rab        ! called by ldfslp, zdfddm, trabbl 
     71   PUBLIC   eos_pt_from_ct ! called by sbcssm 
     72   PUBLIC   eos_fzp        ! called by traadv_cen2 and sbcice_... modules 
     73   PUBLIC   eos_pen        ! used for pe diagnostics in trdpen module 
     74   PUBLIC   eos_init       ! called by istate module 
     75 
     76   !                                !!* Namelist (nameos) * 
     77   INTEGER , PUBLIC ::   nn_eos     ! = 0/1/2 type of eq. of state and Brunt-Vaisala frequ. 
     78   LOGICAL , PUBLIC ::   ln_useCT   ! determine if eos_pt_from_ct is used to compute sst_m 
     79 
     80   !                                   !!!  simplified eos coefficients 
     81   ! default value: Vallis 2006 
     82   REAL(wp) ::   rn_a0      = 1.6550e-1_wp     ! thermal expansion coeff.  
     83   REAL(wp) ::   rn_b0      = 7.6554e-1_wp     ! saline  expansion coeff.  
     84   REAL(wp) ::   rn_lambda1 = 5.9520e-2_wp     ! cabbeling coeff. in T^2         
     85   REAL(wp) ::   rn_lambda2 = 5.4914e-4_wp     ! cabbeling coeff. in S^2         
     86   REAL(wp) ::   rn_mu1     = 1.4970e-4_wp     ! thermobaric coeff. in T   
     87   REAL(wp) ::   rn_mu2     = 1.1090e-5_wp     ! thermobaric coeff. in S   
     88   REAL(wp) ::   rn_nu      = 2.4341e-3_wp     ! cabbeling coeff. in theta*salt   
     89    
     90   ! TEOS10/EOS80 parameters 
     91   REAL(wp) ::   r1_S0, r1_T0, r1_Z0, rdeltaS 
     92    
     93   ! EOS parameters 
     94   REAL(wp) ::   EOS000 , EOS100 , EOS200 , EOS300 , EOS400 , EOS500 , EOS600 
     95   REAL(wp) ::   EOS010 , EOS110 , EOS210 , EOS310 , EOS410 , EOS510 
     96   REAL(wp) ::   EOS020 , EOS120 , EOS220 , EOS320 , EOS420 
     97   REAL(wp) ::   EOS030 , EOS130 , EOS230 , EOS330 
     98   REAL(wp) ::   EOS040 , EOS140 , EOS240 
     99   REAL(wp) ::   EOS050 , EOS150 
     100   REAL(wp) ::   EOS060 
     101   REAL(wp) ::   EOS001 , EOS101 , EOS201 , EOS301 , EOS401 
     102   REAL(wp) ::   EOS011 , EOS111 , EOS211 , EOS311 
     103   REAL(wp) ::   EOS021 , EOS121 , EOS221 
     104   REAL(wp) ::   EOS031 , EOS131 
     105   REAL(wp) ::   EOS041 
     106   REAL(wp) ::   EOS002 , EOS102 , EOS202 
     107   REAL(wp) ::   EOS012 , EOS112 
     108   REAL(wp) ::   EOS022 
     109   REAL(wp) ::   EOS003 , EOS103 
     110   REAL(wp) ::   EOS013  
     111    
     112   ! ALPHA parameters 
     113   REAL(wp) ::   ALP000 , ALP100 , ALP200 , ALP300 , ALP400 , ALP500 
     114   REAL(wp) ::   ALP010 , ALP110 , ALP210 , ALP310 , ALP410 
     115   REAL(wp) ::   ALP020 , ALP120 , ALP220 , ALP320 
     116   REAL(wp) ::   ALP030 , ALP130 , ALP230 
     117   REAL(wp) ::   ALP040 , ALP140 
     118   REAL(wp) ::   ALP050 
     119   REAL(wp) ::   ALP001 , ALP101 , ALP201 , ALP301 
     120   REAL(wp) ::   ALP011 , ALP111 , ALP211 
     121   REAL(wp) ::   ALP021 , ALP121 
     122   REAL(wp) ::   ALP031 
     123   REAL(wp) ::   ALP002 , ALP102 
     124   REAL(wp) ::   ALP012 
     125   REAL(wp) ::   ALP003 
     126    
     127   ! BETA parameters 
     128   REAL(wp) ::   BET000 , BET100 , BET200 , BET300 , BET400 , BET500 
     129   REAL(wp) ::   BET010 , BET110 , BET210 , BET310 , BET410 
     130   REAL(wp) ::   BET020 , BET120 , BET220 , BET320 
     131   REAL(wp) ::   BET030 , BET130 , BET230 
     132   REAL(wp) ::   BET040 , BET140 
     133   REAL(wp) ::   BET050 
     134   REAL(wp) ::   BET001 , BET101 , BET201 , BET301 
     135   REAL(wp) ::   BET011 , BET111 , BET211 
     136   REAL(wp) ::   BET021 , BET121 
     137   REAL(wp) ::   BET031 
     138   REAL(wp) ::   BET002 , BET102 
     139   REAL(wp) ::   BET012 
     140   REAL(wp) ::   BET003 
     141 
     142   ! PEN parameters 
     143   REAL(wp) ::   PEN000 , PEN100 , PEN200 , PEN300 , PEN400 
     144   REAL(wp) ::   PEN010 , PEN110 , PEN210 , PEN310 
     145   REAL(wp) ::   PEN020 , PEN120 , PEN220 
     146   REAL(wp) ::   PEN030 , PEN130 
     147   REAL(wp) ::   PEN040 
     148   REAL(wp) ::   PEN001 , PEN101 , PEN201 
     149   REAL(wp) ::   PEN011 , PEN111 
     150   REAL(wp) ::   PEN021 
     151   REAL(wp) ::   PEN002 , PEN102 
     152   REAL(wp) ::   PEN012 
     153    
     154   ! ALPHA_PEN parameters 
     155   REAL(wp) ::   APE000 , APE100 , APE200 , APE300 
     156   REAL(wp) ::   APE010 , APE110 , APE210 
     157   REAL(wp) ::   APE020 , APE120 
     158   REAL(wp) ::   APE030 
     159   REAL(wp) ::   APE001 , APE101 
     160   REAL(wp) ::   APE011 
     161   REAL(wp) ::   APE002 
     162 
     163   ! BETA_PEN parameters 
     164   REAL(wp) ::   BPE000 , BPE100 , BPE200 , BPE300 
     165   REAL(wp) ::   BPE010 , BPE110 , BPE210 
     166   REAL(wp) ::   BPE020 , BPE120 
     167   REAL(wp) ::   BPE030 
     168   REAL(wp) ::   BPE001 , BPE101 
     169   REAL(wp) ::   BPE011 
     170   REAL(wp) ::   BPE002 
    65171 
    66172   !! * Substitutions 
    … …  
    68174#  include "vectopt_loop_substitute.h90" 
    69175   !!---------------------------------------------------------------------- 
    70    !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
     176   !! NEMO/OPA 3.7 , NEMO Consortium (2014) 
    71177   !! $Id$ 
    72178   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    … …  
    82188      !!       defined through the namelist parameter nn_eos. 
    83189      !! 
    84       !! ** Method  :   3 cases: 
    85       !!      nn_eos = 0 : Jackett and McDougall (1994) equation of state. 
    86       !!         the in situ density is computed directly as a function of 
    87       !!         potential temperature relative to the surface (the opa t 
    88       !!         variable), salt and pressure (assuming no pressure variation 
    89       !!         along geopotential surfaces, i.e. the pressure p in decibars 
    90       !!         is approximated by the depth in meters. 
    91       !!              prd(t,s,p) = ( rho(t,s,p) - rau0 ) / rau0 
    92       !!         with pressure                      p        decibars 
    93       !!              potential temperature         t        deg celsius 
    94       !!              salinity                      s        psu 
    95       !!              reference volumic mass        rau0     kg/m**3 
    96       !!              in situ volumic mass          rho      kg/m**3 
    97       !!              in situ density anomalie      prd      no units 
    98       !!         Check value: rho = 1060.93298 kg/m**3 for p=10000 dbar, 
    99       !!          t = 40 deg celcius, s=40 psu 
    100       !!      nn_eos = 1 : linear equation of state function of temperature only 
    101       !!              prd(t) = 0.0285 - rn_alpha * t 
    102       !!      nn_eos = 2 : linear equation of state function of temperature and 
    103       !!               salinity 
    104       !!              prd(t,s) = rn_beta * s - rn_alpha * tn - 1. 
    105       !!      Note that no boundary condition problem occurs in this routine 
    106       !!      as pts are defined over the whole domain. 
     190      !! ** Method  :   prd(t,s,z) = ( rho(t,s,z) - rau0 ) / rau0 
     191      !!         with   prd    in situ density anomaly      no units 
     192      !!                t      TEOS10: CT or EOS80: PT      Celsius 
     193      !!                s      TEOS10: SA or EOS80: SP      TEOS10: g/kg or EOS80: psu 
     194      !!                z      depth                        meters 
     195      !!                rho    in situ density              kg/m^3 
     196      !!                rau0   reference density            kg/m^3 
     197      !! 
     198      !!     nn_eos = -1 : polynomial TEOS-10 equation of state is used for rho(t,s,z). 
     199      !!         Check value: rho = 1028.21993233072 kg/m^3 for z=3000 dbar, ct=3 Celcius, sa=35.5 g/kg 
     200      !! 
     201      !!     nn_eos =  0 : polynomial EOS-80 equation of state is used for rho(t,s,z). 
     202      !!         Check value: rho = 1028.35011066567 kg/m^3 for z=3000 dbar, pt=3 Celcius, sp=35.5 psu 
     203      !! 
     204      !!     nn_eos =  1 : simplified equation of state 
     205      !!              prd(t,s,z) = ( -a0*(1+lambda/2*(T-T0)+mu*z+nu*(S-S0))*(T-T0) + b0*(S-S0) ) / rau0 
     206      !!              linear case function of T only: rn_alpha<>0, other coefficients = 0 
     207      !!              linear eos function of T and S: rn_alpha and rn_beta<>0, other coefficients=0 
     208      !!              Vallis like equation: use default values of coefficients 
    107209      !! 
    108210      !! ** Action  :   compute prd , the in situ density (no units) 
    109211      !! 
    110       !! References :   Jackett and McDougall, J. Atmos. Ocean. Tech., 1994 
    111       !!---------------------------------------------------------------------- 
    112       !! 
    113       REAL(wp), DIMENSION(:,:,:,:), INTENT(in   ) ::   pts   ! 1 : potential temperature  [Celcius] 
    114       !                                                      ! 2 : salinity               [psu] 
    115       REAL(wp), DIMENSION(:,:,:)  , INTENT(  out) ::   prd   ! in situ density            [-] 
    116       REAL(wp), DIMENSION(:,:,:)  , INTENT(in   ) ::   pdep  ! depth                      [m] 
    117       !! 
    118       INTEGER  ::   ji, jj, jk           ! dummy loop indices 
    119       REAL(wp) ::   zt , zs , zh , zsr   ! local scalars 
    120       REAL(wp) ::   zr1, zr2, zr3, zr4   !   -      - 
    121       REAL(wp) ::   zrhop, ze, zbw, zb   !   -      - 
    122       REAL(wp) ::   zd , zc , zaw, za    !   -      - 
    123       REAL(wp) ::   zb1, za1, zkw, zk0   !   -      - 
    124       REAL(wp), POINTER, DIMENSION(:,:,:) :: zws 
    125       !!---------------------------------------------------------------------- 
    126  
    127       ! 
    128       IF( nn_timing == 1 ) CALL timing_start('eos') 
    129       ! 
    130       CALL wrk_alloc( jpi, jpj, jpk, zws ) 
     212      !! References :   Roquet et al, Ocean Modelling, in preparation (2014) 
     213      !!                Vallis, Atmospheric and Oceanic Fluid Dynamics, 2006 
     214      !!                TEOS-10 Manual, 2010 
     215      !!---------------------------------------------------------------------- 
     216      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::   pts   ! 1 : potential temperature  [Celcius] 
     217      !                                                               ! 2 : salinity               [psu] 
     218      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(  out) ::   prd   ! in situ density            [-] 
     219      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pdep  ! depth                      [m] 
     220      ! 
     221      INTEGER  ::   ji, jj, jk                ! dummy loop indices 
     222      REAL(wp) ::   zt , zh , zs , ztm        ! local scalars 
     223      REAL(wp) ::   zn , zn0, zn1, zn2, zn3   !   -      - 
     224      !!---------------------------------------------------------------------- 
     225      ! 
     226      IF( nn_timing == 1 )   CALL timing_start('eos-insitu') 
    131227      ! 
    132228      SELECT CASE( nn_eos ) 
    133229      ! 
    134       CASE( 0 )                !==  Jackett and McDougall (1994) formulation  ==! 
    135 !CDIR NOVERRCHK 
    136          zws(:,:,:) = SQRT( ABS( pts(:,:,:,jp_sal) ) ) 
     230      CASE( -1, 0 )                !==  polynomial TEOS-10 / EOS-80 ==! 
    137231         ! 
    138232         DO jk = 1, jpkm1 
    139233            DO jj = 1, jpj 
    140234               DO ji = 1, jpi 
    141                   zt = pts   (ji,jj,jk,jp_tem) 
    142                   zs = pts   (ji,jj,jk,jp_sal) 
    143                   zh = pdep(ji,jj,jk)        ! depth 
    144                   zsr= zws   (ji,jj,jk)        ! square root salinity 
    145                   ! 
    146                   ! compute volumic mass pure water at atm pressure 
    147                   zr1= ( ( ( ( 6.536332e-9_wp  *zt - 1.120083e-6_wp )*zt + 1.001685e-4_wp )*zt   & 
    148                      &        -9.095290e-3_wp )*zt + 6.793952e-2_wp )*zt +  999.842594_wp 
    149                   ! seawater volumic mass atm pressure 
    150                   zr2= ( ( ( 5.3875e-9_wp*zt-8.2467e-7_wp ) *zt+7.6438e-5_wp ) *zt        & 
    151                      &                      -4.0899e-3_wp ) *zt+0.824493_wp 
    152                   zr3= ( -1.6546e-6_wp*zt+1.0227e-4_wp )    *zt-5.72466e-3_wp 
    153                   zr4= 4.8314e-4_wp 
    154                   ! 
    155                   ! potential volumic mass (reference to the surface) 
    156                   zrhop= ( zr4*zs + zr3*zsr + zr2 ) *zs + zr1 
    157                   ! 
    158                   ! add the compression terms 
    159                   ze = ( -3.508914e-8_wp*zt-1.248266e-8_wp ) *zt-2.595994e-6_wp 
    160                   zbw= (  1.296821e-6_wp*zt-5.782165e-9_wp ) *zt+1.045941e-4_wp 
    161                   zb = zbw + ze * zs 
    162                   ! 
    163                   zd = -2.042967e-2_wp 
    164                   zc =   (-7.267926e-5_wp*zt+2.598241e-3_wp ) *zt+0.1571896_wp 
    165                   zaw= ( ( 5.939910e-6_wp*zt+2.512549e-3_wp ) *zt-0.1028859_wp ) *zt - 4.721788_wp 
    166                   za = ( zd*zsr + zc ) *zs + zaw 
    167                   ! 
    168                   zb1=   (-0.1909078_wp*zt+7.390729_wp )        *zt-55.87545_wp 
    169                   za1= ( ( 2.326469e-3_wp*zt+1.553190_wp)       *zt-65.00517_wp ) *zt+1044.077_wp 
    170                   zkw= ( ( (-1.361629e-4_wp*zt-1.852732e-2_wp ) *zt-30.41638_wp ) *zt + 2098.925_wp ) *zt+190925.6_wp 
    171                   zk0= ( zb1*zsr + za1 )*zs + zkw 
    172                   ! 
    173                   ! masked in situ density anomaly 
    174                   prd(ji,jj,jk) = (  zrhop / (  1.0_wp - zh / ( zk0 - zh * ( za - zh * zb ) )  )    & 
    175                      &             - rau0  ) * r1_rau0 * tmask(ji,jj,jk) 
     235                  ! 
     236                  zh  = pdep(ji,jj,jk) * r1_Z0                                  ! depth 
     237                  zt  = pts (ji,jj,jk,jp_tem) * r1_T0                           ! temperature 
     238                  zs  = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity 
     239                  ztm = tmask(ji,jj,jk)                                         ! tmask 
     240                  ! 
     241                  zn3 = EOS013*zt   & 
     242                     &   + EOS103*zs+EOS003 
     243                     ! 
     244                  zn2 = (EOS022*zt   & 
     245                     &   + EOS112*zs+EOS012)*zt   & 
     246                     &   + (EOS202*zs+EOS102)*zs+EOS002 
     247                     ! 
     248                  zn1 = (((EOS041*zt   & 
     249                     &   + EOS131*zs+EOS031)*zt   & 
     250                     &   + (EOS221*zs+EOS121)*zs+EOS021)*zt   & 
     251                     &   + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt   & 
     252                     &   + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 
     253                     ! 
     254                  zn0 = (((((EOS060*zt   & 
     255                     &   + EOS150*zs+EOS050)*zt   & 
     256                     &   + (EOS240*zs+EOS140)*zs+EOS040)*zt   & 
     257                     &   + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt   & 
     258                     &   + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt   & 
     259                     &   + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt   & 
     260                     &   + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 
     261                     ! 
     262                  zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 
     263                  ! 
     264                  prd(ji,jj,jk) = (  zn * r1_rau0 - 1._wp  ) * ztm  ! density anomaly (masked) 
     265                  ! 
    176266               END DO 
    177267            END DO 
    178268         END DO 
    179269         ! 
    180       CASE( 1 )                !==  Linear formulation function of temperature only  ==! 
     270      CASE( 1 )                !==  simplified EOS  ==! 
     271         ! 
    181272         DO jk = 1, jpkm1 
    182             prd(:,:,jk) = ( 0.0285_wp - rn_alpha * pts(:,:,jk,jp_tem) ) * tmask(:,:,jk) 
     273            DO jj = 1, jpj 
     274               DO ji = 1, jpi 
     275                  zt  = pts  (ji,jj,jk,jp_tem) - 10._wp 
     276                  zs  = pts  (ji,jj,jk,jp_sal) - 35._wp 
     277                  zh  = pdep (ji,jj,jk) 
     278                  ztm = tmask(ji,jj,jk) 
     279                  ! 
     280                  zn =  - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt + rn_mu1*zh ) * zt   & 
     281                     &  + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs - rn_mu2*zh ) * zs   & 
     282                     &  - rn_nu * zt * zs 
     283                     !                                  
     284                  prd(ji,jj,jk) = zn * r1_rau0 * ztm                ! density anomaly (masked) 
     285               END DO 
     286            END DO 
    183287         END DO 
    184288         ! 
    185       CASE( 2 )                !==  Linear formulation function of temperature and salinity  ==! 
    186          DO jk = 1, jpkm1 
    187             prd(:,:,jk) = ( rn_beta  * pts(:,:,jk,jp_sal) - rn_alpha * pts(:,:,jk,jp_tem) ) * tmask(:,:,jk) 
    188          END DO 
    189          ! 
    190289      END SELECT 
    191290      ! 
    192       IF(ln_ctl)   CALL prt_ctl( tab3d_1=prd, clinfo1=' eos  : ', ovlap=1, kdim=jpk ) 
    193       ! 
    194       CALL wrk_dealloc( jpi, jpj, jpk, zws ) 
    195       ! 
    196       IF( nn_timing == 1 ) CALL timing_stop('eos') 
     291      IF(ln_ctl)   CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-insitu  : ', ovlap=1, kdim=jpk ) 
     292      ! 
     293      IF( nn_timing == 1 )   CALL timing_stop('eos-insitu') 
    197294      ! 
    198295   END SUBROUTINE eos_insitu 
    … …  
    208305      !!     namelist parameter nn_eos. 
    209306      !! 
    210       !! ** Method  : 
    211       !!      nn_eos = 0 : Jackett and McDougall (1994) equation of state. 
    212       !!         the in situ density is computed directly as a function of 
    213       !!         potential temperature relative to the surface (the opa t 
    214       !!         variable), salt and pressure (assuming no pressure variation 
    215       !!         along geopotential surfaces, i.e. the pressure p in decibars 
    216       !!         is approximated by the depth in meters. 
    217       !!              prd(t,s,p) = ( rho(t,s,p) - rau0 ) / rau0 
    218       !!              rhop(t,s)  = rho(t,s,0) 
    219       !!         with pressure                      p        decibars 
    220       !!              potential temperature         t        deg celsius 
    221       !!              salinity                      s        psu 
    222       !!              reference volumic mass        rau0     kg/m**3 
    223       !!              in situ volumic mass          rho      kg/m**3 
    224       !!              in situ density anomalie      prd      no units 
    225       !! 
    226       !!         Check value: rho = 1060.93298 kg/m**3 for p=10000 dbar, 
    227       !!          t = 40 deg celcius, s=40 psu 
    228       !! 
    229       !!      nn_eos = 1 : linear equation of state function of temperature only 
    230       !!              prd(t) = ( rho(t) - rau0 ) / rau0 = 0.028 - rn_alpha * t 
    231       !!              rhop(t,s)  = rho(t,s) 
    232       !! 
    233       !!      nn_eos = 2 : linear equation of state function of temperature and 
    234       !!               salinity 
    235       !!              prd(t,s) = ( rho(t,s) - rau0 ) / rau0 
    236       !!                       = rn_beta * s - rn_alpha * tn - 1. 
    237       !!              rhop(t,s)  = rho(t,s) 
    238       !!      Note that no boundary condition problem occurs in this routine 
    239       !!      as (tn,sn) or (ta,sa) are defined over the whole domain. 
    240       !! 
    241307      !! ** Action  : - prd  , the in situ density (no units) 
    242308      !!              - prhop, the potential volumic mass (Kg/m3) 
    243309      !! 
    244       !! References :   Jackett and McDougall, J. Atmos. Ocean. Tech., 1994 
    245       !!                Brown and Campana, Mon. Weather Rev., 1978 
    246       !!---------------------------------------------------------------------- 
    247       !! 
     310      !!---------------------------------------------------------------------- 
    248311      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::   pts    ! 1 : potential temperature  [Celcius] 
    249312      !                                                                ! 2 : salinity               [psu] 
    … …  
    252315      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pdep   ! depth                      [m] 
    253316      ! 
    254       INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    255       REAL(wp) ::   zt, zs, zh, zsr, zr1, zr2, zr3, zr4, zrhop, ze, zbw   ! local scalars 
    256       REAL(wp) ::   zb, zd, zc, zaw, za, zb1, za1, zkw, zk0               !   -      - 
    257       REAL(wp), POINTER, DIMENSION(:,:,:) :: zws 
    258       !!---------------------------------------------------------------------- 
    259       ! 
    260       IF( nn_timing == 1 ) CALL timing_start('eos-p') 
    261       ! 
    262       CALL wrk_alloc( jpi, jpj, jpk, zws ) 
     317      INTEGER  ::   ji, jj, jk, jsmp             ! dummy loop indices 
     318      INTEGER  ::   jdof 
     319      REAL(wp) ::   zt , zh , zstemp, zs , ztm   ! local scalars 
     320      REAL(wp) ::   zn , zn0, zn1, zn2, zn3      !   -      - 
     321      REAL(wp), DIMENSION(:), ALLOCATABLE :: zn0_sto, zn_sto, zsign    ! local vectors 
     322      !!---------------------------------------------------------------------- 
     323      ! 
     324      IF( nn_timing == 1 )   CALL timing_start('eos-pot') 
    263325      ! 
    264326      SELECT CASE ( nn_eos ) 
    265327      ! 
    266       CASE( 0 )                !==  Jackett and McDougall (1994) formulation  ==! 
    267 !CDIR NOVERRCHK 
    268          zws(:,:,:) = SQRT( ABS( pts(:,:,:,jp_sal) ) ) 
     328      CASE( -1, 0 )                !==  polynomial TEOS-10 / EOS-80 ==! 
     329         ! 
     330         ! Stochastic equation of state 
     331         IF ( ln_sto_eos ) THEN 
     332            ALLOCATE(zn0_sto(1:2*nn_sto_eos)) 
     333            ALLOCATE(zn_sto(1:2*nn_sto_eos)) 
     334            ALLOCATE(zsign(1:2*nn_sto_eos)) 
     335            DO jsmp = 1, 2*nn_sto_eos, 2 
     336              zsign(jsmp)   = 1._wp 
     337              zsign(jsmp+1) = -1._wp 
     338            END DO 
     339            ! 
     340            DO jk = 1, jpkm1 
     341               DO jj = 1, jpj 
     342                  DO ji = 1, jpi 
     343                     ! 
     344                     ! compute density (2*nn_sto_eos) times: 
     345                     ! (1) for t+dt, s+ds (with the random TS fluctutation computed in sto_pts) 
     346                     ! (2) for t-dt, s-ds (with the opposite fluctuation) 
     347                     DO jsmp = 1, nn_sto_eos*2 
     348                        jdof   = (jsmp + 1) / 2 
     349                        zh     = pdep(ji,jj,jk) * r1_Z0                                  ! depth 
     350                        zt     = (pts (ji,jj,jk,jp_tem) + pts_ran(ji,jj,jk,jp_tem,jdof) * zsign(jsmp)) * r1_T0    ! temperature 
     351                        zstemp = pts  (ji,jj,jk,jp_sal) + pts_ran(ji,jj,jk,jp_sal,jdof) * zsign(jsmp) 
     352                        zs     = SQRT( ABS( zstemp + rdeltaS ) * r1_S0 )   ! square root salinity 
     353                        ztm    = tmask(ji,jj,jk)                                         ! tmask 
     354                        ! 
     355                        zn3 = EOS013*zt   & 
     356                           &   + EOS103*zs+EOS003 
     357                           ! 
     358                        zn2 = (EOS022*zt   & 
     359                           &   + EOS112*zs+EOS012)*zt   & 
     360                           &   + (EOS202*zs+EOS102)*zs+EOS002 
     361                           ! 
     362                        zn1 = (((EOS041*zt   & 
     363                           &   + EOS131*zs+EOS031)*zt   & 
     364                           &   + (EOS221*zs+EOS121)*zs+EOS021)*zt   & 
     365                           &   + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt   & 
     366                           &   + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 
     367                           ! 
     368                        zn0_sto(jsmp) = (((((EOS060*zt   & 
     369                           &   + EOS150*zs+EOS050)*zt   & 
     370                           &   + (EOS240*zs+EOS140)*zs+EOS040)*zt   & 
     371                           &   + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt   & 
     372                           &   + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt   & 
     373                           &   + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt   & 
     374                           &   + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 
     375                           ! 
     376                        zn_sto(jsmp)  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0_sto(jsmp) 
     377                     END DO 
     378                     ! 
     379                     ! compute stochastic density as the mean of the (2*nn_sto_eos) densities 
     380                     prhop(ji,jj,jk) = 0._wp ; prd(ji,jj,jk) = 0._wp 
     381                     DO jsmp = 1, nn_sto_eos*2 
     382                        prhop(ji,jj,jk) = prhop(ji,jj,jk) + zn0_sto(jsmp)                      ! potential density referenced at the surface 
     383                        ! 
     384                        prd(ji,jj,jk) = prd(ji,jj,jk) + (  zn_sto(jsmp) * r1_rau0 - 1._wp  )   ! density anomaly (masked) 
     385                     END DO 
     386                     prhop(ji,jj,jk) = 0.5_wp * prhop(ji,jj,jk) * ztm / nn_sto_eos 
     387                     prd  (ji,jj,jk) = 0.5_wp * prd  (ji,jj,jk) * ztm / nn_sto_eos 
     388                  END DO 
     389               END DO 
     390            END DO 
     391            DEALLOCATE(zn0_sto,zn_sto,zsign) 
     392         ! Non-stochastic equation of state 
     393         ELSE 
     394            DO jk = 1, jpkm1 
     395               DO jj = 1, jpj 
     396                  DO ji = 1, jpi 
     397                     ! 
     398                     zh  = pdep(ji,jj,jk) * r1_Z0                                  ! depth 
     399                     zt  = pts (ji,jj,jk,jp_tem) * r1_T0                           ! temperature 
     400                     zs  = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity 
     401                     ztm = tmask(ji,jj,jk)                                         ! tmask 
     402                     ! 
     403                     zn3 = EOS013*zt   & 
     404                        &   + EOS103*zs+EOS003 
     405                        ! 
     406                     zn2 = (EOS022*zt   & 
     407                        &   + EOS112*zs+EOS012)*zt   & 
     408                        &   + (EOS202*zs+EOS102)*zs+EOS002 
     409                        ! 
     410                     zn1 = (((EOS041*zt   & 
     411                        &   + EOS131*zs+EOS031)*zt   & 
     412                        &   + (EOS221*zs+EOS121)*zs+EOS021)*zt   & 
     413                        &   + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt   & 
     414                        &   + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 
     415                        ! 
     416                     zn0 = (((((EOS060*zt   & 
     417                        &   + EOS150*zs+EOS050)*zt   & 
     418                        &   + (EOS240*zs+EOS140)*zs+EOS040)*zt   & 
     419                        &   + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt   & 
     420                        &   + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt   & 
     421                        &   + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt   & 
     422                        &   + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 
     423                        ! 
     424                     zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 
     425                     ! 
     426                     prhop(ji,jj,jk) = zn0 * ztm                           ! potential density referenced at the surface 
     427                     ! 
     428                     prd(ji,jj,jk) = (  zn * r1_rau0 - 1._wp  ) * ztm      ! density anomaly (masked) 
     429                  END DO 
     430               END DO 
     431            END DO 
     432         ENDIF 
     433          
     434      CASE( 1 )                !==  simplified EOS  ==! 
    269435         ! 
    270436         DO jk = 1, jpkm1 
    271437            DO jj = 1, jpj 
    272438               DO ji = 1, jpi 
    273                   zt = pts   (ji,jj,jk,jp_tem) 
    274                   zs = pts   (ji,jj,jk,jp_sal) 
    275                   zh = pdep(ji,jj,jk)        ! depth 
    276                   zsr= zws   (ji,jj,jk)        ! square root salinity 
    277                   ! 
    278                   ! compute volumic mass pure water at atm pressure 
    279                   zr1= ( ( ( ( 6.536332e-9_wp*zt-1.120083e-6_wp )*zt+1.001685e-4_wp )*zt   & 
    280                      &                          -9.095290e-3_wp )*zt+6.793952e-2_wp )*zt+999.842594_wp 
    281                   ! seawater volumic mass atm pressure 
    282                   zr2= ( ( ( 5.3875e-9_wp*zt-8.2467e-7_wp ) *zt+7.6438e-5_wp ) *zt   & 
    283                      &                                         -4.0899e-3_wp ) *zt+0.824493_wp 
    284                   zr3= ( -1.6546e-6_wp*zt+1.0227e-4_wp )    *zt-5.72466e-3_wp 
    285                   zr4= 4.8314e-4_wp 
    286                   ! 
    287                   ! potential volumic mass (reference to the surface) 
    288                   zrhop= ( zr4*zs + zr3*zsr + zr2 ) *zs + zr1 
    289                   ! 
    290                   ! save potential volumic mass 
    291                   prhop(ji,jj,jk) = zrhop * tmask(ji,jj,jk) 
    292                   ! 
    293                   ! add the compression terms 
    294                   ze = ( -3.508914e-8_wp*zt-1.248266e-8_wp ) *zt-2.595994e-6_wp 
    295                   zbw= (  1.296821e-6_wp*zt-5.782165e-9_wp ) *zt+1.045941e-4_wp 
    296                   zb = zbw + ze * zs 
    297                   ! 
    298                   zd = -2.042967e-2_wp 
    299                   zc =   (-7.267926e-5_wp*zt+2.598241e-3_wp ) *zt+0.1571896_wp 
    300                   zaw= ( ( 5.939910e-6_wp*zt+2.512549e-3_wp ) *zt-0.1028859_wp ) *zt - 4.721788_wp 
    301                   za = ( zd*zsr + zc ) *zs + zaw 
    302                   ! 
    303                   zb1=   (  -0.1909078_wp  *zt+7.390729_wp    ) *zt-55.87545_wp 
    304                   za1= ( (   2.326469e-3_wp*zt+1.553190_wp    ) *zt-65.00517_wp ) *zt + 1044.077_wp 
    305                   zkw= ( ( (-1.361629e-4_wp*zt-1.852732e-2_wp ) *zt-30.41638_wp ) *zt + 2098.925_wp ) *zt+190925.6_wp 
    306                   zk0= ( zb1*zsr + za1 )*zs + zkw 
    307                   ! 
    308                   ! masked in situ density anomaly 
    309                   prd(ji,jj,jk) = (  zrhop / (  1.0_wp - zh / ( zk0 - zh * ( za - zh * zb ) )  )    & 
    310                      &             - rau0  ) * r1_rau0 * tmask(ji,jj,jk) 
     439                  zt  = pts  (ji,jj,jk,jp_tem) - 10._wp 
     440                  zs  = pts  (ji,jj,jk,jp_sal) - 35._wp 
     441                  zh  = pdep (ji,jj,jk) 
     442                  ztm = tmask(ji,jj,jk) 
     443                  !                                                     ! potential density referenced at the surface 
     444                  zn =  - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt ) * zt   & 
     445                     &  + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs ) * zs   & 
     446                     &  - rn_nu * zt * zs 
     447                  prhop(ji,jj,jk) = ( rau0 + zn ) * ztm 
     448                  !                                                     ! density anomaly (masked) 
     449                  zn = zn - ( rn_a0 * rn_mu1 * zt + rn_b0 * rn_mu2 * zs ) * zh 
     450                  prd(ji,jj,jk) = zn * r1_rau0 * ztm 
     451                  ! 
    311452               END DO 
    312453            END DO 
    313454         END DO 
    314455         ! 
    315       CASE( 1 )                !==  Linear formulation = F( temperature )  ==! 
    316          DO jk = 1, jpkm1 
    317             prd  (:,:,jk) = ( 0.0285_wp - rn_alpha * pts(:,:,jk,jp_tem) )        * tmask(:,:,jk) 
    318             prhop(:,:,jk) = ( 1.e0_wp   +            prd (:,:,jk)       ) * rau0 * tmask(:,:,jk) 
    319          END DO 
    320          ! 
    321       CASE( 2 )                !==  Linear formulation = F( temperature , salinity )  ==! 
    322          DO jk = 1, jpkm1 
    323             prd  (:,:,jk) = ( rn_beta  * pts(:,:,jk,jp_sal) - rn_alpha * pts(:,:,jk,jp_tem) )        * tmask(:,:,jk) 
    324             prhop(:,:,jk) = ( 1.e0_wp  + prd (:,:,jk) )                                       * rau0 * tmask(:,:,jk) 
    325          END DO 
    326          ! 
    327456      END SELECT 
    328457      ! 
    329       IF(ln_ctl)   CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-p: ', tab3d_2=prhop, clinfo2=' pot : ', ovlap=1, kdim=jpk ) 
    330       ! 
    331       CALL wrk_dealloc( jpi, jpj, jpk, zws ) 
    332       ! 
    333       IF( nn_timing == 1 ) CALL timing_stop('eos-p') 
     458      IF(ln_ctl)   CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-pot: ', tab3d_2=prhop, clinfo2=' pot : ', ovlap=1, kdim=jpk ) 
     459      ! 
     460      IF( nn_timing == 1 )   CALL timing_stop('eos-pot') 
    334461      ! 
    335462   END SUBROUTINE eos_insitu_pot 
    … …  
    344471      !!      defined through the namelist parameter nn_eos. * 2D field case 
    345472      !! 
    346       !! ** Method : 
    347       !!      nn_eos = 0 : Jackett and McDougall (1994) equation of state. 
    348       !!         the in situ density is computed directly as a function of 
    349       !!         potential temperature relative to the surface (the opa t 
    350       !!         variable), salt and pressure (assuming no pressure variation 
    351       !!         along geopotential surfaces, i.e. the pressure p in decibars 
    352       !!         is approximated by the depth in meters. 
    353       !!              prd(t,s,p) = ( rho(t,s,p) - rau0 ) / rau0 
    354       !!         with pressure                      p        decibars 
    355       !!              potential temperature         t        deg celsius 
    356       !!              salinity                      s        psu 
    357       !!              reference volumic mass        rau0     kg/m**3 
    358       !!              in situ volumic mass          rho      kg/m**3 
    359       !!              in situ density anomalie      prd      no units 
    360       !!         Check value: rho = 1060.93298 kg/m**3 for p=10000 dbar, 
    361       !!          t = 40 deg celcius, s=40 psu 
    362       !!      nn_eos = 1 : linear equation of state function of temperature only 
    363       !!              prd(t) = 0.0285 - rn_alpha * t 
    364       !!      nn_eos = 2 : linear equation of state function of temperature and 
    365       !!               salinity 
    366       !!              prd(t,s) = rn_beta * s - rn_alpha * tn - 1. 
    367       !!      Note that no boundary condition problem occurs in this routine 
    368       !!      as pts are defined over the whole domain. 
    369       !! 
    370       !! ** Action  : - prd , the in situ density (no units) 
    371       !! 
    372       !! References :   Jackett and McDougall, J. Atmos. Ocean. Tech., 1994 
    373       !!---------------------------------------------------------------------- 
    374       !! 
     473      !! ** Action  : - prd , the in situ density (no units) (unmasked) 
     474      !! 
     475      !!---------------------------------------------------------------------- 
    375476      REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT(in   ) ::   pts   ! 1 : potential temperature  [Celcius] 
    376477      !                                                           ! 2 : salinity               [psu] 
    377       REAL(wp), DIMENSION(jpi,jpj)     , INTENT(in   ) ::   pdep  ! depth                  [m] 
     478      REAL(wp), DIMENSION(jpi,jpj)     , INTENT(in   ) ::   pdep  ! depth                      [m] 
    378479      REAL(wp), DIMENSION(jpi,jpj)     , INTENT(  out) ::   prd   ! in situ density 
    379       !! 
    380       INTEGER  ::   ji, jj                    ! dummy loop indices 
    381       REAL(wp) ::   zt, zs, zh, zsr, zr1, zr2, zr3, zr4, zrhop, ze, zbw   ! temporary scalars 
    382       REAL(wp) ::   zb, zd, zc, zaw, za, zb1, za1, zkw, zk0, zmask        !    -         - 
    383       REAL(wp), POINTER, DIMENSION(:,:) :: zws 
    384       !!---------------------------------------------------------------------- 
    385       ! 
    386       IF( nn_timing == 1 ) CALL timing_start('eos2d') 
    387       ! 
    388       CALL wrk_alloc( jpi, jpj, zws ) 
    389       ! 
    390  
     480      ! 
     481      INTEGER  ::   ji, jj, jk                ! dummy loop indices 
     482      REAL(wp) ::   zt , zh , zs              ! local scalars 
     483      REAL(wp) ::   zn , zn0, zn1, zn2, zn3   !   -      - 
     484      !!---------------------------------------------------------------------- 
     485      ! 
     486      IF( nn_timing == 1 )   CALL timing_start('eos2d') 
     487      ! 
    391488      prd(:,:) = 0._wp 
    392  
     489      ! 
    393490      SELECT CASE( nn_eos ) 
    394491      ! 
    395       CASE( 0 )                !==  Jackett and McDougall (1994) formulation  ==! 
    396       ! 
    397 !CDIR NOVERRCHK 
     492      CASE( -1, 0 )                !==  polynomial TEOS-10 / EOS-80 ==! 
     493         ! 
    398494         DO jj = 1, jpjm1 
    399 !CDIR NOVERRCHK 
    400495            DO ji = 1, fs_jpim1   ! vector opt. 
    401                zws(ji,jj) = SQRT( ABS( pts(ji,jj,jp_sal) ) ) 
     496               ! 
     497               zh  = pdep(ji,jj) * r1_Z0                                  ! depth 
     498               zt  = pts (ji,jj,jp_tem) * r1_T0                           ! temperature 
     499               zs  = SQRT( ABS( pts(ji,jj,jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity 
     500               ! 
     501               zn3 = EOS013*zt   & 
     502                  &   + EOS103*zs+EOS003 
     503                  ! 
     504               zn2 = (EOS022*zt   & 
     505                  &   + EOS112*zs+EOS012)*zt   & 
     506                  &   + (EOS202*zs+EOS102)*zs+EOS002 
     507                  ! 
     508               zn1 = (((EOS041*zt   & 
     509                  &   + EOS131*zs+EOS031)*zt   & 
     510                  &   + (EOS221*zs+EOS121)*zs+EOS021)*zt   & 
     511                  &   + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt   & 
     512                  &   + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 
     513                  ! 
     514               zn0 = (((((EOS060*zt   & 
     515                  &   + EOS150*zs+EOS050)*zt   & 
     516                  &   + (EOS240*zs+EOS140)*zs+EOS040)*zt   & 
     517                  &   + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt   & 
     518                  &   + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt   & 
     519                  &   + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt   & 
     520                  &   + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 
     521                  ! 
     522               zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 
     523               ! 
     524               prd(ji,jj) = zn * r1_rau0 - 1._wp               ! unmasked in situ density anomaly 
     525               ! 
    402526            END DO 
    403527         END DO 
     528         ! 
     529         CALL lbc_lnk( prd, 'T', 1. )                    ! Lateral boundary conditions 
     530         ! 
     531      CASE( 1 )                !==  simplified EOS  ==! 
     532         ! 
    404533         DO jj = 1, jpjm1 
    405534            DO ji = 1, fs_jpim1   ! vector opt. 
    406                zmask = tmask(ji,jj,1)          ! land/sea bottom mask = surf. mask 
    407                zt    = pts  (ji,jj,jp_tem)            ! interpolated T 
    408                zs    = pts  (ji,jj,jp_sal)            ! interpolated S 
    409                zsr   = zws  (ji,jj)            ! square root of interpolated S 
    410                zh    = pdep (ji,jj)            ! depth at the partial step level 
    411                ! 
    412                ! compute volumic mass pure water at atm pressure 
    413                zr1 = ( ( ( ( 6.536332e-9_wp*zt-1.120083e-6_wp )*zt+1.001685e-4_wp )*zt   & 
    414                   &                        -9.095290e-3_wp )*zt+6.793952e-2_wp )*zt+999.842594_wp 
    415                ! seawater volumic mass atm pressure 
    416                zr2 = ( ( ( 5.3875e-9_wp*zt-8.2467e-7_wp )*zt+7.6438e-5_wp ) *zt   & 
    417                   &                                   -4.0899e-3_wp ) *zt+0.824493_wp 
    418                zr3 = ( -1.6546e-6_wp*zt+1.0227e-4_wp ) *zt-5.72466e-3_wp 
    419                zr4 = 4.8314e-4_wp 
    420                ! 
    421                ! potential volumic mass (reference to the surface) 
    422                zrhop= ( zr4*zs + zr3*zsr + zr2 ) *zs + zr1 
    423                ! 
    424                ! add the compression terms 
    425                ze = ( -3.508914e-8_wp*zt-1.248266e-8_wp ) *zt-2.595994e-6_wp 
    426                zbw= (  1.296821e-6_wp*zt-5.782165e-9_wp ) *zt+1.045941e-4_wp 
    427                zb = zbw + ze * zs 
    428                ! 
    429                zd =    -2.042967e-2_wp 
    430                zc =   (-7.267926e-5_wp*zt+2.598241e-3_wp ) *zt+0.1571896_wp 
    431                zaw= ( ( 5.939910e-6_wp*zt+2.512549e-3_wp ) *zt-0.1028859_wp ) *zt -4.721788_wp 
    432                za = ( zd*zsr + zc ) *zs + zaw 
    433                ! 
    434                zb1=     (-0.1909078_wp  *zt+7.390729_wp      ) *zt-55.87545_wp 
    435                za1=   ( ( 2.326469e-3_wp*zt+1.553190_wp      ) *zt-65.00517_wp ) *zt+1044.077_wp 
    436                zkw= ( ( (-1.361629e-4_wp*zt-1.852732e-2_wp   ) *zt-30.41638_wp ) *zt   & 
    437                   &                             +2098.925_wp ) *zt+190925.6_wp 
    438                zk0= ( zb1*zsr + za1 )*zs + zkw 
    439                ! 
    440                ! masked in situ density anomaly 
    441                prd(ji,jj) = ( zrhop / (  1.0_wp - zh / ( zk0 - zh * ( za - zh * zb ) )  ) - rau0 ) / rau0 * zmask 
     535               ! 
     536               zt    = pts  (ji,jj,jp_tem)  - 10._wp 
     537               zs    = pts  (ji,jj,jp_sal)  - 35._wp 
     538               zh    = pdep (ji,jj)                         ! depth at the partial step level 
     539               ! 
     540               zn =  - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt + rn_mu1*zh ) * zt   & 
     541                  &  + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs - rn_mu2*zh ) * zs   & 
     542                  &  - rn_nu * zt * zs 
     543                  ! 
     544               prd(ji,jj) = zn * r1_rau0               ! unmasked in situ density anomaly 
     545               ! 
    442546            END DO 
    443547         END DO 
    444548         ! 
    445       CASE( 1 )                !==  Linear formulation = F( temperature )  ==! 
    446          DO jj = 1, jpjm1 
    447             DO ji = 1, fs_jpim1   ! vector opt. 
    448                prd(ji,jj) = ( 0.0285_wp - rn_alpha * pts(ji,jj,jp_tem) ) * tmask(ji,jj,1) 
    449             END DO 
    450          END DO 
    451          ! 
    452       CASE( 2 )                !==  Linear formulation = F( temperature , salinity )  ==! 
    453          DO jj = 1, jpjm1 
    454             DO ji = 1, fs_jpim1   ! vector opt. 
    455                prd(ji,jj) = ( rn_beta * pts(ji,jj,jp_sal) - rn_alpha * pts(ji,jj,jp_tem) ) * tmask(ji,jj,1) 
    456             END DO 
    457          END DO 
     549         CALL lbc_lnk( prd, 'T', 1. )                    ! Lateral boundary conditions 
    458550         ! 
    459551      END SELECT 
    460  
     552      ! 
    461553      IF(ln_ctl)   CALL prt_ctl( tab2d_1=prd, clinfo1=' eos2d: ' ) 
    462554      ! 
    463       CALL wrk_dealloc( jpi, jpj, zws ) 
    464       ! 
    465       IF( nn_timing == 1 ) CALL timing_stop('eos2d') 
     555      IF( nn_timing == 1 )   CALL timing_stop('eos2d') 
    466556      ! 
    467557   END SUBROUTINE eos_insitu_2d 
    468558 
    469559 
    470    SUBROUTINE eos_bn2( pts, pn2 ) 
    471       !!---------------------------------------------------------------------- 
    472       !!                  ***  ROUTINE eos_bn2  *** 
    473       !! 
    474       !! ** Purpose :   Compute the local Brunt-Vaisala frequency at the time- 
    475       !!      step of the input arguments 
    476       !! 
    477       !! ** Method : 
    478       !!       * nn_eos = 0  : UNESCO sea water properties 
    479       !!         The brunt-vaisala frequency is computed using the polynomial 
    480       !!      polynomial expression of McDougall (1987): 
    481       !!            N^2 = grav * beta * ( alpha/beta*dk[ t ] - dk[ s ] )/e3w 
    482       !!      If lk_zdfddm=T, the heat/salt buoyancy flux ratio Rrau is 
    483       !!      computed and used in zdfddm module : 
    484       !!              Rrau = alpha/beta * ( dk[ t ] / dk[ s ] ) 
    485       !!       * nn_eos = 1  : linear equation of state (temperature only) 
    486       !!            N^2 = grav * rn_alpha * dk[ t ]/e3w 
    487       !!       * nn_eos = 2  : linear equation of state (temperature & salinity) 
    488       !!            N^2 = grav * (rn_alpha * dk[ t ] - rn_beta * dk[ s ] ) / e3w 
    489       !!      The use of potential density to compute N^2 introduces e r r o r 
    490       !!      in the sign of N^2 at great depths. We recommand the use of 
    491       !!      nn_eos = 0, except for academical studies. 
    492       !!        Macro-tasked on horizontal slab (jk-loop) 
    493       !!      N.B. N^2 is set to zero at the first level (JK=1) in inidtr 
    494       !!      and is never used at this level. 
    495       !! 
    496       !! ** Action  : - pn2 : the brunt-vaisala frequency 
    497       !! 
    498       !! References :   McDougall, J. Phys. Oceanogr., 17, 1950-1964, 1987. 
    499       !!---------------------------------------------------------------------- 
    500       REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::   pts   ! 1 : potential temperature  [Celcius] 
    501       !                                                               ! 2 : salinity               [psu] 
    502       REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(  out) ::   pn2   ! Brunt-Vaisala frequency    [s-1] 
    503       !! 
    504       INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    505       REAL(wp) ::   zgde3w, zt, zs, zh, zalbet, zbeta   ! local scalars 
    506 #if defined key_zdfddm 
    507       REAL(wp) ::   zds   ! local scalars 
    508 #endif 
    509       !!---------------------------------------------------------------------- 
    510  
    511       ! 
    512       IF( nn_timing == 1 ) CALL timing_start('bn2') 
    513       ! 
    514       ! pn2 : interior points only (2=< jk =< jpkm1 ) 
    515       ! -------------------------- 
    516       ! 
    517       SELECT CASE( nn_eos ) 
    518       ! 
    519       CASE( 0 )                !==  Jackett and McDougall (1994) formulation  ==! 
    520          DO jk = 2, jpkm1 
     560   SUBROUTINE rab_3d( pts, pab ) 
     561      !!---------------------------------------------------------------------- 
     562      !!                 ***  ROUTINE rab_3d  *** 
     563      !! 
     564      !! ** Purpose :   Calculates thermal/haline expansion ratio at T-points 
     565      !! 
     566      !! ** Method  :   calculates alpha / beta at T-points 
     567      !! 
     568      !! ** Action  : - pab     : thermal/haline expansion ratio at T-points 
     569      !!---------------------------------------------------------------------- 
     570      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::   pts   ! pot. temperature & salinity 
     571      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(  out) ::   pab   ! thermal/haline expansion ratio 
     572      ! 
     573      INTEGER  ::   ji, jj, jk                ! dummy loop indices 
     574      REAL(wp) ::   zt , zh , zs , ztm        ! local scalars 
     575      REAL(wp) ::   zn , zn0, zn1, zn2, zn3   !   -      - 
     576      !!---------------------------------------------------------------------- 
     577      ! 
     578      IF( nn_timing == 1 )   CALL timing_start('rab_3d') 
     579      ! 
     580      SELECT CASE ( nn_eos ) 
     581      ! 
     582      CASE( -1, 0 )                !==  polynomial TEOS-10 / EOS-80 ==! 
     583         ! 
     584         DO jk = 1, jpkm1 
    521585            DO jj = 1, jpj 
    522586               DO ji = 1, jpi 
    523                   zgde3w = grav / fse3w(ji,jj,jk) 
    524                   zt = 0.5 * ( pts(ji,jj,jk,jp_tem) + pts(ji,jj,jk-1,jp_tem) )         ! potential temperature at w-pt 
    525                   zs = 0.5 * ( pts(ji,jj,jk,jp_sal) + pts(ji,jj,jk-1,jp_sal) ) - 35.0  ! salinity anomaly (s-35) at w-pt 
    526                   zh = fsdepw(ji,jj,jk)                                                ! depth in meters  at w-point 
    527                   ! 
    528                   zalbet = ( ( ( - 0.255019e-07_wp * zt + 0.298357e-05_wp ) * zt   &   ! ratio alpha/beta 
    529                      &                                  - 0.203814e-03_wp ) * zt   & 
    530                      &                                  + 0.170907e-01_wp ) * zt   & 
    531                      &   +         0.665157e-01_wp                                 & 
    532                      &   +     ( - 0.678662e-05_wp * zs                            & 
    533                      &           - 0.846960e-04_wp * zt + 0.378110e-02_wp ) * zs   & 
    534                      &   +   ( ( - 0.302285e-13_wp * zh                            & 
    535                      &           - 0.251520e-11_wp * zs                            & 
    536                      &           + 0.512857e-12_wp * zt * zt              ) * zh   & 
    537                      &           - 0.164759e-06_wp * zs                            & 
    538                      &        +(   0.791325e-08_wp * zt - 0.933746e-06_wp ) * zt   & 
    539                      &                                  + 0.380374e-04_wp ) * zh 
    540                      ! 
    541                   zbeta  = ( ( -0.415613e-09_wp * zt + 0.555579e-07_wp ) * zt      &   ! beta 
    542                      &                               - 0.301985e-05_wp ) * zt      & 
    543                      &   +       0.785567e-03_wp                                   & 
    544                      &   + (     0.515032e-08_wp * zs                              & 
    545                      &         + 0.788212e-08_wp * zt - 0.356603e-06_wp ) * zs     & 
    546                      &   + ( (   0.121551e-17_wp * zh                              & 
    547                      &         - 0.602281e-15_wp * zs                              & 
    548                      &         - 0.175379e-14_wp * zt + 0.176621e-12_wp ) * zh     & 
    549                      &                                + 0.408195e-10_wp   * zs     & 
    550                      &     + ( - 0.213127e-11_wp * zt + 0.192867e-09_wp ) * zt     & 
    551                      &                                - 0.121555e-07_wp ) * zh 
    552                      ! 
    553                   pn2(ji,jj,jk) = zgde3w * zbeta * tmask(ji,jj,jk)           &   ! N^2 
    554                      &          * ( zalbet * ( pts(ji,jj,jk-1,jp_tem) - pts(ji,jj,jk,jp_tem) )   & 
    555                      &                     - ( pts(ji,jj,jk-1,jp_sal) - pts(ji,jj,jk,jp_sal) ) ) 
    556 #if defined key_zdfddm 
    557                   !                                                         !!bug **** caution a traiter zds=dk[S]= 0 !!!! 
    558                   zds = ( pts(ji,jj,jk-1,jp_sal) - pts(ji,jj,jk,jp_sal) )                    ! Rrau = (alpha / beta) (dk[t] / dk[s]) 
    559                   IF ( ABS( zds) <= 1.e-20_wp ) zds = 1.e-20_wp 
    560                   rrau(ji,jj,jk) = zalbet * ( pts(ji,jj,jk-1,jp_tem) - pts(ji,jj,jk,jp_tem) ) / zds 
    561 #endif 
     587                  ! 
     588                  zh  = fsdept(ji,jj,jk) * r1_Z0                                ! depth 
     589                  zt  = pts (ji,jj,jk,jp_tem) * r1_T0                           ! temperature 
     590                  zs  = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity 
     591                  ztm = tmask(ji,jj,jk)                                         ! tmask 
     592                  ! 
     593                  ! alpha 
     594                  zn3 = ALP003 
     595                  ! 
     596                  zn2 = ALP012*zt + ALP102*zs+ALP002 
     597                  ! 
     598                  zn1 = ((ALP031*zt   & 
     599                     &   + ALP121*zs+ALP021)*zt   & 
     600                     &   + (ALP211*zs+ALP111)*zs+ALP011)*zt   & 
     601                     &   + ((ALP301*zs+ALP201)*zs+ALP101)*zs+ALP001 
     602                     ! 
     603                  zn0 = ((((ALP050*zt   & 
     604                     &   + ALP140*zs+ALP040)*zt   & 
     605                     &   + (ALP230*zs+ALP130)*zs+ALP030)*zt   & 
     606                     &   + ((ALP320*zs+ALP220)*zs+ALP120)*zs+ALP020)*zt   & 
     607                     &   + (((ALP410*zs+ALP310)*zs+ALP210)*zs+ALP110)*zs+ALP010)*zt   & 
     608                     &   + ((((ALP500*zs+ALP400)*zs+ALP300)*zs+ALP200)*zs+ALP100)*zs+ALP000 
     609                     ! 
     610                  zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 
     611                  ! 
     612                  pab(ji,jj,jk,jp_tem) = zn * r1_rau0 * ztm 
     613                  ! 
     614                  ! beta 
     615                  zn3 = BET003 
     616                  ! 
     617                  zn2 = BET012*zt + BET102*zs+BET002 
     618                  ! 
     619                  zn1 = ((BET031*zt   & 
     620                     &   + BET121*zs+BET021)*zt   & 
     621                     &   + (BET211*zs+BET111)*zs+BET011)*zt   & 
     622                     &   + ((BET301*zs+BET201)*zs+BET101)*zs+BET001 
     623                     ! 
     624                  zn0 = ((((BET050*zt   & 
     625                     &   + BET140*zs+BET040)*zt   & 
     626                     &   + (BET230*zs+BET130)*zs+BET030)*zt   & 
     627                     &   + ((BET320*zs+BET220)*zs+BET120)*zs+BET020)*zt   & 
     628                     &   + (((BET410*zs+BET310)*zs+BET210)*zs+BET110)*zs+BET010)*zt   & 
     629                     &   + ((((BET500*zs+BET400)*zs+BET300)*zs+BET200)*zs+BET100)*zs+BET000 
     630                     ! 
     631                  zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 
     632                  ! 
     633                  pab(ji,jj,jk,jp_sal) = zn / zs * r1_rau0 * ztm 
     634                  ! 
    562635               END DO 
    563636            END DO 
    564637         END DO 
    565638         ! 
    566       CASE( 1 )                !==  Linear formulation = F( temperature )  ==! 
    567          DO jk = 2, jpkm1 
    568             pn2(:,:,jk) = grav * rn_alpha * ( pts(:,:,jk-1,jp_tem) - pts(:,:,jk,jp_tem) ) / fse3w(:,:,jk) * tmask(:,:,jk) 
    569          END DO 
    570          ! 
    571       CASE( 2 )                !==  Linear formulation = F( temperature , salinity )  ==! 
    572          DO jk = 2, jpkm1 
    573             pn2(:,:,jk) = grav * (  rn_alpha * ( pts(:,:,jk-1,jp_tem) - pts(:,:,jk,jp_tem) )      & 
    574                &                  - rn_beta  * ( pts(:,:,jk-1,jp_sal) - pts(:,:,jk,jp_sal) )  )   & 
    575                &               / fse3w(:,:,jk) * tmask(:,:,jk) 
    576          END DO 
    577 #if defined key_zdfddm 
    578          DO jk = 2, jpkm1                                 ! Rrau = (alpha / beta) (dk[t] / dk[s]) 
     639      CASE( 1 )                  !==  simplified EOS  ==! 
     640         ! 
     641         DO jk = 1, jpkm1 
    579642            DO jj = 1, jpj 
    580643               DO ji = 1, jpi 
    581                   zds = ( pts(ji,jj,jk-1,jp_sal) - pts(ji,jj,jk,jp_sal) ) 
    582                   IF ( ABS( zds ) <= 1.e-20_wp ) zds = 1.e-20_wp 
    583                   rrau(ji,jj,jk) = ralpbet * ( pts(ji,jj,jk-1,jp_tem) - pts(ji,jj,jk,jp_tem) ) / zds 
     644                  zt  = pts (ji,jj,jk,jp_tem) - 10._wp   ! pot. temperature anomaly (t-T0) 
     645                  zs  = pts (ji,jj,jk,jp_sal) - 35._wp   ! abs. salinity anomaly (s-S0) 
     646                  zh  = fsdept(ji,jj,jk)                 ! depth in meters at t-point 
     647                  ztm = tmask(ji,jj,jk)                  ! land/sea bottom mask = surf. mask 
     648                  ! 
     649                  zn  = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs 
     650                  pab(ji,jj,jk,jp_tem) = zn * r1_rau0 * ztm   ! alpha 
     651                  ! 
     652                  zn  = rn_b0 * ( 1._wp - rn_lambda2*zs - rn_mu2*zh ) - rn_nu*zt 
     653                  pab(ji,jj,jk,jp_sal) = zn * r1_rau0 * ztm   ! beta 
     654                  ! 
    584655               END DO 
    585656            END DO 
    586657         END DO 
    587 #endif 
    588       END SELECT 
    589  
    590       IF(ln_ctl)   CALL prt_ctl( tab3d_1=pn2, clinfo1=' bn2  : ', ovlap=1, kdim=jpk ) 
    591 #if defined key_zdfddm 
    592       IF(ln_ctl)   CALL prt_ctl( tab3d_1=rrau, clinfo1=' rrau : ', ovlap=1, kdim=jpk ) 
    593 #endif 
    594       ! 
    595       IF( nn_timing == 1 ) CALL timing_stop('bn2') 
    596       ! 
    597    END SUBROUTINE eos_bn2 
    598  
    599  
    600    SUBROUTINE eos_alpbet( pts, palpbet, beta0 ) 
    601       !!---------------------------------------------------------------------- 
    602       !!                 ***  ROUTINE eos_alpbet  *** 
    603       !! 
    604       !! ** Purpose :   Calculates the in situ thermal/haline expansion ratio at T-points 
    605       !! 
    606       !! ** Method  :   calculates alpha / beta ratio at T-points 
    607       !!       * nn_eos = 0  : UNESCO sea water properties 
    608       !!                       The alpha/beta ratio is returned as 3-D array palpbet using the polynomial 
    609       !!                       polynomial expression of McDougall (1987). 
    610       !!                       Scalar beta0 is returned = 1. 
    611       !!       * nn_eos = 1  : linear equation of state (temperature only) 
    612       !!                       The ratio is undefined, so we return alpha as palpbet 
    613       !!                       Scalar beta0 is returned = 0. 
    614       !!       * nn_eos = 2  : linear equation of state (temperature & salinity) 
    615       !!                       The alpha/beta ratio is returned as ralpbet 
    616       !!                       Scalar beta0 is returned = 1. 
    617       !! 
    618       !! ** Action  : - palpbet : thermal/haline expansion ratio at T-points 
    619       !!            :   beta0   : 1. or 0. 
    620       !!---------------------------------------------------------------------- 
    621       REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::   pts       ! pot. temperature & salinity 
    622       REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(  out) ::   palpbet   ! thermal/haline expansion ratio 
    623       REAL(wp),                              INTENT(  out) ::   beta0     ! set = 1 except with case 1 eos, rho=rho(T) 
    624       !! 
    625       INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    626       REAL(wp) ::   zt, zs, zh   ! local scalars 
    627       !!---------------------------------------------------------------------- 
    628       ! 
    629       IF( nn_timing == 1 ) CALL timing_start('eos_alpbet') 
    630       ! 
    631       SELECT CASE ( nn_eos ) 
    632       ! 
    633       CASE ( 0 )               ! Jackett and McDougall (1994) formulation 
    634          DO jk = 1, jpk 
    635             DO jj = 1, jpj 
    636                DO ji = 1, jpi 
    637                   zt = pts(ji,jj,jk,jp_tem)           ! potential temperature 
    638                   zs = pts(ji,jj,jk,jp_sal) - 35._wp  ! salinity anomaly (s-35) 
    639                   zh = fsdept(ji,jj,jk)               ! depth in meters 
    640                   ! 
    641                   palpbet(ji,jj,jk) =                                              & 
    642                      &     ( ( ( - 0.255019e-07_wp * zt + 0.298357e-05_wp ) * zt   & 
    643                      &                                  - 0.203814e-03_wp ) * zt   & 
    644                      &                                  + 0.170907e-01_wp ) * zt   & 
    645                      &   + 0.665157e-01_wp                                         & 
    646                      &   +     ( - 0.678662e-05_wp * zs                            & 
    647                      &           - 0.846960e-04_wp * zt + 0.378110e-02_wp ) * zs   & 
    648                      &   +   ( ( - 0.302285e-13_wp * zh                            & 
    649                      &           - 0.251520e-11_wp * zs                            & 
    650                      &           + 0.512857e-12_wp * zt * zt              ) * zh   & 
    651                      &           - 0.164759e-06_wp * zs                            & 
    652                      &        +(   0.791325e-08_wp * zt - 0.933746e-06_wp ) * zt   & 
    653                      &                                  + 0.380374e-04_wp ) * zh 
    654                END DO 
    655             END DO 
    656          END DO 
    657          beta0 = 1._wp 
    658          ! 
    659       CASE ( 1 )              !==  Linear formulation = F( temperature )  ==! 
    660          palpbet(:,:,:) = rn_alpha 
    661          beta0 = 0._wp 
    662          ! 
    663       CASE ( 2 )              !==  Linear formulation = F( temperature , salinity )  ==! 
    664          palpbet(:,:,:) = ralpbet 
    665          beta0 = 1._wp 
    666658         ! 
    667659      CASE DEFAULT 
    … …  
    672664      END SELECT 
    673665      ! 
    674       IF( nn_timing == 1 ) CALL timing_stop('eos_alpbet') 
    675       ! 
    676    END SUBROUTINE eos_alpbet 
    677  
    678  
    679    FUNCTION tfreez( psal, pdep ) RESULT( ptf ) 
     666      IF(ln_ctl)   CALL prt_ctl( tab3d_1=pab(:,:,:,jp_tem), clinfo1=' rab_3d_t: ', & 
     667         &                       tab3d_2=pab(:,:,:,jp_sal), clinfo2=' rab_3d_s : ', ovlap=1, kdim=jpk ) 
     668      ! 
     669      IF( nn_timing == 1 )   CALL timing_stop('rab_3d') 
     670      ! 
     671   END SUBROUTINE rab_3d 
     672 
     673   SUBROUTINE rab_2d( pts, pdep, pab ) 
     674      !!---------------------------------------------------------------------- 
     675      !!                 ***  ROUTINE rab_2d  *** 
     676      !! 
     677      !! ** Purpose :   Calculates thermal/haline expansion ratio for a 2d field (unmasked) 
     678      !! 
     679      !! ** Action  : - pab     : thermal/haline expansion ratio at T-points 
     680      !!---------------------------------------------------------------------- 
     681      REAL(wp), DIMENSION(jpi,jpj,jpts)    , INTENT(in   ) ::   pts    ! pot. temperature & salinity 
     682      REAL(wp), DIMENSION(jpi,jpj)         , INTENT(in   ) ::   pdep   ! depth                  [m] 
     683      REAL(wp), DIMENSION(jpi,jpj,jpts)    , INTENT(  out) ::   pab    ! thermal/haline expansion ratio 
     684      ! 
     685      INTEGER  ::   ji, jj, jk                ! dummy loop indices 
     686      REAL(wp) ::   zt , zh , zs              ! local scalars 
     687      REAL(wp) ::   zn , zn0, zn1, zn2, zn3   !   -      - 
     688      !!---------------------------------------------------------------------- 
     689      ! 
     690      IF( nn_timing == 1 ) CALL timing_start('rab_2d') 
     691      ! 
     692      pab(:,:,:) = 0._wp 
     693      ! 
     694      SELECT CASE ( nn_eos ) 
     695      ! 
     696      CASE( -1, 0 )                !==  polynomial TEOS-10 / EOS-80 ==! 
     697         ! 
     698         DO jj = 1, jpjm1 
     699            DO ji = 1, fs_jpim1   ! vector opt. 
     700               ! 
     701               zh  = pdep(ji,jj) * r1_Z0                                  ! depth 
     702               zt  = pts (ji,jj,jp_tem) * r1_T0                           ! temperature 
     703               zs  = SQRT( ABS( pts(ji,jj,jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity 
     704               ! 
     705               ! alpha 
     706               zn3 = ALP003 
     707               ! 
     708               zn2 = ALP012*zt + ALP102*zs+ALP002 
     709               ! 
     710               zn1 = ((ALP031*zt   & 
     711                  &   + ALP121*zs+ALP021)*zt   & 
     712                  &   + (ALP211*zs+ALP111)*zs+ALP011)*zt   & 
     713                  &   + ((ALP301*zs+ALP201)*zs+ALP101)*zs+ALP001 
     714                  ! 
     715               zn0 = ((((ALP050*zt   & 
     716                  &   + ALP140*zs+ALP040)*zt   & 
     717                  &   + (ALP230*zs+ALP130)*zs+ALP030)*zt   & 
     718                  &   + ((ALP320*zs+ALP220)*zs+ALP120)*zs+ALP020)*zt   & 
     719                  &   + (((ALP410*zs+ALP310)*zs+ALP210)*zs+ALP110)*zs+ALP010)*zt   & 
     720                  &   + ((((ALP500*zs+ALP400)*zs+ALP300)*zs+ALP200)*zs+ALP100)*zs+ALP000 
     721                  ! 
     722               zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 
     723               ! 
     724               pab(ji,jj,jp_tem) = zn * r1_rau0 
     725               ! 
     726               ! beta 
     727               zn3 = BET003 
     728               ! 
     729               zn2 = BET012*zt + BET102*zs+BET002 
     730               ! 
     731               zn1 = ((BET031*zt   & 
     732                  &   + BET121*zs+BET021)*zt   & 
     733                  &   + (BET211*zs+BET111)*zs+BET011)*zt   & 
     734                  &   + ((BET301*zs+BET201)*zs+BET101)*zs+BET001 
     735                  ! 
     736               zn0 = ((((BET050*zt   & 
     737                  &   + BET140*zs+BET040)*zt   & 
     738                  &   + (BET230*zs+BET130)*zs+BET030)*zt   & 
     739                  &   + ((BET320*zs+BET220)*zs+BET120)*zs+BET020)*zt   & 
     740                  &   + (((BET410*zs+BET310)*zs+BET210)*zs+BET110)*zs+BET010)*zt   & 
     741                  &   + ((((BET500*zs+BET400)*zs+BET300)*zs+BET200)*zs+BET100)*zs+BET000 
     742                  ! 
     743               zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 
     744               ! 
     745               pab(ji,jj,jp_sal) = zn / zs * r1_rau0 
     746               ! 
     747               ! 
     748            END DO 
     749         END DO 
     750         ! 
     751         CALL lbc_lnk( pab(:,:,jp_tem), 'T', 1. )                    ! Lateral boundary conditions 
     752         CALL lbc_lnk( pab(:,:,jp_sal), 'T', 1. )                     
     753         ! 
     754      CASE( 1 )                  !==  simplified EOS  ==! 
     755         ! 
     756         DO jj = 1, jpjm1 
     757            DO ji = 1, fs_jpim1   ! vector opt. 
     758               ! 
     759               zt    = pts  (ji,jj,jp_tem) - 10._wp   ! pot. temperature anomaly (t-T0) 
     760               zs    = pts  (ji,jj,jp_sal) - 35._wp   ! abs. salinity anomaly (s-S0) 
     761               zh    = pdep (ji,jj)                   ! depth at the partial step level 
     762               ! 
     763               zn  = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs 
     764               pab(ji,jj,jp_tem) = zn * r1_rau0   ! alpha 
     765               ! 
     766               zn  = rn_b0 * ( 1._wp - rn_lambda2*zs - rn_mu2*zh ) - rn_nu*zt 
     767               pab(ji,jj,jp_sal) = zn * r1_rau0   ! beta 
     768               ! 
     769            END DO 
     770         END DO 
     771         ! 
     772         CALL lbc_lnk( pab(:,:,jp_tem), 'T', 1. )                    ! Lateral boundary conditions 
     773         CALL lbc_lnk( pab(:,:,jp_sal), 'T', 1. )                     
     774         ! 
     775      CASE DEFAULT 
     776         IF(lwp) WRITE(numout,cform_err) 
     777         IF(lwp) WRITE(numout,*) '          bad flag value for nn_eos = ', nn_eos 
     778         nstop = nstop + 1 
     779         ! 
     780      END SELECT 
     781      ! 
     782      IF(ln_ctl)   CALL prt_ctl( tab2d_1=pab(:,:,jp_tem), clinfo1=' rab_2d_t: ', & 
     783         &                       tab2d_2=pab(:,:,jp_sal), clinfo2=' rab_2d_s : ' ) 
     784      ! 
     785      IF( nn_timing == 1 )   CALL timing_stop('rab_2d') 
     786      ! 
     787   END SUBROUTINE rab_2d 
     788 
     789 
     790   SUBROUTINE rab_0d( pts, pdep, pab ) 
     791      !!---------------------------------------------------------------------- 
     792      !!                 ***  ROUTINE rab_0d  *** 
     793      !! 
     794      !! ** Purpose :   Calculates thermal/haline expansion ratio for a 2d field (unmasked) 
     795      !! 
     796      !! ** Action  : - pab     : thermal/haline expansion ratio at T-points 
     797      !!---------------------------------------------------------------------- 
     798      REAL(wp), DIMENSION(jpts)    , INTENT(in   ) ::   pts    ! pot. temperature & salinity 
     799      REAL(wp),                      INTENT(in   ) ::   pdep   ! depth                  [m] 
     800      REAL(wp), DIMENSION(jpts)    , INTENT(  out) ::   pab    ! thermal/haline expansion ratio 
     801      ! 
     802      REAL(wp) ::   zt , zh , zs              ! local scalars 
     803      REAL(wp) ::   zn , zn0, zn1, zn2, zn3   !   -      - 
     804      !!---------------------------------------------------------------------- 
     805      ! 
     806      IF( nn_timing == 1 ) CALL timing_start('rab_2d') 
     807      ! 
     808      pab(:) = 0._wp 
     809      ! 
     810      SELECT CASE ( nn_eos ) 
     811      ! 
     812      CASE( -1, 0 )                !==  polynomial TEOS-10 / EOS-80 ==! 
     813         ! 
     814         ! 
     815         zh  = pdep * r1_Z0                                  ! depth 
     816         zt  = pts (jp_tem) * r1_T0                           ! temperature 
     817         zs  = SQRT( ABS( pts(jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity 
     818         ! 
     819         ! alpha 
     820         zn3 = ALP003 
     821         ! 
     822         zn2 = ALP012*zt + ALP102*zs+ALP002 
     823         ! 
     824         zn1 = ((ALP031*zt   & 
     825            &   + ALP121*zs+ALP021)*zt   & 
     826            &   + (ALP211*zs+ALP111)*zs+ALP011)*zt   & 
     827            &   + ((ALP301*zs+ALP201)*zs+ALP101)*zs+ALP001 
     828            ! 
     829         zn0 = ((((ALP050*zt   & 
     830            &   + ALP140*zs+ALP040)*zt   & 
     831            &   + (ALP230*zs+ALP130)*zs+ALP030)*zt   & 
     832            &   + ((ALP320*zs+ALP220)*zs+ALP120)*zs+ALP020)*zt   & 
     833            &   + (((ALP410*zs+ALP310)*zs+ALP210)*zs+ALP110)*zs+ALP010)*zt   & 
     834            &   + ((((ALP500*zs+ALP400)*zs+ALP300)*zs+ALP200)*zs+ALP100)*zs+ALP000 
     835            ! 
     836         zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 
     837         ! 
     838         pab(jp_tem) = zn * r1_rau0 
     839         ! 
     840         ! beta 
     841         zn3 = BET003 
     842         ! 
     843         zn2 = BET012*zt + BET102*zs+BET002 
     844         ! 
     845         zn1 = ((BET031*zt   & 
     846            &   + BET121*zs+BET021)*zt   & 
     847            &   + (BET211*zs+BET111)*zs+BET011)*zt   & 
     848            &   + ((BET301*zs+BET201)*zs+BET101)*zs+BET001 
     849            ! 
     850         zn0 = ((((BET050*zt   & 
     851            &   + BET140*zs+BET040)*zt   & 
     852            &   + (BET230*zs+BET130)*zs+BET030)*zt   & 
     853            &   + ((BET320*zs+BET220)*zs+BET120)*zs+BET020)*zt   & 
     854            &   + (((BET410*zs+BET310)*zs+BET210)*zs+BET110)*zs+BET010)*zt   & 
     855            &   + ((((BET500*zs+BET400)*zs+BET300)*zs+BET200)*zs+BET100)*zs+BET000 
     856            ! 
     857         zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 
     858         ! 
     859         pab(jp_sal) = zn / zs * r1_rau0 
     860         ! 
     861         ! 
     862         ! 
     863      CASE( 1 )                  !==  simplified EOS  ==! 
     864         ! 
     865         zt    = pts(jp_tem) - 10._wp   ! pot. temperature anomaly (t-T0) 
     866         zs    = pts(jp_sal) - 35._wp   ! abs. salinity anomaly (s-S0) 
     867         zh    = pdep                    ! depth at the partial step level 
     868         ! 
     869         zn  = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs 
     870         pab(jp_tem) = zn * r1_rau0   ! alpha 
     871         ! 
     872         zn  = rn_b0 * ( 1._wp - rn_lambda2*zs - rn_mu2*zh ) - rn_nu*zt 
     873         pab(jp_sal) = zn * r1_rau0   ! beta 
     874         ! 
     875      CASE DEFAULT 
     876         IF(lwp) WRITE(numout,cform_err) 
     877         IF(lwp) WRITE(numout,*) '          bad flag value for nn_eos = ', nn_eos 
     878         nstop = nstop + 1 
     879         ! 
     880      END SELECT 
     881      ! 
     882      IF( nn_timing == 1 )   CALL timing_stop('rab_2d') 
     883      ! 
     884   END SUBROUTINE rab_0d 
     885 
     886 
     887   SUBROUTINE bn2( pts, pab, pn2 ) 
     888      !!---------------------------------------------------------------------- 
     889      !!                  ***  ROUTINE bn2  *** 
     890      !! 
     891      !! ** Purpose :   Compute the local Brunt-Vaisala frequency at the  
     892      !!                time-step of the input arguments 
     893      !! 
     894      !! ** Method  :   pn2 = grav * (alpha dk[T] + beta dk[S] ) / e3w 
     895      !!      where alpha and beta are given in pab, and computed on T-points. 
     896      !!      N.B. N^2 is set one for all to zero at jk=1 in istate module. 
     897      !! 
     898      !! ** Action  :   pn2 : square of the brunt-vaisala frequency at w-point  
     899      !! 
     900      !!---------------------------------------------------------------------- 
     901      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::  pts   ! pot. temperature and salinity   [Celcius,psu] 
     902      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::  pab   ! thermal/haline expansion coef.  [Celcius-1,psu-1] 
     903      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(  out) ::  pn2   ! Brunt-Vaisala frequency squared [1/s^2] 
     904      ! 
     905      INTEGER  ::   ji, jj, jk      ! dummy loop indices 
     906      REAL(wp) ::   zaw, zbw, zrw   ! local scalars 
     907      !!---------------------------------------------------------------------- 
     908      ! 
     909      IF( nn_timing == 1 ) CALL timing_start('bn2') 
     910      ! 
     911      DO jk = 2, jpkm1           ! interior points only (2=< jk =< jpkm1 ) 
     912         DO jj = 1, jpj          ! surface and bottom value set to zero one for all in istate.F90 
     913            DO ji = 1, jpi 
     914               zrw =   ( fsdepw(ji,jj,jk  ) - fsdept(ji,jj,jk) )   & 
     915                  &  / ( fsdept(ji,jj,jk-1) - fsdept(ji,jj,jk) )  
     916                  ! 
     917               zaw = pab(ji,jj,jk,jp_tem) * (1. - zrw) + pab(ji,jj,jk-1,jp_tem) * zrw  
     918               zbw = pab(ji,jj,jk,jp_sal) * (1. - zrw) + pab(ji,jj,jk-1,jp_sal) * zrw 
     919               ! 
     920               pn2(ji,jj,jk) = grav * (  zaw * ( pts(ji,jj,jk-1,jp_tem) - pts(ji,jj,jk,jp_tem) )     & 
     921                  &                    - zbw * ( pts(ji,jj,jk-1,jp_sal) - pts(ji,jj,jk,jp_sal) )  )  & 
     922                  &            / fse3w(ji,jj,jk) * tmask(ji,jj,jk) 
     923            END DO 
     924         END DO 
     925      END DO 
     926      ! 
     927      IF(ln_ctl)   CALL prt_ctl( tab3d_1=pn2, clinfo1=' bn2  : ', ovlap=1, kdim=jpk ) 
     928      ! 
     929      IF( nn_timing == 1 )   CALL timing_stop('bn2') 
     930      ! 
     931   END SUBROUTINE bn2 
     932 
     933 
     934   FUNCTION eos_pt_from_ct( ctmp, psal ) RESULT( ptmp ) 
     935      !!---------------------------------------------------------------------- 
     936      !!                 ***  ROUTINE eos_pt_from_ct  *** 
     937      !! 
     938      !! ** Purpose :   Compute pot.temp. from cons. temp. [Celcius] 
     939      !! 
     940      !! ** Method  :   rational approximation (5/3th order) of TEOS-10 algorithm 
     941      !!       checkvalue: pt=20.02391895 Celsius for sa=35.7g/kg, ct=20degC 
     942      !! 
     943      !! Reference  :   TEOS-10, UNESCO 
     944      !!                Rational approximation to TEOS10 algorithm (rms error on WOA13 values: 4.0e-5 degC) 
     945      !!---------------------------------------------------------------------- 
     946      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   ctmp   ! Cons. Temp [Celcius] 
     947      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   psal   ! salinity   [psu] 
     948      ! Leave result array automatic rather than making explicitly allocated 
     949      REAL(wp), DIMENSION(jpi,jpj) ::   ptmp   ! potential temperature [Celcius] 
     950      ! 
     951      INTEGER  ::   ji, jj               ! dummy loop indices 
     952      REAL(wp) ::   zt , zs , ztm        ! local scalars 
     953      REAL(wp) ::   zn , zd              ! local scalars 
     954      REAL(wp) ::   zdeltaS , z1_S0 , z1_T0 
     955      !!---------------------------------------------------------------------- 
     956      ! 
     957      IF ( nn_timing == 1 )   CALL timing_start('eos_pt_from_ct') 
     958      ! 
     959      zdeltaS = 5._wp 
     960      z1_S0   = 0.875_wp/35.16504_wp 
     961      z1_T0   = 1._wp/40._wp 
     962      ! 
     963      DO jj = 1, jpj 
     964         DO ji = 1, jpi 
     965            ! 
     966            zt  = ctmp   (ji,jj) * z1_T0 
     967            zs  = SQRT( ABS( psal(ji,jj) + zdeltaS ) * r1_S0 ) 
     968            ztm = tmask(ji,jj,1) 
     969            ! 
     970            zn = ((((-2.1385727895e-01_wp*zt   & 
     971               &   - 2.7674419971e-01_wp*zs+1.0728094330_wp)*zt   & 
     972               &   + (2.6366564313_wp*zs+3.3546960647_wp)*zs-7.8012209473_wp)*zt   & 
     973               &   + ((1.8835586562_wp*zs+7.3949191679_wp)*zs-3.3937395875_wp)*zs-5.6414948432_wp)*zt   & 
     974               &   + (((3.5737370589_wp*zs-1.5512427389e+01_wp)*zs+2.4625741105e+01_wp)*zs   & 
     975               &      +1.9912291000e+01_wp)*zs-3.2191146312e+01_wp)*zt   & 
     976               &   + ((((5.7153204649e-01_wp*zs-3.0943149543_wp)*zs+9.3052495181_wp)*zs   & 
     977               &      -9.4528934807_wp)*zs+3.1066408996_wp)*zs-4.3504021262e-01_wp 
     978               ! 
     979            zd = (2.0035003456_wp*zt   & 
     980               &   -3.4570358592e-01_wp*zs+5.6471810638_wp)*zt   & 
     981               &   + (1.5393993508_wp*zs-6.9394762624_wp)*zs+1.2750522650e+01_wp 
     982               ! 
     983            ptmp(ji,jj) = ( zt / z1_T0 + zn / zd ) * ztm 
     984               ! 
     985         END DO 
     986      END DO 
     987      ! 
     988      IF( nn_timing == 1 )   CALL timing_stop('eos_pt_from_ct') 
     989      ! 
     990   END FUNCTION eos_pt_from_ct 
     991 
     992 
     993   FUNCTION eos_fzp_2d( psal, pdep ) RESULT( ptf ) 
     994      !!---------------------------------------------------------------------- 
     995      !!                 ***  ROUTINE eos_fzp  *** 
     996      !! 
     997      !! ** Purpose :   Compute the freezing point temperature [Celcius] 
     998      !! 
     999      !! ** Method  :   UNESCO freezing point (ptf) in Celcius is given by 
     1000      !!       ptf(t,z) = (-.0575+1.710523e-3*sqrt(abs(s))-2.154996e-4*s)*s - 7.53e-4*z 
     1001      !!       checkvalue: tf=-2.588567 Celsius for s=40psu, z=500m 
     1002      !! 
     1003      !! Reference  :   UNESCO tech. papers in the marine science no. 28. 1978 
     1004      !!---------------------------------------------------------------------- 
     1005      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   )           ::   psal   ! salinity   [psu] 
     1006      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ), OPTIONAL ::   pdep   ! depth      [m] 
     1007      REAL(wp), DIMENSION(jpi,jpj)                          ::   ptf   ! freezing temperature [Celcius] 
     1008      ! 
     1009      INTEGER  ::   ji, jj   ! dummy loop indices 
     1010      REAL(wp) ::   zt, zs   ! local scalars 
     1011      !!---------------------------------------------------------------------- 
     1012      ! 
     1013      SELECT CASE ( nn_eos ) 
     1014      ! 
     1015      CASE ( -1, 1 )                !==  CT,SA (TEOS-10 formulation) ==! 
     1016         ! 
     1017         DO jj = 1, jpj 
     1018            DO ji = 1, jpi 
     1019               zs= SQRT( ABS( psal(ji,jj) ) * r1_S0 )           ! square root salinity 
     1020               ptf(ji,jj) = ((((1.46873e-03_wp*zs-9.64972e-03_wp)*zs+2.28348e-02_wp)*zs & 
     1021                  &          - 3.12775e-02_wp)*zs+2.07679e-02_wp)*zs-5.87701e-02_wp 
     1022            END DO 
     1023         END DO 
     1024         ptf(:,:) = ptf(:,:) * psal(:,:) 
     1025         ! 
     1026         IF( PRESENT( pdep ) )   ptf(:,:) = ptf(:,:) - 7.53e-4 * pdep(:,:) 
     1027         ! 
     1028      CASE ( 0 )                     !==  PT,SP (UNESCO formulation)  ==! 
     1029         ! 
     1030         ptf(:,:) = ( - 0.0575_wp + 1.710523e-3_wp * SQRT( psal(:,:) )   & 
     1031            &                     - 2.154996e-4_wp *       psal(:,:)   ) * psal(:,:) 
     1032            ! 
     1033         IF( PRESENT( pdep ) )   ptf(:,:) = ptf(:,:) - 7.53e-4 * pdep(:,:) 
     1034         ! 
     1035      CASE DEFAULT 
     1036         IF(lwp) WRITE(numout,cform_err) 
     1037         IF(lwp) WRITE(numout,*) '          bad flag value for nn_eos = ', nn_eos 
     1038         nstop = nstop + 1 
     1039         ! 
     1040      END SELECT 
     1041      ! 
     1042   END FUNCTION eos_fzp_2d 
     1043 
     1044  FUNCTION eos_fzp_0d( psal, pdep ) RESULT( ptf ) 
     1045      !!---------------------------------------------------------------------- 
     1046      !!                 ***  ROUTINE eos_fzp  *** 
     1047      !! 
     1048      !! ** Purpose :   Compute the freezing point temperature [Celcius] 
     1049      !! 
     1050      !! ** Method  :   UNESCO freezing point (ptf) in Celcius is given by 
     1051      !!       ptf(t,z) = (-.0575+1.710523e-3*sqrt(abs(s))-2.154996e-4*s)*s - 7.53e-4*z 
     1052      !!       checkvalue: tf=-2.588567 Celsius for s=40psu, z=500m 
     1053      !! 
     1054      !! Reference  :   UNESCO tech. papers in the marine science no. 28. 1978 
     1055      !!---------------------------------------------------------------------- 
     1056      REAL(wp), INTENT(in)           ::   psal   ! salinity   [psu] 
     1057      REAL(wp), INTENT(in), OPTIONAL ::   pdep   ! depth      [m] 
     1058      REAL(wp)                       ::   ptf   ! freezing temperature [Celcius] 
     1059      ! 
     1060      REAL(wp) :: zs   ! local scalars 
     1061      !!---------------------------------------------------------------------- 
     1062      ! 
     1063      SELECT CASE ( nn_eos ) 
     1064      ! 
     1065      CASE ( -1, 1 )                !==  CT,SA (TEOS-10 formulation) ==! 
     1066         ! 
     1067         zs  = SQRT( ABS( psal ) * r1_S0 )           ! square root salinity 
     1068         ptf = ((((1.46873e-03_wp*zs-9.64972e-03_wp)*zs+2.28348e-02_wp)*zs & 
     1069                  &          - 3.12775e-02_wp)*zs+2.07679e-02_wp)*zs-5.87701e-02_wp 
     1070         ptf = ptf * psal 
     1071         ! 
     1072         IF( PRESENT( pdep ) )   ptf = ptf - 7.53e-4 * pdep 
     1073         ! 
     1074      CASE ( 0 )                     !==  PT,SP (UNESCO formulation)  ==! 
     1075         ! 
     1076         ptf = ( - 0.0575_wp + 1.710523e-3_wp * SQRT( psal )   & 
     1077            &                - 2.154996e-4_wp *       psal   ) * psal 
     1078            ! 
     1079         IF( PRESENT( pdep ) )   ptf = ptf - 7.53e-4 * pdep 
     1080         ! 
     1081      CASE DEFAULT 
     1082         IF(lwp) WRITE(numout,cform_err) 
     1083         IF(lwp) WRITE(numout,*) '          bad flag value for nn_eos = ', nn_eos 
     1084         nstop = nstop + 1 
     1085         ! 
     1086      END SELECT 
     1087      ! 
     1088   END FUNCTION eos_fzp_0d 
     1089 
     1090 
     1091   SUBROUTINE eos_pen( pts, pab_pe, ppen ) 
     1092      !!---------------------------------------------------------------------- 
     1093      !!                 ***  ROUTINE eos_pen  *** 
     1094      !! 
     1095      !! ** Purpose :   Calculates nonlinear anomalies of alpha_PE, beta_PE and PE at T-points 
     1096      !! 
     1097      !! ** Method  :   PE is defined analytically as the vertical  
     1098      !!                   primitive of EOS times -g integrated between 0 and z>0. 
     1099      !!                pen is the nonlinear bsq-PE anomaly: pen = ( PE - rau0 gz ) / rau0 gz - rd 
     1100      !!                                                      = 1/z * /int_0^z rd dz - rd  
     1101      !!                                where rd is the density anomaly (see eos_rhd function) 
     1102      !!                ab_pe are partial derivatives of PE anomaly with respect to T and S: 
     1103      !!                    ab_pe(1) = - 1/(rau0 gz) * dPE/dT + drd/dT = - d(pen)/dT 
     1104      !!                    ab_pe(2) =   1/(rau0 gz) * dPE/dS + drd/dS =   d(pen)/dS 
     1105      !! 
     1106      !! ** Action  : - pen         : PE anomaly given at T-points 
     1107      !!            : - pab_pe  : given at T-points 
     1108      !!                    pab_pe(:,:,:,jp_tem) is alpha_pe 
     1109      !!                    pab_pe(:,:,:,jp_sal) is beta_pe 
     1110      !!---------------------------------------------------------------------- 
     1111      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::   pts     ! pot. temperature & salinity 
     1112      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(  out) ::   pab_pe  ! alpha_pe and beta_pe 
     1113      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(  out) ::   ppen     ! potential energy anomaly 
     1114      ! 
     1115      INTEGER  ::   ji, jj, jk                ! dummy loop indices 
     1116      REAL(wp) ::   zt , zh , zs , ztm        ! local scalars 
     1117      REAL(wp) ::   zn , zn0, zn1, zn2        !   -      - 
     1118      !!---------------------------------------------------------------------- 
     1119      ! 
     1120      IF( nn_timing == 1 )   CALL timing_start('eos_pen') 
     1121      ! 
     1122      SELECT CASE ( nn_eos ) 
     1123      ! 
     1124      CASE( -1, 0 )                !==  polynomial TEOS-10 / EOS-80 ==! 
     1125         ! 
     1126         DO jk = 1, jpkm1 
     1127            DO jj = 1, jpj 
     1128               DO ji = 1, jpi 
     1129                  ! 
     1130                  zh  = fsdept(ji,jj,jk) * r1_Z0                                ! depth 
     1131                  zt  = pts (ji,jj,jk,jp_tem) * r1_T0                           ! temperature 
     1132                  zs  = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity 
     1133                  ztm = tmask(ji,jj,jk)                                         ! tmask 
     1134                  ! 
     1135                  ! potential energy non-linear anomaly 
     1136                  zn2 = (PEN012)*zt   & 
     1137                     &   + PEN102*zs+PEN002 
     1138                     ! 
     1139                  zn1 = ((PEN021)*zt   & 
     1140                     &   + PEN111*zs+PEN011)*zt   & 
     1141                     &   + (PEN201*zs+PEN101)*zs+PEN001 
     1142                     ! 
     1143                  zn0 = ((((PEN040)*zt   & 
     1144                     &   + PEN130*zs+PEN030)*zt   & 
     1145                     &   + (PEN220*zs+PEN120)*zs+PEN020)*zt   & 
     1146                     &   + ((PEN310*zs+PEN210)*zs+PEN110)*zs+PEN010)*zt   & 
     1147                     &   + (((PEN400*zs+PEN300)*zs+PEN200)*zs+PEN100)*zs+PEN000 
     1148                     ! 
     1149                  zn  = ( zn2 * zh + zn1 ) * zh + zn0 
     1150                  ! 
     1151                  ppen(ji,jj,jk)  = zn * zh * r1_rau0 * ztm 
     1152                  ! 
     1153                  ! alphaPE non-linear anomaly 
     1154                  zn2 = APE002 
     1155                  ! 
     1156                  zn1 = (APE011)*zt   & 
     1157                     &   + APE101*zs+APE001 
     1158                     ! 
     1159                  zn0 = (((APE030)*zt   & 
     1160                     &   + APE120*zs+APE020)*zt   & 
     1161                     &   + (APE210*zs+APE110)*zs+APE010)*zt   & 
     1162                     &   + ((APE300*zs+APE200)*zs+APE100)*zs+APE000 
     1163                     ! 
     1164                  zn  = ( zn2 * zh + zn1 ) * zh + zn0 
     1165                  !                               
     1166                  pab_pe(ji,jj,jk,jp_tem) = zn * zh * r1_rau0 * ztm 
     1167                  ! 
     1168                  ! betaPE non-linear anomaly 
     1169                  zn2 = BPE002 
     1170                  ! 
     1171                  zn1 = (BPE011)*zt   & 
     1172                     &   + BPE101*zs+BPE001 
     1173                     ! 
     1174                  zn0 = (((BPE030)*zt   & 
     1175                     &   + BPE120*zs+BPE020)*zt   & 
     1176                     &   + (BPE210*zs+BPE110)*zs+BPE010)*zt   & 
     1177                     &   + ((BPE300*zs+BPE200)*zs+BPE100)*zs+BPE000 
     1178                     ! 
     1179                  zn  = ( zn2 * zh + zn1 ) * zh + zn0 
     1180                  !                               
     1181                  pab_pe(ji,jj,jk,jp_sal) = zn / zs * zh * r1_rau0 * ztm 
     1182                  ! 
     1183               END DO 
     1184            END DO 
     1185         END DO 
     1186         ! 
     1187      CASE( 1 )                !==  Vallis (2006) simplified EOS  ==! 
     1188         ! 
     1189         DO jk = 1, jpkm1 
     1190            DO jj = 1, jpj 
     1191               DO ji = 1, jpi 
     1192                  zt  = pts(ji,jj,jk,jp_tem) - 10._wp  ! temperature anomaly (t-T0) 
     1193                  zs = pts (ji,jj,jk,jp_sal) - 35._wp  ! abs. salinity anomaly (s-S0) 
     1194                  zh  = fsdept(ji,jj,jk)               ! depth in meters  at t-point 
     1195                  ztm = tmask(ji,jj,jk)                ! tmask 
     1196                  zn  = 0.5_wp * zh * r1_rau0 * ztm 
     1197                  !                                    ! Potential Energy 
     1198                  ppen(ji,jj,jk) = ( rn_a0 * rn_mu1 * zt + rn_b0 * rn_mu2 * zs ) * zn 
     1199                  !                                    ! alphaPE 
     1200                  pab_pe(ji,jj,jk,jp_tem) = - rn_a0 * rn_mu1 * zn 
     1201                  pab_pe(ji,jj,jk,jp_sal) =   rn_b0 * rn_mu2 * zn 
     1202                  ! 
     1203               END DO 
     1204            END DO 
     1205         END DO 
     1206         ! 
     1207      CASE DEFAULT 
     1208         IF(lwp) WRITE(numout,cform_err) 
     1209         IF(lwp) WRITE(numout,*) '          bad flag value for nn_eos = ', nn_eos 
     1210         nstop = nstop + 1 
     1211         ! 
     1212      END SELECT 
     1213      ! 
     1214      IF( nn_timing == 1 )   CALL timing_stop('eos_pen') 
     1215      ! 
     1216   END SUBROUTINE eos_pen 
     1217 
     1218 
     1219   SUBROUTINE eos_init 
    6801220      !!---------------------------------------------------------------------- 
    6811221      !!                 ***  ROUTINE eos_init  *** 
    6821222      !! 
    683       !! ** Purpose :   Compute the sea surface freezing temperature [Celcius] 
    684       !! 
    685       !! ** Method  :   UNESCO freezing point at the surface (pressure = 0???) 
    686       !!       freezing point [Celcius]=(-.0575+1.710523e-3*sqrt(abs(s))-2.154996e-4*s)*s-7.53e-4*p 
    687       !!       checkvalue: tf= -2.588567 Celsius for s=40.0psu, p=500. decibars 
    688       !! 
    689       !! Reference  :   UNESCO tech. papers in the marine science no. 28. 1978 
    690       !!---------------------------------------------------------------------- 
    691       REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   psal   ! salinity             [psu] 
    692       REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ), OPTIONAL ::   pdep   ! depth      [decibars] 
    693       ! Leave result array automatic rather than making explicitly allocated 
    694       REAL(wp), DIMENSION(jpi,jpj)                ::   ptf    ! freezing temperature [Celcius] 
    695       !!---------------------------------------------------------------------- 
    696       ! 
    697       ptf(:,:) = ( - 0.0575_wp + 1.710523e-3_wp * SQRT( psal(:,:) )   & 
    698          &                     - 2.154996e-4_wp *       psal(:,:)   ) * psal(:,:) 
    699       IF ( PRESENT( pdep ) ) THEN    
    700          ptf(:,:) = ptf(:,:) - 7.53e-4_wp * pdep(:,:) 
    701       ENDIF 
    702       ! 
    703    END FUNCTION tfreez 
    704  
    705  
    706    SUBROUTINE eos_init 
    707       !!---------------------------------------------------------------------- 
    708       !!                 ***  ROUTINE eos_init  *** 
    709       !! 
    7101223      !! ** Purpose :   initializations for the equation of state 
    7111224      !! 
    7121225      !! ** Method  :   Read the namelist nameos and control the parameters 
    7131226      !!---------------------------------------------------------------------- 
    714       NAMELIST/nameos/ nn_eos, rn_alpha, rn_beta 
    715       !!---------------------------------------------------------------------- 
    716       INTEGER  ::   ios 
     1227      INTEGER  ::   ios   ! local integer 
     1228      !! 
     1229      NAMELIST/nameos/ nn_eos, ln_useCT, rn_a0, rn_b0, rn_lambda1, rn_mu1,   & 
     1230         &                                             rn_lambda2, rn_mu2, rn_nu 
     1231      !!---------------------------------------------------------------------- 
    7171232      ! 
    7181233      REWIND( numnam_ref )              ! Namelist nameos in reference namelist : equation of state 
    7191234      READ  ( numnam_ref, nameos, IOSTAT = ios, ERR = 901 ) 
    7201235901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'nameos in reference namelist', lwp ) 
    721  
     1236      ! 
    7221237      REWIND( numnam_cfg )              ! Namelist nameos in configuration namelist : equation of state 
    7231238      READ  ( numnam_cfg, nameos, IOSTAT = ios, ERR = 902 ) 
    7241239902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'nameos in configuration namelist', lwp ) 
    7251240      IF(lwm) WRITE( numond, nameos ) 
     1241      ! 
     1242      rau0        = 1026._wp                 !: volumic mass of reference     [kg/m3] 
     1243      rcp         = 3991.86795711963_wp      !: heat capacity     [J/K] 
    7261244      ! 
    7271245      IF(lwp) THEN                ! Control print 
    … …  
    7311249         WRITE(numout,*) '          Namelist nameos : set eos parameters' 
    7321250         WRITE(numout,*) '             flag for eq. of state and N^2  nn_eos   = ', nn_eos 
    733          WRITE(numout,*) '             thermal exp. coef. (linear)    rn_alpha = ', rn_alpha 
    734          WRITE(numout,*) '             saline  exp. coef. (linear)    rn_beta  = ', rn_beta 
     1251         IF( ln_useCT )   THEN 
     1252            WRITE(numout,*) '             model uses Conservative Temperature' 
     1253            WRITE(numout,*) '             Important: model must be initialized with CT and SA fields' 
     1254         ELSE 
     1255            WRITE(numout,*) '             model does not use Conservative Temperature' 
     1256         ENDIF 
    7351257      ENDIF 
    7361258      ! 
    7371259      SELECT CASE( nn_eos )         ! check option 
    7381260      ! 
    739       CASE( 0 )                        !==  Jackett and McDougall (1994) formulation  ==! 
     1261      CASE( -1 )                       !==  polynomial TEOS-10  ==! 
    7401262         IF(lwp) WRITE(numout,*) 
    741          IF(lwp) WRITE(numout,*) '          use of Jackett & McDougall (1994) equation of state and' 
    742          IF(lwp) WRITE(numout,*) '                 McDougall (1987) Brunt-Vaisala frequency' 
    743          ! 
    744       CASE( 1 )                        !==  Linear formulation = F( temperature )  ==! 
     1263         IF(lwp) WRITE(numout,*) '          use of TEOS-10 equation of state (cons. temp. and abs. salinity)' 
     1264         ! 
     1265         rdeltaS = 32._wp 
     1266         r1_S0  = 0.875_wp/35.16504_wp 
     1267         r1_T0  = 1._wp/40._wp 
     1268         r1_Z0  = 1.e-4_wp 
     1269         ! 
     1270         EOS000 = 8.0189615746e+02_wp 
     1271         EOS100 = 8.6672408165e+02_wp 
     1272         EOS200 = -1.7864682637e+03_wp 
     1273         EOS300 = 2.0375295546e+03_wp 
     1274         EOS400 = -1.2849161071e+03_wp 
     1275         EOS500 = 4.3227585684e+02_wp 
     1276         EOS600 = -6.0579916612e+01_wp 
     1277         EOS010 = 2.6010145068e+01_wp 
     1278         EOS110 = -6.5281885265e+01_wp 
     1279         EOS210 = 8.1770425108e+01_wp 
     1280         EOS310 = -5.6888046321e+01_wp 
     1281         EOS410 = 1.7681814114e+01_wp 
     1282         EOS510 = -1.9193502195_wp 
     1283         EOS020 = -3.7074170417e+01_wp 
     1284         EOS120 = 6.1548258127e+01_wp 
     1285         EOS220 = -6.0362551501e+01_wp 
     1286         EOS320 = 2.9130021253e+01_wp 
     1287         EOS420 = -5.4723692739_wp 
     1288         EOS030 = 2.1661789529e+01_wp 
     1289         EOS130 = -3.3449108469e+01_wp 
     1290         EOS230 = 1.9717078466e+01_wp 
     1291         EOS330 = -3.1742946532_wp 
     1292         EOS040 = -8.3627885467_wp 
     1293         EOS140 = 1.1311538584e+01_wp 
     1294         EOS240 = -5.3563304045_wp 
     1295         EOS050 = 5.4048723791e-01_wp 
     1296         EOS150 = 4.8169980163e-01_wp 
     1297         EOS060 = -1.9083568888e-01_wp 
     1298         EOS001 = 1.9681925209e+01_wp 
     1299         EOS101 = -4.2549998214e+01_wp 
     1300         EOS201 = 5.0774768218e+01_wp 
     1301         EOS301 = -3.0938076334e+01_wp 
     1302         EOS401 = 6.6051753097_wp 
     1303         EOS011 = -1.3336301113e+01_wp 
     1304         EOS111 = -4.4870114575_wp 
     1305         EOS211 = 5.0042598061_wp 
     1306         EOS311 = -6.5399043664e-01_wp 
     1307         EOS021 = 6.7080479603_wp 
     1308         EOS121 = 3.5063081279_wp 
     1309         EOS221 = -1.8795372996_wp 
     1310         EOS031 = -2.4649669534_wp 
     1311         EOS131 = -5.5077101279e-01_wp 
     1312         EOS041 = 5.5927935970e-01_wp 
     1313         EOS002 = 2.0660924175_wp 
     1314         EOS102 = -4.9527603989_wp 
     1315         EOS202 = 2.5019633244_wp 
     1316         EOS012 = 2.0564311499_wp 
     1317         EOS112 = -2.1311365518e-01_wp 
     1318         EOS022 = -1.2419983026_wp 
     1319         EOS003 = -2.3342758797e-02_wp 
     1320         EOS103 = -1.8507636718e-02_wp 
     1321         EOS013 = 3.7969820455e-01_wp 
     1322         ! 
     1323         ALP000 = -6.5025362670e-01_wp 
     1324         ALP100 = 1.6320471316_wp 
     1325         ALP200 = -2.0442606277_wp 
     1326         ALP300 = 1.4222011580_wp 
     1327         ALP400 = -4.4204535284e-01_wp 
     1328         ALP500 = 4.7983755487e-02_wp 
     1329         ALP010 = 1.8537085209_wp 
     1330         ALP110 = -3.0774129064_wp 
     1331         ALP210 = 3.0181275751_wp 
     1332         ALP310 = -1.4565010626_wp 
     1333         ALP410 = 2.7361846370e-01_wp 
     1334         ALP020 = -1.6246342147_wp 
     1335         ALP120 = 2.5086831352_wp 
     1336         ALP220 = -1.4787808849_wp 
     1337         ALP320 = 2.3807209899e-01_wp 
     1338         ALP030 = 8.3627885467e-01_wp 
     1339         ALP130 = -1.1311538584_wp 
     1340         ALP230 = 5.3563304045e-01_wp 
     1341         ALP040 = -6.7560904739e-02_wp 
     1342         ALP140 = -6.0212475204e-02_wp 
     1343         ALP050 = 2.8625353333e-02_wp 
     1344         ALP001 = 3.3340752782e-01_wp 
     1345         ALP101 = 1.1217528644e-01_wp 
     1346         ALP201 = -1.2510649515e-01_wp 
     1347         ALP301 = 1.6349760916e-02_wp 
     1348         ALP011 = -3.3540239802e-01_wp 
     1349         ALP111 = -1.7531540640e-01_wp 
     1350         ALP211 = 9.3976864981e-02_wp 
     1351         ALP021 = 1.8487252150e-01_wp 
     1352         ALP121 = 4.1307825959e-02_wp 
     1353         ALP031 = -5.5927935970e-02_wp 
     1354         ALP002 = -5.1410778748e-02_wp 
     1355         ALP102 = 5.3278413794e-03_wp 
     1356         ALP012 = 6.2099915132e-02_wp 
     1357         ALP003 = -9.4924551138e-03_wp 
     1358         ! 
     1359         BET000 = 1.0783203594e+01_wp 
     1360         BET100 = -4.4452095908e+01_wp 
     1361         BET200 = 7.6048755820e+01_wp 
     1362         BET300 = -6.3944280668e+01_wp 
     1363         BET400 = 2.6890441098e+01_wp 
     1364         BET500 = -4.5221697773_wp 
     1365         BET010 = -8.1219372432e-01_wp 
     1366         BET110 = 2.0346663041_wp 
     1367         BET210 = -2.1232895170_wp 
     1368         BET310 = 8.7994140485e-01_wp 
     1369         BET410 = -1.1939638360e-01_wp 
     1370         BET020 = 7.6574242289e-01_wp 
     1371         BET120 = -1.5019813020_wp 
     1372         BET220 = 1.0872489522_wp 
     1373         BET320 = -2.7233429080e-01_wp 
     1374         BET030 = -4.1615152308e-01_wp 
     1375         BET130 = 4.9061350869e-01_wp 
     1376         BET230 = -1.1847737788e-01_wp 
     1377         BET040 = 1.4073062708e-01_wp 
     1378         BET140 = -1.3327978879e-01_wp 
     1379         BET050 = 5.9929880134e-03_wp 
     1380         BET001 = -5.2937873009e-01_wp 
     1381         BET101 = 1.2634116779_wp 
     1382         BET201 = -1.1547328025_wp 
     1383         BET301 = 3.2870876279e-01_wp 
     1384         BET011 = -5.5824407214e-02_wp 
     1385         BET111 = 1.2451933313e-01_wp 
     1386         BET211 = -2.4409539932e-02_wp 
     1387         BET021 = 4.3623149752e-02_wp 
     1388         BET121 = -4.6767901790e-02_wp 
     1389         BET031 = -6.8523260060e-03_wp 
     1390         BET002 = -6.1618945251e-02_wp 
     1391         BET102 = 6.2255521644e-02_wp 
     1392         BET012 = -2.6514181169e-03_wp 
     1393         BET003 = -2.3025968587e-04_wp 
     1394         ! 
     1395         PEN000 = -9.8409626043_wp 
     1396         PEN100 = 2.1274999107e+01_wp 
     1397         PEN200 = -2.5387384109e+01_wp 
     1398         PEN300 = 1.5469038167e+01_wp 
     1399         PEN400 = -3.3025876549_wp 
     1400         PEN010 = 6.6681505563_wp 
     1401         PEN110 = 2.2435057288_wp 
     1402         PEN210 = -2.5021299030_wp 
     1403         PEN310 = 3.2699521832e-01_wp 
     1404         PEN020 = -3.3540239802_wp 
     1405         PEN120 = -1.7531540640_wp 
     1406         PEN220 = 9.3976864981e-01_wp 
     1407         PEN030 = 1.2324834767_wp 
     1408         PEN130 = 2.7538550639e-01_wp 
     1409         PEN040 = -2.7963967985e-01_wp 
     1410         PEN001 = -1.3773949450_wp 
     1411         PEN101 = 3.3018402659_wp 
     1412         PEN201 = -1.6679755496_wp 
     1413         PEN011 = -1.3709540999_wp 
     1414         PEN111 = 1.4207577012e-01_wp 
     1415         PEN021 = 8.2799886843e-01_wp 
     1416         PEN002 = 1.7507069098e-02_wp 
     1417         PEN102 = 1.3880727538e-02_wp 
     1418         PEN012 = -2.8477365341e-01_wp 
     1419         ! 
     1420         APE000 = -1.6670376391e-01_wp 
     1421         APE100 = -5.6087643219e-02_wp 
     1422         APE200 = 6.2553247576e-02_wp 
     1423         APE300 = -8.1748804580e-03_wp 
     1424         APE010 = 1.6770119901e-01_wp 
     1425         APE110 = 8.7657703198e-02_wp 
     1426         APE210 = -4.6988432490e-02_wp 
     1427         APE020 = -9.2436260751e-02_wp 
     1428         APE120 = -2.0653912979e-02_wp 
     1429         APE030 = 2.7963967985e-02_wp 
     1430         APE001 = 3.4273852498e-02_wp 
     1431         APE101 = -3.5518942529e-03_wp 
     1432         APE011 = -4.1399943421e-02_wp 
     1433         APE002 = 7.1193413354e-03_wp 
     1434         ! 
     1435         BPE000 = 2.6468936504e-01_wp 
     1436         BPE100 = -6.3170583896e-01_wp 
     1437         BPE200 = 5.7736640125e-01_wp 
     1438         BPE300 = -1.6435438140e-01_wp 
     1439         BPE010 = 2.7912203607e-02_wp 
     1440         BPE110 = -6.2259666565e-02_wp 
     1441         BPE210 = 1.2204769966e-02_wp 
     1442         BPE020 = -2.1811574876e-02_wp 
     1443         BPE120 = 2.3383950895e-02_wp 
     1444         BPE030 = 3.4261630030e-03_wp 
     1445         BPE001 = 4.1079296834e-02_wp 
     1446         BPE101 = -4.1503681096e-02_wp 
     1447         BPE011 = 1.7676120780e-03_wp 
     1448         BPE002 = 1.7269476440e-04_wp 
     1449         ! 
     1450      CASE( 0 )                        !==  polynomial EOS-80 formulation  ==! 
     1451         ! 
    7451452         IF(lwp) WRITE(numout,*) 
    746          IF(lwp) WRITE(numout,*) '          use of linear eos rho(T) = rau0 * ( 1.0285 - rn_alpha * T )' 
    747          IF( lk_zdfddm ) CALL ctl_stop( '          double diffusive mixing parameterization requires',   & 
    748               &                         ' that T and S are used as state variables' ) 
    749          ! 
    750       CASE( 2 )                        !==  Linear formulation = F( temperature , salinity )  ==! 
    751          ralpbet = rn_alpha / rn_beta 
    752          IF(lwp) WRITE(numout,*) 
    753          IF(lwp) WRITE(numout,*) '          use of linear eos rho(T,S) = rau0 * ( rn_beta * S - rn_alpha * T )' 
     1453         IF(lwp) WRITE(numout,*) '          use of EOS-80 equation of state (pot. temp. and pract. salinity)' 
     1454         ! 
     1455         rdeltaS = 20._wp 
     1456         r1_S0  = 1._wp/40._wp 
     1457         r1_T0  = 1._wp/40._wp 
     1458         r1_Z0  = 1.e-4_wp 
     1459         ! 
     1460         EOS000 = 9.5356891948e+02_wp 
     1461         EOS100 = 1.7136499189e+02_wp 
     1462         EOS200 = -3.7501039454e+02_wp 
     1463         EOS300 = 5.1856810420e+02_wp 
     1464         EOS400 = -3.7264470465e+02_wp 
     1465         EOS500 = 1.4302533998e+02_wp 
     1466         EOS600 = -2.2856621162e+01_wp 
     1467         EOS010 = 1.0087518651e+01_wp 
     1468         EOS110 = -1.3647741861e+01_wp 
     1469         EOS210 = 8.8478359933_wp 
     1470         EOS310 = -7.2329388377_wp 
     1471         EOS410 = 1.4774410611_wp 
     1472         EOS510 = 2.0036720553e-01_wp 
     1473         EOS020 = -2.5579830599e+01_wp 
     1474         EOS120 = 2.4043512327e+01_wp 
     1475         EOS220 = -1.6807503990e+01_wp 
     1476         EOS320 = 8.3811577084_wp 
     1477         EOS420 = -1.9771060192_wp 
     1478         EOS030 = 1.6846451198e+01_wp 
     1479         EOS130 = -2.1482926901e+01_wp 
     1480         EOS230 = 1.0108954054e+01_wp 
     1481         EOS330 = -6.2675951440e-01_wp 
     1482         EOS040 = -8.0812310102_wp 
     1483         EOS140 = 1.0102374985e+01_wp 
     1484         EOS240 = -4.8340368631_wp 
     1485         EOS050 = 1.2079167803_wp 
     1486         EOS150 = 1.1515380987e-01_wp 
     1487         EOS060 = -2.4520288837e-01_wp 
     1488         EOS001 = 1.0748601068e+01_wp 
     1489         EOS101 = -1.7817043500e+01_wp 
     1490         EOS201 = 2.2181366768e+01_wp 
     1491         EOS301 = -1.6750916338e+01_wp 
     1492         EOS401 = 4.1202230403_wp 
     1493         EOS011 = -1.5852644587e+01_wp 
     1494         EOS111 = -7.6639383522e-01_wp 
     1495         EOS211 = 4.1144627302_wp 
     1496         EOS311 = -6.6955877448e-01_wp 
     1497         EOS021 = 9.9994861860_wp 
     1498         EOS121 = -1.9467067787e-01_wp 
     1499         EOS221 = -1.2177554330_wp 
     1500         EOS031 = -3.4866102017_wp 
     1501         EOS131 = 2.2229155620e-01_wp 
     1502         EOS041 = 5.9503008642e-01_wp 
     1503         EOS002 = 1.0375676547_wp 
     1504         EOS102 = -3.4249470629_wp 
     1505         EOS202 = 2.0542026429_wp 
     1506         EOS012 = 2.1836324814_wp 
     1507         EOS112 = -3.4453674320e-01_wp 
     1508         EOS022 = -1.2548163097_wp 
     1509         EOS003 = 1.8729078427e-02_wp 
     1510         EOS103 = -5.7238495240e-02_wp 
     1511         EOS013 = 3.8306136687e-01_wp 
     1512         ! 
     1513         ALP000 = -2.5218796628e-01_wp 
     1514         ALP100 = 3.4119354654e-01_wp 
     1515         ALP200 = -2.2119589983e-01_wp 
     1516         ALP300 = 1.8082347094e-01_wp 
     1517         ALP400 = -3.6936026529e-02_wp 
     1518         ALP500 = -5.0091801383e-03_wp 
     1519         ALP010 = 1.2789915300_wp 
     1520         ALP110 = -1.2021756164_wp 
     1521         ALP210 = 8.4037519952e-01_wp 
     1522         ALP310 = -4.1905788542e-01_wp 
     1523         ALP410 = 9.8855300959e-02_wp 
     1524         ALP020 = -1.2634838399_wp 
     1525         ALP120 = 1.6112195176_wp 
     1526         ALP220 = -7.5817155402e-01_wp 
     1527         ALP320 = 4.7006963580e-02_wp 
     1528         ALP030 = 8.0812310102e-01_wp 
     1529         ALP130 = -1.0102374985_wp 
     1530         ALP230 = 4.8340368631e-01_wp 
     1531         ALP040 = -1.5098959754e-01_wp 
     1532         ALP140 = -1.4394226233e-02_wp 
     1533         ALP050 = 3.6780433255e-02_wp 
     1534         ALP001 = 3.9631611467e-01_wp 
     1535         ALP101 = 1.9159845880e-02_wp 
     1536         ALP201 = -1.0286156825e-01_wp 
     1537         ALP301 = 1.6738969362e-02_wp 
     1538         ALP011 = -4.9997430930e-01_wp 
     1539         ALP111 = 9.7335338937e-03_wp 
     1540         ALP211 = 6.0887771651e-02_wp 
     1541         ALP021 = 2.6149576513e-01_wp 
     1542         ALP121 = -1.6671866715e-02_wp 
     1543         ALP031 = -5.9503008642e-02_wp 
     1544         ALP002 = -5.4590812035e-02_wp 
     1545         ALP102 = 8.6134185799e-03_wp 
     1546         ALP012 = 6.2740815484e-02_wp 
     1547         ALP003 = -9.5765341718e-03_wp 
     1548         ! 
     1549         BET000 = 2.1420623987_wp 
     1550         BET100 = -9.3752598635_wp 
     1551         BET200 = 1.9446303907e+01_wp 
     1552         BET300 = -1.8632235232e+01_wp 
     1553         BET400 = 8.9390837485_wp 
     1554         BET500 = -1.7142465871_wp 
     1555         BET010 = -1.7059677327e-01_wp 
     1556         BET110 = 2.2119589983e-01_wp 
     1557         BET210 = -2.7123520642e-01_wp 
     1558         BET310 = 7.3872053057e-02_wp 
     1559         BET410 = 1.2522950346e-02_wp 
     1560         BET020 = 3.0054390409e-01_wp 
     1561         BET120 = -4.2018759976e-01_wp 
     1562         BET220 = 3.1429341406e-01_wp 
     1563         BET320 = -9.8855300959e-02_wp 
     1564         BET030 = -2.6853658626e-01_wp 
     1565         BET130 = 2.5272385134e-01_wp 
     1566         BET230 = -2.3503481790e-02_wp 
     1567         BET040 = 1.2627968731e-01_wp 
     1568         BET140 = -1.2085092158e-01_wp 
     1569         BET050 = 1.4394226233e-03_wp 
     1570         BET001 = -2.2271304375e-01_wp 
     1571         BET101 = 5.5453416919e-01_wp 
     1572         BET201 = -6.2815936268e-01_wp 
     1573         BET301 = 2.0601115202e-01_wp 
     1574         BET011 = -9.5799229402e-03_wp 
     1575         BET111 = 1.0286156825e-01_wp 
     1576         BET211 = -2.5108454043e-02_wp 
     1577         BET021 = -2.4333834734e-03_wp 
     1578         BET121 = -3.0443885826e-02_wp 
     1579         BET031 = 2.7786444526e-03_wp 
     1580         BET002 = -4.2811838287e-02_wp 
     1581         BET102 = 5.1355066072e-02_wp 
     1582         BET012 = -4.3067092900e-03_wp 
     1583         BET003 = -7.1548119050e-04_wp 
     1584         ! 
     1585         PEN000 = -5.3743005340_wp 
     1586         PEN100 = 8.9085217499_wp 
     1587         PEN200 = -1.1090683384e+01_wp 
     1588         PEN300 = 8.3754581690_wp 
     1589         PEN400 = -2.0601115202_wp 
     1590         PEN010 = 7.9263222935_wp 
     1591         PEN110 = 3.8319691761e-01_wp 
     1592         PEN210 = -2.0572313651_wp 
     1593         PEN310 = 3.3477938724e-01_wp 
     1594         PEN020 = -4.9997430930_wp 
     1595         PEN120 = 9.7335338937e-02_wp 
     1596         PEN220 = 6.0887771651e-01_wp 
     1597         PEN030 = 1.7433051009_wp 
     1598         PEN130 = -1.1114577810e-01_wp 
     1599         PEN040 = -2.9751504321e-01_wp 
     1600         PEN001 = -6.9171176978e-01_wp 
     1601         PEN101 = 2.2832980419_wp 
     1602         PEN201 = -1.3694684286_wp 
     1603         PEN011 = -1.4557549876_wp 
     1604         PEN111 = 2.2969116213e-01_wp 
     1605         PEN021 = 8.3654420645e-01_wp 
     1606         PEN002 = -1.4046808820e-02_wp 
     1607         PEN102 = 4.2928871430e-02_wp 
     1608         PEN012 = -2.8729602515e-01_wp 
     1609         ! 
     1610         APE000 = -1.9815805734e-01_wp 
     1611         APE100 = -9.5799229402e-03_wp 
     1612         APE200 = 5.1430784127e-02_wp 
     1613         APE300 = -8.3694846809e-03_wp 
     1614         APE010 = 2.4998715465e-01_wp 
     1615         APE110 = -4.8667669469e-03_wp 
     1616         APE210 = -3.0443885826e-02_wp 
     1617         APE020 = -1.3074788257e-01_wp 
     1618         APE120 = 8.3359333577e-03_wp 
     1619         APE030 = 2.9751504321e-02_wp 
     1620         APE001 = 3.6393874690e-02_wp 
     1621         APE101 = -5.7422790533e-03_wp 
     1622         APE011 = -4.1827210323e-02_wp 
     1623         APE002 = 7.1824006288e-03_wp 
     1624         ! 
     1625         BPE000 = 1.1135652187e-01_wp 
     1626         BPE100 = -2.7726708459e-01_wp 
     1627         BPE200 = 3.1407968134e-01_wp 
     1628         BPE300 = -1.0300557601e-01_wp 
     1629         BPE010 = 4.7899614701e-03_wp 
     1630         BPE110 = -5.1430784127e-02_wp 
     1631         BPE210 = 1.2554227021e-02_wp 
     1632         BPE020 = 1.2166917367e-03_wp 
     1633         BPE120 = 1.5221942913e-02_wp 
     1634         BPE030 = -1.3893222263e-03_wp 
     1635         BPE001 = 2.8541225524e-02_wp 
     1636         BPE101 = -3.4236710714e-02_wp 
     1637         BPE011 = 2.8711395266e-03_wp 
     1638         BPE002 = 5.3661089288e-04_wp 
     1639         ! 
     1640      CASE( 1 )                        !==  Simplified EOS     ==! 
     1641         IF(lwp) THEN 
     1642            WRITE(numout,*) 
     1643            WRITE(numout,*) '          use of simplified eos:    rhd(dT=T-10,dS=S-35,Z) = ' 
     1644            WRITE(numout,*) '             [-a0*(1+lambda1/2*dT+mu1*Z)*dT + b0*(1+lambda2/2*dT+mu2*Z)*dS - nu*dT*dS]/rau0' 
     1645            WRITE(numout,*) 
     1646            WRITE(numout,*) '             thermal exp. coef.    rn_a0      = ', rn_a0 
     1647            WRITE(numout,*) '             saline  cont. coef.   rn_b0      = ', rn_b0 
     1648            WRITE(numout,*) '             cabbeling coef.       rn_lambda1 = ', rn_lambda1 
     1649            WRITE(numout,*) '             cabbeling coef.       rn_lambda2 = ', rn_lambda2 
     1650            WRITE(numout,*) '             thermobar. coef.      rn_mu1     = ', rn_mu1 
     1651            WRITE(numout,*) '             thermobar. coef.      rn_mu2     = ', rn_mu2 
     1652            WRITE(numout,*) '             2nd cabbel. coef.     rn_nu      = ', rn_nu 
     1653            WRITE(numout,*) '               Caution: rn_beta0=0 incompatible with ddm parameterization ' 
     1654         ENDIF 
    7541655         ! 
    7551656      CASE DEFAULT                     !==  ERROR in nn_eos  ==! 
    … …  
    7591660      END SELECT 
    7601661      ! 
     1662      rau0_rcp    = rau0 * rcp  
     1663      r1_rau0     = 1._wp / rau0 
     1664      r1_rcp      = 1._wp / rcp 
     1665      r1_rau0_rcp = 1._wp / rau0_rcp  
     1666      ! 
     1667      IF(lwp) WRITE(numout,*) 
     1668      IF(lwp) WRITE(numout,*) '          volumic mass of reference           rau0  = ', rau0   , ' kg/m^3' 
     1669      IF(lwp) WRITE(numout,*) '          1. / rau0                        r1_rau0  = ', r1_rau0, ' m^3/kg' 
     1670      IF(lwp) WRITE(numout,*) '          ocean specific heat                 rcp   = ', rcp    , ' J/Kelvin' 
     1671      IF(lwp) WRITE(numout,*) '          rau0 * rcp                       rau0_rcp = ', rau0_rcp 
     1672      IF(lwp) WRITE(numout,*) '          1. / ( rau0 * rcp )           r1_rau0_rcp = ', r1_rau0_rcp 
     1673      ! 
    7611674   END SUBROUTINE eos_init 
    7621675 

  • branches/2014/dev_r4650_UKMO14.5_SST_BIAS_CORRECTION/NEMOGCM/NEMO/OPA_SRC/TRA/traadv.F90

    r4624 r5965  
    2626   USE cla             ! cross land advection      (cla_traadv     routine) 
    2727   USE ldftra_oce      ! lateral diffusion coefficient on tracers 
     28   ! 
    2829   USE in_out_manager  ! I/O manager 
    2930   USE iom             ! I/O module 
    … …  
    3233   USE wrk_nemo        ! Memory Allocation 
    3334   USE timing          ! Timing 
     35   USE sbc_oce 
     36   USE diaptr          ! Poleward heat transport  
    3437 
    3538 
    … …  
    4346   LOGICAL ::   ln_traadv_cen2     ! 2nd order centered scheme flag 
    4447   LOGICAL ::   ln_traadv_tvd      ! TVD scheme flag 
     48   LOGICAL ::   ln_traadv_tvd_zts  ! TVD scheme flag with vertical sub time-stepping 
    4549   LOGICAL ::   ln_traadv_muscl    ! MUSCL scheme flag 
    4650   LOGICAL ::   ln_traadv_muscl2   ! MUSCL2 scheme flag 
    … …  
    109113      ! 
    110114      IF( ln_mle    )   CALL tra_adv_mle( kt, nit000, zun, zvn, zwn, 'TRA' )    ! add the mle transport (if necessary) 
     115      ! 
    111116      CALL iom_put( "uocetr_eff", zun )                                         ! output effective transport       
    112117      CALL iom_put( "vocetr_eff", zvn ) 
    113118      CALL iom_put( "wocetr_eff", zwn ) 
    114  
     119      ! 
     120      IF( ln_diaptr )   CALL dia_ptr( zvn )                                     ! diagnose the effective MSF  
     121      ! 
     122    
    115123      SELECT CASE ( nadv )                            !==  compute advection trend and add it to general trend  ==! 
    116       CASE ( 1 )   ;    CALL tra_adv_cen2  ( kt, nit000, 'TRA',         zun, zvn, zwn, tsb, tsn, tsa, jpts )   !  2nd order centered 
    117       CASE ( 2 )   ;    CALL tra_adv_tvd   ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts )   !  TVD  
    118       CASE ( 3 )   ;    CALL tra_adv_muscl ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb,      tsa, jpts, ln_traadv_msc_ups )   !  MUSCL  
    119       CASE ( 4 )   ;    CALL tra_adv_muscl2( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts )   !  MUSCL2  
    120       CASE ( 5 )   ;    CALL tra_adv_ubs   ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts )   !  UBS  
    121       CASE ( 6 )   ;    CALL tra_adv_qck   ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts )   !  QUICKEST  
     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 
    122131      ! 
    123132      CASE (-1 )                                      !==  esopa: test all possibility with control print  ==! 
    … …  
    166175         &                 ln_traadv_muscl, ln_traadv_muscl2,  & 
    167176         &                 ln_traadv_ubs  , ln_traadv_qck,     & 
    168          &                 ln_traadv_msc_ups 
     177         &                 ln_traadv_msc_ups, ln_traadv_tvd_zts 
    169178      !!---------------------------------------------------------------------- 
    170179 
    … …  
    190199         WRITE(numout,*) '      QUICKEST advection scheme      ln_traadv_qck     = ', ln_traadv_qck 
    191200         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 
    192202      ENDIF 
    193203 
    … …  
    199209      IF( ln_traadv_ubs    )   ioptio = ioptio + 1 
    200210      IF( ln_traadv_qck    )   ioptio = ioptio + 1 
     211      IF( ln_traadv_tvd_zts)   ioptio = ioptio + 1 
    201212      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') 
    202216 
    203217      IF( ioptio /= 1 )   CALL ctl_stop( 'Choose ONE advection scheme in namelist namtra_adv' ) 
    … …  
    210224      IF( ln_traadv_ubs    )   nadv =  5 
    211225      IF( ln_traadv_qck    )   nadv =  6 
     226      IF( ln_traadv_tvd_zts)   nadv =  7 
    212227      IF( lk_esopa         )   nadv = -1 
    213228 
    … …  
    220235         IF( nadv ==  5 )   WRITE(numout,*) '         UBS       scheme is used' 
    221236         IF( nadv ==  6 )   WRITE(numout,*) '         QUICKEST  scheme is used' 
     237         IF( nadv ==  7 )   WRITE(numout,*) '         TVD ZTS   scheme is used' 
    222238         IF( nadv == -1 )   WRITE(numout,*) '         esopa test: use all advection scheme' 
    223239      ENDIF 

  • branches/2014/dev_r4650_UKMO14.5_SST_BIAS_CORRECTION/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_cen2.F90

    r4499 r5965  
    44   !! Ocean  tracers:  horizontal & vertical advective trend 
    55   !!====================================================================== 
    6    !! History :  8.2  ! 2001-08  (G. Madec, E. Durand) trahad+trazad=traadv  
    7    !!            1.0  ! 2002-06  (G. Madec)  F90: Free form and module 
    8    !!            9.0  ! 2004-08  (C. Talandier) New trends organization 
     6   !! History :  OPA  ! 2001-08  (G. Madec, E. Durand) v8.2 trahad+trazad=traadv  
     7   !!   NEMO     1.0  ! 2002-06  (G. Madec)  F90: Free form and module 
     8   !!             -   ! 2004-08  (C. Talandier) New trends organization 
    99   !!             -   ! 2005-11  (V. Garnier) Surface pressure gradient organization 
    1010   !!            2.0  ! 2006-04  (R. Benshila, G. Madec) Step reorganization 
    … …  
    2121   USE dom_oce         ! ocean space and time domain 
    2222   USE eosbn2          ! equation of state 
    23    USE trdmod_oce      ! tracers trends 
    24    USE trdtra          ! tracers trends 
     23   USE trd_oce         ! trends: ocean variables 
     24   USE trdtra          ! trends manager: tracers  
    2525   USE closea          ! closed sea 
    2626   USE sbcrnf          ! river runoffs 
    … …  
    3333   USE wrk_nemo        ! Memory Allocation 
    3434   USE timing          ! Timing 
     35   USE phycst 
    3536 
    3637   IMPLICIT NONE 
    3738   PRIVATE 
    3839 
    39    PUBLIC   tra_adv_cen2       ! routine called by step.F90 
    40    PUBLIC   ups_orca_set       ! routine used by traadv_cen2_jki.F90 
    41  
    42    LOGICAL  :: l_trd       ! flag to compute trends 
     40   PUBLIC   tra_adv_cen2   ! routine called by traadv.F90 
    4341 
    4442   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: upsmsk !: mixed upstream/centered scheme near some straits  
    … …  
    5553 
    5654   SUBROUTINE tra_adv_cen2( kt, kit000, cdtype, pun, pvn, pwn,     & 
    57       &                                 ptb, ptn, pta, kjpt   )  
     55      &                                         ptb, ptn, pta, kjpt   )  
    5856      !!---------------------------------------------------------------------- 
    5957      !!                  ***  ROUTINE tra_adv_cen2  *** 
    … …  
    8583      !!       * Add this trend now to the general trend of tracer (ta,sa): 
    8684      !!               pta = pta + ztra 
    87       !!       * trend diagnostic ('key_trdtra' defined): the trend is 
     85      !!       * trend diagnostic (l_trdtra=T or l_trctra=T): the trend is 
    8886      !!      saved for diagnostics. The trends saved is expressed as 
    89       !!      Uh.gradh(T), i.e. 
    90       !!                     save trend = ztra + ptn divn 
     87      !!      Uh.gradh(T), i.e.  save trend = ztra + ptn divn 
    9188      !! 
    9289      !!         Part II : vertical advection 
    … …  
    104101      !!         Add this trend now to the general trend of tracer (ta,sa): 
    105102      !!             pta = pta + ztra 
    106       !!         Trend diagnostic ('key_trdtra' defined): the trend is 
     103      !!         Trend diagnostic (l_trdtra=T or l_trctra=T): the trend is 
    107104      !!      saved for diagnostics. The trends saved is expressed as : 
    108105      !!             save trend =  w.gradz(T) = ztra - ptn divn. 
    … …  
    111108      !!              - save trends if needed 
    112109      !!---------------------------------------------------------------------- 
    113       USE oce     , ONLY:   zwx => ua        , zwy  => va          ! (ua,va) used as 3D workspace 
    114       ! 
    115110      INTEGER                              , INTENT(in   ) ::   kt              ! ocean time-step index 
    116111      INTEGER                              , INTENT(in   ) ::   kit000          ! first time step index 
    … …  
    121116      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta             ! tracer trend  
    122117      ! 
    123       INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    124       INTEGER  ::   ierr             ! local integer 
     118      INTEGER  ::   ji, jj, jk, jn, ikt   ! dummy loop indices 
     119      INTEGER  ::   ierr                 ! local integer 
    125120      REAL(wp) ::   zbtr, ztra                            ! local scalars 
    126121      REAL(wp) ::   zfp_ui, zfp_vj, zfp_w, zcofi          !   -      - 
    … …  
    128123      REAL(wp) ::   zupsut, zcenut, zupst                 !   -      - 
    129124      REAL(wp) ::   zupsvt, zcenvt, zcent, zice           !   -      - 
    130       REAL(wp), POINTER, DIMENSION(:,:  ) :: ztfreez  
    131       REAL(wp), POINTER, DIMENSION(:,:,:) :: zwz, zind 
     125      REAL(wp), POINTER, DIMENSION(:,:)   :: zfzp, zpres   ! 2D workspace 
     126      REAL(wp), POINTER, DIMENSION(:,:,:) :: zwx, zwy     ! 3D     - 
     127      REAL(wp), POINTER, DIMENSION(:,:,:) :: zwz, zind    !  -     - 
    132128      !!---------------------------------------------------------------------- 
    133129      ! 
    134130      IF( nn_timing == 1 )  CALL timing_start('tra_adv_cen2') 
    135131      ! 
    136       CALL wrk_alloc( jpi, jpj, ztfreez ) 
    137       CALL wrk_alloc( jpi, jpj, jpk, zwz, zind ) 
     132      CALL wrk_alloc( jpi, jpj, zpres, zfzp ) 
     133      CALL wrk_alloc( jpi, jpj, jpk, zwx, zwy, zwz, zind ) 
    138134      ! 
    139135 
    … …  
    144140         IF(lwp) WRITE(numout,*) 
    145141         ! 
    146          IF ( .NOT. ALLOCATED( upsmsk ) )  THEN 
     142         IF( .NOT. ALLOCATED( upsmsk ) )  THEN 
    147143             ALLOCATE( upsmsk(jpi,jpj), STAT=ierr ) 
    148144             IF( ierr /= 0 )   CALL ctl_stop('STOP', 'tra_adv_cen2: unable to allocate array') 
    … …  
    162158      ENDIF 
    163159      ! 
    164       l_trd = .FALSE. 
    165       IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) )   l_trd = .TRUE. 
    166       ! 
    167160      ! Upstream / centered scheme indicator 
    168161      ! ------------------------------------ 
    169162!!gm  not strickly exact : the freezing point should be computed at each ocean levels... 
    170163!!gm  not a big deal since cen2 is no more used in global ice-ocean simulations 
    171       ztfreez(:,:) = tfreez( tsn(:,:,1,jp_sal) ) 
     164!!ch  changes for ice shelf to retain standard behaviour elsewhere, even if not optimal  
     165      DO jj = 1, jpj  
     166         DO ji = 1, jpi  
     167            ikt = mikt(ji,jj)  
     168            IF (ikt > 1 ) THEN  
     169               zpres(ji,jj) = grav * rau0 * fsdept(ji,jj,ikt) * 1.e-04   
     170            ELSE  
     171               zpres(ji,jj) = 0.0  
     172            ENDIF   
     173         END DO  
     174      END DO  
     175      zfzp(:,:) = eos_fzp( tsn(:,:,1,jp_sal), zpres(:,:) ) 
    172176      DO jk = 1, jpk 
    173177         DO jj = 1, jpj 
    174178            DO ji = 1, jpi 
    175179               !                                        ! below ice covered area (if tn < "freezing"+0.1 ) 
    176                IF( tsn(ji,jj,jk,jp_tem) <= ztfreez(ji,jj) + 0.1 ) THEN   ;   zice = 1.e0 
    177                ELSE                                                      ;   zice = 0.e0 
     180               IF( tsn(ji,jj,jk,jp_tem) <= zfzp(ji,jj) + 0.1 ) THEN   ;   zice = 1._wp 
     181               ELSE                                                   ;   zice = 0._wp 
    178182               ENDIF 
    179183               zind(ji,jj,jk) = MAX (   & 
    … …  
    224228         !                                                     ! Surface value :  
    225229         IF( lk_vvl ) THEN   ;   zwz(:,:, 1 ) = 0.e0                         ! volume variable 
    226          ELSE                ;   zwz(:,:, 1 ) = pwn(:,:,1) * ptn(:,:,1,jn)   ! linear free surface  
     230         ELSE 
     231            DO jj = 1, jpj   ! vector opt. 
     232               DO ji = 1, jpi   ! vector opt. 
     233                  ikt = mikt(ji,jj)                 
     234                  zwz(ji,jj,ikt ) = pwn(ji,jj,ikt) * ptn(ji,jj,ikt,jn)   ! linear free surface  
     235                  zwz(ji,jj,1:ikt-1) = 0.e0 
     236               END DO 
     237            END DO 
    227238         ENDIF 
    228239         ! 
    … …  
    260271         END DO 
    261272 
    262          !                                 ! trend diagnostics (contribution of upstream fluxes) 
    263          IF( l_trd ) THEN 
    264             CALL trd_tra( kt, cdtype, jn, jptra_trd_xad, zwx, pun, ptn(:,:,:,jn) ) 
    265             CALL trd_tra( kt, cdtype, jn, jptra_trd_yad, zwy, pvn, ptn(:,:,:,jn) ) 
    266             CALL trd_tra( kt, cdtype, jn, jptra_trd_zad, zwz, pwn, ptn(:,:,:,jn) ) 
     273         !                                 ! trend diagnostics 
     274         IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR.    & 
     275            &( cdtype == 'TRC' .AND. l_trdtrc ) )   THEN 
     276            CALL trd_tra( kt, cdtype, jn, jptra_xad, zwx, pun, ptn(:,:,:,jn) ) 
     277            CALL trd_tra( kt, cdtype, jn, jptra_yad, zwy, pvn, ptn(:,:,:,jn) ) 
     278            CALL trd_tra( kt, cdtype, jn, jptra_zad, zwz, pwn, ptn(:,:,:,jn) ) 
    267279         END IF 
    268280         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    269          IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN   
    270            IF( jn == jp_tem )  htr_adv(:) = ptr_vj( zwy(:,:,:) ) 
    271            IF( jn == jp_sal )  str_adv(:) = ptr_vj( zwy(:,:,:) ) 
     281         IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
     282           IF( jn == jp_tem )   htr_adv(:) = ptr_sj( zwy(:,:,:) ) 
     283           IF( jn == jp_sal )   str_adv(:) = ptr_sj( zwy(:,:,:) ) 
    272284         ENDIF 
    273285         ! 
    274       ENDDO 
     286      END DO 
    275287 
    276288      ! ---------------------------  required in restart file to ensure restartability) 
    … …  
    281293      ENDIF 
    282294      ! 
    283       CALL wrk_dealloc( jpi, jpj, ztfreez ) 
    284       CALL wrk_dealloc( jpi, jpj, jpk, zwz, zind ) 
     295      CALL wrk_dealloc( jpi, jpj, zpres, zfzp ) 
     296      CALL wrk_dealloc( jpi, jpj, jpk, zwx, zwy, zwz, zind ) 
    285297      ! 
    286298      IF( nn_timing == 1 )  CALL timing_stop('tra_adv_cen2') 
    … …  
    303315      INTEGER  ::   ii0, ii1, ij0, ij1      ! temporary integers 
    304316      !!---------------------------------------------------------------------- 
    305        
    306317      ! 
    307318      IF( nn_timing == 1 )  CALL timing_start('ups_orca_set') 

  • branches/2014/dev_r4650_UKMO14.5_SST_BIAS_CORRECTION/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_eiv.F90

    r3787 r5965  
    2525   USE phycst          ! physical constants 
    2626   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    27    USE diaar5, ONLY:   lk_diaar5 
    2827# endif   
    2928   USE wrk_nemo        ! Memory Allocation 
    … …  
    161160         CALL iom_put( "voce_eiv", v_eiv )    ! j-eiv current 
    162161         CALL iom_put( "woce_eiv", w_eiv )    ! vert. eiv current 
    163          IF( lk_diaar5 ) THEN 
     162         IF( iom_use('ueiv_heattr') ) THEN 
    164163            zztmp = 0.5 * rau0 * rcp  
    165164            z2d(:,:) = 0.e0  
    … …  
    167166               DO jj = 2, jpjm1 
    168167                  DO ji = fs_2, fs_jpim1   ! vector opt. 
    169                      z2d(ji,jj) = z2d(ji,jj) + zztmp * u_eiv(ji,jj,jk) & 
     168                     z2d(ji,jj) = z2d(ji,jj) + u_eiv(ji,jj,jk) & 
    170169                       &         * (tsn(ji,jj,jk,jp_tem)+tsn(ji+1,jj,jk,jp_tem)) * e2u(ji,jj) * fse3u(ji,jj,jk)  
    171170                  END DO 
    … …  
    173172            END DO 
    174173            CALL lbc_lnk( z2d, 'U', -1. ) 
    175             CALL iom_put( "ueiv_heattr", z2d )                  ! heat transport in i-direction 
     174            CALL iom_put( "ueiv_heattr", zztmp * z2d )                  ! heat transport in i-direction 
     175         ENDIF 
     176             
     177         IF( iom_use('veiv_heattr') ) THEN 
     178            zztmp = 0.5 * rau0 * rcp  
    176179            z2d(:,:) = 0.e0  
    177180            DO jk = 1, jpkm1 
    178181               DO jj = 2, jpjm1 
    179182                  DO ji = fs_2, fs_jpim1   ! vector opt. 
    180                      z2d(ji,jj) = z2d(ji,jj) + zztmp * v_eiv(ji,jj,jk) & 
     183                     z2d(ji,jj) = z2d(ji,jj) + v_eiv(ji,jj,jk) & 
    181184                     &           * (tsn(ji,jj,jk,jp_tem)+tsn(ji,jj+1,jk,jp_tem)) * e1v(ji,jj) * fse3v(ji,jj,jk)  
    182185                  END DO 
    … …  
    184187            END DO 
    185188            CALL lbc_lnk( z2d, 'V', -1. ) 
    186             CALL iom_put( "veiv_heattr", z2d )                  !  heat transport in i-direction 
     189            CALL iom_put( "veiv_heattr", zztmp * z2d )                  !  heat transport in i-direction 
    187190         ENDIF 
    188191    END IF 

  • branches/2014/dev_r4650_UKMO14.5_SST_BIAS_CORRECTION/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_mle.F90

    • Property svn:keywords set to Id
    r4624 r5965  
    5353   !!---------------------------------------------------------------------- 
    5454   !! NEMO/OPA 4.0 , NEMO Consortium (2011) 
    55    !! $Id:$ 
     55   !! $Id$ 
    5656   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 
    5757   !!---------------------------------------------------------------------- 
    … …  
    203203      ! 
    204204      !                                      !==  structure function value at uw- and vw-points  ==! 
    205       zhu(:,:) = 1._wp / zhu(:,:)                   ! hu --> 1/hu 
    206       zhv(:,:) = 1._wp / zhv(:,:) 
     205      DO jj = 1, jpjm1 
     206         DO ji = 1, fs_jpim1   ! vector opt. 
     207            zhu(ji,jj) = 1._wp / zhu(ji,jj)                   ! hu --> 1/hu 
     208            zhv(ji,jj) = 1._wp / zhv(ji,jj) 
     209         END DO 
     210      END DO 
     211      ! 
    207212      zpsi_uw(:,:,:) = 0._wp 
    208213      zpsi_vw(:,:,:) = 0._wp 

  • branches/2014/dev_r4650_UKMO14.5_SST_BIAS_CORRECTION/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_muscl.F90

    r4499 r5965  
    1616   !!---------------------------------------------------------------------- 
    1717   USE oce            ! ocean dynamics and active tracers 
     18   USE trc_oce        ! share passive tracers/Ocean variables 
    1819   USE dom_oce        ! ocean space and time domain 
    19    USE trdmod_oce     ! tracers trends  
    20    USE trdtra         ! tracers trends  
    21    USE in_out_manager ! I/O manager 
     20   USE trd_oce        ! trends: ocean variables 
     21   USE trdtra         ! tracers trends manager 
    2222   USE dynspg_oce     ! choice/control of key cpp for surface pressure gradient 
    23    USE trabbl         ! tracers: bottom boundary layer 
    24    USE lib_mpp        ! distribued memory computing 
    25    USE lbclnk         ! ocean lateral boundary condition (or mpp link)  
     23   USE sbcrnf         ! river runoffs 
    2624   USE diaptr         ! poleward transport diagnostics 
    27    USE trc_oce        ! share passive tracers/Ocean variables 
     25   ! 
    2826   USE wrk_nemo       ! Memory Allocation 
    2927   USE timing         ! Timing 
    3028   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)   
    31    USE eosbn2          ! equation of state 
    32    USE sbcrnf          ! river runoffs 
     29   USE in_out_manager ! I/O manager 
     30   USE lib_mpp        ! distribued memory computing 
     31   USE lbclnk         ! ocean lateral boundary condition (or mpp link)  
    3332 
    3433   IMPLICIT NONE 
    3534   PRIVATE 
    3635 
    37    PUBLIC   tra_adv_muscl  ! routine called by step.F90 
    38  
    39    LOGICAL  :: l_trd                        ! flag to compute trends 
    40    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: upsmsk !: mixed upstream/centered scheme near some straits 
    41    !                                                             !  and in closed seas (orca 2 and 4 configurations) 
    42    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xind         !: mixed upstream/centered index 
     36   PUBLIC   tra_adv_muscl   ! routine called by traadv.F90 
     37    
     38   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   upsmsk   !: mixed upstream/centered scheme near some straits 
     39   !                                                           !  and in closed seas (orca 2 and 4 configurations) 
     40   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   xind     !: mixed upstream/centered index 
     41    
    4342   !! * Substitutions 
    4443#  include "domzgr_substitute.h90" 
    … …  
    5150CONTAINS 
    5251 
    53    SUBROUTINE tra_adv_muscl( kt, kit000, cdtype, p2dt, pun, pvn, pwn, & 
    54       &                                        ptb, pta, kjpt, ld_msc_ups ) 
     52   SUBROUTINE tra_adv_muscl( kt, kit000, cdtype, p2dt, pun, pvn, pwn,   & 
     53      &                                                ptb, pta, kjpt, ld_msc_ups ) 
    5554      !!---------------------------------------------------------------------- 
    5655      !!                    ***  ROUTINE tra_adv_muscl  *** 
    … …  
    6867      !!              IPSL, Sept. 2000 (http://www.lodyc.jussieu.fr/opa) 
    6968      !!---------------------------------------------------------------------- 
    70       USE oce     , ONLY:   zwx   => ua    , zwy   => va          ! (ua,va) used as workspace 
    71       ! 
    7269      INTEGER                              , INTENT(in   ) ::   kt              ! ocean time-step index 
    7370      INTEGER                              , INTENT(in   ) ::   kit000          ! first time step index 
    … …  
    7976      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb             ! before tracer field 
    8077      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta             ! tracer trend  
    81  
    82       ! 
    83       INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
     78      ! 
     79      INTEGER  ::   ji, jj, jk, jn            ! dummy loop indices 
     80      INTEGER  ::   ierr                      ! local integer 
    8481      REAL(wp) ::   zu, z0u, zzwx, zw         ! local scalars 
    8582      REAL(wp) ::   zv, z0v, zzwy, z0w        !   -      - 
    8683      REAL(wp) ::   ztra, zbtr, zdt, zalpha   !   -      - 
    87       REAL(wp), POINTER, DIMENSION(:,:,:) :: zslpx, zslpy 
    88       INTEGER  ::   ierr 
     84      REAL(wp), POINTER, DIMENSION(:,:,:) ::   zslpx, zslpy   ! 3D workspace 
     85      REAL(wp), POINTER, DIMENSION(:,:,:) ::   zwx  , zwy     ! -      -  
    8986      !!---------------------------------------------------------------------- 
    9087      ! 
    9188      IF( nn_timing == 1 )  CALL timing_start('tra_adv_muscl') 
    9289      ! 
    93       CALL wrk_alloc( jpi, jpj, jpk, zslpx, zslpy ) 
    94       ! 
    95  
     90      CALL wrk_alloc( jpi, jpj, jpk, zslpx, zslpy, zwx, zwy ) 
     91      ! 
    9692      IF( kt == kit000 )  THEN 
    9793         IF(lwp) WRITE(numout,*) 
    … …  
    117113 
    118114         ! 
    119          ! Upstream / centered scheme indicator 
     115         ! Upstream / MUSCL scheme indicator 
    120116         ! ------------------------------------ 
     117!!gm  useless 
    121118         xind(:,:,:) = 1._wp                             ! set equal to 1 where up-stream is not needed 
     119!!gm 
    122120         ! 
    123121         IF( ld_msc_ups )  THEN 
    124             DO jk = 1, jpk 
    125                DO jj = 1, jpj 
    126                   DO ji = 1, jpi 
    127                      xind(ji,jj,jk) = 1  - MAX (           & 
    128                         rnfmsk(ji,jj) * rnfmsk_z(jk),      &  ! near runoff mouths (& closed sea outflows) 
    129                         upsmsk(ji,jj) ) * tmask(ji,jj,jk)     ! some of some straits 
    130                   END DO 
    131                END DO 
     122            DO jk = 1, jpkm1 
     123               xind(:,:,jk) = 1._wp                              &                 ! =>1 where up-stream is not needed 
     124                  &         - MAX ( rnfmsk(:,:) * rnfmsk_z(jk),  &                 ! =>0 near runoff mouths (& closed sea outflows) 
     125                  &                 upsmsk(:,:)                ) * tmask(:,:,jk)   ! =>0 near some straits 
    132126            END DO 
    133127         ENDIF  
    134128         ! 
    135129      ENDIF  
    136       ! 
    137       l_trd = .FALSE. 
    138       IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 
    139        
     130      !       
    140131      !                                                     ! =========== 
    141132      DO jn = 1, kjpt                                       ! tracer loop 
    … …  
    192183                  zalpha = 0.5 - z0u 
    193184                  zu  = z0u - 0.5 * pun(ji,jj,jk) * zdt / ( e1u(ji,jj) * e2u(ji,jj) * fse3u(ji,jj,jk) ) 
    194                   zzwx = ptb(ji+1,jj,jk,jn) + xind(ji,jj,jk) * (zu * zslpx(ji+1,jj,jk)) 
    195                   zzwy = ptb(ji  ,jj,jk,jn) + xind(ji,jj,jk) * (zu * zslpx(ji  ,jj,jk)) 
     185                  zzwx = ptb(ji+1,jj,jk,jn) + xind(ji,jj,jk) * zu * zslpx(ji+1,jj,jk) 
     186                  zzwy = ptb(ji  ,jj,jk,jn) + xind(ji,jj,jk) * zu * zslpx(ji  ,jj,jk) 
    196187                  zwx(ji,jj,jk) = pun(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 
    197188                  ! 
    … …  
    199190                  zalpha = 0.5 - z0v 
    200191                  zv  = z0v - 0.5 * pvn(ji,jj,jk) * zdt / ( e1v(ji,jj) * e2v(ji,jj) * fse3v(ji,jj,jk) ) 
    201                   zzwx = ptb(ji,jj+1,jk,jn) + xind(ji,jj,jk) * (zv * zslpy(ji,jj+1,jk)) 
    202                   zzwy = ptb(ji,jj  ,jk,jn) + xind(ji,jj,jk) * (zv * zslpy(ji,jj  ,jk)) 
     192                  zzwx = ptb(ji,jj+1,jk,jn) + xind(ji,jj,jk) * zv * zslpy(ji,jj+1,jk) 
     193                  zzwy = ptb(ji,jj  ,jk,jn) + xind(ji,jj,jk) * zv * zslpy(ji,jj  ,jk) 
    203194                  zwy(ji,jj,jk) = pvn(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 
    204195               END DO 
    … …  
    222213         END DO         
    223214         !                                 ! trend diagnostics (contribution of upstream fluxes) 
    224          IF( l_trd )  THEN 
    225             CALL trd_tra( kt, cdtype, jn, jptra_trd_xad, zwx, pun, ptb(:,:,:,jn) ) 
    226             CALL trd_tra( kt, cdtype, jn, jptra_trd_yad, zwy, pvn, ptb(:,:,:,jn) ) 
     215         IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR.   & 
     216            &( cdtype == 'TRC' .AND. l_trdtrc )      )  THEN 
     217            CALL trd_tra( kt, cdtype, jn, jptra_xad, zwx, pun, ptb(:,:,:,jn) ) 
     218            CALL trd_tra( kt, cdtype, jn, jptra_yad, zwy, pvn, ptb(:,:,:,jn) ) 
    227219         END IF 
    228220         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    229          IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN   
    230             IF( jn == jp_tem )  htr_adv(:) = ptr_vj( zwy(:,:,:) ) 
    231             IF( jn == jp_sal )  str_adv(:) = ptr_vj( zwy(:,:,:) ) 
     221         IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
     222            IF( jn == jp_tem )  htr_adv(:) = ptr_sj( zwy(:,:,:) ) 
     223            IF( jn == jp_sal )  str_adv(:) = ptr_sj( zwy(:,:,:) ) 
    232224         ENDIF 
    233225 
    … …  
    274266                  zalpha = 0.5 + z0w 
    275267                  zw  = z0w - 0.5 * pwn(ji,jj,jk+1) * zdt * zbtr  
    276                   zzwx = ptb(ji,jj,jk+1,jn) + xind(ji,jj,jk) * (zw * zslpx(ji,jj,jk+1)) 
    277                   zzwy = ptb(ji,jj,jk  ,jn) + xind(ji,jj,jk) * (zw * zslpx(ji,jj,jk  )) 
     268                  zzwx = ptb(ji,jj,jk+1,jn) + xind(ji,jj,jk) * zw * zslpx(ji,jj,jk+1) 
     269                  zzwy = ptb(ji,jj,jk  ,jn) + xind(ji,jj,jk) * zw * zslpx(ji,jj,jk  ) 
    278270                  zwx(ji,jj,jk+1) = pwn(ji,jj,jk+1) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 
    279271               END DO  
    … …  
    281273         END DO 
    282274 
    283          ! Compute & add the vertical advective trend 
    284          DO jk = 1, jpkm1 
     275         DO jk = 1, jpkm1                    ! Compute & add the vertical advective trend 
    285276            DO jj = 2, jpjm1       
    286277               DO ji = fs_2, fs_jpim1   ! vector opt. 
    287                   zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
     278                  zbtr = 1. / ( e1e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    288279                  ! vertical advective trends  
    289280                  ztra = - zbtr * ( zwx(ji,jj,jk) - zwx(ji,jj,jk+1) ) 
    … …  
    294285         END DO 
    295286         !                                 ! Save the vertical advective trends for diagnostic 
    296          IF( l_trd ) CALL trd_tra( kt, cdtype, jn, jptra_trd_zad, zwx, pwn, ptb(:,:,:,jn) ) 
    297          ! 
    298       ENDDO 
    299       ! 
    300       CALL wrk_dealloc( jpi, jpj, jpk, zslpx, zslpy ) 
     287         IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR.     & 
     288            &( cdtype == 'TRC' .AND. l_trdtrc )      )   & 
     289            CALL trd_tra( kt, cdtype, jn, jptra_zad, zwx, pwn, ptb(:,:,:,jn) ) 
     290         ! 
     291      END DO 
     292      ! 
     293      CALL wrk_dealloc( jpi, jpj, jpk, zslpx, zslpy, zwx, zwy ) 
    301294      ! 
    302295      IF( nn_timing == 1 )  CALL timing_stop('tra_adv_muscl') 

  • branches/2014/dev_r4650_UKMO14.5_SST_BIAS_CORRECTION/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_muscl2.F90

    r4499 r5965  
    1313   !!---------------------------------------------------------------------- 
    1414   USE oce             ! ocean dynamics and active tracers 
     15   USE trc_oce         ! share passive tracers/Ocean variables 
    1516   USE dom_oce         ! ocean space and time domain 
    16    USE trdmod_oce      ! tracers trends  
    17    USE trdtra          ! tracers trends  
     17   USE trd_oce         ! trends: ocean variables 
     18   USE trdtra          ! trends manager: tracers  
    1819   USE in_out_manager  ! I/O manager 
    1920   USE dynspg_oce      ! choice/control of key cpp for surface pressure gradient 
    20    USE trabbl          ! tracers: bottom boundary layer 
     21   USE diaptr          ! poleward transport diagnostics 
     22   ! 
    2123   USE lib_mpp         ! distribued memory computing 
    2224   USE lbclnk          ! ocean lateral boundary condition (or mpp link)  
    23    USE diaptr          ! poleward transport diagnostics 
    24    USE trc_oce         ! share passive tracers/Ocean variables 
    2525   USE wrk_nemo        ! Memory Allocation 
    2626   USE timing          ! Timing 
    … …  
    3131 
    3232   PUBLIC   tra_adv_muscl2        ! routine called by step.F90 
    33  
    34    LOGICAL  :: l_trd       ! flag to compute trends 
    3533 
    3634   !! * Substitutions 
    … …  
    6159      !!              IPSL, Sept. 2000 (http://www.lodyc.jussieu.fr/opa) 
    6260      !!---------------------------------------------------------------------- 
    63       USE oce     , ONLY:   zwx   => ua    , zwy   => va         ! (ua,va) used as 3D workspace 
    64       !! 
    6561      INTEGER                              , INTENT(in   ) ::   kt              ! ocean time-step index 
    6662      INTEGER                              , INTENT(in   ) ::   kit000          ! first time step index 
    … …  
    7672      REAL(wp) ::   zv, z0v, zzwy, z0w        !   -      - 
    7773      REAL(wp) ::   ztra, zbtr, zdt, zalpha   !   -      - 
    78       REAL(wp), POINTER, DIMENSION(:,:,:) :: zslpx, zslpy 
     74      REAL(wp), POINTER, DIMENSION(:,:,:) :: zslpx, zslpy , zwx, zwy 
    7975      !!---------------------------------------------------------------------- 
    8076      ! 
    8177      IF( nn_timing == 1 )  CALL timing_start('tra_adv_muscl2') 
    8278      ! 
    83       CALL wrk_alloc( jpi, jpj, jpk, zslpx, zslpy ) 
     79      CALL wrk_alloc( jpi, jpj, jpk, zslpx, zslpy, zwx, zwy ) 
    8480      ! 
    8581 
    … …  
    9086      ENDIF 
    9187      ! 
    92       l_trd = .FALSE. 
    93       IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) )   l_trd = .TRUE. 
    94  
    9588      !                                                          ! =========== 
    9689      DO jn = 1, kjpt                                            ! tracer loop 
    … …  
    200193         END DO 
    201194         !                                 ! trend diagnostics (contribution of upstream fluxes) 
    202          IF( l_trd ) THEN 
    203             CALL trd_tra( kt, cdtype, jn, jptra_trd_xad, zwx, pun, ptb(:,:,:,jn) ) 
    204             CALL trd_tra( kt, cdtype, jn, jptra_trd_yad, zwy, pvn, ptb(:,:,:,jn) ) 
     195         IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR.   & 
     196            &( cdtype == 'TRC' .AND. l_trdtrc )      ) THEN 
     197            CALL trd_tra( kt, cdtype, jn, jptra_xad, zwx, pun, ptb(:,:,:,jn) ) 
     198            CALL trd_tra( kt, cdtype, jn, jptra_yad, zwy, pvn, ptb(:,:,:,jn) ) 
    205199         END IF 
    206200 
    207201         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    208          IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN 
    209             IF( jn == jp_tem )  htr_adv(:) = ptr_vj( zwy(:,:,:) ) 
    210             IF( jn == jp_sal )  str_adv(:) = ptr_vj( zwy(:,:,:) ) 
     202         IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 
     203            IF( jn == jp_tem )  htr_adv(:) = ptr_sj( zwy(:,:,:) ) 
     204            IF( jn == jp_sal )  str_adv(:) = ptr_sj( zwy(:,:,:) ) 
    211205         ENDIF 
    212206 
    … …  
    284278         END DO 
    285279         !                       ! trend diagnostics (contribution of upstream fluxes) 
    286          IF( l_trd )  CALL trd_tra( kt, cdtype, jn, jptra_trd_zad, zwx, pwn, ptb(:,:,:,jn) ) 
     280         IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR.     & 
     281            &( cdtype == 'TRC' .AND. l_trdtrc )      )   & 
     282            CALL trd_tra( kt, cdtype, jn, jptra_zad, zwx, pwn, ptb(:,:,:,jn) ) 
    287283         ! 
    288284      END DO 
    289285      ! 
    290       CALL wrk_dealloc( jpi, jpj, jpk, zslpx, zslpy ) 
     286      CALL wrk_dealloc( jpi, jpj, jpk, zslpx, zslpy, zwx, zwy ) 
    291287      ! 
    292288      IF( nn_timing == 1 )  CALL timing_stop('tra_adv_muscl2') 

  • branches/2014/dev_r4650_UKMO14.5_SST_BIAS_CORRECTION/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_qck.F90

    r4499 r5965  
    1717   USE oce             ! ocean dynamics and active tracers 
    1818   USE dom_oce         ! ocean space and time domain 
    19    USE trdmod_oce      ! ocean space and time domain 
    20    USE trdtra          ! ocean tracers trends  
    21    USE trabbl          ! advective term in the BBL 
     19   USE trc_oce         ! share passive tracers/Ocean variables 
     20   USE trd_oce         ! trends: ocean variables 
     21   USE trdtra          ! trends manager: tracers  
     22   USE dynspg_oce      ! surface pressure gradient variables 
     23   USE diaptr          ! poleward transport diagnostics 
     24   ! 
    2225   USE lib_mpp         ! distribued memory computing 
    2326   USE lbclnk          ! ocean lateral boundary condition (or mpp link) 
    24    USE dynspg_oce      ! surface pressure gradient variables 
    2527   USE in_out_manager  ! I/O manager 
    26    USE diaptr          ! poleward transport diagnostics 
    27    USE trc_oce         ! share passive tracers/Ocean variables 
    2828   USE wrk_nemo        ! Memory Allocation 
    2929   USE timing          ! Timing 
    … …  
    9393      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta             ! tracer trend  
    9494      !!---------------------------------------------------------------------- 
    95  
    9695      ! 
    9796      IF( nn_timing == 1 )  CALL timing_start('tra_adv_qck') 
    … …  
    103102         IF(lwp) WRITE(numout,*) 
    104103      ENDIF 
    105       ! 
    106104      l_trd = .FALSE. 
    107       IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 
    108  
     105      IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) )   l_trd = .TRUE. 
     106      ! 
    109107      ! I. The horizontal fluxes are computed with the QUICKEST + ULTIMATE scheme 
    110108      CALL tra_adv_qck_i( kt, cdtype, p2dt, pun, ptb, ptn, pta, kjpt )  
    … …  
    124122      !! 
    125123      !!---------------------------------------------------------------------- 
    126       USE oce     , ONLY:   zwx => ua       ! ua used as workspace 
    127       ! 
    128124      INTEGER                              , INTENT(in   ) ::   kt         ! ocean time-step index 
    129125      CHARACTER(len=3)                     , INTENT(in   ) ::   cdtype     ! =TRA or TRC (tracer indicator) 
    … …  
    136132      INTEGER  :: ji, jj, jk, jn   ! dummy loop indices 
    137133      REAL(wp) :: ztra, zbtr, zdir, zdx, zdt, zmsk   ! local scalars 
    138       REAL(wp), POINTER, DIMENSION(:,:,:) :: zfu, zfc, zfd 
     134      REAL(wp), POINTER, DIMENSION(:,:,:) :: zwx, zfu, zfc, zfd 
    139135      !---------------------------------------------------------------------- 
    140136      ! 
    141       CALL wrk_alloc( jpi, jpj, jpk, zfu, zfc, zfd ) 
     137      CALL wrk_alloc( jpi, jpj, jpk, zwx, zfu, zfc, zfd ) 
    142138      !                                                          ! =========== 
    143139      DO jn = 1, kjpt                                            ! tracer loop 
    … …  
    233229         END DO 
    234230         !                                 ! trend diagnostics (contribution of upstream fluxes) 
    235          IF( l_trd )  CALL trd_tra( kt, cdtype, jn, jptra_trd_xad, zwx, pun, ptn(:,:,:,jn) ) 
     231         IF( l_trd )   CALL trd_tra( kt, cdtype, jn, jptra_xad, zwx, pun, ptn(:,:,:,jn) ) 
    236232         ! 
    237233      END DO 
    238234      ! 
    239       CALL wrk_dealloc( jpi, jpj, jpk, zfu, zfc, zfd ) 
     235      CALL wrk_dealloc( jpi, jpj, jpk, zwx, zfu, zfc, zfd ) 
    240236      ! 
    241237   END SUBROUTINE tra_adv_qck_i 
    … …  
    247243      !! 
    248244      !!---------------------------------------------------------------------- 
    249       USE oce     , ONLY:   zwy => ua       ! ua used as workspace 
    250       ! 
    251245      INTEGER                              , INTENT(in   ) ::   kt         ! ocean time-step index 
    252246      CHARACTER(len=3)                     , INTENT(in   ) ::   cdtype     ! =TRA or TRC (tracer indicator) 
    … …  
    259253      INTEGER  :: ji, jj, jk, jn   ! dummy loop indices 
    260254      REAL(wp) :: ztra, zbtr, zdir, zdx, zdt, zmsk   ! local scalars 
    261       REAL(wp), POINTER, DIMENSION(:,:,:) :: zfu, zfc, zfd 
     255      REAL(wp), POINTER, DIMENSION(:,:,:) :: zwy, zfu, zfc, zfd 
    262256      !---------------------------------------------------------------------- 
    263257      ! 
    264       CALL wrk_alloc( jpi, jpj, jpk, zfu, zfc, zfd ) 
     258      CALL wrk_alloc( jpi, jpj, jpk, zwy, zfu, zfc, zfd ) 
    265259      ! 
    266260      !                                                          ! =========== 
    … …  
    359353         END DO 
    360354         !                                 ! trend diagnostics (contribution of upstream fluxes) 
    361          IF( l_trd )  CALL trd_tra( kt, cdtype, jn, jptra_trd_yad, zwy, pvn, ptn(:,:,:,jn) ) 
     355         IF( l_trd )   CALL trd_tra( kt, cdtype, jn, jptra_yad, zwy, pvn, ptn(:,:,:,jn) ) 
    362356         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    363          IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN   
    364            IF( jn == jp_tem )  htr_adv(:) = ptr_vj( zwy(:,:,:) ) 
    365            IF( jn == jp_sal )  str_adv(:) = ptr_vj( zwy(:,:,:) ) 
     357         IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
     358           IF( jn == jp_tem )  htr_adv(:) = ptr_sj( zwy(:,:,:) ) 
     359           IF( jn == jp_sal )  str_adv(:) = ptr_sj( zwy(:,:,:) ) 
    366360         ENDIF 
    367361         ! 
    368362      END DO 
    369363      ! 
    370       CALL wrk_dealloc( jpi, jpj, jpk, zfu, zfc, zfd ) 
     364      CALL wrk_dealloc( jpi, jpj, jpk, zwy, zfu, zfc, zfd ) 
    371365      ! 
    372366   END SUBROUTINE tra_adv_qck_j 
    … …  
    378372      !! 
    379373      !!---------------------------------------------------------------------- 
    380       USE oce, ONLY:   zwz => ua   ! ua used as workspace 
    381       ! 
    382374      INTEGER                              , INTENT(in   ) ::   kt       ! ocean time-step index 
    383375      CHARACTER(len=3)                     , INTENT(in   ) ::   cdtype   ! =TRA or TRC (tracer indicator) 
    … …  
    389381      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    390382      REAL(wp) ::   zbtr , ztra      ! local scalars 
    391       !!---------------------------------------------------------------------- 
    392  
     383      REAL(wp), POINTER, DIMENSION(:,:,:) :: zwz 
     384      !!---------------------------------------------------------------------- 
     385      ! 
     386      CALL wrk_alloc( jpi, jpj, jpk, zwz ) 
    393387      !                                                          ! =========== 
    394388      DO jn = 1, kjpt                                            ! tracer loop 
    … …  
    422416         END DO 
    423417         !                                 ! Save the vertical advective trends for diagnostic 
    424          IF( l_trd )  CALL trd_tra( kt, cdtype, jn, jptra_trd_zad, zwz, pwn, ptn(:,:,:,jn) ) 
     418         IF( l_trd )  CALL trd_tra( kt, cdtype, jn, jptra_zad, zwz, pwn, ptn(:,:,:,jn) ) 
    425419         ! 
    426420      END DO 
     421      ! 
     422      CALL wrk_dealloc( jpi, jpj, jpk, zwz ) 
    427423      ! 
    428424   END SUBROUTINE tra_adv_cen2_k 

  • branches/2014/dev_r4650_UKMO14.5_SST_BIAS_CORRECTION/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_tvd.F90

    r4499 r5965  
    2222   USE oce            ! ocean dynamics and active tracers 
    2323   USE dom_oce        ! ocean space and time domain 
    24    USE trdmod_oce     ! tracers trends 
     24   USE trc_oce        ! share passive tracers/Ocean variables 
     25   USE trd_oce        ! trends: ocean variables 
    2526   USE trdtra         ! tracers trends 
    26    USE in_out_manager ! I/O manager 
    2727   USE dynspg_oce     ! choice/control of key cpp for surface pressure gradient 
     28   USE diaptr         ! poleward transport diagnostics 
     29   ! 
    2830   USE lib_mpp        ! MPP library 
    2931   USE lbclnk         ! ocean lateral boundary condition (or mpp link)  
    30    USE diaptr         ! poleward transport diagnostics 
    31    USE trc_oce        ! share passive tracers/Ocean variables 
     32   USE in_out_manager ! I/O manager 
    3233   USE wrk_nemo       ! Memory Allocation 
    3334   USE timing         ! Timing 
    … …  
    3738   PRIVATE 
    3839 
    39    PUBLIC   tra_adv_tvd    ! routine called by step.F90 
     40   PUBLIC   tra_adv_tvd        ! routine called by traadv.F90 
     41   PUBLIC   tra_adv_tvd_zts    ! routine called by traadv.F90 
    4042 
    4143   LOGICAL ::   l_trd   ! flag to compute trends 
    … …  
    7779      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta             ! tracer trend  
    7880      ! 
    79       INTEGER  ::   ji, jj, jk, jn           ! dummy loop indices   
     81      INTEGER  ::   ji, jj, jk, jn           ! dummy loop indices 
     82      INTEGER  ::   ik   
    8083      REAL(wp) ::   z2dtt, zbtr, ztra        ! local scalar 
    8184      REAL(wp) ::   zfp_ui, zfp_vj, zfp_wk   !   -      - 
    … …  
    9396         IF(lwp) WRITE(numout,*) 'tra_adv_tvd : TVD advection scheme on ', cdtype 
    9497         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 
     98         ! 
     99         l_trd = .FALSE. 
     100         IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 
    95101      ENDIF 
    96       ! 
    97       l_trd = .FALSE. 
    98       IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 
    99102      ! 
    100103      IF( l_trd )  THEN 
    … …  
    103106      ENDIF 
    104107      ! 
    105       zwi(:,:,:) = 0.e0 
     108      zwi(:,:,:) = 0.e0 ;  
    106109      ! 
    107110      !                                                          ! =========== 
    108111      DO jn = 1, kjpt                                            ! tracer loop 
    109112         !                                                       ! =========== 
    110          ! 1. Bottom value : flux set to zero 
     113         ! 1. Bottom and k=1 value : flux set to zero 
    111114         ! ---------------------------------- 
    112115         zwx(:,:,jpk) = 0.e0    ;    zwz(:,:,jpk) = 0.e0 
    113116         zwy(:,:,jpk) = 0.e0    ;    zwi(:,:,jpk) = 0.e0 
    114  
     117           
     118         zwz(:,:,1  ) = 0._wp 
    115119         ! 2. upstream advection with initial mass fluxes & intermediate update 
    116120         ! -------------------------------------------------------------------- 
    … …  
    131135 
    132136         ! upstream tracer flux in the k direction 
    133          ! Surface value 
    134          IF( lk_vvl ) THEN   ;   zwz(:,:, 1 ) = 0.e0                         ! volume variable 
    135          ELSE                ;   zwz(:,:, 1 ) = pwn(:,:,1) * ptb(:,:,1,jn)   ! linear free surface  
    136          ENDIF 
    137137         ! Interior value 
    138138         DO jk = 2, jpkm1 
    … …  
    141141                  zfp_wk = pwn(ji,jj,jk) + ABS( pwn(ji,jj,jk) ) 
    142142                  zfm_wk = pwn(ji,jj,jk) - ABS( pwn(ji,jj,jk) ) 
    143                   zwz(ji,jj,jk) = 0.5 * ( zfp_wk * ptb(ji,jj,jk,jn) + zfm_wk * ptb(ji,jj,jk-1,jn) ) 
    144                END DO 
    145             END DO 
    146          END DO 
     143                  zwz(ji,jj,jk) = 0.5 * ( zfp_wk * ptb(ji,jj,jk,jn) + zfm_wk * ptb(ji,jj,jk-1,jn) ) * wmask(ji,jj,jk) 
     144               END DO 
     145            END DO 
     146         END DO 
     147         ! Surface value 
     148         IF( lk_vvl ) THEN    
     149            IF ( ln_isfcav ) THEN 
     150               DO jj = 1, jpj 
     151                  DO ji = 1, jpi 
     152                     zwz(ji,jj, mikt(ji,jj) ) = 0.e0          ! volume variable 
     153                  END DO 
     154               END DO 
     155            ELSE 
     156               zwz(:,:,1) = 0.e0          ! volume variable 
     157            END IF 
     158         ELSE                 
     159            IF ( ln_isfcav ) THEN 
     160               DO jj = 1, jpj 
     161                  DO ji = 1, jpi 
     162                     zwz(ji,jj, mikt(ji,jj) ) = pwn(ji,jj,mikt(ji,jj)) * ptb(ji,jj,mikt(ji,jj),jn)   ! linear free surface  
     163                  END DO 
     164               END DO    
     165            ELSE 
     166               zwz(:,:,1) = pwn(:,:,1) * ptb(:,:,1,jn)   ! linear free surface 
     167            END IF 
     168         ENDIF 
    147169 
    148170         ! total advective trend 
    … …  
    157179                     &             + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) 
    158180                  ! update and guess with monotonic sheme 
    159                   pta(ji,jj,jk,jn) =   pta(ji,jj,jk,jn)         + ztra 
     181                  pta(ji,jj,jk,jn) =   pta(ji,jj,jk,jn)         + ztra   * tmask(ji,jj,jk) 
    160182                  zwi(ji,jj,jk)    = ( ptb(ji,jj,jk,jn) + z2dtt * ztra ) * tmask(ji,jj,jk) 
    161183               END DO 
    … …  
    171193         END IF 
    172194         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    173          IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN   
    174            IF( jn == jp_tem )  htr_adv(:) = ptr_vj( zwy(:,:,:) ) 
    175            IF( jn == jp_sal )  str_adv(:) = ptr_vj( zwy(:,:,:) ) 
     195         IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
     196           IF( jn == jp_tem )  htr_adv(:) = ptr_sj( zwy(:,:,:) ) 
     197           IF( jn == jp_sal )  str_adv(:) = ptr_sj( zwy(:,:,:) ) 
    176198         ENDIF 
    177199 
    … …  
    189211       
    190212         ! antidiffusive flux on k 
    191          zwz(:,:,1) = 0.e0         ! Surface value 
    192          ! 
    193          DO jk = 2, jpkm1          ! Interior value 
     213         ! Interior value 
     214         DO jk = 2, jpkm1                     
    194215            DO jj = 1, jpj 
    195216               DO ji = 1, jpi 
    196217                  zwz(ji,jj,jk) = 0.5 * pwn(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji,jj,jk-1,jn) ) - zwz(ji,jj,jk) 
     218               END DO 
     219            END DO 
     220         END DO 
     221         ! surface value 
     222         IF ( ln_isfcav ) THEN 
     223            DO jj = 1, jpj 
     224               DO ji = 1, jpi 
     225                  zwz(ji,jj,mikt(ji,jj)) = 0.e0 
     226               END DO 
     227            END DO 
     228         ELSE 
     229            zwz(:,:,1) = 0.e0 
     230         END IF 
     231         CALL lbc_lnk( zwx, 'U', -1. )   ;   CALL lbc_lnk( zwy, 'V', -1. )         ! Lateral bondary conditions 
     232         CALL lbc_lnk( zwz, 'W',  1. ) 
     233 
     234         ! 4. monotonicity algorithm 
     235         ! ------------------------- 
     236         CALL nonosc( ptb(:,:,:,jn), zwx, zwy, zwz, zwi, p2dt ) 
     237 
     238 
     239         ! 5. final trend with corrected fluxes 
     240         ! ------------------------------------ 
     241         DO jk = 1, jpkm1 
     242            DO jj = 2, jpjm1 
     243               DO ji = fs_2, fs_jpim1   ! vector opt.   
     244                  zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
     245                  ! total advective trends 
     246                  ztra = - zbtr * (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
     247                     &             + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   & 
     248                     &             + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) 
     249                  ! add them to the general tracer trends 
     250                  pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra * tmask(ji,jj,jk) 
     251               END DO 
     252            END DO 
     253         END DO 
     254 
     255         !                                 ! trend diagnostics (contribution of upstream fluxes) 
     256         IF( l_trd )  THEN  
     257            ztrdx(:,:,:) = ztrdx(:,:,:) + zwx(:,:,:)  ! <<< Add to previously computed 
     258            ztrdy(:,:,:) = ztrdy(:,:,:) + zwy(:,:,:)  ! <<< Add to previously computed 
     259            ztrdz(:,:,:) = ztrdz(:,:,:) + zwz(:,:,:)  ! <<< Add to previously computed 
     260             
     261            CALL trd_tra( kt, cdtype, jn, jptra_xad, ztrdx, pun, ptn(:,:,:,jn) )    
     262            CALL trd_tra( kt, cdtype, jn, jptra_yad, ztrdy, pvn, ptn(:,:,:,jn) )   
     263            CALL trd_tra( kt, cdtype, jn, jptra_zad, ztrdz, pwn, ptn(:,:,:,jn) )  
     264         END IF 
     265         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
     266         IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
     267           IF( jn == jp_tem )  htr_adv(:) = ptr_sj( zwy(:,:,:) ) + htr_adv(:) 
     268           IF( jn == jp_sal )  str_adv(:) = ptr_sj( zwy(:,:,:) ) + str_adv(:) 
     269         ENDIF 
     270         ! 
     271      END DO 
     272      ! 
     273                   CALL wrk_dealloc( jpi, jpj, jpk, zwi, zwz ) 
     274      IF( l_trd )  CALL wrk_dealloc( jpi, jpj, jpk, ztrdx, ztrdy, ztrdz ) 
     275      ! 
     276      IF( nn_timing == 1 )  CALL timing_stop('tra_adv_tvd') 
     277      ! 
     278   END SUBROUTINE tra_adv_tvd 
     279 
     280   SUBROUTINE tra_adv_tvd_zts ( kt, kit000, cdtype, p2dt, pun, pvn, pwn,      & 
     281      &                                       ptb, ptn, pta, kjpt ) 
     282      !!---------------------------------------------------------------------- 
     283      !!                  ***  ROUTINE tra_adv_tvd_zts  *** 
     284      !!  
     285      !! **  Purpose :   Compute the now trend due to total advection of  
     286      !!       tracers and add it to the general trend of tracer equations 
     287      !! 
     288      !! **  Method  :   TVD ZTS scheme, i.e. 2nd order centered scheme with 
     289      !!       corrected flux (monotonic correction). This version use sub- 
     290      !!       timestepping for the vertical advection which increases stability 
     291      !!       when vertical metrics are small. 
     292      !!       note: - this advection scheme needs a leap-frog time scheme 
     293      !! 
     294      !! ** Action : - update (pta) with the now advective tracer trends 
     295      !!             - save the trends  
     296      !!---------------------------------------------------------------------- 
     297      USE oce     , ONLY:   zwx => ua        , zwy => va          ! (ua,va) used as workspace 
     298      ! 
     299      INTEGER                              , INTENT(in   ) ::   kt              ! ocean time-step index 
     300      INTEGER                              , INTENT(in   ) ::   kit000          ! first time step index 
     301      CHARACTER(len=3)                     , INTENT(in   ) ::   cdtype          ! =TRA or TRC (tracer indicator) 
     302      INTEGER                              , INTENT(in   ) ::   kjpt            ! number of tracers 
     303      REAL(wp), DIMENSION(        jpk     ), INTENT(in   ) ::   p2dt            ! vertical profile of tracer time-step 
     304      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pun, pvn, pwn   ! 3 ocean velocity components 
     305      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb, ptn        ! before and now tracer fields 
     306      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta             ! tracer trend  
     307      ! 
     308      REAL(wp), DIMENSION( jpk )                           ::   zts             ! length of sub-timestep for vertical advection 
     309      REAL(wp), DIMENSION( jpk )                           ::   zr_p2dt         ! reciprocal of tracer timestep 
     310      INTEGER  ::   ji, jj, jk, jl, jn       ! dummy loop indices   
     311      INTEGER  ::   jnzts = 5       ! number of sub-timesteps for vertical advection 
     312      INTEGER  ::   jtb, jtn, jta   ! sub timestep pointers for leap-frog/euler forward steps 
     313      INTEGER  ::   jtaken          ! toggle for collecting appropriate fluxes from sub timesteps 
     314      REAL(wp) ::   z_rzts          ! Fractional length of Euler forward sub-timestep for vertical advection 
     315      REAL(wp) ::   z2dtt, zbtr, ztra        ! local scalar 
     316      REAL(wp) ::   zfp_ui, zfp_vj, zfp_wk   !   -      - 
     317      REAL(wp) ::   zfm_ui, zfm_vj, zfm_wk   !   -      - 
     318      REAL(wp), POINTER, DIMENSION(:,:  ) :: zwx_sav , zwy_sav 
     319      REAL(wp), POINTER, DIMENSION(:,:,:) :: zwi, zwz, zhdiv, zwz_sav, zwzts 
     320      REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdx, ztrdy, ztrdz 
     321      REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztrs 
     322      !!---------------------------------------------------------------------- 
     323      ! 
     324      IF( nn_timing == 1 )  CALL timing_start('tra_adv_tvd_zts') 
     325      ! 
     326      CALL wrk_alloc( jpi, jpj, zwx_sav, zwy_sav ) 
     327      CALL wrk_alloc( jpi, jpj, jpk, zwi, zwz , zhdiv, zwz_sav, zwzts ) 
     328      CALL wrk_alloc( jpi, jpj, jpk, 3, ztrs ) 
     329      ! 
     330      IF( kt == kit000 )  THEN 
     331         IF(lwp) WRITE(numout,*) 
     332         IF(lwp) WRITE(numout,*) 'tra_adv_tvd_zts : TVD ZTS advection scheme on ', cdtype 
     333         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 
     334      ENDIF 
     335      ! 
     336      l_trd = .FALSE. 
     337      IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 
     338      ! 
     339      IF( l_trd )  THEN 
     340         CALL wrk_alloc( jpi, jpj, jpk, ztrdx, ztrdy, ztrdz ) 
     341         ztrdx(:,:,:) = 0._wp  ;    ztrdy(:,:,:) = 0._wp  ;   ztrdz(:,:,:) = 0._wp 
     342      ENDIF 
     343      ! 
     344      zwi(:,:,:) = 0._wp 
     345      z_rzts = 1._wp / REAL( jnzts, wp ) 
     346      zr_p2dt(:) = 1._wp / p2dt(:) 
     347      ! 
     348      !                                                          ! =========== 
     349      DO jn = 1, kjpt                                            ! tracer loop 
     350         !                                                       ! =========== 
     351         ! 1. Bottom value : flux set to zero 
     352         ! ---------------------------------- 
     353         zwx(:,:,jpk) = 0._wp   ;    zwz(:,:,jpk) = 0._wp 
     354         zwy(:,:,jpk) = 0._wp   ;    zwi(:,:,jpk) = 0._wp 
     355 
     356         ! 2. upstream advection with initial mass fluxes & intermediate update 
     357         ! -------------------------------------------------------------------- 
     358         ! upstream tracer flux in the i and j direction 
     359         DO jk = 1, jpkm1 
     360            DO jj = 1, jpjm1 
     361               DO ji = 1, fs_jpim1   ! vector opt. 
     362                  ! upstream scheme 
     363                  zfp_ui = pun(ji,jj,jk) + ABS( pun(ji,jj,jk) ) 
     364                  zfm_ui = pun(ji,jj,jk) - ABS( pun(ji,jj,jk) ) 
     365                  zfp_vj = pvn(ji,jj,jk) + ABS( pvn(ji,jj,jk) ) 
     366                  zfm_vj = pvn(ji,jj,jk) - ABS( pvn(ji,jj,jk) ) 
     367                  zwx(ji,jj,jk) = 0.5_wp * ( zfp_ui * ptb(ji,jj,jk,jn) + zfm_ui * ptb(ji+1,jj  ,jk,jn) ) 
     368                  zwy(ji,jj,jk) = 0.5_wp * ( zfp_vj * ptb(ji,jj,jk,jn) + zfm_vj * ptb(ji  ,jj+1,jk,jn) ) 
     369               END DO 
     370            END DO 
     371         END DO 
     372 
     373         ! upstream tracer flux in the k direction 
     374         ! Interior value 
     375         DO jk = 2, jpkm1 
     376            DO jj = 1, jpj 
     377               DO ji = 1, jpi 
     378                  zfp_wk = pwn(ji,jj,jk) + ABS( pwn(ji,jj,jk) ) 
     379                  zfm_wk = pwn(ji,jj,jk) - ABS( pwn(ji,jj,jk) ) 
     380                  zwz(ji,jj,jk) = 0.5_wp * ( zfp_wk * ptb(ji,jj,jk,jn) + zfm_wk * ptb(ji,jj,jk-1,jn) ) 
     381               END DO 
     382            END DO 
     383         END DO 
     384         ! Surface value 
     385         IF( lk_vvl ) THEN 
     386            IF ( ln_isfcav ) THEN 
     387               DO jj = 1, jpj 
     388                  DO ji = 1, jpi 
     389                     zwz(ji,jj, mikt(ji,jj) ) = 0.e0          ! volume variable +    isf 
     390                  END DO 
     391               END DO 
     392            ELSE 
     393               zwz(:,:,1) = 0.e0                              ! volume variable + no isf 
     394            END IF 
     395         ELSE 
     396            IF ( ln_isfcav ) THEN 
     397               DO jj = 1, jpj 
     398                  DO ji = 1, jpi 
     399                     zwz(ji,jj, mikt(ji,jj) ) = pwn(ji,jj,mikt(ji,jj)) * ptb(ji,jj,mikt(ji,jj),jn)   ! linear free surface +    isf 
     400                  END DO 
     401               END DO 
     402            ELSE 
     403               zwz(:,:,1) = pwn(:,:,1) * ptb(:,:,1,jn)                                               ! linear free surface + no isf 
     404            END IF 
     405         ENDIF 
     406 
     407         ! total advective trend 
     408         DO jk = 1, jpkm1 
     409            z2dtt = p2dt(jk) 
     410            DO jj = 2, jpjm1 
     411               DO ji = fs_2, fs_jpim1   ! vector opt. 
     412                  zbtr = 1._wp / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
     413                  ! total intermediate advective trends 
     414                  ztra = - zbtr * (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
     415                     &             + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   & 
     416                     &             + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) 
     417                  ! update and guess with monotonic sheme 
     418                  pta(ji,jj,jk,jn) =   pta(ji,jj,jk,jn)         + ztra 
     419                  zwi(ji,jj,jk)    = ( ptb(ji,jj,jk,jn) + z2dtt * ztra ) * tmask(ji,jj,jk) 
     420               END DO 
     421            END DO 
     422         END DO 
     423         !                             ! Lateral boundary conditions on zwi  (unchanged sign) 
     424         CALL lbc_lnk( zwi, 'T', 1. )   
     425 
     426         !                                 ! trend diagnostics (contribution of upstream fluxes) 
     427         IF( l_trd )  THEN  
     428            ! store intermediate advective trends 
     429            ztrdx(:,:,:) = zwx(:,:,:)   ;    ztrdy(:,:,:) = zwy(:,:,:)  ;   ztrdz(:,:,:) = zwz(:,:,:) 
     430         END IF 
     431         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
     432         IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
     433           IF( jn == jp_tem )  htr_adv(:) = ptr_sj( zwy(:,:,:) ) 
     434           IF( jn == jp_sal )  str_adv(:) = ptr_sj( zwy(:,:,:) ) 
     435         ENDIF 
     436 
     437         ! 3. antidiffusive flux : high order minus low order 
     438         ! -------------------------------------------------- 
     439         ! antidiffusive flux on i and j 
     440 
     441 
     442         DO jk = 1, jpkm1 
     443 
     444            DO jj = 1, jpjm1 
     445               DO ji = 1, fs_jpim1   ! vector opt. 
     446                  zwx_sav(ji,jj) = zwx(ji,jj,jk) 
     447                  zwy_sav(ji,jj) = zwy(ji,jj,jk) 
     448 
     449                  zwx(ji,jj,jk) = 0.5_wp * pun(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji+1,jj,jk,jn) ) 
     450                  zwy(ji,jj,jk) = 0.5_wp * pvn(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji,jj+1,jk,jn) ) 
     451               END DO 
     452            END DO 
     453 
     454            DO jj = 2, jpjm1         ! partial horizontal divergence 
     455               DO ji = fs_2, fs_jpim1 
     456                  zhdiv(ji,jj,jk) = (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk)   & 
     457                     &               + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk)  ) 
     458               END DO 
     459            END DO 
     460 
     461            DO jj = 1, jpjm1 
     462               DO ji = 1, fs_jpim1   ! vector opt. 
     463                  zwx(ji,jj,jk) = zwx(ji,jj,jk)  - zwx_sav(ji,jj) 
     464                  zwy(ji,jj,jk) = zwy(ji,jj,jk)  - zwy_sav(ji,jj) 
     465               END DO 
     466            END DO 
     467         END DO 
     468       
     469         ! antidiffusive flux on k 
     470         zwz(:,:,1) = 0._wp        ! Surface value 
     471         zwz_sav(:,:,:) = zwz(:,:,:) 
     472         ! 
     473         ztrs(:,:,:,1) = ptb(:,:,:,jn) 
     474         zwzts(:,:,:) = 0._wp 
     475 
     476         DO jl = 1, jnzts                   ! Start of sub timestepping loop 
     477 
     478            IF( jl == 1 ) THEN              ! Euler forward to kick things off 
     479              jtb = 1   ;   jtn = 1   ;   jta = 2 
     480              zts(:) = p2dt(:) * z_rzts 
     481              jtaken = MOD( jnzts + 1 , 2)  ! Toggle to collect every second flux 
     482                                            ! starting at jl =1 if jnzts is odd;  
     483                                            ! starting at jl =2 otherwise 
     484            ELSEIF( jl == 2 ) THEN          ! First leapfrog step 
     485              jtb = 1   ;   jtn = 2   ;   jta = 3 
     486              zts(:) = 2._wp * p2dt(:) * z_rzts 
     487            ELSE                            ! Shuffle pointers for subsequent leapfrog steps 
     488              jtb = MOD(jtb,3) + 1 
     489              jtn = MOD(jtn,3) + 1 
     490              jta = MOD(jta,3) + 1 
     491            ENDIF 
     492            DO jk = 2, jpkm1          ! Interior value 
     493               DO jj = 2, jpjm1 
     494                  DO ji = fs_2, fs_jpim1 
     495                     zwz(ji,jj,jk) = 0.5_wp * pwn(ji,jj,jk) * ( ztrs(ji,jj,jk,jtn) + ztrs(ji,jj,jk-1,jtn) ) 
     496                     IF( jtaken == 0 ) zwzts(ji,jj,jk) = zwzts(ji,jj,jk) + zwz(ji,jj,jk)*zts(jk)           ! Accumulate time-weighted vertcal flux 
     497                  END DO 
     498               END DO 
     499            END DO 
     500 
     501            jtaken = MOD( jtaken + 1 , 2 ) 
     502 
     503            DO jk = 2, jpkm1          ! Interior value 
     504               DO jj = 2, jpjm1 
     505                  DO ji = fs_2, fs_jpim1 
     506                     zbtr = 1._wp / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
     507                     ! total advective trends 
     508                     ztra = - zbtr * (  zhdiv(ji,jj,jk) + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) 
     509                     ztrs(ji,jj,jk,jta) = ztrs(ji,jj,jk,jtb) + zts(jk) * ztra 
     510                  END DO 
     511               END DO 
     512            END DO 
     513 
     514         END DO 
     515 
     516         DO jk = 2, jpkm1          ! Anti-diffusive vertical flux using average flux from the sub-timestepping 
     517            DO jj = 2, jpjm1 
     518               DO ji = fs_2, fs_jpim1 
     519                  zwz(ji,jj,jk) = zwzts(ji,jj,jk) * zr_p2dt(jk) - zwz_sav(ji,jj,jk) 
    197520               END DO 
    198521            END DO 
    … …  
    228551            ztrdz(:,:,:) = ztrdz(:,:,:) + zwz(:,:,:)  ! <<< Add to previously computed 
    229552             
    230             CALL trd_tra( kt, cdtype, jn, jptra_trd_xad, ztrdx, pun, ptn(:,:,:,jn) )    
    231             CALL trd_tra( kt, cdtype, jn, jptra_trd_yad, ztrdy, pvn, ptn(:,:,:,jn) )   
    232             CALL trd_tra( kt, cdtype, jn, jptra_trd_zad, ztrdz, pwn, ptn(:,:,:,jn) )  
     553            CALL trd_tra( kt, cdtype, jn, jptra_xad, ztrdx, pun, ptn(:,:,:,jn) )    
     554            CALL trd_tra( kt, cdtype, jn, jptra_yad, ztrdy, pvn, ptn(:,:,:,jn) )   
     555            CALL trd_tra( kt, cdtype, jn, jptra_zad, ztrdz, pwn, ptn(:,:,:,jn) )  
    233556         END IF 
    234557         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    235          IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN   
    236            IF( jn == jp_tem )  htr_adv(:) = ptr_vj( zwy(:,:,:) ) + htr_adv(:) 
    237            IF( jn == jp_sal )  str_adv(:) = ptr_vj( zwy(:,:,:) ) + str_adv(:) 
     558         IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
     559           IF( jn == jp_tem )  htr_adv(:) = ptr_sj( zwy(:,:,:) ) + htr_adv(:) 
     560           IF( jn == jp_sal )  str_adv(:) = ptr_sj( zwy(:,:,:) ) + str_adv(:) 
    238561         ENDIF 
    239562         ! 
    240563      END DO 
    241564      ! 
    242                    CALL wrk_dealloc( jpi, jpj, jpk, zwi, zwz ) 
     565                   CALL wrk_dealloc( jpi, jpj, jpk, zwi, zwz, zhdiv, zwz_sav, zwzts ) 
     566                   CALL wrk_dealloc( jpi, jpj, jpk, 3, ztrs ) 
     567                   CALL wrk_dealloc( jpi, jpj, zwx_sav, zwy_sav ) 
    243568      IF( l_trd )  CALL wrk_dealloc( jpi, jpj, jpk, ztrdx, ztrdy, ztrdz ) 
    244569      ! 
    245       IF( nn_timing == 1 )  CALL timing_stop('tra_adv_tvd') 
    246       ! 
    247    END SUBROUTINE tra_adv_tvd 
    248  
     570      IF( nn_timing == 1 )  CALL timing_stop('tra_adv_tvd_zts') 
     571      ! 
     572   END SUBROUTINE tra_adv_tvd_zts 
    249573 
    250574   SUBROUTINE nonosc( pbef, paa, pbb, pcc, paft, p2dt ) 
    … …  
    261585      !!       in-space based differencing for fluid 
    262586      !!---------------------------------------------------------------------- 
    263       ! 
    264       !!---------------------------------------------------------------------- 
    265587      REAL(wp), DIMENSION(jpk)         , INTENT(in   ) ::   p2dt            ! vertical profile of tracer time-step 
    266588      REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   pbef, paft      ! before & after field 
    267589      REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(inout) ::   paa, pbb, pcc   ! monotonic fluxes in the 3 directions 
    268590      ! 
    269       INTEGER ::   ji, jj, jk   ! dummy loop indices 
    270       INTEGER ::   ikm1         ! local integer 
     591      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
     592      INTEGER  ::   ikm1         ! local integer 
    271593      REAL(wp) ::   zpos, zneg, zbt, za, zb, zc, zbig, zrtrn, z2dtt   ! local scalars 
    272594      REAL(wp) ::   zau, zbu, zcu, zav, zbv, zcv, zup, zdo            !   -      - 
    … …  
    278600      CALL wrk_alloc( jpi, jpj, jpk, zbetup, zbetdo, zbup, zbdo ) 
    279601      ! 
    280  
    281602      zbig  = 1.e+40_wp 
    282603      zrtrn = 1.e-15_wp 
    283       zbetup(:,:,jpk) = 0._wp   ;   zbetdo(:,:,jpk) = 0._wp 
    284  
     604      zbetup(:,:,:) = 0._wp   ;   zbetdo(:,:,:) = 0._wp 
    285605 
    286606      ! Search local extrema 
    287607      ! -------------------- 
    288608      ! max/min of pbef & paft with large negative/positive value (-/+zbig) inside land 
    289       zbup = MAX( pbef * tmask - zbig * ( 1.e0 - tmask ),   & 
    290          &        paft * tmask - zbig * ( 1.e0 - tmask )  ) 
    291       zbdo = MIN( pbef * tmask + zbig * ( 1.e0 - tmask ),   & 
    292          &        paft * tmask + zbig * ( 1.e0 - tmask )  ) 
     609      zbup = MAX( pbef * tmask - zbig * ( 1._wp - tmask ),   & 
     610         &        paft * tmask - zbig * ( 1._wp - tmask )  ) 
     611      zbdo = MIN( pbef * tmask + zbig * ( 1._wp - tmask ),   & 
     612         &        paft * tmask + zbig * ( 1._wp - tmask )  ) 
    293613 
    294614      DO jk = 1, jpkm1 
    … …  
    334654         DO jj = 2, jpjm1 
    335655            DO ji = fs_2, fs_jpim1   ! vector opt. 
    336                zau = MIN( 1.e0, zbetdo(ji,jj,jk), zbetup(ji+1,jj,jk) ) 
    337                zbu = MIN( 1.e0, zbetup(ji,jj,jk), zbetdo(ji+1,jj,jk) ) 
     656               zau = MIN( 1._wp, zbetdo(ji,jj,jk), zbetup(ji+1,jj,jk) ) 
     657               zbu = MIN( 1._wp, zbetup(ji,jj,jk), zbetdo(ji+1,jj,jk) ) 
    338658               zcu =       ( 0.5  + SIGN( 0.5 , paa(ji,jj,jk) ) ) 
    339                paa(ji,jj,jk) = paa(ji,jj,jk) * ( zcu * zau + ( 1.e0 - zcu) * zbu ) 
    340  
    341                zav = MIN( 1.e0, zbetdo(ji,jj,jk), zbetup(ji,jj+1,jk) ) 
    342                zbv = MIN( 1.e0, zbetup(ji,jj,jk), zbetdo(ji,jj+1,jk) ) 
     659               paa(ji,jj,jk) = paa(ji,jj,jk) * ( zcu * zau + ( 1._wp - zcu) * zbu ) 
     660 
     661               zav = MIN( 1._wp, zbetdo(ji,jj,jk), zbetup(ji,jj+1,jk) ) 
     662               zbv = MIN( 1._wp, zbetup(ji,jj,jk), zbetdo(ji,jj+1,jk) ) 
    343663               zcv =       ( 0.5  + SIGN( 0.5 , pbb(ji,jj,jk) ) ) 
    344                pbb(ji,jj,jk) = pbb(ji,jj,jk) * ( zcv * zav + ( 1.e0 - zcv) * zbv ) 
     664               pbb(ji,jj,jk) = pbb(ji,jj,jk) * ( zcv * zav + ( 1._wp - zcv) * zbv ) 
    345665 
    346666      ! monotonic flux in the k direction, i.e. pcc 
    … …  
    349669               zb = MIN( 1., zbetup(ji,jj,jk+1), zbetdo(ji,jj,jk) ) 
    350670               zc =       ( 0.5  + SIGN( 0.5 , pcc(ji,jj,jk+1) ) ) 
    351                pcc(ji,jj,jk+1) = pcc(ji,jj,jk+1) * ( zc * za + ( 1.e0 - zc) * zb ) 
     671               pcc(ji,jj,jk+1) = pcc(ji,jj,jk+1) * ( zc * za + ( 1._wp - zc) * zb ) 
    352672            END DO 
    353673         END DO 

  • branches/2014/dev_r4650_UKMO14.5_SST_BIAS_CORRECTION/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_ubs.F90

    r4499 r5965  
    1414   USE oce            ! ocean dynamics and active tracers 
    1515   USE dom_oce        ! ocean space and time domain 
    16    USE trdmod_oce     ! ocean space and time domain 
    17    USE trdtra 
    18    USE lib_mpp 
     16   USE trc_oce        ! share passive tracers/Ocean variables 
     17   USE trd_oce        ! trends: ocean variables 
     18   USE trdtra         ! trends manager: tracers  
     19   USE dynspg_oce     ! choice/control of key cpp for surface pressure gradient 
     20   USE diaptr         ! poleward transport diagnostics 
     21   ! 
     22   USE lib_mpp        ! I/O library 
    1923   USE lbclnk         ! ocean lateral boundary condition (or mpp link) 
    2024   USE in_out_manager ! I/O manager 
    21    USE diaptr         ! poleward transport diagnostics 
    22    USE dynspg_oce     ! choice/control of key cpp for surface pressure gradient 
    23    USE trc_oce        ! share passive tracers/Ocean variables 
    2425   USE wrk_nemo       ! Memory Allocation 
    2526   USE timing         ! Timing 
    … …  
    5152      !!      and add it to the general trend of passive tracer equations. 
    5253      !! 
    53       !! ** Method  :   The upstream biased 3rd order scheme (UBS) is based on an 
     54      !! ** Method  :   The upstream biased scheme (UBS) is based on a 3rd order 
    5455      !!      upstream-biased parabolic interpolation (Shchepetkin and McWilliams 2005) 
    5556      !!      It is only used in the horizontal direction. 
    5657      !!      For example the i-component of the advective fluxes are given by : 
    5758      !!                !  e2u e3u un ( mi(Tn) - zltu(i  ) )   if un(i) >= 0 
    58       !!          zwx = !  or  
     59      !!          ztu = !  or  
    5960      !!                !  e2u e3u un ( mi(Tn) - zltu(i+1) )   if un(i) < 0 
    6061      !!      where zltu is the second derivative of the before temperature field: 
    … …  
    7677      !!             Farrow, D.E., Stevens, D.P., 1995, J. Phys. Ocean. 25, 1731Ð1741.  
    7778      !!---------------------------------------------------------------------- 
    78       USE oce     , ONLY:   zwx  => ua       , zwy  => va         ! (ua,va) used as workspace 
    79       ! 
    8079      INTEGER                              , INTENT(in   ) ::   kt              ! ocean time-step index 
    8180      INTEGER                              , INTENT(in   ) ::   kit000          ! first time step index 
    … …  
    9897      CALL wrk_alloc( jpi, jpj, jpk, ztu, ztv, zltu, zltv, zti, ztw ) 
    9998      ! 
    100  
    10199      IF( kt == kit000 )  THEN 
    102100         IF(lwp) WRITE(numout,*) 
    … …  
    151149                  zcenvt = pvn(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji  ,jj+1,jk,jn) ) 
    152150                  ! UBS advective fluxes 
    153                   zwx(ji,jj,jk) = 0.5 * ( zcenut - zfp_ui * zltu(ji,jj,jk) - zfm_ui * zltu(ji+1,jj,jk) ) 
    154                   zwy(ji,jj,jk) = 0.5 * ( zcenvt - zfp_vj * zltv(ji,jj,jk) - zfm_vj * zltv(ji,jj+1,jk) ) 
     151                  ztu(ji,jj,jk) = 0.5 * ( zcenut - zfp_ui * zltu(ji,jj,jk) - zfm_ui * zltu(ji+1,jj,jk) ) 
     152                  ztv(ji,jj,jk) = 0.5 * ( zcenvt - zfp_vj * zltv(ji,jj,jk) - zfm_vj * zltv(ji,jj+1,jk) ) 
    155153               END DO 
    156154            END DO 
    … …  
    159157         zltu(:,:,:) = pta(:,:,:,jn)      ! store pta trends 
    160158 
    161          ! Horizontal advective trends 
    162          DO jk = 1, jpkm1 
    163             !  Tracer flux divergence at t-point added to the general trend 
     159         DO jk = 1, jpkm1                 ! Horizontal advective trends 
    164160            DO jj = 2, jpjm1 
    165161               DO ji = fs_2, fs_jpim1   ! vector opt. 
    166                   zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    167                   ! horizontal advective 
    168                   ztra = - zbtr * (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk)   & 
    169                      &             + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk)  ) 
    170                   ! add it to the general tracer trends 
    171                   pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra 
     162                  pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn)                        & 
     163                     &             - (  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) ) 
    172165               END DO 
    173166            END DO 
    … …  
    178171         zltu(:,:,:) = pta(:,:,:,jn) - zltu(:,:,:) 
    179172 
    180          ! 3. Save the horizontal advective trends for diagnostic 
    181          ! ------------------------------------------------------ 
    182          !                                 ! trend diagnostics (contribution of upstream fluxes) 
    183          IF( l_trd ) THEN 
    184              CALL trd_tra( kt, cdtype, jn, jptra_trd_xad, zwx, pun, ptn(:,:,:,jn) ) 
    185              CALL trd_tra( kt, cdtype, jn, jptra_trd_yad, zwy, pvn, ptn(:,:,:,jn) ) 
     173         !                 
     174         IF( l_trd ) THEN                  ! trend diagnostics 
     175             CALL trd_tra( kt, cdtype, jn, jptra_xad, ztu, pun, ptn(:,:,:,jn) ) 
     176             CALL trd_tra( kt, cdtype, jn, jptra_yad, ztv, pvn, ptn(:,:,:,jn) ) 
    186177         END IF 
    187178         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    188          IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN   
    189             IF( jn == jp_tem )  htr_adv(:) = ptr_vj( zwy(:,:,:) ) 
    190             IF( jn == jp_sal )  str_adv(:) = ptr_vj( zwy(:,:,:) ) 
     179         IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
     180            IF( jn == jp_tem )  htr_adv(:) = ptr_sj( ztv(:,:,:) ) 
     181            IF( jn == jp_sal )  str_adv(:) = ptr_sj( ztv(:,:,:) ) 
    191182         ENDIF 
    192183          
    … …  
    265256               END DO 
    266257            END DO 
    267             CALL trd_tra( kt, cdtype, jn, jptra_trd_zad, zltv ) 
     258            CALL trd_tra( kt, cdtype, jn, jptra_zad, zltv ) 
    268259         ENDIF 
    269260         ! 
    270       ENDDO 
     261      END DO 
    271262      ! 
    272263      CALL wrk_dealloc( jpi, jpj, jpk, ztu, ztv, zltu, zltv, zti, ztw ) 
    … …  
    290281      !!       in-space based differencing for fluid 
    291282      !!---------------------------------------------------------------------- 
    292       ! 
    293283      REAL(wp), INTENT(in   ), DIMENSION(jpk)          ::   p2dt   ! vertical profile of tracer time-step 
    294284      REAL(wp),                DIMENSION (jpi,jpj,jpk) ::   pbef   ! before field 
    … …  
    306296      CALL wrk_alloc( jpi, jpj, jpk, zbetup, zbetdo ) 
    307297      ! 
    308  
    309298      zbig  = 1.e+40_wp 
    310299      zrtrn = 1.e-15_wp 

  • branches/2014/dev_r4650_UKMO14.5_SST_BIAS_CORRECTION/NEMOGCM/NEMO/OPA_SRC/TRA/trabbc.F90

    r4624 r5965  
    1818   USE dom_oce         ! domain: ocean 
    1919   USE phycst          ! physical constants 
    20    USE trdmod_oce      ! trends: ocean variables  
    21    USE trdtra          ! trends: active tracers  
     20   USE trd_oce         ! trends: ocean variables 
     21   USE trdtra          ! trends manager: tracers  
    2222   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 
    2327   USE prtctl          ! Print control 
    2428   USE wrk_nemo        ! Memory Allocation 
    … …  
    3741 
    3842   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) 
    3944  
    4045   !! * Substitutions 
    … …  
    4247   !!---------------------------------------------------------------------- 
    4348   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    44    !! $Id $  
     49   !! $Id$ 
    4550   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    4651   !!---------------------------------------------------------------------- 
    … …  
    8489      ! 
    8590      !                             !  Add the geothermal heat flux trend on temperature 
    86 #if defined key_vectopt_loop 
    87       DO jj = 1, 1 
    88          DO ji = jpi+2, jpij-jpi-1   ! vector opt. (forced unrolling) 
    89 #else 
    9091      DO jj = 2, jpjm1 
    9192         DO ji = 2, jpim1 
    92 #endif 
    9393            ik = mbkt(ji,jj) 
    9494            zqgh_trd = qgh_trd0(ji,jj) / fse3t(ji,jj,ik) 
    … …  
    9797      END DO 
    9898      ! 
     99      CALL lbc_lnk( tsa(:,:,:,jp_tem) , 'T', 1. ) 
     100      ! 
    99101      IF( l_trdtra ) THEN        ! Save the geothermal heat flux trend for diagnostics 
    100102         ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 
    101          CALL trd_tra( kt, 'TRA', jp_tem, jptra_trd_bbc, ztrdt ) 
     103         CALL trd_tra( kt, 'TRA', jp_tem, jptra_bbc, ztrdt ) 
    102104         CALL wrk_dealloc( jpi, jpj, jpk, ztrdt ) 
    103105      ENDIF 
    … …  
    130132      INTEGER  ::   inum                ! temporary logical unit 
    131133      INTEGER  ::   ios                 ! Local integer output status for namelist read 
    132       !! 
    133       NAMELIST/nambbc/ln_trabbc, nn_geoflx, rn_geoflx_cst  
     134      INTEGER  ::   ierror              ! local integer 
     135      ! 
     136      TYPE(FLD_N)        ::   sn_qgh    ! informations about the geotherm. field to be read 
     137      CHARACTER(len=256) ::   cn_dir    ! Root directory for location of ssr files 
     138      ! 
     139      NAMELIST/nambbc/ln_trabbc, nn_geoflx, rn_geoflx_cst, sn_qgh, cn_dir  
    134140      !!---------------------------------------------------------------------- 
    135141 
    … …  
    166172         CASE ( 2 )                          !* variable geothermal heat flux : read the geothermal fluxes in mW/m2 
    167173            IF(lwp) WRITE(numout,*) '      *** variable geothermal heat flux' 
    168             CALL iom_open ( 'geothermal_heating.nc', inum ) 
    169             CALL iom_get  ( inum, jpdom_data, 'heatflow', qgh_trd0 ) 
    170             CALL iom_close( inum ) 
    171             qgh_trd0(:,:) = r1_rau0_rcp * qgh_trd0(:,:) * 1.e-3     ! conversion in W/m2 
     174            ! 
     175            ALLOCATE( sf_qgh(1), STAT=ierror ) 
     176            IF( ierror > 0 ) THEN 
     177               CALL ctl_stop( 'tra_bbc_init: unable to allocate sf_qgh structure' )   ; 
     178               RETURN 
     179            ENDIF 
     180            ALLOCATE( sf_qgh(1)%fnow(jpi,jpj,1)   ) 
     181            IF( sn_qgh%ln_tint )ALLOCATE( sf_qgh(1)%fdta(jpi,jpj,1,2) ) 
     182            ! fill sf_chl with sn_chl and control print 
     183            CALL fld_fill( sf_qgh, (/ sn_qgh /), cn_dir, 'tra_bbc_init',   & 
     184               &          'bottom temperature boundary condition', 'nambbc' ) 
     185 
     186            CALL fld_read( nit000, 1, sf_qgh )                         ! Read qgh data 
     187            qgh_trd0(:,:) = r1_rau0_rcp * sf_qgh(1)%fnow(:,:,1) * 1.e-3 ! conversion in W/m2 
    172188            ! 
    173189         CASE DEFAULT 

  • branches/2014/dev_r4650_UKMO14.5_SST_BIAS_CORRECTION/NEMOGCM/NEMO/OPA_SRC/TRA/trabbl.F90

    r4624 r5965  
    1212   !!             -   ! 2010-06  (C. Ethe, G. Madec)  merge TRA-TRC 
    1313   !!             -   ! 2010-11  (G. Madec) add mbk. arrays associated to the deepest ocean level 
     14   !!             -   ! 2013-04  (F. Roquet, G. Madec)  use of eosbn2 instead of local hard coded alpha and beta 
    1415   !!---------------------------------------------------------------------- 
    1516#if   defined key_trabbl   ||   defined key_esopa 
    … …  
    2829   USE phycst         ! physical constant 
    2930   USE eosbn2         ! equation of state 
    30    USE trdmod_oce     ! trends: ocean variables 
     31   USE trd_oce     ! trends: ocean variables 
    3132   USE trdtra         ! trends: active tracers 
    32    USE iom            ! IOM server 
     33   ! 
     34   USE iom            ! IOM library                
    3335   USE in_out_manager ! I/O manager 
    3436   USE lbclnk         ! ocean lateral boundary conditions 
    … …  
    3638   USE wrk_nemo       ! Memory Allocation 
    3739   USE timing         ! Timing 
    38  
     40   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)   
    3941 
    4042   IMPLICIT NONE 
    … …  
    5759   REAL(wp), PUBLIC ::   rn_gambbl   !: lateral coeff. for bottom boundary layer scheme [s] 
    5860 
    59    LOGICAL , PUBLIC ::   l_bbl                  !: flag to compute bbl diffu. flux coef and transport 
     61   LOGICAL , PUBLIC ::   l_bbl       !: flag to compute bbl diffu. flux coef and transport 
    6062 
    6163   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC ::   utr_bbl  , vtr_bbl   ! u- (v-) transport in the bottom boundary layer 
    … …  
    8486         &      vtr_bbl  (jpi,jpj) , ahv_bbl  (jpi,jpj) , mbkv_d  (jpi,jpj) , mgrhv(jpi,jpj) ,     & 
    8587         &      ahu_bbl_0(jpi,jpj) , ahv_bbl_0(jpi,jpj) ,                                          & 
    86          &      e3u_bbl_0(jpi,jpj) , e3v_bbl_0(jpi,jpj) , STAT= tra_bbl_alloc                ) 
     88         &      e3u_bbl_0(jpi,jpj) , e3v_bbl_0(jpi,jpj) ,                                      STAT=tra_bbl_alloc ) 
    8789         ! 
    8890      IF( lk_mpp            )   CALL mpp_sum ( tra_bbl_alloc ) 
    … …  
    104106      !!---------------------------------------------------------------------- 
    105107      INTEGER, INTENT( in ) ::   kt   ! ocean time-step 
    106       !! 
     108      ! 
    107109      REAL(wp), POINTER, DIMENSION(:,:,:) ::  ztrdt, ztrds 
    108110      !!---------------------------------------------------------------------- 
    … …  
    110112      IF( nn_timing == 1 )  CALL timing_start( 'tra_bbl') 
    111113      ! 
    112       IF( l_trdtra )   THEN                        !* Save ta and sa trends 
     114      IF( l_trdtra )   THEN                         !* Save ta and sa trends 
    113115         CALL wrk_alloc( jpi, jpj, jpk, ztrdt, ztrds ) 
    114116         ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 
    … …  
    116118      ENDIF 
    117119 
    118       IF( l_bbl )  CALL bbl( kt, nit000, 'TRA' )   !* bbl coef. and transport (only if not already done in trcbbl) 
    119  
    120       IF( nn_bbl_ldf == 1 ) THEN                   !* Diffusive bbl 
     120      IF( l_bbl )   CALL bbl( kt, nit000, 'TRA' )   !* bbl coef. and transport (only if not already done in trcbbl) 
     121 
     122      IF( nn_bbl_ldf == 1 ) THEN                    !* Diffusive bbl 
    121123         ! 
    122124         CALL tra_bbl_dif( tsb, tsa, jpts ) 
    123125         IF( ln_ctl )  & 
    124126         CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' bbl_ldf  - Ta: ', mask1=tmask, & 
    125          &             tab3d_2=tsa(:,:,:,jp_sal), clinfo2=           ' Sa: ', mask2=tmask, clinfo3='tra' ) 
     127            &          tab3d_2=tsa(:,:,:,jp_sal), clinfo2=           ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    126128         ! lateral boundary conditions ; just need for outputs 
    127129         CALL lbc_lnk( ahu_bbl, 'U', 1. )     ;     CALL lbc_lnk( ahv_bbl, 'V', 1. ) 
    … …  
    131133      END IF 
    132134 
    133       IF( nn_bbl_adv /= 0 ) THEN                !* Advective bbl 
     135      IF( nn_bbl_adv /= 0 ) THEN                    !* Advective bbl 
    134136         ! 
    135137         CALL tra_bbl_adv( tsb, tsa, jpts ) 
    136138         IF(ln_ctl)   & 
    137139         CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' bbl_adv  - Ta: ', mask1=tmask,   & 
    138          &             tab3d_2=tsa(:,:,:,jp_sal), clinfo2=           ' Sa: ', mask2=tmask, clinfo3='tra' ) 
     140            &          tab3d_2=tsa(:,:,:,jp_sal), clinfo2=           ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    139141         ! lateral boundary conditions ; just need for outputs 
    140142         CALL lbc_lnk( utr_bbl, 'U', 1. )     ;   CALL lbc_lnk( vtr_bbl, 'V', 1. ) 
    … …  
    147149         ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 
    148150         ztrds(:,:,:) = tsa(:,:,:,jp_sal) - ztrds(:,:,:) 
    149          CALL trd_tra( kt, 'TRA', jp_tem, jptra_trd_bbl, ztrdt ) 
    150          CALL trd_tra( kt, 'TRA', jp_sal, jptra_trd_bbl, ztrds ) 
     151         CALL trd_tra( kt, 'TRA', jp_tem, jptra_bbl, ztrdt ) 
     152         CALL trd_tra( kt, 'TRA', jp_sal, jptra_bbl, ztrds ) 
    151153         CALL wrk_dealloc( jpi, jpj, jpk, ztrdt, ztrds ) 
    152154      ENDIF 
    … …  
    164166      !!                advection terms. 
    165167      !! 
    166       !! ** Method  : 
    167       !!        * diffusive bbl (nn_bbl_ldf=1) : 
     168      !! ** Method  : * diffusive bbl only (nn_bbl_ldf=1) : 
    168169      !!        When the product grad( rho) * grad(h) < 0 (where grad is an 
    169170      !!      along bottom slope gradient) an additional lateral 2nd order 
    … …  
    179180      !!              Campin, J.-M., and H. Goosse, 1999, Tellus, 412-430. 
    180181      !!---------------------------------------------------------------------- 
    181       ! 
    182182      INTEGER                              , INTENT(in   ) ::   kjpt   ! number of tracers 
    183183      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb    ! before and now tracer fields 
    … …  
    196196      DO jn = 1, kjpt                                     ! tracer loop 
    197197         !                                                ! =========== 
    198 #  if defined key_vectopt_loop 
    199          DO jj = 1, 1   ! vector opt. (forced unrolling) 
    200             DO ji = 1, jpij 
    201 #else 
    202198         DO jj = 1, jpj 
    203199            DO ji = 1, jpi 
    204 #endif 
    205                ik = mbkt(ji,jj)                        ! bottom T-level index 
    206                zptb(ji,jj) = ptb(ji,jj,ik,jn)              ! bottom before T and S 
     200               ik = mbkt(ji,jj)                              ! bottom T-level index 
     201               zptb(ji,jj) = ptb(ji,jj,ik,jn)       ! bottom before T and S 
    207202            END DO 
    208203         END DO 
    209          !                                                ! Compute the trend 
    210 #  if defined key_vectopt_loop 
    211          DO jj = 1, 1   ! vector opt. (forced unrolling) 
    212             DO ji = jpi+1, jpij-jpi-1 
    213 #  else 
    214          DO jj = 2, jpjm1 
     204         !                
     205         DO jj = 2, jpjm1                                    ! Compute the trend 
    215206            DO ji = 2, jpim1 
    216 #  endif 
    217                ik = mbkt(ji,jj)                            ! bottom T-level index 
     207               ik = mbkt(ji,jj)                              ! bottom T-level index 
    218208               zbtr = r1_e12t(ji,jj)  / fse3t(ji,jj,ik) 
    219209               pta(ji,jj,ik,jn) = pta(ji,jj,ik,jn)                                                         & 
    … …  
    264254      DO jn = 1, kjpt                                            ! tracer loop 
    265255         !                                                       ! =========== 
    266 # if defined key_vectopt_loop 
    267          DO jj = 1, 1 
    268             DO ji = 1, jpij-jpi-1   ! vector opt. (forced unrolling) 
    269 # else 
    270256         DO jj = 1, jpjm1 
    271257            DO ji = 1, jpim1            ! CAUTION start from i=1 to update i=2 when cyclic east-west 
    272 # endif 
    273258               IF( utr_bbl(ji,jj) /= 0.e0 ) THEN            ! non-zero i-direction bbl advection 
    274259                  ! down-slope i/k-indices (deep)      &   up-slope i/k indices (shelf) 
    … …  
    333318      !!                advection terms. 
    334319      !! 
    335       !! ** Method  : 
    336       !!        * diffusive bbl (nn_bbl_ldf=1) : 
     320      !! ** Method  : * diffusive bbl (nn_bbl_ldf=1) : 
    337321      !!        When the product grad( rho) * grad(h) < 0 (where grad is an 
    338322      !!      along bottom slope gradient) an additional lateral 2nd order 
    … …  
    342326      !!      a downslope velocity of 20 cm/s if the condition for slope 
    343327      !!      convection is satified) 
    344       !!        * advective bbl (nn_bbl_adv=1 or 2) : 
     328      !!              * advective bbl (nn_bbl_adv=1 or 2) : 
    345329      !!      nn_bbl_adv = 1   use of the ocean velocity as bbl velocity 
    346330      !!      nn_bbl_adv = 2   follow Campin and Goosse (1999) implentation 
    … …  
    353337      !!              Campin, J.-M., and H. Goosse, 1999, Tellus, 412-430. 
    354338      !!---------------------------------------------------------------------- 
    355       ! 
    356339      INTEGER         , INTENT(in   ) ::   kt       ! ocean time-step index 
    357       INTEGER         , INTENT(in   ) ::   kit000          ! first time step index 
     340      INTEGER         , INTENT(in   ) ::   kit000   ! first time step index 
    358341      CHARACTER(len=3), INTENT(in   ) ::   cdtype   ! =TRA or TRC (tracer indicator) 
    359342      !! 
    360343      INTEGER  ::   ji, jj                    ! dummy loop indices 
    361344      INTEGER  ::   ik                        ! local integers 
    362       INTEGER  ::   iis , iid , ijs , ijd     !   -       - 
    363       INTEGER  ::   ikus, ikud, ikvs, ikvd    !   -       - 
    364       REAL(wp) ::   zsign, zsigna, zgbbl      ! local scalars 
    365       REAL(wp) ::   zgdrho, zt, zs, zh        !   -      - 
    366       !! 
    367       REAL(wp) ::   fsalbt, fsbeta, pft, pfs, pfh   ! statement function 
    368       REAL(wp), POINTER, DIMENSION(:,:) :: zub, zvb, ztb, zsb, zdep 
    369       !!----------------------- zv_bbl----------------------------------------------- 
    370       ! ratio alpha/beta = fsalbt : ratio of thermal over saline expension coefficients 
    371       ! ================            pft :  potential temperature in degrees celcius 
    372       !                             pfs :  salinity anomaly (s-35) in psu 
    373       !                             pfh :  depth in meters 
    374       ! nn_eos = 0  (Jackett and McDougall 1994 formulation) 
    375       fsalbt( pft, pfs, pfh ) =                                              &   ! alpha/beta 
    376          ( ( ( -0.255019e-07 * pft + 0.298357e-05 ) * pft                    & 
    377                                    - 0.203814e-03 ) * pft                    & 
    378                                    + 0.170907e-01 ) * pft                    & 
    379                                    + 0.665157e-01                            & 
    380          +(-0.678662e-05 * pfs - 0.846960e-04 * pft + 0.378110e-02 ) * pfs   & 
    381          +  ( ( - 0.302285e-13 * pfh                                         & 
    382                 - 0.251520e-11 * pfs                                         & 
    383                 + 0.512857e-12 * pft * pft          ) * pfh                  & 
    384                                      - 0.164759e-06   * pfs                  & 
    385              +(   0.791325e-08 * pft - 0.933746e-06 ) * pft                  & 
    386                                      + 0.380374e-04 ) * pfh 
    387       fsbeta( pft, pfs, pfh ) =                                              &   ! beta 
    388          ( ( -0.415613e-09 * pft + 0.555579e-07 ) * pft                      & 
    389                                  - 0.301985e-05 ) * pft                      & 
    390                                  + 0.785567e-03                              & 
    391          + (     0.515032e-08 * pfs                                          & 
    392                + 0.788212e-08 * pft - 0.356603e-06 ) * pfs                   & 
    393                +(  (   0.121551e-17 * pfh                                    & 
    394                      - 0.602281e-15 * pfs                                    & 
    395                      - 0.175379e-14 * pft + 0.176621e-12 ) * pfh             & 
    396                                           + 0.408195e-10   * pfs             & 
    397                  + ( - 0.213127e-11 * pft + 0.192867e-09 ) * pft             & 
    398                                           - 0.121555e-07 ) * pfh 
    399       !!---------------------------------------------------------------------- 
    400  
     345      INTEGER  ::   iis, iid, ikus, ikud      !   -       - 
     346      INTEGER  ::   ijs, ijd, ikvs, ikvd      !   -       - 
     347      REAL(wp) ::   za, zb, zgdrho            ! local scalars 
     348      REAL(wp) ::   zsign, zsigna, zgbbl      !   -      - 
     349      REAL(wp), DIMENSION(jpi,jpj,jpts)   :: zts, zab         ! 3D workspace 
     350      REAL(wp), DIMENSION(jpi,jpj)        :: zub, zvb, zdep   ! 2D workspace 
     351      !!---------------------------------------------------------------------- 
    401352      ! 
    402353      IF( nn_timing == 1 )  CALL timing_start( 'bbl') 
    403354      ! 
    404       CALL wrk_alloc( jpi, jpj, zub, zvb, ztb, zsb, zdep ) 
    405       ! 
    406  
    407355      IF( kt == kit000 )  THEN 
    408356         IF(lwp)  WRITE(numout,*) 
    … …  
    410358         IF(lwp)  WRITE(numout,*) '~~~~~~~~~~' 
    411359      ENDIF 
    412  
    413       !                                        !* bottom temperature, salinity, velocity and depth 
    414 #if defined key_vectopt_loop 
    415       DO jj = 1, 1   ! vector opt. (forced unrolling) 
    416          DO ji = 1, jpij 
    417 #else 
     360      !                                        !* bottom variables (T, S, alpha, beta, depth, velocity) 
    418361      DO jj = 1, jpj 
    419362         DO ji = 1, jpi 
    420 #endif 
    421             ik = mbkt(ji,jj)                        ! bottom T-level index 
    422             ztb (ji,jj) = tsb(ji,jj,ik,jp_tem) * tmask(ji,jj,1)      ! bottom before T and S 
    423             zsb (ji,jj) = tsb(ji,jj,ik,jp_sal) * tmask(ji,jj,1) 
    424             zdep(ji,jj) = gdept_0(ji,jj,ik)         ! bottom T-level reference depth 
     363            ik = mbkt(ji,jj)                             ! bottom T-level index 
     364            zts (ji,jj,jp_tem) = tsb(ji,jj,ik,jp_tem)    ! bottom before T and S 
     365            zts (ji,jj,jp_sal) = tsb(ji,jj,ik,jp_sal) 
    425366            ! 
    426             zub(ji,jj) = un(ji,jj,mbku(ji,jj))      ! bottom velocity 
    427             zvb(ji,jj) = vn(ji,jj,mbkv(ji,jj)) 
     367            zdep(ji,jj) = fsdept(ji,jj,ik)               ! bottom T-level reference depth 
     368            zub (ji,jj) = un(ji,jj,mbku(ji,jj))          ! bottom velocity 
     369            zvb (ji,jj) = vn(ji,jj,mbkv(ji,jj)) 
    428370         END DO 
    429371      END DO 
    430  
     372      ! 
     373      CALL eos_rab( zts, zdep, zab ) 
     374      ! 
    431375      !                                   !-------------------! 
    432376      IF( nn_bbl_ldf == 1 ) THEN          !   diffusive bbl   ! 
    433377         !                                !-------------------! 
    434378         DO jj = 1, jpjm1                      ! (criteria for non zero flux: grad(rho).grad(h) < 0 ) 
    435             DO ji = 1, jpim1 
    436                !                                                ! i-direction 
    437                zt = 0.5 * ( ztb (ji,jj) + ztb (ji+1,jj) )  ! T, S anomalie, and depth 
    438                zs = 0.5 * ( zsb (ji,jj) + zsb (ji+1,jj) ) - 35.0 
    439                zh = 0.5 * ( zdep(ji,jj) + zdep(ji+1,jj) ) 
    440                !                                                         ! masked bbl i-gradient of density 
    441                zgdrho = (  fsalbt( zt, zs, zh ) * ( ztb(ji+1,jj) - ztb(ji,jj) )    & 
    442                   &                             - ( zsb(ji+1,jj) - zsb(ji,jj) )  ) * umask(ji,jj,1) 
     379            DO ji = 1, fs_jpim1   ! vector opt. 
     380               !                                                   ! i-direction 
     381               za = zab(ji+1,jj,jp_tem) + zab(ji,jj,jp_tem)              ! 2*(alpha,beta) at u-point 
     382               zb = zab(ji+1,jj,jp_sal) + zab(ji,jj,jp_sal) 
     383               !                                                         ! 2*masked bottom density gradient 
     384               zgdrho = (  za * ( zts(ji+1,jj,jp_tem) - zts(ji,jj,jp_tem) )    & 
     385                  &      - zb * ( zts(ji+1,jj,jp_sal) - zts(ji,jj,jp_sal) )  ) * umask(ji,jj,1) 
    443386               ! 
    444                zsign          = SIGN(  0.5, - zgdrho * REAL( mgrhu(ji,jj) )  )    ! sign of ( i-gradient * i-slope ) 
    445                ahu_bbl(ji,jj) = ( 0.5 - zsign ) * ahu_bbl_0(ji,jj)                  ! masked diffusive flux coeff. 
     387               zsign  = SIGN(  0.5, -zgdrho * REAL( mgrhu(ji,jj) )  )    ! sign of ( i-gradient * i-slope ) 
     388               ahu_bbl(ji,jj) = ( 0.5 - zsign ) * ahu_bbl_0(ji,jj)       ! masked diffusive flux coeff. 
    446389               ! 
    447                !                                                ! j-direction 
    448                zt = 0.5 * ( ztb (ji,jj+1) + ztb (ji,jj) )                ! T, S anomalie, and depth 
    449                zs = 0.5 * ( zsb (ji,jj+1) + zsb (ji,jj) ) - 35.0 
    450                zh = 0.5 * ( zdep(ji,jj+1) + zdep(ji,jj) ) 
    451                !                                                         ! masked bbl j-gradient of density 
    452                zgdrho = (  fsalbt( zt, zs, zh ) * ( ztb(ji,jj+1) - ztb(ji,jj) )    & 
    453                   &                             - ( zsb(ji,jj+1) - zsb(ji,jj) )  ) * vmask(ji,jj,1) 
     390               !                                                   ! j-direction 
     391               za = zab(ji,jj+1,jp_tem) + zab(ji,jj,jp_tem)              ! 2*(alpha,beta) at v-point 
     392               zb = zab(ji,jj+1,jp_sal) + zab(ji,jj,jp_sal) 
     393               !                                                         ! 2*masked bottom density gradient 
     394               zgdrho = (  za * ( zts(ji,jj+1,jp_tem) - zts(ji,jj,jp_tem) )    & 
     395                  &      - zb * ( zts(ji,jj+1,jp_sal) - zts(ji,jj,jp_sal) )  ) * vmask(ji,jj,1) 
    454396               ! 
    455                zsign          = SIGN(  0.5, -zgdrho * REAL( mgrhv(ji,jj) )  )     ! sign of ( j-gradient * j-slope ) 
     397               zsign = SIGN(  0.5, -zgdrho * REAL( mgrhv(ji,jj) )  )     ! sign of ( j-gradient * j-slope ) 
    456398               ahv_bbl(ji,jj) = ( 0.5 - zsign ) * ahv_bbl_0(ji,jj) 
    457                ! 
    458399            END DO 
    459400         END DO 
    … …  
    469410            DO jj = 1, jpjm1                                 ! criteria: grad(rho).grad(h)<0  and grad(rho).grad(h)<0 
    470411               DO ji = 1, fs_jpim1   ! vector opt. 
    471                   !                                               ! i-direction 
    472                   zt = 0.5 * ( ztb (ji,jj) + ztb (ji+1,jj) )                  ! T, S anomalie, and depth 
    473                   zs = 0.5 * ( zsb (ji,jj) + zsb (ji+1,jj) ) - 35.0 
    474                   zh = 0.5 * ( zdep(ji,jj) + zdep(ji+1,jj) ) 
    475                   !                                                           ! masked bbl i-gradient of density 
    476                   zgdrho = (  fsalbt( zt, zs, zh ) * ( ztb(ji+1,jj) - ztb(ji,jj) )    & 
    477                      &                             - ( zsb(ji+1,jj) - zsb(ji,jj) )  ) * umask(ji,jj,1) 
    478                   ! 
    479                   zsign = SIGN(  0.5, - zgdrho   * REAL( mgrhu(ji,jj) )  )    ! sign of i-gradient * i-slope 
    480                   zsigna= SIGN(  0.5, zub(ji,jj) * REAL( mgrhu(ji,jj) )  )    ! sign of u * i-slope 
    481                   ! 
    482                   !                                                           ! bbl velocity 
     412                  !                                                  ! i-direction 
     413                  za = zab(ji+1,jj,jp_tem) + zab(ji,jj,jp_tem)               ! 2*(alpha,beta) at u-point 
     414                  zb = zab(ji+1,jj,jp_sal) + zab(ji,jj,jp_sal) 
     415                  !                                                          ! 2*masked bottom density gradient  
     416                  zgdrho = (  za * ( zts(ji+1,jj,jp_tem) - zts(ji,jj,jp_tem) )    & 
     417                            - zb * ( zts(ji+1,jj,jp_sal) - zts(ji,jj,jp_sal) )  ) * umask(ji,jj,1) 
     418                  ! 
     419                  zsign = SIGN(  0.5, - zgdrho   * REAL( mgrhu(ji,jj) )  )   ! sign of i-gradient * i-slope 
     420                  zsigna= SIGN(  0.5, zub(ji,jj) * REAL( mgrhu(ji,jj) )  )   ! sign of u * i-slope 
     421                  ! 
     422                  !                                                          ! bbl velocity 
    483423                  utr_bbl(ji,jj) = ( 0.5 + zsigna ) * ( 0.5 - zsign ) * e2u(ji,jj) * e3u_bbl_0(ji,jj) * zub(ji,jj) 
    484424                  ! 
    485                   !                                               ! j-direction 
    486                   zt = 0.5 * ( ztb (ji,jj+1) + ztb (ji,jj) )                  ! T, S anomalie, and depth 
    487                   zs = 0.5 * ( zsb (ji,jj+1) + zsb (ji,jj) ) - 35.0 
    488                   zh = 0.5 * ( zdep(ji,jj+1) + zdep(ji,jj) ) 
    489                   !                                                           ! masked bbl j-gradient of density 
    490                   zgdrho = (  fsalbt( zt, zs, zh ) * ( ztb(ji,jj+1) - ztb(ji,jj) )    & 
    491                      &                             - ( zsb(ji,jj+1) - zsb(ji,jj) )  ) * vmask(ji,jj,1) 
    492                   zsign = SIGN(  0.5, - zgdrho   * REAL( mgrhv(ji,jj) )  )    ! sign of j-gradient * j-slope 
    493                   zsigna= SIGN(  0.5, zvb(ji,jj) * REAL( mgrhv(ji,jj) )  )    ! sign of u * i-slope 
    494                   ! 
    495                   !                                                           ! bbl velocity 
     425                  !                                                  ! j-direction 
     426                  za = zab(ji,jj+1,jp_tem) + zab(ji,jj,jp_tem)               ! 2*(alpha,beta) at v-point 
     427                  zb = zab(ji,jj+1,jp_sal) + zab(ji,jj,jp_sal) 
     428                  !                                                          ! 2*masked bottom density gradient 
     429                  zgdrho = (  za * ( zts(ji,jj+1,jp_tem) - zts(ji,jj,jp_tem) )    & 
     430                     &      - zb * ( zts(ji,jj+1,jp_sal) - zts(ji,jj,jp_sal) )  ) * vmask(ji,jj,1) 
     431                  zsign = SIGN(  0.5, - zgdrho   * REAL( mgrhv(ji,jj) )  )   ! sign of j-gradient * j-slope 
     432                  zsigna= SIGN(  0.5, zvb(ji,jj) * REAL( mgrhv(ji,jj) )  )   ! sign of u * i-slope 
     433                  ! 
     434                  !                                                          ! bbl transport 
    496435                  vtr_bbl(ji,jj) = ( 0.5 + zsigna ) * ( 0.5 - zsign ) * e1v(ji,jj) * e3v_bbl_0(ji,jj) * zvb(ji,jj) 
    497436               END DO 
    … …  
    502441            DO jj = 1, jpjm1                            ! criteria: rho_up > rho_down 
    503442               DO ji = 1, fs_jpim1   ! vector opt. 
    504                   !                                         ! i-direction 
     443                  !                                                  ! i-direction 
    505444                  ! down-slope T-point i/k-index (deep)  &   up-slope T-point i/k-index (shelf) 
    506                   iid  = ji + MAX( 0, mgrhu(ji,jj) )     ;    iis  = ji + 1 - MAX( 0, mgrhu(ji,jj) ) 
    507                   ikud = mbku_d(ji,jj)                   ;    ikus = mbku(ji,jj) 
    508                   ! 
    509                   !                                             ! mid-depth density anomalie (up-slope minus down-slope) 
    510                   zt = 0.5 * ( ztb (ji,jj) + ztb (ji+1,jj) )           ! mid slope depth of T, S, and depth 
    511                   zs = 0.5 * ( zsb (ji,jj) + zsb (ji+1,jj) ) - 35.0 
    512                   zh = 0.5 * ( zdep(ji,jj) + zdep(ji+1,jj) ) 
    513                   zgdrho =    fsbeta( zt, zs, zh )                                    & 
    514                      &   * (  fsalbt( zt, zs, zh ) * ( ztb(iid,jj) - ztb(iis,jj) )    & 
    515                      &                             - ( zsb(iid,jj) - zsb(iis,jj) )  ) * umask(ji,jj,1) 
    516                   zgdrho = MAX( 0.e0, zgdrho )                         ! only if shelf is denser than deep 
    517                   ! 
    518                   !                                             ! bbl transport (down-slope direction) 
     445                  iid  = ji + MAX( 0, mgrhu(ji,jj) ) 
     446                  iis  = ji + 1 - MAX( 0, mgrhu(ji,jj) ) 
     447                  ! 
     448                  ikud = mbku_d(ji,jj) 
     449                  ikus = mbku(ji,jj) 
     450                  ! 
     451                  za = zab(ji+1,jj,jp_tem) + zab(ji,jj,jp_tem)               ! 2*(alpha,beta) at u-point 
     452                  zb = zab(ji+1,jj,jp_sal) + zab(ji,jj,jp_sal) 
     453                  !                                                          !   masked bottom density gradient 
     454                  zgdrho = 0.5 * (  za * ( zts(iid,jj,jp_tem) - zts(iis,jj,jp_tem) )    & 
     455                     &            - zb * ( zts(iid,jj,jp_sal) - zts(iis,jj,jp_sal) )  ) * umask(ji,jj,1) 
     456                  zgdrho = MAX( 0.e0, zgdrho )                               ! only if shelf is denser than deep 
     457                  ! 
     458                  !                                                          ! bbl transport (down-slope direction) 
    519459                  utr_bbl(ji,jj) = e2u(ji,jj) * e3u_bbl_0(ji,jj) * zgbbl * zgdrho * REAL( mgrhu(ji,jj) ) 
    520460                  ! 
    521                   !                                         ! j-direction 
     461                  !                                                  ! j-direction 
    522462                  !  down-slope T-point j/k-index (deep)  &   of the up  -slope T-point j/k-index (shelf) 
    523                   ijd  = jj + MAX( 0, mgrhv(ji,jj) )      ;    ijs  = jj + 1 - MAX( 0, mgrhv(ji,jj) ) 
    524                   ikvd = mbkv_d(ji,jj)                    ;    ikvs = mbkv(ji,jj) 
    525                   ! 
    526                   !                                             ! mid-depth density anomalie (up-slope minus down-slope) 
    527                   zt = 0.5 * ( ztb (ji,jj) + ztb (ji,jj+1) )           ! mid slope depth of T, S, and depth 
    528                   zs = 0.5 * ( zsb (ji,jj) + zsb (ji,jj+1) ) - 35.0 
    529                   zh = 0.5 * ( zdep(ji,jj) + zdep(ji,jj+1) ) 
    530                   zgdrho =    fsbeta( zt, zs, zh )                                    & 
    531                      &   * (  fsalbt( zt, zs, zh ) * ( ztb(ji,ijd) - ztb(ji,ijs) )    & 
    532                      &                             - ( zsb(ji,ijd) - zsb(ji,ijs) )  ) * vmask(ji,jj,1) 
    533                   zgdrho = MAX( 0.e0, zgdrho )                         ! only if shelf is denser than deep 
    534                   ! 
    535                   !                                             ! bbl transport (down-slope direction) 
     463                  ijd  = jj + MAX( 0, mgrhv(ji,jj) ) 
     464                  ijs  = jj + 1 - MAX( 0, mgrhv(ji,jj) ) 
     465                  ! 
     466                  ikvd = mbkv_d(ji,jj) 
     467                  ikvs = mbkv(ji,jj) 
     468                  ! 
     469                  za = zab(ji,jj+1,jp_tem) + zab(ji,jj,jp_tem)               ! 2*(alpha,beta) at v-point 
     470                  zb = zab(ji,jj+1,jp_sal) + zab(ji,jj,jp_sal) 
     471                  !                                                          !   masked bottom density gradient 
     472                  zgdrho = 0.5 * (  za * ( zts(ji,ijd,jp_tem) - zts(ji,ijs,jp_tem) )    & 
     473                     &            - zb * ( zts(ji,ijd,jp_sal) - zts(ji,ijs,jp_sal) )  ) * vmask(ji,jj,1) 
     474                  zgdrho = MAX( 0.e0, zgdrho )                               ! only if shelf is denser than deep 
     475                  ! 
     476                  !                                                          ! bbl transport (down-slope direction) 
    536477                  vtr_bbl(ji,jj) = e1v(ji,jj) * e3v_bbl_0(ji,jj) * zgbbl * zgdrho * REAL( mgrhv(ji,jj) ) 
    537478               END DO 
    … …  
    541482      ENDIF 
    542483      ! 
    543       CALL wrk_dealloc( jpi, jpj, zub, zvb, ztb, zsb, zdep ) 
    544       ! 
    545484      IF( nn_timing == 1 )  CALL timing_stop( 'bbl') 
    546485      ! 
    … …  
    558497      !!---------------------------------------------------------------------- 
    559498      INTEGER ::   ji, jj               ! dummy loop indices 
    560       INTEGER ::   ii0, ii1, ij0, ij1   ! temporary integer 
    561       INTEGER  ::   ios                 ! Local integer output status for namelist read 
     499      INTEGER ::   ii0, ii1, ij0, ij1   ! local integer 
     500      INTEGER ::   ios                  !   -      - 
    562501      REAL(wp), POINTER, DIMENSION(:,:) :: zmbk 
    563502      !! 
    … …  
    598537      IF( nn_bbl_adv == 2 )    WRITE(numout,*) '       * Advective BBL using velocity = F( delta rho)' 
    599538 
    600       IF( nn_eos /= 0 )   CALL ctl_stop ( ' bbl parameterisation requires eos = 0. We stop.' ) 
    601  
    602539      !                             !* vertical index of  "deep" bottom u- and v-points 
    603540      DO jj = 1, jpjm1                    ! (the "shelf" bottom k-indices are mbku and mbkv) 
    … …  
    607544         END DO 
    608545      END DO 
    609       ! convert into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk 
     546      ! converte into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk 
    610547      zmbk(:,:) = REAL( mbku_d(:,:), wp )   ;   CALL lbc_lnk(zmbk,'U',1.)   ;   mbku_d(:,:) = MAX( INT( zmbk(:,:) ), 1 ) 
    611548      zmbk(:,:) = REAL( mbkv_d(:,:), wp )   ;   CALL lbc_lnk(zmbk,'V',1.)   ;   mbkv_d(:,:) = MAX( INT( zmbk(:,:) ), 1 ) 
    612549 
    613                                      !* sign of grad(H) at u- and v-points 
    614       mgrhu(jpi,:) = 0.    ;    mgrhu(:,jpj) = 0.   ;    mgrhv(jpi,:) = 0.    ;    mgrhv(:,jpj) = 0. 
     550                                        !* sign of grad(H) at u- and v-points 
     551      mgrhu(jpi,:) = 0   ;   mgrhu(:,jpj) = 0   ;   mgrhv(jpi,:) = 0   ;   mgrhv(:,jpj) = 0 
    615552      DO jj = 1, jpjm1 
    616553         DO ji = 1, jpim1 
    … …  
    621558 
    622559      DO jj = 1, jpjm1              !* bbl thickness at u- (v-) point 
    623          DO ji = 1, jpim1           ! minimum of top & bottom e3u_0 (e3v_0) 
     560         DO ji = 1, jpim1                 ! minimum of top & bottom e3u_0 (e3v_0) 
    624561            e3u_bbl_0(ji,jj) = MIN( e3u_0(ji,jj,mbkt(ji+1,jj  )), e3u_0(ji,jj,mbkt(ji,jj)) ) 
    625562            e3v_bbl_0(ji,jj) = MIN( e3v_0(ji,jj,mbkt(ji  ,jj+1)), e3v_0(ji,jj,mbkt(ji,jj)) ) 

  • branches/2014/dev_r4650_UKMO14.5_SST_BIAS_CORRECTION/NEMOGCM/NEMO/OPA_SRC/TRA/tradmp.F90

    r4624 r5965  
    2121   !!   tra_dmp       : update the tracer trend with the internal damping 
    2222   !!   tra_dmp_init  : initialization, namlist read, parameters control 
    23    !!   dtacof_zoom   : restoring coefficient for zoom domain 
    24    !!   dtacof        : restoring coefficient for global domain 
    25    !!   cofdis        : compute the distance to the coastline 
    2623   !!---------------------------------------------------------------------- 
    2724   USE oce            ! ocean: variables 
    2825   USE dom_oce        ! ocean: domain variables 
    2926   USE c1d            ! 1D vertical configuration 
    30    USE trdmod_oce     ! ocean: trend variables 
    31    USE trdtra         ! active tracers: trends 
     27   USE trd_oce        ! trends: ocean variables 
     28   USE trdtra         ! trends manager: tracers  
    3229   USE zdf_oce        ! ocean: vertical physics 
    3330   USE phycst         ! physical constants 
    … …  
    3936   USE wrk_nemo       ! Memory allocation 
    4037   USE timing         ! Timing 
     38   USE iom 
    4139 
    4240   IMPLICIT NONE 
    … …  
    4543   PUBLIC   tra_dmp      ! routine called by step.F90 
    4644   PUBLIC   tra_dmp_init ! routine called by opa.F90 
    47    PUBLIC   dtacof       ! routine called by tradmp.F90, trcdmp.F90 and dyndmp.F90 
    48    PUBLIC   dtacof_zoom  ! routine called by tradmp.F90, trcdmp.F90 and dyndmp.F90 
    4945 
    5046   !                               !!* Namelist namtra_dmp : T & S newtonian damping * 
     47   ! nn_zdmp and cn_resto are public as they are used by C1D/dyndmp.F90 
    5148   LOGICAL , PUBLIC ::   ln_tradmp   !: internal damping flag 
    52    INTEGER , PUBLIC ::   nn_hdmp     ! = 0/-1/'latitude' for damping over T and S 
    5349   INTEGER , PUBLIC ::   nn_zdmp     ! = 0/1/2 flag for damping in the mixed layer 
    54    REAL(wp), PUBLIC ::   rn_surf     ! surface time scale for internal damping        [days] 
    55    REAL(wp), PUBLIC ::   rn_bot      ! bottom time scale for internal damping         [days] 
    56    REAL(wp), PUBLIC ::   rn_dep      ! depth of transition between rn_surf and rn_bot [meters] 
    57    INTEGER , PUBLIC ::   nn_file     ! = 1 create a damping.coeff NetCDF file  
     50   CHARACTER(LEN=200) , PUBLIC :: cn_resto      ! name of netcdf file containing restoration coefficient field 
     51   ! 
     52 
    5853 
    5954   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   strdmp   !: damping salinity trend (psu/s) 
    … …  
    112107      ! 
    113108      CALL wrk_alloc( jpi, jpj, jpk, jpts,  zts_dta ) 
     109      ! 
    114110      !                           !==   input T-S data at kt   ==! 
    115111      CALL dta_tsd( kt, zts_dta )            ! read and interpolates T-S data at kt 
    … …  
    172168      ! 
    173169      IF( l_trdtra )   THEN       ! trend diagnostic 
    174          CALL trd_tra( kt, 'TRA', jp_tem, jptra_trd_dmp, ttrdmp ) 
    175          CALL trd_tra( kt, 'TRA', jp_sal, jptra_trd_dmp, strdmp ) 
     170         CALL trd_tra( kt, 'TRA', jp_tem, jptra_dmp, ttrdmp ) 
     171         CALL trd_tra( kt, 'TRA', jp_sal, jptra_dmp, strdmp ) 
    176172      ENDIF 
    177173      !                           ! Control print 
    … …  
    194190      !! ** Method  :   read the namtra_dmp namelist and check the parameters 
    195191      !!---------------------------------------------------------------------- 
    196       NAMELIST/namtra_dmp/ ln_tradmp, nn_hdmp, nn_zdmp, rn_surf, rn_bot, rn_dep, nn_file 
    197       INTEGER  ::   ios                 ! Local integer output status for namelist read 
    198       !!---------------------------------------------------------------------- 
    199  
    200       REWIND( numnam_ref )              ! Namelist namtra_dmp in reference namelist : Temperature and salinity damping term 
     192      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      !! 
     196      !!---------------------------------------------------------------------- 
     197      ! 
     198      REWIND( numnam_ref )   ! Namelist namtra_dmp in reference namelist : T & S relaxation 
    201199      READ  ( numnam_ref, namtra_dmp, IOSTAT = ios, ERR = 901) 
    202200901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_dmp in reference namelist', lwp ) 
    203  
    204       REWIND( numnam_cfg )              ! Namelist namtra_dmp in configuration namelist : Temperature and salinity damping term 
     201      ! 
     202      REWIND( numnam_cfg )   ! Namelist namtra_dmp in configuration namelist : T & S relaxation 
    205203      READ  ( numnam_cfg, namtra_dmp, IOSTAT = ios, ERR = 902 ) 
    206204902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_dmp in configuration namelist', lwp ) 
    207205      IF(lwm) WRITE ( numond, namtra_dmp ) 
    208        
    209       IF( lzoom .AND. .NOT. lk_c1d )   nn_zdmp = 0          ! restoring to climatology at closed north or south boundaries 
    210  
    211       IF(lwp) THEN                       ! Namelist print 
     206 
     207      IF(lwp) THEN                 !Namelist print 
    212208         WRITE(numout,*) 
    213          WRITE(numout,*) 'tra_dmp_init : T and S newtonian damping' 
     209         WRITE(numout,*) 'tra_dmp_init : T and S newtonian relaxation' 
    214210         WRITE(numout,*) '~~~~~~~' 
    215          WRITE(numout,*) '   Namelist namtra_dmp : set damping parameter' 
    216          WRITE(numout,*) '      add a damping term or not       ln_tradmp = ', ln_tradmp 
    217          WRITE(numout,*) '      T and S damping option          nn_hdmp   = ', nn_hdmp 
    218          WRITE(numout,*) '      mixed layer damping option      nn_zdmp   = ', nn_zdmp, '(non-C1D zoom: forced to 0)' 
    219          WRITE(numout,*) '      surface time scale (days)       rn_surf   = ', rn_surf 
    220          WRITE(numout,*) '      bottom time scale (days)        rn_bot    = ', rn_bot 
    221          WRITE(numout,*) '      depth of transition (meters)    rn_dep    = ', rn_dep 
    222          WRITE(numout,*) '      create a damping.coeff file     nn_file   = ', nn_file 
     211         WRITE(numout,*) '   Namelist namtra_dmp : set relaxation parameters' 
     212         WRITE(numout,*) '      Apply relaxation   or not       ln_tradmp = ', ln_tradmp 
     213         WRITE(numout,*) '      mixed layer damping option      nn_zdmp   = ', nn_zdmp 
     214         WRITE(numout,*) '      Damping file name               cn_resto  = ', cn_resto 
    223215         WRITE(numout,*) 
    224216      ENDIF 
    225217 
    226       IF( ln_tradmp ) THEN               ! initialization for T-S damping 
    227          ! 
     218      IF( ln_tradmp) THEN 
     219         ! 
     220         !Allocate arrays 
    228221         IF( tra_dmp_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'tra_dmp_init: unable to allocate arrays' ) 
    229          ! 
    230 #if ! defined key_c1d 
    231          SELECT CASE ( nn_hdmp ) 
    232          CASE (  -1  )   ;   IF(lwp) WRITE(numout,*) '   tracer damping in the Med & Red seas only' 
    233          CASE ( 1:90 )   ;   IF(lwp) WRITE(numout,*) '   tracer damping poleward of', nn_hdmp, ' degrees' 
    234          CASE DEFAULT 
    235             WRITE(ctmp1,*) '          bad flag value for nn_hdmp = ', nn_hdmp 
    236             CALL ctl_stop(ctmp1) 
     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' 
    237228         END SELECT 
    238          ! 
    239 #endif 
    240          SELECT CASE ( nn_zdmp ) 
    241          CASE ( 0 )   ;   IF(lwp) WRITE(numout,*) '   tracer damping throughout the water column' 
    242          CASE ( 1 )   ;   IF(lwp) WRITE(numout,*) '   no tracer damping in the turbocline (avt > 5 cm2/s)' 
    243          CASE ( 2 )   ;   IF(lwp) WRITE(numout,*) '   no tracer damping in the mixed layer' 
    244          CASE DEFAULT 
    245             WRITE(ctmp1,*) 'bad flag value for nn_zdmp = ', nn_zdmp 
    246             CALL ctl_stop(ctmp1) 
    247          END SELECT 
    248          ! 
     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? 
    249232         IF( .NOT.ln_tsd_tradmp ) THEN 
    250233            CALL ctl_warn( 'tra_dmp_init: read T-S data not initialized, we force ln_tsd_tradmp=T' ) 
    251234            CALL dta_tsd_init( ld_tradmp=ln_tradmp )        ! forces the initialisation of T-S data 
    252235         ENDIF 
    253          ! 
    254          strdmp(:,:,:) = 0._wp       ! internal damping salinity trend (used in asmtrj) 
     236 
     237         !initialise arrays - Are these actually used anywhere else? 
     238         strdmp(:,:,:) = 0._wp 
    255239         ttrdmp(:,:,:) = 0._wp 
    256          !                          ! Damping coefficients initialization 
    257          IF( lzoom .AND. .NOT. lk_c1d ) THEN   ;   CALL dtacof_zoom( resto ) 
    258          ELSE               ;   CALL dtacof( nn_hdmp, rn_surf, rn_bot, rn_dep, nn_file, 'TRA', resto ) 
    259          ENDIF 
    260          ! 
    261       ENDIF 
    262       ! 
     240 
     241         !Read in mask from file 
     242         CALL iom_open ( cn_resto, imask) 
     243         CALL iom_get  ( imask, jpdom_autoglo, 'resto', resto) 
     244         CALL iom_close( imask ) 
     245       ENDIF 
     246 
    263247   END SUBROUTINE tra_dmp_init 
    264248 
    265  
    266    SUBROUTINE dtacof_zoom( presto ) 
    267       !!---------------------------------------------------------------------- 
    268       !!                  ***  ROUTINE dtacof_zoom  *** 
    269       !! 
    270       !! ** Purpose :   Compute the damping coefficient for zoom domain 
    271       !! 
    272       !! ** Method  : - set along closed boundary due to zoom a damping over 
    273       !!                6 points with a max time scale of 5 days. 
    274       !!              - ORCA arctic/antarctic zoom: set the damping along 
    275       !!                south/north boundary over a latitude strip. 
    276       !! 
    277       !! ** Action  : - resto, the damping coeff. for T and S 
    278       !!---------------------------------------------------------------------- 
    279       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout)  ::   presto   ! restoring coeff. (s-1) 
    280       ! 
    281       INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    282       REAL(wp) ::   zlat, zlat0, zlat1, zlat2, z1_5d   ! local scalar 
    283       REAL(wp), DIMENSION(6)  ::   zfact               ! 1Dworkspace 
    284       !!---------------------------------------------------------------------- 
    285       ! 
    286       IF( nn_timing == 1 )  CALL timing_start( 'dtacof_zoom') 
    287       ! 
    288  
    289       zfact(1) =  1._wp 
    290       zfact(2) =  1._wp 
    291       zfact(3) = 11._wp / 12._wp 
    292       zfact(4) =  8._wp / 12._wp 
    293       zfact(5) =  4._wp / 12._wp 
    294       zfact(6) =  1._wp / 12._wp 
    295       zfact(:) = zfact(:) / ( 5._wp * rday )    ! 5 days max restoring time scale 
    296  
    297       presto(:,:,:) = 0._wp 
    298  
    299       ! damping along the forced closed boundary over 6 grid-points 
    300       DO jn = 1, 6 
    301          IF( lzoom_w )   presto( mi0(jn+jpizoom):mi1(jn+jpizoom), : , : )                    = zfact(jn)   ! west  closed 
    302          IF( lzoom_s )   presto( : , mj0(jn+jpjzoom):mj1(jn+jpjzoom), : )                    = zfact(jn)   ! south closed  
    303          IF( lzoom_e )   presto( mi0(jpiglo+jpizoom-1-jn):mi1(jpiglo+jpizoom-1-jn) , : , : ) = zfact(jn)   ! east  closed  
    304          IF( lzoom_n )   presto( : , mj0(jpjglo+jpjzoom-1-jn):mj1(jpjglo+jpjzoom-1-jn) , : ) = zfact(jn)   ! north closed 
    305       END DO 
    306  
    307       !                                           ! ==================================================== 
    308       IF( cp_cfz == "arctic" .OR. cp_cfz == "antarctic" ) THEN   !  ORCA configuration : arctic or antarctic zoom 
    309          !                                        ! ==================================================== 
    310          IF(lwp) WRITE(numout,*) 
    311          IF(lwp .AND. cp_cfz == "arctic" ) WRITE(numout,*) '              dtacof_zoom : ORCA    Arctic zoom' 
    312          IF(lwp .AND. cp_cfz == "antarctic" ) WRITE(numout,*) '           dtacof_zoom : ORCA Antarctic zoom' 
    313          IF(lwp) WRITE(numout,*) 
    314          ! 
    315          !                          ! Initialization :  
    316          presto(:,:,:) = 0._wp 
    317          zlat0 = 10._wp                     ! zlat0 : latitude strip where resto decreases 
    318          zlat1 = 30._wp                     ! zlat1 : resto = 1 before zlat1 
    319          zlat2 = zlat1 + zlat0              ! zlat2 : resto decreases from 1 to 0 between zlat1 and zlat2 
    320          z1_5d = 1._wp / ( 5._wp * rday )   ! z1_5d : 1 / 5days 
    321  
    322          DO jk = 2, jpkm1           ! Compute arrays resto ; value for internal damping : 5 days 
    323             DO jj = 1, jpj 
    324                DO ji = 1, jpi 
    325                   zlat = ABS( gphit(ji,jj) ) 
    326                   IF( zlat1 <= zlat .AND. zlat <= zlat2 ) THEN 
    327                      presto(ji,jj,jk) = 0.5_wp * z1_5d * (  1._wp - COS( rpi*(zlat2-zlat)/zlat0 )  )  
    328                   ELSEIF( zlat < zlat1 ) THEN 
    329                      presto(ji,jj,jk) = z1_5d 
    330                   ENDIF 
    331                END DO 
    332             END DO 
    333          END DO 
    334          ! 
    335       ENDIF 
    336       !                             ! Mask resto array 
    337       presto(:,:,:) = presto(:,:,:) * tmask(:,:,:) 
    338       ! 
    339       IF( nn_timing == 1 )  CALL timing_stop( 'dtacof_zoom') 
    340       ! 
    341    END SUBROUTINE dtacof_zoom 
    342  
    343  
    344    SUBROUTINE dtacof( kn_hdmp, pn_surf, pn_bot, pn_dep,  & 
    345       &               kn_file, cdtype , presto           ) 
    346       !!---------------------------------------------------------------------- 
    347       !!                  ***  ROUTINE dtacof  *** 
    348       !! 
    349       !! ** Purpose :   Compute the damping coefficient 
    350       !! 
    351       !! ** Method  :   Arrays defining the damping are computed for each grid 
    352       !!                point for temperature and salinity (resto) 
    353       !!                Damping depends on distance to coast, depth and latitude 
    354       !! 
    355       !! ** Action  : - resto, the damping coeff. for T and S 
    356       !!---------------------------------------------------------------------- 
    357       USE iom 
    358       USE ioipsl 
    359       !! 
    360       INTEGER                         , INTENT(in   )  ::  kn_hdmp    ! damping option 
    361       REAL(wp)                        , INTENT(in   )  ::  pn_surf    ! surface time scale (days) 
    362       REAL(wp)                        , INTENT(in   )  ::  pn_bot     ! bottom time scale (days) 
    363       REAL(wp)                        , INTENT(in   )  ::  pn_dep     ! depth of transition (meters) 
    364       INTEGER                         , INTENT(in   )  ::  kn_file    ! save the damping coef on a file or not 
    365       CHARACTER(len=3)                , INTENT(in   )  ::  cdtype     ! =TRA, TRC or DYN (tracer/dynamics indicator) 
    366       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout)  ::  presto     ! restoring coeff. (s-1) 
    367       ! 
    368       INTEGER  ::   ji, jj, jk                  ! dummy loop indices 
    369       INTEGER  ::   ii0, ii1, ij0, ij1          ! local integers 
    370       INTEGER  ::   inum0, icot                 !   -       - 
    371       REAL(wp) ::   zinfl, zlon                 ! local scalars 
    372       REAL(wp) ::   zlat, zlat0, zlat1, zlat2   !   -      - 
    373       REAL(wp) ::   zsdmp, zbdmp                !   -      - 
    374       CHARACTER(len=20)                   :: cfile 
    375       REAL(wp), POINTER, DIMENSION(:    ) :: zhfac  
    376       REAL(wp), POINTER, DIMENSION(:,:  ) :: zmrs  
    377       REAL(wp), POINTER, DIMENSION(:,:,:) :: zdct  
    378       !!---------------------------------------------------------------------- 
    379       ! 
    380       IF( nn_timing == 1 )  CALL timing_start('dtacof') 
    381       ! 
    382       CALL wrk_alloc( jpk, zhfac          ) 
    383       CALL wrk_alloc( jpi, jpj, zmrs      ) 
    384       CALL wrk_alloc( jpi, jpj, jpk, zdct ) 
    385 #if defined key_c1d 
    386       !                                   ! ==================== 
    387       !                                   !  C1D configuration : local domain 
    388       !                                   ! ==================== 
    389       ! 
    390       IF(lwp) WRITE(numout,*) 
    391       IF(lwp) WRITE(numout,*) '              dtacof : C1D 3x3 local domain' 
    392       IF(lwp) WRITE(numout,*) '              -----------------------------' 
    393       ! 
    394       presto(:,:,:) = 0._wp 
    395       ! 
    396       zsdmp = 1._wp / ( pn_surf * rday ) 
    397       zbdmp = 1._wp / ( pn_bot  * rday ) 
    398       DO jk = 2, jpkm1 
    399          DO jj = 1, jpj 
    400             DO ji = 1, jpi 
    401                !   ONLY vertical variation from zsdmp (sea surface) to zbdmp (bottom) 
    402                presto(ji,jj,jk) = zbdmp + (zsdmp-zbdmp) * EXP(-fsdept(ji,jj,jk)/pn_dep) 
    403             END DO 
    404          END DO 
    405       END DO 
    406       ! 
    407       presto(:,:, : ) = presto(:,:,:) * tmask(:,:,:) 
    408 #else 
    409       !                                   ! ==================== 
    410       !                                   !  ORCA configuration : global domain 
    411       !                                   ! ==================== 
    412       ! 
    413       IF(lwp) WRITE(numout,*) 
    414       IF(lwp) WRITE(numout,*) '              dtacof : Global domain of ORCA' 
    415       IF(lwp) WRITE(numout,*) '              ------------------------------' 
    416       ! 
    417       presto(:,:,:) = 0._wp 
    418       ! 
    419       IF( kn_hdmp > 0 ) THEN      !  Damping poleward of 'nn_hdmp' degrees  ! 
    420          !                        !-----------------------------------------! 
    421          IF(lwp) WRITE(numout,*) 
    422          IF(lwp) WRITE(numout,*) '              Damping poleward of ', kn_hdmp, ' deg.' 
    423          ! 
    424          CALL iom_open ( 'dist.coast.nc', icot, ldstop = .FALSE. ) 
    425          ! 
    426          IF( icot > 0 ) THEN          ! distance-to-coast read in file 
    427             CALL iom_get  ( icot, jpdom_data, 'Tcoast', zdct ) 
    428             CALL iom_close( icot ) 
    429          ELSE                         ! distance-to-coast computed and saved in file (output in zdct) 
    430             CALL cofdis( zdct ) 
    431          ENDIF 
    432  
    433          !                            ! Compute arrays resto  
    434          zinfl = 1000.e3_wp                ! distance of influence for damping term 
    435          zlat0 = 10._wp                    ! latitude strip where resto decreases 
    436          zlat1 = REAL( kn_hdmp )           ! resto = 0 between -zlat1 and zlat1 
    437          zlat2 = zlat1 + zlat0             ! resto increases from 0 to 1 between |zlat1| and |zlat2| 
    438  
    439          DO jj = 1, jpj 
    440             DO ji = 1, jpi 
    441                zlat = ABS( gphit(ji,jj) ) 
    442                IF ( zlat1 <= zlat .AND. zlat <= zlat2 ) THEN 
    443                   presto(ji,jj,1) = 0.5_wp * (  1._wp - COS( rpi*(zlat-zlat1)/zlat0 )  ) 
    444                ELSEIF ( zlat > zlat2 ) THEN 
    445                   presto(ji,jj,1) = 1._wp 
    446                ENDIF 
    447             END DO 
    448          END DO 
    449  
    450          IF ( kn_hdmp == 20 ) THEN       ! North Indian ocean (20N/30N x 45E/100E) : resto=0 
    451             DO jj = 1, jpj 
    452                DO ji = 1, jpi 
    453                   zlat = gphit(ji,jj) 
    454                   zlon = MOD( glamt(ji,jj), 360._wp ) 
    455                   IF ( zlat1 < zlat .AND. zlat < zlat2 .AND. 45._wp < zlon .AND. zlon < 100._wp ) THEN 
    456                      presto(ji,jj,1) = 0._wp 
    457                   ENDIF 
    458                END DO 
    459             END DO 
    460          ENDIF 
    461  
    462          zsdmp = 1._wp / ( pn_surf * rday ) 
    463          zbdmp = 1._wp / ( pn_bot  * rday ) 
    464          DO jk = 2, jpkm1 
    465             DO jj = 1, jpj 
    466                DO ji = 1, jpi 
    467                   zdct(ji,jj,jk) = MIN( zinfl, zdct(ji,jj,jk) ) 
    468                   !   ... Decrease the value in the vicinity of the coast 
    469                   presto(ji,jj,jk) = presto(ji,jj,1 ) * 0.5_wp * (  1._wp - COS( rpi*zdct(ji,jj,jk)/zinfl)  ) 
    470                   !   ... Vertical variation from zsdmp (sea surface) to zbdmp (bottom) 
    471                   presto(ji,jj,jk) = presto(ji,jj,jk) * (  zbdmp + (zsdmp-zbdmp) * EXP(-fsdept(ji,jj,jk)/pn_dep)  ) 
    472                END DO 
    473             END DO 
    474          END DO 
    475          ! 
    476       ENDIF 
    477  
    478       !                                  ! ========================= 
    479       !                                  !  Med and Red Sea damping    (ORCA configuration only) 
    480       !                                  ! ========================= 
    481       IF( cp_cfg == "orca" .AND. ( kn_hdmp > 0 .OR. kn_hdmp == -1 ) ) THEN 
    482          IF(lwp)WRITE(numout,*) 
    483          IF(lwp)WRITE(numout,*) '              ORCA configuration: Damping in Med and Red Seas' 
    484          ! 
    485          zmrs(:,:) = 0._wp 
    486          ! 
    487          SELECT CASE ( jp_cfg ) 
    488          !                                           ! ======================= 
    489          CASE ( 4 )                                  !  ORCA_R4 configuration  
    490             !                                        ! ======================= 
    491             ij0 =  50   ;   ij1 =  56                    ! Mediterranean Sea 
    492  
    493             ii0 =  81   ;   ii1 =  91   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp 
    494             ij0 =  50   ;   ij1 =  55 
    495             ii0 =  75   ;   ii1 =  80   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp 
    496             ij0 =  52   ;   ij1 =  53 
    497             ii0 =  70   ;   ii1 =  74   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp 
    498             ! Smooth transition from 0 at surface to 1./rday at the 18th level in Med and Red Sea 
    499             DO jk = 1, 17 
    500                zhfac (jk) = 0.5_wp * (  1._wp - COS( rpi * REAL(jk-1,wp) / 16._wp )  ) / rday 
    501             END DO 
    502             DO jk = 18, jpkm1 
    503                zhfac (jk) = 1._wp / rday 
    504             END DO 
    505             !                                        ! ======================= 
    506          CASE ( 2 )                                  !  ORCA_R2 configuration  
    507             !                                        ! ======================= 
    508             ij0 =  96   ;   ij1 = 110                    ! Mediterranean Sea 
    509             ii0 = 157   ;   ii1 = 181   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp 
    510             ij0 = 100   ;   ij1 = 110 
    511             ii0 = 144   ;   ii1 = 156   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp 
    512             ij0 = 100   ;   ij1 = 103 
    513             ii0 = 139   ;   ii1 = 143   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp 
    514             ! 
    515             ij0 = 101   ;   ij1 = 102                    ! Decrease before Gibraltar Strait 
    516             ii0 = 139   ;   ii1 = 141   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0._wp 
    517             ii0 = 142   ;   ii1 = 142   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp / 90._wp 
    518             ii0 = 143   ;   ii1 = 143   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0.40_wp 
    519             ii0 = 144   ;   ii1 = 144   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0.75_wp 
    520             ! 
    521             ij0 =  87   ;   ij1 =  96                    ! Red Sea 
    522             ii0 = 147   ;   ii1 = 163   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp 
    523             ! 
    524             ij0 =  91   ;   ij1 =  91                    ! Decrease before Bab el Mandeb Strait 
    525             ii0 = 153   ;   ii1 = 160   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0.80_wp 
    526             ij0 =  90   ;   ij1 =  90 
    527             ii0 = 153   ;   ii1 = 160   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0.40_wp 
    528             ij0 =  89   ;   ij1 =  89 
    529             ii0 = 158   ;   ii1 = 160   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp / 90._wp 
    530             ij0 =  88   ;   ij1 =  88 
    531             ii0 = 160   ;   ii1 = 163   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0._wp 
    532             ! Smooth transition from 0 at surface to 1./rday at the 18th level in Med and Red Sea 
    533             DO jk = 1, 17 
    534                zhfac (jk) = 0.5_wp * (  1._wp - COS( rpi * REAL(jk-1,wp) / 16._wp )  ) / rday 
    535             END DO 
    536             DO jk = 18, jpkm1 
    537                zhfac (jk) = 1._wp / rday 
    538             END DO 
    539             !                                        ! ======================= 
    540          CASE ( 05 )                                 !  ORCA_R05 configuration 
    541             !                                        ! ======================= 
    542             ii0 = 568   ;   ii1 = 574                    ! Mediterranean Sea 
    543             ij0 = 324   ;   ij1 = 333   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp 
    544             ii0 = 575   ;   ii1 = 658 
    545             ij0 = 314   ;   ij1 = 366   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp 
    546             ! 
    547             ii0 = 641   ;   ii1 = 651                    ! Black Sea (remaining part 
    548             ij0 = 367   ;   ij1 = 372   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp 
    549             ! 
    550             ij0 = 324   ;   ij1 = 333                    ! Decrease before Gibraltar Strait 
    551             ii0 = 565   ;   ii1 = 565   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp / 90._wp 
    552             ii0 = 566   ;   ii1 = 566   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0.40_wp 
    553             ii0 = 567   ;   ii1 = 567   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0.75_wp 
    554             ! 
    555             ii0 = 641   ;   ii1 = 665                    ! Red Sea 
    556             ij0 = 270   ;   ij1 = 310   ;   zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp 
    557             ! 
    558             ii0 = 666   ;   ii1 = 675                    ! Decrease before Bab el Mandeb Strait 
    559             ij0 = 270   ;   ij1 = 290    
    560             DO ji = mi0(ii0), mi1(ii1) 
    561                zmrs( ji , mj0(ij0):mj1(ij1) ) = 0.1_wp * ABS( FLOAT(ji - mi1(ii1)) ) 
    562             END DO  
    563             zsdmp = 1._wp / ( pn_surf * rday ) 
    564             zbdmp = 1._wp / ( pn_bot  * rday ) 
    565             DO jk = 1, jpk 
    566                zhfac(jk) = (  zbdmp + (zsdmp-zbdmp) * EXP( -fsdept(1,1,jk)/pn_dep )  ) 
    567             END DO 
    568             !                                       ! ======================== 
    569          CASE ( 025 )                               !  ORCA_R025 configuration  
    570             !                                       ! ======================== 
    571             CALL ctl_stop( ' Not yet implemented in ORCA_R025' ) 
    572             ! 
    573          END SELECT 
    574  
    575          DO jk = 1, jpkm1 
    576             presto(:,:,jk) = zmrs(:,:) * zhfac(jk) + ( 1._wp - zmrs(:,:) ) * presto(:,:,jk) 
    577          END DO 
    578  
    579          ! Mask resto array and set to 0 first and last levels 
    580          presto(:,:, : ) = presto(:,:,:) * tmask(:,:,:) 
    581          presto(:,:, 1 ) = 0._wp 
    582          presto(:,:,jpk) = 0._wp 
    583          !                         !--------------------! 
    584       ELSE                         !     No damping     ! 
    585          !                         !--------------------! 
    586          CALL ctl_stop( 'Choose a correct value of nn_hdmp or put ln_tradmp to FALSE' ) 
    587       ENDIF 
    588 #endif 
    589  
    590       !                            !--------------------------------! 
    591       IF( kn_file == 1 ) THEN      !  save damping coef. in a file  ! 
    592          !                         !--------------------------------! 
    593          IF(lwp) WRITE(numout,*) '              create damping.coeff.nc file' 
    594          IF( cdtype == 'TRA' ) cfile = 'damping.coeff' 
    595          IF( cdtype == 'TRC' ) cfile = 'damping.coeff.trc' 
    596          IF( cdtype == 'DYN' ) cfile = 'damping.coeff.dyn' 
    597          cfile = TRIM( cfile ) 
    598          CALL iom_open  ( cfile, inum0, ldwrt = .TRUE., kiolib = jprstlib ) 
    599          CALL iom_rstput( 0, 0, inum0, 'Resto', presto ) 
    600          CALL iom_close ( inum0 ) 
    601       ENDIF 
    602       ! 
    603       CALL wrk_dealloc( jpk, zhfac) 
    604       CALL wrk_dealloc( jpi, jpj, zmrs ) 
    605       CALL wrk_dealloc( jpi, jpj, jpk, zdct ) 
    606       ! 
    607       IF( nn_timing == 1 )  CALL timing_stop('dtacof') 
    608       ! 
    609    END SUBROUTINE dtacof 
    610  
    611  
    612    SUBROUTINE cofdis( pdct ) 
    613       !!---------------------------------------------------------------------- 
    614       !!                 ***  ROUTINE cofdis  *** 
    615       !! 
    616       !! ** Purpose :   Compute the distance between ocean T-points and the 
    617       !!      ocean model coastlines. Save the distance in a NetCDF file. 
    618       !! 
    619       !! ** Method  :   For each model level, the distance-to-coast is  
    620       !!      computed as follows :  
    621       !!       - The coastline is defined as the serie of U-,V-,F-points 
    622       !!      that are at the ocean-land bound. 
    623       !!       - For each ocean T-point, the distance-to-coast is then  
    624       !!      computed as the smallest distance (on the sphere) between the  
    625       !!      T-point and all the coastline points. 
    626       !!       - For land T-points, the distance-to-coast is set to zero. 
    627       !!      C A U T I O N : Computation not yet implemented in mpp case. 
    628       !! 
    629       !! ** Action  : - pdct, distance to the coastline (argument) 
    630       !!              - NetCDF file 'dist.coast.nc'  
    631       !!---------------------------------------------------------------------- 
    632       USE ioipsl      ! IOipsl librairy 
    633       !! 
    634       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( out ) ::   pdct   ! distance to the coastline 
    635       !! 
    636       INTEGER ::   ji, jj, jk, jl   ! dummy loop indices 
    637       INTEGER ::   iju, ijt, icoast, itime, ierr, icot   ! local integers 
    638       CHARACTER (len=32) ::   clname                     ! local name 
    639       REAL(wp) ::   zdate0                               ! local scalar 
    640       REAL(wp), POINTER, DIMENSION(:,:) ::  zxt, zyt, zzt, zmask 
    641       REAL(wp), POINTER, DIMENSION(:  ) ::  zxc, zyc, zzc, zdis    ! temporary workspace 
    642       LOGICAL , ALLOCATABLE, DIMENSION(:,:) ::  llcotu, llcotv, llcotf   ! 2D logical workspace 
    643       !!---------------------------------------------------------------------- 
    644       ! 
    645       IF( nn_timing == 1 )  CALL timing_start('cofdis') 
    646       ! 
    647       CALL wrk_alloc( jpi, jpj , zxt, zyt, zzt, zmask    ) 
    648       CALL wrk_alloc( 3*jpi*jpj, zxc, zyc, zzc, zdis     ) 
    649       ALLOCATE( llcotu(jpi,jpj), llcotv(jpi,jpj), llcotf(jpi,jpj)  ) 
    650       ! 
    651       IF( lk_mpp    )   CALL mpp_sum( ierr ) 
    652       IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'cofdis: requested local arrays unavailable') 
    653  
    654       ! 0. Initialization 
    655       ! ----------------- 
    656       IF(lwp) WRITE(numout,*) 
    657       IF(lwp) WRITE(numout,*) 'cofdis : compute the distance to coastline' 
    658       IF(lwp) WRITE(numout,*) '~~~~~~' 
    659       IF(lwp) WRITE(numout,*) 
    660       IF( lk_mpp ) & 
    661            & CALL ctl_stop('         Computation not yet implemented with key_mpp_...', & 
    662            &               '         Rerun the code on another computer or ', & 
    663            &               '         create the "dist.coast.nc" file using IDL' ) 
    664  
    665       pdct(:,:,:) = 0._wp 
    666       zxt(:,:) = COS( rad * gphit(:,:) ) * COS( rad * glamt(:,:) ) 
    667       zyt(:,:) = COS( rad * gphit(:,:) ) * SIN( rad * glamt(:,:) ) 
    668       zzt(:,:) = SIN( rad * gphit(:,:) ) 
    669  
    670  
    671       ! 1. Loop on vertical levels 
    672       ! -------------------------- 
    673       !                                                ! =============== 
    674       DO jk = 1, jpkm1                                 ! Horizontal slab 
    675          !                                             ! =============== 
    676          ! Define the coastline points (U, V and F) 
    677          DO jj = 2, jpjm1 
    678             DO ji = 2, jpim1 
    679                zmask(ji,jj) =  ( tmask(ji,jj+1,jk) + tmask(ji+1,jj+1,jk) & 
    680                    &           + tmask(ji,jj  ,jk) + tmask(ji+1,jj  ,jk) ) 
    681                llcotu(ji,jj) = ( tmask(ji,jj,  jk) + tmask(ji+1,jj  ,jk) == 1._wp )  
    682                llcotv(ji,jj) = ( tmask(ji,jj  ,jk) + tmask(ji  ,jj+1,jk) == 1._wp )  
    683                llcotf(ji,jj) = ( zmask(ji,jj) > 0._wp ) .AND. ( zmask(ji,jj) < 4._wp ) 
    684             END DO 
    685          END DO 
    686  
    687          ! Lateral boundaries conditions 
    688          llcotu(:, 1 ) = umask(:,  2  ,jk) == 1 
    689          llcotu(:,jpj) = umask(:,jpjm1,jk) == 1 
    690          llcotv(:, 1 ) = vmask(:,  2  ,jk) == 1 
    691          llcotv(:,jpj) = vmask(:,jpjm1,jk) == 1 
    692          llcotf(:, 1 ) = fmask(:,  2  ,jk) == 1 
    693          llcotf(:,jpj) = fmask(:,jpjm1,jk) == 1 
    694  
    695          IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN 
    696             llcotu( 1 ,:) = llcotu(jpim1,:) 
    697             llcotu(jpi,:) = llcotu(  2  ,:) 
    698             llcotv( 1 ,:) = llcotv(jpim1,:) 
    699             llcotv(jpi,:) = llcotv(  2  ,:) 
    700             llcotf( 1 ,:) = llcotf(jpim1,:) 
    701             llcotf(jpi,:) = llcotf(  2  ,:) 
    702          ELSE 
    703             llcotu( 1 ,:) = umask(  2  ,:,jk) == 1 
    704             llcotu(jpi,:) = umask(jpim1,:,jk) == 1 
    705             llcotv( 1 ,:) = vmask(  2  ,:,jk) == 1 
    706             llcotv(jpi,:) = vmask(jpim1,:,jk) == 1 
    707             llcotf( 1 ,:) = fmask(  2  ,:,jk) == 1 
    708             llcotf(jpi,:) = fmask(jpim1,:,jk) == 1 
    709          ENDIF 
    710          IF( nperio == 3 .OR. nperio == 4 ) THEN 
    711             DO ji = 1, jpim1 
    712                iju = jpi - ji + 1 
    713                llcotu(ji,jpj  ) = llcotu(iju,jpj-2) 
    714                llcotf(ji,jpjm1) = llcotf(iju,jpj-2) 
    715                llcotf(ji,jpj  ) = llcotf(iju,jpj-3) 
    716             END DO 
    717             DO ji = jpi/2, jpim1 
    718                iju = jpi - ji + 1 
    719                llcotu(ji,jpjm1) = llcotu(iju,jpjm1) 
    720             END DO 
    721             DO ji = 2, jpi 
    722                ijt = jpi - ji + 2 
    723                llcotv(ji,jpjm1) = llcotv(ijt,jpj-2) 
    724                llcotv(ji,jpj  ) = llcotv(ijt,jpj-3) 
    725             END DO 
    726          ENDIF 
    727          IF( nperio == 5 .OR. nperio == 6 ) THEN 
    728             DO ji = 1, jpim1 
    729                iju = jpi - ji 
    730                llcotu(ji,jpj  ) = llcotu(iju,jpjm1) 
    731                llcotf(ji,jpj  ) = llcotf(iju,jpj-2) 
    732             END DO 
    733             DO ji = jpi/2, jpim1 
    734                iju = jpi - ji 
    735                llcotf(ji,jpjm1) = llcotf(iju,jpjm1) 
    736             END DO 
    737             DO ji = 1, jpi 
    738                ijt = jpi - ji + 1 
    739                llcotv(ji,jpj  ) = llcotv(ijt,jpjm1) 
    740             END DO 
    741             DO ji = jpi/2+1, jpi 
    742                ijt = jpi - ji + 1 
    743                llcotv(ji,jpjm1) = llcotv(ijt,jpjm1) 
    744             END DO 
    745          ENDIF 
    746  
    747          ! Compute cartesian coordinates of coastline points 
    748          ! and the number of coastline points 
    749          icoast = 0 
    750          DO jj = 1, jpj 
    751             DO ji = 1, jpi 
    752                IF( llcotf(ji,jj) ) THEN 
    753                   icoast = icoast + 1 
    754                   zxc(icoast) = COS( rad*gphif(ji,jj) ) * COS( rad*glamf(ji,jj) ) 
    755                   zyc(icoast) = COS( rad*gphif(ji,jj) ) * SIN( rad*glamf(ji,jj) ) 
    756                   zzc(icoast) = SIN( rad*gphif(ji,jj) ) 
    757                ENDIF 
    758                IF( llcotu(ji,jj) ) THEN 
    759                   icoast = icoast+1 
    760                   zxc(icoast) = COS( rad*gphiu(ji,jj) ) * COS( rad*glamu(ji,jj) ) 
    761                   zyc(icoast) = COS( rad*gphiu(ji,jj) ) * SIN( rad*glamu(ji,jj) ) 
    762                   zzc(icoast) = SIN( rad*gphiu(ji,jj) ) 
    763                ENDIF 
    764                IF( llcotv(ji,jj) ) THEN 
    765                   icoast = icoast+1 
    766                   zxc(icoast) = COS( rad*gphiv(ji,jj) ) * COS( rad*glamv(ji,jj) ) 
    767                   zyc(icoast) = COS( rad*gphiv(ji,jj) ) * SIN( rad*glamv(ji,jj) ) 
    768                   zzc(icoast) = SIN( rad*gphiv(ji,jj) ) 
    769                ENDIF 
    770             END DO 
    771          END DO 
    772  
    773          ! Distance for the T-points 
    774          DO jj = 1, jpj 
    775             DO ji = 1, jpi 
    776                IF( tmask(ji,jj,jk) == 0._wp ) THEN 
    777                   pdct(ji,jj,jk) = 0._wp 
    778                ELSE 
    779                   DO jl = 1, icoast 
    780                      zdis(jl) = ( zxt(ji,jj) - zxc(jl) )**2   & 
    781                         &     + ( zyt(ji,jj) - zyc(jl) )**2   & 
    782                         &     + ( zzt(ji,jj) - zzc(jl) )**2 
    783                   END DO 
    784                   pdct(ji,jj,jk) = ra * SQRT( MINVAL( zdis(1:icoast) ) ) 
    785                ENDIF 
    786             END DO 
    787          END DO 
    788          !                                                ! =============== 
    789       END DO                                              !   End of slab 
    790       !                                                   ! =============== 
    791  
    792  
    793       ! 2. Create the  distance to the coast file in NetCDF format 
    794       ! ----------------------------------------------------------     
    795       clname = 'dist.coast' 
    796       itime  = 0 
    797       CALL ymds2ju( 0     , 1       , 1     , 0._wp , zdate0 ) 
    798       CALL restini( 'NONE', jpi     , jpj   , glamt, gphit ,   & 
    799          &          jpk   , gdept_1d, clname, itime, zdate0,   & 
    800          &          rdt   , icot                         ) 
    801       CALL restput( icot, 'Tcoast', jpi, jpj, jpk, 0, pdct ) 
    802       CALL restclo( icot ) 
    803       ! 
    804       CALL wrk_dealloc( jpi, jpj , zxt, zyt, zzt, zmask    ) 
    805       CALL wrk_dealloc( 3*jpi*jpj, zxc, zyc, zzc, zdis     ) 
    806       DEALLOCATE( llcotu, llcotv, llcotf  ) 
    807       ! 
    808       IF( nn_timing == 1 )  CALL timing_stop('cofdis') 
    809       ! 
    810    END SUBROUTINE cofdis 
    811    !!====================================================================== 
    812249END MODULE tradmp 

  • branches/2014/dev_r4650_UKMO14.5_SST_BIAS_CORRECTION/NEMOGCM/NEMO/OPA_SRC/TRA/traldf.F90

    r4488 r5965  
    2323   USE traldf_iso_grif ! lateral mixing          (tra_ldf_iso_grif routine) 
    2424   USE traldf_lap      ! lateral mixing               (tra_ldf_lap routine) 
    25    USE trdmod_oce      ! ocean space and time domain 
    26    USE trdtra          ! ocean active tracers trends 
     25   USE trd_oce         ! trends: ocean variables 
     26   USE trdtra          ! trends manager: tracers  
     27   ! 
    2728   USE prtctl          ! Print control 
    2829   USE in_out_manager  ! I/O manager 
    … …  
    3536   PRIVATE 
    3637 
    37    PUBLIC   tra_ldf         ! called by step.F90  
    38    PUBLIC   tra_ldf_init    ! called by opa.F90  
     38   PUBLIC   tra_ldf        ! called by step.F90  
     39   PUBLIC   tra_ldf_init   ! called by opa.F90  
    3940   ! 
    4041   INTEGER ::   nldf = 0   ! type of lateral diffusion used defined from ln_traldf_... namlist logicals) 
    … …  
    7576 
    7677      SELECT CASE ( nldf )                       ! compute lateral mixing trend and add it to the general trend 
    77       CASE ( 0 )   ;   CALL tra_ldf_lap     ( kt, nit000, 'TRA', gtsu, gtsv, tsb, tsa, jpts        )  ! iso-level laplacian 
     78      CASE ( 0 )   ;   CALL tra_ldf_lap     ( kt, nit000, 'TRA', gtsu, gtsv, gtui, gtvi,        & 
     79                               &                                   tsb, tsa, jpts        )  ! iso-level laplacian 
    7880      CASE ( 1 )                                                                              ! rotated laplacian 
    7981         IF( ln_traldf_grif ) THEN                                                           
    8082                       CALL tra_ldf_iso_grif( kt, nit000,'TRA', gtsu, gtsv, tsb, tsa, jpts, ahtb0 )      ! Griffies operator 
    8183         ELSE                                                                                 
    82                        CALL tra_ldf_iso     ( kt, nit000, 'TRA', gtsu, gtsv, tsb, tsa, jpts, ahtb0 )      ! Madec operator 
    83          ENDIF 
    84       CASE ( 2 )   ;   CALL tra_ldf_bilap   ( kt, nit000, 'TRA', gtsu, gtsv, tsb, tsa, jpts        )  ! iso-level bilaplacian 
     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 
    8589      CASE ( 3 )   ;   CALL tra_ldf_bilapg  ( kt, nit000, 'TRA',             tsb, tsa, jpts        )  ! s-coord. geopot. bilap. 
    8690         ! 
    8791      CASE ( -1 )                                ! esopa: test all possibility with control print 
    88          CALL tra_ldf_lap   ( kt, nit000, 'TRA', gtsu, gtsv, tsb, tsa, jpts        )  
     92         CALL tra_ldf_lap   ( kt, nit000, 'TRA', gtsu, gtsv, gtui, gtvi,        & 
     93         &                                       tsb, tsa, jpts        )  
    8994         CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' ldf0 - Ta: ', mask1=tmask,               & 
    9095         &             tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    … …  
    9297            CALL tra_ldf_iso_grif( kt, nit000, 'TRA', gtsu, gtsv, tsb, tsa, jpts, ahtb0 ) 
    9398         ELSE 
    94             CALL tra_ldf_iso     ( kt, nit000, 'TRA', gtsu, gtsv, tsb, tsa, jpts, ahtb0 )   
     99            CALL tra_ldf_iso     ( kt, nit000, 'TRA', gtsu, gtsv, gtui, gtvi,        & 
     100            &                                               tsb, tsa, jpts, ahtb0 )   
    95101         ENDIF 
    96102         CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' ldf1 - Ta: ', mask1=tmask,               & 
    97103         &             tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    98          CALL tra_ldf_bilap ( kt, nit000, 'TRA', gtsu, gtsv, tsb, tsa, jpts        )  
     104         CALL tra_ldf_bilap ( kt, nit000, 'TRA', gtsu, gtsv, gtui, gtvi,        & 
     105         &                                       tsb, tsa, jpts        )  
    99106         CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' ldf2 - Ta: ', mask1=tmask,               & 
    100107         &             tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    … …  
    112119         ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 
    113120         ztrds(:,:,:) = tsa(:,:,:,jp_sal) - ztrds(:,:,:) 
    114          CALL trd_tra( kt, 'TRA', jp_tem, jptra_trd_ldf, ztrdt ) 
    115          CALL trd_tra( kt, 'TRA', jp_sal, jptra_trd_ldf, ztrds ) 
     121         CALL trd_tra( kt, 'TRA', jp_tem, jptra_ldf, ztrdt ) 
     122         CALL trd_tra( kt, 'TRA', jp_sal, jptra_ldf, ztrds ) 
    116123         CALL wrk_dealloc( jpi, jpj, jpk, ztrdt, ztrds )  
    117124      ENDIF 
    … …  
    174181            IF ( ln_traldf_iso   )   nldf = 1      ! isoneutral (   rotation) 
    175182         ENDIF 
    176          IF ( ln_zps ) THEN             ! z-coordinate 
     183         IF ( ln_zps ) THEN             ! zps-coordinate 
    177184            IF ( ln_traldf_level )   ierr = 1      ! iso-level not allowed 
    178185            IF ( ln_traldf_hor   )   nldf = 0      ! horizontal (no rotation) 
    179186            IF ( ln_traldf_iso   )   nldf = 1      ! isoneutral (   rotation) 
    180187         ENDIF 
    181          IF ( ln_sco ) THEN             ! z-coordinate 
     188         IF ( ln_sco ) THEN             ! s-coordinate 
    182189            IF ( ln_traldf_level )   nldf = 0      ! iso-level  (no rotation) 
    183190            IF ( ln_traldf_hor   )   nldf = 1      ! horizontal (   rotation) 
    … …  
    192199            IF ( ln_traldf_iso   )   ierr = 2      ! isoneutral (   rotation) 
    193200         ENDIF 
    194          IF ( ln_zps ) THEN             ! z-coordinate 
     201         IF ( ln_zps ) THEN             ! zps-coordinate 
    195202            IF ( ln_traldf_level )   ierr = 1      ! iso-level not allowed  
    196203            IF ( ln_traldf_hor   )   nldf = 2      ! horizontal (no rotation) 
    197204            IF ( ln_traldf_iso   )   ierr = 2      ! isoneutral (   rotation) 
    198205         ENDIF 
    199          IF ( ln_sco ) THEN             ! z-coordinate 
     206         IF ( ln_sco ) THEN             ! s-coordinate 
    200207            IF ( ln_traldf_level )   nldf = 2      ! iso-level  (no rotation) 
    201208            IF ( ln_traldf_hor   )   nldf = 3      ! horizontal (   rotation) 
    … …  
    283290      IF(lwp) WRITE(numout,*) '              homogeneous ocean T = ', zt0, ' S = ',zs0 
    284291 
     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 
    285297      !                                        ! T & S profile (to be coded +namelist parameter 
    286298 

  • branches/2014/dev_r4650_UKMO14.5_SST_BIAS_CORRECTION/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_bilap.F90

    r4292 r5965  
    4949CONTAINS 
    5050  
    51    SUBROUTINE tra_ldf_bilap( kt, kit000, cdtype, pgu, pgv,      & 
     51   SUBROUTINE tra_ldf_bilap( kt, kit000, cdtype, pgu, pgv,            & 
     52      &                                          pgui, pgvi,          & 
    5253      &                                  ptb, pta, kjpt )   
    5354      !!---------------------------------------------------------------------- 
    … …  
    8283      CHARACTER(len=3)                     , INTENT(in   ) ::   cdtype     ! =TRA or TRC (tracer indicator) 
    8384      INTEGER                              , INTENT(in   ) ::   kjpt       ! number of tracers 
    84       REAL(wp), DIMENSION(jpi,jpj,    kjpt), INTENT(in   ) ::   pgu, pgv   ! tracer gradient at pstep levels 
     85      REAL(wp), DIMENSION(jpi,jpj,    kjpt), INTENT(in   ) ::   pgu , pgv  ! tracer gradient at pstep levels 
     86      REAL(wp), DIMENSION(jpi,jpj,    kjpt), INTENT(in   ) ::   pgui, pgvi ! tracer gradient at pstep levels 
    8587      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb        ! before and now tracer fields 
    8688      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta        ! tracer trend  
    … …  
    114116               END DO 
    115117            END DO 
    116  
    117118            !                          !==  Laplacian  ==! 
    118119            ! 
    … …  
    123124               END DO 
    124125            END DO 
     126            ! 
    125127            IF( ln_zps ) THEN                ! set gradient at partial step level (last ocean level) 
    126128               DO jj = 1, jpjm1 
    … …  
    131133               END DO 
    132134            ENDIF 
     135            ! (ISH) 
     136            IF( ln_zps .AND. ln_isfcav ) THEN ! set gradient at partial step level (first ocean level in a cavity) 
     137               DO jj = 1, jpjm1 
     138                  DO ji = 1, jpim1 
     139                     IF( miku(ji,jj) == MAX(jk,2) )  ztu(ji,jj,jk) = zeeu(ji,jj) * pgui(ji,jj,jn) 
     140                     IF( mikv(ji,jj) == MAX(jk,2) )  ztu(ji,jj,jk) = zeev(ji,jj) * pgvi(ji,jj,jn) 
     141                  END DO 
     142               END DO 
     143            ENDIF 
     144            ! 
    133145            DO jj = 2, jpjm1                 ! Second derivative (divergence) time the eddy diffusivity coefficient 
    134146               DO ji = fs_2, fs_jpim1   ! vector opt. 
    … …  
    161173         !                                                 
    162174         ! "zonal" mean lateral diffusive heat and salt transport 
    163          IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN   
    164            IF( jn == jp_tem )  htr_ldf(:) = ptr_vj( ztv(:,:,:) ) 
    165            IF( jn == jp_sal )  str_ldf(:) = ptr_vj( ztv(:,:,:) ) 
     175         IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
     176           IF( jn == jp_tem )  htr_ldf(:) = ptr_sj( ztv(:,:,:) ) 
     177           IF( jn == jp_sal )  str_ldf(:) = ptr_sj( ztv(:,:,:) ) 
    166178         ENDIF 
    167179         !                                                ! =========== 

  • branches/2014/dev_r4650_UKMO14.5_SST_BIAS_CORRECTION/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_bilapg.F90

    r4292 r5965  
    247247         !                                                ! =============== 
    248248         ! "Poleward" diffusive heat or salt transport 
    249          IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( kaht == 2 ) .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN 
     249         IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( kaht == 2 ) ) THEN 
    250250            ! note sign is reversed to give down-gradient diffusive transports (#1043) 
    251             IF( jn == jp_tem)   htr_ldf(:) = ptr_vj( -zftv(:,:,:) ) 
    252             IF( jn == jp_sal)   str_ldf(:) = ptr_vj( -zftv(:,:,:) ) 
     251            IF( jn == jp_tem)   htr_ldf(:) = ptr_sj( -zftv(:,:,:) ) 
     252            IF( jn == jp_sal)   str_ldf(:) = ptr_sj( -zftv(:,:,:) ) 
    253253         ENDIF 
    254254 

  • branches/2014/dev_r4650_UKMO14.5_SST_BIAS_CORRECTION/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_iso.F90

    r4292 r5965  
    2828   USE in_out_manager  ! I/O manager 
    2929   USE iom             ! I/O library 
    30 #if defined key_diaar5 
    3130   USE phycst          ! physical constants 
    3231   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    33 #endif 
    3432   USE wrk_nemo        ! Memory Allocation 
    3533   USE timing          ! Timing 
    … …  
    5250 
    5351   SUBROUTINE tra_ldf_iso( kt, kit000, cdtype, pgu, pgv,              & 
     52      &                                pgui, pgvi,                    & 
    5453      &                                ptb, pta, kjpt, pahtb0 ) 
    5554      !!---------------------------------------------------------------------- 
    … …  
    9897      CHARACTER(len=3)                     , INTENT(in   ) ::   cdtype     ! =TRA or TRC (tracer indicator) 
    9998      INTEGER                              , INTENT(in   ) ::   kjpt       ! number of tracers 
    100       REAL(wp), DIMENSION(jpi,jpj    ,kjpt), INTENT(in   ) ::   pgu, pgv   ! tracer gradient at pstep levels 
     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 
    101101      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb        ! before and now tracer fields 
    102102      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta        ! tracer trend  
    … …  
    104104      ! 
    105105      INTEGER  ::  ji, jj, jk, jn   ! dummy loop indices 
     106      INTEGER  ::  ikt 
    106107      REAL(wp) ::  zmsku, zabe1, zcof1, zcoef3   ! local scalars 
    107108      REAL(wp) ::  zmskv, zabe2, zcof2, zcoef4   !   -      - 
    108109      REAL(wp) ::  zcoef0, zbtr, ztra            !   -      - 
    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, ztfw  
     110      REAL(wp), POINTER, DIMENSION(:,:  ) ::  z2d 
     111      REAL(wp), POINTER, DIMENSION(:,:,:) ::  zdkt, zdk1t, zdit, zdjt, ztfw  
    114112      !!---------------------------------------------------------------------- 
    115113      ! 
    116114      IF( nn_timing == 1 )  CALL timing_start('tra_ldf_iso') 
    117115      ! 
    118       CALL wrk_alloc( jpi, jpj,      zdkt, zdk1t, z2d )  
    119       CALL wrk_alloc( jpi, jpj, jpk, zdit, zdjt, ztfw  )  
     116      CALL wrk_alloc( jpi, jpj,      z2d )  
     117      CALL wrk_alloc( jpi, jpj, jpk, zdit, zdjt, ztfw, zdkt, zdk1t )  
    120118      ! 
    121119 
    … …  
    147145            END DO 
    148146         END DO 
     147 
     148         ! partial cell correction 
    149149         IF( ln_zps ) THEN      ! partial steps correction at the last ocean level  
    150150            DO jj = 1, jpjm1 
    151151               DO ji = 1, fs_jpim1   ! vector opt. 
     152! IF useless if zpshde defines pgu everywhere 
    152153                  zdit(ji,jj,mbku(ji,jj)) = pgu(ji,jj,jn)           
    153                   zdjt(ji,jj,mbkv(ji,jj)) = pgv(ji,jj,jn)       
     154                  zdjt(ji,jj,mbkv(ji,jj)) = pgv(ji,jj,jn) 
    154155               END DO 
    155156            END DO 
    156157         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 
     160               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 
    157166 
    158167         !!---------------------------------------------------------------------- 
    159168         !!   II - horizontal trend  (full) 
    160169         !!---------------------------------------------------------------------- 
    161 !CDIR PARALLEL DO PRIVATE( zdk1t )  
    162          !                                                ! =============== 
    163          DO jk = 1, jpkm1                                 ! Horizontal slab 
    164             !                                             ! =============== 
     170!!!!!!!!!!CDIR PARALLEL DO PRIVATE( zdk1t )  
    165171            ! 1. Vertical tracer gradient at level jk and jk+1 
    166172            ! ------------------------------------------------ 
    167             ! surface boundary condition: zdkt(jk=1)=zdkt(jk=2) 
    168             zdk1t(:,:) = ( ptb(:,:,jk,jn) - ptb(:,:,jk+1,jn) ) * tmask(:,:,jk+1) 
    169             ! 
    170             IF( jk == 1 ) THEN   ;   zdkt(:,:) = zdk1t(:,:) 
    171             ELSE                 ;   zdkt(:,:) = ( ptb(:,:,jk-1,jn) - ptb(:,:,jk,jn) ) * tmask(:,:,jk) 
    172             ENDIF 
    173  
    174             ! 2. Horizontal fluxes 
    175             ! --------------------    
     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 
    176200            DO jj = 1 , jpjm1 
    177201               DO ji = 1, fs_jpim1   ! vector opt. 
    … …  
    189213                  ! 
    190214                  zftu(ji,jj,jk ) = (  zabe1 * zdit(ji,jj,jk)   & 
    191                      &              + zcof1 * (  zdkt (ji+1,jj) + zdk1t(ji,jj)      & 
    192                      &                         + zdk1t(ji+1,jj) + zdkt (ji,jj)  )  ) * umask(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) 
    193217                  zftv(ji,jj,jk) = (  zabe2 * zdjt(ji,jj,jk)   & 
    194                      &              + zcof2 * (  zdkt (ji,jj+1) + zdk1t(ji,jj)      & 
    195                      &                         + zdk1t(ji,jj+1) + zdkt (ji,jj)  )  ) * vmask(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)                   
    196220               END DO 
    197221            END DO 
    … …  
    211235         ! 
    212236         ! "Poleward" diffusive heat or salt transports (T-S case only) 
    213          IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN 
     237         IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 
    214238            ! note sign is reversed to give down-gradient diffusive transports (#1043) 
    215             IF( jn == jp_tem)   htr_ldf(:) = ptr_vj( -zftv(:,:,:) ) 
    216             IF( jn == jp_sal)   str_ldf(:) = ptr_vj( -zftv(:,:,:) ) 
     239            IF( jn == jp_tem)   htr_ldf(:) = ptr_sj( -zftv(:,:,:) ) 
     240            IF( jn == jp_sal)   str_ldf(:) = ptr_sj( -zftv(:,:,:) ) 
    217241         ENDIF 
    218242  
    219 #if defined key_diaar5 
    220          IF( cdtype == 'TRA' .AND. jn == jp_tem  ) THEN 
    221             z2d(:,:) = 0._wp  
    222             ! note sign is reversed to give down-gradient diffusive transports (#1043) 
    223             zztmp = -1.0_wp * rau0 * rcp 
    224             DO jk = 1, jpkm1 
    225                DO jj = 2, jpjm1 
    226                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    227                      z2d(ji,jj) = z2d(ji,jj) + zftu(ji,jj,jk)  
     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 
    228252                  END DO 
    229253               END DO 
    230             END DO 
    231             z2d(:,:) = zztmp * z2d(:,:) 
    232             CALL lbc_lnk( z2d, 'U', -1. ) 
    233             CALL iom_put( "udiff_heattr", z2d )                  ! heat transport in i-direction 
    234             z2d(:,:) = 0._wp  
    235             DO jk = 1, jpkm1 
    236                DO jj = 2, jpjm1 
    237                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    238                      z2d(ji,jj) = z2d(ji,jj) + zftv(ji,jj,jk)  
     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 
    239264                  END DO 
    240265               END DO 
    241             END DO 
    242             z2d(:,:) = zztmp * z2d(:,:) 
    243             CALL lbc_lnk( z2d, 'V', -1. ) 
    244             CALL iom_put( "vdiff_heattr", z2d )                  !  heat transport in i-direction 
    245          END IF 
    246 #endif 
     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 
    247272 
    248273         !!---------------------------------------------------------------------- 
    … …  
    264289            DO jj = 2, jpjm1 
    265290               DO ji = fs_2, fs_jpim1   ! vector opt. 
    266                   zcoef0 = - fsahtw(ji,jj,jk) * tmask(ji,jj,jk) 
     291                  zcoef0 = - fsahtw(ji,jj,jk) * wmask(ji,jj,jk) 
    267292                  ! 
    268293                  zmsku = 1./MAX(   umask(ji  ,jj,jk-1) + umask(ji-1,jj,jk)      & 
    … …  
    297322      END DO 
    298323      ! 
    299       CALL wrk_dealloc( jpi, jpj,      zdkt, zdk1t, z2d )  
    300       CALL wrk_dealloc( jpi, jpj, jpk, zdit, zdjt, ztfw  )  
     324      CALL wrk_dealloc( jpi, jpj, z2d )  
     325      CALL wrk_dealloc( jpi, jpj, jpk, zdit, zdjt, ztfw, zdkt, zdk1t )  
    301326      ! 
    302327      IF( nn_timing == 1 )  CALL timing_stop('tra_ldf_iso') 
    … …  
    309334   !!---------------------------------------------------------------------- 
    310335CONTAINS 
    311    SUBROUTINE tra_ldf_iso( kt, kit000,cdtype, pgu, pgv, ptb, pta, kjpt, pahtb0 )      ! Empty routine 
     336   SUBROUTINE tra_ldf_iso( kt, kit000,cdtype, pgu, pgv, pgui, pgvi, ptb, pta, kjpt, pahtb0 )      ! Empty routine 
    312337      INTEGER:: kt, kit000 
    313338      CHARACTER(len=3) ::   cdtype 
    314       REAL, DIMENSION(:,:,:) ::   pgu, pgv   ! tracer gradient at pstep levels 
     339      REAL, DIMENSION(:,:,:) ::   pgu, pgv, pgui, pgvi    ! tracer gradient at pstep levels 
    315340      REAL, DIMENSION(:,:,:,:) ::   ptb, pta 
    316341      WRITE(*,*) 'tra_ldf_iso: You should not have seen this print! error?', kt, kit000, cdtype,   & 

  • branches/2014/dev_r4650_UKMO14.5_SST_BIAS_CORRECTION/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_iso_grif.F90

    r3632 r5965  
    113113      REAL(wp) ::   ze1ur, zdxt, ze2vr, ze3wr, zdyt, zdzt 
    114114      REAL(wp) ::   zah, zah_slp, zaei_slp 
    115 #if defined key_diaar5 
    116       REAL(wp) ::   zztmp              ! local scalar 
    117 #endif 
    118115      REAL(wp), POINTER, DIMENSION(:,:  ) :: z2d 
    119116      REAL(wp), POINTER, DIMENSION(:,:,:) :: zdit, zdjt, ztfw  
    … …  
    207204      END DO 
    208205      ! 
    209 #if defined key_iomput 
    210       IF( ln_traldf_gdia .AND. cdtype == 'TRA' ) THEN 
    211          CALL wrk_alloc( jpi , jpj , jpk  , zw3d ) 
    212          DO jk=1,jpkm1 
    213             zw3d(:,:,jk) = (psix_eiv(:,:,jk+1) - psix_eiv(:,:,jk))/fse3u(:,:,jk)  ! u_eiv = -dpsix/dz 
    214          END DO 
    215          zw3d(:,:,jpk) = 0._wp 
    216          CALL iom_put( "uoce_eiv", zw3d )    ! i-eiv current 
    217  
    218          DO jk=1,jpk-1 
    219             zw3d(:,:,jk) = (psiy_eiv(:,:,jk+1) - psiy_eiv(:,:,jk))/fse3v(:,:,jk)  ! v_eiv = -dpsiy/dz 
    220          END DO 
    221          zw3d(:,:,jpk) = 0._wp 
    222          CALL iom_put( "voce_eiv", zw3d )    ! j-eiv current 
    223  
    224          DO jk=1,jpk-1 
    225             DO jj = 2, jpjm1 
    226                DO ji = fs_2, fs_jpim1  ! vector opt. 
    227                   zw3d(ji,jj,jk) = (psiy_eiv(ji,jj,jk) - psiy_eiv(ji,jj-1,jk))/e2t(ji,jj) + & 
    228                        &    (psix_eiv(ji,jj,jk) - psix_eiv(ji-1,jj,jk))/e1t(ji,jj) ! w_eiv = dpsiy/dy + dpsiy/dx 
    229                END DO 
    230             END DO 
    231          END DO 
    232          zw3d(:,:,jpk) = 0._wp 
    233          CALL iom_put( "woce_eiv", zw3d )    ! vert. eiv current 
    234          CALL wrk_dealloc( jpi , jpj , jpk  , zw3d ) 
     206      IF( iom_use("uoce_eiv") .OR. iom_use("voce_eiv") .OR. iom_use("woce_eiv") )  THEN 
     207         ! 
     208         IF( ln_traldf_gdia .AND. cdtype == 'TRA' ) THEN 
     209            CALL wrk_alloc( jpi , jpj , jpk  , zw3d ) 
     210            DO jk=1,jpkm1 
     211               zw3d(:,:,jk) = (psix_eiv(:,:,jk+1) - psix_eiv(:,:,jk))/fse3u(:,:,jk)  ! u_eiv = -dpsix/dz 
     212            END DO 
     213            zw3d(:,:,jpk) = 0._wp 
     214            CALL iom_put( "uoce_eiv", zw3d )    ! i-eiv current 
     215 
     216            DO jk=1,jpk-1 
     217               zw3d(:,:,jk) = (psiy_eiv(:,:,jk+1) - psiy_eiv(:,:,jk))/fse3v(:,:,jk)  ! v_eiv = -dpsiy/dz 
     218            END DO 
     219            zw3d(:,:,jpk) = 0._wp 
     220            CALL iom_put( "voce_eiv", zw3d )    ! j-eiv current 
     221 
     222            DO jk=1,jpk-1 
     223               DO jj = 2, jpjm1 
     224                  DO ji = fs_2, fs_jpim1  ! vector opt. 
     225                     zw3d(ji,jj,jk) = (psiy_eiv(ji,jj,jk) - psiy_eiv(ji,jj-1,jk))/e2t(ji,jj) + & 
     226                          &    (psix_eiv(ji,jj,jk) - psix_eiv(ji-1,jj,jk))/e1t(ji,jj) ! w_eiv = dpsiy/dy + dpsiy/dx 
     227                  END DO 
     228               END DO 
     229            END DO 
     230            zw3d(:,:,jpk) = 0._wp 
     231            CALL iom_put( "woce_eiv", zw3d )    ! vert. eiv current 
     232            CALL wrk_dealloc( jpi , jpj , jpk  , zw3d ) 
     233         ENDIF 
     234         ! 
    235235      ENDIF 
    236 #endif 
    237236      !                                                          ! =========== 
    238237      DO jn = 1, kjpt                                            ! tracer loop 
    … …  
    252251         END DO 
    253252         IF( ln_zps.and.l_grad_zps ) THEN              ! partial steps: correction at the last level 
    254 # if defined key_vectopt_loop 
    255             DO jj = 1, 1 
    256                DO ji = 1, jpij-jpi   ! vector opt. (forced unrolling) 
    257 # else 
    258253            DO jj = 1, jpjm1 
    259254               DO ji = 1, jpim1 
    260 # endif 
    261255                  zdit(ji,jj,mbku(ji,jj)) = pgu(ji,jj,jn) 
    262256                  zdjt(ji,jj,mbkv(ji,jj)) = pgv(ji,jj,jn) 
    … …  
    392386         ! 
    393387         !                             ! "Poleward" diffusive heat or salt transports (T-S case only) 
    394          IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN 
    395             IF( jn == jp_tem)   htr_ldf(:) = ptr_vj( zftv(:,:,:) )        ! 3.3  names 
    396             IF( jn == jp_sal)   str_ldf(:) = ptr_vj( zftv(:,:,:) ) 
     388         IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 
     389            IF( jn == jp_tem)   htr_ldf(:) = ptr_sj( zftv(:,:,:) )        ! 3.3  names 
     390            IF( jn == jp_sal)   str_ldf(:) = ptr_sj( zftv(:,:,:) ) 
    397391         ENDIF 
    398392 
    399 #if defined key_diaar5 
    400          IF( cdtype == 'TRA' .AND. jn == jp_tem  ) THEN 
    401             z2d(:,:) = 0._wp 
    402             zztmp = rau0 * rcp 
    403             DO jk = 1, jpkm1 
    404                DO jj = 2, jpjm1 
    405                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    406                      z2d(ji,jj) = z2d(ji,jj) + zftu(ji,jj,jk) 
    407                   END DO 
    408                END DO 
    409             END DO 
    410             z2d(:,:) = zztmp * z2d(:,:) 
    411             CALL lbc_lnk( z2d, 'U', -1. ) 
    412             CALL iom_put( "udiff_heattr", z2d )                  ! heat transport in i-direction 
    413             z2d(:,:) = 0._wp 
    414             DO jk = 1, jpkm1 
    415                DO jj = 2, jpjm1 
    416                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    417                      z2d(ji,jj) = z2d(ji,jj) + zftv(ji,jj,jk) 
    418                   END DO 
    419                END DO 
    420             END DO 
    421             z2d(:,:) = zztmp * z2d(:,:) 
    422             CALL lbc_lnk( z2d, 'V', -1. ) 
    423             CALL iom_put( "vdiff_heattr", z2d )                  !  heat transport in j-direction 
    424          END IF 
    425 #endif 
     393         IF( iom_use("udiff_heattr") .OR. iom_use("vdiff_heattr") ) THEN 
     394           ! 
     395           IF( cdtype == 'TRA' .AND. jn == jp_tem  ) THEN 
     396               z2d(:,:) = 0._wp  
     397               DO jk = 1, jpkm1 
     398                  DO jj = 2, jpjm1 
     399                     DO ji = fs_2, fs_jpim1   ! vector opt. 
     400                        z2d(ji,jj) = z2d(ji,jj) + zftu(ji,jj,jk)  
     401                     END DO 
     402                  END DO 
     403               END DO 
     404               z2d(:,:) = rau0_rcp * z2d(:,:)  
     405               CALL lbc_lnk( z2d, 'U', -1. ) 
     406               CALL iom_put( "udiff_heattr", z2d )                  ! heat transport in i-direction 
     407               ! 
     408               z2d(:,:) = 0._wp  
     409               DO jk = 1, jpkm1 
     410                  DO jj = 2, jpjm1 
     411                     DO ji = fs_2, fs_jpim1   ! vector opt. 
     412                        z2d(ji,jj) = z2d(ji,jj) + zftv(ji,jj,jk)  
     413                     END DO 
     414                  END DO 
     415               END DO 
     416               z2d(:,:) = rau0_rcp * z2d(:,:)      
     417               CALL lbc_lnk( z2d, 'V', -1. ) 
     418               CALL iom_put( "vdiff_heattr", z2d )                  !  heat transport in i-direction 
     419            END IF 
     420            ! 
     421         ENDIF 
    426422         ! 
    427423      END DO 

  • branches/2014/dev_r4650_UKMO14.5_SST_BIAS_CORRECTION/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_lap.F90

    r4364 r5965  
    4343CONTAINS 
    4444 
    45    SUBROUTINE tra_ldf_lap( kt, kit000, cdtype, pgu, pgv,      & 
     45   SUBROUTINE tra_ldf_lap( kt, kit000, cdtype, pgu , pgv ,    & 
     46      &                                        pgui, pgvi,    & 
    4647      &                                ptb, pta, kjpt )  
    4748      !!---------------------------------------------------------------------- 
    … …  
    6970      INTEGER                              , INTENT(in   ) ::   kjpt       ! number of tracers 
    7071      REAL(wp), DIMENSION(jpi,jpj    ,kjpt), INTENT(in   ) ::   pgu, pgv   ! tracer gradient at pstep levels 
     72      REAL(wp), DIMENSION(jpi,jpj,    kjpt), INTENT(in   ) ::   pgui, pgvi ! tracer gradient at top levels 
    7173      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb        ! before and now tracer fields 
    7274      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta        ! tracer trend  
    … …  
    100102               END DO 
    101103            END DO 
    102             IF( ln_zps ) THEN      ! set gradient at partial step level 
     104            IF( ln_zps ) THEN      ! set gradient at partial step level for the last ocean cell 
    103105               DO jj = 1, jpjm1 
    104106                  DO ji = 1, fs_jpim1   ! vector opt. 
    … …  
    114116                        ztv(ji,jj,jk) = zabe2 * pgv(ji,jj,jn) 
    115117                     ENDIF 
     118                  END DO 
     119               END DO 
     120            ENDIF 
     121            ! (ISH) 
     122            IF( ln_zps .AND. ln_isfcav ) THEN      ! set gradient at partial step level for the first ocean cell 
     123                                                   ! into a cavity 
     124               DO jj = 1, jpjm1 
     125                  DO ji = 1, fs_jpim1   ! vector opt. 
     126                     ! ice shelf level level MAX(2,jk) => only where ice shelf 
     127                     iku = miku(ji,jj)  
     128                     ikv = mikv(ji,jj)  
     129                     IF( iku == MAX(2,jk) ) THEN  
     130                        zabe1 = fsahtu(ji,jj,iku) * umask(ji,jj,iku) * re2u_e1u(ji,jj) * fse3u_n(ji,jj,iku)  
     131                        ztu(ji,jj,jk) = zabe1 * pgui(ji,jj,jn)  
     132                     ENDIF  
     133                     IF( ikv == MAX(2,jk) ) THEN  
     134                        zabe2 = fsahtv(ji,jj,ikv) * vmask(ji,jj,ikv) * re1v_e2v(ji,jj) * fse3v_n(ji,jj,ikv)  
     135                        ztv(ji,jj,jk) = zabe2 * pgvi(ji,jj,jn)  
     136                     END IF  
    116137                  END DO 
    117138               END DO 
    … …  
    133154         ! 
    134155         ! "Poleward" diffusive heat or salt transports 
    135          IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN 
    136             IF( jn  == jp_tem)   htr_ldf(:) = ptr_vj( ztv(:,:,:) ) 
    137             IF( jn  == jp_sal)   str_ldf(:) = ptr_vj( ztv(:,:,:) ) 
     156         IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 
     157            IF( jn  == jp_tem)   htr_ldf(:) = ptr_sj( ztv(:,:,:) ) 
     158            IF( jn  == jp_sal)   str_ldf(:) = ptr_sj( ztv(:,:,:) ) 
    138159         ENDIF 
    139160         !                                                  ! ================== 

  • branches/2014/dev_r4650_UKMO14.5_SST_BIAS_CORRECTION/NEMOGCM/NEMO/OPA_SRC/TRA/tranpc.F90

    r4313 r5965  
    22   !!============================================================================== 
    33   !!                       ***  MODULE  tranpc  *** 
    4    !! Ocean active tracers:  non penetrative convection scheme 
     4   !! Ocean active tracers:  non penetrative convective adjustment scheme 
    55   !!============================================================================== 
    66   !! History :  1.0  ! 1990-09  (G. Madec)  Original code 
    … …  
    99   !!            3.0  ! 2008-06  (G. Madec)  applied on ta, sa and called before tranxt in step.F90 
    1010   !!            3.3  ! 2010-05  (C. Ethe, G. Madec)  merge TRC-TRA 
     11   !!            3.6  ! 2015-05  (L. Brodeau) new algorithm based on local Brunt-Vaisala freq. 
    1112   !!---------------------------------------------------------------------- 
    1213 
    … …  
    1415   !!   tra_npc : apply the non penetrative convection scheme 
    1516   !!---------------------------------------------------------------------- 
    16    USE oce             ! ocean dynamics and active tracers  
     17   USE oce             ! ocean dynamics and active tracers 
    1718   USE dom_oce         ! ocean space and time domain 
     19   USE phycst          ! physical constants 
    1820   USE zdf_oce         ! ocean vertical physics 
    19    USE trdmod_oce      ! ocean active tracer trends 
     21   USE trd_oce         ! ocean active tracer trends 
    2022   USE trdtra          ! ocean active tracer trends 
    21    USE eosbn2          ! equation of state (eos routine)  
     23   USE eosbn2          ! equation of state (eos routine) 
     24   ! 
    2225   USE lbclnk          ! lateral boundary conditions (or mpp link) 
    2326   USE in_out_manager  ! I/O manager 
    … …  
    2932   PRIVATE 
    3033 
    31    PUBLIC   tra_npc       ! routine called by step.F90 
     34   PUBLIC   tra_npc    ! routine called by step.F90 
    3235 
    3336   !! * Substitutions 
    3437#  include "domzgr_substitute.h90" 
    35    !!---------------------------------------------------------------------- 
    36    !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    37    !! $Id$  
     38#  include "vectopt_loop_substitute.h90" 
     39   !!---------------------------------------------------------------------- 
     40   !! NEMO/OPA 3.6 , NEMO Consortium (2014) 
     41   !! $Id$ 
    3842   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    3943   !!---------------------------------------------------------------------- 
    … …  
    4448      !!                  ***  ROUTINE tranpc  *** 
    4549      !! 
    46       !! ** Purpose :   Non penetrative convective adjustment scheme. solve  
     50      !! ** Purpose : Non-penetrative convective adjustment scheme. solve 
    4751      !!      the static instability of the water column on after fields 
    4852      !!      while conserving heat and salt contents. 
    4953      !! 
    50       !! ** Method  :   The algorithm used converges in a maximium of jpk  
    51       !!      iterations. instabilities are treated when the vertical density 
    52       !!      gradient is less than 1.e-5. 
    53       !!      l_trdtra=T: the trend associated with this algorithm is saved. 
     54      !! ** Method  : updated algorithm able to deal with non-linear equation of state 
     55      !!              (i.e. static stability computed locally) 
    5456      !! 
    5557      !! ** Action  : - (ta,sa) after the application od the npc scheme 
    56       !!              - save the associated trends (ttrd,strd) ('key_trdtra') 
     58      !!              - send the associated trends for on-line diagnostics (l_trdtra=T) 
    5759      !! 
    58       !! References : Madec, et al., 1991, JPO, 21, 9, 1349-1371. 
     60      !! References :     Madec, et al., 1991, JPO, 21, 9, 1349-1371. 
    5961      !!---------------------------------------------------------------------- 
    60       ! 
    6162      INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
    6263      ! 
    6364      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    6465      INTEGER  ::   inpcc        ! number of statically instable water column 
    65       INTEGER  ::   inpci        ! number of iteration for npc scheme 
    66       INTEGER  ::   jiter, jkdown, jkp        ! ??? 
    67       INTEGER  ::   ikbot, ik, ikup, ikdown   ! ??? 
    68       REAL(wp) ::   ze3tot, zta, zsa, zraua, ze3dwn 
    69       REAL(wp), POINTER, DIMENSION(:,:  ) :: zwx, zwy, zwz 
    70       REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdt, ztrds, zrhop 
     66      INTEGER  ::   jiter, ikbot, ikp, ikup, ikdown, ilayer, ik_low   ! local integers 
     67      LOGICAL  ::   l_bottom_reached, l_column_treated 
     68      REAL(wp) ::   zta, zalfa, zsum_temp, zsum_alfa, zaw, zdz, zsum_z 
     69      REAL(wp) ::   zsa, zbeta, zsum_sali, zsum_beta, zbw, zrw, z1_r2dt 
     70      REAL(wp), PARAMETER :: zn2_zero = 1.e-14_wp       ! acceptance criteria for neutrality (N2==0) 
     71      REAL(wp), POINTER, DIMENSION(:)       ::   zvn2   ! vertical profile of N2 at 1 given point... 
     72      REAL(wp), POINTER, DIMENSION(:,:)     ::   zvts   ! vertical profile of T and S at 1 given point... 
     73      REAL(wp), POINTER, DIMENSION(:,:)     ::   zvab   ! vertical profile of alpha and beta 
     74      REAL(wp), POINTER, DIMENSION(:,:,:)   ::   zn2    ! N^2  
     75      REAL(wp), POINTER, DIMENSION(:,:,:,:) ::   zab    ! alpha and beta 
     76      REAL(wp), POINTER, DIMENSION(:,:,:)   ::   ztrdt, ztrds   ! 3D workspace 
     77      ! 
     78      LOGICAL, PARAMETER :: l_LB_debug = .FALSE. ! set to true if you want to follow what is 
     79      INTEGER :: ilc1, jlc1, klc1, nncpu         ! actually happening in a water column at point "ilc1, jlc1" 
     80      LOGICAL :: lp_monitor_point = .FALSE.      ! in CPU domain "nncpu" 
    7181      !!---------------------------------------------------------------------- 
    7282      ! 
    7383      IF( nn_timing == 1 )  CALL timing_start('tra_npc') 
    7484      ! 
    75       CALL wrk_alloc(jpi, jpj, jpk, zrhop ) 
    76       CALL wrk_alloc(jpi, jpk, zwx, zwy, zwz ) 
    77       ! 
    7885      IF( MOD( kt, nn_npc ) == 0 ) THEN 
    79  
    80          inpcc = 0 
    81          inpci = 0 
    82  
    83          CALL eos( tsa, rhd, zrhop, fsdept_n(:,:,:) )         ! Potential density 
    84  
    85          IF( l_trdtra )   THEN                    !* Save ta and sa trends 
     86         ! 
     87         CALL wrk_alloc( jpi, jpj, jpk, zn2 )    ! N2 
     88         CALL wrk_alloc( jpi, jpj, jpk, 2, zab ) ! Alpha and Beta 
     89         CALL wrk_alloc( jpk, 2, zvts, zvab )    ! 1D column vector at point ji,jj 
     90         CALL wrk_alloc( jpk, zvn2 )             ! 1D column vector at point ji,jj 
     91 
     92         IF( l_trdtra )   THEN                    !* Save initial after fields 
    8693            CALL wrk_alloc( jpi, jpj, jpk, ztrdt, ztrds ) 
    8794            ztrdt(:,:,:) = tsa(:,:,:,jp_tem)  
    … …  
    8996         ENDIF 
    9097 
    91          !                                                ! =============== 
    92          DO jj = 1, jpj                                   !  Vertical slab 
    93             !                                             ! =============== 
    94             !  Static instability pointer  
    95             ! ---------------------------- 
    96             DO jk = 1, jpkm1 
    97                DO ji = 1, jpi 
    98                   zwx(ji,jk) = ( zrhop(ji,jj,jk) - zrhop(ji,jj,jk+1) ) * tmask(ji,jj,jk+1) 
    99                END DO 
    100             END DO 
    101  
    102             ! 1.1 do not consider the boundary points 
    103  
    104             ! even if east-west cyclic b. c. do not considere ji=1 or jpi 
    105             DO jk = 1, jpkm1 
    106                zwx( 1 ,jk) = 0.e0 
    107                zwx(jpi,jk) = 0.e0 
    108             END DO 
    109             ! even if south-symmetric b. c. used, do not considere jj=1 
    110             IF( jj == 1 )   zwx(:,:) = 0.e0 
    111  
    112             DO jk = 1, jpkm1 
    113                DO ji = 1, jpi 
    114                   zwx(ji,jk) = 1. 
    115                   IF( zwx(ji,jk) < 1.e-5 ) zwx(ji,jk) = 0.e0 
    116                END DO 
    117             END DO 
    118  
    119             zwy(:,1) = 0.e0 
    120             DO ji = 1, jpi 
    121                DO jk = 1, jpkm1 
    122                   zwy(ji,1) = zwy(ji,1) + zwx(ji,jk) 
    123                END DO 
    124             END DO 
    125  
    126             zwz(1,1) = 0.e0 
    127             DO ji = 1, jpi 
    128                zwz(1,1) = zwz(1,1) + zwy(ji,1) 
    129             END DO 
    130  
    131             inpcc = inpcc + NINT( zwz(1,1) ) 
    132  
    133  
    134             ! 2. Vertical mixing for each instable portion of the density profil 
    135             ! ------------------------------------------------------------------ 
    136  
    137             IF( zwz(1,1) /= 0.e0 ) THEN         ! -->> the density profil is statically instable : 
    138                DO ji = 1, jpi 
    139                   IF( zwy(ji,1) /= 0.e0 ) THEN 
     98         IF( l_LB_debug ) THEN 
     99            ! Location of 1 known convection site to follow what's happening in the water column 
     100            ilc1 = 45 ;  jlc1 = 3 ; !  ORCA2 4x4, Antarctic coast, more than 2 unstable portions in the  water column...            
     101            nncpu = 1  ;            ! the CPU domain contains the convection spot 
     102            klc1 =  mbkt(ilc1,jlc1) ! bottom of the ocean for debug point...           
     103         ENDIF 
     104          
     105         CALL eos_rab( tsa, zab )         ! after alpha and beta (given on T-points) 
     106         CALL bn2    ( tsa, zab, zn2 )    ! after Brunt-Vaisala  (given on W-points) 
     107         
     108         inpcc = 0 
     109 
     110         DO jj = 2, jpjm1                 ! interior column only 
     111            DO ji = fs_2, fs_jpim1 
     112               ! 
     113               IF( tmask(ji,jj,2) == 1 ) THEN      ! At least 2 ocean points 
     114                  !                                     ! consider one ocean column  
     115                  zvts(:,jp_tem) = tsa(ji,jj,:,jp_tem)      ! temperature 
     116                  zvts(:,jp_sal) = tsa(ji,jj,:,jp_sal)      ! salinity 
     117 
     118                  zvab(:,jp_tem)  = zab(ji,jj,:,jp_tem)     ! Alpha  
     119                  zvab(:,jp_sal)  = zab(ji,jj,:,jp_sal)     ! Beta   
     120                  zvn2(:)         = zn2(ji,jj,:)            ! N^2  
     121                  
     122                  IF( l_LB_debug ) THEN                  !LB debug: 
     123                     lp_monitor_point = .FALSE. 
     124                     IF( ( ji == ilc1 ).AND.( jj == jlc1 ) ) lp_monitor_point = .TRUE. 
     125                     ! writing only if on CPU domain where conv region is: 
     126                     lp_monitor_point = (narea == nncpu).AND.lp_monitor_point                       
     127                  ENDIF                                  !LB debug  end 
     128 
     129                  ikbot = mbkt(ji,jj)   ! ikbot: ocean bottom T-level 
     130                  ikp = 1                  ! because N2 is irrelevant at the surface level (will start at ikp=2) 
     131                  ilayer = 0 
     132                  jiter  = 0 
     133                  l_column_treated = .FALSE. 
     134                  
     135                  DO WHILE ( .NOT. l_column_treated ) 
    140136                     ! 
    141                      ikbot = mbkt(ji,jj)        ! ikbot: ocean bottom T-level 
     137                     jiter = jiter + 1 
     138                     
     139                     IF( jiter >= 400 ) EXIT 
     140                     
     141                     l_bottom_reached = .FALSE. 
     142 
     143                     DO WHILE ( .NOT. l_bottom_reached ) 
     144 
     145                        ikp = ikp + 1 
     146                        
     147                        !! Testing level ikp for instability 
     148                        !! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
     149                        IF( zvn2(ikp) <  -zn2_zero ) THEN ! Instability found! 
     150 
     151                           ilayer = ilayer + 1    ! yet another instable portion of the water column found.... 
     152 
     153                           IF( lp_monitor_point ) THEN  
     154                              WRITE(numout,*) 
     155                              IF( ilayer == 1 .AND. jiter == 1 ) THEN   ! first time a column is spoted with an instability 
     156                                 WRITE(numout,*) 
     157                                 WRITE(numout,*) 'Time step = ',kt,' !!!' 
     158                              ENDIF 
     159                              WRITE(numout,*)  ' * Iteration #',jiter,': found instable portion #',ilayer,   & 
     160                                 &                                    ' in column! Starting at ikp =', ikp 
     161                              WRITE(numout,*)  ' *** N2 for point (i,j) = ',ji,' , ',jj 
     162                              DO jk = 1, klc1 
     163                                 WRITE(numout,*) jk, zvn2(jk) 
     164                              END DO 
     165                              WRITE(numout,*) 
     166                           ENDIF 
     167                            
     168 
     169                           IF( jiter == 1 )   inpcc = inpcc + 1  
     170 
     171                           IF( lp_monitor_point )   WRITE(numout, *) 'Negative N2 at ikp =',ikp,' for layer #', ilayer 
     172 
     173                           !! ikup is the uppermost point where mixing will start: 
     174                           ikup = ikp - 1 ! ikup is always "at most at ikp-1", less if neutral levels overlying 
     175                            
     176                           !! If the points above ikp-1 have N2 == 0 they must also be mixed: 
     177                           IF( ikp > 2 ) THEN 
     178                              DO jk = ikp-1, 2, -1 
     179                                 IF( ABS(zvn2(jk)) < zn2_zero ) THEN 
     180                                    ikup = ikup - 1  ! 1 more upper level has N2=0 and must be added for the mixing 
     181                                 ELSE 
     182                                    EXIT 
     183                                 ENDIF 
     184                              END DO 
     185                           ENDIF 
     186                            
     187                           IF( ikup < 1 )   CALL ctl_stop( 'tra_npc :  PROBLEM #1') 
     188 
     189                           zsum_temp = 0._wp 
     190                           zsum_sali = 0._wp 
     191                           zsum_alfa = 0._wp 
     192                           zsum_beta = 0._wp 
     193                           zsum_z    = 0._wp 
     194                                                     
     195                           DO jk = ikup, ikbot      ! Inside the instable (and overlying neutral) portion of the column 
     196                              ! 
     197                              zdz       = fse3t(ji,jj,jk) 
     198                              zsum_temp = zsum_temp + zvts(jk,jp_tem)*zdz 
     199                              zsum_sali = zsum_sali + zvts(jk,jp_sal)*zdz 
     200                              zsum_alfa = zsum_alfa + zvab(jk,jp_tem)*zdz 
     201                              zsum_beta = zsum_beta + zvab(jk,jp_sal)*zdz 
     202                              zsum_z    = zsum_z    + zdz 
     203                              !                               
     204                              IF( jk == ikbot ) EXIT ! avoid array-index overshoot in case ikbot = jpk, cause we're calling jk+1 next line 
     205                              !! EXIT when we have reached the last layer that is instable (N2<0) or neutral (N2=0): 
     206                              IF( zvn2(jk+1) > zn2_zero ) EXIT 
     207                           END DO 
     208                           
     209                           ikdown = jk ! for the current unstable layer, ikdown is the deepest point with a negative or neutral N2 
     210                           IF( ikup == ikdown )   CALL ctl_stop( 'tra_npc :  PROBLEM #2') 
     211 
     212                           ! Mixing Temperature, salinity, alpha and beta from ikup to ikdown included: 
     213                           zta   = zsum_temp/zsum_z 
     214                           zsa   = zsum_sali/zsum_z 
     215                           zalfa = zsum_alfa/zsum_z 
     216                           zbeta = zsum_beta/zsum_z 
     217 
     218                           IF( lp_monitor_point ) THEN 
     219                              WRITE(numout,*) 'MIXED T, S, alfa and beta between ikup =',ikup,   & 
     220                                 &            ' and ikdown =',ikdown,', in layer #',ilayer 
     221                              WRITE(numout,*) '  => Mean temp. in that portion =', zta 
     222                              WRITE(numout,*) '  => Mean sali. in that portion =', zsa 
     223                              WRITE(numout,*) '  => Mean Alfa  in that portion =', zalfa 
     224                              WRITE(numout,*) '  => Mean Beta  in that portion =', zbeta 
     225                           ENDIF 
     226 
     227                           !! Homogenaizing the temperature, salinity, alpha and beta in this portion of the column 
     228                           DO jk = ikup, ikdown 
     229                              zvts(jk,jp_tem) = zta 
     230                              zvts(jk,jp_sal) = zsa 
     231                              zvab(jk,jp_tem) = zalfa 
     232                              zvab(jk,jp_sal) = zbeta 
     233                           END DO 
     234                            
     235                            
     236                           !! Updating N2 in the relvant portion of the water column 
     237                           !! Temperature, Salinity, Alpha and Beta have been homogenized in the unstable portion 
     238                           !! => Need to re-compute N2! will use Alpha and Beta! 
     239                            
     240                           ikup   = MAX(2,ikup)         ! ikup can never be 1 ! 
     241                           ik_low = MIN(ikdown+1,ikbot) ! we must go 1 point deeper than ikdown! 
     242                            
     243                           DO jk = ikup, ik_low              ! we must go 1 point deeper than ikdown! 
     244 
     245                              !! 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)) 
     248                              zaw = zvab(jk,jp_tem) * (1._wp - zrw) + zvab(jk-1,jp_tem) * zrw 
     249                              zbw = zvab(jk,jp_sal) * (1._wp - zrw) + zvab(jk-1,jp_sal) * zrw 
     250 
     251                              !! N2 at W point, doing exactly as in eosbn2.F90: 
     252                              zvn2(jk) = grav*( zaw * ( zvts(jk-1,jp_tem) - zvts(jk,jp_tem) )     & 
     253                                 &            - zbw * ( zvts(jk-1,jp_sal) - zvts(jk,jp_sal) )  )  & 
     254                                 &       / fse3w(ji,jj,jk) * tmask(ji,jj,jk) 
     255 
     256                              !! OR, faster  => just considering the vertical gradient of density 
     257                              !! as only the signa maters... 
     258                              !zvn2(jk) = (  zaw * ( zvts(jk-1,jp_tem) - zvts(jk,jp_tem) )     & 
     259                              !     &      - zbw * ( zvts(jk-1,jp_sal) - zvts(jk,jp_sal) )  ) 
     260 
     261                           END DO 
     262                         
     263                           ikp = MIN(ikdown+1,ikbot) 
     264                            
     265 
     266                        ENDIF  !IF( zvn2(ikp) < 0. ) 
     267 
     268 
     269                        IF( ikp == ikbot ) l_bottom_reached = .TRUE. 
     270                        ! 
     271                     END DO ! DO WHILE ( .NOT. l_bottom_reached ) 
     272 
     273                     IF( ikp /= ikbot )   CALL ctl_stop( 'tra_npc :  PROBLEM #3') 
     274                     
     275                     ! ******* At this stage ikp == ikbot ! ******* 
     276                     
     277                     IF( ilayer > 0 ) THEN      !! least an unstable layer has been found 
     278                        ! 
     279                        IF( lp_monitor_point ) THEN 
     280                           WRITE(numout,*) 
     281                           WRITE(numout,*) 'After ',jiter,' iteration(s), we neutralized ',ilayer,' instable layer(s)' 
     282                           WRITE(numout,*) '   ==> N2 at i,j=',ji,',',jj,' now looks like this:' 
     283                           DO jk = 1, klc1 
     284                              WRITE(numout,*) jk, zvn2(jk) 
     285                           END DO 
     286                           WRITE(numout,*) 
     287                        ENDIF 
     288                        ! 
     289                        ikp    = 1     ! starting again at the surface for the next iteration 
     290                        ilayer = 0 
     291                     ENDIF 
    142292                     ! 
    143                      DO jiter = 1, jpk          ! vertical iteration 
    144                         ! 
    145                         ! search of ikup : the first static instability from the sea surface 
    146                         ! 
    147                         ik = 0 
    148 220                     CONTINUE 
    149                         ik = ik + 1 
    150                         IF( ik >= ikbot ) GO TO 200 
    151                         zwx(ji,ik) = zrhop(ji,jj,ik) - zrhop(ji,jj,ik+1) 
    152                         IF( zwx(ji,ik) <= 0.e0 ) GO TO 220 
    153                         ikup = ik 
    154                         ! the density profil is instable below ikup 
    155                         ! ikdown : bottom of the instable portion of the density profil 
    156                         ! search of ikdown and vertical mixing from ikup to ikdown 
    157                         ! 
    158                         ze3tot= fse3t(ji,jj,ikup) 
    159                         zta   = tsa  (ji,jj,ikup,jp_tem) 
    160                         zsa   = tsa  (ji,jj,ikup,jp_sal) 
    161                         zraua = zrhop(ji,jj,ikup) 
    162                         ! 
    163                         DO jkdown = ikup+1, ikbot-1 
    164                            IF( zraua <= zrhop(ji,jj,jkdown) ) THEN 
    165                               ikdown = jkdown 
    166                               GO TO 240 
    167                            ENDIF 
    168                            ze3dwn =  fse3t(ji,jj,jkdown) 
    169                            ze3tot =  ze3tot + ze3dwn 
    170                            zta   = ( zta*(ze3tot-ze3dwn) + tsa(ji,jj,jkdown,jp_tem)*ze3dwn )/ze3tot 
    171                            zsa   = ( zsa*(ze3tot-ze3dwn) + tsa(ji,jj,jkdown,jp_sal)*ze3dwn )/ze3tot 
    172                            zraua = ( zraua*(ze3tot-ze3dwn) + zrhop(ji,jj,jkdown)*ze3dwn )/ze3tot 
    173                            inpci = inpci+1 
    174                         END DO 
    175                         ikdown = ikbot-1 
    176 240                     CONTINUE 
    177                         ! 
    178                         DO jkp = ikup, ikdown-1 
    179                            tsa  (ji,jj,jkp,jp_tem) = zta 
    180                            tsa  (ji,jj,jkp,jp_sal) = zsa 
    181                            zrhop(ji,jj,jkp       ) = zraua 
    182                         END DO 
    183                         IF (ikdown == ikbot-1 .AND. zraua >= zrhop(ji,jj,ikdown) ) THEN 
    184                            tsa  (ji,jj,jkp,jp_tem) = zta 
    185                            tsa  (ji,jj,jkp,jp_sal) = zsa 
    186                            zrhop(ji,jj,ikdown    ) = zraua 
    187                         ENDIF 
    188                      END DO 
    189                   ENDIF 
    190 200               CONTINUE 
    191                END DO 
    192                ! <<-- no more static instability on slab jj 
    193             ENDIF 
    194             !                                             ! =============== 
    195          END DO                                           !   End of slab 
    196          !                                                ! =============== 
    197          !  
    198          IF( l_trdtra )   THEN         ! save the Non penetrative mixing trends for diagnostic 
    199             ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 
    200             ztrds(:,:,:) = tsa(:,:,:,jp_sal) - ztrds(:,:,:) 
    201             CALL trd_tra( kt, 'TRA', jp_tem, jptra_trd_npc, ztrdt ) 
    202             CALL trd_tra( kt, 'TRA', jp_sal, jptra_trd_npc, ztrds ) 
     293                     IF( ikp >= ikbot )   l_column_treated = .TRUE. 
     294                     ! 
     295                  END DO ! DO WHILE ( .NOT. l_column_treated ) 
     296 
     297                  !! Updating tsa: 
     298                  tsa(ji,jj,:,jp_tem) = zvts(:,jp_tem) 
     299                  tsa(ji,jj,:,jp_sal) = zvts(:,jp_sal) 
     300 
     301                  !! LB:  Potentially some other global variable beside theta and S can be treated here 
     302                  !!      like BGC tracers. 
     303 
     304                  IF( lp_monitor_point )   WRITE(numout,*) 
     305 
     306               ENDIF ! IF( tmask(ji,jj,3) == 1 ) THEN 
     307 
     308            END DO ! ji 
     309         END DO ! jj 
     310         ! 
     311         IF( l_trdtra ) THEN         ! send the Non penetrative mixing trends for diagnostic 
     312            z1_r2dt = 1._wp / (2._wp * rdt) 
     313            ztrdt(:,:,:) = ( tsa(:,:,:,jp_tem) - ztrdt(:,:,:) ) * z1_r2dt 
     314            ztrds(:,:,:) = ( tsa(:,:,:,jp_sal) - ztrds(:,:,:) ) * z1_r2dt 
     315            CALL trd_tra( kt, 'TRA', jp_tem, jptra_npc, ztrdt ) 
     316            CALL trd_tra( kt, 'TRA', jp_sal, jptra_npc, ztrds ) 
    203317            CALL wrk_dealloc( jpi, jpj, jpk, ztrdt, ztrds ) 
    204318         ENDIF 
    205        
    206          ! Lateral boundary conditions on ( ta, sa )   ( Unchanged sign) 
    207          ! ------------------------------============ 
     319         ! 
    208320         CALL lbc_lnk( tsa(:,:,:,jp_tem), 'T', 1. )   ;   CALL lbc_lnk( tsa(:,:,:,jp_sal), 'T', 1. ) 
    209        
    210  
    211          !  2. non penetrative convective scheme statistics 
    212          !  ----------------------------------------------- 
    213          IF( nn_npcp /= 0 .AND. MOD( kt, nn_npcp ) == 0 ) THEN 
    214             IF(lwp) WRITE(numout,*)' kt=',kt, ' number of statically instable',   & 
    215                &                   ' water column : ',inpcc, ' number of iteration : ',inpci 
     321         ! 
     322         IF( lwp .AND. l_LB_debug ) THEN 
     323            WRITE(numout,*) 'Exiting tra_npc , kt = ',kt,', => numb. of statically instable water-columns: ', inpcc 
     324            WRITE(numout,*) 
    216325         ENDIF 
    217326         ! 
    218       ENDIF 
    219       ! 
    220       CALL wrk_dealloc(jpi, jpj, jpk, zrhop ) 
    221       CALL wrk_dealloc(jpi, jpk, zwx, zwy, zwz ) 
     327         CALL wrk_dealloc(jpi, jpj, jpk, zn2 ) 
     328         CALL wrk_dealloc(jpi, jpj, jpk, 2, zab ) 
     329         CALL wrk_dealloc(jpk, zvn2 ) 
     330         CALL wrk_dealloc(jpk, 2, zvts, zvab ) 
     331         ! 
     332      ENDIF   ! IF( MOD( kt, nn_npc ) == 0 ) THEN 
    222333      ! 
    223334      IF( nn_timing == 1 )  CALL timing_stop('tra_npc') 

  • branches/2014/dev_r4650_UKMO14.5_SST_BIAS_CORRECTION/NEMOGCM/NEMO/OPA_SRC/TRA/tranxt.F90

    r4328 r5965  
    2727   USE dom_oce         ! ocean space and time domain variables  
    2828   USE sbc_oce         ! surface boundary condition: ocean 
    29    USE zdf_oce         ! ??? 
     29   USE sbcrnf          ! river runoffs 
     30   USE zdf_oce         ! ocean vertical mixing 
    3031   USE domvvl          ! variable volume 
    3132   USE dynspg_oce      ! surface     pressure gradient variables 
    3233   USE dynhpg          ! hydrostatic pressure gradient  
    33    USE trdmod_oce      ! ocean space and time domain variables  
    34    USE trdtra          ! ocean active tracers trends  
    35    USE phycst 
    36    USE bdy_oce 
     34   USE trd_oce         ! trends: ocean variables 
     35   USE trdtra          ! trends manager: tracers  
     36   USE traqsr          ! penetrative solar radiation (needed for nksr) 
     37   USE phycst          ! physical constant 
     38   USE ldftra_oce      ! lateral physics on tracers 
     39   USE bdy_oce         ! BDY open boundary condition variables 
    3740   USE bdytra          ! open boundary condition (bdy_tra routine) 
     41   ! 
    3842   USE in_out_manager  ! I/O manager 
    3943   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    4044   USE prtctl          ! Print control 
    41    USE traqsr          ! penetrative solar radiation (needed for nksr) 
     45   USE wrk_nemo        ! Memory allocation 
     46   USE timing          ! Timing 
    4247#if defined key_agrif 
    4348   USE agrif_opa_update 
    4449   USE agrif_opa_interp 
    4550#endif 
    46    USE wrk_nemo        ! Memory allocation 
    47    USE timing          ! Timing 
    4851 
    4952   IMPLICIT NONE 
    … …  
    8083      !!             at the local domain   boundaries through lbc_lnk call,  
    8184      !!             at the one-way open boundaries (lk_bdy=T),  
    82       !!             at the AGRIF zoom     boundaries (lk_agrif=T) 
     85      !!             at the AGRIF zoom   boundaries (lk_agrif=T) 
    8386      !! 
    8487      !!              - Update lateral boundary conditions on AGRIF children 
    … …  
    127130         ztrdt(:,:,:) = tsn(:,:,:,jp_tem)  
    128131         ztrds(:,:,:) = tsn(:,:,:,jp_sal) 
     132         IF( ln_traldf_iso ) THEN              ! diagnose the "pure" Kz diffusive trend  
     133            CALL trd_tra( kt, 'TRA', jp_tem, jptra_zdfp, ztrdt ) 
     134            CALL trd_tra( kt, 'TRA', jp_sal, jptra_zdfp, ztrds ) 
     135         ENDIF 
    129136      ENDIF 
    130137 
    … …  
    137144      ELSE                                            ! Leap-Frog + Asselin filter time stepping 
    138145         ! 
    139          IF( lk_vvl )  THEN   ;   CALL tra_nxt_vvl( kt, nit000, 'TRA', tsb, tsn, tsa, jpts )  ! variable volume level (vvl)      
    140          ELSE                 ;   CALL tra_nxt_fix( kt, nit000, 'TRA', tsb, tsn, tsa, jpts )  ! fixed    volume level  
     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  
    141149         ENDIF 
    142150      ENDIF  
    … …  
    150158      IF( l_trdtra ) THEN      ! trend of the Asselin filter (tb filtered - tb)/dt      
    151159         DO jk = 1, jpkm1 
    152             zfact = 1.e0_wp / r2dtra(jk)              
     160            zfact = 1._wp / r2dtra(jk)              
    153161            ztrdt(:,:,jk) = ( tsb(:,:,jk,jp_tem) - ztrdt(:,:,jk) ) * zfact 
    154162            ztrds(:,:,jk) = ( tsb(:,:,jk,jp_sal) - ztrds(:,:,jk) ) * zfact 
    155163         END DO 
    156          CALL trd_tra( kt, 'TRA', jp_tem, jptra_trd_atf, ztrdt ) 
    157          CALL trd_tra( kt, 'TRA', jp_sal, jptra_trd_atf, ztrds ) 
     164         CALL trd_tra( kt, 'TRA', jp_tem, jptra_atf, ztrdt ) 
     165         CALL trd_tra( kt, 'TRA', jp_sal, jptra_atf, ztrds ) 
    158166         CALL wrk_dealloc( jpi, jpj, jpk, ztrdt, ztrds ) 
    159167      END IF 
    … …  
    163171         &                       tab3d_2=tsn(:,:,:,jp_sal), clinfo2=       ' Sn: ', mask2=tmask ) 
    164172      ! 
    165       ! 
    166       IF( nn_timing == 1 )  CALL timing_stop('tra_nxt') 
     173      IF( nn_timing == 1 )   CALL timing_stop('tra_nxt') 
    167174      ! 
    168175   END SUBROUTINE tra_nxt 
    … …  
    236243 
    237244 
    238    SUBROUTINE tra_nxt_vvl( kt, kit000, cdtype, ptb, ptn, pta, kjpt ) 
     245   SUBROUTINE tra_nxt_vvl( kt, kit000, p2dt, cdtype, ptb, ptn, pta, psbc_tc, psbc_tc_b, kjpt ) 
    239246      !!---------------------------------------------------------------------- 
    240247      !!                   ***  ROUTINE tra_nxt_vvl  *** 
    … …  
    260267      !!              - (ta,sa) time averaged (t,s)   (ln_dynhpg_imp = T) 
    261268      !!---------------------------------------------------------------------- 
    262       INTEGER         , INTENT(in   )                               ::   kt       ! ocean time-step index 
    263       INTEGER         , INTENT(in   )                               ::   kit000   ! first time step index 
    264       CHARACTER(len=3), INTENT(in   )                               ::   cdtype   ! =TRA or TRC (tracer indicator) 
    265       INTEGER         , INTENT(in   )                               ::   kjpt     ! number of tracers 
    266       REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::   ptb      ! before tracer fields 
    267       REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::   ptn      ! now tracer fields 
    268       REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::   pta      ! tracer trend 
     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 
    269280      !!      
    270       LOGICAL  ::   ll_tra, ll_tra_hpg, ll_traqsr   ! local logical 
     281      LOGICAL  ::   ll_tra_hpg, ll_traqsr, ll_rnf   ! local logical 
    271282      INTEGER  ::   ji, jj, jk, jn              ! dummy loop indices 
    272283      REAL(wp) ::   zfact1, ztc_a , ztc_n , ztc_b , ztc_f , ztc_d    ! local scalar 
    … …  
    281292      ! 
    282293      IF( cdtype == 'TRA' )  THEN    
    283          ll_tra     = .TRUE.           ! active tracers case   
    284294         ll_tra_hpg = ln_dynhpg_imp    ! active  tracers case  and  semi-implicit hpg 
    285295         ll_traqsr  = ln_traqsr        ! active  tracers case  and  solar penetration 
     296         ll_rnf     = ln_rnf           ! active  tracers case  and  river runoffs 
    286297      ELSE                           
    287          ll_tra     = .FALSE.          ! passive tracers case 
    288298         ll_tra_hpg = .FALSE.          ! passive tracers case or NO semi-implicit hpg 
    289299         ll_traqsr  = .FALSE.          ! active  tracers case and NO solar penetration 
     300         ll_rnf     = .FALSE.          ! passive tracers or NO river runoffs 
    290301      ENDIF 
    291302      ! 
    292303      DO jn = 1, kjpt       
    293304         DO jk = 1, jpkm1 
    294             zfact1 = atfp * rdttra(jk) 
     305            zfact1 = atfp * p2dt(jk) 
    295306            zfact2 = zfact1 / rau0 
    296307            DO jj = 1, jpj 
    … …  
    310321                  ztc_f  = ztc_n  + atfp * ztc_d 
    311322                  ! 
    312                   IF( ll_tra .AND. jk == 1 ) THEN           ! first level only for T & S 
    313                       ze3t_f = ze3t_f - zfact2 * ( emp_b(ji,jj) - emp(ji,jj) ) 
    314                       ztc_f  = ztc_f  - zfact1 * ( sbc_tsc(ji,jj,jn) - sbc_tsc_b(ji,jj,jn) ) 
     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) ) 
     325                     ztc_f  = ztc_f  - zfact1 * ( psbc_tc(ji,jj,jn) - psbc_tc_b(ji,jj,jn) ) 
    315326                  ENDIF 
     327 
    316328                  IF( ll_traqsr .AND. jn == jp_tem .AND. jk <= nksr )   &     ! solar penetration (temperature only) 
    317329                     &     ztc_f  = ztc_f  - zfact1 * ( qsr_hc(ji,jj,jk) - qsr_hc_b(ji,jj,jk) )  
    318330 
    319                    ze3t_f = 1.e0 / ze3t_f 
    320                    ptb(ji,jj,jk,jn) = ztc_f * ze3t_f       ! ptb <-- ptn filtered 
    321                    ptn(ji,jj,jk,jn) = pta(ji,jj,jk,jn)     ! ptn <-- pta 
    322                    ! 
    323                    IF( ll_tra_hpg ) THEN        ! semi-implicit hpg (T & S only) 
    324                       ze3t_d           = 1.e0   / ( ze3t_n + rbcp * ze3t_d ) 
    325                       pta(ji,jj,jk,jn) = ze3t_d * ( ztc_n  + rbcp * ztc_d  )   ! ta <-- Brown & Campana average 
    326                    ENDIF 
     331                  IF( ll_rnf .AND. jk <= nk_rnf(ji,jj) )   &            ! river runoffs 
     332                     &     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 
     335                  ze3t_f = 1.e0 / ze3t_f 
     336                  ptb(ji,jj,jk,jn) = ztc_f * ze3t_f       ! ptb <-- ptn filtered 
     337                  ptn(ji,jj,jk,jn) = pta(ji,jj,jk,jn)     ! ptn <-- pta 
     338                  ! 
     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 
    327343               END DO 
    328344            END DO 

  • branches/2014/dev_r4650_UKMO14.5_SST_BIAS_CORRECTION/NEMOGCM/NEMO/OPA_SRC/TRA/traqsr.F90

    r4624 r5965  
    2121   USE sbc_oce         ! surface boundary condition: ocean 
    2222   USE trc_oce         ! share SMS/Ocean variables 
    23    USE trdmod_oce      ! ocean variables trends 
    24    USE trdtra          ! ocean active tracers trends  
     23   USE trd_oce        ! trends: ocean variables 
     24   USE trdtra         ! trends manager: tracers 
    2525   USE in_out_manager  ! I/O manager 
    2626   USE phycst          ! physical constants 
    … …  
    3232   USE wrk_nemo       ! Memory Allocation 
    3333   USE timing         ! Timing 
    34    USE sbc_ice, ONLY : lk_lim3 
    3534 
    3635   IMPLICIT NONE 
    … …  
    3837 
    3938   PUBLIC   tra_qsr       ! routine called by step.F90 (ln_traqsr=T) 
    40    PUBLIC   tra_qsr_init  ! routine called by opa.F90 
     39   PUBLIC   tra_qsr_init  ! routine called by nemogcm.F90 
    4140 
    4241   !                                 !!* Namelist namtra_qsr: penetrative solar radiation 
    … …  
    5049   REAL(wp), PUBLIC ::   rn_si0       !: very near surface depth of extinction      (RGB & 2 bands) 
    5150   REAL(wp), PUBLIC ::   rn_si1       !: deepest depth of extinction (water type I)       (2 bands) 
    52     
     51  
    5352   ! Module variables 
    5453   REAL(wp) ::   xsi0r                           !: inverse of rn_si0 
    … …  
    129128      IF( kt == nit000 ) THEN                     ! Set the forcing field at nit000 - 1 
    130129         !                                        ! ----------------------------------- 
     130         qsr_hc(:,:,:) = 0.e0 
     131         ! 
    131132         IF( ln_rstart .AND.    &                    ! Restart: read in restart file 
    132133              & iom_varid( numror, 'qsr_hc_b', ldstop = .FALSE. ) > 0 ) THEN 
    … …  
    163164         CALL iom_put( 'qsr3d', etot3 )   ! Shortwave Radiation 3D distribution 
    164165         ! clem: store attenuation coefficient of the first ocean level 
    165          IF ( lk_lim3 .AND. ln_qsr_ice ) THEN 
     166         IF ( ln_qsr_ice ) THEN 
    166167            DO jj = 1, jpj 
    167168               DO ji = 1, jpi 
    168169                  IF ( qsr(ji,jj) /= 0._wp ) THEN 
    169                      oatte(ji,jj) = ( qsr_hc(ji,jj,1) / ( r1_rau0_rcp * qsr(ji,jj) ) ) 
    170                      iatte(ji,jj) = oatte(ji,jj) 
     170                     fraqsr_1lev(ji,jj) = ( qsr_hc(ji,jj,1) / ( r1_rau0_rcp * qsr(ji,jj) ) ) 
     171                  ELSE 
     172                     fraqsr_1lev(ji,jj) = 1. 
    171173                  ENDIF 
    172174               END DO 
    … …  
    232234               END DO 
    233235               ! clem: store attenuation coefficient of the first ocean level 
    234                IF ( lk_lim3 .AND. ln_qsr_ice ) THEN 
     236               IF ( ln_qsr_ice ) THEN 
    235237                  DO jj = 1, jpj 
    236238                     DO ji = 1, jpi 
    … …  
    239241                        zzc2 = zcoef  * EXP( - fse3t(ji,jj,1) * zekg(ji,jj) ) 
    240242                        zzc3 = zcoef  * EXP( - fse3t(ji,jj,1) * zekr(ji,jj) ) 
    241                         oatte(ji,jj) = 1.0 - ( zzc0 + zzc1 + zzc2  + zzc3  ) * tmask(ji,jj,2)  
    242                         iatte(ji,jj) = 1.0 - ( zzc0 + zzc1 + zcoef + zcoef ) * tmask(ji,jj,2) 
     243                        fraqsr_1lev(ji,jj) = 1.0 - ( zzc0 + zzc1 + zzc2  + zzc3  ) * tmask(ji,jj,2)  
    243244                     END DO 
    244245                  END DO 
    … …  
    256257               END DO 
    257258               ! clem: store attenuation coefficient of the first ocean level 
    258                IF ( lk_lim3 .AND. ln_qsr_ice ) THEN 
    259                   oatte(:,:) = etot3(:,:,1) / r1_rau0_rcp 
    260                   iatte(:,:) = oatte(:,:) 
     259               IF ( ln_qsr_ice ) THEN 
     260                  fraqsr_1lev(:,:) = etot3(:,:,1) / r1_rau0_rcp 
    261261               ENDIF 
    262262           ENDIF 
    … …  
    280280               END DO 
    281281               ! clem: store attenuation coefficient of the first ocean level 
    282                IF ( lk_lim3 .AND. ln_qsr_ice ) THEN 
     282               IF ( ln_qsr_ice ) THEN 
    283283                  DO jj = 1, jpj 
    284284                     DO ji = 1, jpi 
    285285                        zc0 = zz0 * EXP( -fsdepw(ji,jj,1)*xsi0r ) + zz1 * EXP( -fsdepw(ji,jj,1)*xsi1r ) 
    286286                        zc1 = zz0 * EXP( -fsdepw(ji,jj,2)*xsi0r ) + zz1 * EXP( -fsdepw(ji,jj,2)*xsi1r ) 
    287                         oatte(ji,jj) = ( zc0*tmask(ji,jj,1) - zc1*tmask(ji,jj,2) ) / r1_rau0_rcp 
    288                         iatte(ji,jj) = oatte(ji,jj) 
     287                        fraqsr_1lev(ji,jj) = ( zc0*tmask(ji,jj,1) - zc1*tmask(ji,jj,2) ) / r1_rau0_rcp 
    289288                     END DO 
    290289                  END DO 
    … …  
    294293                  DO jj = 2, jpjm1 
    295294                     DO ji = fs_2, fs_jpim1   ! vector opt. 
    296                         qsr_hc(ji,jj,jk) =  etot3(ji,jj,jk) * qsr(ji,jj) 
     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) 
    297297                     END DO 
    298298                  END DO 
    299299               END DO 
    300300               ! clem: store attenuation coefficient of the first ocean level 
    301                IF ( lk_lim3 .AND. ln_qsr_ice ) THEN 
    302                   oatte(:,:) = etot3(:,:,1) / r1_rau0_rcp 
    303                   iatte(:,:) = oatte(:,:) 
     301               IF ( ln_qsr_ice ) THEN 
     302                  fraqsr_1lev(:,:) = etot3(:,:,1) / r1_rau0_rcp 
    304303               ENDIF 
    305304               ! 
    … …  
    326325            &                    'at it= ', kt,' date= ', ndastp 
    327326         IF(lwp) WRITE(numout,*) '~~~~' 
    328          CALL iom_rstput( kt, nitrst, numrow, 'qsr_hc_b', qsr_hc ) 
     327         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  
    329329         ! 
    330330      ENDIF 
    … …  
    332332      IF( l_trdtra ) THEN     ! qsr tracers trends saved for diagnostics 
    333333         ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 
    334          CALL trd_tra( kt, 'TRA', jp_tem, jptra_trd_qsr, ztrdt ) 
     334         CALL trd_tra( kt, 'TRA', jp_tem, jptra_qsr, ztrdt ) 
    335335         CALL wrk_dealloc( jpi, jpj, jpk, ztrdt )  
    336336      ENDIF 
    … …  
    381381      ! 
    382382      IF( nn_timing == 1 )  CALL timing_start('tra_qsr_init') 
    383       ! 
    384       ! clem init for oatte and iatte 
    385       IF( .NOT. ln_rstart ) THEN 
    386          oatte(:,:) = 1._wp 
    387          iatte(:,:) = 1._wp 
    388       ENDIF 
    389383      ! 
    390384      CALL wrk_alloc( jpi, jpj,      zekb, zekg, zekr        )  
    … …  
    415409         WRITE(numout,*) '      RGB & 2 bands: shortess depth of extinction  rn_si0 = ', rn_si0 
    416410         WRITE(numout,*) '      2 bands: longest depth of extinction         rn_si1 = ', rn_si1 
    417          WRITE(numout,*) '      light penetration for ice-model LIM3     ln_qsr_ice = ', ln_qsr_ice     
    418411      ENDIF 
    419412 
    … …  
    520513                  ! 
    521514                  DO jk = 1, nksr 
    522                      etot3(:,:,jk) = r1_rau0_rcp * ( zea(:,:,jk) - zea(:,:,jk+1) )  
     515                     ! (ISF) no light penetration below the ice shelves 
     516                     etot3(:,:,jk) = r1_rau0_rcp * ( zea(:,:,jk) - zea(:,:,jk+1) ) * tmask(:,:,1) 
    523517                  END DO 
    524518                  etot3(:,:,nksr+1:jpk) = 0.e0                ! below 400m set to zero 
    … …  
    548542                        zc0 = zz0 * EXP( -fsdepw(ji,jj,jk  )*xsi0r ) + zz1 * EXP( -fsdepw(ji,jj,jk  )*xsi1r ) 
    549543                        zc1 = zz0 * EXP( -fsdepw(ji,jj,jk+1)*xsi0r ) + zz1 * EXP( -fsdepw(ji,jj,jk+1)*xsi1r ) 
    550                         etot3(ji,jj,jk) = (  zc0 * tmask(ji,jj,jk) - zc1 * tmask(ji,jj,jk+1)  )  
     544                        etot3(ji,jj,jk) = (  zc0 * tmask(ji,jj,jk) - zc1 * tmask(ji,jj,jk+1)  ) * tmask(ji,jj,1)  
    551545                     END DO 
    552546                  END DO 
    … …  
    566560      ENDIF 
    567561      ! 
     562      ! initialisation of fraqsr_1lev used in sbcssm 
     563      IF( iom_varid( numror, 'fraqsr_1lev', ldstop = .FALSE. ) > 0 ) THEN 
     564         CALL iom_get( numror, jpdom_autoglo, 'fraqsr_1lev'  , fraqsr_1lev  ) 
     565      ELSE 
     566         fraqsr_1lev(:,:) = 1._wp   ! default definition 
     567      ENDIF 
     568      ! 
    568569      CALL wrk_dealloc( jpi, jpj,      zekb, zekg, zekr        )  
    569570      CALL wrk_dealloc( jpi, jpj, jpk, ze0, ze1, ze2, ze3, zea )  

  • branches/2014/dev_r4650_UKMO14.5_SST_BIAS_CORRECTION/NEMOGCM/NEMO/OPA_SRC/TRA/trasbc.F90

    r3764 r5965  
    99   !!            3.3  !  2010-04  (M. Leclair, G. Madec)  Forcing averaged over 2 time steps 
    1010   !!             -   !  2010-09  (C. Ethe, G. Madec) Merge TRA-TRC 
     11   !!            3.6  !  2014-11  (P. Mathiot) isf melting forcing  
    1112   !!---------------------------------------------------------------------- 
    1213 
    … …  
    1819   USE dom_oce         ! ocean space domain variables 
    1920   USE phycst          ! physical constant 
     21   USE sbcmod          ! ln_rnf   
     22   USE sbcrnf          ! River runoff   
     23   USE sbcisf          ! Ice shelf    
    2024   USE traqsr          ! solar radiation penetration 
    21    USE trdmod_oce      ! ocean trends  
    22    USE trdtra          ! ocean trends 
     25   USE trd_oce         ! trends: ocean variables 
     26   USE trdtra          ! trends manager: tracers  
     27   ! 
    2328   USE in_out_manager  ! I/O manager 
    2429   USE prtctl          ! Print control 
    25    USE sbcrnf          ! River runoff   
    26    USE sbcmod          ! ln_rnf   
    2730   USE iom 
    2831   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    2932   USE wrk_nemo        ! Memory Allocation 
    3033   USE timing          ! Timing 
     34   USE eosbn2 
    3135 
    3236   IMPLICIT NONE 
    … …  
    3943#  include "vectopt_loop_substitute.h90" 
    4044   !!---------------------------------------------------------------------- 
    41    !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
     45   !! NEMO/OPA 3.7 , NEMO Consortium (2014) 
    4246   !! $Id$ 
    4347   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    … …  
    9195      !!         where emp, the surface freshwater budget (evaporation minus 
    9296      !!         precipitation minus runoff) given in kg/m2/s is divided 
    93       !!         by rau0 = 1020 kg/m3 (density of sea water) to obtain m/s.     
     97      !!         by rau0 (density of sea water) to obtain m/s.     
    9498      !!         Note: even though Fwe does not appear explicitly for  
    9599      !!         temperature in this routine, the heat carried by the water 
    … …  
    107111      !! ** Action  : - Update the 1st level of (ta,sa) with the trend associated 
    108112      !!                with the tracer surface boundary condition  
    109       !!              - save the trend it in ttrd ('key_trdtra') 
     113      !!              - send trends to trdtra module (l_trdtra=T) 
    110114      !!---------------------------------------------------------------------- 
    111115      INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
    112116      !! 
    113117      INTEGER  ::   ji, jj, jk, jn           ! dummy loop indices   
     118      INTEGER  ::   ikt, ikb  
     119      INTEGER  ::   nk_isf 
    114120      REAL(wp) ::   zfact, z1_e3t, zdep 
     121      REAL(wp) ::   zalpha, zhk 
     122      REAL(wp) ::  zt_frz, zpress 
    115123      REAL(wp), POINTER, DIMENSION(:,:,:) ::  ztrdt, ztrds 
    116124      !!---------------------------------------------------------------------- 
    … …  
    124132      ENDIF 
    125133 
    126       IF( l_trdtra )   THEN                    !* Save ta and sa trends 
     134      IF( l_trdtra ) THEN                    !* Save ta and sa trends 
    127135         CALL wrk_alloc( jpi, jpj, jpk, ztrdt, ztrds )  
    128136         ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 
    … …  
    137145 
    138146      !---------------------------------------- 
    139       !        EMP, EMPS and QNS effects 
     147      !        EMP, SFX and QNS effects 
    140148      !---------------------------------------- 
    141149      !                                          Set before sbc tracer content fields 
    … …  
    146154              & iom_varid( numror, 'sbc_hc_b', ldstop = .FALSE. ) > 0 ) THEN 
    147155            IF(lwp) WRITE(numout,*) '          nit000-1 surface tracer content forcing fields red in the restart file' 
    148             zfact = 0.5e0 
     156            zfact = 0.5_wp 
    149157            CALL iom_get( numror, jpdom_autoglo, 'sbc_hc_b', sbc_tsc_b(:,:,jp_tem) )   ! before heat content sbc trend 
    150158            CALL iom_get( numror, jpdom_autoglo, 'sbc_sc_b', sbc_tsc_b(:,:,jp_sal) )   ! before salt content sbc trend 
    151159         ELSE                                         ! No restart or restart not found: Euler forward time stepping 
    152             zfact = 1.e0 
    153             sbc_tsc_b(:,:,:) = 0.e0 
     160            zfact = 1._wp 
     161            sbc_tsc_b(:,:,:) = 0._wp 
    154162         ENDIF 
    155163      ELSE                                         ! Swap of forcing fields 
    156164         !                                         ! ---------------------- 
    157          zfact = 0.5e0 
     165         zfact = 0.5_wp 
    158166         sbc_tsc_b(:,:,:) = sbc_tsc(:,:,:) 
    159167      ENDIF 
    … …  
    182190            END DO 
    183191         END DO 
    184          CALL iom_put( "emp_x_sst", emp (:,:) * tsn(:,:,1,jp_tem) )                          ! c/d term on sst 
    185          CALL iom_put( "emp_x_sss", emp (:,:) * tsn(:,:,1,jp_sal) )                          ! c/d term on sss 
     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 
    186194      ENDIF 
    187195      ! Concentration dilution effect on (t,s) due to evapouration, precipitation and qns, but not river runoff   
    … …  
    205213      ENDIF 
    206214      ! 
     215      ! 
     216      !---------------------------------------- 
     217      !       Ice Shelf effects (ISF) 
     218      !     tbl treated as in Losh (2008) JGR 
     219      !---------------------------------------- 
     220      ! 
     221      IF( nn_isf > 0 ) THEN 
     222         zfact = 0.5e0 
     223         DO jj = 2, jpj 
     224            DO ji = fs_2, fs_jpim1 
     225          
     226               ikt = misfkt(ji,jj) 
     227               ikb = misfkb(ji,jj) 
     228    
     229               ! 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) 
     231               ! sign - because fwf sign of evapo (rnf sign of precip) 
     232               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 ) 
     236               ! 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) & 
     240                     &           * 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) 
     243               END DO 
     244    
     245               ! 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 ) 
     249               ! 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) &  
     253                  &              * 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)  
     256            END DO 
     257         END DO 
     258         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(:,:)          ) 
     264            CALL iom_rstput( kt, nitrst, numrow, 'isf_hc_b' , risf_tsc(:,:,jp_tem) ) 
     265            CALL iom_rstput( kt, nitrst, numrow, 'isf_sc_b' , risf_tsc(:,:,jp_sal) ) 
     266         ENDIF 
     267      END IF 
     268      ! 
    207269      !---------------------------------------- 
    208270      !        River Runoff effects 
    … …  
    226288      ENDIF 
    227289  
    228       IF( l_trdtra )   THEN                      ! save the horizontal diffusive trends for further diagnostics 
     290      IF( l_trdtra )   THEN                      ! send trends for further diagnostics 
    229291         ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 
    230292         ztrds(:,:,:) = tsa(:,:,:,jp_sal) - ztrds(:,:,:) 
    231          CALL trd_tra( kt, 'TRA', jp_tem, jptra_trd_nsr, ztrdt ) 
    232          CALL trd_tra( kt, 'TRA', jp_sal, jptra_trd_nsr, ztrds ) 
     293         CALL trd_tra( kt, 'TRA', jp_tem, jptra_nsr, ztrdt ) 
     294         CALL trd_tra( kt, 'TRA', jp_sal, jptra_nsr, ztrds ) 
    233295         CALL wrk_dealloc( jpi, jpj, jpk, ztrdt, ztrds )  
    234296      ENDIF 

  • branches/2014/dev_r4650_UKMO14.5_SST_BIAS_CORRECTION/NEMOGCM/NEMO/OPA_SRC/TRA/trazdf.F90

    r3294 r5965  
    1919   USE sbc_oce         ! surface boundary condition: ocean 
    2020   USE dynspg_oce 
    21  
    2221   USE trazdf_exp      ! vertical diffusion: explicit (tra_zdf_exp     routine) 
    2322   USE trazdf_imp      ! vertical diffusion: implicit (tra_zdf_imp     routine) 
    24  
    2523   USE ldftra_oce      ! ocean active tracers: lateral physics 
    26    USE trdmod_oce      ! ocean active tracers: lateral physics 
    27    USE trdtra      ! ocean tracers trends  
     24   USE trd_oce         ! trends: ocean variables 
     25   USE trdtra          ! trends manager: tracers  
     26   ! 
    2827   USE in_out_manager  ! I/O manager 
    2928   USE prtctl          ! Print control 
    … …  
    3231   USE wrk_nemo        ! Memory allocation 
    3332   USE timing          ! Timing 
    34  
    3533 
    3634   IMPLICIT NONE 
    … …  
    4745#  include "vectopt_loop_substitute.h90" 
    4846   !!---------------------------------------------------------------------- 
    49    !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
     47   !! NEMO/OPA 3.7 , NEMO Consortium (2014) 
    5048   !! $Id$ 
    5149   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    … …  
    9088         &             tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    9189      END SELECT 
     90      ! DRAKKAR SSS control { 
     91      ! JMM avoid negative salinities near river outlet ! Ugly fix 
     92      ! JMM : restore negative salinities to small salinities: 
     93      WHERE ( tsa(:,:,:,jp_sal) < 0._wp )   tsa(:,:,:,jp_sal) = 0.1_wp 
    9294 
    9395      IF( l_trdtra )   THEN                      ! save the vertical diffusive trends for further diagnostics 
    … …  
    9698            ztrds(:,:,jk) = ( ( tsa(:,:,jk,jp_sal) - tsb(:,:,jk,jp_sal) ) / r2dtra(jk) ) - ztrds(:,:,jk) 
    9799         END DO 
    98          CALL trd_tra( kt, 'TRA', jp_tem, jptra_trd_zdf, ztrdt ) 
    99          CALL trd_tra( kt, 'TRA', jp_sal, jptra_trd_zdf, ztrds ) 
     100         CALL lbc_lnk( ztrdt, 'T', 1. ) 
     101         CALL lbc_lnk( ztrds, 'T', 1. ) 
     102         CALL trd_tra( kt, 'TRA', jp_tem, jptra_zdf, ztrdt ) 
     103         CALL trd_tra( kt, 'TRA', jp_sal, jptra_zdf, ztrds ) 
    100104         CALL wrk_dealloc( jpi, jpj, jpk, ztrdt, ztrds ) 
    101105      ENDIF 

  • branches/2014/dev_r4650_UKMO14.5_SST_BIAS_CORRECTION/NEMOGCM/NEMO/OPA_SRC/TRA/trazdf_imp.F90

    r3294 r5965  
    120120            ELSE                                            ;   zwt(:,:,2:jpk) = fsavs(:,:,2:jpk) 
    121121            ENDIF 
    122             zwt(:,:,1) = 0._wp 
    123             ! 
     122            DO jj=1, jpj 
     123               DO ji=1, jpi 
     124                  zwt(ji,jj,1) = 0._wp 
     125               END DO 
     126            END DO 
     127! 
    124128#if defined key_ldfslp 
    125129            ! isoneutral diffusion: add the contribution  
    … …  
    186190               DO jj = 2, jpjm1 
    187191                  DO ji = fs_2, fs_jpim1 
    188                     zwt(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwt(ji,jj,jk-1) 
     192                     zwt(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwt(ji,jj,jk-1) 
    189193                  END DO 
    190194               END DO 
    … …  
    198202               ze3tb = ( 1. - r_vvl ) + r_vvl * fse3t_b(ji,jj,1) 
    199203               ze3tn = ( 1. - r_vvl ) + r_vvl * fse3t(ji,jj,1) 
    200                pta(ji,jj,1,jn) = ze3tb * ptb(ji,jj,1,jn) + p2dt(1) * ze3tn * pta(ji,jj,1,jn) 
     204               pta(ji,jj,1,jn) = ze3tb * ptb(ji,jj,1,jn)                     & 
     205                  &                      + p2dt(1) * ze3tn * pta(ji,jj,1,jn) 
    201206            END DO 
    202207         END DO 

  • branches/2014/dev_r4650_UKMO14.5_SST_BIAS_CORRECTION/NEMOGCM/NEMO/OPA_SRC/TRA/zpshde.F90

    r3294 r5965  
    88   !!             -   !  2004-03  (C. Ethe)  adapted for passive tracers 
    99   !!            3.3  !  2010-05  (C. Ethe, G. Madec)  merge TRC-TRA  
     10   !!            3.6  !  2014-11  (P. Mathiot) Add zps_hde_isf (needed to open a cavity) 
    1011   !!====================================================================== 
    1112    
    … …  
    2728   PRIVATE 
    2829 
    29    PUBLIC   zps_hde    ! routine called by step.F90 
     30   PUBLIC   zps_hde     ! routine called by step.F90 
     31   PUBLIC   zps_hde_isf ! routine called by step.F90 
    3032 
    3133   !! * Substitutions 
    … …  
    4042 
    4143   SUBROUTINE zps_hde( kt, kjpt, pta, pgtu, pgtv,   & 
    42                                  prd, pgru, pgrv    ) 
     44      &                          prd, pgru, pgrv    ) 
    4345      !!---------------------------------------------------------------------- 
    4446      !!                     ***  ROUTINE zps_hde  *** 
    … …  
    7476      !!          Idem for di(s) and dj(s)           
    7577      !! 
    76       !!      For rho, we call eos_insitu_2d which will compute rd~(t~,s~) at  
    77       !!      the good depth zh from interpolated T and S for the different 
    78       !!      formulation of the equation of state (eos). 
     78      !!      For rho, we call eos which will compute rd~(t~,s~) at the right 
     79      !!      depth zh from interpolated T and S for the different formulations 
     80      !!      of the equation of state (eos). 
    7981      !!      Gradient formulation for rho : 
    80       !!          di(rho) = rd~ - rd(i,j,k) or rd(i+1,j,k) - rd~ 
     82      !!          di(rho) = rd~ - rd(i,j,k)   or  rd(i+1,j,k) - rd~ 
    8183      !! 
    82       !! ** Action  : - pgtu, pgtv: horizontal gradient of tracer at u- & v-points 
    83       !!              - pgru, pgrv: horizontal gradient of rho (if present) at u- & v-points  
     84      !! ** Action  : compute for top interfaces 
     85      !!              - pgtu, pgtv: horizontal gradient of tracer at u- & v-points 
     86      !!              - pgru, pgrv: horizontal gradient of rho (if present) at u- & v-points 
    8487      !!---------------------------------------------------------------------- 
    85       ! 
    8688      INTEGER                              , INTENT(in   )           ::  kt          ! ocean time-step index 
    8789      INTEGER                              , INTENT(in   )           ::  kjpt        ! number of tracers 
    … …  
    8991      REAL(wp), DIMENSION(jpi,jpj,    kjpt), INTENT(  out)           ::  pgtu, pgtv  ! hor. grad. of ptra at u- & v-pts  
    9092      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ), OPTIONAL ::  prd         ! 3D density anomaly fields 
    91       REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pgru, pgrv  ! hor. grad. of prd at u- & v-pts  
     93      REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pgru, pgrv  ! hor. grad of prd at u- & v-pts (bottom) 
    9294      ! 
    9395      INTEGER  ::   ji, jj, jn      ! Dummy loop indices 
    9496      INTEGER  ::   iku, ikv, ikum1, ikvm1   ! partial step level (ocean bottom level) at u- and v-points 
    9597      REAL(wp) ::  ze3wu, ze3wv, zmaxu, zmaxv  ! temporary scalars 
    96       REAL(wp), POINTER, DIMENSION(:,:  ) ::  zri, zrj, zhi, zhj 
    97       REAL(wp), POINTER, DIMENSION(:,:,:) ::  zti, ztj    ! interpolated value of tracer 
     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             !  
    98100      !!---------------------------------------------------------------------- 
    99101      ! 
    100102      IF( nn_timing == 1 )  CALL timing_start( 'zps_hde') 
    101103      ! 
    102       CALL wrk_alloc( jpi, jpj,       zri, zrj, zhi, zhj )  
    103       CALL wrk_alloc( jpi, jpj, kjpt, zti, ztj           )  
     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 ; 
    104107      ! 
    105108      DO jn = 1, kjpt      !==   Interpolation of tracers at the last ocean level   ==! 
    106109         ! 
    107 # if defined key_vectopt_loop 
    108          jj = 1 
    109          DO ji = 1, jpij-jpi   ! vector opt. (forced unrolled) 
    110 # else 
    111          DO jj = 1, jpjm1 
    112             DO ji = 1, jpim1 
    113 # endif 
     110         DO jj = 1, jpjm1 
     111            DO ji = 1, jpim1 
    114112               iku = mbku(ji,jj)   ;   ikum1 = MAX( iku - 1 , 1 )    ! last and before last ocean level at u- & v-points 
    115113               ikv = mbkv(ji,jj)   ;   ikvm1 = MAX( ikv - 1 , 1 )    ! if level first is a p-step, ik.m1=1 
    … …  
    121119                  zmaxu =  ze3wu / fse3w(ji+1,jj,iku) 
    122120                  ! interpolated values of tracers 
    123                   zti(ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,ikum1,jn) - pta(ji+1,jj,iku,jn) ) 
     121                  zti (ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,ikum1,jn) - pta(ji+1,jj,iku,jn) ) 
    124122                  ! gradient of  tracers 
    125123                  pgtu(ji,jj,jn) = umask(ji,jj,1) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) ) 
    … …  
    127125                  zmaxu = -ze3wu / fse3w(ji,jj,iku) 
    128126                  ! interpolated values of tracers 
    129                   zti(ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,ikum1,jn) - pta(ji,jj,iku,jn) ) 
     127                  zti (ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,ikum1,jn) - pta(ji,jj,iku,jn) ) 
    130128                  ! gradient of tracers 
    131129                  pgtu(ji,jj,jn) = umask(ji,jj,1) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) ) 
    … …  
    136134                  zmaxv =  ze3wv / fse3w(ji,jj+1,ikv) 
    137135                  ! interpolated values of tracers 
    138                   ztj(ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikvm1,jn) - pta(ji,jj+1,ikv,jn) ) 
     136                  ztj (ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikvm1,jn) - pta(ji,jj+1,ikv,jn) ) 
    139137                  ! gradient of tracers 
    140138                  pgtv(ji,jj,jn) = vmask(ji,jj,1) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) ) 
    … …  
    142140                  zmaxv =  -ze3wv / fse3w(ji,jj,ikv) 
    143141                  ! interpolated values of tracers 
    144                   ztj(ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikvm1,jn) - pta(ji,jj,ikv,jn) ) 
     142                  ztj (ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikvm1,jn) - pta(ji,jj,ikv,jn) ) 
    145143                  ! gradient of tracers 
    146144                  pgtv(ji,jj,jn) = vmask(ji,jj,1) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) ) 
    147145               ENDIF 
    148 # if ! defined key_vectopt_loop 
    149             END DO 
    150 # endif 
     146            END DO 
    151147         END DO 
    152148         CALL lbc_lnk( pgtu(:,:,jn), 'U', -1. )   ;   CALL lbc_lnk( pgtv(:,:,jn), 'V', -1. )   ! Lateral boundary cond. 
    … …  
    156152      ! horizontal derivative of density anomalies (rd) 
    157153      IF( PRESENT( prd ) ) THEN         ! depth of the partial step level 
    158 # if defined key_vectopt_loop 
    159          jj = 1 
    160          DO ji = 1, jpij-jpi   ! vector opt. (forced unrolled) 
    161 # else 
    162          DO jj = 1, jpjm1 
    163             DO ji = 1, jpim1 
    164 # endif 
     154         pgru(:,:)=0.0_wp   ; pgrv(:,:)=0.0_wp ;  
     155         DO jj = 1, jpjm1 
     156            DO ji = 1, jpim1 
    165157               iku = mbku(ji,jj) 
    166158               ikv = mbkv(ji,jj) 
    … …  
    173165               ELSE                        ;   zhj(ji,jj) = fsdept(ji,jj+1,ikv)     ! -     -      case 2 
    174166               ENDIF 
    175 # if ! defined key_vectopt_loop 
    176             END DO 
    177 # endif 
     167            END DO 
    178168         END DO 
    179169 
    … …  
    184174 
    185175         ! Gradient of density at the last level  
    186 # if defined key_vectopt_loop 
    187          jj = 1 
    188          DO ji = 1, jpij-jpi   ! vector opt. (forced unrolled) 
    189 # else 
    190          DO jj = 1, jpjm1 
    191             DO ji = 1, jpim1 
    192 # endif 
     176         DO jj = 1, jpjm1 
     177            DO ji = 1, jpim1 
    193178               iku = mbku(ji,jj) 
    194179               ikv = mbkv(ji,jj) 
    195180               ze3wu  = fse3w(ji+1,jj  ,iku) - fse3w(ji,jj,iku) 
    196181               ze3wv  = fse3w(ji  ,jj+1,ikv) - fse3w(ji,jj,ikv) 
    197                IF( ze3wu >= 0._wp ) THEN   ;   pgru(ji,jj) = umask(ji,jj,1) * ( zri(ji  ,jj) - prd(ji,jj,iku) )   ! i: 1 
    198                ELSE                        ;   pgru(ji,jj) = umask(ji,jj,1) * ( prd(ji+1,jj,iku) - zri(ji,jj) )   ! i: 2 
    199                ENDIF 
    200                IF( ze3wv >= 0._wp ) THEN   ;   pgrv(ji,jj) = vmask(ji,jj,1) * ( zrj(ji,jj  ) - prd(ji,jj,ikv) )   ! j: 1 
    201                ELSE                        ;   pgrv(ji,jj) = vmask(ji,jj,1) * ( prd(ji,jj+1,ikv) - zrj(ji,jj) )   ! j: 2 
    202                ENDIF 
    203 # if ! defined key_vectopt_loop 
    204             END DO 
    205 # endif 
     182               IF( ze3wu >= 0._wp ) THEN   ;   pgru(ji,jj) = umask(ji,jj,1) * ( zri(ji  ,jj    ) - prd(ji,jj,iku) )   ! i: 1 
     183               ELSE                        ;   pgru(ji,jj) = umask(ji,jj,1) * ( prd(ji+1,jj,iku) - zri(ji,jj    ) )   ! i: 2 
     184               ENDIF 
     185               IF( ze3wv >= 0._wp ) THEN   ;   pgrv(ji,jj) = vmask(ji,jj,1) * ( zrj(ji,jj      ) - prd(ji,jj,ikv) )   ! j: 1 
     186               ELSE                        ;   pgrv(ji,jj) = vmask(ji,jj,1) * ( prd(ji,jj+1,ikv) - zrj(ji,jj    ) )   ! j: 2 
     187               ENDIF 
     188            END DO 
    206189         END DO 
    207190         CALL lbc_lnk( pgru , 'U', -1. )   ;   CALL lbc_lnk( pgrv , 'V', -1. )   ! Lateral boundary conditions 
    … …  
    209192      END IF 
    210193      ! 
    211       CALL wrk_dealloc( jpi, jpj,       zri, zrj, zhi, zhj )  
    212       CALL wrk_dealloc( jpi, jpj, kjpt, zti, ztj           )  
    213       ! 
    214194      IF( nn_timing == 1 )  CALL timing_stop( 'zps_hde') 
    215195      ! 
    216196   END SUBROUTINE zps_hde 
    217  
     197   ! 
     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  *** 
     203      !!                     
     204      !! ** Purpose :   Compute the horizontal derivative of T, S and rho 
     205      !!      at u- and v-points with a linear interpolation for z-coordinate 
     206      !!      with partial steps. 
     207      !! 
     208      !! ** Method  :   In z-coord with partial steps, scale factors on last  
     209      !!      levels are different for each grid point, so that T, S and rd  
     210      !!      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 :  
     212      !!      Linear interpolation of T, S    
     213      !!         Computation of di(tb) and dj(tb) by vertical interpolation: 
     214      !!          di(t) = t~ - t(i,j,k) or t(i+1,j,k) - t~ 
     215      !!          dj(t) = t~ - t(i,j,k) or t(i,j+1,k) - t~ 
     216      !!         This formulation computes the two cases: 
     217      !!                 CASE 1                   CASE 2   
     218      !!         k-1  ___ ___________   k-1   ___ ___________ 
     219      !!                    Ti  T~                  T~  Ti+1 
     220      !!                  _____                        _____ 
     221      !!         k        |   |Ti+1     k           Ti |   | 
     222      !!                  |   |____                ____|   | 
     223      !!              ___ |   |   |           ___  |   |   | 
     224      !!                   
     225      !!      case 1->   e3w(i+1) >= e3w(i) ( and e3w(j+1) >= e3w(j) ) then 
     226      !!          t~ = t(i+1,j  ,k) + (e3w(i+1) - e3w(i)) * dk(Ti+1)/e3w(i+1) 
     227      !!        ( t~ = t(i  ,j+1,k) + (e3w(j+1) - e3w(j)) * dk(Tj+1)/e3w(j+1)  ) 
     228      !!          or 
     229      !!      case 2->   e3w(i+1) <= e3w(i) ( and e3w(j+1) <= e3w(j) ) then 
     230      !!          t~ = t(i,j,k) + (e3w(i) - e3w(i+1)) * dk(Ti)/e3w(i ) 
     231      !!        ( t~ = t(i,j,k) + (e3w(j) - e3w(j+1)) * dk(Tj)/e3w(j ) ) 
     232      !!          Idem for di(s) and dj(s)           
     233      !! 
     234      !!      For rho, we call eos which will compute rd~(t~,s~) at the right 
     235      !!      depth zh from interpolated T and S for the different formulations 
     236      !!      of the equation of state (eos). 
     237      !!      Gradient formulation for rho : 
     238      !!          di(rho) = rd~ - rd(i,j,k)   or   rd(i+1,j,k) - rd~ 
     239      !! 
     240      !! ** Action  : compute for top and bottom interfaces 
     241      !!              - pgtu, pgtv, pgtui, pgtvi: horizontal gradient of tracer at u- & v-points 
     242      !!              - 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) 
     261      ! 
     262      INTEGER  ::   ji, jj, jn      ! Dummy loop indices 
     263      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 
     265      REAL(wp), DIMENSION(jpi,jpj)      ::  zri, zrj, zhi, zhj   ! NB: 3rd dim=1 to use eos 
     266      REAL(wp), DIMENSION(jpi,jpj,kjpt) ::  zti, ztj             !  
     267      !!---------------------------------------------------------------------- 
     268      ! 
     269      IF( nn_timing == 1 )  CALL timing_start( 'zps_hde_isf') 
     270      ! 
     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 ; 
     275      ! 
     276      DO jn = 1, kjpt      !==   Interpolation of tracers at the last ocean level   ==! 
     277         ! 
     278         DO jj = 1, jpjm1 
     279            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 
     282               ! (ISF) case partial step top and bottom in adjacent cell in vertical 
     283               ! cannot used e3w because if 2 cell water column, we have ps at top and bottom 
     284               ! in this case e3w(i,j) - e3w(i,j+1) is not the distance between Tj~ and Tj 
     285               ! 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               ! 
     289               ! i- direction 
     290               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) ) 
     294                  ! 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) ) 
     302               ENDIF 
     303               ! 
     304               ! j- direction 
     305               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. 
     321         ! 
     322      END DO 
     323 
     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 
     453               iku = miku(ji,jj) 
     454               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 
     516         ! 
     517      END IF   
     518      ! 
     519      IF( nn_timing == 1 )  CALL timing_stop( 'zps_hde_isf') 
     520      ! 
     521   END SUBROUTINE zps_hde_isf 
    218522   !!====================================================================== 
    219523END MODULE zpshde 
Note: See TracChangeset for help on using the changeset viewer.