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 13151 – NEMO

Changeset 13151


Ignore:
Timestamp:
2020-06-24T14:38:26+02:00 (4 years ago)
Author:
gm
Message:

result from merge with qco r12983

Location:
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src
Files:
8 added
163 edited

Legend:

Unmodified
Added
Removed

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/ABL/ablrst.F90

    r11945 r13151  
    7474            ENDIF 
    7575            ! 
    76             CALL iom_open( TRIM(clpath)//TRIM(clname), numraw, ldwrt = .TRUE., kdlev = jpka ) 
     76            CALL iom_open( TRIM(clpath)//TRIM(clname), numraw, ldwrt = .TRUE., kdlev = jpka, cdcomp = 'ABL' ) 
    7777            lrst_abl = .TRUE. 
    7878         ENDIF 
    … …  
    146146      ENDIF 
    147147 
    148       CALL iom_open ( TRIM(cn_ablrst_indir)//'/'//cn_ablrst_in, numrar, kdlev = jpka ) 
     148      CALL iom_open ( TRIM(cn_ablrst_indir)//'/'//cn_ablrst_in, numrar ) 
    149149 
    150150      ! Time info 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/ABL/sbcabl.F90

    r12489 r13151  
    7575      !!--------------------------------------------------------------------- 
    7676 
    77       REWIND( numnam_ref )              ! Namelist namsbc_abl in reference namelist : ABL parameters 
     77      ! Namelist namsbc_abl in reference namelist : ABL parameters 
    7878      READ  ( numnam_ref, namsbc_abl, IOSTAT = ios, ERR = 901 ) 
    7979901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_abl in reference namelist' ) 
    80       ! 
    81       REWIND( numnam_cfg )              ! Namelist namsbc_abl in configuration namelist : ABL parameters 
     80      ! Namelist namsbc_abl in configuration namelist : ABL parameters 
    8281      READ  ( numnam_cfg, namsbc_abl, IOSTAT = ios, ERR = 902 ) 
    8382902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_abl in configuration namelist' ) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/ICE/icectl.F90

    r12489 r13151  
    331331      IF(lwp) WRITE(numout,*)                 
    332332 
    333       CALL iom_open( TRIM(cdfile_name), inum, ldwrt = .TRUE., kdlev = jpl ) 
     333      CALL iom_open( TRIM(cdfile_name), inum, ldwrt = .TRUE., kdlev = jpl, cdcomp = 'ICE' ) 
    334334       
    335335      CALL iom_rstput( 0, 0, inum, 'cons_mass', pdiag_mass(:,:) , ktype = jp_r8 )    ! ice mass spurious lost/gain 
    … …  
    725725       
    726726      CALL prt_ctl_info(' ') 
    727       CALL prt_ctl_info(' - Heat / FW fluxes : ') 
    728       CALL prt_ctl_info('   ~~~~~~~~~~~~~~~~~~ ') 
    729       CALL prt_ctl(tab2d_1=sst_m  , clinfo1= ' sst   : ', tab2d_2=sss_m     , clinfo2= ' sss       : ') 
    730       CALL prt_ctl(tab2d_1=qsr    , clinfo1= ' qsr   : ', tab2d_2=qns       , clinfo2= ' qns       : ') 
    731       CALL prt_ctl(tab2d_1=emp    , clinfo1= ' emp   : ', tab2d_2=sfx       , clinfo2= ' sfx       : ') 
    732        
    733       CALL prt_ctl_info(' ') 
    734727      CALL prt_ctl_info(' - Stresses : ') 
    735728      CALL prt_ctl_info('   ~~~~~~~~~~ ') 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/ICE/icedyn_rhg_evp.F90

    r12489 r13151  
    4949   !! * Substitutions 
    5050#  include "do_loop_substitute.h90" 
     51#  include "domzgr_substitute.h90" 
    5152   !!---------------------------------------------------------------------- 
    5253   !! NEMO/ICE 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/ICE/iceistate.F90

    r12489 r13151  
    1818   USE oce            ! dynamics and tracers variables 
    1919   USE dom_oce        ! ocean domain 
    20    USE sbc_oce , ONLY : sst_m, sss_m, ln_ice_embd  
     20   USE sbc_oce , ONLY : sst_m, sss_m, ln_ice_embd 
    2121   USE sbc_ice , ONLY : tn_ice, snwice_mass, snwice_mass_b 
    2222   USE eosbn2         ! equation of state 
    … …  
    6060   INTEGER , PARAMETER ::   jp_hpd = 9           ! index of pnd depth        (m) 
    6161   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   si  ! structure of input fields (file informations, fields read) 
    62    !    
     62 
    6363   !! * Substitutions 
    6464#  include "do_loop_substitute.h90" 
    … …  
    7777      !! 
    7878      !! ** Method  :   This routine will put some ice where ocean 
    79       !!                is at the freezing point, then fill in ice  
    80       !!                state variables using prescribed initial  
    81       !!                values in the namelist             
     79      !!                is at the freezing point, then fill in ice 
     80      !!                state variables using prescribed initial 
     81      !!                values in the namelist 
    8282      !! 
    8383      !! ** Steps   :   1) Set initial surface and basal temperatures 
    … …  
    9191      !!              where there is no ice 
    9292      !!-------------------------------------------------------------------- 
    93       INTEGER, INTENT(in) :: kt            ! time step  
     93      INTEGER, INTENT(in) :: kt            ! time step 
    9494      INTEGER, INTENT(in) :: Kbb, Kmm, Kaa ! ocean time level indices 
    9595      ! 
    … …  
    102102      REAL(wp), DIMENSION(jpi,jpj)     ::   zt_su_ini, zht_s_ini, zsm_i_ini, ztm_i_ini !data from namelist or nc file 
    103103      REAL(wp), DIMENSION(jpi,jpj)     ::   zapnd_ini, zhpnd_ini                       !data from namelist or nc file 
    104       REAL(wp), DIMENSION(jpi,jpj,jpl) ::   zti_3d , zts_3d                            !temporary arrays 
     104      REAL(wp), DIMENSION(jpi,jpj,jpl) ::   zti_3d , zts_3d                            !locak arrays 
    105105      !! 
    106106      REAL(wp), DIMENSION(:,:), ALLOCATABLE ::   zhi_2d, zhs_2d, zai_2d, zti_2d, zts_2d, ztsu_2d, zsi_2d, zaip_2d, zhip_2d 
    … …  
    117117      ! basal temperature (considered at freezing point)   [Kelvin] 
    118118      CALL eos_fzp( sss_m(:,:), t_bo(:,:) ) 
    119       t_bo(:,:) = ( t_bo(:,:) + rt0 ) * tmask(:,:,1)  
     119      t_bo(:,:) = ( t_bo(:,:) + rt0 ) * tmask(:,:,1) 
    120120      ! 
    121121      ! surface temperature and conductivity 
    … …  
    142142      e_i (:,:,:,:) = 0._wp 
    143143      e_s (:,:,:,:) = 0._wp 
    144        
     144 
    145145      ! general fields 
    146146      a_i (:,:,:) = 0._wp 
    … …  
    213213            IF( TRIM(si(jp_apd)%clrootname) == 'NOT USED' ) & 
    214214               &     si(jp_apd)%fnow(:,:,1) = ( rn_apd_ini_n * zswitch + rn_apd_ini_s * (1._wp - zswitch) ) * tmask(:,:,1) & ! rn_apd = pond fraction => rn_apnd * a_i = pond conc. 
    215                &                              * si(jp_ati)%fnow(:,:,1)  
     215               &                              * si(jp_ati)%fnow(:,:,1) 
    216216            ! 
    217217            ! pond depth 
    … …  
    227227            ! 
    228228            ! change the switch for the following 
    229             WHERE( zat_i_ini(:,:) > 0._wp )   ;   zswitch(:,:) = tmask(:,:,1)  
     229            WHERE( zat_i_ini(:,:) > 0._wp )   ;   zswitch(:,:) = tmask(:,:,1) 
    230230            ELSEWHERE                         ;   zswitch(:,:) = 0._wp 
    231231            END WHERE 
    … …  
    234234            !                          !---------------! 
    235235            ! no ice if (sst - Tfreez) >= thresold 
    236             WHERE( ( sst_m(:,:) - (t_bo(:,:) - rt0) ) * tmask(:,:,1) >= rn_thres_sst )   ;   zswitch(:,:) = 0._wp  
     236            WHERE( ( sst_m(:,:) - (t_bo(:,:) - rt0) ) * tmask(:,:,1) >= rn_thres_sst )   ;   zswitch(:,:) = 0._wp 
    237237            ELSEWHERE                                                                    ;   zswitch(:,:) = tmask(:,:,1) 
    238238            END WHERE 
    … …  
    247247               zt_su_ini(:,:) = rn_tsu_ini_n * zswitch(:,:) 
    248248               ztm_s_ini(:,:) = rn_tms_ini_n * zswitch(:,:) 
    249                zapnd_ini(:,:) = rn_apd_ini_n * zswitch(:,:) * zat_i_ini(:,:) ! rn_apd = pond fraction => rn_apd * a_i = pond conc.  
     249               zapnd_ini(:,:) = rn_apd_ini_n * zswitch(:,:) * zat_i_ini(:,:) ! rn_apd = pond fraction => rn_apd * a_i = pond conc. 
    250250               zhpnd_ini(:,:) = rn_hpd_ini_n * zswitch(:,:) 
    251251            ELSEWHERE 
    … …  
    268268            zhpnd_ini(:,:) = 0._wp 
    269269         ENDIF 
    270           
     270 
    271271         !-------------! 
    272272         ! fill fields ! 
    … …  
    295295         ALLOCATE( zhi_2d(npti,jpl), zhs_2d(npti,jpl), zai_2d (npti,jpl), & 
    296296            &      zti_2d(npti,jpl), zts_2d(npti,jpl), ztsu_2d(npti,jpl), zsi_2d(npti,jpl), zaip_2d(npti,jpl), zhip_2d(npti,jpl) ) 
    297           
     297 
    298298         ! distribute 1-cat into jpl-cat: (jpi*jpj) -> (jpi*jpj,jpl) 
    299299         CALL ice_var_itd( h_i_1d(1:npti)  , h_s_1d(1:npti)  , at_i_1d(1:npti),                                                   & 
    … …  
    341341         DO jl = 1, jpl 
    342342            DO_3D_11_11( 1, nlay_i ) 
    343                t_i (ji,jj,jk,jl) = zti_3d(ji,jj,jl)  
     343               t_i (ji,jj,jk,jl) = zti_3d(ji,jj,jl) 
    344344               ztmelts          = - rTmlt * sz_i(ji,jj,jk,jl) + rt0 ! melting temperature in K 
    345345               e_i(ji,jj,jk,jl) = zswitch(ji,jj) * v_i(ji,jj,jl) * r1_nlay_i * & 
    … …  
    357357         END WHERE 
    358358         v_ip(:,:,:) = h_ip(:,:,:) * a_ip(:,:,:) 
    359            
     359 
    360360         ! specific temperatures for coupled runs 
    361361         tn_ice(:,:,:) = t_su(:,:,:) 
    … …  
    377377         ssh(:,:,Kbb) = ssh(:,:,Kbb) - snwice_mass(:,:) * r1_rho0 
    378378         ! 
    379          IF( .NOT.ln_linssh ) THEN 
    380             ! 
    381             WHERE( ht_0(:,:) > 0 )   ;   z2d(:,:) = 1._wp + ssh(:,:,Kmm)*tmask(:,:,1) / ht_0(:,:) 
    382             ELSEWHERE                ;   z2d(:,:) = 1._wp   ;   END WHERE 
    383             ! 
    384             DO jk = 1,jpkm1                     ! adjust initial vertical scale factors                 
    385                e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * z2d(:,:) 
    386                e3t(:,:,jk,Kbb) = e3t(:,:,jk,Kmm) 
    387                e3t(:,:,jk,Kaa) = e3t(:,:,jk,Kmm) 
    388             END DO 
    389             ! 
    390             ! Reconstruction of all vertical scale factors at now and before time-steps 
    391             ! ========================================================================= 
    392             ! Horizontal scale factor interpolations 
    393             ! -------------------------------------- 
    394             CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3u(:,:,:,Kbb), 'U' ) 
    395             CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3v(:,:,:,Kbb), 'V' ) 
    396             CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3u(:,:,:,Kmm), 'U' ) 
    397             CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3v(:,:,:,Kmm), 'V' ) 
    398             CALL dom_vvl_interpol( e3u(:,:,:,Kmm), e3f(:,:,:), 'F' ) 
    399             ! Vertical scale factor interpolations 
    400             ! ------------------------------------ 
    401             CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3w (:,:,:,Kmm), 'W'  ) 
    402             CALL dom_vvl_interpol( e3u(:,:,:,Kmm), e3uw(:,:,:,Kmm), 'UW' ) 
    403             CALL dom_vvl_interpol( e3v(:,:,:,Kmm), e3vw(:,:,:,Kmm), 'VW' ) 
    404             CALL dom_vvl_interpol( e3u(:,:,:,Kbb), e3uw(:,:,:,Kbb), 'UW' ) 
    405             CALL dom_vvl_interpol( e3v(:,:,:,Kbb), e3vw(:,:,:,Kbb), 'VW' ) 
    406             ! t- and w- points depth 
    407             ! ---------------------- 
    408             !!gm not sure of that.... 
    409             gdept(:,:,1,Kmm) = 0.5_wp * e3w(:,:,1,Kmm) 
    410             gdepw(:,:,1,Kmm) = 0.0_wp 
    411             gde3w(:,:,1) = gdept(:,:,1,Kmm) - ssh(:,:,Kmm) 
    412             DO jk = 2, jpk 
    413                gdept(:,:,jk,Kmm) = gdept(:,:,jk-1,Kmm) + e3w(:,:,jk  ,Kmm) 
    414                gdepw(:,:,jk,Kmm) = gdepw(:,:,jk-1,Kmm) + e3t(:,:,jk-1,Kmm) 
    415                gde3w(:,:,jk) = gdept(:,:,jk  ,Kmm) - ssh (:,:,Kmm) 
    416             END DO 
    417          ENDIF 
     379         IF( .NOT.ln_linssh )   CALL dom_vvl_zgr( Kbb, Kmm, Kaa )   ! interpolation scale factor, depth and water column 
     380! !!st 
     381!          IF( .NOT.ln_linssh ) THEN 
     382!             ! 
     383!             WHERE( ht_0(:,:) > 0 )   ;   z2d(:,:) = 1._wp + ssh(:,:,Kmm)*tmask(:,:,1) / ht_0(:,:) 
     384!             ELSEWHERE                ;   z2d(:,:) = 1._wp   ;   END WHERE 
     385!             ! 
     386!             DO jk = 1,jpkm1                     ! adjust initial vertical scale factors 
     387!                e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * z2d(:,:) 
     388!                e3t(:,:,jk,Kbb) = e3t(:,:,jk,Kmm) 
     389!                e3t(:,:,jk,Kaa) = e3t(:,:,jk,Kmm) 
     390!             END DO 
     391!             ! 
     392!             ! Reconstruction of all vertical scale factors at now and before time-steps 
     393!             ! ========================================================================= 
     394!             ! Horizontal scale factor interpolations 
     395!             ! -------------------------------------- 
     396!             CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3u(:,:,:,Kbb), 'U' ) 
     397!             CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3v(:,:,:,Kbb), 'V' ) 
     398!             CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3u(:,:,:,Kmm), 'U' ) 
     399!             CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3v(:,:,:,Kmm), 'V' ) 
     400!             CALL dom_vvl_interpol( e3u(:,:,:,Kmm), e3f(:,:,:), 'F' ) 
     401!             ! Vertical scale factor interpolations 
     402!             ! ------------------------------------ 
     403!             CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3w (:,:,:,Kmm), 'W'  ) 
     404!             CALL dom_vvl_interpol( e3u(:,:,:,Kmm), e3uw(:,:,:,Kmm), 'UW' ) 
     405!             CALL dom_vvl_interpol( e3v(:,:,:,Kmm), e3vw(:,:,:,Kmm), 'VW' ) 
     406!             CALL dom_vvl_interpol( e3u(:,:,:,Kbb), e3uw(:,:,:,Kbb), 'UW' ) 
     407!             CALL dom_vvl_interpol( e3v(:,:,:,Kbb), e3vw(:,:,:,Kbb), 'VW' ) 
     408!             ! t- and w- points depth 
     409!             ! ---------------------- 
     410!             !!gm not sure of that.... 
     411!             gdept(:,:,1,Kmm) = 0.5_wp * e3w(:,:,1,Kmm) 
     412!             gdepw(:,:,1,Kmm) = 0.0_wp 
     413!             gde3w(:,:,1) = gdept(:,:,1,Kmm) - ssh(:,:,Kmm) 
     414!             DO jk = 2, jpk 
     415!                gdept(:,:,jk,Kmm) = gdept(:,:,jk-1,Kmm) + e3w(:,:,jk  ,Kmm) 
     416!                gdepw(:,:,jk,Kmm) = gdepw(:,:,jk-1,Kmm) + e3t(:,:,jk-1,Kmm) 
     417!                gde3w(:,:,jk) = gdept(:,:,jk  ,Kmm) - ssh (:,:,Kmm) 
     418!             END DO 
     419!          ENDIF 
    418420      ENDIF 
    419        
     421 
    420422      !------------------------------------ 
    421423      ! 4) store fields at before time-step 
    … …  
    432434      v_ice_b(:,:)     = v_ice(:,:) 
    433435      ! total concentration is needed for Lupkes parameterizations 
    434       at_i_b (:,:)     = at_i (:,:)  
     436      at_i_b (:,:)     = at_i (:,:) 
    435437 
    436438!!clem: output of initial state should be written here but it is impossible because 
    437439!!      the ocean and ice are in the same file 
    438 !!      CALL dia_wri_state( 'output.init' ) 
     440!!      CALL dia_wri_state( Kmm, 'output.init' ) 
    439441      ! 
    440442   END SUBROUTINE ice_istate 
    … …  
    444446      !!------------------------------------------------------------------- 
    445447      !!                   ***  ROUTINE ice_istate_init  *** 
    446       !!         
    447       !! ** Purpose :   Definition of initial state of the ice  
    448       !! 
    449       !! ** Method  :   Read the namini namelist and check the parameter  
     448      !! 
     449      !! ** Purpose :   Definition of initial state of the ice 
     450      !! 
     451      !! ** Method  :   Read the namini namelist and check the parameter 
    450452      !!              values called at the first timestep (nit000) 
    451453      !! 
    … …  
    453455      !! 
    454456      !!----------------------------------------------------------------------------- 
    455       INTEGER ::   ios   ! Local integer output status for namelist read 
    456       INTEGER ::   ifpr, ierror 
     457      INTEGER ::   ios, ifpr, ierror   ! Local integers 
     458 
    457459      ! 
    458460      CHARACTER(len=256) ::  cn_dir          ! Root directory for location of ice files 
    … …  
    488490         WRITE(numout,*) '      max ocean temp. above Tfreeze with initial ice   rn_thres_sst   = ', rn_thres_sst 
    489491         IF( ln_iceini .AND. .NOT.ln_iceini_file ) THEN 
    490             WRITE(numout,*) '      initial snw thickness in the north-south         rn_hts_ini     = ', rn_hts_ini_n,rn_hts_ini_s  
     492            WRITE(numout,*) '      initial snw thickness in the north-south         rn_hts_ini     = ', rn_hts_ini_n,rn_hts_ini_s 
    491493            WRITE(numout,*) '      initial ice thickness in the north-south         rn_hti_ini     = ', rn_hti_ini_n,rn_hti_ini_s 
    492494            WRITE(numout,*) '      initial ice concentr  in the north-south         rn_ati_ini     = ', rn_ati_ini_n,rn_ati_ini_s 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/ICE/icerst.F90

    r12377 r13151  
    8080            ENDIF 
    8181            ! 
    82             CALL iom_open( TRIM(clpath)//TRIM(clname), numriw, ldwrt = .TRUE., kdlev = jpl ) 
     82            CALL iom_open( TRIM(clpath)//TRIM(clname), numriw, ldwrt = .TRUE., kdlev = jpl, cdcomp = 'ICE' ) 
    8383            lrst_ice = .TRUE. 
    8484         ENDIF 
    … …  
    185185      ENDIF 
    186186 
    187       CALL iom_open ( TRIM(cn_icerst_indir)//'/'//cn_icerst_in, numrir, kdlev = jpl ) 
     187      CALL iom_open ( TRIM(cn_icerst_indir)//'/'//cn_icerst_in, numrir ) 
    188188 
    189189      ! test if v_i exists  

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/ASM/asminc.F90

    r12489 r13151  
    99   !!                 ! 2007-04  (A. Weaver)  Merge with OPAVAR/NEMOVAR 
    1010   !!   NEMO     3.3  ! 2010-05  (D. Lea)  Update to work with NEMO v3.2 
    11    !!             -   ! 2010-05  (D. Lea)  add calc_month_len routine based on day_init  
     11   !!             -   ! 2010-05  (D. Lea)  add calc_month_len routine based on day_init 
    1212   !!            3.4  ! 2012-10  (A. Weaver and K. Mogensen) Fix for direct initialization 
    1313   !!                 ! 2014-09  (D. Lea)  Local calc_date removed use routine from OBS 
    … …  
    3131   USE zpshde          ! Partial step : Horizontal Derivative 
    3232   USE asmpar          ! Parameters for the assmilation interface 
    33    USE asmbkg          !  
     33   USE asmbkg          ! 
    3434   USE c1d             ! 1D initialization 
    3535   USE sbc_oce         ! Surface boundary condition variables. 
    … …  
    4545   IMPLICIT NONE 
    4646   PRIVATE 
    47     
     47 
    4848   PUBLIC   asm_inc_init   !: Initialize the increment arrays and IAU weights 
    4949   PUBLIC   tra_asm_inc    !: Apply the tracer (T and S) increments 
    … …  
    7272   REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE ::   u_bkg   , v_bkg      !: Background u- & v- velocity components 
    7373   REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE ::   t_bkginc, s_bkginc   !: Increment to the background T & S 
    74    REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE ::   u_bkginc, v_bkginc   !: Increment to the u- & v-components  
     74   REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE ::   u_bkginc, v_bkginc   !: Increment to the u- & v-components 
    7575   REAL(wp), PUBLIC, DIMENSION(:)    , ALLOCATABLE ::   wgtiau               !: IAU weights for each time step 
    7676#if defined key_asminc 
    … …  
    8080   INTEGER , PUBLIC ::   nitbkg      !: Time step of the background state used in the Jb term 
    8181   INTEGER , PUBLIC ::   nitdin      !: Time step of the background state for direct initialization 
    82    INTEGER , PUBLIC ::   nitiaustr   !: Time step of the start of the IAU interval  
     82   INTEGER , PUBLIC ::   nitiaustr   !: Time step of the start of the IAU interval 
    8383   INTEGER , PUBLIC ::   nitiaufin   !: Time step of the end of the IAU interval 
    84    !  
     84   ! 
    8585   INTEGER , PUBLIC ::   niaufn      !: Type of IAU weighing function: = 0   Constant weighting 
    86    !                                 !: = 1   Linear hat-like, centred in middle of IAU interval  
     86   !                                 !: = 1   Linear hat-like, centred in middle of IAU interval 
    8787   REAL(wp), PUBLIC ::   salfixmin   !: Ensure that the salinity is larger than this  value if (ln_salfix) 
    8888 
    … …  
    9595   !! * Substitutions 
    9696#  include "do_loop_substitute.h90" 
     97#  include "domzgr_substitute.h90" 
    9798   !!---------------------------------------------------------------------- 
    9899   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    105106      !!---------------------------------------------------------------------- 
    106107      !!                    ***  ROUTINE asm_inc_init  *** 
    107       !!           
     108      !! 
    108109      !! ** Purpose : Initialize the assimilation increment and IAU weights. 
    109110      !! 
    110111      !! ** Method  : Initialize the assimilation increment and IAU weights. 
    111112      !! 
    112       !! ** Action  :  
     113      !! ** Action  : 
    113114      !!---------------------------------------------------------------------- 
    114115      INTEGER, INTENT(in) ::  Kbb, Kmm, Krhs  ! time level indices 
    … …  
    262263         ! 
    263264         !                                !--------------------------------------------------------- 
    264          IF( niaufn == 0 ) THEN           ! Constant IAU forcing  
     265         IF( niaufn == 0 ) THEN           ! Constant IAU forcing 
    265266            !                             !--------------------------------------------------------- 
    266267            DO jt = 1, iiauper 
    … …  
    268269            END DO 
    269270            !                             !--------------------------------------------------------- 
    270          ELSEIF ( niaufn == 1 ) THEN      ! Linear hat-like, centred in middle of IAU interval  
     271         ELSEIF ( niaufn == 1 ) THEN      ! Linear hat-like, centred in middle of IAU interval 
    271272            !                             !--------------------------------------------------------- 
    272273            ! Compute the normalization factor 
    273274            znorm = 0._wp 
    274275            IF( MOD( iiauper, 2 ) == 0 ) THEN   ! Even number of time steps in IAU interval 
    275                imid = iiauper / 2  
     276               imid = iiauper / 2 
    276277               DO jt = 1, imid 
    277278                  znorm = znorm + REAL( jt ) 
    … …  
    279280               znorm = 2.0 * znorm 
    280281            ELSE                                ! Odd number of time steps in IAU interval 
    281                imid = ( iiauper + 1 ) / 2         
     282               imid = ( iiauper + 1 ) / 2 
    282283               DO jt = 1, imid - 1 
    283284                  znorm = znorm + REAL( jt ) 
    … …  
    306307             DO jt = 1, icycper 
    307308                ztotwgt = ztotwgt + wgtiau(jt) 
    308                 WRITE(numout,*) '         ', jt, '       ', wgtiau(jt)  
    309              END DO    
     309                WRITE(numout,*) '         ', jt, '       ', wgtiau(jt) 
     310             END DO 
    310311             WRITE(numout,*) '         ===================================' 
    311312             WRITE(numout,*) '         Time-integrated weight = ', ztotwgt 
    312313             WRITE(numout,*) '         ===================================' 
    313314          ENDIF 
    314           
     315 
    315316      ENDIF 
    316317 
    … …  
    337338         CALL iom_open( c_asminc, inum ) 
    338339         ! 
    339          CALL iom_get( inum, 'time'       , zdate_inc   )  
     340         CALL iom_get( inum, 'time'       , zdate_inc   ) 
    340341         CALL iom_get( inum, 'z_inc_dateb', z_inc_dateb ) 
    341342         CALL iom_get( inum, 'z_inc_datef', z_inc_datef ) 
    … …  
    344345         ! 
    345346         IF(lwp) THEN 
    346             WRITE(numout,*)  
     347            WRITE(numout,*) 
    347348            WRITE(numout,*) 'asm_inc_init : Assimilation increments valid between dates ', z_inc_dateb,' and ', z_inc_datef 
    348349            WRITE(numout,*) '~~~~~~~~~~~~' 
    … …  
    358359            &                ' not agree with Direct Initialization time' ) 
    359360 
    360          IF ( ln_trainc ) THEN    
     361         IF ( ln_trainc ) THEN 
    361362            CALL iom_get( inum, jpdom_autoglo, 'bckint', t_bkginc, 1 ) 
    362363            CALL iom_get( inum, jpdom_autoglo, 'bckins', s_bkginc, 1 ) 
    … …  
    370371         ENDIF 
    371372 
    372          IF ( ln_dyninc ) THEN    
    373             CALL iom_get( inum, jpdom_autoglo, 'bckinu', u_bkginc, 1 )               
    374             CALL iom_get( inum, jpdom_autoglo, 'bckinv', v_bkginc, 1 )               
     373         IF ( ln_dyninc ) THEN 
     374            CALL iom_get( inum, jpdom_autoglo, 'bckinu', u_bkginc, 1 ) 
     375            CALL iom_get( inum, jpdom_autoglo, 'bckinv', v_bkginc, 1 ) 
    375376            ! Apply the masks 
    376377            u_bkginc(:,:,:) = u_bkginc(:,:,:) * umask(:,:,:) 
    … …  
    381382            WHERE( ABS( v_bkginc(:,:,:) ) > 1.0e+10 ) v_bkginc(:,:,:) = 0.0 
    382383         ENDIF 
    383          
     384 
    384385         IF ( ln_sshinc ) THEN 
    385386            CALL iom_get( inum, jpdom_autoglo, 'bckineta', ssh_bkginc, 1 ) 
    … …  
    407408      IF ( ln_dyninc .AND. nn_divdmp > 0 ) THEN    ! Apply divergence damping filter 
    408409         !                                         !-------------------------------------- 
    409          ALLOCATE( zhdiv(jpi,jpj) )  
     410         ALLOCATE( zhdiv(jpi,jpj) ) 
    410411         ! 
    411412         DO jt = 1, nn_divdmp 
    … …  
    417418                     &            - e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm) * u_bkginc(ji-1,jj,jk)    & 
    418419                     &            + e1v(ji,jj  ) * e3v(ji,jj  ,jk,Kmm) * v_bkginc(ji,jj  ,jk)    & 
    419                      &            - e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) * v_bkginc(ji,jj-1,jk)  ) / e3t(ji,jj,jk,Kmm) 
     420                     &            - e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) * v_bkginc(ji,jj-1,jk)  ) & 
     421                     &            / e3t(ji,jj,jk,Kmm) 
    420422               END_2D 
    421423               CALL lbc_lnk( 'asminc', zhdiv, 'T', 1. )   ! lateral boundary cond. (no sign change) 
    … …  
    425427                     &               + 0.2_wp * ( zhdiv(ji+1,jj) - zhdiv(ji  ,jj) ) * r1_e1u(ji,jj) * umask(ji,jj,jk) 
    426428                  v_bkginc(ji,jj,jk) = v_bkginc(ji,jj,jk)                         & 
    427                      &               + 0.2_wp * ( zhdiv(ji,jj+1) - zhdiv(ji,jj  ) ) * r1_e2v(ji,jj) * vmask(ji,jj,jk)  
     429                     &               + 0.2_wp * ( zhdiv(ji,jj+1) - zhdiv(ji,jj  ) ) * r1_e2v(ji,jj) * vmask(ji,jj,jk) 
    428430               END_2D 
    429431            END DO 
    … …  
    431433         END DO 
    432434         ! 
    433          DEALLOCATE( zhdiv )  
     435         DEALLOCATE( zhdiv ) 
    434436         ! 
    435437      ENDIF 
    … …  
    452454         CALL iom_open( c_asmdin, inum ) 
    453455         ! 
    454          CALL iom_get( inum, 'rdastp', zdate_bkg )  
     456         CALL iom_get( inum, 'rdastp', zdate_bkg ) 
    455457         ! 
    456458         IF(lwp) THEN 
    457             WRITE(numout,*)  
     459            WRITE(numout,*) 
    458460            WRITE(numout,*) '   ==>>>  Assimilation background state valid at : ', zdate_bkg 
    459461            WRITE(numout,*) 
    … …  
    464466            &                ' not agree with Direct Initialization time' ) 
    465467         ! 
    466          IF ( ln_trainc ) THEN    
     468         IF ( ln_trainc ) THEN 
    467469            CALL iom_get( inum, jpdom_autoglo, 'tn', t_bkg ) 
    468470            CALL iom_get( inum, jpdom_autoglo, 'sn', s_bkg ) 
    … …  
    471473         ENDIF 
    472474         ! 
    473          IF ( ln_dyninc ) THEN    
     475         IF ( ln_dyninc ) THEN 
    474476            CALL iom_get( inum, jpdom_autoglo, 'un', u_bkg ) 
    475477            CALL iom_get( inum, jpdom_autoglo, 'vn', v_bkg ) 
    … …  
    499501      ! 
    500502   END SUBROUTINE asm_inc_init 
    501     
    502     
     503 
     504 
    503505   SUBROUTINE tra_asm_inc( kt, Kbb, Kmm, pts, Krhs ) 
    504506      !!---------------------------------------------------------------------- 
    505507      !!                    ***  ROUTINE tra_asm_inc  *** 
    506       !!           
     508      !! 
    507509      !! ** Purpose : Apply the tracer (T and S) assimilation increments 
    508510      !! 
    509511      !! ** Method  : Direct initialization or Incremental Analysis Updating 
    510512      !! 
    511       !! ** Action  :  
     513      !! ** Action  : 
    512514      !!---------------------------------------------------------------------- 
    513515      INTEGER                                  , INTENT(in   ) :: kt             ! Current time step 
    … …  
    521523      !!---------------------------------------------------------------------- 
    522524      ! 
    523       ! freezing point calculation taken from oc_fz_pt (but calculated for all depths)  
    524       ! used to prevent the applied increments taking the temperature below the local freezing point  
     525      ! freezing point calculation taken from oc_fz_pt (but calculated for all depths) 
     526      ! used to prevent the applied increments taking the temperature below the local freezing point 
    525527      DO jk = 1, jpkm1 
    526528        CALL eos_fzp( pts(:,:,jk,jp_sal,Kmm), fzptnz(:,:,jk), gdept(:,:,jk,Kmm) ) 
    … …  
    537539            ! 
    538540            IF(lwp) THEN 
    539                WRITE(numout,*)  
     541               WRITE(numout,*) 
    540542               WRITE(numout,*) 'tra_asm_inc : Tracer IAU at time step = ', kt,' with IAU weight = ', wgtiau(it) 
    541543               WRITE(numout,*) '~~~~~~~~~~~~' 
    … …  
    547549                  ! Do not apply negative increments if the temperature will fall below freezing 
    548550                  WHERE(t_bkginc(:,:,jk) > 0.0_wp .OR. & 
    549                      &   pts(:,:,jk,jp_tem,Kmm) + pts(:,:,jk,jp_tem,Krhs) + t_bkginc(:,:,jk) * wgtiau(it) > fzptnz(:,:,jk) )  
    550                      pts(:,:,jk,jp_tem,Krhs) = pts(:,:,jk,jp_tem,Krhs) + t_bkginc(:,:,jk) * zincwgt   
     551                     &   pts(:,:,jk,jp_tem,Kmm) + pts(:,:,jk,jp_tem,Krhs) + t_bkginc(:,:,jk) * wgtiau(it) > fzptnz(:,:,jk) ) 
     552                     pts(:,:,jk,jp_tem,Krhs) = pts(:,:,jk,jp_tem,Krhs) + t_bkginc(:,:,jk) * zincwgt 
    551553                  END WHERE 
    552554               ELSE 
    553                   pts(:,:,jk,jp_tem,Krhs) = pts(:,:,jk,jp_tem,Krhs) + t_bkginc(:,:,jk) * zincwgt   
     555                  pts(:,:,jk,jp_tem,Krhs) = pts(:,:,jk,jp_tem,Krhs) + t_bkginc(:,:,jk) * zincwgt 
    554556               ENDIF 
    555557               IF (ln_salfix) THEN 
    … …  
    557559                  ! minimum value salfixmin 
    558560                  WHERE(s_bkginc(:,:,jk) > 0.0_wp .OR. & 
    559                      &   pts(:,:,jk,jp_sal,Kmm) + pts(:,:,jk,jp_sal,Krhs) + s_bkginc(:,:,jk) * wgtiau(it) > salfixmin )  
     561                     &   pts(:,:,jk,jp_sal,Kmm) + pts(:,:,jk,jp_sal,Krhs) + s_bkginc(:,:,jk) * wgtiau(it) > salfixmin ) 
    560562                     pts(:,:,jk,jp_sal,Krhs) = pts(:,:,jk,jp_sal,Krhs) + s_bkginc(:,:,jk) * zincwgt 
    561563                  END WHERE 
    … …  
    574576      ELSEIF ( ln_asmdin ) THEN        ! Direct Initialization 
    575577         !                             !-------------------------------------- 
    576          !             
     578         ! 
    577579         IF ( kt == nitdin_r ) THEN 
    578580            ! 
    … …  
    582584            IF (ln_temnofreeze) THEN 
    583585               ! Do not apply negative increments if the temperature will fall below freezing 
    584                WHERE( t_bkginc(:,:,:) > 0.0_wp .OR. pts(:,:,:,jp_tem,Kmm) + t_bkginc(:,:,:) > fzptnz(:,:,:) )  
    585                   pts(:,:,:,jp_tem,Kmm) = t_bkg(:,:,:) + t_bkginc(:,:,:)    
     586               WHERE( t_bkginc(:,:,:) > 0.0_wp .OR. pts(:,:,:,jp_tem,Kmm) + t_bkginc(:,:,:) > fzptnz(:,:,:) ) 
     587                  pts(:,:,:,jp_tem,Kmm) = t_bkg(:,:,:) + t_bkginc(:,:,:) 
    586588               END WHERE 
    587589            ELSE 
    588                pts(:,:,:,jp_tem,Kmm) = t_bkg(:,:,:) + t_bkginc(:,:,:)    
     590               pts(:,:,:,jp_tem,Kmm) = t_bkg(:,:,:) + t_bkginc(:,:,:) 
    589591            ENDIF 
    590592            IF (ln_salfix) THEN 
    591593               ! Do not apply negative increments if the salinity will fall below a specified 
    592594               ! minimum value salfixmin 
    593                WHERE( s_bkginc(:,:,:) > 0.0_wp .OR. pts(:,:,:,jp_sal,Kmm) + s_bkginc(:,:,:) > salfixmin )  
    594                   pts(:,:,:,jp_sal,Kmm) = s_bkg(:,:,:) + s_bkginc(:,:,:)    
     595               WHERE( s_bkginc(:,:,:) > 0.0_wp .OR. pts(:,:,:,jp_sal,Kmm) + s_bkginc(:,:,:) > salfixmin ) 
     596                  pts(:,:,:,jp_sal,Kmm) = s_bkg(:,:,:) + s_bkginc(:,:,:) 
    595597               END WHERE 
    596598            ELSE 
    597                pts(:,:,:,jp_sal,Kmm) = s_bkg(:,:,:) + s_bkginc(:,:,:)    
     599               pts(:,:,:,jp_sal,Kmm) = s_bkg(:,:,:) + s_bkginc(:,:,:) 
    598600            ENDIF 
    599601 
    … …  
    617619            DEALLOCATE( s_bkg    ) 
    618620         ENDIF 
    619          !   
     621         ! 
    620622      ENDIF 
    621623      ! Perhaps the following call should be in step 
    … …  
    628630      !!---------------------------------------------------------------------- 
    629631      !!                    ***  ROUTINE dyn_asm_inc  *** 
    630       !!           
     632      !! 
    631633      !! ** Purpose : Apply the dynamics (u and v) assimilation increments. 
    632634      !! 
    633635      !! ** Method  : Direct initialization or Incremental Analysis Updating. 
    634636      !! 
    635       !! ** Action  :  
     637      !! ** Action  : 
    636638      !!---------------------------------------------------------------------- 
    637639      INTEGER                             , INTENT( in )  ::  kt             ! ocean time-step index 
    … …  
    654656            ! 
    655657            IF(lwp) THEN 
    656                WRITE(numout,*)  
     658               WRITE(numout,*) 
    657659               WRITE(numout,*) 'dyn_asm_inc : Dynamics IAU at time step = ', kt,' with IAU weight = ', wgtiau(it) 
    658660               WRITE(numout,*) '~~~~~~~~~~~~' 
    … …  
    674676      ELSEIF ( ln_asmdin ) THEN     ! Direct Initialization 
    675677         !                          !----------------------------------------- 
    676          !          
     678         ! 
    677679         IF ( kt == nitdin_r ) THEN 
    678680            ! 
    … …  
    681683            ! Initialize the now fields with the background + increment 
    682684            puu(:,:,:,Kmm) = u_bkg(:,:,:) + u_bkginc(:,:,:) 
    683             pvv(:,:,:,Kmm) = v_bkg(:,:,:) + v_bkginc(:,:,:)   
     685            pvv(:,:,:,Kmm) = v_bkg(:,:,:) + v_bkginc(:,:,:) 
    684686            ! 
    685687            puu(:,:,:,Kbb) = puu(:,:,:,Kmm)         ! Update before fields 
    … …  
    700702      !!---------------------------------------------------------------------- 
    701703      !!                    ***  ROUTINE ssh_asm_inc  *** 
    702       !!           
     704      !! 
    703705      !! ** Purpose : Apply the sea surface height assimilation increment. 
    704706      !! 
    705707      !! ** Method  : Direct initialization or Incremental Analysis Updating. 
    706708      !! 
    707       !! ** Action  :  
     709      !! ** Action  : 
    708710      !!---------------------------------------------------------------------- 
    709711      INTEGER, INTENT(IN) :: kt         ! Current time step 
    … …  
    725727            ! 
    726728            IF(lwp) THEN 
    727                WRITE(numout,*)  
     729               WRITE(numout,*) 
    728730               WRITE(numout,*) 'ssh_asm_inc : SSH IAU at time step = ', & 
    729731                  &  kt,' with IAU weight = ', wgtiau(it) 
    … …  
    758760            ! 
    759761            ssh(:,:,Kbb) = ssh(:,:,Kmm)                        ! Update before fields 
     762#if ! defined key_qco 
    760763            e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 
     764#endif 
    761765!!gm why not e3u(:,:,:,Kbb), e3v(:,:,:,Kbb), gdept(:,:,:,Kbb) ???? 
    762766            ! 
    … …  
    775779      !!                  ***  ROUTINE ssh_asm_div  *** 
    776780      !! 
    777       !! ** Purpose :   ssh increment with z* is incorporated via a correction of the local divergence           
     781      !! ** Purpose :   ssh increment with z* is incorporated via a correction of the local divergence 
    778782      !!                across all the water column 
    779783      !! 
    … …  
    791795      REAL(wp), DIMENSION(:,:)  , POINTER       ::   ztim     ! local array 
    792796      !!---------------------------------------------------------------------- 
    793       !  
     797      ! 
    794798#if defined key_asminc 
    795799      CALL ssh_asm_inc( kt, Kbb, Kmm ) !==   (calculate increments) 
    796800      ! 
    797       IF( ln_linssh ) THEN  
     801      IF( ln_linssh ) THEN 
    798802         phdivn(:,:,1) = phdivn(:,:,1) - ssh_iau(:,:) / e3t(:,:,1,Kmm) * tmask(:,:,1) 
    799       ELSE  
     803      ELSE 
    800804         ALLOCATE( ztim(jpi,jpj) ) 
    801805         ztim(:,:) = ssh_iau(:,:) / ( ht(:,:) + 1.0 - ssmask(:,:) ) 
    802          DO jk = 1, jpkm1                                  
    803             phdivn(:,:,jk) = phdivn(:,:,jk) - ztim(:,:) * tmask(:,:,jk)  
     806         DO jk = 1, jpkm1 
     807            phdivn(:,:,jk) = phdivn(:,:,jk) - ztim(:,:) * tmask(:,:,jk) 
    804808         END DO 
    805809         ! 
    … …  
    814818      !!---------------------------------------------------------------------- 
    815819      !!                    ***  ROUTINE seaice_asm_inc  *** 
    816       !!           
     820      !! 
    817821      !! ** Purpose : Apply the sea ice assimilation increment. 
    818822      !! 
    819823      !! ** Method  : Direct initialization or Incremental Analysis Updating. 
    820824      !! 
    821       !! ** Action  :  
     825      !! ** Action  : 
    822826      !! 
    823827      !!---------------------------------------------------------------------- 
    … …  
    840844            ! 
    841845            it = kt - nit000 + 1 
    842             zincwgt = wgtiau(it)      ! IAU weight for the current time step  
     846            zincwgt = wgtiau(it)      ! IAU weight for the current time step 
    843847            ! note this is not a tendency so should not be divided by rn_Dt (as with the tracer and other increments) 
    844848            ! 
    845849            IF(lwp) THEN 
    846                WRITE(numout,*)  
     850               WRITE(numout,*) 
    847851               WRITE(numout,*) 'seaice_asm_inc : sea ice conc IAU at time step = ', kt,' with IAU weight = ', wgtiau(it) 
    848852               WRITE(numout,*) '~~~~~~~~~~~~' 
    … …  
    862866            ! 
    863867            ! Nudge sea ice depth to bring it up to a required minimum depth 
    864             WHERE( zseaicendg(:,:) > 0.0_wp .AND. hm_i(:,:) < zhicifmin )  
    865                zhicifinc(:,:) = (zhicifmin - hm_i(:,:)) * zincwgt     
     868            WHERE( zseaicendg(:,:) > 0.0_wp .AND. hm_i(:,:) < zhicifmin ) 
     869               zhicifinc(:,:) = (zhicifmin - hm_i(:,:)) * zincwgt 
    866870            ELSEWHERE 
    867871               zhicifinc(:,:) = 0.0_wp 
    … …  
    896900         IF ( kt == nitdin_r ) THEN 
    897901            ! 
     902<<<<<<< .working 
    898903            l_1st_euler = 0              ! Force Euler forward step 
     904======= 
     905            l_1st_euler = .TRUE.              ! Force Euler forward step 
     906>>>>>>> .merge-right.r13092 
    899907            ! 
    900908            ! Sea-ice : SI3 case 
    … …  
    903911            zofrld (:,:) = 1._wp - at_i(:,:) 
    904912            zohicif(:,:) = hm_i(:,:) 
    905             !  
     913            ! 
    906914            ! Initialize the now fields the background + increment 
    907915            at_i(:,:) = 1. - MIN( MAX( 1.-at_i(:,:) - seaice_bkginc(:,:), 0.0_wp), 1.0_wp) 
    908             at_i_b(:,:) = at_i(:,:)  
     916            at_i_b(:,:) = at_i(:,:) 
    909917            fr_i(:,:) = at_i(:,:)        ! adjust ice fraction 
    910918            ! 
    … …  
    912920            ! 
    913921            ! Nudge sea ice depth to bring it up to a required minimum depth 
    914             WHERE( zseaicendg(:,:) > 0.0_wp .AND. hm_i(:,:) < zhicifmin )  
     922            WHERE( zseaicendg(:,:) > 0.0_wp .AND. hm_i(:,:) < zhicifmin ) 
    915923               zhicifinc(:,:) = zhicifmin - hm_i(:,:) 
    916924            ELSEWHERE 
    … …  
    942950!#if defined defined key_si3 || defined key_cice 
    943951! 
    944 !            IF (ln_seaicebal ) THEN        
     952!            IF (ln_seaicebal ) THEN 
    945953!             !! balancing salinity increments 
    946954!             !! simple case from limflx.F90 (doesn't include a mass flux) 
    … …  
    954962! 
    955963!             DO jj = 1, jpj 
    956 !               DO ji = 1, jpi  
     964!               DO ji = 1, jpi 
    957965!           ! calculate change in ice and snow mass per unit area 
    958966!           ! positive values imply adding salt to the ocean (results from ice formation) 
    … …  
    965973! 
    966974!           ! prevent small mld 
    967 !           ! less than 10m can cause salinity instability  
     975!           ! less than 10m can cause salinity instability 
    968976!                 IF (mld < 10) mld=10 
    969977! 
    970 !           ! set to bottom of a level  
     978!           ! set to bottom of a level 
    971979!                 DO jk = jpk-1, 2, -1 
    972 !                   IF ((mld > gdepw(ji,jj,jk)) .and. (mld < gdepw(ji,jj,jk+1))) THEN  
    973 !                     mld=gdepw(ji,jj,jk+1) 
     980!                   IF ((mld > gdepw(ji,jj,jk,Kmm)) .and. (mld < gdepw(ji,jj,jk+1,Kmm))) THEN 
     981!                     mld=gdepw(ji,jj,jk+1,Kmm) 
    974982!                     jkmax=jk 
    975983!                   ENDIF 
    … …  
    977985! 
    978986!            ! avoid applying salinity balancing in shallow water or on land 
    979 !            !  
     987!            ! 
    980988! 
    981989!            ! dsal_ocn (psu kg m^-2) / (kg m^-3 * m) 
    … …  
    988996! 
    989997!           ! put increments in for levels in the mixed layer 
    990 !           ! but prevent salinity below a threshold value  
    991 ! 
    992 !                   DO jk = 1, jkmax               
    993 ! 
    994 !                     IF (dsal_ocn > 0.0_wp .or. sb(ji,jj,jk)+dsal_ocn > sal_thresh) THEN  
     998!           ! but prevent salinity below a threshold value 
     999! 
     1000!                   DO jk = 1, jkmax 
     1001! 
     1002!                     IF (dsal_ocn > 0.0_wp .or. sb(ji,jj,jk)+dsal_ocn > sal_thresh) THEN 
    9951003!                           sb(ji,jj,jk) = sb(ji,jj,jk) + dsal_ocn 
    9961004!                           sn(ji,jj,jk) = sn(ji,jj,jk) + dsal_ocn 
    … …  
    10031011!      ! 
    10041012!      !! Adjust fsalt. A +ve fsalt means adding salt to ocean 
    1005 !      !!           fsalt(ji,jj) =  fsalt(ji,jj) + zpmess     ! adjust fsalt   
    1006 !      !!                
    1007 !      !!           emps(ji,jj) = emps(ji,jj) + zpmess        ! or adjust emps (see icestp1d)  
     1013!      !!           fsalt(ji,jj) =  fsalt(ji,jj) + zpmess     ! adjust fsalt 
     1014!      !! 
     1015!      !!           emps(ji,jj) = emps(ji,jj) + zpmess        ! or adjust emps (see icestp1d) 
    10081016!      !!                                                     ! E-P (kg m-2 s-2) 
    10091017!      !            emp(ji,jj) = emp(ji,jj) + zpmess          ! E-P (kg m-2 s-2) 
    … …  
    10181026      ! 
    10191027   END SUBROUTINE seaice_asm_inc 
    1020     
     1028 
    10211029   !!====================================================================== 
    10221030END MODULE asminc 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/BDY/bdydta.F90

    r12396 r13151  
    7070   !! * Substitutions 
    7171#  include "do_loop_substitute.h90" 
     72#  include "domzgr_substitute.h90" 
    7273   !!---------------------------------------------------------------------- 
    7374   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    9293      INTEGER ::  ii, ij, ik, igrd, ipl               ! local integers 
    9394      INTEGER,   DIMENSION(jpbgrd)     ::   ilen1  
    94       INTEGER,   DIMENSION(:), POINTER ::   nblen, nblenrim  ! short cuts 
    9595      TYPE(OBC_DATA)         , POINTER ::   dta_alias        ! short cut 
    9696      TYPE(FLD), DIMENSION(:), POINTER ::   bf_alias 
    … …  
    108108         DO jbdy = 1, nb_bdy 
    109109            ! 
    110             nblen    => idx_bdy(jbdy)%nblen 
    111             nblenrim => idx_bdy(jbdy)%nblenrim 
    112             ! 
    113110            IF( nn_dyn2d_dta(jbdy) == 0 ) THEN  
    114                ilen1(:) = nblen(:) 
    115111               IF( dta_bdy(jbdy)%lneed_ssh ) THEN  
    116112                  igrd = 1 
    117                   DO ib = 1, ilen1(igrd) 
     113                  DO ib = 1, idx_bdy(jbdy)%nblenrim(igrd)   ! ssh is allocated and used only on the rim 
    118114                     ii = idx_bdy(jbdy)%nbi(ib,igrd) 
    119115                     ij = idx_bdy(jbdy)%nbj(ib,igrd) 
    … …  
    121117                  END DO 
    122118               ENDIF 
    123                IF( dta_bdy(jbdy)%lneed_dyn2d) THEN  
     119               IF( dta_bdy(jbdy)%lneed_dyn2d .AND. ASSOCIATED(dta_bdy(jbdy)%u2d) ) THEN   ! no SIZE with a unassociated pointer 
    124120                  igrd = 2 
    125                   DO ib = 1, ilen1(igrd) 
     121                  DO ib = 1, SIZE(dta_bdy(jbdy)%u2d)   ! u2d is used only on the rim except if ln_full_vel = T, see bdy_dta_init 
    126122                     ii = idx_bdy(jbdy)%nbi(ib,igrd) 
    127123                     ij = idx_bdy(jbdy)%nbj(ib,igrd) 
    … …  
    129125                  END DO 
    130126                  igrd = 3 
    131                   DO ib = 1, ilen1(igrd) 
     127                  DO ib = 1, SIZE(dta_bdy(jbdy)%v2d)   ! v2d is used only on the rim except if ln_full_vel = T, see bdy_dta_init 
    132128                     ii = idx_bdy(jbdy)%nbi(ib,igrd) 
    133129                     ij = idx_bdy(jbdy)%nbj(ib,igrd) 
    … …  
    138134            ! 
    139135            IF( nn_dyn3d_dta(jbdy) == 0 ) THEN  
    140                ilen1(:) = nblen(:) 
    141136               IF( dta_bdy(jbdy)%lneed_dyn3d ) THEN  
    142137                  igrd = 2  
    143                   DO ib = 1, ilen1(igrd) 
     138                  DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 
    144139                     DO ik = 1, jpkm1 
    145140                        ii = idx_bdy(jbdy)%nbi(ib,igrd) 
    … …  
    149144                  END DO 
    150145                  igrd = 3  
    151                   DO ib = 1, ilen1(igrd) 
     146                  DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 
    152147                     DO ik = 1, jpkm1 
    153148                        ii = idx_bdy(jbdy)%nbi(ib,igrd) 
    … …  
    160155 
    161156            IF( nn_tra_dta(jbdy) == 0 ) THEN  
    162                ilen1(:) = nblen(:) 
    163157               IF( dta_bdy(jbdy)%lneed_tra ) THEN 
    164158                  igrd = 1  
    165                   DO ib = 1, ilen1(igrd) 
     159                  DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 
    166160                     DO ik = 1, jpkm1 
    167161                        ii = idx_bdy(jbdy)%nbi(ib,igrd) 
    … …  
    176170#if defined key_si3 
    177171            IF( nn_ice_dta(jbdy) == 0 ) THEN    ! set ice to initial values 
    178                ilen1(:) = nblen(:) 
    179172               IF( dta_bdy(jbdy)%lneed_ice ) THEN 
    180173                  igrd = 1    
    181174                  DO jl = 1, jpl 
    182                      DO ib = 1, ilen1(igrd) 
     175                     DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 
    183176                        ii = idx_bdy(jbdy)%nbi(ib,igrd) 
    184177                        ij = idx_bdy(jbdy)%nbj(ib,igrd) 
    … …  
    236229         ! tidal harmonic forcing ONLY: initialise arrays 
    237230         IF( nn_dyn2d_dta(jbdy) == 2 ) THEN   ! we did not read ssh, u/v2d  
    238             IF( dta_alias%lneed_ssh   ) dta_alias%ssh(:) = 0._wp 
    239             IF( dta_alias%lneed_dyn2d ) dta_alias%u2d(:) = 0._wp 
    240             IF( dta_alias%lneed_dyn2d ) dta_alias%v2d(:) = 0._wp 
     231            IF( dta_alias%lneed_ssh   .AND. ASSOCIATED(dta_alias%ssh) ) dta_alias%ssh(:) = 0._wp 
     232            IF( dta_alias%lneed_dyn2d .AND. ASSOCIATED(dta_alias%u2d) ) dta_alias%u2d(:) = 0._wp 
     233            IF( dta_alias%lneed_dyn2d .AND. ASSOCIATED(dta_alias%v2d) ) dta_alias%v2d(:) = 0._wp 
    241234         ENDIF 
    242235 
    … …  
    245238            ! 
    246239            igrd = 2                       ! zonal velocity 
    247             dta_alias%u2d(:) = 0._wp       ! compute barotrope zonal velocity and put it in u2d 
    248240            DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 
    249241               ii   = idx_bdy(jbdy)%nbi(ib,igrd) 
    250242               ij   = idx_bdy(jbdy)%nbj(ib,igrd) 
     243               dta_alias%u2d(ib) = 0._wp   ! compute barotrope zonal velocity and put it in u2d 
    251244               DO ik = 1, jpkm1 
    252                   dta_alias%u2d(ib) = dta_alias%u2d(ib) + e3u(ii,ij,ik,Kmm) * umask(ii,ij,ik) * dta_alias%u3d(ib,ik) 
     245                  dta_alias%u2d(ib) = dta_alias%u2d(ib)   & 
     246                     &              + e3u(ii,ij,ik,Kmm) * umask(ii,ij,ik) * dta_alias%u3d(ib,ik) 
    253247               END DO 
    254248               dta_alias%u2d(ib) =  dta_alias%u2d(ib) * r1_hu(ii,ij,Kmm) 
    … …  
    258252            END DO 
    259253            igrd = 3                       ! meridional velocity 
    260             dta_alias%v2d(:) = 0._wp       ! compute barotrope meridional velocity and put it in v2d 
    261254            DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 
    262255               ii   = idx_bdy(jbdy)%nbi(ib,igrd) 
    263256               ij   = idx_bdy(jbdy)%nbj(ib,igrd) 
     257               dta_alias%v2d(ib) = 0._wp   ! compute barotrope meridional velocity and put it in v2d 
    264258               DO ik = 1, jpkm1 
    265                   dta_alias%v2d(ib) = dta_alias%v2d(ib) + e3v(ii,ij,ik,Kmm) * vmask(ii,ij,ik) * dta_alias%v3d(ib,ik) 
     259                  dta_alias%v2d(ib) = dta_alias%v2d(ib)   & 
     260                     &              + e3v(ii,ij,ik,Kmm) * vmask(ii,ij,ik) * dta_alias%v3d(ib,ik) 
    266261               END DO 
    267262               dta_alias%v2d(ib) =  dta_alias%v2d(ib) * r1_hv(ii,ij,Kmm) 
    … …  
    283278 
    284279#if defined key_si3 
    285          IF( dta_alias%lneed_ice ) THEN 
     280         IF( dta_alias%lneed_ice .AND. idx_bdy(jbdy)%nblen(1) > 0 ) THEN 
    286281            ! fill temperature and salinity arrays 
    287282            IF( TRIM(bf_alias(jp_bdyt_i)%clrootname) == 'NOT USED' )   bf_alias(jp_bdyt_i)%fnow(:,1,:) = rice_tem (jbdy) 
    … …  
    338333            DO jbdy = 1, nb_bdy      ! Tidal component added in ts loop 
    339334               IF ( nn_dyn2d_dta(jbdy) .GE. 2 ) THEN 
    340                   nblen => idx_bdy(jbdy)%nblen 
    341                   nblenrim => idx_bdy(jbdy)%nblenrim 
    342                   IF( cn_dyn2d(jbdy) == 'frs' ) THEN   ;   ilen1(:)=nblen(:) 
    343                   ELSE                                 ;   ilen1(:)=nblenrim(:) 
     335                  IF( cn_dyn2d(jbdy) == 'frs' ) THEN   ;   ilen1(:)=idx_bdy(jbdy)%nblen(:) 
     336                  ELSE                                 ;   ilen1(:)=idx_bdy(jbdy)%nblenrim(:) 
    344337                  ENDIF 
    345338                  IF ( dta_bdy(jbdy)%lneed_ssh   ) dta_bdy_s(jbdy)%ssh(1:ilen1(1)) = dta_bdy(jbdy)%ssh(1:ilen1(1)) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/BDY/bdydyn.F90

    r12377 r13151  
    2929 
    3030   PUBLIC   bdy_dyn    ! routine called in dyn_nxt 
    31  
     31    
     32   !! * Substitutions 
     33#  include "domzgr_substitute.h90" 
    3234   !!---------------------------------------------------------------------- 
    3335   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/C1D/step_c1d.F90

    r12377 r13151  
    8383      IF(.NOT.ln_linssh )   CALL dom_vvl_sf_nxt( kstp, Nbb, Nnn,      Naa )  ! after vertical scale factors  
    8484 
    85       IF(.NOT.ln_linssh )   CALL wzv           ( kstp, Nbb, Nnn, ww,  Naa )  ! now cross-level velocity  
     85      IF(.NOT.ln_linssh )   CALL wzv           ( kstp, Nbb, Nnn, Naa, ww )  ! now cross-level velocity  
    8686      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    8787      ! diagnostics and outputs        

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/CRS/crsfld.F90

    r12377 r13151  
    3333   !! * Substitutions 
    3434#  include "do_loop_substitute.h90" 
     35#  include "domzgr_substitute.h90" 
    3536   !!---------------------------------------------------------------------- 
    3637   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    6869 
    6970      ! Depth work arrrays 
    70       ze3t(:,:,:) = e3t(:,:,:,Kmm) 
    71       ze3u(:,:,:) = e3u(:,:,:,Kmm) 
    72       ze3v(:,:,:) = e3v(:,:,:,Kmm) 
    73       ze3w(:,:,:) = e3w(:,:,:,Kmm) 
     71      DO jk = 1 , jpk  
     72         ze3t(:,:,jk) = e3t(:,:,jk,Kmm) 
     73         ze3u(:,:,jk) = e3u(:,:,jk,Kmm) 
     74         ze3v(:,:,jk) = e3v(:,:,jk,Kmm) 
     75         ze3w(:,:,jk) = e3w(:,:,jk,Kmm) 
     76      END DO 
    7477 
    7578      IF( kt == nit000  ) THEN 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/CRS/crsini.F90

    r12377 r13151  
    2828   PUBLIC   crs_init   ! called by nemogcm.F90 module 
    2929 
     30   !! * Substitutions 
     31#  include "domzgr_substitute.h90" 
    3032   !!---------------------------------------------------------------------- 
    3133   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    174176      
    175177     ! 
    176      ze3t(:,:,:) = e3t(:,:,:,Kmm) 
    177      ze3u(:,:,:) = e3u(:,:,:,Kmm) 
    178      ze3v(:,:,:) = e3v(:,:,:,Kmm) 
    179      ze3w(:,:,:) = e3w(:,:,:,Kmm) 
     178     DO jk = 1, jpk 
     179        ze3t(:,:,jk) = e3t(:,:,jk,Kmm) 
     180        ze3u(:,:,jk) = e3u(:,:,jk,Kmm) 
     181        ze3v(:,:,jk) = e3v(:,:,jk,Kmm) 
     182        ze3w(:,:,jk) = e3w(:,:,jk,Kmm) 
     183     END DO   
    180184 
    181185     !    3.d.2   Surfaces  

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DIA/diaar5.F90

    r12489 r13151  
    3232   REAL(wp)                         ::   vol0         ! ocean volume (interior domain) 
    3333   REAL(wp)                         ::   area_tot     ! total ocean surface (interior domain) 
    34    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:  ) ::   area         ! cell surface (interior domain) 
    3534   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:  ) ::   thick0       ! ocean thickness (interior domain) 
    3635   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   sn0          ! initial salinity 
    … …  
    4039   !! * Substitutions 
    4140#  include "do_loop_substitute.h90" 
     41#  include "domzgr_substitute.h90" 
    4242   !!---------------------------------------------------------------------- 
    4343   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    5454      !!---------------------------------------------------------------------- 
    5555      ! 
    56       ALLOCATE( area(jpi,jpj), thick0(jpi,jpj) , sn0(jpi,jpj,jpk) , STAT=dia_ar5_alloc ) 
     56      ALLOCATE( thick0(jpi,jpj) , sn0(jpi,jpj,jpk) , STAT=dia_ar5_alloc ) 
    5757      ! 
    5858      CALL mpp_sum ( 'diaar5', dia_ar5_alloc ) 
    … …  
    7777      ! 
    7878      REAL(wp), ALLOCATABLE, DIMENSION(:,:)     :: zarea_ssh , zbotpres       ! 2D workspace  
    79       REAL(wp), ALLOCATABLE, DIMENSION(:,:)     :: zpe, z2d                   ! 2D workspace  
    80       REAL(wp), ALLOCATABLE, DIMENSION(:,:,:)   :: zrhd , zrhop, ztpot   ! 3D workspace 
     79      REAL(wp), ALLOCATABLE, DIMENSION(:,:)     :: z2d, zpe                   ! 2D workspace  
     80      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:)   :: z3d, zrhd , zrhop, ztpot, zgdept   ! 3D workspace (zgdept: needed to use the substitute) 
    8181      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: ztsn                       ! 4D workspace 
    8282 
    … …  
    9090         ALLOCATE( zrhd(jpi,jpj,jpk) , zrhop(jpi,jpj,jpk) ) 
    9191         ALLOCATE( ztsn(jpi,jpj,jpk,jpts) ) 
    92          zarea_ssh(:,:) = area(:,:) * ssh(:,:,Kmm) 
    93       ENDIF 
    94       ! 
    95       CALL iom_put( 'e2u'      , e2u (:,:) ) 
    96       CALL iom_put( 'e1v'      , e1v (:,:) ) 
    97       CALL iom_put( 'areacello', area(:,:) ) 
     92         zarea_ssh(:,:) = e1e2t(:,:) * ssh(:,:,Kmm) 
     93      ENDIF 
     94      ! 
     95      CALL iom_put( 'e2u'      , e2u  (:,:) ) 
     96      CALL iom_put( 'e1v'      , e1v  (:,:) ) 
     97      CALL iom_put( 'areacello', e1e2t(:,:) ) 
    9898      ! 
    9999      IF( iom_use( 'volcello' ) .OR. iom_use( 'masscello' )  ) THEN   
    100100         zrhd(:,:,jpk) = 0._wp        ! ocean volume ; rhd is used as workspace 
    101101         DO jk = 1, jpkm1 
    102             zrhd(:,:,jk) = area(:,:) * e3t(:,:,jk,Kmm) * tmask(:,:,jk) 
     102            zrhd(:,:,jk) = e1e2t(:,:) * e3t(:,:,jk,Kmm) * tmask(:,:,jk) 
    103103         END DO 
     104         DO jk = 1, jpk 
     105            z3d(:,:,jk) =  rho0 * e3t(:,:,jk,Kmm) * tmask(:,:,jk) 
     106         END DO  
    104107         CALL iom_put( 'volcello'  , zrhd(:,:,:)  )  ! WARNING not consistent with CMIP DR where volcello is at ca. 2000 
    105          CALL iom_put( 'masscello' , rho0 * e3t(:,:,:,Kmm) * tmask(:,:,:) )  ! ocean mass 
     108         CALL iom_put( 'masscello' , z3d (:,:,:) )   ! ocean mass 
    106109      ENDIF  
    107110      ! 
    … …  
    129132         ztsn(:,:,:,jp_tem) = ts(:,:,:,jp_tem,Kmm)                    ! thermosteric ssh 
    130133         ztsn(:,:,:,jp_sal) = sn0(:,:,:) 
    131          CALL eos( ztsn, zrhd, gdept(:,:,:,Kmm) )                       ! now in situ density using initial salinity 
     134         DO jk = 1, jpk 
     135            zgdept(:,:,jk) = gdept(:,:,jk,Kmm) 
     136         END DO 
     137         CALL eos( ztsn, zrhd, zgdept)                       ! now in situ density using initial salinity 
    132138         ! 
    133139         zbotpres(:,:) = 0._wp                        ! no atmospheric surface pressure, levitating sea-ice 
    … …  
    151157         END IF 
    152158         !                                          
    153          zarho = glob_sum( 'diaar5', area(:,:) * zbotpres(:,:) )  
     159         zarho = glob_sum( 'diaar5', e1e2t(:,:) * zbotpres(:,:) )  
    154160         zssh_steric = - zarho / area_tot 
    155161         CALL iom_put( 'sshthster', zssh_steric ) 
    156162       
    157163         !                                         ! steric sea surface height 
    158          CALL eos( ts(:,:,:,:,Kmm), zrhd, zrhop, gdept(:,:,:,Kmm) )                 ! now in situ and potential density 
     164         CALL eos( ts(:,:,:,:,Kmm), zrhd, zrhop, zgdept )                 ! now in situ and potential density 
    159165         zrhop(:,:,jpk) = 0._wp 
    160166         CALL iom_put( 'rhop', zrhop ) 
    … …  
    177183         END IF 
    178184         !     
    179          zarho = glob_sum( 'diaar5', area(:,:) * zbotpres(:,:) )  
     185         zarho = glob_sum( 'diaar5', e1e2t(:,:) * zbotpres(:,:) )  
    180186         zssh_steric = - zarho / area_tot 
    181187         CALL iom_put( 'sshsteric', zssh_steric ) 
    … …  
    191197          ztsn(:,:,:,:) = 0._wp                    ! ztsn(:,:,1,jp_tem/sal) is used here as 2D Workspace for temperature & salinity 
    192198          DO_3D_11_11( 1, jpkm1 ) 
    193              zztmp = area(ji,jj) * e3t(ji,jj,jk,Kmm) 
     199             zztmp = e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) 
    194200             ztsn(ji,jj,1,jp_tem) = ztsn(ji,jj,1,jp_tem) + zztmp * ts(ji,jj,jk,jp_tem,Kmm) 
    195201             ztsn(ji,jj,1,jp_sal) = ztsn(ji,jj,1,jp_sal) + zztmp * ts(ji,jj,jk,jp_sal,Kmm) 
    … …  
    237243               z2d(:,:) = 0._wp 
    238244               DO jk = 1, jpkm1 
    239                  z2d(:,:) = z2d(:,:) + area(:,:) * e3t(:,:,jk,Kmm) * ztpot(:,:,jk) 
     245                 z2d(:,:) = z2d(:,:) + e1e2t(:,:) * e3t(:,:,jk,Kmm) * ztpot(:,:,jk) 
    240246               END DO 
    241247               ztemp = glob_sum( 'diaar5', z2d(:,:)  )  
    … …  
    244250             ! 
    245251             IF( iom_use( 'ssttot' ) ) THEN   ! Output potential temperature in case we use TEOS-10 
    246                zsst = glob_sum( 'diaar5',  area(:,:) * ztpot(:,:,1)  )  
     252               zsst = glob_sum( 'diaar5',  e1e2t(:,:) * ztpot(:,:,1)  )  
    247253               CALL iom_put( 'ssttot', zsst / area_tot ) 
    248254             ENDIF 
    … …  
    259265      ELSE        
    260266         IF( iom_use('ssttot') ) THEN   ! Output sst in case we use EOS-80 
    261             zsst  = glob_sum( 'diaar5', area(:,:) * ts(:,:,1,jp_tem,Kmm) ) 
     267            zsst  = glob_sum( 'diaar5', e1e2t(:,:) * ts(:,:,1,jp_tem,Kmm) ) 
    262268            CALL iom_put('ssttot', zsst / area_tot ) 
    263269         ENDIF 
    … …  
    375381         IF( dia_ar5_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'dia_ar5_init : unable to allocate arrays' ) 
    376382 
    377          area(:,:) = e1e2t(:,:) 
    378          area_tot  = glob_sum( 'diaar5', area(:,:) ) 
     383         area_tot  = glob_sum( 'diaar5', e1e2t(:,:) ) 
    379384 
    380385         ALLOCATE( zvol0(jpi,jpj) ) 
    … …  
    383388         DO_3D_11_11( 1, jpkm1 ) 
    384389            idep = tmask(ji,jj,jk) * e3t_0(ji,jj,jk) 
    385             zvol0 (ji,jj) = zvol0 (ji,jj) +  idep * area(ji,jj) 
     390            zvol0 (ji,jj) = zvol0 (ji,jj) +  idep * e1e2t(ji,jj) 
    386391            thick0(ji,jj) = thick0(ji,jj) +  idep     
    387392         END_3D 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DIA/diacfl.F90

    r12489 r13151  
    3434   !! * Substitutions 
    3535#  include "do_loop_substitute.h90" 
     36#  include "domzgr_substitute.h90" 
    3637   !!---------------------------------------------------------------------- 
    3738   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DIA/diadct.F90

    r12489 r13151  
    1111   !!            3.4  ! 09/2011 (C Bricaud) 
    1212   !!---------------------------------------------------------------------- 
    13    !! does not work with agrif 
    14 #if ! defined key_agrif 
     13#if ! defined key_agrif        
     14   !!                        ==>>  CAUTION: does not work with agrif 
    1515   !!---------------------------------------------------------------------- 
    1616   !!   dia_dct      :  Compute the transport through a sec. 
    … …  
    6666   TYPE SECTION 
    6767      CHARACTER(len=60)                            :: name              ! name of the sec 
    68       LOGICAL                                      :: llstrpond         ! true if you want the computation of salt and 
    69                                                                        ! heat transports 
     68      LOGICAL                                      :: llstrpond         ! true if you want the computation of salt and heat transports 
    7069      LOGICAL                                      :: ll_ice_section    ! ice surface and ice volume computation 
    7170      LOGICAL                                      :: ll_date_line      ! = T if the section crosses the date-line 
    … …  
    7473      INTEGER, DIMENSION(nb_point_max)             :: direction         ! vector direction of the point in the section 
    7574      CHARACTER(len=40),DIMENSION(nb_class_max)    :: classname         ! characteristics of the class 
    76       REAL(wp), DIMENSION(nb_class_max)            :: zsigi           ,&! in-situ   density classes    (99 if you don't want) 
    77                                                       zsigp           ,&! potential density classes    (99 if you don't want) 
    78                                                       zsal            ,&! salinity classes   (99 if you don't want) 
    79                                                       ztem            ,&! temperature classes(99 if you don't want) 
    80                                                       zlay              ! level classes      (99 if you don't want) 
     75      REAL(wp), DIMENSION(nb_class_max)            :: zsigi             ! in-situ   density classes    (99 if you don't want) 
     76      REAL(wp), DIMENSION(nb_class_max)            :: zsigp             ! potential density classes    (99 if you don't want) 
     77      REAL(wp), DIMENSION(nb_class_max)            :: zsal              ! salinity classes   (99 if you don't want) 
     78      REAL(wp), DIMENSION(nb_class_max)            :: ztem              ! temperature classes(99 if you don't want) 
     79      REAL(wp), DIMENSION(nb_class_max)            :: zlay              ! level classes      (99 if you don't want) 
    8180      REAL(wp), DIMENSION(nb_type_class,nb_class_max)  :: transport     ! transport output 
    8281      REAL(wp)                                         :: slopeSection  ! slope of the section 
    … …  
    9089   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:)   ::  transports_2d   
    9190 
     91 
     92   !! * Substitutions 
     93#  include "domzgr_substitute.h90" 
    9294   !!---------------------------------------------------------------------- 
    9395   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    9597   !! Software governed by the CeCILL license (see ./LICENSE) 
    9698   !!---------------------------------------------------------------------- 
     99 
    97100CONTAINS 
    98101  
    … …  
    11191122  !!    |               |                  |       interpolation between ptab(I,J,K) and ptab(I,J,K+1) 
    11201123  !!    |               |                  |       zbis =  
    1121   !!    |               |                  |      [ e3w(I+1,J,K)*ptab(I,J,K) + ( e3w(I,J,K) - e3w(I+1,J,K) ) * ptab(I,J,K-1) ] 
    1122   !!    |               |                  |      /[ e3w(I+1,J,K) + e3w(I,J,K) - e3w(I+1,J,K) ]  
     1124  !!    |               |                  |      [ e3w_n(I+1,J,K,NOW)*ptab(I,J,K) + ( e3w_n(I,J,K,NOW) - e3w_n(I+1,J,K,NOW) ) * ptab(I,J,K-1) ] 
     1125  !!    |               |                  |     /[ e3w_n(I+1,J,K,NOW)             +   e3w_n(I,J,K,NOW) - e3w_n(I+1,J,K,NOW) ]  
    11231126  !!    |               |                  |  
    11241127  !!    |               |                  |    2. Horizontal interpolation: compute value at U/V point 
    … …  
    12121215  ELSE       ! full step or partial step case  
    12131216 
    1214      ze3t  = e3t(ii2,ij2,kk,Kmm) - e3t(ii1,ij1,kk,Kmm)  
    1215      zwgt1 = ( e3w(ii2,ij2,kk,Kmm) - e3w(ii1,ij1,kk,Kmm) ) / e3w(ii2,ij2,kk,Kmm) 
    1216      zwgt2 = ( e3w(ii1,ij1,kk,Kmm) - e3w(ii2,ij2,kk,Kmm) ) / e3w(ii1,ij1,kk,Kmm) 
     1217     ze3t  =   e3t(ii2,ij2,kk,Kmm) - e3t(ii1,ij1,kk,Kmm)  
     1218     zwgt1 = ( e3w(ii2,ij2,kk,Kmm) - e3w(ii1,ij1,kk,Kmm) )   & 
     1219        &    / e3w(ii2,ij2,kk,Kmm) 
     1220     zwgt2 = ( e3w(ii1,ij1,kk,Kmm) - e3w(ii2,ij2,kk,Kmm) )   & 
     1221        &    / e3w(ii1,ij1,kk,Kmm) 
    12171222 
    12181223     IF(kk .NE. 1)THEN 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DIA/diahsb.F90

    r12489 r13151  
    5050   REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   tmask_ini 
    5151 
     52   !! * Substitutions 
     53#  include "domzgr_substitute.h90" 
    5254   !!---------------------------------------------------------------------- 
    5355   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    156158      ! 
    157159      DO jk = 1, jpkm1           ! volume variation (calculated with scale factors) 
    158          zwrk(:,:,jk) = surf(:,:)*e3t(:,:,jk,Kmm)*tmask(:,:,jk) - surf_ini(:,:)*e3t_ini(:,:,jk)*tmask_ini(:,:,jk) 
     160         zwrk(:,:,jk) =   surf    (:,:) * e3t    (:,:,jk,Kmm)*tmask    (:,:,jk)   & 
     161            &           - surf_ini(:,:) * e3t_ini(:,:,jk    )*tmask_ini(:,:,jk) 
    159162      END DO 
    160163      zdiff_v2 = glob_sum_full( 'diahsb', zwrk(:,:,:) )     ! glob_sum_full needed as tmask and tmask_ini could be different 
    161164      DO jk = 1, jpkm1           ! heat content variation 
    162          zwrk(:,:,jk) = ( surf(:,:)*e3t(:,:,jk,Kmm)*ts(:,:,jk,jp_tem,Kmm) - surf_ini(:,:)*hc_loc_ini(:,:,jk) ) 
     165         zwrk(:,:,jk) = ( surf    (:,:) * e3t(:,:,jk,Kmm)*ts(:,:,jk,jp_tem,Kmm)   & 
     166            &           - surf_ini(:,:) *         hc_loc_ini(:,:,jk) ) 
    163167      END DO 
    164168      zdiff_hc = glob_sum_full( 'diahsb', zwrk(:,:,:) ) 
    165169      DO jk = 1, jpkm1           ! salt content variation 
    166          zwrk(:,:,jk) = ( surf(:,:)*e3t(:,:,jk,Kmm)*ts(:,:,jk,jp_sal,Kmm) - surf_ini(:,:)*sc_loc_ini(:,:,jk) ) 
     170         zwrk(:,:,jk) = ( surf    (:,:) * e3t(:,:,jk,Kmm)*ts(:,:,jk,jp_sal,Kmm)   & 
     171            &           - surf_ini(:,:) *         sc_loc_ini(:,:,jk) ) 
    167172      END DO 
    168173      zdiff_sc = glob_sum_full( 'diahsb', zwrk(:,:,:) ) 
    … …  
    287292            DO jk = 1, jpk 
    288293              ! if ice sheet/oceqn coupling, need to mask ini variables here (mask could change at the next NEMO instance). 
    289                e3t_ini   (:,:,jk) = e3t(:,:,jk,Kmm)                      * tmask(:,:,jk)  ! initial vertical scale factors 
     294               e3t_ini   (:,:,jk) =                       e3t(:,:,jk,Kmm)*tmask(:,:,jk)  ! initial vertical scale factors 
    290295               tmask_ini (:,:,jk) = tmask(:,:,jk)                                       ! initial mask 
    291                hc_loc_ini(:,:,jk) = ts(:,:,jk,jp_tem,Kmm) * e3t(:,:,jk,Kmm) * tmask(:,:,jk)  ! initial heat content 
    292                sc_loc_ini(:,:,jk) = ts(:,:,jk,jp_sal,Kmm) * e3t(:,:,jk,Kmm) * tmask(:,:,jk)  ! initial salt content 
     296               hc_loc_ini(:,:,jk) = ts(:,:,jk,jp_tem,Kmm)*e3t(:,:,jk,Kmm)*tmask(:,:,jk)  ! initial heat content 
     297               sc_loc_ini(:,:,jk) = ts(:,:,jk,jp_sal,Kmm)*e3t(:,:,jk,Kmm)*tmask(:,:,jk)  ! initial salt content 
    293298            END DO 
    294299            frc_v = 0._wp                                           ! volume       trend due to forcing 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DIA/diahth.F90

    r12489 r13151  
    4242   !! * Substitutions 
    4343#  include "do_loop_substitute.h90" 
     44#  include "domzgr_substitute.h90" 
    4445   !!---------------------------------------------------------------------- 
    4546   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    361362         ik = ilevel(ji,jj) 
    362363         zthick(ji,jj) = pdep - zthick(ji,jj)   !   remaining thickness to reach depht pdep 
    363          phtc(ji,jj)   = phtc(ji,jj) + pt(ji,jj,ik+1) * MIN( e3t(ji,jj,ik+1,Kmm), zthick(ji,jj) ) & 
     364         phtc(ji,jj)   = phtc(ji,jj)    & 
     365            &           + pt (ji,jj,ik+1) * MIN( e3t(ji,jj,ik+1,Kmm), zthick(ji,jj) ) & 
    364366                                                       * tmask(ji,jj,ik+1) 
    365367      END_2D 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DIA/diamlr.F90

    r12377 r13151  
    44   !! Management of the IOM context for multiple-linear-regression analysis 
    55   !!====================================================================== 
    6    !! History :       !  2019  (S. Mueller) 
     6   !! History :  4.0  !  2019  (S. Mueller)   Original code 
    77   !!---------------------------------------------------------------------- 
    88 
    99   USE par_oce        , ONLY :   wp, jpi, jpj 
    1010   USE phycst         , ONLY :   rpi 
     11   USE dom_oce        , ONLY :   adatrj 
     12   USE tide_mod 
     13   ! 
    1114   USE in_out_manager , ONLY :   lwp, numout, ln_timing 
    1215   USE iom            , ONLY :   iom_put, iom_use, iom_update_file_name 
    13    USE dom_oce        , ONLY :   adatrj 
    1416   USE timing         , ONLY :   timing_start, timing_stop 
    1517#if defined key_iomput 
    1618   USE xios 
    1719#endif 
    18    USE tide_mod 
    1920 
    2021   IMPLICIT NONE 
    2122   PRIVATE 
    2223 
    23    LOGICAL, PUBLIC ::   lk_diamlr = .FALSE. 
     24   LOGICAL, PUBLIC ::   lk_diamlr = .FALSE.   !:         ===>>>   NOT a DOCTOR norm name :  use l_diamlr 
     25   !                                                              lk_  is used only for logical controlled by a CPP key 
    2426 
    2527   PUBLIC ::   dia_mlr_init, dia_mlr_iom_init, dia_mlr 
    … …  
    3335   !!---------------------------------------------------------------------- 
    3436CONTAINS 
    35     
     37 
    3638   SUBROUTINE dia_mlr_init 
    3739      !!---------------------------------------------------------------------- 
    3840      !!                 ***  ROUTINE dia_mlr_init  *** 
    3941      !! 
    40       !! ** Purpose : initialisation of IOM context management for  
     42      !! ** Purpose : initialisation of IOM context management for 
    4143      !!              multiple-linear-regression analysis 
    4244      !! 
    4345      !!---------------------------------------------------------------------- 
    44  
     46      ! 
    4547      lk_diamlr = .TRUE. 
    46  
     48      ! 
    4749      IF(lwp) THEN 
    4850         WRITE(numout, *) 
    … …  
    5052         WRITE(numout, *) '~~~~~~~~~~~~   multiple-linear-regression analysis' 
    5153      END IF 
    52  
     54      ! 
    5355   END SUBROUTINE dia_mlr_init 
     56 
    5457 
    5558   SUBROUTINE dia_mlr_iom_init 
    … …  
    8487      INTEGER                                     ::   itide                       ! Number of available tidal components 
    8588      REAL(wp)                                    ::   ztide_phase                 ! Tidal-constituent phase at adatrj=0 
    86       CHARACTER (LEN=4), DIMENSION(jpmax_harmo)   ::   ctide_selected = ' n/a ' 
     89      CHARACTER (LEN=4), DIMENSION(jpmax_harmo)   ::   ctide_selected = 'n/a ' 
    8790      TYPE(tide_harmonic), DIMENSION(:), POINTER  ::   stideconst 
    8891 
    … …  
    145148            ! Retrieve information (frequency, phase, nodal correction) about all 
    146149            ! available tidal constituents for placeholder substitution below 
    147             ctide_selected(1:34) = (/ 'Mf', 'Mm', 'Ssa', 'Mtm', 'Msf',    & 
    148                &                      'Msqm', 'Sa', 'K1', 'O1', 'P1',     & 
    149                &                      'Q1', 'J1', 'S1', 'M2', 'S2', 'N2', & 
    150                &                      'K2', 'nu2', 'mu2', '2N2', 'L2',    & 
    151                &                      'T2', 'eps2', 'lam2', 'R2', 'M3',   & 
    152                &                      'MKS2', 'MN4', 'MS4', 'M4', 'N4',   & 
    153                &                      'S4', 'M6', 'M8' /) 
     150            ! Warning: we must use the same character length in an array constructor (at least for gcc compiler) 
     151            ctide_selected(1:34) = (/ 'Mf  ', 'Mm  ', 'Ssa ', 'Mtm ', 'Msf ',         & 
     152               &                      'Msqm', 'Sa  ', 'K1  ', 'O1  ', 'P1  ',         & 
     153               &                      'Q1  ', 'J1  ', 'S1  ', 'M2  ', 'S2  ', 'N2  ', & 
     154               &                      'K2  ', 'nu2 ', 'mu2 ', '2N2 ', 'L2  ',         & 
     155               &                      'T2  ', 'eps2', 'lam2', 'R2  ', 'M3  ',         & 
     156               &                      'MKS2', 'MN4 ', 'MS4 ', 'M4  ', 'N4  ',         & 
     157               &                      'S4  ', 'M6  ', 'M8  ' /) 
    154158            CALL tide_init_harmonics(ctide_selected, stideconst) 
    155159            itide = size(stideconst) 
    … …  
    157161            itide = 0 
    158162         ENDIF 
    159           
     163 
    160164         DO jm = 1, jpscanmax 
    161165            WRITE (cl3i, '(i3.3)') jm 
    … …  
    236240               ! If enabled, keep handle in list of fields selected for analysis 
    237241               IF ( llxatt_enabled ) THEN 
    238                    
     242 
    239243                  ! Set name attribute (and overwrite possible pre-configured name) 
    240244                  ! with field id to enable id string retrieval from stored handle 
    … …  
    323327            CALL xios_set_attr  ( slxhdl_fld, standard_name=TRIM( clxatt_comment ), long_name=TRIM( clxatt_expr ),   & 
    324328               &                  operation="average" ) 
    325                 
     329 
    326330            ! iii) set up the output of scalar products with itself and with 
    327331            !      other active regressors 
    … …  
    396400   END SUBROUTINE dia_mlr_iom_init 
    397401 
     402 
    398403   SUBROUTINE dia_mlr 
    399404      !!---------------------------------------------------------------------- 
    … …  
    403408      !! 
    404409      !!---------------------------------------------------------------------- 
    405  
    406410      REAL(wp), DIMENSION(jpi,jpj) ::   zadatrj2d 
     411      !!---------------------------------------------------------------------- 
    407412 
    408413      IF( ln_timing )   CALL timing_start('dia_mlr') 
    … …  
    411416      ! (value of adatrj converted to time in units of seconds) 
    412417      ! 
    413       ! A 2-dimensional field of constant value is sent, and subsequently used 
    414       ! directly or transformed to a scalar or a constant 3-dimensional field as 
    415       ! required. 
     418      ! A 2-dimensional field of constant value is sent, and subsequently used directly  
     419      ! or transformed to a scalar or a constant 3-dimensional field as required. 
    416420      zadatrj2d(:,:) = adatrj*86400.0_wp 
    417421      IF ( iom_use('diamlr_time') ) CALL iom_put('diamlr_time', zadatrj2d) 
    418        
     422      ! 
    419423      IF( ln_timing )   CALL timing_stop('dia_mlr') 
    420  
     424      ! 
    421425   END SUBROUTINE dia_mlr 
    422426 
     427   !!====================================================================== 
    423428END MODULE diamlr 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DIA/diaptr.F90

    r12489 r13151  
    6060 
    6161   LOGICAL ::   ll_init = .TRUE.        !: tracers  trend flag (set from namelist in trdini) 
     62    
    6263   !! * Substitutions 
    6364#  include "do_loop_substitute.h90" 
     65#  include "domzgr_substitute.h90" 
    6466   !!---------------------------------------------------------------------- 
    6567   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DIA/diawri.F90

    r12493 r13151  
    8585   !! * Substitutions 
    8686#  include "do_loop_substitute.h90" 
     87#  include "domzgr_substitute.h90" 
    8788   !!---------------------------------------------------------------------- 
    8889   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    136137      CALL iom_put("e3v_0", e3v_0(:,:,:) ) 
    137138      ! 
    138       CALL iom_put( "e3t" , e3t(:,:,:,Kmm) ) 
    139       CALL iom_put( "e3u" , e3u(:,:,:,Kmm) ) 
    140       CALL iom_put( "e3v" , e3v(:,:,:,Kmm) ) 
    141       CALL iom_put( "e3w" , e3w(:,:,:,Kmm) ) 
    142       IF( iom_use("e3tdef") )   & 
    143          CALL iom_put( "e3tdef"  , ( ( e3t(:,:,:,Kmm) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 ) 
    144  
    145       IF( ll_wd ) THEN 
    146          CALL iom_put( "ssh" , (ssh(:,:,Kmm)+ssh_ref)*tmask(:,:,1) )   ! sea surface height (brought back to the reference used for wetting and drying) 
     139      IF ( iom_use("e3t") .OR. iom_use("e3tdef") ) THEN  ! time-varying e3t 
     140         DO jk = 1, jpk 
     141            z3d(:,:,jk) =  e3t(:,:,jk,Kmm) 
     142         END DO 
     143         CALL iom_put( "e3t"     ,     z3d(:,:,:) ) 
     144         CALL iom_put( "e3tdef"  , ( ( z3d(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 )  
     145      ENDIF  
     146      IF ( iom_use("e3u") ) THEN                         ! time-varying e3u 
     147         DO jk = 1, jpk 
     148            z3d(:,:,jk) =  e3u(:,:,jk,Kmm) 
     149         END DO  
     150         CALL iom_put( "e3u" , z3d(:,:,:) ) 
     151      ENDIF 
     152      IF ( iom_use("e3v") ) THEN                         ! time-varying e3v 
     153         DO jk = 1, jpk 
     154            z3d(:,:,jk) =  e3v(:,:,jk,Kmm) 
     155         END DO  
     156         CALL iom_put( "e3v" , z3d(:,:,:) ) 
     157      ENDIF 
     158      IF ( iom_use("e3w") ) THEN                         ! time-varying e3w 
     159         DO jk = 1, jpk 
     160            z3d(:,:,jk) =  e3w(:,:,jk,Kmm) 
     161         END DO  
     162         CALL iom_put( "e3w" , z3d(:,:,:) ) 
     163      ENDIF 
     164 
     165      IF( ll_wd ) THEN                                   ! sea surface height (brought back to the reference used for wetting and drying) 
     166         CALL iom_put( "ssh" , (ssh(:,:,Kmm)+ssh_ref)*tmask(:,:,1) ) 
    147167      ELSE 
    148168         CALL iom_put( "ssh" , ssh(:,:,Kmm) )              ! sea surface height 
    … …  
    208228 
    209229      IF( ln_zad_Aimp ) ww = ww + wi               ! Recombine explicit and implicit parts of vertical velocity for diagnostic output 
    210       ! 
    211230      CALL iom_put( "woce", ww )                   ! vertical velocity 
     231 
    212232      IF( iom_use('w_masstr') .OR. iom_use('w_masstr2') ) THEN   ! vertical mass transport & its square value 
    213233         ! Caution: in the VVL case, it only correponds to the baroclinic mass transport. 
    … …  
    415435      ! 
    416436      REAL(wp), DIMENSION(jpi,jpj)   :: zw2d       ! 2D workspace 
    417       REAL(wp), DIMENSION(jpi,jpj,jpk) :: zw3d       ! 3D workspace 
     437      REAL(wp), DIMENSION(jpi,jpj,jpk) :: zw3d, ze3t, zgdept       ! 3D workspace 
    418438      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zw3d_abl   ! ABL 3D workspace 
    419439      !!---------------------------------------------------------------------- 
    … …  
    455475      it = kt 
    456476      itmod = kt - nit000 + 1 
     477 
     478      ! store e3t for subsitute 
     479      DO jk = 1, jpk 
     480         ze3t  (:,:,jk) =  e3t  (:,:,jk,Kmm) 
     481         zgdept(:,:,jk) =  gdept(:,:,jk,Kmm) 
     482      END DO 
    457483 
    458484 
    … …  
    569595         DEALLOCATE(zw3d_abl) 
    570596         ENDIF 
     597         ! 
    571598 
    572599         ! Declare all the output fields as NETCDF variables 
    … …  
    578605            &          jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout ) 
    579606         IF(  .NOT.ln_linssh  ) THEN 
    580             CALL histdef( nid_T, "vovvle3t", "Level thickness"                    , "m"      ,&  ! e3t(:,:,:,Kmm) 
     607            CALL histdef( nid_T, "vovvle3t", "Level thickness"                    , "m"      ,&  ! e3t n 
    581608            &             jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout ) 
    582             CALL histdef( nid_T, "vovvldep", "T point depth"                      , "m"      ,&  ! e3t(:,:,:,Kmm) 
     609            CALL histdef( nid_T, "vovvldep", "T point depth"                      , "m"      ,&  ! e3t n 
    583610            &             jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout ) 
    584             CALL histdef( nid_T, "vovvldef", "Squared level deformation"          , "%^2"    ,&  ! e3t(:,:,:,Kmm) 
     611            CALL histdef( nid_T, "vovvldef", "Squared level deformation"          , "%^2"    ,&  ! e3t n 
    585612            &             jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout ) 
    586613         ENDIF 
    … …  
    766793 
    767794      IF( .NOT.ln_linssh ) THEN 
    768          CALL histwrite( nid_T, "votemper", it, ts(:,:,:,jp_tem,Kmm) * e3t(:,:,:,Kmm) , ndim_T , ndex_T  )   ! heat content 
    769          CALL histwrite( nid_T, "vosaline", it, ts(:,:,:,jp_sal,Kmm) * e3t(:,:,:,Kmm) , ndim_T , ndex_T  )   ! salt content 
    770          CALL histwrite( nid_T, "sosstsst", it, ts(:,:,1,jp_tem,Kmm) * e3t(:,:,1,Kmm) , ndim_hT, ndex_hT )   ! sea surface heat content 
    771          CALL histwrite( nid_T, "sosaline", it, ts(:,:,1,jp_sal,Kmm) * e3t(:,:,1,Kmm) , ndim_hT, ndex_hT )   ! sea surface salinity content 
     795         CALL histwrite( nid_T, "votemper", it, ts(:,:,:,jp_tem,Kmm) * ze3t(:,:,:) , ndim_T , ndex_T  )   ! heat content 
     796         CALL histwrite( nid_T, "vosaline", it, ts(:,:,:,jp_sal,Kmm) * ze3t(:,:,:) , ndim_T , ndex_T  )   ! salt content 
     797         CALL histwrite( nid_T, "sosstsst", it, ts(:,:,1,jp_tem,Kmm) * ze3t(:,:,1) , ndim_hT, ndex_hT )   ! sea surface heat content 
     798         CALL histwrite( nid_T, "sosaline", it, ts(:,:,1,jp_sal,Kmm) * ze3t(:,:,1) , ndim_hT, ndex_hT )   ! sea surface salinity content 
    772799      ELSE 
    773800         CALL histwrite( nid_T, "votemper", it, ts(:,:,:,jp_tem,Kmm) , ndim_T , ndex_T  )   ! temperature 
    … …  
    777804      ENDIF 
    778805      IF( .NOT.ln_linssh ) THEN 
    779          zw3d(:,:,:) = ( ( e3t(:,:,:,Kmm) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 
    780          CALL histwrite( nid_T, "vovvle3t", it, e3t (:,:,:,Kmm) , ndim_T , ndex_T  )   ! level thickness 
    781          CALL histwrite( nid_T, "vovvldep", it, gdept(:,:,:,Kmm) , ndim_T , ndex_T  )   ! t-point depth 
     806         zw3d(:,:,:) = ( ( ze3t(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 
     807         CALL histwrite( nid_T, "vovvle3t", it, ze3t (:,:,:)    , ndim_T , ndex_T  )   ! level thickness 
     808         CALL histwrite( nid_T, "vovvldep", it, zgdept , ndim_T , ndex_T  )   ! t-point depth  
    782809         CALL histwrite( nid_T, "vovvldef", it, zw3d             , ndim_T , ndex_T  )   ! level thickness deformation 
    783810      ENDIF 
    … …  
    918945      !! 
    919946      INTEGER :: inum, jk 
     947      REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t, zgdept      ! 3D workspace !!st patch to use substitution 
    920948      !!---------------------------------------------------------------------- 
    921949      !  
    922       IF(lwp) WRITE(numout,*) 
    923       IF(lwp) WRITE(numout,*) 'dia_wri_state : single instantaneous ocean state' 
    924       IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~   and forcing fields file created ' 
    925       IF(lwp) WRITE(numout,*) '                and named :', cdfile_name, '...nc' 
    926  
    927 #if defined key_si3 
    928      CALL iom_open( TRIM(cdfile_name), inum, ldwrt = .TRUE., kdlev = jpl ) 
    929 #else 
    930      CALL iom_open( TRIM(cdfile_name), inum, ldwrt = .TRUE. ) 
    931 #endif 
    932  
     950      IF(lwp) THEN 
     951         WRITE(numout,*) 
     952         WRITE(numout,*) 'dia_wri_state : single instantaneous ocean state' 
     953         WRITE(numout,*) '~~~~~~~~~~~~~   and forcing fields file created ' 
     954         WRITE(numout,*) '                and named :', cdfile_name, '...nc' 
     955      ENDIF  
     956      ! 
     957      DO jk = 1, jpk 
     958         ze3t(:,:,jk) =  e3t(:,:,jk,Kmm) 
     959         zgdept(:,:,jk) =  gdept(:,:,jk,Kmm) 
     960      END DO 
     961      ! 
     962      CALL iom_open( TRIM(cdfile_name), inum, ldwrt = .TRUE. ) 
     963      ! 
    933964      CALL iom_rstput( 0, 0, inum, 'votemper', ts(:,:,:,jp_tem,Kmm) )    ! now temperature 
    934965      CALL iom_rstput( 0, 0, inum, 'vosaline', ts(:,:,:,jp_sal,Kmm) )    ! now salinity 
    935       CALL iom_rstput( 0, 0, inum, 'sossheig', ssh(:,:,Kmm)              )    ! sea surface height 
    936       CALL iom_rstput( 0, 0, inum, 'vozocrtx', uu(:,:,:,Kmm)                )    ! now i-velocity 
    937       CALL iom_rstput( 0, 0, inum, 'vomecrty', vv(:,:,:,Kmm)                )    ! now j-velocity 
     966      CALL iom_rstput( 0, 0, inum, 'sossheig', ssh(:,:        ,Kmm) )    ! sea surface height 
     967      CALL iom_rstput( 0, 0, inum, 'vozocrtx', uu(:,:,:       ,Kmm) )    ! now i-velocity 
     968      CALL iom_rstput( 0, 0, inum, 'vomecrty', vv(:,:,:       ,Kmm) )    ! now j-velocity 
    938969      IF( ln_zad_Aimp ) THEN 
    939970         CALL iom_rstput( 0, 0, inum, 'vovecrtz', ww + wi        )    ! now k-velocity 
    … …  
    942973      ENDIF 
    943974      CALL iom_rstput( 0, 0, inum, 'risfdep', risfdep            )    ! now k-velocity 
    944       CALL iom_rstput( 0, 0, inum, 'ht'     , ht                 )    ! now water column height 
    945  
     975      CALL iom_rstput( 0, 0, inum, 'ht'     , ht(:,:)            )    ! now water column height 
     976      ! 
    946977      IF ( ln_isf ) THEN 
    947978         IF (ln_isfcav_mlt) THEN 
    … …  
    949980            CALL iom_rstput( 0, 0, inum, 'rhisf_cav_tbl', rhisf_tbl_cav    )    ! now k-velocity 
    950981            CALL iom_rstput( 0, 0, inum, 'rfrac_cav_tbl', rfrac_tbl_cav    )    ! now k-velocity 
    951             CALL iom_rstput( 0, 0, inum, 'misfkb_cav', REAL(misfkb_cav,8)    )    ! now k-velocity 
    952             CALL iom_rstput( 0, 0, inum, 'misfkt_cav', REAL(misfkt_cav,8)    )    ! now k-velocity 
    953             CALL iom_rstput( 0, 0, inum, 'mskisf_cav', REAL(mskisf_cav,8), ktype = jp_i1 ) 
     982            CALL iom_rstput( 0, 0, inum, 'misfkb_cav', REAL(misfkb_cav,wp) )    ! now k-velocity 
     983            CALL iom_rstput( 0, 0, inum, 'misfkt_cav', REAL(misfkt_cav,wp) )    ! now k-velocity 
     984            CALL iom_rstput( 0, 0, inum, 'mskisf_cav', REAL(mskisf_cav,wp), ktype = jp_i1 ) 
    954985         END IF 
    955986         IF (ln_isfpar_mlt) THEN 
    956             CALL iom_rstput( 0, 0, inum, 'isfmsk_par', REAL(mskisf_par,8) )    ! now k-velocity 
     987            CALL iom_rstput( 0, 0, inum, 'isfmsk_par', REAL(mskisf_par,wp) )    ! now k-velocity 
    957988            CALL iom_rstput( 0, 0, inum, 'fwfisf_par', fwfisf_par          )    ! now k-velocity 
    958989            CALL iom_rstput( 0, 0, inum, 'rhisf_par_tbl', rhisf_tbl_par    )    ! now k-velocity 
    959990            CALL iom_rstput( 0, 0, inum, 'rfrac_par_tbl', rfrac_tbl_par    )    ! now k-velocity 
    960             CALL iom_rstput( 0, 0, inum, 'misfkb_par', REAL(misfkb_par,8)    )    ! now k-velocity 
    961             CALL iom_rstput( 0, 0, inum, 'misfkt_par', REAL(misfkt_par,8)    )    ! now k-velocity 
    962             CALL iom_rstput( 0, 0, inum, 'mskisf_par', REAL(mskisf_par,8), ktype = jp_i1 ) 
     991            CALL iom_rstput( 0, 0, inum, 'misfkb_par', REAL(misfkb_par,wp) )    ! now k-velocity 
     992            CALL iom_rstput( 0, 0, inum, 'misfkt_par', REAL(misfkt_par,wp) )    ! now k-velocity 
     993            CALL iom_rstput( 0, 0, inum, 'mskisf_par', REAL(mskisf_par,wp), ktype = jp_i1 ) 
    963994         END IF 
    964995      END IF 
    965  
     996      ! 
    966997      IF( ALLOCATED(ahtu) ) THEN 
    967998         CALL iom_rstput( 0, 0, inum,  'ahtu', ahtu              )    ! aht at u-point 
    … …  
    9781009      CALL iom_rstput( 0, 0, inum, 'sozotaux', utau              )    ! i-wind stress 
    9791010      CALL iom_rstput( 0, 0, inum, 'sometauy', vtau              )    ! j-wind stress 
    980       IF(  .NOT.ln_linssh  ) THEN              
    981          CALL iom_rstput( 0, 0, inum, 'vovvldep', gdept(:,:,:,Kmm)        )    !  T-cell depth  
    982          CALL iom_rstput( 0, 0, inum, 'vovvle3t', e3t(:,:,:,Kmm)          )    !  T-cell thickness   
     1011      IF(  .NOT.ln_linssh  ) THEN 
     1012         CALL iom_rstput( 0, 0, inum, 'vovvldep', zgdept        )    !  T-cell depth  
     1013         CALL iom_rstput( 0, 0, inum, 'vovvle3t', ze3t          )    !  T-cell thickness   
    9831014      END IF 
    9841015      IF( ln_wave .AND. ln_sdw ) THEN 
    … …  
    9931024         CALL iom_rstput ( 0, 0, inum, "qz1_abl",  tq_abl(:,:,2,nt_a,2) )   ! now first level humidity 
    9941025      ENDIF 
    995   
     1026      ! 
     1027      CALL iom_close( inum ) 
     1028      !  
    9961029#if defined key_si3 
    9971030      IF( nn_ice == 2 ) THEN   ! condition needed in case agrif + ice-model but no-ice in child grid 
     1031         CALL iom_open( TRIM(cdfile_name)//'_ice', inum, ldwrt = .TRUE., kdlev = jpl, cdcomp = 'ICE' ) 
    9981032         CALL ice_wri_state( inum ) 
     1033         CALL iom_close( inum ) 
    9991034      ENDIF 
    10001035#endif 
    1001       ! 
    1002       CALL iom_close( inum ) 
    1003       !  
     1036 
    10041037   END SUBROUTINE dia_wri_state 
    10051038 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DOM/dom_oce.F90

    r12489 r13151  
    22   !!====================================================================== 
    33   !!                       ***  MODULE dom_oce  *** 
    4    !!        
    54   !! ** Purpose :   Define in memory all the ocean space domain variables 
    65   !!====================================================================== 
    7    !! History :  1.0  ! 2005-10  (A. Beckmann, G. Madec)  reactivate s-coordinate  
     6   !! History :  1.0  ! 2005-10  (A. Beckmann, G. Madec)  reactivate s-coordinate 
    87   !!            3.3  ! 2010-11  (G. Madec) add mbk. arrays associated to the deepest ocean level 
    98   !!            3.4  ! 2011-01  (A. R. Porter, STFC Daresbury) dynamical allocation 
    … …  
    1312   !!             -   ! 2015-11  (G. Madec, A. Coward)  time varying zgr by default 
    1413   !!            4.1  ! 2019-08  (A. Coward, D. Storkey) rename prognostic variables in preparation for new time scheme. 
     14   !!            4.x  ! 2020-02  (G. Madec, S. Techene) introduce ssh to h0 ratio 
    1515   !!---------------------------------------------------------------------- 
    1616 
    … …  
    7171   !                                !  = 6 cyclic East-West AND North fold F-point pivot 
    7272   !                                !  = 7 bi-cyclic East-West AND North-South 
    73    LOGICAL, PUBLIC ::   l_Iperio, l_Jperio   !   should we explicitely take care I/J periodicity  
    74  
    75    !                                 ! domain MPP decomposition parameters 
     73   LOGICAL, PUBLIC ::   l_Iperio, l_Jperio   !   should we explicitely take care I/J periodicity 
     74 
     75   !                             !: domain MPP decomposition parameters 
    7676   INTEGER             , PUBLIC ::   nimpp, njmpp     !: i- & j-indexes for mpp-subdomain left bottom 
    7777   INTEGER             , PUBLIC ::   nreci, nrecj     !: overlap region in i and j 
    … …  
    8181   INTEGER, ALLOCATABLE, PUBLIC ::   nbondi_bdy(:)    !: mark i-direction local boundaries for BDY open boundaries 
    8282   INTEGER, ALLOCATABLE, PUBLIC ::   nbondj_bdy(:)    !: mark j-direction local boundaries for BDY open boundaries 
    83    INTEGER, ALLOCATABLE, PUBLIC ::   nbondi_bdy_b(:)  !: mark i-direction of neighbours local boundaries for BDY open boundaries   
    84    INTEGER, ALLOCATABLE, PUBLIC ::   nbondj_bdy_b(:)  !: mark j-direction of neighbours local boundaries for BDY open boundaries   
     83   INTEGER, ALLOCATABLE, PUBLIC ::   nbondi_bdy_b(:)  !: mark i-direction of neighbours local boundaries for BDY open boundaries 
     84   INTEGER, ALLOCATABLE, PUBLIC ::   nbondj_bdy_b(:)  !: mark j-direction of neighbours local boundaries for BDY open boundaries 
    8585 
    8686   INTEGER, PUBLIC ::   npolj             !: north fold mark (0, 3 or 4) 
    … …  
    126126   LOGICAL, PUBLIC ::   ln_zps       !: z-coordinate - partial step 
    127127   LOGICAL, PUBLIC ::   ln_sco       !: s-coordinate or hybrid z-s coordinate 
    128    LOGICAL, PUBLIC ::   ln_isfcav    !: presence of ISF  
     128   LOGICAL, PUBLIC ::   ln_isfcav    !: presence of ISF 
    129129   !                                                        !  reference scale factors 
    130130   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::     e3t_0   !: t- vert. scale factor [m] 
    … …  
    136136   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::    e3vw_0   !: vw-vert. scale factor [m] 
    137137   !                                                        !  time-dependent scale factors 
     138#if ! defined key_qco 
    138139   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   e3t, e3u, e3v, e3w, e3uw, e3vw  !: vert. scale factor [m] 
    139140   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   e3f                             !: F-point vert. scale factor [m] 
     141#endif 
     142   !                                                        !  time-dependent ratio ssh / h_0 
     143   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   r3t, r3u, r3v                   !: time-dependent    ratio at t-, u- and v-point [-] 
     144   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   r3f                             !: mid-time-level    ratio at f-point            [-] 
     145   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   r3t_f, r3u_f, r3v_f             !: now time-filtered ratio at t-, u- and v-point [-] 
    140146 
    141147   !                                                        !  reference depths of cells 
    142    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   gdept_0  !: t- depth              [m] 
    143    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   gdepw_0  !: w- depth              [m] 
    144    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   gde3w_0  !: w- depth (sum of e3w) [m] 
     148   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   gdept_0  !: t- depth              [m] 
     149   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   gdepw_0  !: w- depth              [m] 
     150   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   gde3w_0  !: w- depth (sum of e3w) [m] 
    145151   !                                                        !  time-dependent depths of cells 
    146    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::  gdept, gdepw   
    147    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::  gde3w   
    148     
    149    !                                                      !  reference heights of water column 
    150    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ht_0  !: t-depth              [m] 
    151    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hu_0  !: u-depth              [m] 
    152    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hv_0  !: v-depth              [m] 
    153                                                           ! time-dependent heights of water column 
    154    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ht                     !: height of water column at T-points [m] 
    155    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   hu, hv, r1_hu, r1_hv   !: height of water column [m] and reciprocal [1/m] 
     152   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   gdept, gdepw 
     153   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   gde3w 
     154 
     155   !                                                        !  reference heights of ocean water column and its inverse 
     156   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   ht_0, r1_ht_0   !: t-depth        [m] and [1/m] 
     157   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   hu_0, r1_hu_0   !: u-depth        [m] and [1/m] 
     158   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   hv_0, r1_hv_0   !: v-depth        [m] and [1/m] 
     159   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   hf_0, r1_hf_0   !: f-depth        [m] and [1/m] 
     160   !                                                        ! time-dependent heights of ocean water column 
     161#if ! defined key_qco 
     162   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   ht          !: t-points           [m] 
     163#endif 
     164   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   hu, r1_hu   !: u-depth            [m] and [1/m] 
     165   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   hv, r1_hv   !: v-depth            [m] and [1/m] 
    156166 
    157167   INTEGER, PUBLIC ::   nla10              !: deepest    W level Above  ~10m (nlb10 - 1) 
    158    INTEGER, PUBLIC ::   nlb10              !: shallowest W level Bellow ~10m (nla10 + 1)  
     168   INTEGER, PUBLIC ::   nlb10              !: shallowest W level Bellow ~10m (nla10 + 1) 
    159169 
    160170   !! 1D reference  vertical coordinate 
    … …  
    169179   !! --------------------------------------------------------------------- 
    170180!!gm Proposition of new name for top/bottom vertical indices 
    171 !   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   mtk_t, mtk_u, mtk_v   !: top first wet T-, U-, V-, F-level (ISF) 
    172 !   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   mbk_t, mbk_u, mbk_v   !: bottom last wet T-, U- and V-level 
     181!   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   mtk_t, mtk_u, mtk_v   !: top    first wet T-, U-, and V-level (ISF) 
     182!   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   mbk_t, mbk_u, mbk_v   !: bottom last  wet T-, U-, and V-level 
    173183!!gm 
    174184   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   mbkt, mbku, mbkv   !: bottom last wet T-, U- and V-level 
    … …  
    178188   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   mikt, miku, mikv, mikf  !: top first wet T-, U-, V-, F-level           (ISF) 
    179189 
    180    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ssmask, ssumask, ssvmask             !: surface mask at T-,U-, V- and F-pts 
    181    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: tmask, umask, vmask, fmask   !: land/ocean mask at T-, U-, V- and F-pts 
    182    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: wmask, wumask, wvmask        !: land/ocean mask at WT-, WU- and WV-pts 
     190   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)           ::   ssmask, ssumask, ssvmask, ssfmask   !: surface mask at T-,U-, V- and F-pts 
     191   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: tmask, umask, vmask, fmask            !: land/ocean mask at T-, U-, V- and F-pts 
     192   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: wmask, wumask, wvmask                 !: land/ocean mask at WT-, WU- and WV-pts 
    183193 
    184194   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   tpol, fpol          !: north fold mask (jperio= 3 or 4) 
    … …  
    198208   INTEGER , PUBLIC ::   nsec_monday   !: seconds between 00h         of the last Monday   and half of the current time step 
    199209   INTEGER , PUBLIC ::   nsec_day      !: seconds between 00h         of the current   day and half of the current time step 
    200    REAL(wp), PUBLIC ::   fjulday       !: current julian day  
     210   REAL(wp), PUBLIC ::   fjulday       !: current julian day 
    201211   REAL(wp), PUBLIC ::   fjulstartyear !: first day of the current year in julian days 
    202212   REAL(wp), PUBLIC ::   adatrj        !: number of elapsed days since the begining of the whole simulation 
    203213   !                                   !: (cumulative duration of previous runs that may have used different time-step size) 
    204    INTEGER , PUBLIC, DIMENSION(  0: 2) ::   nyear_len     !: length in days of the previous/current/next year 
    205    INTEGER , PUBLIC, DIMENSION(-11:25) ::   nmonth_len    !: length in days of the months of the current year 
    206    INTEGER , PUBLIC, DIMENSION(-11:25) ::   nmonth_beg    !: second since Jan 1st 0h of the current year and the half of the months 
    207    INTEGER , PUBLIC                  ::   nsec1jan000     !: second since Jan 1st 0h of nit000 year and Jan 1st 0h the current year 
    208    INTEGER , PUBLIC                  ::   nsec000_1jan000   !: second since Jan 1st 0h of nit000 year and nit000 
    209    INTEGER , PUBLIC                  ::   nsecend_1jan000   !: second since Jan 1st 0h of nit000 year and nitend 
     214   INTEGER , PUBLIC, DIMENSION(  0: 2) ::   nyear_len         !: length in days of the previous/current/next year 
     215   INTEGER , PUBLIC, DIMENSION(-11:25) ::   nmonth_len        !: length in days of the months of the current year 
     216   INTEGER , PUBLIC, DIMENSION(-11:25) ::   nmonth_beg        !: second since Jan 1st 0h of the current year and the half of the months 
     217   INTEGER , PUBLIC                    ::   nsec1jan000       !: second since Jan 1st 0h of nit000 year and Jan 1st 0h the current year 
     218   INTEGER , PUBLIC                    ::   nsec000_1jan000   !: second since Jan 1st 0h of nit000 year and nit000 
     219   INTEGER , PUBLIC                    ::   nsecend_1jan000   !: second since Jan 1st 0h of nit000 year and nitend 
    210220 
    211221   !!---------------------------------------------------------------------- 
    … …  
    220230   !!---------------------------------------------------------------------- 
    221231   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    222    !! $Id$  
     232   !! $Id$ 
    223233   !! Software governed by the CeCILL license (see ./LICENSE) 
    224234   !!---------------------------------------------------------------------- 
    … …  
    234244 
    235245   CHARACTER(len=3) FUNCTION Agrif_CFixed() 
    236       Agrif_CFixed = '0'  
     246      Agrif_CFixed = '0' 
    237247   END FUNCTION Agrif_CFixed 
    238248#endif 
    … …  
    240250   INTEGER FUNCTION dom_oce_alloc() 
    241251      !!---------------------------------------------------------------------- 
    242       INTEGER, DIMENSION(12) :: ierr 
     252      INTEGER                ::   ii 
     253      INTEGER, DIMENSION(30) :: ierr 
    243254      !!---------------------------------------------------------------------- 
    244       ierr(:) = 0 
     255      ii = 0   ;   ierr(:) = 0 
    245256      ! 
    246       ALLOCATE( mig(jpi), mjg(jpj), STAT=ierr(1) ) 
    247          ! 
    248       ALLOCATE( mi0(jpiglo)   , mi1 (jpiglo),  mj0(jpjglo)   , mj1 (jpjglo) ,     & 
    249          &      tpol(jpiglo)  , fpol(jpiglo)                                , STAT=ierr(2) ) 
    250          ! 
     257      ii = ii+1 
     258      ALLOCATE( mig(jpi), mjg(jpj), STAT=ierr(ii) ) 
     259         ! 
     260      ii = ii+1 
     261      ALLOCATE( mi0 (jpiglo) , mi1 (jpiglo),  mj0(jpjglo) , mj1 (jpjglo) ,     & 
     262         &      tpol(jpiglo) , fpol(jpiglo)                              , STAT=ierr(ii) ) 
     263         ! 
     264      ii = ii+1 
    251265      ALLOCATE( glamt(jpi,jpj) ,    glamu(jpi,jpj) ,  glamv(jpi,jpj) ,  glamf(jpi,jpj) ,     & 
    252266         &      gphit(jpi,jpj) ,    gphiu(jpi,jpj) ,  gphiv(jpi,jpj) ,  gphif(jpi,jpj) ,     & 
    … …  
    259273         &      e1e2v(jpi,jpj) , r1_e1e2v(jpi,jpj) , e1_e2v(jpi,jpj)                   ,     & 
    260274         &      e1e2f(jpi,jpj) , r1_e1e2f(jpi,jpj)                                     ,     & 
    261          &      ff_f (jpi,jpj) ,    ff_t (jpi,jpj)                                     , STAT=ierr(3) ) 
    262          ! 
     275         &      ff_f (jpi,jpj) ,    ff_t (jpi,jpj)                                     , STAT=ierr(ii) ) 
     276         ! 
     277      ii = ii+1 
    263278      ALLOCATE( gdept_0(jpi,jpj,jpk)     , gdepw_0(jpi,jpj,jpk)     , gde3w_0(jpi,jpj,jpk) ,      & 
    264          &      gdept  (jpi,jpj,jpk,jpt) , gdepw  (jpi,jpj,jpk,jpt) , gde3w  (jpi,jpj,jpk) , STAT=ierr(4) ) 
    265          ! 
    266       ALLOCATE( e3t_0(jpi,jpj,jpk)     , e3u_0(jpi,jpj,jpk)     , e3v_0(jpi,jpj,jpk)     , e3f_0(jpi,jpj,jpk) , e3w_0(jpi,jpj,jpk)     ,   & 
    267          &      e3t  (jpi,jpj,jpk,jpt) , e3u  (jpi,jpj,jpk,jpt) , e3v  (jpi,jpj,jpk,jpt) , e3f  (jpi,jpj,jpk) , e3w  (jpi,jpj,jpk,jpt) ,   &  
    268          &      e3uw_0(jpi,jpj,jpk)     , e3vw_0(jpi,jpj,jpk)     ,         & 
    269          &      e3uw  (jpi,jpj,jpk,jpt) , e3vw  (jpi,jpj,jpk,jpt) ,    STAT=ierr(5) )                        
    270          ! 
    271       ALLOCATE( ht_0(jpi,jpj) , hu_0(jpi,jpj)    , hv_0(jpi,jpj)     ,                                             & 
    272          &      ht  (jpi,jpj) , hu(  jpi,jpj,jpt), hv(  jpi,jpj,jpt) , r1_hu(jpi,jpj,jpt) , r1_hv(jpi,jpj,jpt) ,   & 
    273          &                      STAT=ierr(6)  ) 
    274          ! 
    275       ALLOCATE( risfdep(jpi,jpj) , bathy(jpi,jpj) , STAT=ierr(7)  )  
    276          ! 
    277       ALLOCATE( gdept_1d(jpk) , gdepw_1d(jpk) , e3t_1d(jpk) , e3w_1d(jpk) , STAT=ierr(8) ) 
    278          ! 
    279       ALLOCATE( tmask_i(jpi,jpj) , tmask_h(jpi,jpj) ,                        &  
    280          &      ssmask (jpi,jpj) , ssumask(jpi,jpj) , ssvmask(jpi,jpj) ,     & 
    281          &      mbkt   (jpi,jpj) , mbku   (jpi,jpj) , mbkv   (jpi,jpj) , STAT=ierr(9) ) 
    282          ! 
    283       ALLOCATE( mikt(jpi,jpj), miku(jpi,jpj), mikv(jpi,jpj), mikf(jpi,jpj), STAT=ierr(10) ) 
    284          ! 
    285       ALLOCATE( tmask(jpi,jpj,jpk) , umask(jpi,jpj,jpk) ,     &  
    286          &      vmask(jpi,jpj,jpk) , fmask(jpi,jpj,jpk) , STAT=ierr(11) ) 
    287          ! 
    288       ALLOCATE( wmask(jpi,jpj,jpk) , wumask(jpi,jpj,jpk), wvmask(jpi,jpj,jpk) , STAT=ierr(12) ) 
     279         &      gdept  (jpi,jpj,jpk,jpt) , gdepw  (jpi,jpj,jpk,jpt) , gde3w  (jpi,jpj,jpk) , STAT=ierr(ii) ) 
     280         ! 
     281      ii = ii+1 
     282      ALLOCATE(  e3t_0(jpi,jpj,jpk) , e3u_0 (jpi,jpj,jpk) , e3v_0 (jpi,jpj,jpk) , e3f_0(jpi,jpj,jpk) ,      & 
     283         &       e3w_0(jpi,jpj,jpk) , e3uw_0(jpi,jpj,jpk) , e3vw_0(jpi,jpj,jpk)                      ,  STAT=ierr(ii) ) 
     284         ! 
     285#if ! defined key_qco 
     286      ii = ii+1 
     287      ALLOCATE( e3t(jpi,jpj,jpk,jpt) , e3u (jpi,jpj,jpk,jpt) , e3v (jpi,jpj,jpk,jpt) , e3f(jpi,jpj,jpk) ,      & 
     288         &      e3w(jpi,jpj,jpk,jpt) , e3uw(jpi,jpj,jpk,jpt) , e3vw(jpi,jpj,jpk,jpt)                    ,  STAT=ierr(ii) ) 
     289#endif   
     290         ! 
     291      ii = ii+1 
     292      ALLOCATE( r3t  (jpi,jpj,jpt)   , r3u  (jpi,jpj,jpt)    , r3v  (jpi,jpj,jpt)    , r3f  (jpi,jpj) ,  & 
     293         &      r3t_f(jpi,jpj)       , r3u_f(jpi,jpj)        , r3v_f(jpi,jpj)                         ,  STAT=ierr(ii) )        
     294         ! 
     295      ii = ii+1 
     296      ALLOCATE( ht_0(jpi,jpj) ,    hu_0(jpi,jpj)    ,    hv_0(jpi,jpj)     , hf_0(jpi,jpj) ,       & 
     297         &   r1_ht_0(jpi,jpj) , r1_hu_0(jpi,jpj) ,    r1_hv_0(jpi,jpj),   r1_hf_0(jpi,jpj) ,   STAT=ierr(ii)  ) 
     298         ! 
     299#if ! defined key_qco 
     300      ii = ii+1 
     301      ALLOCATE( ht  (jpi,jpj) ,    hu  (jpi,jpj,jpt),    hv  (jpi,jpj,jpt)                 ,       & 
     302         &                      r1_hu  (jpi,jpj,jpt), r1_hv  (jpi,jpj,jpt)                 ,   STAT=ierr(ii)  ) 
     303#else 
     304      ii = ii+1 
     305      ALLOCATE(                    hu  (jpi,jpj,jpt),    hv  (jpi,jpj,jpt)                 ,       & 
     306         &                      r1_hu  (jpi,jpj,jpt), r1_hv  (jpi,jpj,jpt)                 ,   STAT=ierr(ii)  ) 
     307#endif 
     308         ! 
     309      ii = ii+1 
     310      ALLOCATE( risfdep(jpi,jpj) , bathy(jpi,jpj) , STAT=ierr(ii)  )  
     311         ! 
     312      ii = ii+1 
     313      ALLOCATE( gdept_1d(jpk) , gdepw_1d(jpk) , e3t_1d(jpk) , e3w_1d(jpk) , STAT=ierr(ii) ) 
     314         ! 
     315      ii = ii+1 
     316      ALLOCATE( tmask_i(jpi,jpj) , tmask_h(jpi,jpj) ,                                           & 
     317         &      ssmask (jpi,jpj) , ssumask(jpi,jpj) , ssvmask(jpi,jpj) , ssfmask(jpi,jpj) ,     & 
     318         &      mbkt   (jpi,jpj) , mbku   (jpi,jpj) , mbkv   (jpi,jpj) ,                    STAT=ierr(ii) ) 
     319         ! 
     320      ii = ii+1 
     321      ALLOCATE( mikt(jpi,jpj), miku(jpi,jpj), mikv(jpi,jpj), mikf(jpi,jpj), STAT=ierr(ii) ) 
     322         ! 
     323      ii = ii+1 
     324      ALLOCATE( tmask(jpi,jpj,jpk) , umask(jpi,jpj,jpk) ,     & 
     325         &      vmask(jpi,jpj,jpk) , fmask(jpi,jpj,jpk) , STAT=ierr(ii) ) 
     326         ! 
     327      ii = ii+1 
     328      ALLOCATE( wmask(jpi,jpj,jpk) , wumask(jpi,jpj,jpk), wvmask(jpi,jpj,jpk) , STAT=ierr(ii) ) 
    289329      ! 
    290330      dom_oce_alloc = MAXVAL(ierr) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DOM/domain.F90

    r12489 r13151  
    66   !! History :  OPA  !  1990-10  (C. Levy - G. Madec)  Original code 
    77   !!                 !  1992-01  (M. Imbard) insert time step initialization 
    8    !!                 !  1996-06  (G. Madec) generalized vertical coordinate  
     8   !!                 !  1996-06  (G. Madec) generalized vertical coordinate 
    99   !!                 !  1997-02  (G. Madec) creation of domwri.F 
    1010   !!                 !  2001-05  (E.Durand - G. Madec) insert closed sea 
    … …  
    1515   !!            3.7  !  2015-11  (G. Madec, A. Coward)  time varying zgr by default 
    1616   !!            4.0  !  2016-10  (G. Madec, S. Flavoni)  domain configuration / user defined interface 
     17   !!            4.x  ! 2020-02  (G. Madec, S. Techene) introduce ssh to h0 ratio 
    1718   !!---------------------------------------------------------------------- 
    18     
     19 
    1920   !!---------------------------------------------------------------------- 
    2021   !!   dom_init      : initialize the space and time domain 
    … …  
    3435   USE dommsk         ! domain: set the mask system 
    3536   USE domwri         ! domain: write the meshmask file 
     37#if ! defined key_qco 
    3638   USE domvvl         ! variable volume 
     39#else 
     40   USE domqco          ! variable volume 
     41#endif 
    3742   USE c1d            ! 1D configuration 
    3843   USE dyncor_c1d     ! 1D configuration: Coriolis term    (cor_c1d routine) 
    … …  
    6166      !!---------------------------------------------------------------------- 
    6267      !!                  ***  ROUTINE dom_init  *** 
    63       !!                     
    64       !! ** Purpose :   Domain initialization. Call the routines that are  
    65       !!              required to create the arrays which define the space  
     68      !! 
     69      !! ** Purpose :   Domain initialization. Call the routines that are 
     70      !!              required to create the arrays which define the space 
    6671      !!              and time domain of the ocean model. 
    6772      !! 
    … …  
    7681      CHARACTER (len=*), INTENT(in) :: cdstr                  ! model: NEMO or SAS. Determines core restart variables 
    7782      ! 
    78       INTEGER ::   ji, jj, jk, ik   ! dummy loop indices 
     83      INTEGER ::   ji, jj, jk, jt   ! dummy loop indices 
    7984      INTEGER ::   iconf = 0    ! local integers 
    80       CHARACTER (len=64) ::   cform = "(A12, 3(A13, I7))"  
     85      CHARACTER (len=64) ::   cform = "(A12, 3(A13, I7))" 
    8186      INTEGER , DIMENSION(jpi,jpj) ::   ik_top , ik_bot       ! top and bottom ocean level 
    8287      REAL(wp), DIMENSION(jpi,jpj) ::   z1_hu_0, z1_hv_0 
    … …  
    110115         CASE( 7 )   ;   WRITE(numout,*) '         (i.e. cyclic east-west and north-south)' 
    111116         CASE DEFAULT 
    112             CALL ctl_stop( 'jperio is out of range' ) 
     117            CALL ctl_stop( 'dom_init:   jperio is out of range' ) 
    113118         END SELECT 
    114119         WRITE(numout,*)     '      Ocean model configuration used:' 
    … …  
    140145      IF( ln_closea ) CALL dom_clo      ! Read in masks to define closed seas and lakes 
    141146 
    142       CALL dom_zgr( ik_top, ik_bot )    ! Vertical mesh and bathymetry 
     147      CALL dom_zgr( ik_top, ik_bot )    ! Vertical mesh and bathymetry (return top and bottom ocean t-level indices) 
    143148 
    144149      CALL dom_msk( ik_top, ik_bot )    ! Masks 
    … …  
    147152      hu_0(:,:) = 0._wp 
    148153      hv_0(:,:) = 0._wp 
     154      hf_0(:,:) = 0._wp 
    149155      DO jk = 1, jpk 
    150156         ht_0(:,:) = ht_0(:,:) + e3t_0(:,:,jk) * tmask(:,:,jk) 
    151157         hu_0(:,:) = hu_0(:,:) + e3u_0(:,:,jk) * umask(:,:,jk) 
    152158         hv_0(:,:) = hv_0(:,:) + e3v_0(:,:,jk) * vmask(:,:,jk) 
     159         hf_0(:,:) = hf_0(:,:) + e3f_0(:,:,jk) * fmask(:,:,jk) 
    153160      END DO 
    154161      ! 
     162      r1_ht_0(:,:) = ssmask (:,:) / ( ht_0(:,:) + 1._wp -  ssmask (:,:) ) 
     163      r1_hu_0(:,:) = ssumask(:,:) / ( hu_0(:,:) + 1._wp -  ssumask(:,:) ) 
     164      r1_hv_0(:,:) = ssvmask(:,:) / ( hv_0(:,:) + 1._wp -  ssvmask(:,:) ) 
     165      r1_hf_0(:,:) = ssfmask(:,:) / ( hf_0(:,:) + 1._wp -  ssfmask(:,:) ) 
     166 
     167      ! 
     168#if defined key_qco 
     169      !           !==  initialisation of time varying coordinate  ==!   Quasi-Euerian coordinate case 
     170      ! 
     171      IF( .NOT.l_offline )   CALL dom_qco_init( Kbb, Kmm, Kaa ) 
     172      ! 
     173      IF( ln_linssh )        CALL ctl_stop('STOP','domain: key_qco and ln_linssh = T are incompatible') 
     174      ! 
     175#else 
    155176      !           !==  time varying part of coordinate system  ==! 
    156177      ! 
    157178      IF( ln_linssh ) THEN       != Fix in time : set to the reference one for all 
    158       ! 
    159          !       before        !          now          !       after         ! 
    160             gdept(:,:,:,Kbb) = gdept_0  ;   gdept(:,:,:,Kmm) = gdept_0   ;   gdept(:,:,:,Kaa) = gdept_0   ! depth of grid-points 
    161             gdepw(:,:,:,Kbb) = gdepw_0  ;   gdepw(:,:,:,Kmm) = gdepw_0   ;   gdepw(:,:,:,Kaa) = gdepw_0   ! 
    162                                    gde3w = gde3w_0   !        ---          ! 
    163          !                                                                   
    164               e3t(:,:,:,Kbb) =   e3t_0  ;     e3t(:,:,:,Kmm) =   e3t_0   ;   e3t(:,:,:,Kaa) =  e3t_0    ! scale factors 
    165               e3u(:,:,:,Kbb) =   e3u_0  ;     e3u(:,:,:,Kmm) =   e3u_0   ;   e3u(:,:,:,Kaa) =  e3u_0    ! 
    166               e3v(:,:,:,Kbb) =   e3v_0  ;     e3v(:,:,:,Kmm) =   e3v_0   ;   e3v(:,:,:,Kaa) =  e3v_0    ! 
    167                                      e3f =   e3f_0   !        ---          ! 
    168               e3w(:,:,:,Kbb) =   e3w_0  ;     e3w(:,:,:,Kmm) =   e3w_0   ;    e3w(:,:,:,Kaa) =   e3w_0   !  
    169              e3uw(:,:,:,Kbb) =  e3uw_0  ;    e3uw(:,:,:,Kmm) =  e3uw_0   ;   e3uw(:,:,:,Kaa) =  e3uw_0   !   
    170              e3vw(:,:,:,Kbb) =  e3vw_0  ;    e3vw(:,:,:,Kmm) =  e3vw_0   ;   e3vw(:,:,:,Kaa) =  e3vw_0   ! 
    171          ! 
    172          z1_hu_0(:,:) = ssumask(:,:) / ( hu_0(:,:) + 1._wp - ssumask(:,:) )     ! _i mask due to ISF 
    173          z1_hv_0(:,:) = ssvmask(:,:) / ( hv_0(:,:) + 1._wp - ssvmask(:,:) ) 
    174          ! 
    175          !        before       !          now          !       after         ! 
    176                                       ht =    ht_0   !                     ! water column thickness 
    177                hu(:,:,Kbb) =    hu_0  ;      hu(:,:,Kmm) =    hu_0   ;    hu(:,:,Kaa) =    hu_0   !  
    178                hv(:,:,Kbb) =    hv_0  ;      hv(:,:,Kmm) =    hv_0   ;    hv(:,:,Kaa) =    hv_0   ! 
    179             r1_hu(:,:,Kbb) = z1_hu_0  ;   r1_hu(:,:,Kmm) = z1_hu_0   ; r1_hu(:,:,Kaa) = z1_hu_0   ! inverse of water column thickness 
    180             r1_hv(:,:,Kbb) = z1_hv_0  ;   r1_hv(:,:,Kmm) = z1_hv_0   ; r1_hv(:,:,Kaa) = z1_hv_0   ! 
    181          ! 
     179         ! 
     180         DO jt = 1, jpt                         ! depth of t- and w-grid-points 
     181            gdept(:,:,:,jt) = gdept_0(:,:,:) 
     182            gdepw(:,:,:,jt) = gdepw_0(:,:,:) 
     183         END DO 
     184            gde3w(:,:,:)    = gde3w_0(:,:,:)    ! = gdept as the sum of e3t 
     185         ! 
     186         DO jt = 1, jpt                         ! vertical scale factors 
     187            e3t(:,:,:,jt) =  e3t_0(:,:,:) 
     188            e3u(:,:,:,jt) =  e3u_0(:,:,:) 
     189            e3v(:,:,:,jt) =  e3v_0(:,:,:) 
     190            e3w(:,:,:,jt) =  e3w_0(:,:,:) 
     191            e3uw(:,:,:,jt) = e3uw_0(:,:,:) 
     192            e3vw(:,:,:,jt) = e3vw_0(:,:,:) 
     193         END DO 
     194            e3f(:,:,:)    =  e3f_0(:,:,:) 
     195         ! 
     196         DO jt = 1, jpt                         ! water column thickness and its inverse 
     197            hu(:,:,jt)    =    hu_0(:,:) 
     198            hv(:,:,jt)    =    hv_0(:,:) 
     199            r1_hu(:,:,jt) = r1_hu_0(:,:) 
     200            r1_hv(:,:,jt) = r1_hv_0(:,:) 
     201         END DO 
     202            ht(:,:) =    ht_0(:,:) 
    182203         ! 
    183204      ELSE                       != time varying : initialize before/now/after variables 
    184205         ! 
    185          IF( .NOT.l_offline )  CALL dom_vvl_init( Kbb, Kmm, Kaa ) 
    186          ! 
    187       ENDIF 
     206         IF( .NOT.l_offline )   CALL dom_vvl_init( Kbb, Kmm, Kaa ) 
     207         ! 
     208      ENDIF 
     209#endif 
     210 
    188211      ! 
    189212      IF( lk_c1d         )   CALL cor_c1d       ! 1D configuration: Coriolis set at T-point 
    … …  
    198221         WRITE(numout,*) 'dom_init :   ==>>>   END of domain initialization' 
    199222         WRITE(numout,*) '~~~~~~~~' 
    200          WRITE(numout,*)  
     223         WRITE(numout,*) 
    201224      ENDIF 
    202225      ! 
    … …  
    210233      !! ** Purpose :   initialization of global domain <--> local domain indices 
    211234      !! 
    212       !! ** Method  :    
     235      !! ** Method  : 
    213236      !! 
    214237      !! ** Action  : - mig , mjg : local  domain indices ==> global domain indices 
    … …  
    226249      END DO 
    227250      !                              ! global domain indices ==> local domain indices 
    228       !                                   ! (return (m.0,m.1)=(1,0) if data domain gridpoint is to the west/south of the  
    229       !                                   ! local domain, or (m.0,m.1)=(jp.+1,jp.) to the east/north of local domain.  
     251      !                                   ! (return (m.0,m.1)=(1,0) if data domain gridpoint is to the west/south of the 
     252      !                                   ! local domain, or (m.0,m.1)=(jp.+1,jp.) to the east/north of local domain. 
    230253      DO ji = 1, jpiglo 
    231254        mi0(ji) = MAX( 1 , MIN( ji - nimpp + 1, jpi+1 ) ) 
    … …  
    273296      !!---------------------------------------------------------------------- 
    274297      !!                     ***  ROUTINE dom_nam  *** 
    275       !!                     
     298      !! 
    276299      !! ** Purpose :   read domaine namelists and print the variables. 
    277300      !! 
    … …  
    355378      l_1st_euler = ln_1st_euler 
    356379      IF( .NOT. l_1st_euler .AND. .NOT. ln_rstart ) THEN 
    357          IF(lwp) WRITE(numout,*)   
     380         IF(lwp) WRITE(numout,*) 
    358381         IF(lwp) WRITE(numout,*)'   ==>>>   Start from rest (ln_rstart=F)' 
    359382         IF(lwp) WRITE(numout,*)'           an Euler initial time step is used : l_1st_euler is forced to .true. '    
    … …  
    383406      IF(lwp) WRITE(numout,*) 
    384407      SELECT CASE ( nleapy )        ! Choose calendar for IOIPSL 
    385       CASE (  1 )  
     408      CASE (  1 ) 
    386409         CALL ioconf_calendar('gregorian') 
    387410         IF(lwp) WRITE(numout,*) '   ==>>>   The IOIPSL calendar is "gregorian", i.e. leap year' 
    … …  
    419442      IF( TRIM(Agrif_CFixed()) == '0' ) THEN 
    420443         lrxios = ln_xios_read.AND.ln_rstart 
    421 !set output file type for XIOS based on NEMO namelist  
    422          IF (nn_wxios > 0) lwxios = .TRUE.  
     444!set output file type for XIOS based on NEMO namelist 
     445         IF (nn_wxios > 0) lwxios = .TRUE. 
    423446         nxioso = nn_wxios 
    424447      ENDIF 
    … …  
    463486      !!---------------------------------------------------------------------- 
    464487      INTEGER, DIMENSION(2) ::   imi1, imi2, ima1, ima2 
    465       INTEGER, DIMENSION(2) ::   iloc   !  
     488      INTEGER, DIMENSION(2) ::   iloc   ! 
    466489      REAL(wp) ::   ze1min, ze1max, ze2min, ze2max 
    467490      !!---------------------------------------------------------------------- 
    … …  
    473496         CALL mpp_maxloc( 'domain', e2t(:,:), tmask_i(:,:), ze2max, ima2 ) 
    474497      ELSE 
    475          ze1min = MINVAL( e1t(:,:), mask = tmask_i(:,:) == 1._wp )     
    476          ze2min = MINVAL( e2t(:,:), mask = tmask_i(:,:) == 1._wp )     
    477          ze1max = MAXVAL( e1t(:,:), mask = tmask_i(:,:) == 1._wp )     
    478          ze2max = MAXVAL( e2t(:,:), mask = tmask_i(:,:) == 1._wp )     
     498         ze1min = MINVAL( e1t(:,:), mask = tmask_i(:,:) == 1._wp ) 
     499         ze2min = MINVAL( e2t(:,:), mask = tmask_i(:,:) == 1._wp ) 
     500         ze1max = MAXVAL( e1t(:,:), mask = tmask_i(:,:) == 1._wp ) 
     501         ze2max = MAXVAL( e2t(:,:), mask = tmask_i(:,:) == 1._wp ) 
    479502         ! 
    480503         iloc  = MINLOC( e1t(:,:), mask = tmask_i(:,:) == 1._wp ) 
    … …  
    507530      !!---------------------------------------------------------------------- 
    508531      !!                     ***  ROUTINE dom_nam  *** 
    509       !!                     
     532      !! 
    510533      !! ** Purpose :   read the domain size in domain configuration file 
    511534      !! 
    … …  
    514537      CHARACTER(len=*)              , INTENT(out) ::   cd_cfg          ! configuration name 
    515538      INTEGER                       , INTENT(out) ::   kk_cfg          ! configuration resolution 
    516       INTEGER                       , INTENT(out) ::   kpi, kpj, kpk   ! global domain sizes  
    517       INTEGER                       , INTENT(out) ::   kperio          ! lateral global domain b.c.  
     539      INTEGER                       , INTENT(out) ::   kpi, kpj, kpk   ! global domain sizes 
     540      INTEGER                       , INTENT(out) ::   kperio          ! lateral global domain b.c. 
    518541      ! 
    519542      INTEGER ::   inum   ! local integer 
    … …  
    547570         cd_cfg = 'UNKNOWN' 
    548571         kk_cfg = -9999999 
    549                                           !- or they may be present as global attributes  
    550                                           !- (netcdf only)   
     572                                          !- or they may be present as global attributes 
     573                                          !- (netcdf only) 
    551574         CALL iom_getatt( inum, 'cn_cfg', cd_cfg )  ! returns   !  if not found 
    552575         CALL iom_getatt( inum, 'nn_cfg', kk_cfg )  ! returns -999 if not found 
    … …  
    570593         WRITE(numout,*) '      type of global domain lateral boundary   jperio = ', kperio 
    571594      ENDIF 
    572       !         
     595      ! 
    573596   END SUBROUTINE domain_cfg 
    574     
    575     
     597 
     598 
    576599   SUBROUTINE cfg_write 
    577600      !!---------------------------------------------------------------------- 
    578601      !!                  ***  ROUTINE cfg_write  *** 
    579       !!                    
    580       !! ** Purpose :   Create the "cn_domcfg_out" file, a NetCDF file which  
    581       !!              contains all the ocean domain informations required to  
     602      !! 
     603      !! ** Purpose :   Create the "cn_domcfg_out" file, a NetCDF file which 
     604      !!              contains all the ocean domain informations required to 
    582605      !!              define an ocean configuration. 
    583606      !! 
    … …  
    585608      !!              ocean configuration. 
    586609      !! 
    587       !! ** output file :   domcfg_out.nc : domain size, characteristics, horizontal  
     610      !! ** output file :   domcfg_out.nc : domain size, characteristics, horizontal 
    588611      !!                       mesh, Coriolis parameter, and vertical scale factors 
    589612      !!                    NB: also contain ORCA family information 
    … …  
    603626      !                       !  create 'domcfg_out.nc' file  ! 
    604627      !                       ! ============================= ! 
    605       !          
     628      ! 
    606629      clnam = cn_domcfg_out  ! filename (configuration information) 
    607630      CALL iom_open( TRIM(clnam), inum, ldwrt = .TRUE. ) 
    608        
     631 
    609632      ! 
    610633      !                             !==  ORCA family specificities  ==! 
    611634      IF( cn_cfg == "ORCA" ) THEN 
    612635         CALL iom_rstput( 0, 0, inum, 'ORCA'      , 1._wp            , ktype = jp_i4 ) 
    613          CALL iom_rstput( 0, 0, inum, 'ORCA_index', REAL( nn_cfg, wp), ktype = jp_i4 )          
     636         CALL iom_rstput( 0, 0, inum, 'ORCA_index', REAL( nn_cfg, wp), ktype = jp_i4 ) 
    614637      ENDIF 
    615638      ! 
    … …  
    643666      CALL iom_rstput( 0, 0, inum, 'glamv', glamv, ktype = jp_r8 ) 
    644667      CALL iom_rstput( 0, 0, inum, 'glamf', glamf, ktype = jp_r8 ) 
    645       !                                 
     668      ! 
    646669      CALL iom_rstput( 0, 0, inum, 'gphit', gphit, ktype = jp_r8 )   ! longitude 
    647670      CALL iom_rstput( 0, 0, inum, 'gphiu', gphiu, ktype = jp_r8 ) 
    648671      CALL iom_rstput( 0, 0, inum, 'gphiv', gphiv, ktype = jp_r8 ) 
    649672      CALL iom_rstput( 0, 0, inum, 'gphif', gphif, ktype = jp_r8 ) 
    650       !                                 
     673      ! 
    651674      CALL iom_rstput( 0, 0, inum, 'e1t'  , e1t  , ktype = jp_r8 )   ! i-scale factors (e1.) 
    652675      CALL iom_rstput( 0, 0, inum, 'e1u'  , e1u  , ktype = jp_r8 ) 
    … …  
    663686      ! 
    664687      !                             !==  vertical mesh  ==! 
    665       !                                                      
     688      ! 
    666689      CALL iom_rstput( 0, 0, inum, 'e3t_1d'  , e3t_1d , ktype = jp_r8 )   ! reference 1D-coordinate 
    667690      CALL iom_rstput( 0, 0, inum, 'e3w_1d'  , e3w_1d , ktype = jp_r8 ) 
    … …  
    674697      CALL iom_rstput( 0, 0, inum, 'e3uw_0'  , e3uw_0 , ktype = jp_r8 ) 
    675698      CALL iom_rstput( 0, 0, inum, 'e3vw_0'  , e3vw_0 , ktype = jp_r8 ) 
    676       !                                          
     699      ! 
    677700      !                             !==  wet top and bottom level  ==!   (caution: multiplied by ssmask) 
    678701      ! 
    … …  
    694717      ! 
    695718      !                                ! ============================ 
    696       !                                !        close the files  
     719      !                                !        close the files 
    697720      !                                ! ============================ 
    698721      CALL iom_close( inum ) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DOM/dommsk.F90

    r12377 r13151  
    22   !!====================================================================== 
    33   !!                       ***  MODULE dommsk   *** 
    4    !! Ocean initialization : domain land/sea mask  
     4   !! Ocean initialization : domain land/sea mask 
    55   !!====================================================================== 
    66   !! History :  OPA  ! 1987-07  (G. Madec)  Original code 
    … …  
    1818   !!            3.6  ! 2015-05  (P. Mathiot) ISF: add wmask,wumask and wvmask 
    1919   !!            4.0  ! 2016-06  (G. Madec, S. Flavoni)  domain configuration / user defined interface 
     20   !!            4.x  ! 2020-02  (G. Madec, S. Techene) introduce ssh to h0 ratio 
    2021   !!---------------------------------------------------------------------- 
    2122 
    … …  
    4041   !                            !!* Namelist namlbc : lateral boundary condition * 
    4142   REAL(wp)        :: rn_shlat   ! type of lateral boundary condition on velocity 
    42    LOGICAL, PUBLIC :: ln_vorlat  !  consistency of vorticity boundary condition  
     43   LOGICAL, PUBLIC :: ln_vorlat  !  consistency of vorticity boundary condition 
    4344   !                                            with analytical eqs. 
    4445 
    … …  
    4748   !!---------------------------------------------------------------------- 
    4849   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    49    !! $Id$  
     50   !! $Id$ 
    5051   !! Software governed by the CeCILL license (see ./LICENSE) 
    5152   !!---------------------------------------------------------------------- 
    … …  
    5960      !!      zontal velocity points (u & v), vorticity points (f) points. 
    6061      !! 
    61       !! ** Method  :   The ocean/land mask  at t-point is deduced from ko_top  
    62       !!      and ko_bot, the indices of the fist and last ocean t-levels which  
     62      !! ** Method  :   The ocean/land mask  at t-point is deduced from ko_top 
     63      !!      and ko_bot, the indices of the fist and last ocean t-levels which 
    6364      !!      are either defined in usrdef_zgr or read in zgr_read. 
    64       !!                The velocity masks (umask, vmask, wmask, wumask, wvmask)  
     65      !!                The velocity masks (umask, vmask, wmask, wumask, wvmask) 
    6566      !!      are deduced from a product of the two neighboring tmask. 
    6667      !!                The vorticity mask (fmask) is deduced from tmask taking 
    … …  
    7778      !!                due to cyclic or North Fold boundaries as well as MPP halos. 
    7879      !! 
    79       !! ** Action :   tmask, umask, vmask, wmask, wumask, wvmask : land/ocean mask  
     80      !! ** Action :   tmask, umask, vmask, wmask, wumask, wvmask : land/ocean mask 
    8081      !!                         at t-, u-, v- w, wu-, and wv-points (=0. or 1.) 
    81       !!               fmask   : land/ocean mask at f-point (=0., or =1., or  
     82      !!               fmask   : land/ocean mask at f-point (=0., or =1., or 
    8283      !!                         =rn_shlat along lateral boundaries) 
    83       !!               tmask_i : interior ocean mask  
     84      !!               tmask_i : interior ocean mask 
    8485      !!               tmask_h : halo mask 
    8586      !!               ssmask , ssumask, ssvmask, ssfmask : 2D ocean mask 
    … …  
    108109902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namlbc in configuration namelist' ) 
    109110      IF(lwm) WRITE ( numond, namlbc ) 
    110        
     111 
    111112      IF(lwp) THEN                  ! control print 
    112113         WRITE(numout,*) 
    … …  
    115116         WRITE(numout,*) '   Namelist namlbc' 
    116117         WRITE(numout,*) '      lateral momentum boundary cond.    rn_shlat  = ',rn_shlat 
    117          WRITE(numout,*) '      consistency with analytical form   ln_vorlat = ',ln_vorlat  
     118         WRITE(numout,*) '      consistency with analytical form   ln_vorlat = ',ln_vorlat 
    118119      ENDIF 
    119120      ! 
    … …  
    140141      ! 
    141142      ! the following call is mandatory 
    142       ! it masks boundaries (bathy=0) where needed depending on the configuration (closed, periodic...)   
     143      ! it masks boundaries (bathy=0) where needed depending on the configuration (closed, periodic...) 
    143144      CALL lbc_lnk( 'dommsk', tmask  , 'T', 1._wp )      ! Lateral boundary conditions 
    144  
     145       
    145146     ! Mask corrections for bdy (read in mppini2) 
    146147      READ  ( numnam_ref, nambdy, IOSTAT = ios, ERR = 903) 
    … …  
    157158         END_3D 
    158159      ENDIF 
    159           
     160 
    160161      !  Ocean/land mask at u-, v-, and f-points   (computed from tmask) 
    161162      ! ---------------------------------------- 
    … …  
    174175      END DO 
    175176      CALL lbc_lnk_multi( 'dommsk', umask, 'U', 1., vmask, 'V', 1., fmask, 'F', 1. )      ! Lateral boundary conditions 
    176   
     177 
    177178      ! Ocean/land mask at wu-, wv- and w points    (computed from tmask) 
    178179      !----------------------------------------- 
    … …  
    182183      DO jk = 2, jpk                   ! interior values 
    183184         wmask (:,:,jk) = tmask(:,:,jk) * tmask(:,:,jk-1) 
    184          wumask(:,:,jk) = umask(:,:,jk) * umask(:,:,jk-1)    
     185         wumask(:,:,jk) = umask(:,:,jk) * umask(:,:,jk-1) 
    185186         wvmask(:,:,jk) = vmask(:,:,jk) * vmask(:,:,jk-1) 
    186187      END DO 
    … …  
    192193      ssumask(:,:) = MAXVAL( umask(:,:,:), DIM=3 ) 
    193194      ssvmask(:,:) = MAXVAL( vmask(:,:,:), DIM=3 ) 
     195      ssfmask(:,:) = MAXVAL( fmask(:,:,:), DIM=3 ) 
    194196 
    195197 
    … …  
    201203      ! 
    202204      !                          ! halo mask : 0 on the halo and 1 elsewhere 
    203       tmask_h(:,:) = 1._wp                   
     205      tmask_h(:,:) = 1._wp 
    204206      tmask_h( 1 :iif,   :   ) = 0._wp      ! first columns 
    205207      tmask_h(iil:jpi,   :   ) = 0._wp      ! last  columns (including mpp extra columns) 
    … …  
    208210      ! 
    209211      !                          ! north fold mask 
    210       tpol(1:jpiglo) = 1._wp  
     212      tpol(1:jpiglo) = 1._wp 
    211213      fpol(1:jpiglo) = 1._wp 
    212214      IF( jperio == 3 .OR. jperio == 4 ) THEN      ! T-point pivot 
    … …  
    225227      ENDIF 
    226228      ! 
    227       !                          ! interior mask : 2D ocean mask x halo mask  
     229      !                          ! interior mask : 2D ocean mask x halo mask 
    228230      tmask_i(:,:) = ssmask(:,:) * tmask_h(:,:) 
    229231 
    230232 
    231233      ! Lateral boundary conditions on velocity (modify fmask) 
    232       ! ---------------------------------------   
     234      ! --------------------------------------- 
    233235      IF( rn_shlat /= 0 ) THEN      ! Not free-slip lateral boundary condition 
    234236         ! 
    … …  
    236238         ! 
    237239         DO jk = 1, jpk 
    238             zwf(:,:) = fmask(:,:,jk)          
     240            zwf(:,:) = fmask(:,:,jk) 
    239241            DO_2D_00_00 
    240242               IF( fmask(ji,jj,jk) == 0._wp ) THEN 
    … …  
    250252                  fmask(jpi,jj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(jpi,jj+1), zwf(jpim1,jj), zwf(jpi,jj-1) ) ) 
    251253               ENDIF 
    252             END DO          
     254            END DO 
    253255            DO ji = 2, jpim1 
    254256               IF( fmask(ji,1,jk) == 0._wp ) THEN 
    … …  
    259261               ENDIF 
    260262            END DO 
    261 #if defined key_agrif  
    262             IF( .NOT. AGRIF_Root() ) THEN  
    263                IF ((nbondi ==  1).OR.(nbondi == 2)) fmask(nlci-1 , :     ,jk) = 0.e0      ! east  
    264                IF ((nbondi == -1).OR.(nbondi == 2)) fmask(1      , :     ,jk) = 0.e0      ! west  
    265                IF ((nbondj ==  1).OR.(nbondj == 2)) fmask(:      ,nlcj-1 ,jk) = 0.e0      ! north  
    266                IF ((nbondj == -1).OR.(nbondj == 2)) fmask(:      ,1      ,jk) = 0.e0      ! south  
    267             ENDIF  
    268 #endif  
     263#if defined key_agrif 
     264            IF( .NOT. AGRIF_Root() ) THEN 
     265               IF ((nbondi ==  1).OR.(nbondi == 2)) fmask(nlci-1 , :     ,jk) = 0.e0      ! east 
     266               IF ((nbondi == -1).OR.(nbondi == 2)) fmask(1      , :     ,jk) = 0.e0      ! west 
     267               IF ((nbondj ==  1).OR.(nbondj == 2)) fmask(:      ,nlcj-1 ,jk) = 0.e0      ! north 
     268               IF ((nbondj == -1).OR.(nbondj == 2)) fmask(:      ,1      ,jk) = 0.e0      ! south 
     269            ENDIF 
     270#endif 
    269271         END DO 
    270272         ! 
    … …  
    276278         ! 
    277279      ENDIF 
    278        
     280 
    279281      ! User defined alteration of fmask (use to reduce ocean transport in specified straits) 
    280       ! --------------------------------  
     282      ! -------------------------------- 
    281283      ! 
    282284      CALL usr_def_fmask( cn_cfg, nn_cfg, fmask ) 
    283285      ! 
    284286   END SUBROUTINE dom_msk 
    285     
     287 
    286288   !!====================================================================== 
    287289END MODULE dommsk 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DOM/domvvl.F90

    r12489 r13151  
    22   !!====================================================================== 
    33   !!                       ***  MODULE domvvl   *** 
    4    !! Ocean :  
     4   !! Ocean : 
    55   !!====================================================================== 
    66   !! History :  2.0  !  2006-06  (B. Levier, L. Marie)  original code 
    … …  
    99   !!            3.6  !  2014-11  (P. Mathiot) add ice shelf capability 
    1010   !!            4.1  !  2019-08  (A. Coward, D. Storkey) rename dom_vvl_sf_swp -> dom_vvl_sf_update for new timestepping 
     11   !!            4.x  ! 2020-02  (G. Madec, S. Techene) introduce ssh to h0 ratio 
    1112   !!---------------------------------------------------------------------- 
    1213 
    13    !!---------------------------------------------------------------------- 
    14    !!   dom_vvl_init     : define initial vertical scale factors, depths and column thickness 
    15    !!   dom_vvl_sf_nxt   : Compute next vertical scale factors 
    16    !!   dom_vvl_sf_update   : Swap vertical scale factors and update the vertical grid 
    17    !!   dom_vvl_interpol : Interpolate vertical scale factors from one grid point to another 
    18    !!   dom_vvl_rst      : read/write restart file 
    19    !!   dom_vvl_ctl      : Check the vvl options 
    20    !!---------------------------------------------------------------------- 
    2114   USE oce             ! ocean dynamics and tracers 
    2215   USE phycst          ! physical constant 
    … …  
    3528   IMPLICIT NONE 
    3629   PRIVATE 
    37  
    38    PUBLIC  dom_vvl_init       ! called by domain.F90 
    39    PUBLIC  dom_vvl_zgr        ! called by isfcpl.F90 
    40    PUBLIC  dom_vvl_sf_nxt     ! called by step.F90 
    41    PUBLIC  dom_vvl_sf_update  ! called by step.F90 
    42    PUBLIC  dom_vvl_interpol   ! called by dynnxt.F90 
    43  
     30    
    4431   !                                                      !!* Namelist nam_vvl 
    4532   LOGICAL , PUBLIC :: ln_vvl_zstar           = .FALSE.    ! zstar  vertical coordinate 
    … …  
    6350   REAL(wp)        , ALLOCATABLE, SAVE, DIMENSION(:,:)   :: frq_rst_hdv                 ! retoring period for low freq. divergence 
    6451 
     52#if defined key_qco 
     53   !!---------------------------------------------------------------------- 
     54   !!   'key_qco'      EMPTY MODULE      Quasi-Eulerian vertical coordonate 
     55   !!---------------------------------------------------------------------- 
     56#else 
     57   !!---------------------------------------------------------------------- 
     58   !!   Default key      Old management of time varying vertical coordinate 
     59   !!---------------------------------------------------------------------- 
     60    
     61   !!---------------------------------------------------------------------- 
     62   !!   dom_vvl_init     : define initial vertical scale factors, depths and column thickness 
     63   !!   dom_vvl_sf_nxt   : Compute next vertical scale factors 
     64   !!   dom_vvl_sf_update   : Swap vertical scale factors and update the vertical grid 
     65   !!   dom_vvl_interpol : Interpolate vertical scale factors from one grid point to another 
     66   !!   dom_vvl_rst      : read/write restart file 
     67   !!   dom_vvl_ctl      : Check the vvl options 
     68   !!---------------------------------------------------------------------- 
     69 
     70   PUBLIC  dom_vvl_init       ! called by domain.F90 
     71   PUBLIC  dom_vvl_zgr        ! called by isfcpl.F90 
     72   PUBLIC  dom_vvl_sf_nxt     ! called by step.F90 
     73   PUBLIC  dom_vvl_sf_update  ! called by step.F90 
     74   PUBLIC  dom_vvl_interpol   ! called by dynnxt.F90 
     75    
    6576   !! * Substitutions 
    6677#  include "do_loop_substitute.h90" 
    … …  
    98109      !!---------------------------------------------------------------------- 
    99110      !!                ***  ROUTINE dom_vvl_init  *** 
    100       !!                    
     111      !! 
    101112      !! ** Purpose :  Initialization of all scale factors, depths 
    102113      !!               and water column heights 
    … …  
    107118      !! ** Action  : - e3t_(n/b) and tilde_e3t_(n/b) 
    108119      !!              - Regrid: e3[u/v](:,:,:,Kmm) 
    109       !!                        e3[u/v](:,:,:,Kmm)        
    110       !!                        e3w(:,:,:,Kmm)            
     120      !!                        e3[u/v](:,:,:,Kmm) 
     121      !!                        e3w(:,:,:,Kmm) 
    111122      !!                        e3[u/v]w_b 
    112       !!                        e3[u/v]w_n       
     123      !!                        e3[u/v]w_n 
    113124      !!                        gdept(:,:,:,Kmm), gdepw(:,:,:,Kmm) and gde3w 
    114125      !!              - h(t/u/v)_0 
    … …  
    135146      ! 
    136147   END SUBROUTINE dom_vvl_init 
    137    ! 
     148 
     149 
    138150   SUBROUTINE dom_vvl_zgr(Kbb, Kmm, Kaa) 
    139151      !!---------------------------------------------------------------------- 
    140152      !!                ***  ROUTINE dom_vvl_init  *** 
    141       !!                    
    142       !! ** Purpose :  Interpolation of all scale factors,  
     153      !! 
     154      !! ** Purpose :  Interpolation of all scale factors, 
    143155      !!               depths and water column heights 
    144156      !! 
    … …  
    147159      !! ** Action  : - e3t_(n/b) and tilde_e3t_(n/b) 
    148160      !!              - Regrid: e3(u/v)_n 
    149       !!                        e3(u/v)_b        
    150       !!                        e3w_n            
    151       !!                        e3(u/v)w_b       
    152       !!                        e3(u/v)w_n       
     161      !!                        e3(u/v)_b 
     162      !!                        e3w_n 
     163      !!                        e3(u/v)w_b 
     164      !!                        e3(u/v)w_n 
    153165      !!                        gdept_n, gdepw_n and gde3w_n 
    154166      !!              - h(t/u/v)_0 
    … …  
    168180      CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3u(:,:,:,Kbb), 'U' )    ! from T to U 
    169181      CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3u(:,:,:,Kmm), 'U' ) 
    170       CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3v(:,:,:,Kbb), 'V' )    ! from T to V  
     182      CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3v(:,:,:,Kbb), 'V' )    ! from T to V 
    171183      CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3v(:,:,:,Kmm), 'V' ) 
    172184      CALL dom_vvl_interpol( e3u(:,:,:,Kmm), e3f(:,:,:), 'F' )    ! from U to F 
    173       !                                ! Vertical interpolation of e3t,u,v  
     185      !                                ! Vertical interpolation of e3t,u,v 
    174186      CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3w (:,:,:,Kmm), 'W'  )  ! from T to W 
    175187      CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3w (:,:,:,Kbb), 'W'  ) 
    … …  
    193205         !    zcoef = tmask - wmask    ! 0 everywhere tmask = wmask, ie everywhere expect at jk = mikt 
    194206         !                             ! 1 everywhere from mbkt to mikt + 1 or 1 (if no isf) 
    195          !                             ! 0.5 where jk = mikt      
     207         !                             ! 0.5 where jk = mikt 
    196208!!gm ???????   BUG ?  gdept(:,:,:,Kmm) as well as gde3w  does not include the thickness of ISF ?? 
    197209         zcoef = ( tmask(ji,jj,jk) - wmask(ji,jj,jk) ) 
    198210         gdepw(ji,jj,jk,Kmm) = gdepw(ji,jj,jk-1,Kmm) + e3t(ji,jj,jk-1,Kmm) 
    199211         gdept(ji,jj,jk,Kmm) =      zcoef  * ( gdepw(ji,jj,jk  ,Kmm) + 0.5 * e3w(ji,jj,jk,Kmm))  & 
    200             &                + (1-zcoef) * ( gdept(ji,jj,jk-1,Kmm) +       e3w(ji,jj,jk,Kmm))  
     212            &                + (1-zcoef) * ( gdept(ji,jj,jk-1,Kmm) +       e3w(ji,jj,jk,Kmm)) 
    201213         gde3w(ji,jj,jk) = gdept(ji,jj,jk,Kmm) - ssh(ji,jj,Kmm) 
    202214         gdepw(ji,jj,jk,Kbb) = gdepw(ji,jj,jk-1,Kbb) + e3t(ji,jj,jk-1,Kbb) 
    203215         gdept(ji,jj,jk,Kbb) =      zcoef  * ( gdepw(ji,jj,jk  ,Kbb) + 0.5 * e3w(ji,jj,jk,Kbb))  & 
    204             &                + (1-zcoef) * ( gdept(ji,jj,jk-1,Kbb) +       e3w(ji,jj,jk,Kbb))  
     216            &                + (1-zcoef) * ( gdept(ji,jj,jk-1,Kbb) +       e3w(ji,jj,jk,Kbb)) 
    205217      END_3D 
    206218      ! 
    … …  
    261273            IF( cn_cfg == "orca" .OR. cn_cfg == "ORCA" ) THEN 
    262274               IF( nn_cfg == 3 ) THEN   ! ORCA2: Suppress ztilde in the Foxe Basin for ORCA2 
    263                   ii0 = 103   ;   ii1 = 111        
    264                   ij0 = 128   ;   ij1 = 135   ;    
     275                  ii0 = 103   ;   ii1 = 111 
     276                  ij0 = 128   ;   ij1 = 135   ; 
    265277                  frq_rst_e3t( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  0.0_wp 
    266278                  frq_rst_hdv( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  1.e0_wp / rn_Dt 
    … …  
    280292            CALL iom_set_rstw_var_active('tilde_e3t_n') 
    281293         END IF 
    282          !                                           ! -------------!     
     294         !                                           ! -------------! 
    283295         IF( ln_vvl_ztilde ) THEN                    ! z_tilde case ! 
    284296            !                                        ! ------------ ! 
    … …  
    291303 
    292304 
    293    SUBROUTINE dom_vvl_sf_nxt( kt, Kbb, Kmm, Kaa, kcall )  
     305   SUBROUTINE dom_vvl_sf_nxt( kt, Kbb, Kmm, Kaa, kcall ) 
    294306      !!---------------------------------------------------------------------- 
    295307      !!                ***  ROUTINE dom_vvl_sf_nxt  *** 
    296       !!                    
     308      !! 
    297309      !! ** Purpose :  - compute the after scale factors used in tra_zdf, dynnxt, 
    298310      !!                 tranxt and dynspg routines 
    299311      !! 
    300312      !! ** Method  :  - z_star case:  Repartition of ssh INCREMENT proportionnaly to the level thickness. 
    301       !!               - z_tilde_case: after scale factor increment =  
     313      !!               - z_tilde_case: after scale factor increment = 
    302314      !!                                    high frequency part of horizontal divergence 
    303315      !!                                  + retsoring towards the background grid 
    … …  
    307319      !! 
    308320      !! ** Action  :  - hdiv_lf    : restoring towards full baroclinic divergence in z_tilde case 
    309       !!               - tilde_e3t_a: after increment of vertical scale factor  
     321      !!               - tilde_e3t_a: after increment of vertical scale factor 
    310322      !!                              in z_tilde case 
    311323      !!               - e3(t/u/v)_a 
    … …  
    410422            un_td(ji,jj,jk) = rn_ahe3 * umask(ji,jj,jk) * e2_e1u(ji,jj)           & 
    411423               &            * ( tilde_e3t_b(ji,jj,jk) - tilde_e3t_b(ji+1,jj  ,jk) ) 
    412             vn_td(ji,jj,jk) = rn_ahe3 * vmask(ji,jj,jk) * e1_e2v(ji,jj)           &  
     424            vn_td(ji,jj,jk) = rn_ahe3 * vmask(ji,jj,jk) * e1_e2v(ji,jj)           & 
    413425               &            * ( tilde_e3t_b(ji,jj,jk) - tilde_e3t_b(ji  ,jj+1,jk) ) 
    414426            zwu(ji,jj) = zwu(ji,jj) + un_td(ji,jj,jk) 
    … …  
    460472               WRITE(numout, *) 'at i, j, k=', ijk_max 
    461473               WRITE(numout, *) 'MIN( tilde_e3t_a(:,:,:) / e3t_0(:,:,:) ) =', z_tmin 
    462                WRITE(numout, *) 'at i, j, k=', ijk_min             
     474               WRITE(numout, *) 'at i, j, k=', ijk_min 
    463475               CALL ctl_stop( 'STOP', 'MAX( ABS( tilde_e3t_a(:,:,: ) ) / e3t_0(:,:,:) ) too high') 
    464476            ENDIF 
    … …  
    575587      !!---------------------------------------------------------------------- 
    576588      !!                ***  ROUTINE dom_vvl_sf_update  *** 
    577       !!                    
    578       !! ** Purpose :  for z tilde case: compute time filter and swap of scale factors  
     589      !! 
     590      !! ** Purpose :  for z tilde case: compute time filter and swap of scale factors 
    579591      !!               compute all depths and related variables for next time step 
    580592      !!               write outputs and restart file 
    … …  
    586598      !! ** Action  :  - tilde_e3t_(b/n) ready for next time step 
    587599      !!               - Recompute: 
    588       !!                    e3(u/v)_b        
    589       !!                    e3w(:,:,:,Kmm)            
    590       !!                    e3(u/v)w_b       
    591       !!                    e3(u/v)w_n       
     600      !!                    e3(u/v)_b 
     601      !!                    e3w(:,:,:,Kmm) 
     602      !!                    e3(u/v)w_b 
     603      !!                    e3(u/v)w_n 
    592604      !!                    gdept(:,:,:,Kmm), gdepw(:,:,:,Kmm)  and gde3w 
    593605      !!                    h(u/v) and h(u/v)r 
    … …  
    620632            tilde_e3t_b(:,:,:) = tilde_e3t_n(:,:,:) 
    621633         ELSE 
    622             tilde_e3t_b(:,:,:) = tilde_e3t_n(:,:,:) &  
     634            tilde_e3t_b(:,:,:) = tilde_e3t_n(:,:,:) & 
    623635            &         + rn_atfp * ( tilde_e3t_b(:,:,:) - 2.0_wp * tilde_e3t_n(:,:,:) + tilde_e3t_a(:,:,:) ) 
    624636         ENDIF 
    … …  
    632644      ! - ML - e3u(:,:,:,Kbb) and e3v(:,:,:,Kbb) are already computed in dynnxt 
    633645      ! - JC - hu(:,:,:,Kbb), hv(:,:,:,:,Kbb), hur_b, hvr_b also 
    634        
     646 
    635647      CALL dom_vvl_interpol( e3u(:,:,:,Kmm), e3f(:,:,:), 'F'  ) 
    636        
     648 
    637649      ! Vertical scale factor interpolations 
    638650      CALL dom_vvl_interpol( e3t(:,:,:,Kmm),  e3w(:,:,:,Kmm), 'W'  ) 
    … …  
    653665         gdepw(ji,jj,jk,Kmm) = gdepw(ji,jj,jk-1,Kmm) + e3t(ji,jj,jk-1,Kmm) 
    654666         gdept(ji,jj,jk,Kmm) =    zcoef  * ( gdepw(ji,jj,jk  ,Kmm) + 0.5 * e3w(ji,jj,jk,Kmm) )  & 
    655              &             + (1-zcoef) * ( gdept(ji,jj,jk-1,Kmm) +       e3w(ji,jj,jk,Kmm) )  
     667             &             + (1-zcoef) * ( gdept(ji,jj,jk-1,Kmm) +       e3w(ji,jj,jk,Kmm) ) 
    656668         gde3w(ji,jj,jk) = gdept(ji,jj,jk,Kmm) - ssh(ji,jj,Kmm) 
    657669      END_3D 
    … …  
    772784      !!--------------------------------------------------------------------- 
    773785      !!                   ***  ROUTINE dom_vvl_rst  *** 
    774       !!                      
     786      !! 
    775787      !! ** Purpose :   Read or write VVL file in restart file 
    776788      !! 
    … …  
    789801      !!---------------------------------------------------------------------- 
    790802      ! 
    791       IF( TRIM(cdrw) == 'READ' ) THEN        ! Read/initialise  
     803      IF( TRIM(cdrw) == 'READ' ) THEN        ! Read/initialise 
    792804         !                                   ! =============== 
    793805         IF( ln_rstart ) THEN                   !* Read the restart file 
    … …  
    808820               CALL iom_get( numror, jpdom_autoglo, 'e3t_b', e3t(:,:,:,Kbb), ldxios = lrxios ) 
    809821               CALL iom_get( numror, jpdom_autoglo, 'e3t_n', e3t(:,:,:,Kmm), ldxios = lrxios ) 
    810                ! needed to restart if land processor not computed  
     822               ! needed to restart if land processor not computed 
    811823               IF(lwp) write(numout,*) 'dom_vvl_rst : e3t(:,:,:,Kbb) and e3t(:,:,:,Kmm) found in restart files' 
    812                WHERE ( tmask(:,:,:) == 0.0_wp )  
     824               WHERE ( tmask(:,:,:) == 0.0_wp ) 
    813825                  e3t(:,:,:,Kmm) = e3t_0(:,:,:) 
    814826                  e3t(:,:,:,Kbb) = e3t_0(:,:,:) 
    … …  
    873885            ! 
    874886 
    875             IF( ll_wd ) THEN   ! MJB ll_wd edits start here - these are essential  
     887            IF( ll_wd ) THEN   ! MJB ll_wd edits start here - these are essential 
    876888               ! 
    877889               IF( cn_cfg == 'wad' ) THEN 
    … …  
    908920                       CALL ctl_stop( 'dom_vvl_rst: ht_0 must be positive at potentially wet points' ) 
    909921                     ENDIF 
    910                   END DO  
    911                END DO  
     922                  END DO 
     923               END DO 
    912924               ! 
    913925            ELSE 
    … …  
    950962            CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_n', tilde_e3t_n(:,:,:), ldxios = lwxios) 
    951963         END IF 
    952          !                                           ! -------------!     
     964         !                                           ! -------------! 
    953965         IF( ln_vvl_ztilde ) THEN                    ! z_tilde case ! 
    954966            !                                        ! ------------ ! 
    … …  
    965977      !!--------------------------------------------------------------------- 
    966978      !!                  ***  ROUTINE dom_vvl_ctl  *** 
    967       !!                 
     979      !! 
    968980      !! ** Purpose :   Control the consistency between namelist options 
    969981      !!                for vertical coordinate 
    … …  
    974986         &              ln_vvl_zstar_at_eqtor      , rn_ahe3     , rn_rst_e3t            , & 
    975987         &              rn_lf_cutoff               , rn_zdef_max , ln_vvl_dbg                ! not yet implemented: ln_vvl_kepe 
    976       !!----------------------------------------------------------------------  
     988      !!---------------------------------------------------------------------- 
    977989      ! 
    978990      READ  ( numnam_ref, nam_vvl, IOSTAT = ios, ERR = 901) 
    … …  
    10311043   END SUBROUTINE dom_vvl_ctl 
    10321044 
     1045#endif 
     1046 
    10331047   !!====================================================================== 
    10341048END MODULE domvvl 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DOM/istate.F90

    r12489 r13151  
    4343   !! * Substitutions 
    4444#  include "do_loop_substitute.h90" 
     45#  include "domzgr_substitute.h90" 
    4546   !!---------------------------------------------------------------------- 
    4647   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    5960      ! 
    6061      INTEGER ::   ji, jj, jk   ! dummy loop indices 
     62      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zgdept     ! 3D table  !!st patch to use gdept subtitute 
    6163!!gm see comment further down 
    6264      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) ::   zuvd    ! U & V data workspace 
    … …  
    115117            ! 
    116118         ELSE                                 ! user defined initial T and S 
    117             CALL usr_def_istate( gdept(:,:,:,Kbb), tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb), ssh(:,:,Kbb)  )          
     119            DO jk = 1, jpk 
     120               zgdept(:,:,jk) = gdept(:,:,jk,Kbb) 
     121            END DO 
     122            CALL usr_def_istate( zgdept, tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb), ssh(:,:,Kbb)  )          
    118123         ENDIF 
    119124         ts  (:,:,:,:,Kmm) = ts (:,:,:,:,Kbb)       ! set now values from to before ones 
    … …  
    127132!!gm POTENTIAL BUG : 
    128133!!gm  ISSUE :  if ssh(:,:,Kbb) /= 0  then, in non linear free surface, the e3._n, e3._b should be recomputed 
    129 !!             as well as gdept and gdepw....   !!!!!  
     134!!             as well as gdept_ and gdepw_....   !!!!!  
    130135!!      ===>>>>   probably a call to domvvl initialisation here.... 
    131136 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DYN/divhor.F90

    r12377 r13151  
    2121   USE dom_oce         ! ocean space and time domain 
    2222   USE sbc_oce, ONLY : ln_rnf      ! river runoff 
    23    USE sbcrnf , ONLY : sbc_rnf_div ! river runoff  
     23   USE sbcrnf , ONLY : sbc_rnf_div ! river runoff 
    2424   USE isf_oce, ONLY : ln_isf      ! ice shelf 
    2525   USE isfhdiv, ONLY : isf_hdiv    ! ice shelf 
    26 #if defined key_asminc    
     26#if defined key_asminc 
    2727   USE asminc          ! Assimilation increment 
    2828#endif 
    … …  
    4040   !! * Substitutions 
    4141#  include "do_loop_substitute.h90" 
     42#  include "domzgr_substitute.h90" 
    4243   !!---------------------------------------------------------------------- 
    4344   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    44    !! $Id$  
     45   !! $Id$ 
    4546   !! Software governed by the CeCILL license (see ./LICENSE) 
    4647   !!---------------------------------------------------------------------- 
    … …  
    5051      !!---------------------------------------------------------------------- 
    5152      !!                  ***  ROUTINE div_hor  *** 
    52       !!                     
     53      !! 
    5354      !! ** Purpose :   compute the horizontal divergence at now time-step 
    5455      !! 
    5556      !! ** Method  :   the now divergence is computed as : 
    5657      !!         hdiv = 1/(e1e2t*e3t) ( di[e2u*e3u un] + dj[e1v*e3v vn] ) 
    57       !!      and correct with runoff inflow (div_rnf) and cross land flow (div_cla)  
     58      !!      and correct with runoff inflow (div_rnf) and cross land flow (div_cla) 
    5859      !! 
    5960      !! ** Action  : - update hdiv, the now horizontal divergence 
    … …  
    7879      DO_3D_00_00( 1, jpkm1 ) 
    7980         hdiv(ji,jj,jk) = (  e2u(ji  ,jj) * e3u(ji  ,jj,jk,Kmm) * uu(ji  ,jj,jk,Kmm)      & 
    80             &               - e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm) * uu(ji-1,jj,jk,Kmm)      & 
    81             &               + e1v(ji,jj  ) * e3v(ji,jj  ,jk,Kmm) * vv(ji,jj  ,jk,Kmm)      & 
    82             &               - e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) * vv(ji,jj-1,jk,Kmm)  )   & 
     81            &              - e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm) * uu(ji-1,jj,jk,Kmm)      & 
     82            &              + e1v(ji,jj  ) * e3v(ji,jj  ,jk,Kmm) * vv(ji,jj  ,jk,Kmm)      & 
     83            &              - e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) * vv(ji,jj-1,jk,Kmm)  )   & 
    8384            &            * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
    8485      END_3D 
    … …  
    9596      IF( ln_rnf )   CALL sbc_rnf_div( hdiv, Kmm )                     !==  runoffs    ==!   (update hdiv field) 
    9697      ! 
    97 #if defined key_asminc  
     98#if defined key_asminc 
    9899      IF( ln_sshinc .AND. ln_asmiau )   CALL ssh_asm_div( kt, Kbb, Kmm, hdiv )   !==  SSH assimilation  ==!   (update hdiv field) 
    99       !  
     100      ! 
    100101#endif 
    101102      ! 
    … …  
    107108      ! 
    108109   END SUBROUTINE div_hor 
    109     
     110 
    110111   !!====================================================================== 
    111112END MODULE divhor 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DYN/dynadv_cen2.F90

    r12377 r13151  
    2828   !! * Substitutions 
    2929#  include "do_loop_substitute.h90" 
     30#  include "domzgr_substitute.h90" 
    3031   !!---------------------------------------------------------------------- 
    3132   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    7980         DO_2D_00_00 
    8081            puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - (  zfu_t(ji+1,jj,jk) - zfu_t(ji,jj  ,jk)    & 
    81                &                           + zfv_f(ji  ,jj,jk) - zfv_f(ji,jj-1,jk)  ) * r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm) 
     82               &                           + zfv_f(ji  ,jj,jk) - zfv_f(ji,jj-1,jk)  ) * r1_e1e2u(ji,jj)   & 
     83               &                           / e3u(ji,jj,jk,Kmm) 
    8284            pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - (  zfu_f(ji,jj  ,jk) - zfu_f(ji-1,jj,jk)    & 
    83                &                           + zfv_t(ji,jj+1,jk) - zfv_t(ji  ,jj,jk)  ) * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm) 
     85               &                           + zfv_t(ji,jj+1,jk) - zfv_t(ji  ,jj,jk)  ) * r1_e1e2v(ji,jj)   & 
     86               &                           / e3v(ji,jj,jk,Kmm) 
    8487         END_2D 
    8588      END DO 
    … …  
    115118      END DO 
    116119      DO_3D_00_00( 1, jpkm1 ) 
    117          puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zfu_uw(ji,jj,jk) - zfu_uw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm) 
    118          pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( zfv_vw(ji,jj,jk) - zfv_vw(ji,jj,jk+1) ) * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm) 
     120         puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zfu_uw(ji,jj,jk) - zfu_uw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj)   & 
     121            &                                      / e3u(ji,jj,jk,Kmm) 
     122         pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( zfv_vw(ji,jj,jk) - zfv_vw(ji,jj,jk+1) ) * r1_e1e2v(ji,jj)   & 
     123            &                                      / e3v(ji,jj,jk,Kmm) 
    119124      END_3D 
    120125      ! 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DYN/dynadv_ubs.F90

    r12377 r13151  
    3434   !! * Substitutions 
    3535#  include "do_loop_substitute.h90" 
     36#  include "domzgr_substitute.h90" 
    3637   !!---------------------------------------------------------------------- 
    3738   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    169170         DO_2D_00_00 
    170171            puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - (  zfu_t(ji+1,jj,jk) - zfu_t(ji,jj  ,jk)    & 
    171                &                           + zfv_f(ji  ,jj,jk) - zfv_f(ji,jj-1,jk)  ) * r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm) 
     172               &                           + zfv_f(ji  ,jj,jk) - zfv_f(ji,jj-1,jk)  ) * r1_e1e2u(ji,jj)   & 
     173               &                           / e3u(ji,jj,jk,Kmm) 
    172174            pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - (  zfu_f(ji,jj  ,jk) - zfu_f(ji-1,jj,jk)    & 
    173                &                           + zfv_t(ji,jj+1,jk) - zfv_t(ji  ,jj,jk)  ) * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm) 
     175               &                           + zfv_t(ji,jj+1,jk) - zfv_t(ji  ,jj,jk)  ) * r1_e1e2v(ji,jj)   & 
     176               &                           / e3v(ji,jj,jk,Kmm) 
    174177         END_2D 
    175178      END DO 
    … …  
    206209      END DO 
    207210      DO_3D_00_00( 1, jpkm1 ) 
    208          puu(ji,jj,jk,Krhs) =  puu(ji,jj,jk,Krhs) - ( zfu_uw(ji,jj,jk) - zfu_uw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm) 
    209          pvv(ji,jj,jk,Krhs) =  pvv(ji,jj,jk,Krhs) - ( zfv_vw(ji,jj,jk) - zfv_vw(ji,jj,jk+1) ) * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm) 
     211         puu(ji,jj,jk,Krhs) =  puu(ji,jj,jk,Krhs) - ( zfu_uw(ji,jj,jk) - zfu_uw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj)   & 
     212            &                                       / e3u(ji,jj,jk,Kmm) 
     213         pvv(ji,jj,jk,Krhs) =  pvv(ji,jj,jk,Krhs) - ( zfv_vw(ji,jj,jk) - zfv_vw(ji,jj,jk+1) ) * r1_e1e2v(ji,jj)   & 
     214            &                                       / e3v(ji,jj,jk,Kmm) 
    210215      END_3D 
    211216      ! 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DYN/dynatf.F90

    r12489 r13151  
    1313   !!             -   !  2002-10  (C. Talandier, A-M. Treguier) Open boundary cond. 
    1414   !!            2.0  !  2005-11  (V. Garnier) Surface pressure gradient organization 
    15    !!            2.3  !  2007-07  (D. Storkey) Calls to BDY routines.  
     15   !!            2.3  !  2007-07  (D. Storkey) Calls to BDY routines. 
    1616   !!            3.2  !  2009-06  (G. Madec, R.Benshila)  re-introduce the vvl option 
    1717   !!            3.3  !  2010-09  (D. Storkey, E.O'Dea) Bug fix for BDY module 
    … …  
    2222   !!            4.1  !  2019-08  (A. Coward, D. Storkey) Rename dynnxt.F90 -> dynatf.F90. Now just does time filtering. 
    2323   !!------------------------------------------------------------------------- 
    24    
     24 
    2525   !!---------------------------------------------------------------------------------------------- 
    2626   !!   dyn_atf       : apply Asselin time filtering to "now" velocities and vertical scale factors 
    … …  
    4242   USE trdken         ! trend manager: kinetic energy 
    4343   USE isf_oce   , ONLY: ln_isf     ! ice shelf 
    44    USE isfdynatf , ONLY: isf_dynatf ! ice shelf volume filter correction subroutine  
     44   USE isfdynatf , ONLY: isf_dynatf ! ice shelf volume filter correction subroutine 
    4545   ! 
    4646   USE in_out_manager ! I/O manager 
    … …  
    5959   PUBLIC    dyn_atf   ! routine called by step.F90 
    6060 
     61#if defined key_qco 
     62   !!---------------------------------------------------------------------- 
     63   !!   'key_qco'      EMPTY ROUTINE     Quasi-Eulerian vertical coordonate 
     64   !!---------------------------------------------------------------------- 
     65CONTAINS 
     66 
     67   SUBROUTINE dyn_atf ( kt, Kbb, Kmm, Kaa, puu, pvv, pe3t, pe3u, pe3v ) 
     68      INTEGER                             , INTENT(in   ) :: kt               ! ocean time-step index 
     69      INTEGER                             , INTENT(in   ) :: Kbb, Kmm, Kaa    ! before and after time level indices 
     70      REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv         ! velocities to be time filtered 
     71      REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: pe3t, pe3u, pe3v ! scale factors to be time filtered 
     72 
     73      WRITE(*,*) 'dyn_atf: You should not have seen this print! error?', kt 
     74   END SUBROUTINE dyn_atf 
     75 
     76#else 
     77 
    6178   !! * Substitutions 
    6279#  include "do_loop_substitute.h90" 
    6380   !!---------------------------------------------------------------------- 
    6481   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    65    !! $Id$  
     82   !! $Id$ 
    6683   !! Software governed by the CeCILL license (see ./LICENSE) 
    6784   !!---------------------------------------------------------------------- 
    … …  
    7188      !!---------------------------------------------------------------------- 
    7289      !!                  ***  ROUTINE dyn_atf  *** 
    73       !!                    
    74       !! ** Purpose :   Finalize after horizontal velocity. Apply the boundary  
     90      !! 
     91      !! ** Purpose :   Finalize after horizontal velocity. Apply the boundary 
    7592      !!             condition on the after velocity and apply the Asselin time 
    7693      !!             filter to the now fields. 
    … …  
    7996      !!             estimate (ln_dynspg_ts=T) 
    8097      !! 
    81       !!              * Apply lateral boundary conditions on after velocity  
     98      !!              * Apply lateral boundary conditions on after velocity 
    8299      !!             at the local domain boundaries through lbc_lnk call, 
    83100      !!             at the one-way open boundaries (ln_bdy=T), 
    … …  
    86103      !!              * Apply the Asselin time filter to the now fields 
    87104      !!             arrays to start the next time step: 
    88       !!                (puu(Kmm),pvv(Kmm)) = (puu(Kmm),pvv(Kmm))  
     105      !!                (puu(Kmm),pvv(Kmm)) = (puu(Kmm),pvv(Kmm)) 
    89106      !!                                    + rn_atfp [ (puu(Kbb),pvv(Kbb)) + (puu(Kaa),pvv(Kaa)) - 2 (puu(Kmm),pvv(Kmm)) ] 
    90107      !!             Note that with flux form advection and non linear free surface, 
    … …  
    92109      !!             As a result, dyn_atf MUST be called after tra_atf. 
    93110      !! 
    94       !! ** Action :   puu(Kmm),pvv(Kmm)   filtered now horizontal velocity  
     111      !! ** Action :   puu(Kmm),pvv(Kmm)   filtered now horizontal velocity 
    95112      !!---------------------------------------------------------------------- 
    96113      INTEGER                             , INTENT(in   ) :: kt               ! ocean time-step index 
    … …  
    103120      REAL(wp) ::   zve3a, zve3n, zve3b, z1_2dt   !   -      - 
    104121      REAL(wp), ALLOCATABLE, DIMENSION(:,:)   ::   zue, zve, zwfld 
    105       REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   ze3t_f, ze3u_f, ze3v_f, zua, zva  
     122      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   ze3t_f, ze3u_f, ze3v_f, zua, zva 
    106123      !!---------------------------------------------------------------------- 
    107124      ! 
    … …  
    131148         ! 
    132149         IF( .NOT.ln_bt_fw ) THEN 
    133             ! Remove advective velocity from "now velocities"  
    134             ! prior to asselin filtering      
    135             ! In the forward case, this is done below after asselin filtering    
    136             ! so that asselin contribution is removed at the same time  
     150            ! Remove advective velocity from "now velocities" 
     151            ! prior to asselin filtering 
     152            ! In the forward case, this is done below after asselin filtering 
     153            ! so that asselin contribution is removed at the same time 
    137154            DO jk = 1, jpkm1 
    138155               puu(:,:,jk,Kmm) = ( puu(:,:,jk,Kmm) - un_adv(:,:)*r1_hu(:,:,Kmm) + uu_b(:,:,Kmm) )*umask(:,:,jk) 
    139156               pvv(:,:,jk,Kmm) = ( pvv(:,:,jk,Kmm) - vn_adv(:,:)*r1_hv(:,:,Kmm) + vv_b(:,:,Kmm) )*vmask(:,:,jk) 
    140             END DO   
     157            END DO 
    141158         ENDIF 
    142159      ENDIF 
    143160 
    144161      ! Update after velocity on domain lateral boundaries 
    145       ! --------------------------------------------------       
     162      ! -------------------------------------------------- 
    146163# if defined key_agrif 
    147164      CALL Agrif_dyn( kt )             !* AGRIF zoom boundaries 
    … …  
    198215            zwfld(:,:) = emp_b(:,:) - emp(:,:) 
    199216            IF ( ln_rnf ) zwfld(:,:) =  zwfld(:,:) - ( rnf_b(:,:) - rnf(:,:) ) 
     217 
    200218            DO jk = 1, jpkm1 
    201219               ze3t_f(:,:,jk) = ze3t_f(:,:,jk) - zcoef * zwfld(:,:) * tmask(:,:,jk) & 
    202                               &                        * pe3t(:,:,jk,Kmm) / ( ht(:,:) + 1._wp - ssmask(:,:) )  
     220                              &                        * pe3t(:,:,jk,Kmm) / ( ht(:,:) + 1._wp - ssmask(:,:) ) 
    203221            END DO 
    204222            ! 
    … …  
    237255                  pvv(ji,jj,jk,Kmm) = ( zve3n + rn_atfp * ( zve3b - 2._wp * zve3n  + zve3a ) ) / ze3v_f(ji,jj,jk) 
    238256               END_3D 
    239                pe3u(:,:,1:jpkm1,Kmm) = ze3u_f(:,:,1:jpkm1)   
     257               pe3u(:,:,1:jpkm1,Kmm) = ze3u_f(:,:,1:jpkm1) 
    240258               pe3v(:,:,1:jpkm1,Kmm) = ze3v_f(:,:,1:jpkm1) 
    241259               ! 
    … …  
    248266         IF( ln_dynspg_ts .AND. ln_bt_fw ) THEN 
    249267            ! Revert filtered "now" velocities to time split estimate 
    250             ! Doing it here also means that asselin filter contribution is removed   
     268            ! Doing it here also means that asselin filter contribution is removed 
    251269            zue(:,:) = pe3u(:,:,1,Kmm) * puu(:,:,1,Kmm) * umask(:,:,1) 
    252             zve(:,:) = pe3v(:,:,1,Kmm) * pvv(:,:,1,Kmm) * vmask(:,:,1)     
     270            zve(:,:) = pe3v(:,:,1,Kmm) * pvv(:,:,1,Kmm) * vmask(:,:,1) 
    253271            DO jk = 2, jpkm1 
    254272               zue(:,:) = zue(:,:) + pe3u(:,:,jk,Kmm) * puu(:,:,jk,Kmm) * umask(:,:,jk) 
    255                zve(:,:) = zve(:,:) + pe3v(:,:,jk,Kmm) * pvv(:,:,jk,Kmm) * vmask(:,:,jk)     
     273               zve(:,:) = zve(:,:) + pe3v(:,:,jk,Kmm) * pvv(:,:,jk,Kmm) * vmask(:,:,jk) 
    256274            END DO 
    257275            DO jk = 1, jpkm1 
    … …  
    305323      IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab3d_1=puu(:,:,:,Kaa), clinfo1=' nxt  - puu(:,:,:,Kaa): ', mask1=umask,   & 
    306324         &                                  tab3d_2=pvv(:,:,:,Kaa), clinfo2=' pvv(:,:,:,Kaa): '       , mask2=vmask ) 
    307       !  
     325      ! 
    308326      IF( ln_dynspg_ts )   DEALLOCATE( zue, zve ) 
    309327      IF( l_trddyn     )   DEALLOCATE( zua, zva ) 
    … …  
    312330   END SUBROUTINE dyn_atf 
    313331 
     332#endif 
     333 
    314334   !!========================================================================= 
    315335END MODULE dynatf 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DYN/dynhpg.F90

    r12377 r13151  
    4343   USE in_out_manager  ! I/O manager 
    4444   USE prtctl          ! Print control 
    45    USE lbclnk          ! lateral boundary condition  
     45   USE lbclnk          ! lateral boundary condition 
    4646   USE lib_mpp         ! MPP library 
    4747   USE eosbn2          ! compute density 
    … …  
    7676   !! * Substitutions 
    7777#  include "do_loop_substitute.h90" 
     78#  include "domzgr_substitute.h90" 
     79 
    7880   !!---------------------------------------------------------------------- 
    7981   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    204206      ! 
    205207      IF( ioptio /= 1 )   CALL ctl_stop( 'NO or several hydrostatic pressure gradient options used' ) 
    206       !  
     208      ! 
    207209      IF(lwp) THEN 
    208210         WRITE(numout,*) 
    … …  
    217219         WRITE(numout,*) 
    218220      ENDIF 
    219       !                           
     221      ! 
    220222   END SUBROUTINE dyn_hpg_init 
    221223 
    … …  
    427429            zcpx(ji,jj) = 0._wp 
    428430          END IF 
    429     
     431 
    430432          ll_tmp1 = MIN(  ssh(ji,jj,Kmm)              ,  ssh(ji,jj+1,Kmm) ) >                & 
    431433               &    MAX( -ht_0(ji,jj)              , -ht_0(ji,jj+1) ) .AND.            & 
    … …  
    452454      DO_2D_00_00 
    453455         ! hydrostatic pressure gradient along s-surfaces 
    454          zhpi(ji,jj,1) = zcoef0 * (  e3w(ji+1,jj  ,1,Kmm) * ( znad + rhd(ji+1,jj  ,1) )    & 
    455             &                      - e3w(ji  ,jj  ,1,Kmm) * ( znad + rhd(ji  ,jj  ,1) )  ) * r1_e1u(ji,jj) 
    456          zhpj(ji,jj,1) = zcoef0 * (  e3w(ji  ,jj+1,1,Kmm) * ( znad + rhd(ji  ,jj+1,1) )    & 
    457             &                      - e3w(ji  ,jj  ,1,Kmm) * ( znad + rhd(ji  ,jj  ,1) )  ) * r1_e2v(ji,jj) 
     456         zhpi(ji,jj,1) =   & 
     457            &  zcoef0 * (  e3w(ji+1,jj  ,1,Kmm) * ( znad + rhd(ji+1,jj  ,1) )    & 
     458            &            - e3w(ji  ,jj  ,1,Kmm) * ( znad + rhd(ji  ,jj  ,1) )  ) & 
     459            &           * r1_e1u(ji,jj) 
     460         zhpj(ji,jj,1) =   & 
     461            &  zcoef0 * (  e3w(ji  ,jj+1,1,Kmm) * ( znad + rhd(ji  ,jj+1,1) )    & 
     462            &            - e3w(ji  ,jj  ,1,Kmm) * ( znad + rhd(ji  ,jj  ,1) )  ) & 
     463            &           * r1_e2v(ji,jj) 
    458464         ! s-coordinate pressure gradient correction 
    459465         zuap = -zcoef0 * ( rhd    (ji+1,jj,1) + rhd    (ji,jj,1) + 2._wp * znad )   & 
    … …  
    464470         IF( ln_wd_il ) THEN 
    465471            zhpi(ji,jj,1) = zhpi(ji,jj,1) * zcpx(ji,jj) 
    466             zhpj(ji,jj,1) = zhpj(ji,jj,1) * zcpy(ji,jj)  
     472            zhpj(ji,jj,1) = zhpj(ji,jj,1) * zcpy(ji,jj) 
    467473            zuap = zuap * zcpx(ji,jj) 
    468474            zvap = zvap * zcpy(ji,jj) 
    … …  
    478484         ! hydrostatic pressure gradient along s-surfaces 
    479485         zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1) + zcoef0 * r1_e1u(ji,jj)   & 
    480             &           * (  e3w(ji+1,jj,jk,Kmm) * ( rhd(ji+1,jj,jk) + rhd(ji+1,jj,jk-1) + 2*znad )   & 
    481             &              - e3w(ji  ,jj,jk,Kmm) * ( rhd(ji  ,jj,jk) + rhd(ji  ,jj,jk-1) + 2*znad )  ) 
     486            &    * (  e3w(ji+1,jj,jk,Kmm) * ( rhd(ji+1,jj,jk) + rhd(ji+1,jj,jk-1) + 2*znad )  & 
     487            &       - e3w(ji  ,jj,jk,Kmm) * ( rhd(ji  ,jj,jk) + rhd(ji  ,jj,jk-1) + 2*znad )  ) 
    482488         zhpj(ji,jj,jk) = zhpj(ji,jj,jk-1) + zcoef0 * r1_e2v(ji,jj)   & 
    483             &           * (  e3w(ji,jj+1,jk,Kmm) * ( rhd(ji,jj+1,jk) + rhd(ji,jj+1,jk-1) + 2*znad )   & 
    484             &              - e3w(ji,jj  ,jk,Kmm) * ( rhd(ji,jj,  jk) + rhd(ji,jj  ,jk-1) + 2*znad )  ) 
     489            &    * (  e3w(ji,jj+1,jk,Kmm) * ( rhd(ji,jj+1,jk) + rhd(ji,jj+1,jk-1) + 2*znad )   & 
     490            &       - e3w(ji,jj  ,jk,Kmm) * ( rhd(ji,jj,  jk) + rhd(ji,jj  ,jk-1) + 2*znad )  ) 
    485491         ! s-coordinate pressure gradient correction 
    486492         zuap = -zcoef0 * ( rhd    (ji+1,jj  ,jk) + rhd    (ji,jj,jk) + 2._wp * znad )   & 
    … …  
    491497         IF( ln_wd_il ) THEN 
    492498            zhpi(ji,jj,jk) = zhpi(ji,jj,jk) * zcpx(ji,jj) 
    493             zhpj(ji,jj,jk) = zhpj(ji,jj,jk) * zcpy(ji,jj)  
     499            zhpj(ji,jj,jk) = zhpj(ji,jj,jk) * zcpy(ji,jj) 
    494500            zuap = zuap * zcpx(ji,jj) 
    495501            zvap = zvap * zcpy(ji,jj) 
    … …  
    522528      !!         pvv(:,:,:,Krhs) = pvv(:,:,:,Krhs) - 1/e2v * zhpj 
    523529      !!      iceload is added 
    524       !!       
     530      !! 
    525531      !! ** Action : - Update (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) with the now hydrastatic pressure trend 
    526532      !!---------------------------------------------------------------------- 
    … …  
    540546      znad=1._wp                 ! To use density and not density anomaly 
    541547      ! 
    542       !                          ! iniitialised to 0. zhpi zhpi  
     548      !                          ! iniitialised to 0. zhpi zhpi 
    543549      zhpi(:,:,:) = 0._wp   ;   zhpj(:,:,:) = 0._wp 
    544550 
    … …  
    554560      CALL eos( zts_top, risfdep, zrhdtop_oce ) 
    555561 
    556 !==================================================================================      
    557 !===== Compute surface value =====================================================  
     562!================================================================================== 
     563!===== Compute surface value ===================================================== 
    558564!================================================================================== 
    559565      DO_2D_00_00 
    … …  
    567573            &                                  - 0.5_wp * e3w(ji,jj,ikt,Kmm)                                         & 
    568574            &                                    * ( 2._wp * znad + rhd(ji,jj,ikt) + zrhdtop_oce(ji,jj) )          & 
    569             &                                  + ( risfload(ji+1,jj) - risfload(ji,jj))                            )  
     575            &                                  + ( risfload(ji+1,jj) - risfload(ji,jj))                            ) 
    570576         zhpj(ji,jj,1) = zcoef0 / e2v(ji,jj) * ( 0.5_wp * e3w(ji,jj+1,iktp1j,Kmm)                                    & 
    571577            &                                    * ( 2._wp * znad + rhd(ji,jj+1,iktp1j) + zrhdtop_oce(ji,jj+1) )   & 
    572             &                                  - 0.5_wp * e3w(ji,jj,ikt,Kmm)                                         &  
     578            &                                  - 0.5_wp * e3w(ji,jj,ikt,Kmm)                                         & 
    573579            &                                    * ( 2._wp * znad + rhd(ji,jj,ikt) + zrhdtop_oce(ji,jj) )          & 
    574             &                                  + ( risfload(ji,jj+1) - risfload(ji,jj))                            )  
     580            &                                  + ( risfload(ji,jj+1) - risfload(ji,jj))                            ) 
    575581         ! s-coordinate pressure gradient correction (=0 if z coordinate) 
    576582         zuap = -zcoef0 * ( rhd    (ji+1,jj,1) + rhd    (ji,jj,1) + 2._wp * znad )   & 
    … …  
    582588         pvv(ji,jj,1,Krhs) = pvv(ji,jj,1,Krhs) + (zhpj(ji,jj,1) + zvap) * vmask(ji,jj,1) 
    583589      END_2D 
    584 !==================================================================================      
    585 !===== Compute interior value =====================================================  
     590!================================================================================== 
     591!===== Compute interior value ===================================================== 
    586592!================================================================================== 
    587593      ! interior value (2=<jk=<jpkm1) 
    … …  
    589595         ! hydrostatic pressure gradient along s-surfaces 
    590596         zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1) + zcoef0 / e1u(ji,jj)   & 
    591             &           * (  e3w(ji+1,jj,jk,Kmm) * ( rhd(ji+1,jj,jk) + rhd(ji+1,jj,jk-1) + 2*znad ) * wmask(ji+1,jj,jk)   & 
    592             &              - e3w(ji  ,jj,jk,Kmm) * ( rhd(ji  ,jj,jk) + rhd(ji  ,jj,jk-1) + 2*znad ) * wmask(ji  ,jj,jk)   ) 
     597            &           * (  e3w(ji+1,jj,jk,Kmm)                   & 
     598            &                  * ( rhd(ji+1,jj,jk) + rhd(ji+1,jj,jk-1) + 2*znad ) * wmask(ji+1,jj,jk)   & 
     599            &              - e3w(ji  ,jj,jk,Kmm)                   & 
     600            &                  * ( rhd(ji  ,jj,jk) + rhd(ji  ,jj,jk-1) + 2*znad ) * wmask(ji  ,jj,jk)   ) 
    593601         zhpj(ji,jj,jk) = zhpj(ji,jj,jk-1) + zcoef0 / e2v(ji,jj)   & 
    594             &           * (  e3w(ji,jj+1,jk,Kmm) * ( rhd(ji,jj+1,jk) + rhd(ji,jj+1,jk-1) + 2*znad ) * wmask(ji,jj+1,jk)   & 
    595             &              - e3w(ji,jj  ,jk,Kmm) * ( rhd(ji,jj,  jk) + rhd(ji,jj  ,jk-1) + 2*znad ) * wmask(ji,jj  ,jk)   ) 
     602            &           * (  e3w(ji,jj+1,jk,Kmm)                   & 
     603            &                  * ( rhd(ji,jj+1,jk) + rhd(ji,jj+1,jk-1) + 2*znad ) * wmask(ji,jj+1,jk)   & 
     604            &              - e3w(ji,jj  ,jk,Kmm)                   & 
     605            &                  * ( rhd(ji,jj,  jk) + rhd(ji,jj  ,jk-1) + 2*znad ) * wmask(ji,jj  ,jk)   ) 
    596606         ! s-coordinate pressure gradient correction 
    597607         zuap = -zcoef0 * ( rhd   (ji+1,jj  ,jk) + rhd   (ji,jj,jk) + 2._wp * znad )   & 
    … …  
    650660            zcpx(ji,jj) = 0._wp 
    651661          END IF 
    652     
     662 
    653663          ll_tmp1 = MIN(  ssh(ji,jj,Kmm)              ,  ssh(ji,jj+1,Kmm) ) >                & 
    654664               &    MAX( -ht_0(ji,jj)              , -ht_0(ji,jj+1) ) .AND.            & 
    … …  
    771781      !------------------------------------------------------------- 
    772782 
    773 !!bug gm   :  e3w-gde3w = 0.5*e3w  ....  and gde3w(2)-gde3w(1)=e3w(2) ....   to be verified 
    774 !          true if gde3w is really defined as the sum of the e3w scale factors as, it seems to me, it should be 
     783!!bug gm   :  e3w-gde3w(:,:,:) = 0.5*e3w  ....  and gde3w(:,:,2)-gde3w(:,:,1)=e3w(:,:,2,Kmm) ....   to be verified 
     784!          true if gde3w(:,:,:) is really defined as the sum of the e3w scale factors as, it seems to me, it should be 
    775785 
    776786      DO_2D_00_00 
    … …  
    825835         IF( ln_wd_il ) THEN 
    826836           zhpi(ji,jj,1) = zhpi(ji,jj,1) * zcpx(ji,jj) 
    827            zhpj(ji,jj,1) = zhpj(ji,jj,1) * zcpy(ji,jj)  
     837           zhpj(ji,jj,1) = zhpj(ji,jj,1) * zcpy(ji,jj) 
    828838         ENDIF 
    829839         ! add to the general momentum trend 
    … …  
    845855         IF( ln_wd_il ) THEN 
    846856           zhpi(ji,jj,jk) = zhpi(ji,jj,jk) * zcpx(ji,jj) 
    847            zhpj(ji,jj,jk) = zhpj(ji,jj,jk) * zcpy(ji,jj)  
     857           zhpj(ji,jj,jk) = zhpj(ji,jj,jk) * zcpy(ji,jj) 
    848858         ENDIF 
    849859         ! add to the general momentum trend 
    … …  
    916926            zcpx(ji,jj) = ABS( (ssh(ji+1,jj,Kmm) + ht_0(ji+1,jj) - ssh(ji,jj,Kmm) - ht_0(ji,jj)) & 
    917927                        &    / (ssh(ji+1,jj,Kmm) -  ssh(ji  ,jj,Kmm)) ) 
    918             
     928 
    919929             zcpx(ji,jj) = max(min( zcpx(ji,jj) , 1.0_wp),0.0_wp) 
    920930          ELSE 
    921931            zcpx(ji,jj) = 0._wp 
    922932          END IF 
    923     
     933 
    924934          ll_tmp1 = MIN(  ssh(ji,jj,Kmm)              ,  ssh(ji,jj+1,Kmm) ) >                & 
    925935               &    MAX( -ht_0(ji,jj)              , -ht_0(ji,jj+1) ) .AND.            & 
    … …  
    10021012!!gm BUG ?    if it is ssh at u- & v-point then it should be: 
    10031013!          zsshu_n(ji,jj) = (e1e2t(ji,jj) * ssh(ji,jj,Kmm) + e1e2t(ji+1,jj) * ssh(ji+1,jj,Kmm)) * & 
    1004 !                         & r1_e1e2u(ji,jj) * umask(ji,jj,1) * 0.5_wp  
     1014!                         & r1_e1e2u(ji,jj) * umask(ji,jj,1) * 0.5_wp 
    10051015!          zsshv_n(ji,jj) = (e1e2t(ji,jj) * ssh(ji,jj,Kmm) + e1e2t(ji,jj+1) * ssh(ji,jj+1,Kmm)) * & 
    1006 !                         & r1_e1e2v(ji,jj) * vmask(ji,jj,1) * 0.5_wp  
     1016!                         & r1_e1e2v(ji,jj) * vmask(ji,jj,1) * 0.5_wp 
    10071017!!gm not this: 
    10081018       zsshu_n(ji,jj) = (e1e2u(ji,jj) * ssh(ji,jj,Kmm) + e1e2u(ji+1, jj) * ssh(ji+1,jj,Kmm)) * & 
    1009                       & r1_e1e2u(ji,jj) * umask(ji,jj,1) * 0.5_wp  
     1019                      & r1_e1e2u(ji,jj) * umask(ji,jj,1) * 0.5_wp 
    10101020       zsshv_n(ji,jj) = (e1e2v(ji,jj) * ssh(ji,jj,Kmm) + e1e2v(ji+1, jj) * ssh(ji,jj+1,Kmm)) * & 
    1011                       & r1_e1e2v(ji,jj) * vmask(ji,jj,1) * 0.5_wp  
     1021                      & r1_e1e2v(ji,jj) * vmask(ji,jj,1) * 0.5_wp 
    10121022      END_2D 
    10131023 
    … …  
    10151025 
    10161026      DO_2D_00_00 
    1017        zu(ji,jj,1) = - ( e3u(ji,jj,1,Kmm) - zsshu_n(ji,jj) * znad)  
     1027       zu(ji,jj,1) = - ( e3u(ji,jj,1,Kmm) - zsshu_n(ji,jj) * znad) 
    10181028       zv(ji,jj,1) = - ( e3v(ji,jj,1,Kmm) - zsshv_n(ji,jj) * znad) 
    10191029      END_2D 
    … …  
    10981108            zdpdx2 = zdpdx2 * zcpx(ji,jj) * wdrampu(ji,jj) 
    10991109         ENDIF 
    1100          puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + (zdpdx1 + zdpdx2) * umask(ji,jj,jk)  
     1110         puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + (zdpdx1 + zdpdx2) * umask(ji,jj,jk) 
    11011111      ENDIF 
    11021112 
    … …  
    11541164         ENDIF 
    11551165         IF( ln_wd_il ) THEN 
    1156             zdpdy1 = zdpdy1 * zcpy(ji,jj) * wdrampv(ji,jj)  
    1157             zdpdy2 = zdpdy2 * zcpy(ji,jj) * wdrampv(ji,jj)  
     1166            zdpdy1 = zdpdy1 * zcpy(ji,jj) * wdrampv(ji,jj) 
     1167            zdpdy2 = zdpdy2 * zcpy(ji,jj) * wdrampv(ji,jj) 
    11581168         ENDIF 
    11591169 
    … …  
    11891199      !!---------------------------------------------------------------------- 
    11901200      ! 
    1191 !!gm  WHAT !!!!!   THIS IS VERY DANGEROUS !!!!!   
     1201!!gm  WHAT !!!!!   THIS IS VERY DANGEROUS !!!!! 
    11921202      jpi   = size(fsp,1) 
    11931203      jpj   = size(fsp,2) 
    … …  
    13591369   !!====================================================================== 
    13601370END MODULE dynhpg 
    1361  

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DYN/dynldf_iso.F90

    r12377 r13151  
    2222   USE ldftra          ! lateral physics: eddy diffusivity 
    2323   USE zdf_oce         ! ocean vertical physics 
    24    USE ldfslp          ! iso-neutral slopes  
     24   USE ldfslp          ! iso-neutral slopes 
    2525   ! 
    2626   USE in_out_manager  ! I/O manager 
    … …  
    3636 
    3737   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   akzu, akzv   !: vertical component of rotated lateral viscosity 
    38     
    39    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zfuw, zdiu, zdju, zdj1u   ! 2D workspace (dyn_ldf_iso)  
     38 
     39   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zfuw, zdiu, zdju, zdj1u   ! 2D workspace (dyn_ldf_iso) 
    4040   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zfvw, zdiv, zdjv, zdj1v   !  -      - 
    4141 
    4242   !! * Substitutions 
    4343#  include "do_loop_substitute.h90" 
     44#  include "domzgr_substitute.h90" 
    4445   !!---------------------------------------------------------------------- 
    4546   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    5354      !!                  ***  ROUTINE dyn_ldf_iso_alloc  *** 
    5455      !!---------------------------------------------------------------------- 
    55       ALLOCATE( akzu(jpi,jpj,jpk) , zfuw(jpi,jpk) , zdiu(jpi,jpk) , zdju(jpi,jpk) , zdj1u(jpi,jpk) ,     &  
     56      ALLOCATE( akzu(jpi,jpj,jpk) , zfuw(jpi,jpk) , zdiu(jpi,jpk) , zdju(jpi,jpk) , zdj1u(jpi,jpk) ,     & 
    5657         &      akzv(jpi,jpj,jpk) , zfvw(jpi,jpk) , zdiv(jpi,jpk) , zdjv(jpi,jpk) , zdj1v(jpi,jpk) , STAT=dyn_ldf_iso_alloc ) 
    5758         ! 
    … …  
    6364      !!---------------------------------------------------------------------- 
    6465      !!                     ***  ROUTINE dyn_ldf_iso  *** 
    65       !!                        
     66      !! 
    6667      !! ** Purpose :   Compute the before trend of the rotated laplacian 
    6768      !!      operator of lateral momentum diffusion except the diagonal 
    … …  
    137138         ! 
    138139       ENDIF 
    139           
     140 
    140141      zaht_0 = 0.5_wp * rn_Ud * rn_Ld                  ! aht_0 from namtra_ldf = zaht_max 
    141        
     142 
    142143      !                                                ! =============== 
    143144      DO jk = 1, jpkm1                                 ! Horizontal slab 
    … …  
    161162 
    162163         !                               -----f----- 
    163          ! Horizontal fluxes on U             |   
     164         ! Horizontal fluxes on U             | 
    164165         ! --------------------===        t   u   t 
    165          !                                    |   
     166         !                                    | 
    166167         ! i-flux at t-point             -----f----- 
    167168 
    168169         IF( ln_zps ) THEN      ! z-coordinate - partial steps : min(e3u) 
    169170            DO_2D_00_01 
    170                zabe1 = ( ahmt(ji,jj,jk)+rn_ahm_b ) * e2t(ji,jj) * MIN( e3u(ji,jj,jk,Kmm), e3u(ji-1,jj,jk,Kmm) ) * r1_e1t(ji,jj) 
     171               zabe1 = ( ahmt(ji,jj,jk)+rn_ahm_b ) * e2t(ji,jj)   & 
     172                  &    * MIN( e3u(ji  ,jj,jk,Kmm),                & 
     173                  &           e3u(ji-1,jj,jk,Kmm) ) * r1_e1t(ji,jj) 
    171174 
    172175               zmskt = 1._wp / MAX(   umask(ji-1,jj,jk  )+umask(ji,jj,jk+1)     & 
    … …  
    181184         ELSE                   ! other coordinate system (zco or sco) : e3t 
    182185            DO_2D_00_01 
    183                zabe1 = ( ahmt(ji,jj,jk)+rn_ahm_b ) * e2t(ji,jj) * e3t(ji,jj,jk,Kmm) * r1_e1t(ji,jj) 
     186               zabe1 = ( ahmt(ji,jj,jk)+rn_ahm_b )   & 
     187                  &     * e2t(ji,jj) * e3t(ji,jj,jk,Kmm) * r1_e1t(ji,jj) 
    184188 
    185189               zmskt = 1._wp / MAX(   umask(ji-1,jj,jk  ) + umask(ji,jj,jk+1)     & 
    … …  
    196200         ! j-flux at f-point 
    197201         DO_2D_10_10 
    198             zabe2 = ( ahmf(ji,jj,jk) + rn_ahm_b ) * e1f(ji,jj) * e3f(ji,jj,jk) * r1_e2f(ji,jj) 
     202            zabe2 = ( ahmf(ji,jj,jk) + rn_ahm_b )   & 
     203               &     * e1f(ji,jj) * e3f(ji,jj,jk) * r1_e2f(ji,jj) 
    199204 
    200205            zmskf = 1._wp / MAX(   umask(ji,jj+1,jk  )+umask(ji,jj,jk+1)     & 
    … …  
    215220 
    216221         DO_2D_00_10 
    217             zabe1 = ( ahmf(ji,jj,jk) + rn_ahm_b ) * e2f(ji,jj) * e3f(ji,jj,jk) * r1_e1f(ji,jj) 
     222            zabe1 = ( ahmf(ji,jj,jk) + rn_ahm_b )   & 
     223               &     * e2f(ji,jj) * e3f(ji,jj,jk) * r1_e1f(ji,jj) 
    218224 
    219225            zmskf = 1._wp / MAX(  vmask(ji+1,jj,jk  )+vmask(ji,jj,jk+1)     & 
    … …  
    230236         IF( ln_zps ) THEN      ! z-coordinate - partial steps : min(e3u) 
    231237            DO_2D_01_10 
    232                zabe2 = ( ahmt(ji,jj,jk)+rn_ahm_b ) * e1t(ji,jj) * MIN( e3v(ji,jj,jk,Kmm), e3v(ji,jj-1,jk,Kmm) ) * r1_e2t(ji,jj) 
     238               zabe2 = ( ahmt(ji,jj,jk)+rn_ahm_b ) * e1t(ji,jj)   & 
     239                  &     * MIN( e3v(ji,jj  ,jk,Kmm),                 & 
     240                  &            e3v(ji,jj-1,jk,Kmm) ) * r1_e2t(ji,jj) 
    233241 
    234242               zmskt = 1._wp / MAX(  vmask(ji,jj-1,jk  )+vmask(ji,jj,jk+1)     & 
    … …  
    243251         ELSE                   ! other coordinate system (zco or sco) : e3t 
    244252            DO_2D_01_10 
    245                zabe2 = ( ahmt(ji,jj,jk)+rn_ahm_b ) * e1t(ji,jj) * e3t(ji,jj,jk,Kmm) * r1_e2t(ji,jj) 
     253               zabe2 = ( ahmt(ji,jj,jk)+rn_ahm_b )   & 
     254                  &     * e1t(ji,jj) * e3t(ji,jj,jk,Kmm) * r1_e2t(ji,jj) 
    246255 
    247256               zmskt = 1./MAX(  vmask(ji,jj-1,jk  )+vmask(ji,jj,jk+1)   & 
    … …  
    261270         DO_2D_00_00 
    262271            puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + (  ziut(ji+1,jj) - ziut(ji,jj  )    & 
    263                &                           + zjuf(ji  ,jj) - zjuf(ji,jj-1)  ) * r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm) 
     272               &                           + zjuf(ji  ,jj) - zjuf(ji,jj-1)  ) * r1_e1e2u(ji,jj)   & 
     273               &                           / e3u(ji,jj,jk,Kmm) 
    264274            pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + (  zivf(ji,jj  ) - zivf(ji-1,jj)    & 
    265                &                           + zjvt(ji,jj+1) - zjvt(ji,jj  )  ) * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm) 
     275               &                           + zjvt(ji,jj+1) - zjvt(ji,jj  )  ) * r1_e1e2v(ji,jj)   & 
     276               &                           / e3v(ji,jj,jk,Kmm) 
    266277         END_2D 
    267278         !                                             ! =============== 
    … …  
    278289         !                                             ! =============== 
    279290 
    280   
     291 
    281292         ! I. vertical trends associated with the lateral mixing 
    282293         ! ===================================================== 
    … …  
    375386         DO jk = 1, jpkm1 
    376387            DO ji = 2, jpim1 
    377                puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + ( zfuw(ji,jk) - zfuw(ji,jk+1) ) * r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm) 
    378                pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + ( zfvw(ji,jk) - zfvw(ji,jk+1) ) * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm) 
     388               puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + ( zfuw(ji,jk) - zfuw(ji,jk+1) ) * r1_e1e2u(ji,jj)   & 
     389                  &               / e3u(ji,jj,jk,Kmm) 
     390               pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + ( zfvw(ji,jk) - zfvw(ji,jk+1) ) * r1_e1e2v(ji,jj)   & 
     391                  &               / e3v(ji,jj,jk,Kmm) 
    379392            END DO 
    380393         END DO 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DYN/dynldf_lap_blp.F90

    r12377 r13151  
    1414   USE dom_oce        ! ocean space and time domain 
    1515   USE ldfdyn         ! lateral diffusion: eddy viscosity coef. 
    16    USE ldfslp         ! iso-neutral slopes  
     16   USE ldfslp         ! iso-neutral slopes 
    1717   USE zdf_oce        ! ocean vertical physics 
    1818   ! 
    … …  
    2828   !! * Substitutions 
    2929#  include "do_loop_substitute.h90" 
     30#  include "domzgr_substitute.h90" 
    3031   !!---------------------------------------------------------------------- 
    3132   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    32    !! $Id$  
     33   !! $Id$ 
    3334   !! Software governed by the CeCILL license (see ./LICENSE) 
    3435   !!---------------------------------------------------------------------- 
    … …  
    3839      !!---------------------------------------------------------------------- 
    3940      !!                     ***  ROUTINE dyn_ldf_lap  *** 
    40       !!                        
    41       !! ** Purpose :   Compute the before horizontal momentum diffusive  
     41      !! 
     42      !! ** Purpose :   Compute the before horizontal momentum diffusive 
    4243      !!      trend and add it to the general trend of momentum equation. 
    4344      !! 
    44       !! ** Method  :   The Laplacian operator apply on horizontal velocity is  
    45       !!      writen as :   grad_h( ahmt div_h(U )) - curl_h( ahmf curl_z(U) )  
     45      !! ** Method  :   The Laplacian operator apply on horizontal velocity is 
     46      !!      writen as :   grad_h( ahmt div_h(U )) - curl_h( ahmf curl_z(U) ) 
    4647      !! 
    4748      !! ** Action : - pu_rhs, pv_rhs increased by the harmonic operator applied on pu, pv. 
    … …  
    7677!!gm open question here : e3f  at before or now ?    probably now... 
    7778!!gm note that ahmf has already been multiplied by fmask 
    78             zcur(ji-1,jj-1) = ahmf(ji-1,jj-1,jk) * e3f(ji-1,jj-1,jk) * r1_e1e2f(ji-1,jj-1)       & 
    79                &     * (  e2v(ji  ,jj-1) * pv(ji  ,jj-1,jk) - e2v(ji-1,jj-1) * pv(ji-1,jj-1,jk)  & 
    80                &        - e1u(ji-1,jj  ) * pu(ji-1,jj  ,jk) + e1u(ji-1,jj-1) * pu(ji-1,jj-1,jk)  ) 
     79            zcur(ji-1,jj-1) =  & 
     80               &      ahmf(ji-1,jj-1,jk) * e3f(ji-1,jj-1,jk) * r1_e1e2f(ji-1,jj-1)      & 
     81               &  * (  e2v(ji  ,jj-1) * pv(ji  ,jj-1,jk) - e2v(ji-1,jj-1) * pv(ji-1,jj-1,jk)  & 
     82               &     - e1u(ji-1,jj  ) * pu(ji-1,jj  ,jk) + e1u(ji-1,jj-1) * pu(ji-1,jj-1,jk)  ) 
    8183            !                                      ! ahm * div        (computed from 2 to jpi/jpj) 
    8284!!gm note that ahmt has already been multiplied by tmask 
    83             zdiv(ji,jj)     = ahmt(ji,jj,jk) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kbb)                                         & 
    84                &     * (  e2u(ji,jj)*e3u(ji,jj,jk,Kbb) * pu(ji,jj,jk) - e2u(ji-1,jj)*e3u(ji-1,jj,jk,Kbb) * pu(ji-1,jj,jk)  & 
    85                &        + e1v(ji,jj)*e3v(ji,jj,jk,Kbb) * pv(ji,jj,jk) - e1v(ji,jj-1)*e3v(ji,jj-1,jk,Kbb) * pv(ji,jj-1,jk)  ) 
     85            zdiv(ji,jj)     =   & 
     86               &   ahmt(ji,jj,jk) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kbb)      & 
     87               &     * (  e2u(ji,jj)*e3u(ji,jj,jk,Kbb) * pu(ji,jj,jk)        & 
     88               &        - e2u(ji-1,jj)*e3u(ji-1,jj,jk,Kbb) * pu(ji-1,jj,jk)  & 
     89               &        + e1v(ji,jj)*e3v(ji,jj,jk,Kbb) * pv(ji,jj,jk)        & 
     90               &        - e1v(ji,jj-1)*e3v(ji,jj-1,jk,Kbb) * pv(ji,jj-1,jk)  ) 
    8691         END_2D 
    8792         ! 
    8893         DO_2D_00_00 
    89             pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zsign * (                                                 & 
    90                &              - ( zcur(ji  ,jj) - zcur(ji,jj-1) ) * r1_e2u(ji,jj) / e3u(ji,jj,jk,Kmm)   & 
    91                &              + ( zdiv(ji+1,jj) - zdiv(ji,jj  ) ) * r1_e1u(ji,jj)                     ) 
     94            pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zsign * (                             & 
     95               &              - ( zcur(ji  ,jj) - zcur(ji,jj-1) ) * r1_e2u(ji,jj)   & 
     96               &              / e3u(ji,jj,jk,Kmm)   & 
     97               &              + ( zdiv(ji+1,jj) - zdiv(ji,jj  ) ) * r1_e1u(ji,jj)        ) 
    9298               ! 
    93             pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zsign * (                                                 & 
    94                &                ( zcur(ji,jj  ) - zcur(ji-1,jj) ) * r1_e1v(ji,jj) / e3v(ji,jj,jk,Kmm)   & 
    95                &              + ( zdiv(ji,jj+1) - zdiv(ji  ,jj) ) * r1_e2v(ji,jj)                     ) 
     99            pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zsign * (                              & 
     100               &                ( zcur(ji,jj  ) - zcur(ji-1,jj) ) * r1_e1v(ji,jj)   & 
     101               &              / e3v(ji,jj,jk,Kmm)   & 
     102               &              + ( zdiv(ji,jj+1) - zdiv(ji  ,jj) ) * r1_e2v(ji,jj)       ) 
    96103         END_2D 
    97104         !                                             ! =============== 
    … …  
    105112      !!---------------------------------------------------------------------- 
    106113      !!                 ***  ROUTINE dyn_ldf_blp  *** 
    107       !!                     
    108       !! ** Purpose :   Compute the before lateral momentum viscous trend  
     114      !! 
     115      !! ** Purpose :   Compute the before lateral momentum viscous trend 
    109116      !!              and add it to the general trend of momentum equation. 
    110117      !! 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DYN/dynspg_ts.F90

    r12489 r13151  
    8787   !! * Substitutions 
    8888#  include "do_loop_substitute.h90" 
     89#  include "domzgr_substitute.h90" 
    8990   !!---------------------------------------------------------------------- 
    9091   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    161162      REAL(wp), DIMENSION(jpi,jpj) :: zCdU_u, zCdU_v   ! top/bottom stress at u- & v-points 
    162163      REAL(wp), DIMENSION(jpi,jpj) :: zhU, zhV         ! fluxes 
     164      REAL(wp), DIMENSION(jpi, jpj, jpk) :: ze3u, ze3v 
    163165      ! 
    164166      REAL(wp) ::   zwdramp                     ! local scalar - only used if ln_wd_dl = .True.  
    … …  
    227229      !                                   !=  zu_frc =  1/H e3*d/dt(Ua)  =!  (Vertical mean of Ua, the 3D trends) 
    228230      !                                   !  ---------------------------  ! 
    229       zu_frc(:,:) = SUM( e3u(:,:,:,Kmm) * uu(:,:,:,Krhs) * umask(:,:,:) , DIM=3 ) * r1_hu(:,:,Kmm) 
    230       zv_frc(:,:) = SUM( e3v(:,:,:,Kmm) * vv(:,:,:,Krhs) * vmask(:,:,:) , DIM=3 ) * r1_hv(:,:,Kmm) 
     231      DO jk = 1 , jpk 
     232         ze3u(:,:,jk) = e3u(:,:,jk,Kmm) 
     233         ze3v(:,:,jk) = e3v(:,:,jk,Kmm) 
     234      END DO 
     235      ! 
     236      zu_frc(:,:) = SUM( ze3u(:,:,:) * uu(:,:,:,Krhs) * umask(:,:,:) , DIM=3 ) * r1_hu(:,:,Kmm) 
     237      zv_frc(:,:) = SUM( ze3v(:,:,:) * vv(:,:,:,Krhs) * vmask(:,:,:) , DIM=3 ) * r1_hv(:,:,Kmm) 
    231238      ! 
    232239      ! 
    … …  
    250257      zhV(:,:) = pvv_b(:,:,Kmm) * hv(:,:,Kmm) * e1v(:,:)        ! NB: FULL domain : put a value in last row and column 
    251258      ! 
    252       CALL dyn_cor_2d( hu(:,:,Kmm), hv(:,:,Kmm), puu_b(:,:,Kmm), pvv_b(:,:,Kmm), zhU, zhV,  &   ! <<== in 
     259      CALL dyn_cor_2d( ht(:,:), hu(:,:,Kmm), hv(:,:,Kmm), puu_b(:,:,Kmm), pvv_b(:,:,Kmm), zhU, zhV,  &   ! <<== in 
    253260         &                                                                     zu_trd, zv_trd   )   ! ==>> out 
    254261      ! 
    … …  
    567574         ! at each time step. We however keep them constant here for optimization. 
    568575         ! Recall that zhU and zhV hold fluxes at jn+0.5 (extrapolated not backward interpolated) 
    569          CALL dyn_cor_2d( zhup2_e, zhvp2_e, ua_e, va_e, zhU, zhV,    zu_trd, zv_trd   ) 
     576         CALL dyn_cor_2d( zhtp2_e, zhup2_e, zhvp2_e, ua_e, va_e, zhU, zhV,    zu_trd, zv_trd   ) 
    570577         ! 
    571578         ! Add tidal astronomical forcing if defined 
    … …  
    10881095      ! 
    10891096      SELECT CASE( nvor_scheme ) 
    1090       CASE( np_EEN )                != EEN scheme using e3f (energy & enstrophy scheme) 
     1097      CASE( np_EEN )                != EEN scheme using e3f energy & enstrophy scheme 
    10911098         SELECT CASE( nn_een_e3f )              !* ff_f/e3 at F-point 
    10921099         CASE ( 0 )                                   ! original formulation  (masked averaging of e3t divided by 4) 
    … …  
    11151122         END_2D 
    11161123         ! 
    1117       CASE( np_EET )                  != EEN scheme using e3t (energy conserving scheme) 
     1124      CASE( np_EET )                  != EEN scheme using e3t energy conserving scheme 
    11181125         ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp 
    11191126         DO_2D_01_01 
    … …  
    11791186 
    11801187 
    1181    SUBROUTINE dyn_cor_2d( phu, phv, punb, pvnb, zhU, zhV,    zu_trd, zv_trd   ) 
     1188   SUBROUTINE dyn_cor_2d( pht, phu, phv, punb, pvnb, zhU, zhV,    zu_trd, zv_trd   ) 
    11821189      !!--------------------------------------------------------------------- 
    11831190      !!                   ***  ROUTINE dyn_cor_2d  *** 
    … …  
    11871194      INTEGER  ::   ji ,jj                             ! dummy loop indices 
    11881195      REAL(wp) ::   zx1, zx2, zy1, zy2, z1_hu, z1_hv   !   -      - 
    1189       REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) :: phu, phv, punb, pvnb, zhU, zhV 
     1196      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) :: pht, phu, phv, punb, pvnb, zhU, zhV 
    11901197      REAL(wp), DIMENSION(jpi,jpj), INTENT(  out) :: zu_trd, zv_trd 
    11911198      !!---------------------------------------------------------------------- 
    … …  
    11961203            z1_hv = ssvmask(ji,jj) / ( phv(ji,jj) + 1._wp - ssvmask(ji,jj) ) 
    11971204            zu_trd(ji,jj) = + r1_4 * r1_e1e2u(ji,jj) * z1_hu                    & 
    1198                &               * (  e1e2t(ji+1,jj)*ht(ji+1,jj)*ff_t(ji+1,jj) * ( pvnb(ji+1,jj) + pvnb(ji+1,jj-1) )   & 
    1199                &                  + e1e2t(ji  ,jj)*ht(ji  ,jj)*ff_t(ji  ,jj) * ( pvnb(ji  ,jj) + pvnb(ji  ,jj-1) )   ) 
     1205               &               * (  e1e2t(ji+1,jj)*pht(ji+1,jj)*ff_t(ji+1,jj) * ( pvnb(ji+1,jj) + pvnb(ji+1,jj-1) )   & 
     1206               &                  + e1e2t(ji  ,jj)*pht(ji  ,jj)*ff_t(ji  ,jj) * ( pvnb(ji  ,jj) + pvnb(ji  ,jj-1) )   ) 
    12001207               ! 
    12011208            zv_trd(ji,jj) = - r1_4 * r1_e1e2v(ji,jj) * z1_hv                    & 
    1202                &               * (  e1e2t(ji,jj+1)*ht(ji,jj+1)*ff_t(ji,jj+1) * ( punb(ji,jj+1) + punb(ji-1,jj+1) )   &  
    1203                &                  + e1e2t(ji,jj  )*ht(ji,jj  )*ff_t(ji,jj  ) * ( punb(ji,jj  ) + punb(ji-1,jj  ) )   )  
     1209               &               * (  e1e2t(ji,jj+1)*pht(ji,jj+1)*ff_t(ji,jj+1) * ( punb(ji,jj+1) + punb(ji-1,jj+1) )   &  
     1210               &                  + e1e2t(ji,jj  )*pht(ji,jj  )*ff_t(ji,jj  ) * ( punb(ji,jj  ) + punb(ji-1,jj  ) )   )  
    12041211         END_2D 
    12051212         !          

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DYN/dynvor.F90

    r12377 r13151  
    1515   !!            3.2  ! 2009-04  (R. Benshila)  vvl: correction of een scheme 
    1616   !!            3.3  ! 2010-10  (C. Ethe, G. Madec)  reorganisation of initialisation phase 
    17    !!            3.7  ! 2014-04  (G. Madec)  trend simplification: suppress jpdyn_trd_dat vorticity  
     17   !!            3.7  ! 2014-04  (G. Madec)  trend simplification: suppress jpdyn_trd_dat vorticity 
    1818   !!             -   ! 2014-06  (G. Madec)  suppression of velocity curl from in-core memory 
    1919   !!             -   ! 2016-12  (G. Madec, E. Clementi) add Stokes-Coriolis trends (ln_stcor=T) 
    … …  
    7070   INTEGER, PUBLIC, PARAMETER ::   np_MIX = 5   ! MIX scheme 
    7171 
    72    INTEGER ::   ncor, nrvm, ntot   ! choice of calculated vorticity  
     72   INTEGER ::   ncor, nrvm, ntot   ! choice of calculated vorticity 
    7373   !                               ! associated indices: 
    7474   INTEGER, PUBLIC, PARAMETER ::   np_COR = 1         ! Coriolis (planetary) 
    … …  
    7979 
    8080   REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   di_e2u_2        ! = di(e2u)/2          used in T-point metric term calculation 
    81    REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   dj_e1v_2        ! = dj(e1v)/2           -        -      -       -  
     81   REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   dj_e1v_2        ! = dj(e1v)/2           -        -      -       - 
    8282   REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   di_e2v_2e1e2f   ! = di(e2u)/(2*e1e2f)  used in F-point metric term calculation 
    83    REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   dj_e1u_2e1e2f   ! = dj(e1v)/(2*e1e2f)   -        -      -       -  
    84     
     83   REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   dj_e1u_2e1e2f   ! = dj(e1v)/(2*e1e2f)   -        -      -       - 
     84 
    8585   REAL(wp) ::   r1_4  = 0.250_wp         ! =1/4 
    8686   REAL(wp) ::   r1_8  = 0.125_wp         ! =1/8 
    8787   REAL(wp) ::   r1_12 = 1._wp / 12._wp   ! 1/12 
    88     
     88 
    8989   !! * Substitutions 
    9090#  include "do_loop_substitute.h90" 
     91#  include "domzgr_substitute.h90" 
     92 
    9193   !!---------------------------------------------------------------------- 
    9294   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    103105      !! ** Action : - Update (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) with the now vorticity term trend 
    104106      !!             - save the trends in (ztrdu,ztrdv) in 2 parts (relative 
    105       !!               and planetary vorticity trends) and send them to trd_dyn  
     107      !!               and planetary vorticity trends) and send them to trd_dyn 
    106108      !!               for futher diagnostics (l_trddyn=T) 
    107109      !!---------------------------------------------------------------------- 
    … …  
    193195      !!                  ***  ROUTINE vor_enT  *** 
    194196      !! 
    195       !! ** Purpose :   Compute the now total vorticity trend and add it to  
     197      !! ** Purpose :   Compute the now total vorticity trend and add it to 
    196198      !!      the general trend of the momentum equation. 
    197199      !! 
    198       !! ** Method  :   Trend evaluated using now fields (centered in time)  
     200      !! ** Method  :   Trend evaluated using now fields (centered in time) 
    199201      !!       and t-point evaluation of vorticity (planetary and relative). 
    200202      !!       conserves the horizontal kinetic energy. 
    201       !!         The general trend of momentum is increased due to the vorticity  
     203      !!         The general trend of momentum is increased due to the vorticity 
    202204      !!       term which is given by: 
    203205      !!          voru = 1/bu  mj[ ( mi(mj(bf*rvor))+bt*f_t)/e3t  mj[vn] ] 
    … …  
    233235                  &             - e1u(ji,jj+1) * pu(ji,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk)  ) * r1_e1e2f(ji,jj) 
    234236            END_2D 
    235             IF( ln_dynvor_msk ) THEN                     ! mask/unmask relative vorticity  
     237            IF( ln_dynvor_msk ) THEN                     ! mask/unmask relative vorticity 
    236238               DO_2D_10_10 
    237239                  zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk) 
    … …  
    248250                  &              - e1u(ji,jj+1) * pu(ji,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk)   ) * r1_e1e2f(ji,jj) 
    249251            END_2D 
    250             IF( ln_dynvor_msk ) THEN                     ! mask/unmask relative vorticity  
     252            IF( ln_dynvor_msk ) THEN                     ! mask/unmask relative vorticity 
    251253               DO_2D_10_10 
    252254                  zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk) 
    … …  
    269271            DO_2D_01_01 
    270272               zwt(ji,jj) = r1_4 * (   zwz(ji-1,jj  ,jk) + zwz(ji,jj  ,jk)   & 
    271                   &                  + zwz(ji-1,jj-1,jk) + zwz(ji,jj-1,jk) ) * e1e2t(ji,jj)*e3t(ji,jj,jk,Kmm) 
     273                  &                  + zwz(ji-1,jj-1,jk) + zwz(ji,jj-1,jk) ) & 
     274                  &                  * e1e2t(ji,jj)*e3t(ji,jj,jk,Kmm) 
    272275            END_2D 
    273276         CASE ( np_MET )                           !* metric term 
    274277            DO_2D_01_01 
    275                zwt(ji,jj) = (   ( pv(ji,jj,jk) + pv(ji,jj-1,jk) ) * di_e2u_2(ji,jj)   & 
    276                   &           - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj)   ) * e3t(ji,jj,jk,Kmm) 
     278               zwt(ji,jj) = (   ( pv(ji,jj,jk) + pv(ji,jj-1,jk) ) * di_e2u_2(ji,jj)     & 
     279                  &           - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj)   ) & 
     280                  &             * e3t(ji,jj,jk,Kmm) 
    277281            END_2D 
    278282         CASE ( np_CRV )                           !* Coriolis + relative vorticity 
    279283            DO_2D_01_01 
    280                zwt(ji,jj) = (  ff_t(ji,jj) + r1_4 * ( zwz(ji-1,jj  ,jk) + zwz(ji,jj  ,jk)    & 
    281                   &                                 + zwz(ji-1,jj-1,jk) + zwz(ji,jj-1,jk) )  ) * e1e2t(ji,jj)*e3t(ji,jj,jk,Kmm) 
     284               zwt(ji,jj) = (  ff_t(ji,jj) + r1_4 * ( zwz(ji-1,jj  ,jk) + zwz(ji,jj  ,jk)      & 
     285                  &                                 + zwz(ji-1,jj-1,jk) + zwz(ji,jj-1,jk) )  ) & 
     286                  &                                 * e1e2t(ji,jj)*e3t(ji,jj,jk,Kmm) 
    282287            END_2D 
    283288         CASE ( np_CME )                           !* Coriolis + metric 
    284289            DO_2D_01_01 
    285                zwt(ji,jj) = (  ff_t(ji,jj) * e1e2t(ji,jj)                           & 
    286                     &        + ( pv(ji,jj,jk) + pv(ji,jj-1,jk) ) * di_e2u_2(ji,jj)  & 
    287                     &        - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj)  ) * e3t(ji,jj,jk,Kmm) 
     290               zwt(ji,jj) = (  ff_t(ji,jj) * e1e2t(ji,jj)                             & 
     291                    &        + ( pv(ji,jj,jk) + pv(ji,jj-1,jk) ) * di_e2u_2(ji,jj)    & 
     292                    &        - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj)  ) & 
     293                    &          * e3t(ji,jj,jk,Kmm) 
    288294            END_2D 
    289295         CASE DEFAULT                                             ! error 
    … …  
    298304               ! 
    299305            pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) - r1_4 * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm)                    & 
    300                &                                * (  zwt(ji,jj+1) * ( pu(ji,jj+1,jk) + pu(ji-1,jj+1,jk) )   &  
    301                &                                   + zwt(ji,jj  ) * ( pu(ji,jj  ,jk) + pu(ji-1,jj  ,jk) )   )  
     306               &                                * (  zwt(ji,jj+1) * ( pu(ji,jj+1,jk) + pu(ji-1,jj+1,jk) )   & 
     307               &                                   + zwt(ji,jj  ) * ( pu(ji,jj  ,jk) + pu(ji-1,jj  ,jk) )   ) 
    302308         END_2D 
    303309         !                                             ! =============== 
    … …  
    311317      !!                  ***  ROUTINE vor_ene  *** 
    312318      !! 
    313       !! ** Purpose :   Compute the now total vorticity trend and add it to  
     319      !! ** Purpose :   Compute the now total vorticity trend and add it to 
    314320      !!      the general trend of the momentum equation. 
    315321      !! 
    316       !! ** Method  :   Trend evaluated using now fields (centered in time)  
     322      !! ** Method  :   Trend evaluated using now fields (centered in time) 
    317323      !!       and the Sadourny (1975) flux form formulation : conserves the 
    318324      !!       horizontal kinetic energy. 
    319       !!         The general trend of momentum is increased due to the vorticity  
     325      !!         The general trend of momentum is increased due to the vorticity 
    320326      !!       term which is given by: 
    321327      !!          voru = 1/e1u  mj-1[ (rvor+f)/e3f  mi(e1v*e3v pvv(:,:,:,Kmm)) ] 
    … …  
    350356         SELECT CASE( kvor )                 !==  vorticity considered  ==! 
    351357         CASE ( np_COR )                           !* Coriolis (planetary vorticity) 
    352             zwz(:,:) = ff_f(:,:)  
     358            zwz(:,:) = ff_f(:,:) 
    353359         CASE ( np_RVO )                           !* relative vorticity 
    354360            DO_2D_10_10 
    … …  
    396402            zx2 = zwx(ji  ,jj) + zwx(ji  ,jj+1) 
    397403            pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + r1_4 * r1_e1u(ji,jj) * ( zwz(ji  ,jj-1) * zy1 + zwz(ji,jj) * zy2 ) 
    398             pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) - r1_4 * r1_e2v(ji,jj) * ( zwz(ji-1,jj  ) * zx1 + zwz(ji,jj) * zx2 )  
     404            pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) - r1_4 * r1_e2v(ji,jj) * ( zwz(ji-1,jj  ) * zx1 + zwz(ji,jj) * zx2 ) 
    399405         END_2D 
    400406         !                                             ! =============== 
    … …  
    446452         SELECT CASE( kvor )                 !==  vorticity considered  ==! 
    447453         CASE ( np_COR )                           !* Coriolis (planetary vorticity) 
    448             zwz(:,:) = ff_f(:,:)  
     454            zwz(:,:) = ff_f(:,:) 
    449455         CASE ( np_RVO )                           !* relative vorticity 
    450456            DO_2D_10_10 
    … …  
    504510      !!                ***  ROUTINE vor_een  *** 
    505511      !! 
    506       !! ** Purpose :   Compute the now total vorticity trend and add it to  
     512      !! ** Purpose :   Compute the now total vorticity trend and add it to 
    507513      !!      the general trend of the momentum equation. 
    508514      !! 
    509       !! ** Method  :   Trend evaluated using now fields (centered in time)  
    510       !!      and the Arakawa and Lamb (1980) flux form formulation : conserves  
     515      !! ** Method  :   Trend evaluated using now fields (centered in time) 
     516      !!      and the Arakawa and Lamb (1980) flux form formulation : conserves 
    511517      !!      both the horizontal kinetic energy and the potential enstrophy 
    512518      !!      when horizontal divergence is zero (see the NEMO documentation) 
    … …  
    545551         CASE ( 0 )                                   ! original formulation  (masked averaging of e3t divided by 4) 
    546552            DO_2D_10_10 
    547                ze3f = (  e3t(ji,jj+1,jk,Kmm)*tmask(ji,jj+1,jk) + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk)   & 
    548                   &    + e3t(ji,jj  ,jk,Kmm)*tmask(ji,jj  ,jk) + e3t(ji+1,jj  ,jk,Kmm)*tmask(ji+1,jj  ,jk)  ) 
     553               ze3f = (  e3t(ji  ,jj+1,jk,Kmm)*tmask(ji  ,jj+1,jk)   & 
     554                  &    + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk)   & 
     555                  &    + e3t(ji  ,jj  ,jk,Kmm)*tmask(ji  ,jj  ,jk)   & 
     556                  &    + e3t(ji+1,jj  ,jk,Kmm)*tmask(ji+1,jj  ,jk)  ) 
    549557               IF( ze3f /= 0._wp ) THEN   ;   z1_e3f(ji,jj) = 4._wp / ze3f 
    550558               ELSE                       ;   z1_e3f(ji,jj) = 0._wp 
    … …  
    553561         CASE ( 1 )                                   ! new formulation  (masked averaging of e3t divided by the sum of mask) 
    554562            DO_2D_10_10 
    555                ze3f = (  e3t(ji,jj+1,jk,Kmm)*tmask(ji,jj+1,jk) + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk)   & 
    556                   &    + e3t(ji,jj  ,jk,Kmm)*tmask(ji,jj  ,jk) + e3t(ji+1,jj  ,jk,Kmm)*tmask(ji+1,jj  ,jk)  ) 
     563               ze3f = (  e3t(ji  ,jj+1,jk,Kmm)*tmask(ji  ,jj+1,jk)   & 
     564                  &    + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk)   & 
     565                  &    + e3t(ji  ,jj  ,jk,Kmm)*tmask(ji  ,jj  ,jk)   & 
     566                  &    + e3t(ji+1,jj  ,jk,Kmm)*tmask(ji+1,jj  ,jk)  ) 
    557567               zmsk = (                    tmask(ji,jj+1,jk) +                     tmask(ji+1,jj+1,jk)   & 
    558568                  &                      + tmask(ji,jj  ,jk) +                     tmask(ji+1,jj  ,jk)  ) 
    … …  
    644654      !!                ***  ROUTINE vor_eeT  *** 
    645655      !! 
    646       !! ** Purpose :   Compute the now total vorticity trend and add it to  
     656      !! ** Purpose :   Compute the now total vorticity trend and add it to 
    647657      !!      the general trend of the momentum equation. 
    648658      !! 
    649       !! ** Method  :   Trend evaluated using now fields (centered in time)  
    650       !!      and the Arakawa and Lamb (1980) vector form formulation using  
     659      !! ** Method  :   Trend evaluated using now fields (centered in time) 
     660      !!      and the Arakawa and Lamb (1980) vector form formulation using 
    651661      !!      a modified version of Arakawa and Lamb (1980) scheme (see vor_een). 
    652       !!      The change consists in  
     662      !!      The change consists in 
    653663      !!      Add this trend to the general momentum trend (pu_rhs,pv_rhs). 
    654664      !! 
    … …  
    667677      REAL(wp) ::   zua, zva       ! local scalars 
    668678      REAL(wp) ::   zmsk, z1_e3t   ! local scalars 
    669       REAL(wp), DIMENSION(jpi,jpj)     ::   zwx , zwy  
     679      REAL(wp), DIMENSION(jpi,jpj)     ::   zwx , zwy 
    670680      REAL(wp), DIMENSION(jpi,jpj)     ::   ztnw, ztne, ztsw, ztse 
    671681      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zwz 
    … …  
    827837      ! 
    828838      IF( ioptio /= 1 ) CALL ctl_stop( ' use ONE and ONLY one vorticity scheme' ) 
    829       !                       
     839      ! 
    830840      IF(lwp) WRITE(numout,*)        ! type of calculated vorticity (set ncor, nrvm, ntot) 
    831841      ncor = np_COR                       ! planetary vorticity 
    … …  
    836846         ntot = np_COR        !     -         - 
    837847      CASE( np_VEC_c2  ) 
    838          IF(lwp) WRITE(numout,*) '   ==>>>   vector form dynamics : total vorticity = Coriolis + relative vorticity'  
     848         IF(lwp) WRITE(numout,*) '   ==>>>   vector form dynamics : total vorticity = Coriolis + relative vorticity' 
    839849         nrvm = np_RVO        ! relative vorticity 
    840          ntot = np_CRV        ! relative + planetary vorticity          
     850         ntot = np_CRV        ! relative + planetary vorticity 
    841851      CASE( np_FLX_c2 , np_FLX_ubs  ) 
    842852         IF(lwp) WRITE(numout,*) '   ==>>>   flux form dynamics : total vorticity = Coriolis + metric term' 
    … …  
    863873         ! 
    864874      END SELECT 
    865        
     875 
    866876      IF(lwp) THEN                   ! Print the choice 
    867877         WRITE(numout,*) 
    … …  
    873883         CASE( np_EEN )   ;   WRITE(numout,*) '   ==>>>   energy and enstrophy conserving scheme (EEN)' 
    874884         CASE( np_MIX )   ;   WRITE(numout,*) '   ==>>>   mixed enstrophy/energy conserving scheme (MIX)' 
    875          END SELECT          
     885         END SELECT 
    876886      ENDIF 
    877887      ! 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DYN/dynzad.F90

    r12377 r13151  
    2929   !! * Substitutions 
    3030#  include "do_loop_substitute.h90" 
     31#  include "domzgr_substitute.h90" 
    3132   !!---------------------------------------------------------------------- 
    3233   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    9596      ! 
    9697      DO_3D_00_00( 1, jpkm1 ) 
    97          puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zwuw(ji,jj,jk) + zwuw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm) 
    98          pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( zwvw(ji,jj,jk) + zwvw(ji,jj,jk+1) ) * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm) 
     98         puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zwuw(ji,jj,jk) + zwuw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj)   & 
     99            &                                      / e3u(ji,jj,jk,Kmm) 
     100         pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( zwvw(ji,jj,jk) + zwvw(ji,jj,jk+1) ) * r1_e1e2v(ji,jj)   & 
     101            &                                      / e3v(ji,jj,jk,Kmm) 
    99102      END_3D 
    100103 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DYN/dynzdf.F90

    r12489 r13151  
    3838   !! * Substitutions 
    3939#  include "do_loop_substitute.h90" 
     40#  include "domzgr_substitute.h90" 
    4041   !!---------------------------------------------------------------------- 
    4142   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    5556      !! ** Method  :  - Leap-Frog time stepping on all trends but the vertical mixing 
    5657      !!         u(after) =         u(before) + 2*dt *       u(rhs)                vector form or linear free surf. 
    57       !!         u(after) = ( e3u_b*u(before) + 2*dt * e3u_n*u(rhs) ) / e3u(after)   otherwise 
     58      !!         u(after) = ( e3u_b*u(before) + 2*dt * e3u_n*u(rhs) ) / e3u_after   otherwise 
    5859      !!               - update the after velocity with the implicit vertical mixing. 
    5960      !!      This requires to solver the following system:  
    60       !!         u(after) = u(after) + 1/e3u(after) dk+1[ mi(avm) / e3uw(after) dk[ua] ] 
     61      !!         u(after) = u(after) + 1/e3u_after  dk+1[ mi(avm) / e3uw_after dk[ua] ] 
    6162      !!      with the following surface/top/bottom boundary condition: 
    6263      !!      surface: wind stress input (averaged over kt-1/2 & kt+1/2) 
    … …  
    112113      ELSE                                      ! applied on thickness weighted velocity 
    113114         DO jk = 1, jpkm1 
    114             puu(:,:,jk,Kaa) = (         e3u(:,:,jk,Kbb) * puu(:,:,jk,Kbb)  & 
    115                &          + rDt * e3u(:,:,jk,Kmm) * puu(:,:,jk,Krhs)  ) / e3u(:,:,jk,Kaa) * umask(:,:,jk) 
    116             pvv(:,:,jk,Kaa) = (         e3v(:,:,jk,Kbb) * pvv(:,:,jk,Kbb)  & 
    117                &          + rDt * e3v(:,:,jk,Kmm) * pvv(:,:,jk,Krhs)  ) / e3v(:,:,jk,Kaa) * vmask(:,:,jk) 
     115            puu(:,:,jk,Kaa) =  (    e3u(:,:,jk,Kbb) * puu(:,:,jk,Kbb)       & 
     116               &            + rDt * e3u(:,:,jk,Kmm) * puu(:,:,jk,Krhs)  )   & 
     117               &                  / e3u(:,:,jk,Kaa) * umask(:,:,jk) 
     118            pvv(:,:,jk,Kaa) =  (    e3v(:,:,jk,Kbb) * pvv(:,:,jk,Kbb)       & 
     119               &            + rDt * e3v(:,:,jk,Kmm) * pvv(:,:,jk,Krhs)  )   & 
     120               &                  / e3v(:,:,jk,Kaa) * vmask(:,:,jk) 
    118121         END DO 
    119122      ENDIF 
    … …  
    131134            iku = mbku(ji,jj)         ! ocean bottom level at u- and v-points  
    132135            ikv = mbkv(ji,jj)         ! (deepest ocean u- and v-points) 
    133             ze3ua =  ( 1._wp - r_vvl ) * e3u(ji,jj,iku,Kmm) + r_vvl * e3u(ji,jj,iku,Kaa) 
    134             ze3va =  ( 1._wp - r_vvl ) * e3v(ji,jj,ikv,Kmm) + r_vvl * e3v(ji,jj,ikv,Kaa) 
     136            ze3ua =  ( 1._wp - r_vvl ) * e3u(ji,jj,iku,Kmm)    & 
     137               &             + r_vvl   * e3u(ji,jj,iku,Kaa) 
     138            ze3va =  ( 1._wp - r_vvl ) * e3v(ji,jj,ikv,Kmm)    & 
     139               &             + r_vvl   * e3v(ji,jj,ikv,Kaa) 
    135140            puu(ji,jj,iku,Kaa) = puu(ji,jj,iku,Kaa) + rDt * 0.5*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) * uu_b(ji,jj,Kaa) / ze3ua 
    136141            pvv(ji,jj,ikv,Kaa) = pvv(ji,jj,ikv,Kaa) + rDt * 0.5*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) * vv_b(ji,jj,Kaa) / ze3va 
    … …  
    140145               iku = miku(ji,jj)         ! top ocean level at u- and v-points  
    141146               ikv = mikv(ji,jj)         ! (first wet ocean u- and v-points) 
    142                ze3ua =  ( 1._wp - r_vvl ) * e3u(ji,jj,iku,Kmm) + r_vvl * e3u(ji,jj,iku,Kaa) 
    143                ze3va =  ( 1._wp - r_vvl ) * e3v(ji,jj,ikv,Kmm) + r_vvl * e3v(ji,jj,ikv,Kaa) 
     147               ze3ua =  ( 1._wp - r_vvl ) * e3u(ji,jj,iku,Kmm)    & 
     148                  &             + r_vvl   * e3u(ji,jj,iku,Kaa) 
     149               ze3va =  ( 1._wp - r_vvl ) * e3v(ji,jj,ikv,Kmm)    & 
     150                  &             + r_vvl   * e3v(ji,jj,ikv,Kaa) 
    144151               puu(ji,jj,iku,Kaa) = puu(ji,jj,iku,Kaa) + rDt * 0.5*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * uu_b(ji,jj,Kaa) / ze3ua 
    145152               pvv(ji,jj,ikv,Kaa) = pvv(ji,jj,ikv,Kaa) + rDt * 0.5*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) * vv_b(ji,jj,Kaa) / ze3va 
    … …  
    156163         CASE( np_lap_i )           ! rotated lateral mixing: add its vertical mixing (akzu) 
    157164            DO_3D_00_00( 1, jpkm1 ) 
    158                ze3ua =  ( 1._wp - r_vvl ) * e3u(ji,jj,jk,Kmm) + r_vvl * e3u(ji,jj,jk,Kaa)   ! after scale factor at U-point 
     165               ze3ua =  ( 1._wp - r_vvl ) * e3u(ji,jj,jk,Kmm)    & 
     166                  &             + r_vvl   * e3u(ji,jj,jk,Kaa)   ! after scale factor at U-point 
    159167               zzwi = - zdt * ( avm(ji+1,jj,jk  ) + avm(ji,jj,jk  ) + akzu(ji,jj,jk  ) )   & 
    160168                  &         / ( ze3ua * e3uw(ji,jj,jk  ,Kmm) ) * wumask(ji,jj,jk  ) 
    … …  
    169177         CASE DEFAULT               ! iso-level lateral mixing 
    170178            DO_3D_00_00( 1, jpkm1 ) 
    171                ze3ua =  ( 1._wp - r_vvl ) * e3u(ji,jj,jk,Kmm) + r_vvl * e3u(ji,jj,jk,Kaa)   ! after scale factor at U-point 
    172                zzwi = - zdt * ( avm(ji+1,jj,jk  ) + avm(ji,jj,jk  ) ) / ( ze3ua * e3uw(ji,jj,jk  ,Kmm) ) * wumask(ji,jj,jk  ) 
    173                zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) ) / ( ze3ua * e3uw(ji,jj,jk+1,Kmm) ) * wumask(ji,jj,jk+1) 
     179               ze3ua =  ( 1._wp - r_vvl ) * e3u(ji,jj,jk,Kmm)    &    ! after scale factor at U-point 
     180                  &             + r_vvl   * e3u(ji,jj,jk,Kaa) 
     181               zzwi = - zdt * ( avm(ji+1,jj,jk  ) + avm(ji,jj,jk  ) )   & 
     182                  &         / ( ze3ua * e3uw(ji,jj,jk  ,Kmm) ) * wumask(ji,jj,jk  ) 
     183               zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) )   & 
     184                  &         / ( ze3ua * e3uw(ji,jj,jk+1,Kmm) ) * wumask(ji,jj,jk+1) 
    174185               zWui = ( wi(ji,jj,jk  ) + wi(ji+1,jj,jk  ) ) / ze3ua 
    175186               zWus = ( wi(ji,jj,jk+1) + wi(ji+1,jj,jk+1) ) / ze3ua 
    … …  
    181192         DO_2D_00_00 
    182193            zwi(ji,jj,1) = 0._wp 
    183             ze3ua =  ( 1._wp - r_vvl ) * e3u(ji,jj,1,Kmm) + r_vvl * e3u(ji,jj,1,Kaa) 
    184             zzws = - zdt * ( avm(ji+1,jj,2) + avm(ji  ,jj,2) ) / ( ze3ua * e3uw(ji,jj,2,Kmm) ) * wumask(ji,jj,2) 
     194            ze3ua =  ( 1._wp - r_vvl ) * e3u(ji,jj,1,Kmm)    & 
     195               &             + r_vvl   * e3u(ji,jj,1,Kaa) 
     196            zzws = - zdt * ( avm(ji+1,jj,2) + avm(ji  ,jj,2) )   & 
     197               &         / ( ze3ua * e3uw(ji,jj,2,Kmm) ) * wumask(ji,jj,2) 
    185198            zWus = ( wi(ji  ,jj,2) +  wi(ji+1,jj,2) ) / ze3ua 
    186199            zws(ji,jj,1 ) = zzws - zdt * MAX( zWus, 0._wp ) 
    … …  
    191204         CASE( np_lap_i )           ! rotated lateral mixing: add its vertical mixing (akzu) 
    192205            DO_3D_00_00( 1, jpkm1 ) 
    193                ze3ua =  ( 1._wp - r_vvl ) * e3u(ji,jj,jk,Kmm) + r_vvl * e3u(ji,jj,jk,Kaa)   ! after scale factor at U-point 
     206               ze3ua =  ( 1._wp - r_vvl ) * e3u(ji,jj,jk,Kmm)    & 
     207                  &             + r_vvl   * e3u(ji,jj,jk,Kaa)   ! after scale factor at U-point 
    194208               zzwi = - zdt * ( avm(ji+1,jj,jk  ) + avm(ji,jj,jk  ) + akzu(ji,jj,jk  ) )   & 
    195209                  &         / ( ze3ua * e3uw(ji,jj,jk  ,Kmm) ) * wumask(ji,jj,jk  ) 
    … …  
    202216         CASE DEFAULT               ! iso-level lateral mixing 
    203217            DO_3D_00_00( 1, jpkm1 ) 
    204                ze3ua =  ( 1._wp - r_vvl ) * e3u(ji,jj,jk,Kmm) + r_vvl * e3u(ji,jj,jk,Kaa)   ! after scale factor at U-point 
    205                zzwi = - zdt * ( avm(ji+1,jj,jk  ) + avm(ji,jj,jk  ) ) / ( ze3ua * e3uw(ji,jj,jk  ,Kmm) ) * wumask(ji,jj,jk  ) 
    206                zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) ) / ( ze3ua * e3uw(ji,jj,jk+1,Kmm) ) * wumask(ji,jj,jk+1) 
     218               ze3ua =  ( 1._wp - r_vvl ) * e3u(ji,jj,jk,Kmm)    & 
     219                  &             + r_vvl   * e3u(ji,jj,jk,Kaa)   ! after scale factor at U-point 
     220               zzwi = - zdt * ( avm(ji+1,jj,jk  ) + avm(ji,jj,jk  ) )    & 
     221                  &         / ( ze3ua * e3uw(ji,jj,jk  ,Kmm) ) * wumask(ji,jj,jk  ) 
     222               zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) )    & 
     223                  &         / ( ze3ua * e3uw(ji,jj,jk+1,Kmm) ) * wumask(ji,jj,jk+1) 
    207224               zwi(ji,jj,jk) = zzwi 
    208225               zws(ji,jj,jk) = zzws 
    … …  
    226243         DO_2D_00_00 
    227244            iku = mbku(ji,jj)       ! ocean bottom level at u- and v-points 
    228             ze3ua =  ( 1._wp - r_vvl ) * e3u(ji,jj,iku,Kmm) + r_vvl * e3u(ji,jj,iku,Kaa)   ! after scale factor at T-point 
     245            ze3ua =  ( 1._wp - r_vvl ) * e3u(ji,jj,iku,Kmm)    & 
     246               &             + r_vvl   * e3u(ji,jj,iku,Kaa)   ! after scale factor at T-point 
    229247            zwd(ji,jj,iku) = zwd(ji,jj,iku) - rDt * 0.5*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) / ze3ua 
    230248         END_2D 
    … …  
    233251               !!gm   top Cd is masked (=0 outside cavities) no need of test on mik>=2  ==>> it has been suppressed 
    234252               iku = miku(ji,jj)       ! ocean top level at u- and v-points  
    235                ze3ua =  ( 1._wp - r_vvl ) * e3u(ji,jj,iku,Kmm) + r_vvl * e3u(ji,jj,iku,Kaa)   ! after scale factor at T-point 
     253               ze3ua =  ( 1._wp - r_vvl ) * e3u(ji,jj,iku,Kmm)    & 
     254                  &             + r_vvl   * e3u(ji,jj,iku,Kaa)   ! after scale factor at T-point 
    236255               zwd(ji,jj,iku) = zwd(ji,jj,iku) - rDt * 0.5*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) / ze3ua 
    237256            END_2D 
    … …  
    259278      ! 
    260279      DO_2D_00_00 
    261          ze3ua =  ( 1._wp - r_vvl ) * e3u(ji,jj,1,Kmm) + r_vvl * e3u(ji,jj,1,Kaa)  
     280         ze3ua =  ( 1._wp - r_vvl ) * e3u(ji,jj,1,Kmm)    & 
     281            &             + r_vvl   * e3u(ji,jj,1,Kaa)  
    262282         puu(ji,jj,1,Kaa) = puu(ji,jj,1,Kaa) + rDt * 0.5_wp * ( utau_b(ji,jj) + utau(ji,jj) )   & 
    263283            &                                      / ( ze3ua * rho0 ) * umask(ji,jj,1)  
    … …  
    282302         CASE( np_lap_i )           ! rotated lateral mixing: add its vertical mixing (akzv) 
    283303            DO_3D_00_00( 1, jpkm1 ) 
    284                ze3va =  ( 1._wp - r_vvl ) * e3v(ji,jj,jk,Kmm) + r_vvl * e3v(ji,jj,jk,Kaa)   ! after scale factor at V-point 
     304               ze3va =  ( 1._wp - r_vvl ) * e3v(ji,jj,jk,Kmm)    & 
     305                  &             + r_vvl   * e3v(ji,jj,jk,Kaa)   ! after scale factor at V-point 
    285306               zzwi = - zdt * ( avm(ji,jj+1,jk  ) + avm(ji,jj,jk  ) + akzv(ji,jj,jk  ) )   & 
    286307                  &         / ( ze3va * e3vw(ji,jj,jk  ,Kmm) ) * wvmask(ji,jj,jk  ) 
    … …  
    295316         CASE DEFAULT               ! iso-level lateral mixing 
    296317            DO_3D_00_00( 1, jpkm1 ) 
    297                ze3va =  ( 1._wp - r_vvl ) * e3v(ji,jj,jk,Kmm) + r_vvl * e3v(ji,jj,jk,Kaa)   ! after scale factor at V-point 
    298                zzwi = - zdt * ( avm(ji,jj+1,jk  ) + avm(ji,jj,jk  ) ) / ( ze3va * e3vw(ji,jj,jk  ,Kmm) ) * wvmask(ji,jj,jk  ) 
    299                zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) ) / ( ze3va * e3vw(ji,jj,jk+1,Kmm) ) * wvmask(ji,jj,jk+1) 
     318               ze3va =  ( 1._wp - r_vvl ) * e3v(ji,jj,jk,Kmm)    & 
     319                  &             + r_vvl   * e3v(ji,jj,jk,Kaa)   ! after scale factor at V-point 
     320               zzwi = - zdt * ( avm(ji,jj+1,jk  ) + avm(ji,jj,jk  ) )    & 
     321                  &         / ( ze3va * e3vw(ji,jj,jk  ,Kmm) ) * wvmask(ji,jj,jk  ) 
     322               zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) )    & 
     323                  &         / ( ze3va * e3vw(ji,jj,jk+1,Kmm) ) * wvmask(ji,jj,jk+1) 
    300324               zWvi = ( wi(ji,jj,jk  ) + wi(ji,jj+1,jk  ) ) / ze3va 
    301325               zWvs = ( wi(ji,jj,jk+1) + wi(ji,jj+1,jk+1) ) / ze3va 
    … …  
    307331         DO_2D_00_00 
    308332            zwi(ji,jj,1) = 0._wp 
    309             ze3va =  ( 1._wp - r_vvl ) * e3v(ji,jj,1,Kmm) + r_vvl * e3v(ji,jj,1,Kaa) 
    310             zzws = - zdt * ( avm(ji,jj+1,2) + avm(ji,jj,2) ) / ( ze3va * e3vw(ji,jj,2,Kmm) ) * wvmask(ji,jj,2) 
     333            ze3va =  ( 1._wp - r_vvl ) * e3v(ji,jj,1,Kmm)    & 
     334               &             + r_vvl   * e3v(ji,jj,1,Kaa) 
     335            zzws = - zdt * ( avm(ji,jj+1,2) + avm(ji,jj,2) )    & 
     336               &         / ( ze3va * e3vw(ji,jj,2,Kmm) ) * wvmask(ji,jj,2) 
    311337            zWvs = ( wi(ji,jj  ,2) +  wi(ji,jj+1,2) ) / ze3va 
    312338            zws(ji,jj,1 ) = zzws - zdt * MAX( zWvs, 0._wp ) 
    … …  
    317343         CASE( np_lap_i )           ! rotated lateral mixing: add its vertical mixing (akzu) 
    318344            DO_3D_00_00( 1, jpkm1 ) 
    319                ze3va =  ( 1._wp - r_vvl ) * e3v(ji,jj,jk,Kmm) + r_vvl * e3v(ji,jj,jk,Kaa)   ! after scale factor at V-point 
     345               ze3va =  ( 1._wp - r_vvl ) * e3v(ji,jj,jk,Kmm)    & 
     346                  &             + r_vvl   * e3v(ji,jj,jk,Kaa)   ! after scale factor at V-point 
    320347               zzwi = - zdt * ( avm(ji,jj+1,jk  ) + avm(ji,jj,jk  ) + akzv(ji,jj,jk  ) )   & 
    321348                  &         / ( ze3va * e3vw(ji,jj,jk  ,Kmm) ) * wvmask(ji,jj,jk  ) 
    … …  
    328355         CASE DEFAULT               ! iso-level lateral mixing 
    329356            DO_3D_00_00( 1, jpkm1 ) 
    330                ze3va =  ( 1._wp - r_vvl ) * e3v(ji,jj,jk,Kmm) + r_vvl * e3v(ji,jj,jk,Kaa)   ! after scale factor at V-point 
    331                zzwi = - zdt * ( avm(ji,jj+1,jk  ) + avm(ji,jj,jk  ) ) / ( ze3va * e3vw(ji,jj,jk  ,Kmm) ) * wvmask(ji,jj,jk  ) 
    332                zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) ) / ( ze3va * e3vw(ji,jj,jk+1,Kmm) ) * wvmask(ji,jj,jk+1) 
     357               ze3va =  ( 1._wp - r_vvl ) * e3v(ji,jj,jk,Kmm)    & 
     358                  &             + r_vvl   * e3v(ji,jj,jk,Kaa)   ! after scale factor at V-point 
     359               zzwi = - zdt * ( avm(ji,jj+1,jk  ) + avm(ji,jj,jk  ) )    & 
     360                  &         / ( ze3va * e3vw(ji,jj,jk  ,Kmm) ) * wvmask(ji,jj,jk  ) 
     361               zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) )    & 
     362                  &         / ( ze3va * e3vw(ji,jj,jk+1,Kmm) ) * wvmask(ji,jj,jk+1) 
    333363               zwi(ji,jj,jk) = zzwi 
    334364               zws(ji,jj,jk) = zzws 
    … …  
    351381         DO_2D_00_00 
    352382            ikv = mbkv(ji,jj)       ! (deepest ocean u- and v-points) 
    353             ze3va =  ( 1._wp - r_vvl ) * e3v(ji,jj,ikv,Kmm) + r_vvl * e3v(ji,jj,ikv,Kaa)   ! after scale factor at T-point 
     383            ze3va =  ( 1._wp - r_vvl ) * e3v(ji,jj,ikv,Kmm)    & 
     384               &             + r_vvl   * e3v(ji,jj,ikv,Kaa)   ! after scale factor at T-point 
    354385            zwd(ji,jj,ikv) = zwd(ji,jj,ikv) - rDt * 0.5*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) / ze3va            
    355386         END_2D 
    … …  
    357388            DO_2D_00_00 
    358389               ikv = mikv(ji,jj)       ! (first wet ocean u- and v-points) 
    359                ze3va =  ( 1._wp - r_vvl ) * e3v(ji,jj,ikv,Kmm) + r_vvl * e3v(ji,jj,ikv,Kaa)   ! after scale factor at T-point 
     390               ze3va =  ( 1._wp - r_vvl ) * e3v(ji,jj,ikv,Kmm)    & 
     391                  &             + r_vvl   * e3v(ji,jj,ikv,Kaa)   ! after scale factor at T-point 
    360392               zwd(ji,jj,ikv) = zwd(ji,jj,ikv) - rDt * 0.5*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) / ze3va 
    361393            END_2D 
    … …  
    383415      ! 
    384416      DO_2D_00_00 
    385          ze3va =  ( 1._wp - r_vvl ) * e3v(ji,jj,1,Kmm) + r_vvl * e3v(ji,jj,1,Kaa)  
     417         ze3va =  ( 1._wp - r_vvl ) * e3v(ji,jj,1,Kmm)    & 
     418            &             + r_vvl   * e3v(ji,jj,1,Kaa)  
    386419         pvv(ji,jj,1,Kaa) = pvv(ji,jj,1,Kaa) + rDt * 0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) )   & 
    387420            &                                      / ( ze3va * rho0 ) * vmask(ji,jj,1)  

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DYN/sshwzv.F90

    r12489 r13151  
    1 MODULE sshwzv    
     1MODULE sshwzv 
    22   !!============================================================================== 
    33   !!                       ***  MODULE  sshwzv  *** 
    … …  
    55   !!============================================================================== 
    66   !! History :  3.1  !  2009-02  (G. Madec, M. Leclair)  Original code 
    7    !!            3.3  !  2010-04  (M. Leclair, G. Madec)  modified LF-RA  
     7   !!            3.3  !  2010-04  (M. Leclair, G. Madec)  modified LF-RA 
    88   !!             -   !  2010-05  (K. Mogensen, A. Weaver, M. Martin, D. Lea) Assimilation interface 
    99   !!             -   !  2010-09  (D.Storkey and E.O'Dea) bug fixes for BDY module 
    … …  
    2020   USE oce            ! ocean dynamics and tracers variables 
    2121   USE isf_oce        ! ice shelf 
    22    USE dom_oce        ! ocean space and time domain variables  
     22   USE dom_oce        ! ocean space and time domain variables 
    2323   USE sbc_oce        ! surface boundary condition: ocean 
    2424   USE domvvl         ! Variable volume 
    … …  
    3131#endif 
    3232   ! 
    33    USE iom  
     33   USE iom 
    3434   USE in_out_manager ! I/O manager 
    3535   USE restart        ! only for lrst_oce 
    … …  
    5050   !! * Substitutions 
    5151#  include "do_loop_substitute.h90" 
     52#  include "domzgr_substitute.h90" 
     53 
    5254   !!---------------------------------------------------------------------- 
    5355   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    6062      !!---------------------------------------------------------------------- 
    6163      !!                ***  ROUTINE ssh_nxt  *** 
    62       !!                    
     64      !! 
    6365      !! ** Purpose :   compute the after ssh (ssh(Kaa)) 
    6466      !! 
    … …  
    7476      INTEGER                         , INTENT(in   ) ::   Kbb, Kmm, Kaa  ! time level index 
    7577      REAL(wp), DIMENSION(jpi,jpj,jpt), INTENT(inout) ::   pssh           ! sea-surface height 
    76       !  
     78      ! 
    7779      INTEGER  ::   jk      ! dummy loop index 
    7880      REAL(wp) ::   zcoef   ! local scalar 
    … …  
    106108      ! In time-split case we need a first guess of the ssh after (using the baroclinic timestep) in order to 
    107109      ! compute the vertical velocity which can be used to compute the non-linear terms of the momentum equations. 
    108       !  
     110      ! 
    109111      pssh(:,:,Kaa) = (  pssh(:,:,Kbb) - rDt * ( zcoef * ( emp_b(:,:) + emp(:,:) ) + zhdiv(:,:) )  ) * ssmask(:,:) 
    110112      ! 
    111113#if defined key_agrif 
    112       Kbb_a = Kbb; Kmm_a = Kmm; Krhs_a = Kaa; CALL agrif_ssh( kt ) 
     114      Kbb_a = Kbb   ;   Kmm_a = Kmm   ;   Krhs_a = Kaa 
     115      CALL agrif_ssh( kt ) 
    113116#endif 
    114117      ! 
    … …  
    129132   END SUBROUTINE ssh_nxt 
    130133 
    131     
    132    SUBROUTINE wzv( kt, Kbb, Kmm, pww, Kaa ) 
     134 
     135   SUBROUTINE wzv( kt, Kbb, Kmm, Kaa, pww ) 
    133136      !!---------------------------------------------------------------------- 
    134137      !!                ***  ROUTINE wzv  *** 
    135       !!                    
     138      !! 
    136139      !! ** Purpose :   compute the now vertical velocity 
    137140      !! 
    138       !! ** Method  : - Using the incompressibility hypothesis, the vertical  
    139       !!      velocity is computed by integrating the horizontal divergence   
     141      !! ** Method  : - Using the incompressibility hypothesis, the vertical 
     142      !!      velocity is computed by integrating the horizontal divergence 
    140143      !!      from the bottom to the surface minus the scale factor evolution. 
    141144      !!        The boundary conditions are w=0 at the bottom (no flux) and. 
    … …  
    147150      INTEGER                         , INTENT(in)    ::   kt             ! time step 
    148151      INTEGER                         , INTENT(in)    ::   Kbb, Kmm, Kaa  ! time level indices 
    149       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pww            ! now vertical velocity 
     152      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pww            ! vertical velocity at Kmm 
    150153      ! 
    151154      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    … …  
    160163         IF(lwp) WRITE(numout,*) '~~~~~ ' 
    161164         ! 
    162          pww(:,:,jpk) = 0._wp                  ! bottom boundary condition: w=0 (set once for all) 
     165         pww(:,:,jpk) = 0._wp           ! bottom boundary condition: w=0 (set once for all) 
    163166      ENDIF 
    164167      !                                           !------------------------------! 
    … …  
    166169      !                                           !------------------------------! 
    167170      ! 
    168       IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN      ! z_tilde and layer cases 
    169          ALLOCATE( zhdiv(jpi,jpj,jpk) )  
     171      !                                               !===============================! 
     172      IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN      !==  z_tilde and layer cases  ==! 
     173         !                                            !===============================! 
     174         ALLOCATE( zhdiv(jpi,jpj,jpk) ) 
    170175         ! 
    171176         DO jk = 1, jpkm1 
    … …  
    181186         DO jk = jpkm1, 1, -1                       ! integrate from the bottom the hor. divergence 
    182187            ! computation of w 
    183             pww(:,:,jk) = pww(:,:,jk+1) - (  e3t(:,:,jk,Kmm) * hdiv(:,:,jk) + zhdiv(:,:,jk)    & 
    184                &                         + r1_Dt * ( e3t(:,:,jk,Kaa) - e3t(:,:,jk,Kbb) )     ) * tmask(:,:,jk) 
     188            pww(:,:,jk) = pww(:,:,jk+1) - (   e3t(:,:,jk,Kmm) * hdiv(:,:,jk)   & 
     189               &                            +                  zhdiv(:,:,jk)   & 
     190               &                            + r1_Dt * (  e3t(:,:,jk,Kaa)       & 
     191               &                                       - e3t(:,:,jk,Kbb) )   ) * tmask(:,:,jk) 
    185192         END DO 
    186193         !          IF( ln_vvl_layer ) pww(:,:,:) = 0.e0 
    187          DEALLOCATE( zhdiv )  
    188       ELSE   ! z_star and linear free surface cases 
    189          DO jk = jpkm1, 1, -1                       ! integrate from the bottom the hor. divergence 
    190             ! computation of w 
    191             pww(:,:,jk) = pww(:,:,jk+1) - (  e3t(:,:,jk,Kmm) * hdiv(:,:,jk)                 & 
    192                &                         + r1_Dt * ( e3t(:,:,jk,Kaa) - e3t(:,:,jk,Kbb) )  ) * tmask(:,:,jk) 
     194         DEALLOCATE( zhdiv ) 
     195         !                                            !=================================! 
     196      ELSEIF( ln_linssh )   THEN                      !==  linear free surface cases  ==! 
     197         !                                            !=================================! 
     198         DO jk = jpkm1, 1, -1                               ! integrate from the bottom the hor. divergence 
     199            pww(:,:,jk) = pww(:,:,jk+1) - (  e3t(:,:,jk,Kmm) * hdiv(:,:,jk)  ) * tmask(:,:,jk) 
     200         END DO 
     201         !                                            !==========================================! 
     202      ELSE                                            !==  Quasi-Eulerian vertical coordinate  ==!   ('key_qco') 
     203         !                                            !==========================================! 
     204         DO jk = jpkm1, 1, -1                               ! integrate from the bottom the hor. divergence 
     205            pww(:,:,jk) = pww(:,:,jk+1) - (   e3t(:,:,jk,Kmm) * hdiv(:,:,jk)    & 
     206               &                            + r1_Dt * (  e3t(:,:,jk,Kaa)        & 
     207               &                                       - e3t(:,:,jk,Kbb)  )   ) * tmask(:,:,jk) 
    193208         END DO 
    194209      ENDIF 
    … …  
    200215      ENDIF 
    201216      ! 
    202 #if defined key_agrif  
    203       IF( .NOT. AGRIF_Root() ) THEN  
    204          IF ((nbondi ==  1).OR.(nbondi == 2)) pww(nlci-1 , :     ,:) = 0.e0      ! east  
    205          IF ((nbondi == -1).OR.(nbondi == 2)) pww(2      , :     ,:) = 0.e0      ! west  
    206          IF ((nbondj ==  1).OR.(nbondj == 2)) pww(:      ,nlcj-1 ,:) = 0.e0      ! north  
    207          IF ((nbondj == -1).OR.(nbondj == 2)) pww(:      ,2      ,:) = 0.e0      ! south  
    208       ENDIF  
    209 #endif  
     217#if defined key_agrif 
     218      IF( .NOT. AGRIF_Root() ) THEN 
     219         IF ((nbondi ==  1).OR.(nbondi == 2)) pww(nlci-1 , :     ,:) = 0.e0      ! east 
     220         IF ((nbondi == -1).OR.(nbondi == 2)) pww(2      , :     ,:) = 0.e0      ! west 
     221         IF ((nbondj ==  1).OR.(nbondj == 2)) pww(:      ,nlcj-1 ,:) = 0.e0      ! north 
     222         IF ((nbondj == -1).OR.(nbondj == 2)) pww(:      ,2      ,:) = 0.e0      ! south 
     223      ENDIF 
     224#endif 
    210225      ! 
    211226      IF( ln_timing )   CALL timing_stop('wzv') 
    … …  
    214229 
    215230 
    216    SUBROUTINE ssh_atf( kt, Kbb, Kmm, Kaa, pssh ) 
     231   SUBROUTINE ssh_atf( kt, Kbb, Kmm, Kaa, pssh, pssh_f ) 
    217232      !!---------------------------------------------------------------------- 
    218233      !!                    ***  ROUTINE ssh_atf  *** 
    … …  
    229244      !! Reference  : Leclair, M., and G. Madec, 2009, Ocean Modelling. 
    230245      !!---------------------------------------------------------------------- 
    231       INTEGER                         , INTENT(in   ) ::   kt             ! ocean time-step index 
    232       INTEGER                         , INTENT(in   ) ::   Kbb, Kmm, Kaa  ! ocean time level indices 
    233       REAL(wp), DIMENSION(jpi,jpj,jpt), INTENT(inout) ::   pssh           ! SSH field 
     246      INTEGER                                   , INTENT(in   ) ::   kt             ! ocean time-step index 
     247      INTEGER                                   , INTENT(in   ) ::   Kbb, Kmm, Kaa  ! ocean time level indices 
     248      REAL(wp), DIMENSION(jpi,jpj,jpt)          , TARGET, INTENT(inout) ::   pssh           ! SSH field 
     249      REAL(wp), DIMENSION(jpi,jpj    ), OPTIONAL, TARGET, INTENT(  out) ::   pssh_f         ! filtered SSH field 
    234250      ! 
    235251      REAL(wp) ::   zcoef   ! local scalar 
     252      REAL(wp), POINTER, DIMENSION(:,:) ::   zssh   ! pointer for filtered SSH  
    236253      !!---------------------------------------------------------------------- 
    237254      ! 
    … …  
    245262      !              !==  Euler time-stepping: no filter, just swap  ==! 
    246263      IF ( .NOT.( l_1st_euler ) ) THEN   ! Only do time filtering for leapfrog timesteps 
     264         IF( PRESENT( pssh_f ) ) THEN   ;   zssh => pssh_f 
     265         ELSE                           ;   zssh => pssh(:,:,Kmm) 
     266         ENDIF 
    247267         !                                                  ! filtered "now" field 
    248268         pssh(:,:,Kmm) = pssh(:,:,Kmm) + rn_atfp * ( pssh(:,:,Kbb) - 2 * pssh(:,:,Kmm) + pssh(:,:,Kaa) ) 
    … …  
    266286   END SUBROUTINE ssh_atf 
    267287 
     288    
    268289   SUBROUTINE wAimp( kt, Kmm ) 
    269290      !!---------------------------------------------------------------------- 
    270291      !!                ***  ROUTINE wAimp  *** 
    271       !!                    
     292      !! 
    272293      !! ** Purpose :   compute the Courant number and partition vertical velocity 
    273294      !!                if a proportion needs to be treated implicitly 
    274295      !! 
    275       !! ** Method  : -  
     296      !! ** Method  : - 
    276297      !! 
    277298      !! ** action  :   ww      : now vertical velocity (to be handled explicitly) 
    … …  
    279300      !! 
    280301      !! Reference  : Shchepetkin, A. F. (2015): An adaptive, Courant-number-dependent 
    281       !!              implicit scheme for vertical advection in oceanic modeling.  
     302      !!              implicit scheme for vertical advection in oceanic modeling. 
    282303      !!              Ocean Modelling, 91, 38-69. 
    283304      !!---------------------------------------------------------------------- 
    … …  
    306327         DO_3D_00_00( 1, jpkm1 ) 
    307328            z1_e3t = 1._wp / e3t(ji,jj,jk,Kmm) 
    308             ! 2*rn_Dt and not rDt (for restartability) 
    309             Cu_adv(ji,jj,jk) = 2._wp * rn_Dt * ( ( MAX( ww(ji,jj,jk) , 0._wp ) - MIN( ww(ji,jj,jk+1) , 0._wp ) )                       &   
    310                &                             + ( MAX( e2u(ji  ,jj)*e3u(ji  ,jj,jk,Kmm)*uu(ji  ,jj,jk,Kmm) + un_td(ji  ,jj,jk), 0._wp ) -   & 
    311                &                                 MIN( e2u(ji-1,jj)*e3u(ji-1,jj,jk,Kmm)*uu(ji-1,jj,jk,Kmm) + un_td(ji-1,jj,jk), 0._wp ) )   & 
    312                &                               * r1_e1e2t(ji,jj)                                                                     & 
    313                &                             + ( MAX( e1v(ji,jj  )*e3v(ji,jj  ,jk,Kmm)*vv(ji,jj  ,jk,Kmm) + vn_td(ji,jj  ,jk), 0._wp ) -   & 
    314                &                                 MIN( e1v(ji,jj-1)*e3v(ji,jj-1,jk,Kmm)*vv(ji,jj-1,jk,Kmm) + vn_td(ji,jj-1,jk), 0._wp ) )   & 
    315                &                               * r1_e1e2t(ji,jj)                                                                     & 
    316                &                             ) * z1_e3t 
     329            ! 2*rdt and not r2dt (for restartability) 
     330            Cu_adv(ji,jj,jk) =  2._wp * rDt *   & 
     331               &  ( ( MAX( ww(ji,jj,jk) , 0._wp ) - MIN( ww(ji,jj,jk+1) , 0._wp ) )            & 
     332               &  + ( MAX( e2u(ji  ,jj) * e3u(ji  ,jj,jk,Kmm)                                  & 
     333               &                        * uu (ji  ,jj,jk,Kmm) + un_td(ji  ,jj,jk), 0._wp ) -   & 
     334               &      MIN( e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm)                                  & 
     335               &                        * uu (ji-1,jj,jk,Kmm) + un_td(ji-1,jj,jk), 0._wp ) )   & 
     336               &    * r1_e1e2t(ji  ,jj)                                                        & 
     337               &  + ( MAX( e1v(ji,jj  ) * e3v(ji,jj  ,jk,Kmm)                                  & 
     338               &                        * vv (ji,jj  ,jk,Kmm) + vn_td(ji,jj  ,jk), 0._wp ) -   & 
     339               &      MIN( e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm)                                  & 
     340               &                        * vv (ji,jj-1,jk,Kmm) + vn_td(ji,jj-1,jk), 0._wp ) )   & 
     341               &    * r1_e1e2t(ji,jj  )                                                        & 
     342               &  ) * z1_e3t 
    317343         END_3D 
    318344      ELSE 
    319345         DO_3D_00_00( 1, jpkm1 ) 
    320346            z1_e3t = 1._wp / e3t(ji,jj,jk,Kmm) 
    321             ! 2*rn_Dt and not rDt (for restartability) 
    322             Cu_adv(ji,jj,jk) = 2._wp * rn_Dt * ( ( MAX( ww(ji,jj,jk) , 0._wp ) - MIN( ww(ji,jj,jk+1) , 0._wp ) )   &  
    323                &                             + ( MAX( e2u(ji  ,jj)*e3u(ji  ,jj,jk,Kmm)*uu(ji  ,jj,jk,Kmm), 0._wp ) -   & 
    324                &                                 MIN( e2u(ji-1,jj)*e3u(ji-1,jj,jk,Kmm)*uu(ji-1,jj,jk,Kmm), 0._wp ) )   & 
    325                &                               * r1_e1e2t(ji,jj)                                                 & 
    326                &                             + ( MAX( e1v(ji,jj  )*e3v(ji,jj  ,jk,Kmm)*vv(ji,jj  ,jk,Kmm), 0._wp ) -   & 
    327                &                                 MIN( e1v(ji,jj-1)*e3v(ji,jj-1,jk,Kmm)*vv(ji,jj-1,jk,Kmm), 0._wp ) )   & 
    328                &                               * r1_e1e2t(ji,jj)                                                 & 
    329                &                             ) * z1_e3t 
     347            ! 2*rdt and not r2dt (for restartability) 
     348            Cu_adv(ji,jj,jk) =   2._wp * rDt *   & 
     349               &  ( ( MAX( ww(ji,jj,jk) , 0._wp ) - MIN( ww(ji,jj,jk+1) , 0._wp ) )         & 
     350               &  + ( MAX( e2u(ji  ,jj)*e3u(ji  ,jj,jk,Kmm)*uu(ji  ,jj,jk,Kmm), 0._wp ) -   & 
     351               &      MIN( e2u(ji-1,jj)*e3u(ji-1,jj,jk,Kmm)*uu(ji-1,jj,jk,Kmm), 0._wp ) )   & 
     352               &    * r1_e1e2t(ji,jj)                                                       & 
     353               &  + ( MAX( e1v(ji,jj  )*e3v(ji,jj  ,jk,Kmm)*vv(ji,jj  ,jk,Kmm), 0._wp ) -   & 
     354               &      MIN( e1v(ji,jj-1)*e3v(ji,jj-1,jk,Kmm)*vv(ji,jj-1,jk,Kmm), 0._wp ) )   & 
     355               &    * r1_e1e2t(ji,jj)                                                       & 
     356               &  ) * z1_e3t 
    330357         END_3D 
    331358      ENDIF 
    … …  
    339366            zCu = MAX( Cu_adv(ji,jj,jk) , Cu_adv(ji,jj,jk-1) ) 
    340367! alt: 
    341 !                  IF ( ww(ji,jj,jk) > 0._wp ) THEN  
    342 !                     zCu =  Cu_adv(ji,jj,jk)  
     368!                  IF ( ww(ji,jj,jk) > 0._wp ) THEN 
     369!                     zCu =  Cu_adv(ji,jj,jk) 
    343370!                  ELSE 
    344371!                     zCu =  Cu_adv(ji,jj,jk-1) 
    345 !                  ENDIF  
     372!                  ENDIF 
    346373            ! 
    347374            IF( zCu <= Cu_min ) THEN              !<-- Fully explicit 
    … …  
    360387            Cu_adv(ji,jj,jk) = zcff               ! Reuse array to output coefficient below and in stp_ctl 
    361388         END_3D 
    362          Cu_adv(:,:,1) = 0._wp  
     389         Cu_adv(:,:,1) = 0._wp 
    363390      ELSE 
    364391         ! Fully explicit everywhere 
    … …  
    366393         wi    (:,:,:) = 0._wp 
    367394      ENDIF 
    368       CALL iom_put("wimp",wi)  
     395      CALL iom_put("wimp",wi) 
    369396      CALL iom_put("wi_cff",Cu_adv) 
    370397      CALL iom_put("wexp",ww) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DYN/wet_dry.F90

    r12489 r13151  
    3333   !! * Substitutions 
    3434#  include "do_loop_substitute.h90" 
     35#  include "domzgr_substitute.h90" 
    3536   !!---------------------------------------------------------------------- 
    3637   !! critical depths,filters, limiters,and masks for  Wetting and Drying 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/FLO/flo4rk.F90

    r12489 r13151  
    2626   REAL(wp), DIMENSION (3) ::   scoef1 = (/  0.5  ,  0.5  ,  1.0  /)           ! 
    2727 
     28#  include "domzgr_substitute.h90" 
    2829   !!---------------------------------------------------------------------- 
    2930   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/FLO/floblk.F90

    r12489 r13151  
    2020   PUBLIC   flo_blk    ! routine called by floats.F90 
    2121 
     22#  include "domzgr_substitute.h90" 
     23 
    2224   !!---------------------------------------------------------------------- 
    2325   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    24    !! $Id$  
     26   !! $Id$ 
    2527   !! Software governed by the CeCILL license (see ./LICENSE) 
    2628   !!---------------------------------------------------------------------- 
    … …  
    3032      !!--------------------------------------------------------------------- 
    3133      !!                  ***  ROUTINE flo_blk  *** 
    32       !!            
     34      !! 
    3335      !! ** Purpose :   Compute the geographical position,latitude, longitude 
    3436      !!      and depth of each float at each time step. 
    35       !!  
     37      !! 
    3638      !! ** Method  :   The position of a float is computed with Bruno Blanke 
    3739      !!      algorithm. We need to know the velocity field, the old positions 
    … …  
    4749         zuoutfl,zvoutfl,zwoutfl,   &     ! transport across the ouput face 
    4850         zvol,                      &     ! volume of the mesh 
    49          zsurfz,                    &     ! surface of the face of the mesh  
     51         zsurfz,                    &     ! surface of the face of the mesh 
    5052         zind 
    5153 
    … …  
    5355 
    5456      INTEGER  , DIMENSION ( jpnfl )  ::   iil, ijl, ikl                   ! index of nearest mesh 
    55       INTEGER  , DIMENSION ( jpnfl )  ::   iiloc , ijloc               
     57      INTEGER  , DIMENSION ( jpnfl )  ::   iiloc , ijloc 
    5658      INTEGER  , DIMENSION ( jpnfl )  ::   iiinfl, ijinfl, ikinfl          ! index of input mesh of the float. 
    5759      INTEGER  , DIMENSION ( jpnfl )  ::   iioutfl, ijoutfl, ikoutfl       ! index of output mesh of the float. 
    58       REAL(wp) , DIMENSION ( jpnfl )  ::   zgifl, zgjfl, zgkfl             ! position of floats, index on  
     60      REAL(wp) , DIMENSION ( jpnfl )  ::   zgifl, zgjfl, zgkfl             ! position of floats, index on 
    5961      !                                                                         ! velocity mesh. 
    6062      REAL(wp) , DIMENSION ( jpnfl )  ::    ztxfl, ztyfl, ztzfl            ! time for a float to quit the mesh 
    61       !                                                                         ! across one of the face x,y and z  
    62       REAL(wp) , DIMENSION ( jpnfl )  ::    zttfl                          ! time for a float to quit the mesh  
    63       REAL(wp) , DIMENSION ( jpnfl )  ::    zagefl                         ! time during which, trajectorie of  
     63      !                                                                         ! across one of the face x,y and z 
     64      REAL(wp) , DIMENSION ( jpnfl )  ::    zttfl                          ! time for a float to quit the mesh 
     65      REAL(wp) , DIMENSION ( jpnfl )  ::    zagefl                         ! time during which, trajectorie of 
    6466      !                                                                         ! the float has been computed 
    65       REAL(wp) , DIMENSION ( jpnfl )  ::   zagenewfl                       ! new age of float after calculation  
     67      REAL(wp) , DIMENSION ( jpnfl )  ::   zagenewfl                       ! new age of float after calculation 
    6668      !                                                                         ! of new position 
    6769      REAL(wp) , DIMENSION ( jpnfl )  ::   zufl, zvfl, zwfl                ! interpolated vel. at float position 
    … …  
    7779 
    7880      ! Initialisation of parameters 
    79        
     81 
    8082      DO jfl = 1, jpnfl 
    8183         ! ages of floats are put at zero 
    8284         zagefl(jfl) = 0. 
    83          ! index on the velocity grid  
    84          ! We considere k coordinate negative, with this transformation  
    85          ! the computation in the 3 direction is the same.  
     85         ! index on the velocity grid 
     86         ! We considere k coordinate negative, with this transformation 
     87         ! the computation in the 3 direction is the same. 
    8688         zgifl(jfl) = tpifl(jfl) - 0.5 
    8789         zgjfl(jfl) = tpjfl(jfl) - 0.5 
    8890         zgkfl(jfl) = MIN(-1.,-(tpkfl(jfl))) 
    89          ! surface drift every 10 days  
     91         ! surface drift every 10 days 
    9092         IF( ln_argo ) THEN 
    9193            IF( MOD(kt,150) >= 146 .OR. MOD(kt,150) == 0 )  zgkfl(jfl) = -1. 
    … …  
    9698         ikl(jfl) =     INT(zgkfl(jfl)) 
    9799      END DO 
    98         
     100 
    99101      iloop = 0 
    100102222   DO jfl = 1, jpnfl 
    … …  
    104106            iiloc(jfl) = iil(jfl) - mig(1) + 1 
    105107            ijloc(jfl) = ijl(jfl) - mjg(1) + 1 
    106 # else  
     108# else 
    107109            iiloc(jfl) = iil(jfl) 
    108110            ijloc(jfl) = ijl(jfl) 
    109111# endif 
    110              
    111             ! compute the transport across the mesh where the float is.             
    112 !!bug (gm) change e3t into e3. but never checked  
    113             zsurfx(1) = e2u(iiloc(jfl)-1,ijloc(jfl)  ) * e3u(iiloc(jfl)-1,ijloc(jfl)  ,-ikl(jfl),Kmm) 
    114             zsurfx(2) = e2u(iiloc(jfl)  ,ijloc(jfl)  ) * e3u(iiloc(jfl)  ,ijloc(jfl)  ,-ikl(jfl),Kmm) 
    115             zsurfy(1) = e1v(iiloc(jfl)  ,ijloc(jfl)-1) * e3v(iiloc(jfl)  ,ijloc(jfl)-1,-ikl(jfl),Kmm) 
    116             zsurfy(2) = e1v(iiloc(jfl)  ,ijloc(jfl)  ) * e3v(iiloc(jfl)  ,ijloc(jfl)  ,-ikl(jfl),Kmm) 
     112 
     113            ! compute the transport across the mesh where the float is. 
     114!!bug (gm) change e3t into e3. but never checked 
     115            zsurfx(1) =   & 
     116            &   e2u(iiloc(jfl)-1,ijloc(jfl)  )    & 
     117            & * e3u(iiloc(jfl)-1,ijloc(jfl)  ,-ikl(jfl),Kmm) 
     118            zsurfx(2) =   & 
     119            &   e2u(iiloc(jfl)  ,ijloc(jfl)  )    & 
     120            & * e3u(iiloc(jfl)  ,ijloc(jfl)  ,-ikl(jfl),Kmm) 
     121            zsurfy(1) =   & 
     122            &   e1v(iiloc(jfl)  ,ijloc(jfl)-1)    & 
     123            & * e3v(iiloc(jfl)  ,ijloc(jfl)-1,-ikl(jfl),Kmm) 
     124            zsurfy(2) =   & 
     125            &   e1v(iiloc(jfl)  ,ijloc(jfl)  )    & 
     126            & * e3v(iiloc(jfl)  ,ijloc(jfl)  ,-ikl(jfl),Kmm) 
    117127 
    118128            ! for a isobar float zsurfz is put to zero. The vertical velocity will be zero too. 
    … …  
    129139            zwoutfl=-(wb(iiloc(jfl),ijloc(jfl),- ikl(jfl)   )   & 
    130140               &   +  ww(iiloc(jfl),ijloc(jfl),- ikl(jfl)   ) )/2. *  zsurfz*nisobfl(jfl) 
    131              
    132             ! interpolation of velocity field on the float initial position             
     141 
     142            ! interpolation of velocity field on the float initial position 
    133143            zufl(jfl)=  zuinfl  + ( zgifl(jfl) - float(iil(jfl)-1) ) * ( zuoutfl - zuinfl) 
    134144            zvfl(jfl)=  zvinfl  + ( zgjfl(jfl) - float(ijl(jfl)-1) ) * ( zvoutfl - zvinfl) 
    135145            zwfl(jfl)=  zwinfl  + ( zgkfl(jfl) - float(ikl(jfl)-1) ) * ( zwoutfl - zwinfl) 
    136              
     146 
    137147            ! faces of input and output 
    138148            ! u-direction 
    … …  
    147157               iiinfl (jfl) = iil(jfl) - 1 
    148158            ENDIF 
    149             ! v-direction        
     159            ! v-direction 
    150160            IF( zvfl(jfl) < 0. ) THEN 
    151161               ijoutfl(jfl) = ijl(jfl) - 1. 
    … …  
    169179               ikinfl (jfl) = ikl(jfl) - 1. 
    170180            ENDIF 
    171              
     181 
    172182            ! compute the time to go out the mesh across a face 
    173183            ! u-direction 
    … …  
    175185            zgidfl(jfl) = float(iioutfl(jfl) - iiinfl(jfl)) 
    176186            IF( zufl(jfl)*zuoutfl <= 0. ) THEN 
    177                ztxfl(jfl) = 1.E99 
     187               ztxfl(jfl) = HUGE(1._wp) 
    178188            ELSE 
    179189               IF( ABS(zudfl(jfl)) >= 1.E-5 ) THEN 
    … …  
    191201            zgjdfl(jfl) = float(ijoutfl(jfl)-ijinfl(jfl)) 
    192202            IF( zvfl(jfl)*zvoutfl <= 0. ) THEN 
    193                ztyfl(jfl) = 1.E99 
     203               ztyfl(jfl) = HUGE(1._wp) 
    194204            ELSE 
    195205               IF( ABS(zvdfl(jfl)) >= 1.E-5 ) THEN 
    … …  
    203213               ENDIF 
    204214            ENDIF 
    205             ! w-direction         
    206             IF( nisobfl(jfl) == 1. ) THEN  
     215            ! w-direction 
     216            IF( nisobfl(jfl) == 1. ) THEN 
    207217               zwdfl (jfl) = zwoutfl - zwinfl 
    208218               zgkdfl(jfl) = float(ikoutfl(jfl) - ikinfl(jfl)) 
    209219               IF( zwfl(jfl)*zwoutfl <= 0. ) THEN 
    210                   ztzfl(jfl) = 1.E99 
     220                  ztzfl(jfl) = HUGE(1._wp) 
    211221               ELSE 
    212222                  IF( ABS(zwdfl(jfl)) >= 1.E-5 ) THEN 
    … …  
    221231               ENDIF 
    222232            ENDIF 
    223              
     233 
    224234            ! the time to go leave the mesh is the smallest time 
    225                     
    226             IF( nisobfl(jfl) == 1. ) THEN  
     235 
     236            IF( nisobfl(jfl) == 1. ) THEN 
    227237               zttfl(jfl) = MIN(ztxfl(jfl),ztyfl(jfl),ztzfl(jfl)) 
    228238            ELSE 
    … …  
    231241            ! new age of the FLOAT 
    232242            zagenewfl(jfl) = zagefl(jfl) + zttfl(jfl)*zvol 
    233             ! test to know if the "age" of the float is not bigger than the  
     243            ! test to know if the "age" of the float is not bigger than the 
    234244            ! time step 
    235245            IF( zagenewfl(jfl) > rn_Dt ) THEN 
    … …  
    237247               zagenewfl(jfl) = rn_Dt 
    238248            ENDIF 
    239              
     249 
    240250            ! In the "minimal" direction we compute the index of new mesh 
    241251            ! on i-direction 
    … …  
    250260               iiinfl(jfl) = ind 
    251261            ELSE 
    252                IF( ABS(zudfl(jfl)) >= 1.E-5 ) THEN  
     262               IF( ABS(zudfl(jfl)) >= 1.E-5 ) THEN 
    253263                  zgifl(jfl) = zgifl(jfl) + zgidfl(jfl)*zufl(jfl)    & 
    254264                     &       * ( EXP( zudfl(jfl)/zgidfl(jfl)*zttfl(jfl) ) - 1. ) /  zudfl(jfl) 
    … …  
    268278               ijinfl(jfl) = ind 
    269279            ELSE 
    270                IF( ABS(zvdfl(jfl)) >= 1.E-5 ) THEN  
     280               IF( ABS(zvdfl(jfl)) >= 1.E-5 ) THEN 
    271281                  zgjfl(jfl) = zgjfl(jfl)+zgjdfl(jfl)*zvfl(jfl)   & 
    272282                     &       * ( EXP(zvdfl(jfl)/zgjdfl(jfl)*zttfl(jfl)) - 1. ) /  zvdfl(jfl) 
    … …  
    287297                  ikinfl(jfl) = ind 
    288298               ELSE 
    289                   IF( ABS(zwdfl(jfl)) >= 1.E-5 ) THEN  
     299                  IF( ABS(zwdfl(jfl)) >= 1.E-5 ) THEN 
    290300                     zgkfl(jfl) = zgkfl(jfl)+zgkdfl(jfl)*zwfl(jfl)    & 
    291301                        &       * ( EXP(zwdfl(jfl)/zgkdfl(jfl)*zttfl(jfl)) - 1. ) /  zwdfl(jfl) 
    … …  
    295305               ENDIF 
    296306            ENDIF 
    297              
     307 
    298308            ! coordinate of the new point on the temperature grid 
    299              
     309 
    300310            iil(jfl) = MAX(iiinfl(jfl),iioutfl(jfl)) 
    301311            ijl(jfl) = MAX(ijinfl(jfl),ijoutfl(jfl)) 
    … …  
    306316!!Alexcadm     .    ikoutfl(jfl),ztxfl(jfl),ztyfl(jfl) 
    307317!!Alexcadm     .     ,ztzfl(jfl),zgifl(jfl), 
    308 !!Alexcadm     .  zgjfl(jfl)  
     318!!Alexcadm     .  zgjfl(jfl) 
    309319!!Alexcadm  IF (jfl == 910) write(*,*)'Flotteur 910', 
    310320!!Alexcadm     .    iiinfl(jfl),iioutfl(jfl),ijinfl(jfl) 
    … …  
    312322!!Alexcadm     .    ikoutfl(jfl),ztxfl(jfl),ztyfl(jfl) 
    313323!!Alexcadm     .     ,ztzfl(jfl),zgifl(jfl), 
    314 !!Alexcadm     .  zgjfl(jfl)  
     324!!Alexcadm     .  zgjfl(jfl) 
    315325            ! reinitialisation of the age of FLOAT 
    316326            zagefl(jfl) = zagenewfl(jfl) 
    … …  
    327337# endif 
    328338      END DO 
    329        
     339 
    330340      ! synchronisation 
    331341      CALL mpp_sum( 'floblk', zgifl , jpnfl )   ! sums over the global domain 
    … …  
    335345      CALL mpp_sum( 'floblk', iil   , jpnfl ) 
    336346      CALL mpp_sum( 'floblk', ijl   , jpnfl ) 
    337        
     347 
    338348      ! Test to know if a  float hasn't integrated enought time 
    339349      IF( ln_argo ) THEN 
    … …  
    361371!!Alexcadm     .       tpkfl(jpnfl),zufl(jpnfl),zvfl(jpnfl),zwfl(jpnfl) 
    362372      IF( ifin == 0 ) THEN 
    363          iloop = iloop + 1  
     373         iloop = iloop + 1 
    364374         GO TO 222 
    365375      ENDIF 
    … …  
    369379 
    370380   !!====================================================================== 
    371 END MODULE floblk  
     381END MODULE floblk 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/IOM/iom.F90

    r12489 r13151  
    111111      CHARACTER(len=lc) :: clname 
    112112      INTEGER             :: irefyear, irefmonth, irefday 
    113       INTEGER           :: ji, jkmin 
     113      INTEGER           :: ji 
    114114      LOGICAL :: llrst_context              ! is context related to restart 
    115115      ! 
    … …  
    220220           
    221221          ! Add vertical grid bounds 
    222           jkmin = MIN(2,jpk)  ! in case jpk=1 (i.e. sas2D) 
    223           zt_bnds(2,:        ) = gdept_1d(:) 
    224           zt_bnds(1,jkmin:jpk) = gdept_1d(1:jpkm1) 
    225           zt_bnds(1,1        ) = gdept_1d(1) - e3w_1d(1) 
    226           zw_bnds(1,:        ) = gdepw_1d(:) 
    227           zw_bnds(2,1:jpkm1  ) = gdepw_1d(jkmin:jpk) 
    228           zw_bnds(2,jpk:     ) = gdepw_1d(jpk) + e3t_1d(jpk) 
     222          zt_bnds(2,:      ) = gdept_1d(:) 
     223          zt_bnds(1,2:jpk  ) = gdept_1d(1:jpkm1) 
     224          zt_bnds(1,1      ) = gdept_1d(1) - e3w_1d(1) 
     225          zw_bnds(1,:      ) = gdepw_1d(:) 
     226          zw_bnds(2,1:jpkm1) = gdepw_1d(2:jpk) 
     227          zw_bnds(2,jpk:   ) = gdepw_1d(jpk) + e3t_1d(jpk) 
    229228          CALL iom_set_axis_attr(  "deptht", bounds=zw_bnds ) 
    230229          CALL iom_set_axis_attr(  "depthu", bounds=zw_bnds ) 
    … …  
    665664 
    666665 
    667    SUBROUTINE iom_open( cdname, kiomid, ldwrt, kdom, ldstop, ldiof, kdlev ) 
     666   SUBROUTINE iom_open( cdname, kiomid, ldwrt, kdom, ldstop, ldiof, kdlev, cdcomp ) 
    668667      !!--------------------------------------------------------------------- 
    669668      !!                   ***  SUBROUTINE  iom_open  *** 
    … …  
    678677      LOGICAL         , INTENT(in   ), OPTIONAL ::   ldiof    ! Interp On the Fly, needed for AGRIF (default = .FALSE.) 
    679678      INTEGER         , INTENT(in   ), OPTIONAL ::   kdlev    ! number of vertical levels 
     679      CHARACTER(len=3), INTENT(in   ), OPTIONAL ::   cdcomp   ! name of component calling iom_nf90_open 
    680680      ! 
    681681      CHARACTER(LEN=256)    ::   clname    ! the name of the file based on cdname [[+clcpu]+clcpu] 
    … …  
    823823      ENDIF 
    824824      IF( istop == nstop ) THEN   ! no error within this routine 
    825          CALL iom_nf90_open( clname, kiomid, llwrt, llok, idompar, kdlev = kdlev ) 
     825         CALL iom_nf90_open( clname, kiomid, llwrt, llok, idompar, kdlev = kdlev, cdcomp = cdcomp ) 
    826826      ENDIF 
    827827      ! 
    … …  
    13851385      REAL(wp), DIMENSION(jpi,jpj) ::   z2d  
    13861386#if defined key_iomput 
    1387       IF( xios_field_is_active( cdname, at_current_timestep_arg = .TRUE. ) ) THEN 
    1388          z2d(:,:) = 0._wp 
    1389          CALL xios_recv_field( cdname, z2d) 
    1390       ENDIF 
     1387!!an juste pour compiler xios2.0 
     1388!      IF( xios_field_is_active( cdname, at_current_timestep_arg = .TRUE. ) ) THEN 
     1389!         z2d(:,:) = 0._wp 
     1390!         CALL xios_recv_field( cdname, z2d) 
     1391!      ENDIF 
     1392!!an  
    13911393#else 
    13921394      IF( .FALSE. )   WRITE(numout,*) cdname, z2d ! useless test to avoid compilation warnings 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/IOM/iom_def.F90

    r12377 r13151  
    5050   TYPE, PUBLIC ::   file_descriptor 
    5151      CHARACTER(LEN=240)                        ::   name     !: name of the file 
     52      CHARACTER(LEN=3  )                        ::   comp     !: name of component opening the file ('OCE', 'ICE'...) 
    5253      INTEGER                                   ::   nfid     !: identifier of the file (0 if closed) 
    5354                                                              !: jpioipsl option has been removed) 
    … …  
    6465      REAL(kind=wp), DIMENSION(jpmax_vars)      ::   scf      !: scale_factor of the variables 
    6566      REAL(kind=wp), DIMENSION(jpmax_vars)      ::   ofs      !: add_offset of the variables 
    66       INTEGER                                   ::   nlev     ! number of vertical levels 
    6767   END TYPE file_descriptor 
    6868   TYPE(file_descriptor), DIMENSION(jpmax_files), PUBLIC ::   iom_file !: array containing the info for all opened files 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/IOM/iom_nf90.F90

    r12377 r13151  
    1919   !!---------------------------------------------------------------------- 
    2020   USE dom_oce         ! ocean space and time domain 
    21    USE sbc_oce, ONLY: jpka, ght_abl ! abl vertical level number and height 
     21   USE sbc_oce, ONLY: ght_abl ! abl vertical level number and height 
    2222   USE lbclnk          ! lateal boundary condition / mpp exchanges 
    2323   USE iom_def         ! iom variables definitions 
    … …  
    4646CONTAINS 
    4747 
    48    SUBROUTINE iom_nf90_open( cdname, kiomid, ldwrt, ldok, kdompar, kdlev ) 
     48   SUBROUTINE iom_nf90_open( cdname, kiomid, ldwrt, ldok, kdompar, kdlev, cdcomp ) 
    4949      !!--------------------------------------------------------------------- 
    5050      !!                   ***  SUBROUTINE  iom_open  *** 
    … …  
    5858      INTEGER, DIMENSION(2,5), INTENT(in   ), OPTIONAL ::   kdompar     ! domain parameters:  
    5959      INTEGER                , INTENT(in   ), OPTIONAL ::   kdlev       ! size of the ice/abl third dimension 
     60      CHARACTER(len=3)       , INTENT(in   ), OPTIONAL ::   cdcomp      ! name of component calling iom_nf90_open 
    6061 
    6162      CHARACTER(LEN=256) ::   clinfo           ! info character 
    6263      CHARACTER(LEN=256) ::   cltmp            ! temporary character 
     64      CHARACTER(LEN=3  ) ::   clcomp           ! name of component calling iom_nf90_open 
    6365      INTEGER            ::   iln              ! lengths of character 
    6466      INTEGER            ::   istop            ! temporary storage of nstop 
    … …  
    7072      INTEGER            ::   ihdf5            ! local variable for retrieval of value for NF90_HDF5 
    7173      LOGICAL            ::   llclobber        ! local definition of ln_clobber 
    72       INTEGER            ::   ilevels          ! vertical levels 
    7374      !--------------------------------------------------------------------- 
    7475      ! 
    … …  
    7778      ! 
    7879      !                 !number of vertical levels 
    79       IF( PRESENT(kdlev) )   THEN   ;   ilevels = kdlev    ! use input value (useful for sea-ice and abl) 
    80       ELSE                          ;   ilevels = jpk      ! by default jpk 
     80      IF( PRESENT(cdcomp) )   THEN 
     81         IF( .NOT. PRESENT(kdlev) ) CALL ctl_stop( 'iom_nf90_open: cdcomp and kdlev must both be present' ) 
     82         clcomp = cdcomp    ! use input value 
     83      ELSE 
     84         clcomp = 'OCE'     ! by default  
    8185      ENDIF 
    8286      ! 
    … …  
    125129            CALL iom_nf90_check(NF90_SET_FILL( if90id, NF90_NOFILL,                   idmy ), clinfo) 
    126130            ! define dimensions 
    127             CALL iom_nf90_check(NF90_DEF_DIM( if90id,            'x',   kdompar(1,1), idmy ), clinfo) 
    128             CALL iom_nf90_check(NF90_DEF_DIM( if90id,            'y',   kdompar(2,1), idmy ), clinfo) 
    129             IF( PRESENT(kdlev) ) THEN 
    130               IF( kdlev == jpka ) THEN 
    131                  CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'nav_lev',          kdlev, idmy ), clinfo) 
    132                  CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'time_counter', NF90_UNLIMITED, idmy ), clinfo) 
    133               ELSE 
    134                  CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'nav_lev',            jpk, idmy ), clinfo) 
    135                  CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'time_counter', NF90_UNLIMITED, idmy ), clinfo) 
    136                  CALL iom_nf90_check(NF90_DEF_DIM( if90id,  'numcat',          kdlev, idmy ), clinfo) 
    137               ENDIF 
    138             ELSE 
    139                CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'nav_lev',            jpk, idmy ), clinfo) 
    140                CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'time_counter', NF90_UNLIMITED, idmy ), clinfo) 
    141             ENDIF 
     131                               CALL iom_nf90_check(NF90_DEF_DIM( if90id,            'x',   kdompar(1,1), idmy ), clinfo) 
     132                               CALL iom_nf90_check(NF90_DEF_DIM( if90id,            'y',   kdompar(2,1), idmy ), clinfo) 
     133            SELECT CASE (clcomp) 
     134            CASE ('OCE')   ;   CALL iom_nf90_check(NF90_DEF_DIM( if90id,      'nav_lev',            jpk, idmy ), clinfo) 
     135            CASE ('ICE')   ;   CALL iom_nf90_check(NF90_DEF_DIM( if90id,       'numcat',          kdlev, idmy ), clinfo) 
     136            CASE ('ABL')   ;   CALL iom_nf90_check(NF90_DEF_DIM( if90id,      'nav_lev',          kdlev, idmy ), clinfo) 
     137            CASE ('SED')   ;   CALL iom_nf90_check(NF90_DEF_DIM( if90id,       'numsed',          kdlev, idmy ), clinfo) 
     138            CASE DEFAULT   ;   CALL ctl_stop( 'iom_nf90_open unknown component type' ) 
     139            END SELECT 
     140                               CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'time_counter', NF90_UNLIMITED, idmy ), clinfo) 
    142141            ! global attributes 
    143142            CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_number_total'   , jpnij              ), clinfo) 
    … …  
    165164         ENDDO 
    166165         iom_file(kiomid)%name   = TRIM(cdname) 
     166         iom_file(kiomid)%comp   = clcomp 
    167167         iom_file(kiomid)%nfid   = if90id 
    168168         iom_file(kiomid)%nvars  = 0 
    169169         iom_file(kiomid)%irec   = -1   ! useless for NetCDF files, used to know if the file is in define mode  
    170          iom_file(kiomid)%nlev   = ilevels 
    171170         CALL iom_nf90_check(NF90_Inquire(if90id, unlimitedDimId = iom_file(kiomid)%iduld), clinfo) 
    172171         IF( iom_file(kiomid)%iduld .GE. 0 ) THEN 
    … …  
    529528      INTEGER, DIMENSION(4) :: idimid               ! dimensions id 
    530529      CHARACTER(LEN=256)    :: clinfo               ! info character 
    531       CHARACTER(LEN= 12), DIMENSION(5) :: cltmp     ! temporary character 
    532530      INTEGER               :: if90id               ! nf90 file identifier 
    533       INTEGER               :: idmy                 ! dummy variable 
    534531      INTEGER               :: itype                ! variable type 
    535532      INTEGER, DIMENSION(4) :: ichunksz             ! NetCDF4 chunk sizes. Will be computed using 
    … …  
    540537      !                                             ! when appropriate (currently chunking is applied to 4d fields only) 
    541538      INTEGER               :: idlv                 ! local variable 
    542       INTEGER               :: idim3                ! id of the third dimension 
    543539      !--------------------------------------------------------------------- 
    544540      ! 
    … …  
    554550         ENDIF 
    555551         ! define the dimension variables if it is not already done 
    556          ! Warning: we must use the same character length in an array constructor (at least for gcc compiler) 
    557          cltmp = (/ 'nav_lon     ', 'nav_lat     ', 'nav_lev     ', 'time_counter', 'numcat      ' /)    
    558          CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cltmp(1)), NF90_FLOAT , (/ 1, 2 /), iom_file(kiomid)%nvid(1) ), clinfo) 
    559          CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cltmp(2)), NF90_FLOAT , (/ 1, 2 /), iom_file(kiomid)%nvid(2) ), clinfo) 
    560          CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cltmp(3)), NF90_FLOAT , (/ 3    /), iom_file(kiomid)%nvid(3) ), clinfo) 
    561          CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cltmp(4)), NF90_DOUBLE, (/ 4    /), iom_file(kiomid)%nvid(4) ), clinfo) 
     552         DO jd = 1, 2 
     553            CALL iom_nf90_check(NF90_INQUIRE_DIMENSION(if90id,jd,iom_file(kiomid)%cn_var(jd),iom_file(kiomid)%dimsz(jd,jd)),clinfo) 
     554            CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(iom_file(kiomid)%cn_var(jd)), NF90_FLOAT , (/ 1, 2 /),   & 
     555               &                              iom_file(kiomid)%nvid(jd) ), clinfo) 
     556         END DO 
     557         iom_file(kiomid)%dimsz(2,1) = iom_file(kiomid)%dimsz(2,2)   ! second dim of first  variable 
     558         iom_file(kiomid)%dimsz(1,2) = iom_file(kiomid)%dimsz(1,1)   ! first  dim of second variable 
     559         DO jd = 3, 4 
     560            CALL iom_nf90_check(NF90_INQUIRE_DIMENSION(if90id,jd,iom_file(kiomid)%cn_var(jd),iom_file(kiomid)%dimsz(1,jd)), clinfo) 
     561            CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(iom_file(kiomid)%cn_var(jd)), NF90_FLOAT , (/ jd   /),   & 
     562               &                              iom_file(kiomid)%nvid(jd) ), clinfo) 
     563         END DO 
    562564         ! update informations structure related the dimension variable we just added... 
    563565         iom_file(kiomid)%nvars       = 4 
    564566         iom_file(kiomid)%luld(1:4)   = (/ .FALSE., .FALSE., .FALSE., .TRUE. /) 
    565          iom_file(kiomid)%cn_var(1:4) = cltmp(1:4) 
    566567         iom_file(kiomid)%ndims(1:4)  = (/ 2, 2, 1, 1 /) 
    567          IF( NF90_INQ_DIMID( if90id, 'numcat', idmy ) == nf90_noerr ) THEN   ! add a 5th variable corresponding to the 5th dimension 
    568             CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cltmp(5)), NF90_FLOAT , (/ 5 /), iom_file(kiomid)%nvid(5) ), clinfo) 
    569             iom_file(kiomid)%nvars     = 5 
    570             iom_file(kiomid)%luld(5)   = .FALSE. 
    571             iom_file(kiomid)%cn_var(5) = cltmp(5) 
    572             iom_file(kiomid)%ndims(5)  = 1 
    573          ENDIF 
    574          ! trick: defined to 0 to say that dimension variables are defined but not yet written 
    575          iom_file(kiomid)%dimsz(1, 1)  = 0    
    576568         IF(lwp) WRITE(numout,*) TRIM(clinfo)//' define dimension variables done' 
    577569      ENDIF 
    … …  
    594586         IF(     PRESENT(pv_r0d) ) THEN   ;   idims = 0 
    595587         ELSEIF( PRESENT(pv_r1d) ) THEN 
    596             IF(( SIZE(pv_r1d,1) == jpk ).OR.( SIZE(pv_r1d,1) == jpka )) THEN   ;   idim3 = 3 
    597             ELSE                                                               ;   idim3 = 5 
    598             ENDIF 
    599                                               idims = 2   ;   idimid(1:idims) = (/idim3,4/) 
    600          ELSEIF( PRESENT(pv_r2d) ) THEN   ;   idims = 3   ;   idimid(1:idims) = (/1,2  ,4/) 
     588                                              idims = 2   ;   idimid(1:idims) = (/3,4/) 
     589         ELSEIF( PRESENT(pv_r2d) ) THEN   ;   idims = 3   ;   idimid(1:idims) = (/1,2,4/) 
    601590         ELSEIF( PRESENT(pv_r3d) ) THEN 
    602             IF(( SIZE(pv_r3d,3) == jpk ).OR.( SIZE(pv_r3d,3) == jpka )) THEN   ;   idim3 = 3 
    603             ELSE                                                               ;   idim3 = 5 
    604             ENDIF 
    605                                               idims = 4   ;   idimid(1:idims) = (/1,2,idim3,4/) 
     591                                              idims = 4   ;   idimid(1:idims) = (/1,2,3,4/) 
    606592         ENDIF 
    607593         IF( PRESENT(ktype) ) THEN   ! variable external type 
    … …  
    678664            ! ============= 
    679665            ! trick: is defined to 0 => dimension variable are defined but not yet written 
    680             IF( iom_file(kiomid)%dimsz(1, 1) == 0 ) THEN 
    681                CALL iom_nf90_check( NF90_INQ_VARID( if90id, 'nav_lon'     , idmy )         , clinfo ) 
    682                CALL iom_nf90_check( NF90_PUT_VAR  ( if90id, idmy, glamt(ix1:ix2, iy1:iy2) ), clinfo ) 
    683                CALL iom_nf90_check( NF90_INQ_VARID( if90id, 'nav_lat'     , idmy )         , clinfo ) 
    684                CALL iom_nf90_check( NF90_PUT_VAR  ( if90id, idmy, gphit(ix1:ix2, iy1:iy2) ), clinfo ) 
    685                CALL iom_nf90_check( NF90_INQ_VARID( if90id, 'nav_lev'     , idmy ), clinfo ) 
    686                IF (iom_file(kiomid)%nlev == jpka) THEN   ;   CALL iom_nf90_check( NF90_PUT_VAR  ( if90id, idmy,  ght_abl), clinfo ) 
    687                ELSE                                      ;   CALL iom_nf90_check( NF90_PUT_VAR  ( if90id, idmy, gdept_1d), clinfo ) 
    688                ENDIF 
    689                IF( NF90_INQ_VARID( if90id, 'numcat', idmy ) == nf90_noerr ) THEN 
    690                   CALL iom_nf90_check( NF90_PUT_VAR  ( if90id, idmy, (/ (idlv, idlv = 1,iom_file(kiomid)%nlev) /)), clinfo ) 
    691                ENDIF 
    692                ! +++ WRONG VALUE: to be improved but not really useful... 
    693                CALL iom_nf90_check( NF90_INQ_VARID( if90id, 'time_counter', idmy ), clinfo ) 
    694                CALL iom_nf90_check( NF90_PUT_VAR( if90id, idmy, kt                      ), clinfo )    
    695                ! update the values of the variables dimensions size 
    696                CALL iom_nf90_check( NF90_INQUIRE_DIMENSION( if90id, 1, len = iom_file(kiomid)%dimsz(1,1) ), clinfo ) 
    697                CALL iom_nf90_check( NF90_INQUIRE_DIMENSION( if90id, 2, len = iom_file(kiomid)%dimsz(2,1) ), clinfo ) 
    698                iom_file(kiomid)%dimsz(1:2, 2) = iom_file(kiomid)%dimsz(1:2, 1) 
    699                CALL iom_nf90_check( NF90_INQUIRE_DIMENSION( if90id, 3, len = iom_file(kiomid)%dimsz(1,3) ), clinfo ) 
    700                iom_file(kiomid)%dimsz(1  , 4) = 1   ! unlimited dimension 
     666            IF( iom_file(kiomid)%dimsz(1, 4) == 0 ) THEN   ! time_counter = 0 
     667               CALL iom_nf90_check(    NF90_PUT_VAR( if90id, 1,                            glamt(ix1:ix2, iy1:iy2) ), clinfo ) 
     668               CALL iom_nf90_check(    NF90_PUT_VAR( if90id, 2,                            gphit(ix1:ix2, iy1:iy2) ), clinfo ) 
     669               SELECT CASE (iom_file(kiomid)%comp) 
     670               CASE ('OCE')   
     671                  CALL iom_nf90_check( NF90_PUT_VAR( if90id, 3,                                           gdept_1d ), clinfo ) 
     672               CASE ('ABL') 
     673                  CALL iom_nf90_check( NF90_PUT_VAR( if90id, 3,                                            ght_abl ), clinfo ) 
     674               CASE DEFAULT 
     675                  CALL iom_nf90_check( NF90_PUT_VAR( if90id, 3, (/ (idlv, idlv = 1,iom_file(kiomid)%dimsz(1,3)) /) ), clinfo ) 
     676               END SELECT 
     677               ! "wrong" value: to be improved but not really useful... 
     678               CALL iom_nf90_check(   NF90_PUT_VAR( if90id, 4,                                                  kt ), clinfo )    
     679               ! update the size of the variable corresponding to the unlimited dimension 
     680               iom_file(kiomid)%dimsz(1, 4) = 1   ! so we don't enter this IF case any more... 
    701681               IF(lwp) WRITE(numout,*) TRIM(clinfo)//' write dimension variables done' 
    702682            ENDIF 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/IOM/restart.F90

    r12489 r13151  
    291291      ! 
    292292      IF( l_1st_euler ) THEN                                  ! Euler restart  
    293          ts   (:,:,:,:,Kbb) = ts   (:,:,:,:,Kmm)              ! all before fields set to now values 
    294          uu   (:,:,:  ,Kbb) = uu   (:,:,:  ,Kmm) 
    295          vv   (:,:,:  ,Kbb) = vv   (:,:,:  ,Kmm) 
    296          ssh  (:,:    ,Kbb) = ssh  (:,:    ,Kmm) 
    297          ! 
    298          IF( .NOT.ln_linssh ) THEN 
    299             DO jk = 1, jpk 
    300                e3t(:,:,jk,Kbb) = e3t(:,:,jk,Kmm) 
    301             END DO 
    302          ENDIF 
    303          ! 
     293         ts (:,:,:,:,Kbb) = ts (:,:,:,:,Kmm)                  ! all before fields set to now values 
     294         uu (:,:,:  ,Kbb) = uu (:,:,:  ,Kmm) 
     295         vv (:,:,:  ,Kbb) = vv (:,:,:  ,Kmm) 
     296         ssh(:,:    ,Kbb) = ssh(:,:    ,Kmm) 
    304297      ENDIF 
    305298      ! 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/ISF/isfcavgam.F90

    r12077 r13151  
    2929   ! 
    3030   PUBLIC   isfcav_gammats 
    31  
     31    
     32#  include "domzgr_substitute.h90" 
    3233   !!---------------------------------------------------------------------- 
    3334   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/ISF/isfcpl.F90

    r12489 r13151  
    1515   USE isfutils, ONLY : debug 
    1616   USE lib_mpp , ONLY: mpp_sum, mpp_max ! mpp routine 
     17#if ! defined key_qco 
    1718   USE domvvl  , ONLY: dom_vvl_zgr      ! vertical scale factor interpolation 
     19#else 
     20   USE domqco   , ONLY: dom_qco_zgr      ! vertical scale factor interpolation 
     21#endif 
    1822   USE domngb  , ONLY: dom_ngb          ! find the closest grid point from a given lon/lat position 
    1923   ! 
    … …  
    4347   !! * Substitutions 
    4448#  include "do_loop_substitute.h90" 
     49#  include "domzgr_substitute.h90" 
    4550   !!---------------------------------------------------------------------- 
    4651   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    112117      vv   (:,:,:,Kbb)   = vv   (:,:,:,Kmm) 
    113118      ssh (:,:,Kbb)     = ssh (:,:,Kmm) 
     119#if ! defined key_qco 
    114120      e3t(:,:,:,Kbb)   = e3t(:,:,:,Kmm) 
    115   
     121#endif  
    116122      ! prepare writing restart 
    117123      IF( lwxios ) THEN 
    … …  
    135141      INTEGER, INTENT(in) :: Kmm    ! ocean time level index 
    136142      !!---------------------------------------------------------------------- 
     143      INTEGER :: jk                               ! loop index 
     144      REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t, ze3u, ze3v, zgdepw  ! e3t , e3u, e3v !!st patch to use substitution 
     145      !!---------------------------------------------------------------------- 
     146      ! 
     147      DO jk = 1, jpk 
     148         ze3t(:,:,jk) = e3t(:,:,jk,Kmm) 
     149         ze3u(:,:,jk) = e3u(:,:,jk,Kmm) 
     150         ze3v(:,:,jk) = e3v(:,:,jk,Kmm) 
     151         ! 
     152         zgdepw(:,:,jk) = gdepw(:,:,jk,Kmm) 
     153      END DO  
    137154      ! 
    138155      IF( lwxios ) CALL iom_swap( cwxios_context ) 
    139156      CALL iom_rstput( kt, nitrst, numrow, 'tmask'  , tmask , ldxios = lwxios ) 
    140157      CALL iom_rstput( kt, nitrst, numrow, 'ssmask' , ssmask, ldxios = lwxios ) 
    141       CALL iom_rstput( kt, nitrst, numrow, 'e3t_n'  , e3t(:,:,:,Kmm) , ldxios = lwxios ) 
    142       CALL iom_rstput( kt, nitrst, numrow, 'e3u_n'  , e3u(:,:,:,Kmm) , ldxios = lwxios ) 
    143       CALL iom_rstput( kt, nitrst, numrow, 'e3v_n'  , e3v(:,:,:,Kmm) , ldxios = lwxios ) 
    144       CALL iom_rstput( kt, nitrst, numrow, 'gdepw_n', gdepw(:,:,:,Kmm) , ldxios = lwxios ) 
     158      CALL iom_rstput( kt, nitrst, numrow, 'e3t_n'  , ze3t , ldxios = lwxios ) 
     159      CALL iom_rstput( kt, nitrst, numrow, 'e3u_n'  , ze3u , ldxios = lwxios ) 
     160      CALL iom_rstput( kt, nitrst, numrow, 'e3v_n'  , ze3v , ldxios = lwxios ) 
     161      CALL iom_rstput( kt, nitrst, numrow, 'gdepw_n', zgdepw , ldxios = lwxios ) 
    145162      IF( lwxios ) CALL iom_swap( cxios_context ) 
    146163      ! 
    … …  
    209226      IF(lwp) write(numout,*) 'isfcpl_ssh : recompute scale factor from ssh (new wet cell,Kmm)' 
    210227      IF(lwp) write(numout,*) '~~~~~~~~~~~' 
     228#if ! defined key_qco 
    211229      DO jk = 1, jpk 
    212          e3t(:,:,jk,Kmm) =  e3t_0(:,:,jk) * ( ht_0(:,:) + ssh(:,:,Kmm) ) & 
    213              &                          / ( ht_0(:,:) + 1._wp - ssmask(:,:) ) * tmask(:,:,jk)   & 
    214              &          + e3t_0(:,:,jk)                               * (1._wp -tmask(:,:,jk)) 
     230         e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * ( 1._wp + (ht_0(:,:) + ssh(:,:,Kmm)) * r1_ht_0(:,:) ) 
    215231      END DO 
    216232      e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 
    217233      CALL dom_vvl_zgr(Kbb, Kmm, Kaa) 
     234#else 
     235      CALL dom_qco_zgr(Kbb, Kmm, Kaa) 
     236#endif 
    218237      ! 
    219238   END SUBROUTINE isfcpl_ssh 
    … …  
    400419         ! 1.1: get volume flux before coupling (>0 out) 
    401420         DO_2D_00_00 
    402             zqvolb(ji,jj,jk) =  (   e2u(ji,jj) * ze3u_b(ji,jj,jk) * uu(ji,jj,jk,Kmm) - e2u(ji-1,jj  ) * ze3u_b(ji-1,jj  ,jk) * uu(ji-1,jj  ,jk,Kmm)    & 
    403                &                  + e1v(ji,jj) * ze3v_b(ji,jj,jk) * vv(ji,jj,jk,Kmm) - e1v(ji  ,jj-1) * ze3v_b(ji  ,jj-1,jk) * vv(ji  ,jj-1,jk,Kmm)  ) & 
    404                &                * ztmask_b(ji,jj,jk) 
     421            zqvolb(ji,jj,jk) =    & 
     422               &  (   e2u(ji  ,jj  ) * ze3u_b(ji  ,jj  ,jk) * uu(ji  ,jj  ,jk,Kmm)      & 
     423               &    - e2u(ji-1,jj  ) * ze3u_b(ji-1,jj  ,jk) * uu(ji-1,jj  ,jk,Kmm)      & 
     424               &    + e1v(ji  ,jj  ) * ze3v_b(ji  ,jj  ,jk) * vv(ji  ,jj  ,jk,Kmm)      & 
     425               &    - e1v(ji  ,jj-1) * ze3v_b(ji  ,jj-1,jk) * vv(ji  ,jj-1,jk,Kmm)  )   & 
     426               &   * ztmask_b(ji,jj,jk) 
    405427         END_2D 
    406428         ! 
    … …  
    412434         ! compute volume flux divergence after coupling 
    413435         DO_2D_00_00 
    414             zqvoln(ji,jj,jk) = (   e2u(ji,jj) * e3u(ji,jj,jk,Kmm) * uu(ji,jj,jk,Kmm) - e2u(ji-1,jj  ) * e3u(ji-1,jj  ,jk,Kmm) * uu(ji-1,jj  ,jk,Kmm)    & 
    415                &                 + e1v(ji,jj) * e3v(ji,jj,jk,Kmm) * vv(ji,jj,jk,Kmm) - e1v(ji  ,jj-1) * e3v(ji  ,jj-1,jk,Kmm) * vv(ji  ,jj-1,jk,Kmm)  ) & 
    416                &               * tmask(ji,jj,jk) 
     436            zqvoln(ji,jj,jk) =   & 
     437               &  (   e2u(ji  ,jj  ) * e3u(ji  ,jj  ,jk,Kmm) * uu(ji  ,jj  ,jk,Kmm)    & 
     438               &    - e2u(ji-1,jj  ) * e3u(ji-1,jj  ,jk,Kmm) * uu(ji-1,jj  ,jk,Kmm)    & 
     439               &    + e1v(ji  ,jj  ) * e3v(ji  ,jj  ,jk,Kmm) * vv(ji  ,jj  ,jk,Kmm)    & 
     440               &    - e1v(ji  ,jj-1) * e3v(ji  ,jj-1,jk,Kmm) * vv(ji  ,jj-1,jk,Kmm)  ) & 
     441               &  * tmask(ji,jj,jk) 
    417442         END_2D 
    418443         ! 
    … …  
    523548 
    524549               ! volume diff 
    525                zdvol = e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk) - ze3t_b(ji,jj,jk) * ztmask_b(ji,jj,jk) 
     550               zdvol =   e3t  (ji,jj,jk,Kmm) *  tmask  (ji,jj,jk)   & 
     551                  &   - ze3t_b(ji,jj,jk    ) * ztmask_b(ji,jj,jk) 
    526552 
    527553               ! heat diff 
    528                zdtem = ts (ji,jj,jk,jp_tem,Kmm) *  e3t(ji,jj,jk,Kmm) *  tmask  (ji,jj,jk)   & 
     554               zdtem = ts(ji,jj,jk,jp_tem,Kmm) *  e3t(ji,jj,jk,Kmm) *  tmask  (ji,jj,jk)   & 
    529555                     - zt_b(ji,jj,jk)        * ze3t_b(ji,jj,jk) * ztmask_b(ji,jj,jk) 
    530556 
    … …  
    555581            DO ji = nldi,nlei 
    556582               jip1=MIN(ji+1,jpi) ; jim1=MAX(ji-1,1) ; jjp1=MIN(jj+1,jpj) ; jjm1=MAX(jj-1,1) ; 
    557                IF ( tmask(ji,jj,jk) == 0._wp .AND. ztmask_b(ji,jj,jk) == 1._wp ) nisfl(narea) = nisfl(narea) + MAX(SUM(tmask(jim1:jip1,jjm1:jjp1,jk)),1._wp) 
     583               IF ( tmask(ji,jj,jk) == 0._wp .AND. ztmask_b(ji,jj,jk) == 1._wp ) THEN  
     584                  nisfl(narea) = nisfl(narea) + MAX(SUM(tmask(jim1:jip1,jjm1:jjp1,jk)),1._wp) 
     585               ENDIF 
    558586            ENDDO 
    559587         ENDDO 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/ISF/isfdiags.F90

    r12340 r13151  
    2626   !! * Substitutions 
    2727#  include "do_loop_substitute.h90" 
     28#  include "domzgr_substitute.h90" 
    2829   !!---------------------------------------------------------------------- 
    2930   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/ISF/isfdynatf.F90

    r12489 r13151  
    1414 
    1515   USE phycst , ONLY: r1_rho0         ! physical constant 
    16    USE dom_oce, ONLY: tmask, ssmask, ht, e3t, r1_e1e2t   ! time and space domain 
     16   USE dom_oce                        ! time and space domain 
     17   USE oce, ONLY : ssh                ! sea-surface height !!st needed for substitution 
    1718 
    1819   USE in_out_manager 
    … …  
    2526   !! * Substitutions 
    2627#  include "do_loop_substitute.h90" 
     28#  include "domzgr_substitute.h90" 
    2729 
    2830CONTAINS 
    … …  
    8183      ! add the increment 
    8284      DO jk = 1, jpkm1 
    83          pe3t_f(:,:,jk) = pe3t_f(:,:,jk) - tmask(:,:,jk) * zfwfinc(:,:) * e3t(:,:,jk,Kmm) 
     85         pe3t_f(:,:,jk) = pe3t_f(:,:,jk) - tmask(:,:,jk) * zfwfinc(:,:)   & 
     86            &                              * e3t(:,:,jk,Kmm) 
    8487      END DO 
    8588      ! 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/ISF/isfhdiv.F90

    r12489 r13151  
    2626   !! * Substitutions 
    2727#  include "do_loop_substitute.h90" 
     28#  include "domzgr_substitute.h90" 
    2829 
    2930CONTAINS 
    … …  
    134135      ! 
    135136      DO jk=1,jpk  
    136          phdiv(:,:,jk) =  phdiv(:,:,jk) + pqvol(:,:,jk) * r1_e1e2t(:,:) / e3t(:,:,jk,Kmm) 
     137         phdiv(:,:,jk) =  phdiv(:,:,jk) + pqvol(:,:,jk) * r1_e1e2t(:,:)   & 
     138            &                             / e3t(:,:,jk,Kmm) 
    137139      END DO 
    138140      ! 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/ISF/isfload.F90

    r12340 r13151  
    1313   USE isf_oce, ONLY: cn_isfload, rn_isfload_T, rn_isfload_S ! ice shelf variables 
    1414 
    15    USE dom_oce, ONLY: e3w, gdept, risfdep, mikt     ! vertical scale factor 
     15   USE dom_oce                                      ! vertical scale factor 
    1616   USE eosbn2 , ONLY: eos                           ! eos routine 
    1717 
    … …  
    2626   !! * Substitutions 
    2727#  include "do_loop_substitute.h90" 
     28#  include "domzgr_substitute.h90" 
    2829 
    2930CONTAINS 
    … …  
    99100            ! 
    100101            ! top layer of the ice shelf 
    101             pisfload(ji,jj) = pisfload(ji,jj) + (znad + zrhd(ji,jj,1) ) * e3w(ji,jj,1,Kmm) 
     102            pisfload(ji,jj) = pisfload(ji,jj) + (znad + zrhd(ji,jj,1) )   & 
     103               &                                * e3w(ji,jj,1,Kmm) 
    102104            ! 
    103105            ! core layers of the ice shelf 
    104106            DO jk = 2, ikt-1 
    105                pisfload(ji,jj) = pisfload(ji,jj) + (2._wp * znad + zrhd(ji,jj,jk-1) + zrhd(ji,jj,jk)) * e3w(ji,jj,jk,Kmm) 
     107               pisfload(ji,jj) = pisfload(ji,jj) + (2._wp * znad + zrhd(ji,jj,jk-1) + zrhd(ji,jj,jk))   & 
     108                  &                                * e3w(ji,jj,jk,Kmm) 
    106109            END DO 
    107110            ! 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/ISF/isfstp.F90

    r12242 r13151  
    1111 
    1212   !!---------------------------------------------------------------------- 
    13    !!   isfstp       : compute iceshelf melt and heat flux 
    14    !!---------------------------------------------------------------------- 
    15    ! 
    16    USE isf_oce                                      ! isf variables 
    17    USE isfload, ONLY: isf_load                      ! ice shelf load 
    18    USE isftbl , ONLY: isf_tbl_lvl                   ! ice shelf boundary layer 
    19    USE isfpar , ONLY: isf_par, isf_par_init         ! ice shelf parametrisation 
    20    USE isfcav , ONLY: isf_cav, isf_cav_init         ! ice shelf cavity 
    21    USE isfcpl , ONLY: isfcpl_rst_write, isfcpl_init ! isf variables 
    22  
    23    USE dom_oce, ONLY: ht, e3t, ln_isfcav, ln_linssh     ! ocean space and time domain 
    24    USE domvvl,  ONLY: ln_vvl_zstar                      ! zstar logical 
    25    USE zdfdrg,  ONLY: r_Cdmin_top, r_ke0_top            ! vertical physics: top/bottom drag coef. 
     13   !!   isfstp        : compute iceshelf melt and heat flux 
     14   !!---------------------------------------------------------------------- 
     15   USE isf_oce        ! isf variables 
     16   USE isfload  , ONLY: isf_load                      ! ice shelf load 
     17   USE isftbl   , ONLY: isf_tbl_lvl                   ! ice shelf boundary layer 
     18   USE isfpar   , ONLY: isf_par, isf_par_init         ! ice shelf parametrisation 
     19   USE isfcav   , ONLY: isf_cav, isf_cav_init         ! ice shelf cavity 
     20   USE isfcpl   , ONLY: isfcpl_rst_write, isfcpl_init ! isf variables 
     21 
     22   USE dom_oce        ! ocean space and time domain 
     23   USE oce      , ONLY: ssh                           ! sea surface height 
     24   USE domvvl   , ONLY: ln_vvl_zstar                  ! zstar logical 
     25   USE zdfdrg   , ONLY: r_Cdmin_top, r_ke0_top        ! vertical physics: top/bottom drag coef. 
    2626   ! 
    2727   USE lib_mpp, ONLY: ctl_stop, ctl_nam 
    … …  
    3131 
    3232   IMPLICIT NONE 
    33  
    3433   PRIVATE 
    3534 
    3635   PUBLIC   isf_stp, isf_init, isf_nam  ! routine called in sbcmod and divhor 
    3736 
     37   !! * Substitutions 
     38#  include "domzgr_substitute.h90" 
    3839   !!---------------------------------------------------------------------- 
    3940   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    4142   !! Software governed by the CeCILL license (see ./LICENSE) 
    4243   !!---------------------------------------------------------------------- 
     44 
    4345CONTAINS 
    4446  
    … …  
    6062      INTEGER, INTENT(in) ::   kt   ! ocean time step 
    6163      INTEGER, INTENT(in) ::   Kmm  ! ocean time level index 
     64      !!---------------------------------------------------------------------- 
     65      INTEGER :: jk                               ! loop index 
     66      REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t    ! e3t  
    6267      !!--------------------------------------------------------------------- 
    6368      ! 
    … …  
    7883         ! 1.2: compute misfkb, rhisf_tbl, rfrac (deepest level, thickness, fraction of deepest cell affected by tbl) 
    7984         rhisf_tbl_cav(:,:) = rn_htbl * mskisf_cav(:,:) 
    80          CALL isf_tbl_lvl(ht, e3t(:,:,:,Kmm), misfkt_cav, misfkb_cav, rhisf_tbl_cav, rfrac_tbl_cav) 
     85         DO jk = 1, jpk 
     86            ze3t(:,:,jk) = e3t(:,:,jk,Kmm) 
     87         END DO  
     88         CALL isf_tbl_lvl(ht(:,:), ze3t, misfkt_cav, misfkb_cav, rhisf_tbl_cav, rfrac_tbl_cav) 
    8189         ! 
    8290         ! 1.3: compute ice shelf melt 
    … …  
    100108         ! by simplicity, we assume the top level where param applied do not change with time (done in init part) 
    101109         rhisf_tbl_par(:,:) = rhisf0_tbl_par(:,:) 
    102          CALL isf_tbl_lvl(ht, e3t(:,:,:,Kmm), misfkt_par, misfkb_par, rhisf_tbl_par, rfrac_tbl_par) 
     110         DO jk = 1, jpk 
     111            ze3t(:,:,jk) = e3t(:,:,jk,Kmm) 
     112         END DO 
     113         CALL isf_tbl_lvl(ht(:,:), ze3t, misfkt_par, misfkb_par, rhisf_tbl_par, rfrac_tbl_par) 
    103114         ! 
    104115         ! 2.3: compute ice shelf melt 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/ISF/isftbl.F90

    r12340 r13151  
    2525   !! * Substitutions 
    2626#  include "do_loop_substitute.h90" 
     27#  include "domzgr_substitute.h90" 
    2728 
    2829CONTAINS 
    … …  
    5657      REAL(wp), DIMENSION(jpi,jpj) :: zhtbl   ! thickness of the tbl 
    5758      REAL(wp), DIMENSION(jpi,jpj) :: zfrac   ! thickness of the tbl 
     59      INTEGER :: jk                            ! loop index 
     60      REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t,ze3u,ze3v ! e3  
    5861      !!-------------------------------------------------------------------- 
    5962      !  
    … …  
    6467         zhtbl = phtbl 
    6568         ! 
     69         DO jk = 1, jpk 
     70            ze3u(:,:,jk) = e3u(:,:,jk,Kmm) 
     71         END DO  
    6672         ! compute tbl lvl and thickness 
    67          CALL isf_tbl_lvl( hu(:,:,Kmm), e3u(:,:,:,Kmm), ktop, ikbot, zhtbl, zfrac ) 
     73         CALL isf_tbl_lvl( hu(:,:,Kmm), ze3u, ktop, ikbot, zhtbl, zfrac ) 
    6874         ! 
    6975         ! compute tbl property at U point 
    70          CALL isf_tbl_avg( miku, ikbot, zhtbl, zfrac, e3u(:,:,:,Kmm), pvarin, zvarout ) 
     76         CALL isf_tbl_avg( miku, ikbot, zhtbl, zfrac, ze3u, pvarin, zvarout ) 
    7177         ! 
    7278         ! compute tbl property at T point 
    … …  
    8288         zhtbl = phtbl 
    8389         ! 
     90         DO jk = 1, jpk 
     91            ze3v(:,:,jk) = e3v(:,:,jk,Kmm) 
     92         END DO  
    8493         ! compute tbl lvl and thickness 
    85          CALL isf_tbl_lvl( hv(:,:,Kmm), e3v(:,:,:,Kmm), ktop, ikbot, zhtbl, zfrac ) 
     94         CALL isf_tbl_lvl( hv(:,:,Kmm), ze3v, ktop, ikbot, zhtbl, zfrac ) 
    8695         ! 
    8796         ! compute tbl property at V point 
    88          CALL isf_tbl_avg( mikv, ikbot, zhtbl, zfrac, e3v(:,:,:,Kmm), pvarin, zvarout ) 
     97         CALL isf_tbl_avg( mikv, ikbot, zhtbl, zfrac, ze3v, pvarin, zvarout ) 
    8998         ! 
    9099         ! pvarout is an averaging of wet point 
    … …  
    98107         ! 
    99108         ! compute tbl property at T point 
    100          CALL isf_tbl_avg( ktop, kbot, phtbl, pfrac, e3t(:,:,:,Kmm), pvarin, pvarout ) 
     109         DO jk = 1, jpk 
     110            ze3t(:,:,jk) = e3t(:,:,jk,Kmm) 
     111         END DO  
     112         CALL isf_tbl_avg( ktop, kbot, phtbl, pfrac, ze3t, pvarin, pvarout ) 
    101113         ! 
    102114      END SELECT 
    … …  
    212224      ! phtbl need to be bounded by water column thickness before 
    213225      ! test: if htbl = water column thickness, should return mbathy 
    214       ! test: if htbl = 0 should return ktop (phtbl cap to e3t(ji,jj,1)) 
     226      ! test: if htbl = 0 should return ktop (phtbl cap to pe3t(ji,jj,1)) 
    215227      ! 
    216228      ! get ktbl 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/LDF/ldfslp.F90

    r12377 r13151  
    7575   !! * Substitutions 
    7676#  include "do_loop_substitute.h90" 
     77#  include "domzgr_substitute.h90" 
    7778   !!---------------------------------------------------------------------- 
    7879   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    198199         !                                      !              max slope = 1/2 * e3 / e1 
    199200         IF (ln_zps .AND. jk==mbku(ji,jj)) & 
    200             zbu = MIN(  zbu, - z1_slpmax * ABS( zau ) , - 2._wp * e1u(ji,jj) / e3u(ji,jj,jk,Kmm)* ABS( zau )  ) 
     201            zbu = MIN(  zbu, - z1_slpmax * ABS( zau ) ,   & 
     202               &                - 2._wp * e1u(ji,jj) / e3u(ji,jj,jk,Kmm)* ABS( zau )  ) 
    201203         IF (ln_zps .AND. jk==mbkv(ji,jj)) & 
    202             zbv = MIN(  zbv, - z1_slpmax * ABS( zav ) , - 2._wp * e2v(ji,jj) / e3v(ji,jj,jk,Kmm)* ABS( zav )  ) 
     204            zbv = MIN(  zbv, - z1_slpmax * ABS( zav ) ,   & 
     205               &                - 2._wp * e2v(ji,jj) / e3v(ji,jj,jk,Kmm)* ABS( zav )  ) 
    203206         !                                      ! uslp and vslp output in zwz and zww, resp. 
    204207         zfi = MAX( omlmask(ji,jj,jk), omlmask(ji+1,jj,jk) ) 
    205208         zfj = MAX( omlmask(ji,jj,jk), omlmask(ji,jj+1,jk) ) 
    206209         ! thickness of water column between surface and level k at u/v point 
    207          zdepu = 0.5_wp * ( ( gdept (ji,jj,jk,Kmm) + gdept (ji+1,jj,jk,Kmm) )                            & 
    208                           - 2 * MAX( risfdep(ji,jj), risfdep(ji+1,jj) ) - e3u(ji,jj,miku(ji,jj),Kmm)   ) 
    209          zdepv = 0.5_wp * ( ( gdept (ji,jj,jk,Kmm) + gdept (ji,jj+1,jk,Kmm) )                            & 
    210                           - 2 * MAX( risfdep(ji,jj), risfdep(ji,jj+1) ) - e3v(ji,jj,mikv(ji,jj),Kmm)   ) 
     210         zdepu = 0.5_wp * ( ( gdept (ji,jj,jk,Kmm) + gdept (ji+1,jj,jk,Kmm) )   & 
     211            &              - 2 * MAX( risfdep(ji,jj), risfdep(ji+1,jj) )        & 
     212            &              - e3u(ji,jj,miku(ji,jj),Kmm)   ) 
     213         zdepv = 0.5_wp * ( ( gdept (ji,jj,jk,Kmm) + gdept (ji,jj+1,jk,Kmm) )   & 
     214            &              - 2 * MAX( risfdep(ji,jj), risfdep(ji,jj+1) )        & 
     215            &              - e3v(ji,jj,mikv(ji,jj),Kmm)   ) 
    211216         ! 
    212217         zwz(ji,jj,jk) = ( ( 1._wp - zfi) * zau / ( zbu - zeps )                                     & 
    … …  
    293298!               !                                         ! jk must be >= ML level for zfk=1. otherwise  zfk=0. 
    294299!               zfk = REAL( 1 - 1/(1 + jk / nmln(ji+1,jj)), wp ) 
    295 !               zck = gdepw(ji,jj,jk)    / MAX( hmlp(ji,jj), 10. ) 
     300!               zck = gdepw(ji,jj,jk,Kmm)    / MAX( hmlp(ji,jj), 10. ) 
    296301!               zwz(ji,jj,jk) = ( zfk * zai / ( zbi - zeps ) + ( 1._wp - zfk ) * wslpiml(ji,jj) * zck ) * tmask(ji,jj,jk) 
    297302!               zww(ji,jj,jk) = ( zfk * zaj / ( zbj - zeps ) + ( 1._wp - zfk ) * wslpjml(ji,jj) * zck ) * tmask(ji,jj,jk) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/LDF/ldftra.F90

    r12489 r13151  
    9595   !! * Substitutions 
    9696#  include "do_loop_substitute.h90" 
     97#  include "domzgr_substitute.h90" 
    9798   !!---------------------------------------------------------------------- 
    9899   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/SBC/fldread.F90

    r12489 r13151  
    127127   !! * Substitutions 
    128128#  include "do_loop_substitute.h90" 
     129#  include "domzgr_substitute.h90" 
    129130   !!---------------------------------------------------------------------- 
    130131   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    617618               zcoef = ( umask(ji,jj,jk) - wumask(ji,jj,jk) ) 
    618619               zdhalf(jk) = zdhalf(jk-1) + e3u(ji,jj,jk-1,Kmm) 
    619                zdepth(jk) =          zcoef  * ( zdhalf(jk  ) + 0.5_wp * e3uw(ji,jj,jk,Kmm))  & 
    620                   &         + (1._wp-zcoef) * ( zdepth(jk-1) +          e3uw(ji,jj,jk,Kmm)) 
     620               zdepth(jk) =   zcoef  * ( zdhalf(jk  ) + 0.5_wp * e3uw(ji,jj,jk,Kmm))  & 
     621                  &  + (1._wp-zcoef) * ( zdepth(jk-1) +          e3uw(ji,jj,jk,Kmm)) 
    621622            END DO 
    622623         CASE(3)            ! depth of V points: we must not use gdept_n as we don't want to do a communication 
    … …  
    631632               zcoef = ( vmask(ji,jj,jk) - wvmask(ji,jj,jk) ) 
    632633               zdhalf(jk) = zdhalf(jk-1) + e3v(ji,jj,jk-1,Kmm) 
    633                zdepth(jk) =          zcoef  * ( zdhalf(jk  ) + 0.5_wp * e3vw(ji,jj,jk,Kmm))  & 
    634                   &         + (1._wp-zcoef) * ( zdepth(jk-1) +          e3vw(ji,jj,jk,Kmm)) 
     634               zdepth(jk) =   zcoef  * ( zdhalf(jk  ) + 0.5_wp * e3vw(ji,jj,jk,Kmm))  & 
     635                     + (1._wp-zcoef) * ( zdepth(jk-1) +          e3vw(ji,jj,jk,Kmm)) 
    635636            END DO 
    636637         END SELECT 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/SBC/sbcblk.F90

    r12489 r13151  
    639639      END IF 
    640640 
    641       !!      CALL iom_put( "Cd_oce", zcd_oce)  ! output value of pure ocean-atm. transfer coef. 
    642       !!      CALL iom_put( "Ch_oce", zch_oce)  ! output value of pure ocean-atm. transfer coef. 
    643  
    644       IF( ABS(rn_zu - rn_zqt) < 0.1_wp ) THEN 
    645          !! If zu == zt, then ensuring once for all that: 
    646          t_zu(:,:) = ztpot(:,:) 
    647          q_zu(:,:) = zqair(:,:) 
    648       ENDIF 
    649  
    650  
    651641      !  Turbulent fluxes over ocean  => BULK_FORMULA @ sbcblk_phy.F90 
    652642      ! ------------------------------------------------------------- 
    … …  
    663653      ELSE                      !==  BLK formulation  ==!   turbulent fluxes computation 
    664654         CALL BULK_FORMULA( rn_zu, ptsk(:,:), pssq(:,:), t_zu(:,:), q_zu(:,:), & 
    665             &               zcd_oce(:,:), zch_oce(:,:), zce_oce(:,:),         & 
    666             &               wndm(:,:), zU_zu(:,:), pslp(:,:),                 & 
    667             &               taum(:,:), psen(:,:), zqla(:,:),                  & 
    668             &               pEvap=pevp(:,:), prhoa=rhoa(:,:) ) 
     655            &               zcd_oce(:,:), zch_oce(:,:), zce_oce(:,:),          & 
     656            &               wndm(:,:), zU_zu(:,:), pslp(:,:),                  & 
     657            &               taum(:,:), psen(:,:), zqla(:,:),                   & 
     658            &               pEvap=pevp(:,:), prhoa=rhoa(:,:), pfact_evap=rn_efac ) 
    669659 
    670660         zqla(:,:) = zqla(:,:) * tmask(:,:,1) 
    … …  
    10461036      evap_ice (:,:,:) = rn_efac * qla_ice (:,:,:) * z1_rLsub    ! sublimation 
    10471037      devap_ice(:,:,:) = rn_efac * dqla_ice(:,:,:) * z1_rLsub    ! d(sublimation)/dT 
    1048       zevap    (:,:)   = rn_efac * ( emp(:,:) + tprecip(:,:) )   ! evaporation over ocean 
     1038      zevap    (:,:)   = emp(:,:) + tprecip(:,:)   ! evaporation over ocean  !LB: removed rn_efac here, correct??? 
    10491039 
    10501040      ! --- evaporation minus precipitation --- ! 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/SBC/sbcblk_algo_coare3p0.F90

    r12377 r13151  
    194194      IF( kt == nit000 ) CALL SBCBLK_ALGO_COARE3P0_INIT(l_use_cs, l_use_wl) 
    195195 
    196       l_zt_equal_zu = .FALSE. 
    197       IF( ABS(zu - zt) < 0.01_wp )   l_zt_equal_zu = .TRUE.    ! testing "zu == zt" is risky with double precision 
     196      l_zt_equal_zu = ( ABS(zu - zt) < 0.01_wp ) ! testing "zu == zt" is risky with double precision 
    198197      IF( .NOT. l_zt_equal_zu )  ALLOCATE( zeta_t(jpi,jpj) ) 
    199198 
    … …  
    396395      ! 
    397396      DO_2D_11_11 
    398          ! 
    399          zw = pwnd(ji,jj)   ! wind speed 
    400          ! 
    401          ! Charnock's constant, increases with the wind : 
    402          zgt10 = 0.5 + SIGN(0.5_wp,(zw - 10))  ! If zw<10. --> 0, else --> 1 
    403          zgt18 = 0.5 + SIGN(0.5_wp,(zw - 18.)) ! If zw<18. --> 0, else --> 1 
    404          ! 
    405          alfa_charn_3p0(ji,jj) =  (1. - zgt10)*0.011    &    ! wind is lower than 10 m/s 
    406             &     + zgt10*((1. - zgt18)*(0.011 + (0.018 - 0.011) & 
    407             &      *(zw - 10.)/(18. - 10.)) + zgt18*( 0.018 ) )    ! Hare et al. (1999) 
    408          ! 
     397      ! 
     398      zw = pwnd(ji,jj)   ! wind speed 
     399      ! 
     400      ! Charnock's constant, increases with the wind : 
     401      zgt10 = 0.5 + SIGN(0.5_wp,(zw - 10))  ! If zw<10. --> 0, else --> 1 
     402      zgt18 = 0.5 + SIGN(0.5_wp,(zw - 18.)) ! If zw<18. --> 0, else --> 1 
     403      ! 
     404      alfa_charn_3p0(ji,jj) =  (1. - zgt10)*0.011    &    ! wind is lower than 10 m/s 
     405         &     + zgt10*((1. - zgt18)*(0.011 + (0.018 - 0.011) & 
     406         &      *(zw - 10.)/(18. - 10.)) + zgt18*( 0.018 ) )    ! Hare et al. (1999) 
     407      ! 
    409408      END_2D 
    410409      ! 
    … …  
    432431      ! 
    433432      DO_2D_11_11 
    434          ! 
    435          zta = pzeta(ji,jj) 
    436          ! 
    437          zphi_m = ABS(1. - 15.*zta)**.25    !!Kansas unstable 
    438          ! 
    439          zpsi_k = 2.*LOG((1. + zphi_m)/2.) + LOG((1. + zphi_m*zphi_m)/2.)   & 
    440             & - 2.*ATAN(zphi_m) + 0.5*rpi 
    441          ! 
    442          zphi_c = ABS(1. - 10.15*zta)**.3333                   !!Convective 
    443          ! 
    444          zpsi_c = 1.5*LOG((1. + zphi_c + zphi_c*zphi_c)/3.) & 
    445             &     - 1.7320508*ATAN((1. + 2.*zphi_c)/1.7320508) + 1.813799447 
    446          ! 
    447          zf = zta*zta 
    448          zf = zf/(1. + zf) 
    449          zc = MIN(50._wp, 0.35_wp*zta) 
    450          zstab = 0.5 + SIGN(0.5_wp, zta) 
    451          ! 
    452          psi_m_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) & ! (zta < 0) 
    453             &                -   zstab     * ( 1. + 1.*zta     &                ! (zta > 0) 
    454             &                         + 0.6667*(zta - 14.28)/EXP(zc) + 8.525 )   !     " 
    455          ! 
     433      ! 
     434      zta = pzeta(ji,jj) 
     435      ! 
     436      zphi_m = ABS(1. - 15.*zta)**.25    !!Kansas unstable 
     437      ! 
     438      zpsi_k = 2.*LOG((1. + zphi_m)/2.) + LOG((1. + zphi_m*zphi_m)/2.)   & 
     439         & - 2.*ATAN(zphi_m) + 0.5*rpi 
     440      ! 
     441      zphi_c = ABS(1. - 10.15*zta)**.3333                   !!Convective 
     442      ! 
     443      zpsi_c = 1.5*LOG((1. + zphi_c + zphi_c*zphi_c)/3.) & 
     444         &     - 1.7320508*ATAN((1. + 2.*zphi_c)/1.7320508) + 1.813799447 
     445      ! 
     446      zf = zta*zta 
     447      zf = zf/(1. + zf) 
     448      zc = MIN(50._wp, 0.35_wp*zta) 
     449      zstab = 0.5 + SIGN(0.5_wp, zta) 
     450      ! 
     451      psi_m_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) & ! (zta < 0) 
     452         &                -   zstab     * ( 1. + 1.*zta     &                ! (zta > 0) 
     453         &                         + 0.6667*(zta - 14.28)/EXP(zc) + 8.525 )   !     " 
     454      ! 
    456455      END_2D 
    457456      ! 
    … …  
    483482      ! 
    484483      DO_2D_11_11 
    485          ! 
    486          zta = pzeta(ji,jj) 
    487          ! 
    488          zphi_h = (ABS(1. - 15.*zta))**.5  !! Kansas unstable   (zphi_h = zphi_m**2 when unstable, zphi_m when stable) 
    489          ! 
    490          zpsi_k = 2.*LOG((1. + zphi_h)/2.) 
    491          ! 
    492          zphi_c = (ABS(1. - 34.15*zta))**.3333   !! Convective 
    493          ! 
    494          zpsi_c = 1.5*LOG((1. + zphi_c + zphi_c*zphi_c)/3.) & 
    495             &    -1.7320508*ATAN((1. + 2.*zphi_c)/1.7320508) + 1.813799447 
    496          ! 
    497          zf = zta*zta 
    498          zf = zf/(1. + zf) 
    499          zc = MIN(50._wp,0.35_wp*zta) 
    500          zstab = 0.5 + SIGN(0.5_wp, zta) 
    501          ! 
    502          psi_h_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) & 
    503             &                -   zstab     * ( (ABS(1. + 2.*zta/3.))**1.5     & 
    504             &                           + .6667*(zta - 14.28)/EXP(zc) + 8.525 ) 
    505          ! 
     484      ! 
     485      zta = pzeta(ji,jj) 
     486      ! 
     487      zphi_h = (ABS(1. - 15.*zta))**.5  !! Kansas unstable   (zphi_h = zphi_m**2 when unstable, zphi_m when stable) 
     488      ! 
     489      zpsi_k = 2.*LOG((1. + zphi_h)/2.) 
     490      ! 
     491      zphi_c = (ABS(1. - 34.15*zta))**.3333   !! Convective 
     492      ! 
     493      zpsi_c = 1.5*LOG((1. + zphi_c + zphi_c*zphi_c)/3.) & 
     494         &    -1.7320508*ATAN((1. + 2.*zphi_c)/1.7320508) + 1.813799447 
     495      ! 
     496      zf = zta*zta 
     497      zf = zf/(1. + zf) 
     498      zc = MIN(50._wp,0.35_wp*zta) 
     499      zstab = 0.5 + SIGN(0.5_wp, zta) 
     500      ! 
     501      psi_h_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) & 
     502         &                -   zstab     * ( (ABS(1. + 2.*zta/3.))**1.5     & 
     503         &                           + .6667*(zta - 14.28)/EXP(zc) + 8.525 ) 
     504      ! 
    506505      END_2D 
    507506      ! 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/SBC/sbcblk_algo_coare3p6.F90

    r12377 r13151  
    194194      IF( kt == nit000 ) CALL SBCBLK_ALGO_COARE3P6_INIT(l_use_cs, l_use_wl) 
    195195 
    196       l_zt_equal_zu = .FALSE. 
    197       IF( ABS(zu - zt) < 0.01_wp )   l_zt_equal_zu = .TRUE.    ! testing "zu == zt" is risky with double precision 
     196      l_zt_equal_zu = ( ABS(zu - zt) < 0.01_wp ) ! testing "zu == zt" is risky with double precision 
    198197      IF( .NOT. l_zt_equal_zu )  ALLOCATE( zeta_t(jpi,jpj) ) 
    199198 
    … …  
    432431      ! 
    433432      DO_2D_11_11 
    434          ! 
    435          zta = pzeta(ji,jj) 
    436          ! 
    437          zphi_m = ABS(1. - 15.*zta)**.25    !!Kansas unstable 
    438          ! 
    439          zpsi_k = 2.*LOG((1. + zphi_m)/2.) + LOG((1. + zphi_m*zphi_m)/2.)   & 
    440             & - 2.*ATAN(zphi_m) + 0.5*rpi 
    441          ! 
    442          zphi_c = ABS(1. - 10.15*zta)**.3333                   !!Convective 
    443          ! 
    444          zpsi_c = 1.5*LOG((1. + zphi_c + zphi_c*zphi_c)/3.) & 
    445             &     - 1.7320508*ATAN((1. + 2.*zphi_c)/1.7320508) + 1.813799447 
    446          ! 
    447          zf = zta*zta 
    448          zf = zf/(1. + zf) 
    449          zc = MIN(50._wp, 0.35_wp*zta) 
    450          zstab = 0.5 + SIGN(0.5_wp, zta) 
    451          ! 
    452          psi_m_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) & ! (zta < 0) 
    453             &                -   zstab     * ( 1. + 1.*zta     &                ! (zta > 0) 
    454             &                         + 0.6667*(zta - 14.28)/EXP(zc) + 8.525 )   !     " 
    455          ! 
     433      ! 
     434      zta = pzeta(ji,jj) 
     435      ! 
     436      zphi_m = ABS(1. - 15.*zta)**.25    !!Kansas unstable 
     437      ! 
     438      zpsi_k = 2.*LOG((1. + zphi_m)/2.) + LOG((1. + zphi_m*zphi_m)/2.)   & 
     439         & - 2.*ATAN(zphi_m) + 0.5*rpi 
     440      ! 
     441      zphi_c = ABS(1. - 10.15*zta)**.3333                   !!Convective 
     442      ! 
     443      zpsi_c = 1.5*LOG((1. + zphi_c + zphi_c*zphi_c)/3.) & 
     444         &     - 1.7320508*ATAN((1. + 2.*zphi_c)/1.7320508) + 1.813799447 
     445      ! 
     446      zf = zta*zta 
     447      zf = zf/(1. + zf) 
     448      zc = MIN(50._wp, 0.35_wp*zta) 
     449      zstab = 0.5 + SIGN(0.5_wp, zta) 
     450      ! 
     451      psi_m_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) & ! (zta < 0) 
     452         &                -   zstab     * ( 1. + 1.*zta     &                ! (zta > 0) 
     453         &                         + 0.6667*(zta - 14.28)/EXP(zc) + 8.525 )   !     " 
     454      ! 
    456455      END_2D 
    457456      ! 
    … …  
    483482      ! 
    484483      DO_2D_11_11 
    485          ! 
    486          zta = pzeta(ji,jj) 
    487          ! 
    488          zphi_h = (ABS(1. - 15.*zta))**.5  !! Kansas unstable   (zphi_h = zphi_m**2 when unstable, zphi_m when stable) 
    489          ! 
    490          zpsi_k = 2.*LOG((1. + zphi_h)/2.) 
    491          ! 
    492          zphi_c = (ABS(1. - 34.15*zta))**.3333   !! Convective 
    493          ! 
    494          zpsi_c = 1.5*LOG((1. + zphi_c + zphi_c*zphi_c)/3.) & 
    495             &    -1.7320508*ATAN((1. + 2.*zphi_c)/1.7320508) + 1.813799447 
    496          ! 
    497          zf = zta*zta 
    498          zf = zf/(1. + zf) 
    499          zc = MIN(50._wp,0.35_wp*zta) 
    500          zstab = 0.5 + SIGN(0.5_wp, zta) 
    501          ! 
    502          psi_h_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) & 
    503             &                -   zstab     * ( (ABS(1. + 2.*zta/3.))**1.5     & 
    504             &                           + .6667*(zta - 14.28)/EXP(zc) + 8.525 ) 
    505          ! 
     484      ! 
     485      zta = pzeta(ji,jj) 
     486      ! 
     487      zphi_h = (ABS(1. - 15.*zta))**.5  !! Kansas unstable   (zphi_h = zphi_m**2 when unstable, zphi_m when stable) 
     488      ! 
     489      zpsi_k = 2.*LOG((1. + zphi_h)/2.) 
     490      ! 
     491      zphi_c = (ABS(1. - 34.15*zta))**.3333   !! Convective 
     492      ! 
     493      zpsi_c = 1.5*LOG((1. + zphi_c + zphi_c*zphi_c)/3.) & 
     494         &    -1.7320508*ATAN((1. + 2.*zphi_c)/1.7320508) + 1.813799447 
     495      ! 
     496      zf = zta*zta 
     497      zf = zf/(1. + zf) 
     498      zc = MIN(50._wp,0.35_wp*zta) 
     499      zstab = 0.5 + SIGN(0.5_wp, zta) 
     500      ! 
     501      psi_h_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) & 
     502         &                -   zstab     * ( (ABS(1. + 2.*zta/3.))**1.5     & 
     503         &                           + .6667*(zta - 14.28)/EXP(zc) + 8.525 ) 
     504      ! 
    506505      END_2D 
    507506      ! 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/SBC/sbcblk_algo_ecmwf.F90

    r12377 r13151  
    9898      &                      Qsw, rad_lw, slp, pdT_cs,                                & ! optionals for cool-skin (and warm-layer) 
    9999      &                      pdT_wl, pHz_wl )                                           ! optionals for warm-layer only 
    100       !!---------------------------------------------------------------------- 
     100      !!---------------------------------------------------------------------------------- 
    101101      !!                      ***  ROUTINE  turb_ecmwf  *** 
    102102      !! 
    … …  
    184184      LOGICAL :: l_zt_equal_zu = .FALSE.      ! if q and t are given at same height as U 
    185185      ! 
    186       REAL(wp), DIMENSION(jpi,jpj) ::  u_star, t_star, q_star 
    187       REAL(wp), DIMENSION(jpi,jpj) :: dt_zu, dq_zu      
    188       REAL(wp), DIMENSION(jpi,jpj) :: znu_a !: Nu_air, Viscosity of air 
     186      REAL(wp), DIMENSION(jpi,jpj) :: u_star, t_star, q_star 
     187      REAL(wp), DIMENSION(jpi,jpj) :: dt_zu, dq_zu 
     188      REAL(wp), DIMENSION(jpi,jpj) :: znu_a         !: Nu_air, Viscosity of air 
    189189      REAL(wp), DIMENSION(jpi,jpj) :: Linv  !: 1/L (inverse of Monin Obukhov length... 
    190190      REAL(wp), DIMENSION(jpi,jpj) :: z0, z0t, z0q 
    … …  
    196196      CHARACTER(len=40), PARAMETER :: crtnm = 'turb_ecmwf@sbcblk_algo_ecmwf.F90' 
    197197      !!---------------------------------------------------------------------------------- 
    198  
    199198      IF( kt == nit000 ) CALL SBCBLK_ALGO_ECMWF_INIT(l_use_cs, l_use_wl) 
    200199 
    201       l_zt_equal_zu = .FALSE. 
    202       IF( ABS(zu - zt) < 0.01_wp )   l_zt_equal_zu = .TRUE.    ! testing "zu == zt" is risky with double precision 
     200      l_zt_equal_zu = ( ABS(zu - zt) < 0.01_wp ) ! testing "zu == zt" is risky with double precision 
    203201 
    204202      !! Initializations for cool skin and warm layer: 
    … …  
    413411      !!---------------------------------------------------------------------------------- 
    414412      DO_2D_11_11 
    415          ! 
    416          zzeta = MIN( pzeta(ji,jj) , 5._wp ) !! Very stable conditions (L positif and big!): 
    417          ! 
    418          ! Unstable (Paulson 1970): 
    419          !   eq.3.20, Chap.3, p.33, IFS doc - Cy31r1 
    420          zx = SQRT(ABS(1._wp - 16._wp*zzeta)) 
    421          ztmp = 1._wp + SQRT(zx) 
    422          ztmp = ztmp*ztmp 
    423          psi_unst = LOG( 0.125_wp*ztmp*(1._wp + zx) )   & 
    424             &       -2._wp*ATAN( SQRT(zx) ) + 0.5_wp*rpi 
    425          ! 
    426          ! Unstable: 
    427          ! eq.3.22, Chap.3, p.33, IFS doc - Cy31r1 
    428          psi_stab = -2._wp/3._wp*(zzeta - 5._wp/0.35_wp)*EXP(-0.35_wp*zzeta) & 
    429             &       - zzeta - 2._wp/3._wp*5._wp/0.35_wp 
    430          ! 
    431          ! Combining: 
    432          stab = 0.5_wp + SIGN(0.5_wp, zzeta) ! zzeta > 0 => stab = 1 
    433          ! 
    434          psi_m_ecmwf(ji,jj) = (1._wp - stab) * psi_unst & ! (zzeta < 0) Unstable 
    435             &                +      stab  * psi_stab      ! (zzeta > 0) Stable 
    436          ! 
     413      ! 
     414      zzeta = MIN( pzeta(ji,jj) , 5._wp ) !! Very stable conditions (L positif and big!): 
     415      ! 
     416      ! Unstable (Paulson 1970): 
     417      !   eq.3.20, Chap.3, p.33, IFS doc - Cy31r1 
     418      zx = SQRT(ABS(1._wp - 16._wp*zzeta)) 
     419      ztmp = 1._wp + SQRT(zx) 
     420      ztmp = ztmp*ztmp 
     421      psi_unst = LOG( 0.125_wp*ztmp*(1._wp + zx) )   & 
     422         &       -2._wp*ATAN( SQRT(zx) ) + 0.5_wp*rpi 
     423      ! 
     424      ! Unstable: 
     425      ! eq.3.22, Chap.3, p.33, IFS doc - Cy31r1 
     426      psi_stab = -2._wp/3._wp*(zzeta - 5._wp/0.35_wp)*EXP(-0.35_wp*zzeta) & 
     427         &       - zzeta - 2._wp/3._wp*5._wp/0.35_wp 
     428      ! 
     429      ! Combining: 
     430      stab = 0.5_wp + SIGN(0.5_wp, zzeta) ! zzeta > 0 => stab = 1 
     431      ! 
     432      psi_m_ecmwf(ji,jj) = (1._wp - stab) * psi_unst & ! (zzeta < 0) Unstable 
     433         &                +      stab  * psi_stab      ! (zzeta > 0) Stable 
     434      ! 
    437435      END_2D 
    438436   END FUNCTION psi_m_ecmwf 
    … …  
    458456      ! 
    459457      DO_2D_11_11 
    460          ! 
    461          zzeta = MIN(pzeta(ji,jj) , 5._wp)   ! Very stable conditions (L positif and big!): 
    462          ! 
    463          zx  = ABS(1._wp - 16._wp*zzeta)**.25        ! this is actually (1/phi_m)**2  !!! 
    464          !                                     ! eq.3.19, Chap.3, p.33, IFS doc - Cy31r1 
    465          ! Unstable (Paulson 1970) : 
    466          psi_unst = 2._wp*LOG(0.5_wp*(1._wp + zx*zx))   ! eq.3.20, Chap.3, p.33, IFS doc - Cy31r1 
    467          ! 
    468          ! Stable: 
    469          psi_stab = -2._wp/3._wp*(zzeta - 5._wp/0.35_wp)*EXP(-0.35_wp*zzeta) & ! eq.3.22, Chap.3, p.33, IFS doc - Cy31r1 
    470             &       - ABS(1._wp + 2._wp/3._wp*zzeta)**1.5_wp - 2._wp/3._wp*5._wp/0.35_wp + 1._wp 
    471          ! LB: added ABS() to avoid NaN values when unstable, which contaminates the unstable solution... 
    472          ! 
    473          stab = 0.5_wp + SIGN(0.5_wp, zzeta) ! zzeta > 0 => stab = 1 
    474          ! 
    475          ! 
    476          psi_h_ecmwf(ji,jj) = (1._wp - stab) * psi_unst &   ! (zzeta < 0) Unstable 
    477             &                +    stab    * psi_stab        ! (zzeta > 0) Stable 
    478          ! 
     458      ! 
     459      zzeta = MIN(pzeta(ji,jj) , 5._wp)   ! Very stable conditions (L positif and big!): 
     460      ! 
     461      zx  = ABS(1._wp - 16._wp*zzeta)**.25        ! this is actually (1/phi_m)**2  !!! 
     462      !                                     ! eq.3.19, Chap.3, p.33, IFS doc - Cy31r1 
     463      ! Unstable (Paulson 1970) : 
     464      psi_unst = 2._wp*LOG(0.5_wp*(1._wp + zx*zx))   ! eq.3.20, Chap.3, p.33, IFS doc - Cy31r1 
     465      ! 
     466      ! Stable: 
     467      psi_stab = -2._wp/3._wp*(zzeta - 5._wp/0.35_wp)*EXP(-0.35_wp*zzeta) & ! eq.3.22, Chap.3, p.33, IFS doc - Cy31r1 
     468         &       - ABS(1._wp + 2._wp/3._wp*zzeta)**1.5_wp - 2._wp/3._wp*5._wp/0.35_wp + 1._wp 
     469      ! LB: added ABS() to avoid NaN values when unstable, which contaminates the unstable solution... 
     470      ! 
     471      stab = 0.5_wp + SIGN(0.5_wp, zzeta) ! zzeta > 0 => stab = 1 
     472      ! 
     473      ! 
     474      psi_h_ecmwf(ji,jj) = (1._wp - stab) * psi_unst &   ! (zzeta < 0) Unstable 
     475         &                +    stab    * psi_stab        ! (zzeta > 0) Stable 
     476      ! 
    479477      END_2D 
    480478   END FUNCTION psi_h_ecmwf 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/SBC/sbcblk_algo_ncar.F90

    r12377 r13151  
    112112      REAL(wp), DIMENSION(jpi,jpj) ::   stab          ! stability test integer 
    113113      !!---------------------------------------------------------------------------------- 
    114       ! 
    115       l_zt_equal_zu = .FALSE. 
    116       IF( ABS(zu - zt) < 0.01_wp )   l_zt_equal_zu = .TRUE.    ! testing "zu == zt" is risky with double precision 
     114      l_zt_equal_zu = ( ABS(zu - zt) < 0.01_wp ) ! testing "zu == zt" is risky with double precision 
    117115 
    118116      U_blk = MAX( 0.5_wp , U_zu )   !  relative wind speed at zu (normally 10m), we don't want to fall under 0.5 m/s 
    … …  
    143141      ENDIF 
    144142 
    145       !! Initializing values at z_u with z_t values: 
    146       t_zu = t_zt   ;   q_zu = q_zt 
     143      !! First guess of temperature and humidity at height zu: 
     144      t_zu = MAX( t_zt ,  180._wp )   ! who knows what's given on masked-continental regions... 
     145      q_zu = MAX( q_zt , 1.e-6_wp )   !               " 
    147146 
    148147      !! ITERATION BLOCK 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/SBC/sbcblk_phy.F90

    r12377 r13151  
    520520         zCe = zz0*pqst(ji,jj)/zdq 
    521521 
    522          CALL BULK_FORMULA( pzu, pTs(ji,jj), pqs(ji,jj), pTa(ji,jj), pqa(ji,jj), & 
    523             &              zCd, zCh, zCe,                                        & 
    524             &              pwnd(ji,jj), pUb(ji,jj), pslp(ji,jj),                 & 
    525             &              pTau(ji,jj), zQsen, zQlat ) 
    526  
     522         CALL BULK_FORMULA_SCLR( pzu, pTs(ji,jj), pqs(ji,jj), pTa(ji,jj), pqa(ji,jj), & 
     523            &                    zCd, zCh, zCe,                                       & 
     524            &                    pwnd(ji,jj), pUb(ji,jj), pslp(ji,jj),                & 
     525            &                    pTau(ji,jj), zQsen, zQlat ) 
     526          
    527527         zTs2  = pTs(ji,jj)*pTs(ji,jj) 
    528528         zQlw  = emiss_w*(prlw(ji,jj) - stefan*zTs2*zTs2) ! Net longwave flux 
    … …  
    535535 
    536536 
    537    SUBROUTINE BULK_FORMULA_VCTR( pzu, pTs, pqs, pTa, pqa,  & 
    538       &                          pCd, pCh, pCe,            & 
    539       &                          pwnd, pUb, pslp,          & 
    540       &                          pTau, pQsen, pQlat,  pEvap, prhoa ) 
     537   SUBROUTINE BULK_FORMULA_SCLR( pzu, pTs, pqs, pTa, pqa, & 
     538      &                          pCd, pCh, pCe,           & 
     539      &                          pwnd, pUb, pslp,         & 
     540      &                          pTau, pQsen, pQlat,      & 
     541      &                          pEvap, prhoa, pfact_evap ) 
     542      !!---------------------------------------------------------------------------------- 
     543      REAL(wp),                     INTENT(in)  :: pzu  ! height above the sea-level where all this takes place (normally 10m) 
     544      REAL(wp), INTENT(in)  :: pTs  ! water temperature at the air-sea interface [K] 
     545      REAL(wp), INTENT(in)  :: pqs  ! satur. spec. hum. at T=pTs   [kg/kg] 
     546      REAL(wp), INTENT(in)  :: pTa  ! potential air temperature at z=pzu [K] 
     547      REAL(wp), INTENT(in)  :: pqa  ! specific humidity at z=pzu [kg/kg] 
     548      REAL(wp), INTENT(in)  :: pCd 
     549      REAL(wp), INTENT(in)  :: pCh 
     550      REAL(wp), INTENT(in)  :: pCe 
     551      REAL(wp), INTENT(in)  :: pwnd ! wind speed module at z=pzu [m/s] 
     552      REAL(wp), INTENT(in)  :: pUb  ! bulk wind speed at z=pzu (inc. pot. effect of gustiness etc) [m/s] 
     553      REAL(wp), INTENT(in)  :: pslp ! sea-level atmospheric pressure [Pa] 
     554      !! 
     555      REAL(wp), INTENT(out) :: pTau  ! module of the wind stress [N/m^2] 
     556      REAL(wp), INTENT(out) :: pQsen !  [W/m^2] 
     557      REAL(wp), INTENT(out) :: pQlat !  [W/m^2] 
     558      !! 
     559      REAL(wp), INTENT(out), OPTIONAL :: pEvap ! Evaporation [kg/m^2/s] 
     560      REAL(wp), INTENT(out), OPTIONAL :: prhoa ! Air density at z=pzu [kg/m^3] 
     561      REAL(wp), INTENT(in) , OPTIONAL :: pfact_evap  ! ABOMINATION: corrective factor for evaporation (doing this against my will! /laurent) 
     562      !! 
     563      REAL(wp) :: ztaa, zgamma, zrho, zUrho, zevap, zfact_evap 
     564      INTEGER  :: jq 
     565      !!---------------------------------------------------------------------------------- 
     566      zfact_evap = 1._wp 
     567      IF( PRESENT(pfact_evap) ) zfact_evap = pfact_evap 
     568       
     569      !! Need ztaa, absolute temperature at pzu (formula to estimate rho_air needs absolute temperature, not the potential temperature "pTa") 
     570      ztaa = pTa ! first guess... 
     571      DO jq = 1, 4 
     572         zgamma = gamma_moist( 0.5*(ztaa+pTs) , pqa )  !LOLO: why not "0.5*(pqs+pqa)" rather then "pqa" ??? 
     573         ztaa = pTa - zgamma*pzu   ! Absolute temp. is slightly colder... 
     574      END DO 
     575      zrho = rho_air(ztaa, pqa, pslp) 
     576      zrho = rho_air(ztaa, pqa, pslp-zrho*grav*pzu) ! taking into account that we are pzu m above the sea level where SLP is given! 
     577 
     578      zUrho = pUb*MAX(zrho, 1._wp)     ! rho*U10 
     579 
     580      pTau = zUrho * pCd * pwnd ! Wind stress module 
     581 
     582      zevap = zUrho * pCe * (pqa - pqs) 
     583      pQsen = zUrho * pCh * (pTa - pTs) * cp_air(pqa) 
     584      pQlat = L_vap(pTs) * zevap 
     585 
     586      IF( PRESENT(pEvap) ) pEvap = - zfact_evap * zevap 
     587      IF( PRESENT(prhoa) ) prhoa = zrho 
     588 
     589   END SUBROUTINE BULK_FORMULA_SCLR 
     590 
     591   SUBROUTINE BULK_FORMULA_VCTR( pzu, pTs, pqs, pTa, pqa, & 
     592      &                          pCd, pCh, pCe,           & 
     593      &                          pwnd, pUb, pslp,         & 
     594      &                          pTau, pQsen, pQlat,      &  
     595      &                          pEvap, prhoa, pfact_evap )       
    541596      !!---------------------------------------------------------------------------------- 
    542597      REAL(wp),                     INTENT(in)  :: pzu  ! height above the sea-level where all this takes place (normally 10m) 
    … …  
    558613      REAL(wp), DIMENSION(jpi,jpj), INTENT(out), OPTIONAL :: pEvap ! Evaporation [kg/m^2/s] 
    559614      REAL(wp), DIMENSION(jpi,jpj), INTENT(out), OPTIONAL :: prhoa ! Air density at z=pzu [kg/m^3] 
    560       !! 
    561       REAL(wp) :: ztaa, zgamma, zrho, zUrho, zevap 
    562       INTEGER  :: ji, jj, jq     ! dummy loop indices 
    563       !!---------------------------------------------------------------------------------- 
    564       DO_2D_11_11 
    565  
    566          !! Need ztaa, absolute temperature at pzu (formula to estimate rho_air needs absolute temperature, not the potential temperature "pTa") 
    567          ztaa = pTa(ji,jj) ! first guess... 
    568          DO jq = 1, 4 
    569             zgamma = gamma_moist( 0.5*(ztaa+pTs(ji,jj)) , pqa(ji,jj) ) 
    570             ztaa = pTa(ji,jj) - zgamma*pzu   ! Absolute temp. is slightly colder... 
    571          END DO 
    572          zrho = rho_air(ztaa, pqa(ji,jj), pslp(ji,jj)) 
    573          zrho = rho_air(ztaa, pqa(ji,jj), pslp(ji,jj)-zrho*grav*pzu) ! taking into account that we are pzu m above the sea level where SLP is given! 
    574  
    575          zUrho = pUb(ji,jj)*MAX(zrho, 1._wp)     ! rho*U10 
    576  
    577          pTau(ji,jj) = zUrho * pCd(ji,jj) * pwnd(ji,jj) ! Wind stress module 
    578  
    579          zevap        = zUrho * pCe(ji,jj) * (pqa(ji,jj) - pqs(ji,jj)) 
    580          pQsen(ji,jj) = zUrho * pCh(ji,jj) * (pTa(ji,jj) - pTs(ji,jj)) * cp_air(pqa(ji,jj)) 
    581          pQlat(ji,jj) = L_vap(pTs(ji,jj)) * zevap 
    582  
    583          IF( PRESENT(pEvap) ) pEvap(ji,jj) = - zevap 
     615      REAL(wp),                     INTENT(in) , OPTIONAL :: pfact_evap  ! ABOMINATION: corrective factor for evaporation (doing this against my will! /laurent) 
     616      !! 
     617      REAL(wp) :: ztaa, zgamma, zrho, zUrho, zevap, zfact_evap 
     618      INTEGER  :: ji, jj 
     619      !!---------------------------------------------------------------------------------- 
     620      zfact_evap = 1._wp 
     621      IF( PRESENT(pfact_evap) ) zfact_evap = pfact_evap 
     622 
     623      DO_2D_11_11 
     624 
     625         CALL BULK_FORMULA_SCLR( pzu, pTs(ji,jj), pqs(ji,jj), pTa(ji,jj), pqa(ji,jj), & 
     626            &                    pCd(ji,jj), pCh(ji,jj), pCe(ji,jj),                  & 
     627            &                    pwnd(ji,jj), pUb(ji,jj), pslp(ji,jj),                & 
     628            &                    pTau(ji,jj), pQsen(ji,jj), pQlat(ji,jj),             & 
     629            &                    pEvap=zevap, prhoa=zrho, pfact_evap=zfact_evap       ) 
     630 
     631         IF( PRESENT(pEvap) ) pEvap(ji,jj) = zevap 
    584632         IF( PRESENT(prhoa) ) prhoa(ji,jj) = zrho 
    585  
     633    
    586634      END_2D 
    587635   END SUBROUTINE BULK_FORMULA_VCTR 
    588  
    589  
    590    SUBROUTINE BULK_FORMULA_SCLR( pzu, pTs, pqs, pTa, pqa, & 
    591       &                          pCd, pCh, pCe,           & 
    592       &                          pwnd, pUb, pslp,         & 
    593       &                          pTau, pQsen, pQlat,  pEvap, prhoa ) 
    594       !!---------------------------------------------------------------------------------- 
    595       REAL(wp),                     INTENT(in)  :: pzu  ! height above the sea-level where all this takes place (normally 10m) 
    596       REAL(wp), INTENT(in)  :: pTs  ! water temperature at the air-sea interface [K] 
    597       REAL(wp), INTENT(in)  :: pqs  ! satur. spec. hum. at T=pTs   [kg/kg] 
    598       REAL(wp), INTENT(in)  :: pTa  ! potential air temperature at z=pzu [K] 
    599       REAL(wp), INTENT(in)  :: pqa  ! specific humidity at z=pzu [kg/kg] 
    600       REAL(wp), INTENT(in)  :: pCd 
    601       REAL(wp), INTENT(in)  :: pCh 
    602       REAL(wp), INTENT(in)  :: pCe 
    603       REAL(wp), INTENT(in)  :: pwnd ! wind speed module at z=pzu [m/s] 
    604       REAL(wp), INTENT(in)  :: pUb  ! bulk wind speed at z=pzu (inc. pot. effect of gustiness etc) [m/s] 
    605       REAL(wp), INTENT(in)  :: pslp ! sea-level atmospheric pressure [Pa] 
    606       !! 
    607       REAL(wp), INTENT(out) :: pTau  ! module of the wind stress [N/m^2] 
    608       REAL(wp), INTENT(out) :: pQsen !  [W/m^2] 
    609       REAL(wp), INTENT(out) :: pQlat !  [W/m^2] 
    610       !! 
    611       REAL(wp), INTENT(out), OPTIONAL :: pEvap ! Evaporation [kg/m^2/s] 
    612       REAL(wp), INTENT(out), OPTIONAL :: prhoa ! Air density at z=pzu [kg/m^3] 
    613       !! 
    614       REAL(wp) :: ztaa, zgamma, zrho, zUrho, zevap 
    615       INTEGER  :: jq 
    616       !!---------------------------------------------------------------------------------- 
    617  
    618       !! Need ztaa, absolute temperature at pzu (formula to estimate rho_air needs absolute temperature, not the potential temperature "pTa") 
    619       ztaa = pTa ! first guess... 
    620       DO jq = 1, 4 
    621          zgamma = gamma_moist( 0.5*(ztaa+pTs) , pqa ) 
    622          ztaa = pTa - zgamma*pzu   ! Absolute temp. is slightly colder... 
    623       END DO 
    624       zrho = rho_air(ztaa, pqa, pslp) 
    625       zrho = rho_air(ztaa, pqa, pslp-zrho*grav*pzu) ! taking into account that we are pzu m above the sea level where SLP is given! 
    626  
    627       zUrho = pUb*MAX(zrho, 1._wp)     ! rho*U10 
    628  
    629       pTau = zUrho * pCd * pwnd ! Wind stress module 
    630  
    631       zevap = zUrho * pCe * (pqa - pqs) 
    632       pQsen = zUrho * pCh * (pTa - pTs) * cp_air(pqa) 
    633       pQlat = L_vap(pTs) * zevap 
    634  
    635       IF( PRESENT(pEvap) ) pEvap = - zevap 
    636       IF( PRESENT(prhoa) ) prhoa = zrho 
    637  
    638    END SUBROUTINE BULK_FORMULA_SCLR 
    639  
    640  
    641636 
    642637 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/SBC/sbccpl.F90

    r12489 r13151  
    199199   !! Substitution 
    200200#  include "do_loop_substitute.h90" 
     201#  include "domzgr_substitute.h90" 
    201202   !!---------------------------------------------------------------------- 
    202203   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    11151116         IF( ln_dm2dc .AND. ncpl_qsr_freq /= 86400 )   & 
    11161117            &   CALL ctl_stop( 'sbc_cpl_rcv: diurnal cycle reconstruction (ln_dm2dc) needs daily couping for solar radiation' ) 
    1117          ncpl_qsr_freq = 86400 / ncpl_qsr_freq   ! used by top 
     1118 
     1119         IF( ncpl_qsr_freq /= 0) ncpl_qsr_freq = 86400 / ncpl_qsr_freq ! used by top 
     1120          
    11181121      ENDIF 
    11191122      ! 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/SBC/sbcice_cice.F90

    r12489 r13151  
    1212   USE oce             ! ocean dynamics and tracers 
    1313   USE dom_oce         ! ocean space and time domain 
     14# if ! defined key_qco 
    1415   USE domvvl 
     16# else 
     17   USE domqco 
     18# endif 
    1519   USE phycst, only : rcp, rho0, r1_rho0, rhos, rhoi 
    1620   USE in_out_manager  ! I/O manager 
    … …  
    3640# if defined key_cice4 
    3741   USE ice_flux, only: strax,stray,strocnx,strocny,frain,fsnow,  & 
    38                 strocnxT,strocnyT,                               &  
     42                strocnxT,strocnyT,                               & 
    3943                sst,sss,uocn,vocn,ss_tltx,ss_tlty,fsalt_gbm,     & 
    4044                fresh_gbm,fhocn_gbm,fswthru_gbm,frzmlt,          & 
    … …  
    4549#else 
    4650   USE ice_flux, only: strax,stray,strocnx,strocny,frain,fsnow,  & 
    47                 strocnxT,strocnyT,                               &  
     51                strocnxT,strocnyT,                               & 
    4852                sst,sss,uocn,vocn,ss_tltx,ss_tlty,fsalt_ai,     & 
    4953                fresh_ai,fhocn_ai,fswthru_ai,frzmlt,          & 
    … …  
    7074   INTEGER             ::   jj_off 
    7175 
    72    INTEGER , PARAMETER ::   jpfld   = 13   ! maximum number of files to read  
     76   INTEGER , PARAMETER ::   jpfld   = 13   ! maximum number of files to read 
    7377   INTEGER , PARAMETER ::   jp_snow = 1    ! index of snow file 
    7478   INTEGER , PARAMETER ::   jp_rain = 2    ! index of rain file 
    … …  
    109113      !!--------------------------------------------------------------------- 
    110114      !!                  ***  ROUTINE sbc_ice_cice  *** 
    111       !!                    
    112       !! ** Purpose :   update the ocean surface boundary condition via the  
    113       !!                CICE Sea Ice Model time stepping  
    114       !! 
    115       !! ** Method  : - Get any extra forcing fields for CICE   
     115      !! 
     116      !! ** Purpose :   update the ocean surface boundary condition via the 
     117      !!                CICE Sea Ice Model time stepping 
     118      !! 
     119      !! ** Method  : - Get any extra forcing fields for CICE 
    116120      !!              - Prepare forcing fields 
    117121      !!              - CICE model time stepping 
    118       !!              - call the routine that computes mass and  
     122      !!              - call the routine that computes mass and 
    119123      !!                heat fluxes at the ice/ocean interface 
    120124      !! 
    … …  
    171175      ! there is no restart file. 
    172176      ! Values from a CICE restart file would overwrite this 
    173       IF( .NOT. ln_rstart ) THEN     
    174          CALL nemo2cice( ts(:,:,1,jp_tem,Kmm) , sst , 'T' , 1.)  
    175       ENDIF   
     177      IF( .NOT. ln_rstart ) THEN 
     178         CALL nemo2cice( ts(:,:,1,jp_tem,Kmm) , sst , 'T' , 1.) 
     179      ENDIF 
    176180#endif 
    177181 
    … …  
    233237!!gm This should be put elsewhere....   (same remark for limsbc) 
    234238!!gm especially here it is assumed zstar coordinate, but it can be ztilde.... 
     239#if defined key_qco 
     240            IF( .NOT.ln_linssh )   CALL dom_qco_zgr( Kbb, Kmm, Kaa )   ! interpolation scale factor, depth and water column 
     241#else 
    235242            IF( .NOT.ln_linssh ) THEN 
    236243               ! 
    237244               DO jk = 1,jpkm1                     ! adjust initial vertical scale factors 
    238                   e3t(:,:,jk,Kmm) = e3t_0(:,:,jk)*( 1._wp + ssh(:,:,Kmm)*tmask(:,:,1)/(ht_0(:,:) + 1.0 - tmask(:,:,1)) ) 
    239                   e3t(:,:,jk,Kbb) = e3t_0(:,:,jk)*( 1._wp + ssh(:,:,Kbb)*tmask(:,:,1)/(ht_0(:,:) + 1.0 - tmask(:,:,1)) ) 
    240                ENDDO 
     245                  e3t(:,:,jk,Kmm) = e3t_0(:,:,jk)*( 1._wp + ssh(:,:,Kmm)*r1_ht_0(:,:)*tmask(:,:,jk) ) 
     246                  e3t(:,:,jk,Kbb) = e3t_0(:,:,jk)*( 1._wp + ssh(:,:,Kbb)*r1_ht_0(:,:)*tmask(:,:,jk) ) 
     247               END DO 
    241248               e3t(:,:,:,Krhs) = e3t(:,:,:,Kbb) 
    242249               ! Reconstruction of all vertical scale factors at now and before time-steps 
    … …  
    267274               END DO 
    268275            ENDIF 
     276#endif 
    269277         ENDIF 
    270278      ENDIF 
    … …  
    272280   END SUBROUTINE cice_sbc_init 
    273281 
    274     
     282 
    275283   SUBROUTINE cice_sbc_in( kt, ksbc ) 
    276284      !!--------------------------------------------------------------------- 
    … …  
    281289      INTEGER, INTENT(in   ) ::   ksbc ! surface forcing type 
    282290      ! 
    283       INTEGER  ::   ji, jj, jl                   ! dummy loop indices       
     291      INTEGER  ::   ji, jj, jl                   ! dummy loop indices 
    284292      REAL(wp), DIMENSION(jpi,jpj) :: ztmp, zpice 
    285293      REAL(wp), DIMENSION(jpi,jpj,ncat) :: ztmpn 
    … …  
    293301      ztmp(:,:)=0.0 
    294302 
    295 ! Aggregate ice concentration already set in cice_sbc_out (or cice_sbc_init on  
     303! Aggregate ice concentration already set in cice_sbc_out (or cice_sbc_init on 
    296304! the first time-step) 
    297305 
    298 ! forced and coupled case  
     306! forced and coupled case 
    299307 
    300308      IF( (ksbc == jp_flx).OR.(ksbc == jp_purecpl) ) THEN 
    … …  
    356364!  Convert to GBM 
    357365            IF(ksbc == jp_flx) THEN 
    358                ztmp(:,:) = (topmelt(:,:,jl)+botmelt(:,:,jl))*a_i(:,:,jl)  
     366               ztmp(:,:) = (topmelt(:,:,jl)+botmelt(:,:,jl))*a_i(:,:,jl) 
    359367            ELSE 
    360368               ztmp(:,:) = (topmelt(:,:,jl)+botmelt(:,:,jl)) 
    … …  
    380388         CALL nemo2cice(ztmp,Tair,'T', 1. )    ! Air temperature (K) 
    381389         CALL nemo2cice(ztmp,potT,'T', 1. )    ! Potential temp (K) 
    382 ! Following line uses MAX(....) to avoid problems if tatm_ice has unset halo rows   
    383          ztmp(:,:) = 101000. / ( 287.04 * MAX(1.0,tatm_ice(:,:)) )     
     390! Following line uses MAX(....) to avoid problems if tatm_ice has unset halo rows 
     391         ztmp(:,:) = 101000. / ( 287.04 * MAX(1.0,tatm_ice(:,:)) ) 
    384392                                               ! Constant (101000.) atm pressure assumed 
    385393         CALL nemo2cice(ztmp,rhoa,'T', 1. )    ! Air density (kg/m^3) 
    … …  
    389397         CALL nemo2cice(ztmp,zlvl,'T', 1. )    ! Atmos level height (m) 
    390398 
    391 ! May want to check all values are physically realistic (as in CICE routine  
     399! May want to check all values are physically realistic (as in CICE routine 
    392400! prepare_forcing)? 
    393401 
    394402! Divide shortwave into spectral bands (as in prepare_forcing) 
    395403         ztmp(:,:)=qsr_ice(:,:,1)*frcvdr       ! visible direct 
    396          CALL nemo2cice(ztmp,swvdr,'T', 1. )              
     404         CALL nemo2cice(ztmp,swvdr,'T', 1. ) 
    397405         ztmp(:,:)=qsr_ice(:,:,1)*frcvdf       ! visible diffuse 
    398          CALL nemo2cice(ztmp,swvdf,'T', 1. )               
     406         CALL nemo2cice(ztmp,swvdf,'T', 1. ) 
    399407         ztmp(:,:)=qsr_ice(:,:,1)*frcidr       ! near IR direct 
    400408         CALL nemo2cice(ztmp,swidr,'T', 1. ) 
    … …  
    406414! Snowfall 
    407415! Ensure fsnow is positive (as in CICE routine prepare_forcing) 
    408       IF( iom_use('snowpre') )   CALL iom_put('snowpre',MAX( (1.0-fr_i(:,:))*sprecip(:,:) ,0.0)) !!Joakim edit   
    409       ztmp(:,:)=MAX(fr_i(:,:)*sprecip(:,:),0.0)   
    410       CALL nemo2cice(ztmp,fsnow,'T', 1. )  
     416      IF( iom_use('snowpre') )   CALL iom_put('snowpre',MAX( (1.0-fr_i(:,:))*sprecip(:,:) ,0.0)) !!Joakim edit 
     417      ztmp(:,:)=MAX(fr_i(:,:)*sprecip(:,:),0.0) 
     418      CALL nemo2cice(ztmp,fsnow,'T', 1. ) 
    411419 
    412420! Rainfall 
    413421      IF( iom_use('precip') )   CALL iom_put('precip', (1.0-fr_i(:,:))*(tprecip(:,:)-sprecip(:,:)) ) !!Joakim edit 
    414422      ztmp(:,:)=fr_i(:,:)*(tprecip(:,:)-sprecip(:,:)) 
    415       CALL nemo2cice(ztmp,frain,'T', 1. )  
     423      CALL nemo2cice(ztmp,frain,'T', 1. ) 
    416424 
    417425! Freezing/melting potential 
    … …  
    482490      INTEGER, INTENT( in  ) ::   kt   ! ocean time step 
    483491      INTEGER, INTENT( in  ) ::   ksbc ! surface forcing type 
    484        
     492 
    485493      INTEGER  ::   ji, jj, jl                 ! dummy loop indices 
    486494      REAL(wp), DIMENSION(jpi,jpj) :: ztmp1, ztmp2 
    … …  
    490498         IF(lwp) WRITE(numout,*)'cice_sbc_out' 
    491499      ENDIF 
    492        
    493 ! x comp of ocean-ice stress  
     500 
     501! x comp of ocean-ice stress 
    494502      CALL cice2nemo(strocnx,ztmp1,'F', -1. ) 
    495503      ss_iou(:,:)=0.0 
    … …  
    500508      CALL lbc_lnk( 'sbcice_cice', ss_iou , 'U', -1. ) 
    501509 
    502 ! y comp of ocean-ice stress  
     510! y comp of ocean-ice stress 
    503511      CALL cice2nemo(strocny,ztmp1,'F', -1. ) 
    504512      ss_iov(:,:)=0.0 
    … …  
    513521! Combine wind stress and ocean-ice stress 
    514522! [Note that fr_iu hasn't yet been updated, so still from start of CICE timestep] 
    515 ! strocnx and strocny already weighted by ice fraction in CICE so not done here  
     523! strocnx and strocny already weighted by ice fraction in CICE so not done here 
    516524 
    517525      utau(:,:)=(1.0-fr_iu(:,:))*utau(:,:)-ss_iou(:,:) 
    518       vtau(:,:)=(1.0-fr_iv(:,:))*vtau(:,:)-ss_iov(:,:)      
    519   
    520 ! Also need ice/ocean stress on T points so that taum can be updated  
    521 ! This interpolation is already done in CICE so best to use those values  
    522       CALL cice2nemo(strocnxT,ztmp1,'T',-1.)  
    523       CALL cice2nemo(strocnyT,ztmp2,'T',-1.)  
    524   
    525 ! Update taum with modulus of ice-ocean stress  
    526 ! strocnxT and strocnyT are not weighted by ice fraction in CICE so must be done here  
    527 taum(:,:)=(1.0-fr_i(:,:))*taum(:,:)+fr_i(:,:)*SQRT(ztmp1*ztmp1 + ztmp2*ztmp2)  
    528  
    529 ! Freshwater fluxes  
     526      vtau(:,:)=(1.0-fr_iv(:,:))*vtau(:,:)-ss_iov(:,:) 
     527 
     528! Also need ice/ocean stress on T points so that taum can be updated 
     529! This interpolation is already done in CICE so best to use those values 
     530      CALL cice2nemo(strocnxT,ztmp1,'T',-1.) 
     531      CALL cice2nemo(strocnyT,ztmp2,'T',-1.) 
     532 
     533! Update taum with modulus of ice-ocean stress 
     534! strocnxT and strocnyT are not weighted by ice fraction in CICE so must be done here 
     535taum(:,:)=(1.0-fr_i(:,:))*taum(:,:)+fr_i(:,:)*SQRT(ztmp1*ztmp1 + ztmp2*ztmp2) 
     536 
     537! Freshwater fluxes 
    530538 
    531539      IF(ksbc == jp_flx) THEN 
    532540! Note that emp from the forcing files is evap*(1-aice)-(tprecip-aice*sprecip) 
    533541! What we want here is evap*(1-aice)-tprecip*(1-aice) hence manipulation below 
    534 ! Not ideal since aice won't be the same as in the atmosphere.   
     542! Not ideal since aice won't be the same as in the atmosphere. 
    535543! Better to use evap and tprecip? (but for now don't read in evap in this case) 
    536544         emp(:,:)  = emp(:,:)+fr_i(:,:)*(tprecip(:,:)-sprecip(:,:)) 
    537545      ELSE IF(ksbc == jp_blk) THEN 
    538          emp(:,:)  = (1.0-fr_i(:,:))*emp(:,:)         
     546         emp(:,:)  = (1.0-fr_i(:,:))*emp(:,:) 
    539547      ELSE IF(ksbc == jp_purecpl) THEN 
    540 ! emp_tot is set in sbc_cpl_ice_flx (called from cice_sbc_in above)  
     548! emp_tot is set in sbc_cpl_ice_flx (called from cice_sbc_in above) 
    541549! This is currently as required with the coupling fields from the UM atmosphere 
    542          emp(:,:) = emp_tot(:,:)+tprecip(:,:)*fr_i(:,:)  
     550         emp(:,:) = emp_tot(:,:)+tprecip(:,:)*fr_i(:,:) 
    543551      ENDIF 
    544552 
    … …  
    560568      emp(:,:)=emp(:,:)-ztmp1(:,:) 
    561569      fmmflx(:,:) = ztmp1(:,:) !!Joakim edit 
    562        
     570 
    563571      CALL lbc_lnk_multi( 'sbcice_cice', emp , 'T', 1., sfx , 'T', 1. ) 
    564572 
    … …  
    634642      !!                    ***  ROUTINE cice_sbc_hadgam  *** 
    635643      !! ** Purpose: Prepare fields needed to pass to HadGAM3 atmosphere 
    636       !!  
     644      !! 
    637645      !! 
    638646      !!--------------------------------------------------------------------- 
    … …  
    657665      CALL cice2nemo(vvel,v_ice,'F', -1. ) 
    658666      ! 
    659       ! Ice concentration (CO_1) = a_i calculated at end of cice_sbc_out   
     667      ! Ice concentration (CO_1) = a_i calculated at end of cice_sbc_out 
    660668      ! 
    661669      ! Snow and ice thicknesses (CO_2 and CO_3) 
    … …  
    689697      !!--------------------------------------------------------------------- 
    690698      !! ** Method  :   READ monthly flux file in NetCDF files 
    691       !!       
    692       !!  snowfall     
    693       !!  rainfall     
    694       !!  sublimation rate     
     699      !! 
     700      !!  snowfall 
     701      !!  rainfall 
     702      !!  sublimation rate 
    695703      !!  topmelt (category) 
    696704      !!  botmelt (category) 
    … …  
    709717      TYPE(FLD_N) ::   sn_snow, sn_rain, sn_sblm               ! informations about the fields to be read 
    710718      TYPE(FLD_N) ::   sn_top1, sn_top2, sn_top3, sn_top4, sn_top5 
    711       TYPE(FLD_N) ::   sn_bot1, sn_bot2, sn_bot3, sn_bot4, sn_bot5  
     719      TYPE(FLD_N) ::   sn_bot1, sn_bot2, sn_bot3, sn_bot4, sn_bot5 
    712720      !! 
    713721      NAMELIST/namsbc_cice/ cn_dir, sn_snow, sn_rain, sn_sblm,   & 
    … …  
    727735         !            !    file          ! frequency !  variable    ! time intep !  clim   ! 'yearly' or ! weights  ! rotation   ! landmask 
    728736         !            !    name          !  (hours)  !   name       !   (T/F)    !  (T/F)  !  'monthly'  ! filename ! pairs      ! file 
    729          sn_snow = FLD_N( 'snowfall_1m'  ,    -1.    ,  'snowfall'  ,  .true.    , .true.  ,  ' yearly'  , ''       , ''         ,  ''    )  
    730          sn_rain = FLD_N( 'rainfall_1m'  ,    -1.    ,  'rainfall'  ,  .true.    , .true.  ,  ' yearly'  , ''       , ''         ,  ''    )  
     737         sn_snow = FLD_N( 'snowfall_1m'  ,    -1.    ,  'snowfall'  ,  .true.    , .true.  ,  ' yearly'  , ''       , ''         ,  ''    ) 
     738         sn_rain = FLD_N( 'rainfall_1m'  ,    -1.    ,  'rainfall'  ,  .true.    , .true.  ,  ' yearly'  , ''       , ''         ,  ''    ) 
    731739         sn_sblm = FLD_N( 'sublim_1m'    ,    -1.    ,  'sublim'    ,  .true.    , .true.  ,  ' yearly'  , ''       , ''         ,  ''    ) 
    732740         sn_top1 = FLD_N( 'topmeltn1_1m' ,    -1.    ,  'topmeltn1' ,  .true.    , .true.  ,  ' yearly'  , ''       , ''         ,  ''    ) 
    … …  
    754762         slf_i(jp_bot2) = sn_bot2   ;   slf_i(jp_bot3) = sn_bot3   ;   slf_i(jp_bot4) = sn_bot4 
    755763         slf_i(jp_bot5) = sn_bot5 
    756           
     764 
    757765         ! set sf structure 
    758766         ALLOCATE( sf(jpfld), STAT=ierror ) 
    … …  
    792800      ! control print (if less than 100 time-step asked) 
    793801      IF( nitend-nit000 <= 100 .AND. lwp ) THEN 
    794          WRITE(numout,*)  
     802         WRITE(numout,*) 
    795803         WRITE(numout,*) '        read forcing fluxes for CICE OK' 
    796804         CALL FLUSH(numout) 
    … …  
    802810      !!--------------------------------------------------------------------- 
    803811      !!                    ***  ROUTINE nemo2cice  *** 
    804       !! ** Purpose :   Transfer field in NEMO array to field in CICE array.   
     812      !! ** Purpose :   Transfer field in NEMO array to field in CICE array. 
    805813#if defined key_nemocice_decomp 
    806       !!              
     814      !! 
    807815      !!                NEMO and CICE PE sub domains are identical, hence 
    808       !!                there is no need to gather or scatter data from  
     816      !!                there is no need to gather or scatter data from 
    809817      !!                one PE configuration to another. 
    810818#else 
    811       !!                Automatically gather/scatter between  
     819      !!                Automatically gather/scatter between 
    812820      !!                different processors and blocks 
    813821      !! ** Method :    A. Ensure all haloes are filled in NEMO field (pn) 
    814822      !!                B. Gather pn into global array (png) 
    815823      !!                C. Map png into CICE global array (pcg) 
    816       !!                D. Scatter pcg to CICE blocks (pc) + update haloes   
     824      !!                D. Scatter pcg to CICE blocks (pc) + update haloes 
    817825#endif 
    818826      !!--------------------------------------------------------------------- 
    … …  
    858866      IF( jpnij > 1) THEN 
    859867         CALL mppsync 
    860          CALL mppgather (pn,0,png)  
     868         CALL mppgather (pn,0,png) 
    861869         CALL mppsync 
    862870      ELSE 
    … …  
    869877! (may be OK but not 100% sure) 
    870878 
    871       IF(nproc==0) THEN      
     879      IF(nproc==0) THEN 
    872880!        pcg(:,:)=0.0 
    873881         DO jn=1,jpnij 
    … …  
    890898         CASE ( 'T' ) 
    891899            grid_loc=field_loc_center 
    892          CASE ( 'F' )                               
     900         CASE ( 'F' ) 
    893901            grid_loc=field_loc_NEcorner 
    894902      END SELECT 
    … …  
    897905         CASE ( -1 ) 
    898906            field_type=field_type_vector 
    899          CASE ( 1 )                               
     907         CASE ( 1 ) 
    900908            field_type=field_type_scalar 
    901909      END SELECT 
    … …  
    916924      !! ** Purpose :   Transfer field in CICE array to field in NEMO array. 
    917925#if defined key_nemocice_decomp 
    918       !!              
     926      !! 
    919927      !!                NEMO and CICE PE sub domains are identical, hence 
    920       !!                there is no need to gather or scatter data from  
     928      !!                there is no need to gather or scatter data from 
    921929      !!                one PE configuration to another. 
    922 #else  
     930#else 
    923931      !!                Automatically deal with scatter/gather between 
    924932      !!                different processors and blocks 
    … …  
    926934      !!                B. Map pcg into NEMO global array (png) 
    927935      !!                C. Scatter png into NEMO field (pn) for each processor 
    928       !!                D. Ensure all haloes are filled in pn  
     936      !!                D. Ensure all haloes are filled in pn 
    929937#endif 
    930938      !!--------------------------------------------------------------------- 
    … …  
    958966         CASE ( 'T' ) 
    959967            grid_loc=field_loc_center 
    960          CASE ( 'F' )                               
     968         CASE ( 'F' ) 
    961969            grid_loc=field_loc_NEcorner 
    962970      END SELECT 
    … …  
    965973         CASE ( -1 ) 
    966974            field_type=field_type_vector 
    967          CASE ( 1 )                               
     975         CASE ( 1 ) 
    968976            field_type=field_type_scalar 
    969977      END SELECT 
    … …  
    979987#else 
    980988 
    981 !      A. Gather CICE blocks (pc) into global array (pcg)  
     989!      A. Gather CICE blocks (pc) into global array (pcg) 
    982990 
    983991      CALL gather_global(pcg, pc, 0, distrb_info) 
    … …  
    10051013      IF( jpnij > 1) THEN 
    10061014         CALL mppsync 
    1007          CALL mppscatter (png,0,pn)  
     1015         CALL mppscatter (png,0,pn) 
    10081016         CALL mppsync 
    10091017      ELSE 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/SBC/sbcrnf.F90

    r12489 r13151  
    3434   PUBLIC   sbc_rnf_alloc ! called in sbcmod module 
    3535   PUBLIC   sbc_rnf_init  ! called in sbcmod module 
    36     
     36 
    3737   !                                                !!* namsbc_rnf namelist * 
    3838   CHARACTER(len=100)         ::   cn_dir            !: Root directory for location of rnf files 
    … …  
    5858   LOGICAL , PUBLIC ::   l_rnfcpl = .false.   !: runoffs recieved from oasis 
    5959   INTEGER , PUBLIC ::   nkrnf = 0            !: nb of levels over which Kz is increased at river mouths 
    60     
     60 
    6161   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   rnfmsk              !: river mouth mask (hori.) 
    6262   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)     ::   rnfmsk_z            !: river mouth mask (vert.) 
    6363   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   h_rnf               !: depth of runoff in m 
    6464   INTEGER,  PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   nk_rnf              !: depth of runoff in model levels 
    65    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   rnf_tsc_b, rnf_tsc  !: before and now T & S runoff contents   [K.m/s & PSU.m/s]    
     65   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   rnf_tsc_b, rnf_tsc  !: before and now T & S runoff contents   [K.m/s & PSU.m/s] 
    6666 
    6767   TYPE(FLD),        ALLOCATABLE, DIMENSION(:) ::   sf_rnf       ! structure: river runoff (file information, fields read) 
    6868   TYPE(FLD),        ALLOCATABLE, DIMENSION(:) ::   sf_i_rnf     ! structure: iceberg flux (file information, fields read) 
    69    TYPE(FLD),        ALLOCATABLE, DIMENSION(:) ::   sf_s_rnf     ! structure: river runoff salinity (file information, fields read)   
    70    TYPE(FLD),        ALLOCATABLE, DIMENSION(:) ::   sf_t_rnf     ! structure: river runoff temperature (file information, fields read)   
    71   
     69   TYPE(FLD),        ALLOCATABLE, DIMENSION(:) ::   sf_s_rnf     ! structure: river runoff salinity (file information, fields read) 
     70   TYPE(FLD),        ALLOCATABLE, DIMENSION(:) ::   sf_t_rnf     ! structure: river runoff temperature (file information, fields read) 
     71 
    7272   !! * Substitutions 
    7373#  include "do_loop_substitute.h90" 
     74#  include "domzgr_substitute.h90" 
    7475   !!---------------------------------------------------------------------- 
    7576   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    227228      ELSE                       !==   runoff put only at the surface   ==! 
    228229         h_rnf (:,:)   = e3t (:,:,1,Kmm)        ! update h_rnf to be depth of top box 
    229          phdivn(:,:,1) = phdivn(:,:,1) - ( rnf(:,:) + rnf_b(:,:) ) * zfact * r1_rho0 / e3t(:,:,1,Kmm) 
     230         phdivn(:,:,1) = phdivn(:,:,1) - ( rnf(:,:)+rnf_b(:,:) ) * zfact * r1_rho0 / e3t(:,:,1,Kmm) 
    230231      ENDIF 
    231232      ! 
    … …  
    249250      INTEGER           ::   ios           ! Local integer output status for namelist read 
    250251      INTEGER           ::   nbrec         ! temporary integer 
    251       REAL(wp)          ::   zacoef   
    252       REAL(wp), DIMENSION(jpi,jpj,2) :: zrnfcl     
     252      REAL(wp)          ::   zacoef 
     253      REAL(wp), DIMENSION(jpi,jpj,2) :: zrnfcl 
    253254      !! 
    254255      NAMELIST/namsbc_rnf/ cn_dir            , ln_rnf_depth, ln_rnf_tem, ln_rnf_sal, ln_rnf_icb,   & 
    … …  
    261262      IF( sbc_rnf_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'sbc_rnf_alloc : unable to allocate arrays' ) 
    262263      ! 
    263       IF( .NOT. ln_rnf ) THEN                      ! no specific treatment in vicinity of river mouths  
     264      IF( .NOT. ln_rnf ) THEN                      ! no specific treatment in vicinity of river mouths 
    264265         ln_rnf_mouth  = .FALSE.                   ! default definition needed for example by sbc_ssr or by tra_adv_muscl 
    265266         nkrnf         = 0 
    … …  
    297298      !                                   ! ================== 
    298299      ! 
    299       IF( .NOT. l_rnfcpl ) THEN                     
     300      IF( .NOT. l_rnfcpl ) THEN 
    300301         ALLOCATE( sf_rnf(1), STAT=ierror )         ! Create sf_rnf structure (runoff inflow) 
    301302         IF(lwp) WRITE(numout,*) 
    … …  
    352353         IF(lwp) WRITE(numout,*) '   ==>>>   runoffs depth read in a file' 
    353354         rn_dep_file = TRIM( cn_dir )//TRIM( sn_dep_rnf%clname ) 
    354          IF( .NOT. sn_dep_rnf%ln_clim ) THEN   ;   WRITE(rn_dep_file, '(a,"_y",i4)' ) TRIM( rn_dep_file ), nyear    ! add year  
    355             IF( sn_dep_rnf%cltype == 'monthly' )   WRITE(rn_dep_file, '(a,"m",i2)'  ) TRIM( rn_dep_file ), nmonth   ! add month  
     355         IF( .NOT. sn_dep_rnf%ln_clim ) THEN   ;   WRITE(rn_dep_file, '(a,"_y",i4)' ) TRIM( rn_dep_file ), nyear    ! add year 
     356            IF( sn_dep_rnf%cltype == 'monthly' )   WRITE(rn_dep_file, '(a,"m",i2)'  ) TRIM( rn_dep_file ), nmonth   ! add month 
    356357         ENDIF 
    357358         CALL iom_open ( rn_dep_file, inum )                           ! open file 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/SBC/sbcssm.F90

    r12377 r13151  
    1010 
    1111   !!---------------------------------------------------------------------- 
    12    !!   sbc_ssm       : calculate sea surface mean currents, temperature,   
     12   !!   sbc_ssm       : calculate sea surface mean currents, temperature, 
    1313   !!                   and salinity over nn_fsbc time-step 
    1414   !!---------------------------------------------------------------------- 
    … …  
    3131 
    3232   LOGICAL, SAVE ::   l_ssm_mean = .FALSE.   ! keep track of whether means have been read from restart file 
    33     
     33 
     34#  include "domzgr_substitute.h90" 
    3435   !!---------------------------------------------------------------------- 
    3536   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    4243      !!--------------------------------------------------------------------- 
    4344      !!                     ***  ROUTINE sbc_oce  *** 
    44       !!                      
     45      !! 
    4546      !! ** Purpose :   provide ocean surface variable to sea-surface boundary 
    46       !!                condition computation  
    47       !!                 
    48       !! ** Method  :   compute mean surface velocity (2 components at U and  
     47      !!                condition computation 
     48      !! 
     49      !! ** Method  :   compute mean surface velocity (2 components at U and 
    4950      !!      V-points) [m/s], temperature [Celsius] and salinity [psu] over 
    5051      !!      the periode (kt - nn_fsbc) to kt 
    … …  
    200201         ! 
    201202      ELSE 
    202          !                
     203         ! 
    203204         IF(lwp) WRITE(numout,*) 
    204205         IF(lwp) WRITE(numout,*) 'sbc_ssm_init : sea surface mean fields' 
    … …  
    222223            ! 
    223224            IF( zf_sbc /= REAL( nn_fsbc, wp ) ) THEN      ! nn_fsbc has changed between 2 runs 
    224                IF(lwp) WRITE(numout,*) '   restart with a change in the frequency of mean from ', zf_sbc, ' to ', nn_fsbc  
    225                zcoef = REAL( nn_fsbc - 1, wp ) / zf_sbc  
    226                ssu_m(:,:) = zcoef * ssu_m(:,:)  
     225               IF(lwp) WRITE(numout,*) '   restart with a change in the frequency of mean from ', zf_sbc, ' to ', nn_fsbc 
     226               zcoef = REAL( nn_fsbc - 1, wp ) / zf_sbc 
     227               ssu_m(:,:) = zcoef * ssu_m(:,:) 
    227228               ssv_m(:,:) = zcoef * ssv_m(:,:) 
    228229               sst_m(:,:) = zcoef * sst_m(:,:) 
    … …  
    252253      ENDIF 
    253254      ! 
    254       IF( .NOT. ln_traqsr )   fraqsr_1lev(:,:) = 1._wp   ! default definition: qsr 100% in the fisrt level  
     255      IF( .NOT. ln_traqsr )   fraqsr_1lev(:,:) = 1._wp   ! default definition: qsr 100% in the fisrt level 
    255256      ! 
    256257      IF( lwxios.AND.nn_fsbc > 1 ) THEN 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/SBC/sbcwave.F90

    r12377 r13151  
    7373   !! * Substitutions 
    7474#  include "do_loop_substitute.h90" 
     75#  include "domzgr_substitute.h90" 
    7576   !!---------------------------------------------------------------------- 
    7677   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    207208            &                 - e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm) * usd(ji-1,jj,jk)    & 
    208209            &                 + e1v(ji,jj  ) * e3v(ji,jj  ,jk,Kmm) * vsd(ji,jj  ,jk)    & 
    209             &                 - e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) * vsd(ji,jj-1,jk)  ) * r1_e1e2t(ji,jj) 
     210            &                 - e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) * vsd(ji,jj-1,jk)  ) & 
     211            &                * r1_e1e2t(ji,jj) 
    210212      END_3D 
    211213      ! 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/STO/storng.F90

    r12377 r13151  
    5050 
    5151   ! Parameters to generate real random variates 
    52    REAL(KIND=wp), PARAMETER :: huge64=9223372036854775808.0  ! +1 
    5352   REAL(KIND=wp), PARAMETER :: zero=0.0, half=0.5, one=1.0, two=2.0 
    5453 
    … …  
    275274      REAL(KIND=wp) :: uran 
    276275 
    277       uran = half * ( one + REAL(kiss(),wp) / huge64 ) 
     276      uran = half * ( one + REAL(kiss(),wp) / HUGE(1._wp) ) 
    278277 
    279278   END SUBROUTINE kiss_uniform 
    … …  
    298297         rsq = two 
    299298         DO WHILE ( (rsq.GE.one).OR. (rsq.EQ.zero) ) 
    300             u1 = REAL(kiss(),wp) / huge64 
    301             u2 = REAL(kiss(),wp) / huge64 
     299            u1 = REAL(kiss(),wp) / HUGE(1._wp) 
     300            u2 = REAL(kiss(),wp) / HUGE(1._wp) 
    302301            rsq = u1*u1 + u2*u2 
    303302         ENDDO 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRA/eosbn2.F90

    r12489 r13151  
    180180   !! * Substitutions 
    181181#  include "do_loop_substitute.h90" 
     182#  include "domzgr_substitute.h90" 
    182183   !!---------------------------------------------------------------------- 
    183184   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRA/traadv.F90

    r12489 r13151  
    6565   INTEGER, PARAMETER ::   np_UBS     = 4   ! 3rd order Upstream Biased Scheme 
    6666   INTEGER, PARAMETER ::   np_QCK     = 5   ! QUICK scheme 
    67     
     67 
     68#  include "domzgr_substitute.h90" 
    6869   !!---------------------------------------------------------------------- 
    6970   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    9899      IF( ln_wave .AND. ln_sdw )  THEN 
    99100         DO jk = 1, jpkm1                                                       ! eulerian transport + Stokes Drift 
    100             zuu(:,:,jk) = e2u  (:,:) * e3u(:,:,jk,Kmm) * ( uu(:,:,jk,Kmm) + usd(:,:,jk) ) 
    101             zvv(:,:,jk) = e1v  (:,:) * e3v(:,:,jk,Kmm) * ( vv(:,:,jk,Kmm) + vsd(:,:,jk) ) 
    102             zww(:,:,jk) = e1e2t(:,:)                 * ( ww(:,:,jk) + wsd(:,:,jk) ) 
     101            zuu(:,:,jk) =   & 
     102               &  e2u  (:,:) * e3u(:,:,jk,Kmm) * ( uu(:,:,jk,Kmm) + usd(:,:,jk) ) 
     103            zvv(:,:,jk) =   &  
     104               &  e1v  (:,:) * e3v(:,:,jk,Kmm) * ( vv(:,:,jk,Kmm) + vsd(:,:,jk) ) 
     105            zww(:,:,jk) =   &  
     106               &  e1e2t(:,:)                 * ( ww(:,:,jk) + wsd(:,:,jk) ) 
    103107         END DO 
    104108      ELSE 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRA/traadv_cen.F90

    r12377 r13151  
    1313   USE dom_oce        ! ocean space and time domain 
    1414   USE eosbn2         ! equation of state 
    15    USE traadv_fct     ! acces to routine interp_4th_cpt  
     15   USE traadv_fct     ! acces to routine interp_4th_cpt 
    1616   USE trd_oce        ! trends: ocean variables 
    17    USE trdtra         ! trends manager: tracers  
     17   USE trdtra         ! trends manager: tracers 
    1818   USE diaptr         ! poleward transport diagnostics 
    1919   USE diaar5         ! AR5 diagnostics 
    … …  
    2828 
    2929   PUBLIC   tra_adv_cen   ! called by traadv.F90 
    30     
     30 
    3131   REAL(wp) ::   r1_6 = 1._wp / 6._wp   ! =1/6 
    3232 
    … …  
    3737   !! * Substitutions 
    3838#  include "do_loop_substitute.h90" 
     39#  include "domzgr_substitute.h90" 
    3940   !!---------------------------------------------------------------------- 
    4041   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    4546 
    4647   SUBROUTINE tra_adv_cen( kt, kit000, cdtype, pU, pV, pW,     & 
    47       &                    Kmm, pt, kjpt, Krhs, kn_cen_h, kn_cen_v )  
     48      &                    Kmm, pt, kjpt, Krhs, kn_cen_h, kn_cen_v ) 
    4849      !!---------------------------------------------------------------------- 
    4950      !!                  ***  ROUTINE tra_adv_cen  *** 
    50       !!                  
     51      !! 
    5152      !! ** Purpose :   Compute the now trend due to the advection of tracers 
    5253      !!      and add it to the general trend of passive tracer equations. 
    5354      !! 
    5455      !! ** Method  :   The advection is evaluated by a 2nd or 4th order scheme 
    55       !!               using now fields (leap-frog scheme).  
     56      !!               using now fields (leap-frog scheme). 
    5657      !!       kn_cen_h = 2  ==>> 2nd order centered scheme on the horizontal 
    5758      !!                = 4  ==>> 4th order    -        -       -      - 
    … …  
    9091      l_ptr = .FALSE. 
    9192      IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) )       l_trd = .TRUE. 
    92       IF(   cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) )  )    l_ptr = .TRUE.  
     93      IF(   cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) )  )    l_ptr = .TRUE. 
    9394      IF(   cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 
    9495         &                          iom_use("uadv_salttr") .OR. iom_use("vadv_salttr")  ) )  l_hst = .TRUE. 
    9596      ! 
    96       !                     
     97      ! 
    9798      zwz(:,:, 1 ) = 0._wp       ! surface & bottom vertical flux set to zero for all tracers 
    9899      zwz(:,:,jpk) = 0._wp 
    … …  
    150151            IF( ln_isfcav ) THEN                  ! ice-shelf cavities (top of the ocean) 
    151152               DO_2D_11_11 
    152                   zwz(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kmm)  
     153                  zwz(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kmm) 
    153154               END_2D 
    154155            ELSE                                   ! no ice-shelf cavities (only ocean surface) 
    … …  
    156157            ENDIF 
    157158         ENDIF 
    158          !                
     159         ! 
    159160         DO_3D_00_00( 1, jpkm1 ) 
    160161            pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs)    & 
    161162               &             - (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )    & 
    162163               &                + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )    & 
    163                &                + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1)  ) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
     164               &                + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1)  ) & 
     165               &                * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
    164166         END_3D 
    165167         !                             ! trend diagnostics 
    … …  
    169171            CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_zad, zwz, pW, pt(:,:,:,jn,Kmm) ) 
    170172         END IF 
    171          !                                 ! "Poleward" heat and salt transports  
     173         !                                 ! "Poleward" heat and salt transports 
    172174         IF( l_ptr )   CALL dia_ptr_hst( jn, 'adv', zwy(:,:,:) ) 
    173175         !                                 !  heat and salt transport 
    … …  
    177179      ! 
    178180   END SUBROUTINE tra_adv_cen 
    179     
     181 
    180182   !!====================================================================== 
    181183END MODULE traadv_cen 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRA/traadv_fct.F90

    r12489 r13151  
    1010   !!  tra_adv_fct    : update the tracer trend with a 3D advective trends using a 2nd or 4th order FCT scheme 
    1111   !!                   with sub-time-stepping in the vertical direction 
    12    !!  nonosc         : compute monotonic tracer fluxes by a non-oscillatory algorithm  
     12   !!  nonosc         : compute monotonic tracer fluxes by a non-oscillatory algorithm 
    1313   !!  interp_4th_cpt : 4th order compact scheme for the vertical component of the advection 
    1414   !!---------------------------------------------------------------------- 
    … …  
    2424   ! 
    2525   USE in_out_manager ! I/O manager 
    26    USE iom            !  
     26   USE iom            ! 
    2727   USE lib_mpp        ! MPP library 
    28    USE lbclnk         ! ocean lateral boundary condition (or mpp link)  
    29    USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)   
     28   USE lbclnk         ! ocean lateral boundary condition (or mpp link) 
     29   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 
    3030 
    3131   IMPLICIT NONE 
    … …  
    4646   !! * Substitutions 
    4747#  include "do_loop_substitute.h90" 
     48#  include "domzgr_substitute.h90" 
    4849   !!---------------------------------------------------------------------- 
    4950   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    5758      !!---------------------------------------------------------------------- 
    5859      !!                  ***  ROUTINE tra_adv_fct  *** 
    59       !!  
     60      !! 
    6061      !! **  Purpose :   Compute the now trend due to total advection of tracers 
    6162      !!               and add it to the general trend of tracer equations 
    … …  
    6364      !! **  Method  : - 2nd or 4th FCT scheme on the horizontal direction 
    6465      !!               (choice through the value of kn_fct) 
    65       !!               - on the vertical the 4th order is a compact scheme  
    66       !!               - corrected flux (monotonic correction)  
     66      !!               - on the vertical the 4th order is a compact scheme 
     67      !!               - corrected flux (monotonic correction) 
    6768      !! 
    6869      !! ** Action : - update pt(:,:,:,:,Krhs)  with the now advective tracer trends 
    … …  
    8182      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) ::   pt              ! tracers and RHS of tracer equation 
    8283      ! 
    83       INTEGER  ::   ji, jj, jk, jn                           ! dummy loop indices   
     84      INTEGER  ::   ji, jj, jk, jn                           ! dummy loop indices 
    8485      REAL(wp) ::   ztra                                     ! local scalar 
    8586      REAL(wp) ::   zfp_ui, zfp_vj, zfp_wk, zC2t_u, zC4t_u   !   -      - 
    … …  
    102103      ll_zAimp = .FALSE. 
    103104      IF( ( cdtype == 'TRA' .AND. l_trdtra  ) .OR. ( cdtype =='TRC' .AND. l_trdtrc ) )      l_trd = .TRUE. 
    104       IF(   cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) )    l_ptr = .TRUE.  
     105      IF(   cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) )    l_ptr = .TRUE. 
    105106      IF(   cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR.  & 
    106107         &                         iom_use("uadv_salttr") .OR. iom_use("vadv_salttr")  ) )  l_hst = .TRUE. 
    … …  
    111112      ENDIF 
    112113      ! 
    113       IF( l_ptr ) THEN   
     114      IF( l_ptr ) THEN 
    114115         ALLOCATE( zptry(jpi,jpj,jpk) ) 
    115116         zptry(:,:,:) = 0._wp 
    116117      ENDIF 
    117118      !                          ! surface & bottom value : flux set to zero one for all 
    118       zwz(:,:, 1 ) = 0._wp             
     119      zwz(:,:, 1 ) = 0._wp 
    119120      zwx(:,:,jpk) = 0._wp   ;   zwy(:,:,jpk) = 0._wp    ;    zwz(:,:,jpk) = 0._wp 
    120121      ! 
    121       zwi(:,:,:) = 0._wp         
     122      zwi(:,:,:) = 0._wp 
    122123      ! 
    123124      ! If adaptive vertical advection, check if it is needed on this PE at this time 
    … …  
    129130         ALLOCATE(zwdia(jpi,jpj,jpk), zwinf(jpi,jpj,jpk),zwsup(jpi,jpj,jpk)) 
    130131         DO_3D_00_00( 1, jpkm1 ) 
    131             zwdia(ji,jj,jk) =  1._wp + p2dt * ( MAX( wi(ji,jj,jk  ) , 0._wp ) - MIN( wi(ji,jj,jk+1) , 0._wp ) ) / e3t(ji,jj,jk,Krhs) 
     132            zwdia(ji,jj,jk) =  1._wp + p2dt * ( MAX( wi(ji,jj,jk) , 0._wp ) - MIN( wi(ji,jj,jk+1) , 0._wp ) )   & 
     133            &                               / e3t(ji,jj,jk,Krhs) 
    132134            zwinf(ji,jj,jk) =  p2dt * MIN( wi(ji,jj,jk  ) , 0._wp ) / e3t(ji,jj,jk,Krhs) 
    133135            zwsup(ji,jj,jk) = -p2dt * MAX( wi(ji,jj,jk+1) , 0._wp ) / e3t(ji,jj,jk,Krhs) 
    … …  
    138140         ! 
    139141         !        !==  upstream advection with initial mass fluxes & intermediate update  ==! 
    140          !                    !* upstream tracer flux in the i and j direction  
     142         !                    !* upstream tracer flux in the i and j direction 
    141143         DO_3D_10_10( 1, jpkm1 ) 
    142144            ! upstream scheme 
    … …  
    157159            IF( ln_isfcav ) THEN             ! top of the ice-shelf cavities and at the ocean surface 
    158160               DO_2D_11_11 
    159                   zwz(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kbb)   ! linear free surface  
     161                  zwz(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kbb)   ! linear free surface 
    160162               END_2D 
    161163            ELSE                             ! no cavities: only at the ocean surface 
    … …  
    163165            ENDIF 
    164166         ENDIF 
    165          !                
     167         ! 
    166168         DO_3D_00_00( 1, jpkm1 ) 
    167169            !                             ! total intermediate advective trends 
    … …  
    170172               &      + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) * r1_e1e2t(ji,jj) 
    171173            !                             ! update and guess with monotonic sheme 
    172             pt(ji,jj,jk,jn,Krhs) =                     pt(ji,jj,jk,jn,Krhs) +        ztra   / e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk) 
    173             zwi(ji,jj,jk)    = ( e3t(ji,jj,jk,Kbb) * pt(ji,jj,jk,jn,Kbb) + p2dt * ztra ) / e3t(ji,jj,jk,Krhs) * tmask(ji,jj,jk) 
     174            pt(ji,jj,jk,jn,Krhs) =                   pt(ji,jj,jk,jn,Krhs) +       ztra   & 
     175               &                                  / e3t(ji,jj,jk,Kmm ) * tmask(ji,jj,jk) 
     176            zwi(ji,jj,jk)    = ( e3t(ji,jj,jk,Kbb) * pt(ji,jj,jk,jn,Kbb) + p2dt * ztra ) & 
     177               &                                  / e3t(ji,jj,jk,Krhs) * tmask(ji,jj,jk) 
    174178         END_3D 
    175           
     179 
    176180         IF ( ll_zAimp ) THEN 
    177181            CALL tridia_solver( zwdia, zwsup, zwinf, zwi, zwi , 0 ) 
    … …  
    186190            DO_3D_00_00( 1, jpkm1 ) 
    187191               pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( ztw(ji,jj,jk) - ztw(ji  ,jj  ,jk+1) ) & 
    188                   &                                        * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
     192                  &                                     * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
    189193            END_3D 
    190194            ! 
    191195         END IF 
    192          !                 
     196         ! 
    193197         IF( l_trd .OR. l_hst )  THEN             ! trend diagnostics (contribution of upstream fluxes) 
    194198            ztrdx(:,:,:) = zwx(:,:,:)   ;   ztrdy(:,:,:) = zwy(:,:,:)   ;   ztrdz(:,:,:) = zwz(:,:,:) 
    195199         END IF 
    196200         !                             ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    197          IF( l_ptr )   zptry(:,:,:) = zwy(:,:,:)  
     201         IF( l_ptr )   zptry(:,:,:) = zwy(:,:,:) 
    198202         ! 
    199203         !        !==  anti-diffusive flux : high order minus low order  ==! 
    … …  
    225229               zC2t_u = pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj  ,jk,jn,Kmm)   ! 2 x C2 interpolation of T at u- & v-points 
    226230               zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji  ,jj+1,jk,jn,Kmm) 
    227                !                                                  ! C4 minus upstream advective fluxes  
     231               !                                                  ! C4 minus upstream advective fluxes 
    228232               zwx(ji,jj,jk) =  0.5_wp * pU(ji,jj,jk) * ( zC2t_u + zltu(ji,jj,jk) - zltu(ji+1,jj,jk) ) - zwx(ji,jj,jk) 
    229233               zwy(ji,jj,jk) =  0.5_wp * pV(ji,jj,jk) * ( zC2t_v + zltv(ji,jj,jk) - zltv(ji,jj+1,jk) ) - zwy(ji,jj,jk) 
    … …  
    245249               zC4t_u =  zC2t_u + r1_6 * ( ztu(ji-1,jj  ,jk) - ztu(ji+1,jj  ,jk) ) 
    246250               zC4t_v =  zC2t_v + r1_6 * ( ztv(ji  ,jj-1,jk) - ztv(ji  ,jj+1,jk) ) 
    247                !                                                  ! C4 minus upstream advective fluxes  
     251               !                                                  ! C4 minus upstream advective fluxes 
    248252               zwx(ji,jj,jk) =  0.5_wp * pU(ji,jj,jk) * zC4t_u - zwx(ji,jj,jk) 
    249253               zwy(ji,jj,jk) =  0.5_wp * pV(ji,jj,jk) * zC4t_v - zwy(ji,jj,jk) 
    … …  
    251255            ! 
    252256         END SELECT 
    253          !                       
     257         ! 
    254258         SELECT CASE( kn_fct_v )    !* vertical anti-diffusive fluxes (w-masked interior values) 
    255259         ! 
    … …  
    270274            zwz(:,:,1) = 0._wp   ! only ocean surface as interior zwz values have been w-masked 
    271275         ENDIF 
    272          !          
     276         ! 
    273277         IF ( ll_zAimp ) THEN 
    274278            DO_3D_00_00( 1, jpkm1 ) 
    … …  
    277281                  &      + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   & 
    278282                  &      + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) * r1_e1e2t(ji,jj) 
    279                ztw(ji,jj,jk)  = zwi(ji,jj,jk) + p2dt * ztra / e3t(ji,jj,jk,Krhs) * tmask(ji,jj,jk) 
     283               ztw(ji,jj,jk) = zwi(ji,jj,jk) + p2dt * ztra / e3t(ji,jj,jk,Krhs)*tmask(ji,jj,jk) 
    280284            END_3D 
    281285            ! 
    … …  
    316320            DO_3D_00_00( 1, jpkm1 ) 
    317321               pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( ztw(ji,jj,jk) - ztw(ji  ,jj  ,jk+1) ) & 
    318                   &                                        * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
    319             END_3D 
    320          END IF          
     322                  &                                     * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
     323            END_3D 
     324         END IF 
    321325         ! 
    322326         IF( l_trd .OR. l_hst ) THEN   ! trend diagnostics // heat/salt transport 
    323             ztrdx(:,:,:) = ztrdx(:,:,:) + zwx(:,:,:)  ! <<< add anti-diffusive fluxes  
     327            ztrdx(:,:,:) = ztrdx(:,:,:) + zwx(:,:,:)  ! <<< add anti-diffusive fluxes 
    324328            ztrdy(:,:,:) = ztrdy(:,:,:) + zwy(:,:,:)  !     to upstream fluxes 
    325329            ztrdz(:,:,:) = ztrdz(:,:,:) + zwz(:,:,:)  ! 
    … …  
    344348         DEALLOCATE( zwdia, zwinf, zwsup ) 
    345349      ENDIF 
    346       IF( l_trd .OR. l_hst ) THEN  
     350      IF( l_trd .OR. l_hst ) THEN 
    347351         DEALLOCATE( ztrdx, ztrdy, ztrdz ) 
    348352      ENDIF 
    349       IF( l_ptr ) THEN  
     353      IF( l_ptr ) THEN 
    350354         DEALLOCATE( zptry ) 
    351355      ENDIF 
    … …  
    357361      !!--------------------------------------------------------------------- 
    358362      !!                    ***  ROUTINE nonosc  *** 
    359       !!      
    360       !! **  Purpose :   compute monotonic tracer fluxes from the upstream  
    361       !!       scheme and the before field by a nonoscillatory algorithm  
     363      !! 
     364      !! **  Purpose :   compute monotonic tracer fluxes from the upstream 
     365      !!       scheme and the before field by a nonoscillatory algorithm 
    362366      !! 
    363367      !! **  Method  :   ... ??? 
    … …  
    367371      !!       in-space based differencing for fluid 
    368372      !!---------------------------------------------------------------------- 
    369       INTEGER                          , INTENT(in   ) ::   Kmm             ! time level index  
     373      INTEGER                          , INTENT(in   ) ::   Kmm             ! time level index 
    370374      REAL(wp)                         , INTENT(in   ) ::   p2dt            ! tracer time-step 
    371375      REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   pbef, paft      ! before & after field 
    … …  
    453457      !!---------------------------------------------------------------------- 
    454458      !!                  ***  ROUTINE interp_4th_cpt_org  *** 
    455       !!  
     459      !! 
    456460      !! **  Purpose :   Compute the interpolation of tracer at w-point 
    457461      !! 
    … …  
    464468      REAL(wp),DIMENSION(jpi,jpj,jpk) :: zwd, zwi, zws, zwrm, zwt 
    465469      !!---------------------------------------------------------------------- 
    466        
     470 
    467471      DO_3D_11_11( 3, jpkm1 ) 
    468472         zwd (ji,jj,jk) = 4._wp 
    … …  
    475479            zwi (ji,jj,jk) = 0._wp 
    476480            zws (ji,jj,jk) = 0._wp 
    477             zwrm(ji,jj,jk) = 0.5 * ( pt_in(ji,jj,jk-1) + pt_in(ji,jj,jk) )     
     481            zwrm(ji,jj,jk) = 0.5 * ( pt_in(ji,jj,jk-1) + pt_in(ji,jj,jk) ) 
    478482         ENDIF 
    479483      END_3D 
    … …  
    499503      END_2D 
    500504      DO_3D_11_11( 3, jpkm1 ) 
    501          pt_out(ji,jj,jk) = zwrm(ji,jj,jk) - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1)              
     505         pt_out(ji,jj,jk) = zwrm(ji,jj,jk) - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1) 
    502506      END_3D 
    503507 
    … …  
    508512         pt_out(ji,jj,jk) = ( pt_out(ji,jj,jk) - zws(ji,jj,jk) * pt_out(ji,jj,jk+1) ) / zwt(ji,jj,jk) 
    509513      END_3D 
    510       !     
     514      ! 
    511515   END SUBROUTINE interp_4th_cpt_org 
    512     
     516 
    513517 
    514518   SUBROUTINE interp_4th_cpt( pt_in, pt_out ) 
    515519      !!---------------------------------------------------------------------- 
    516520      !!                  ***  ROUTINE interp_4th_cpt  *** 
    517       !!  
     521      !! 
    518522      !! **  Purpose :   Compute the interpolation of tracer at w-point 
    519523      !! 
    … …  
    543547!      CASE( np_CEN2 )   ! 2nd order centered  at top & bottom 
    544548!      END SELECT 
    545 !!gm   
     549!!gm 
    546550      ! 
    547551      IF ( ln_isfcav ) THEN            ! set level two values which may not be set in ISF case 
    … …  
    561565         zwi (ji,jj,ikb) = 0._wp 
    562566         zws (ji,jj,ikb) = 0._wp 
    563          zwrm(ji,jj,ikb) = 0.5_wp * ( pt_in(ji,jj,ikb-1) + pt_in(ji,jj,ikb) )             
     567         zwrm(ji,jj,ikb) = 0.5_wp * ( pt_in(ji,jj,ikb-1) + pt_in(ji,jj,ikb) ) 
    564568      END_2D 
    565569      ! 
    … …  
    577581      END_2D 
    578582      DO_3D_00_00( 3, jpkm1 ) 
    579          pt_out(ji,jj,jk) = zwrm(ji,jj,jk) - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1)              
     583         pt_out(ji,jj,jk) = zwrm(ji,jj,jk) - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1) 
    580584      END_3D 
    581585 
    … …  
    586590         pt_out(ji,jj,jk) = ( pt_out(ji,jj,jk) - zws(ji,jj,jk) * pt_out(ji,jj,jk+1) ) / zwt(ji,jj,jk) 
    587591      END_3D 
    588       !     
     592      ! 
    589593   END SUBROUTINE interp_4th_cpt 
    590594 
    … …  
    593597      !!---------------------------------------------------------------------- 
    594598      !!                  ***  ROUTINE tridia_solver  *** 
    595       !!  
     599      !! 
    596600      !! **  Purpose :   solve a symmetric 3diagonal system 
    597601      !! 
    598602      !! **  Method  :   solve M.t_out = RHS(t)  where M is a tri diagonal matrix ( jpk*jpk ) 
    599       !!      
     603      !! 
    600604      !!             ( D_1 U_1  0   0   0  )( t_1 )   ( RHS_1 ) 
    601605      !!             ( L_2 D_2 U_2  0   0  )( t_2 )   ( RHS_2 ) 
    … …  
    603607      !!             (        ...          )( ... )   ( ...  ) 
    604608      !!             (  0   0   0  L_k D_k )( t_k )   ( RHS_k ) 
    605       !!      
     609      !! 
    606610      !!        M is decomposed in the product of an upper and lower triangular matrix. 
    607       !!        The tri-diagonals matrix is given as input 3D arrays:   pD, pU, pL  
     611      !!        The tri-diagonals matrix is given as input 3D arrays:   pD, pU, pL 
    608612      !!        (i.e. the Diagonal, the Upper diagonal, and the Lower diagonal). 
    609613      !!        The solution is pta. 
    … …  
    613617      REAL(wp),DIMENSION(:,:,:), INTENT(in   ) ::   pRHS          ! Right-Hand-Side 
    614618      REAL(wp),DIMENSION(:,:,:), INTENT(  out) ::   pt_out        !!gm field at level=F(klev) 
    615       INTEGER                  , INTENT(in   ) ::   klev          ! =1 pt_out at w-level  
     619      INTEGER                  , INTENT(in   ) ::   klev          ! =1 pt_out at w-level 
    616620      !                                                           ! =0 pt at t-level 
    617621      INTEGER ::   ji, jj, jk   ! dummy loop integers 
    … …  
    633637      END_2D 
    634638      DO_3D_00_00( kstart+1, jpkm1 ) 
    635          pt_out(ji,jj,jk) = pRHS(ji,jj,jk) - pL(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1)              
     639         pt_out(ji,jj,jk) = pRHS(ji,jj,jk) - pL(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1) 
    636640      END_3D 
    637641 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRA/traadv_mus.F90

    r12377 r13151  
    2929   USE in_out_manager ! I/O manager 
    3030   USE lib_mpp        ! distribued memory computing 
    31    USE lbclnk         ! ocean lateral boundary condition (or mpp link)  
    32    USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)   
     31   USE lbclnk         ! ocean lateral boundary condition (or mpp link) 
     32   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 
    3333 
    3434   IMPLICIT NONE 
    … …  
    3636 
    3737   PUBLIC   tra_adv_mus   ! routine called by traadv.F90 
    38     
     38 
    3939   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   upsmsk   !: mixed upstream/centered scheme near some straits 
    4040   !                                                           !  and in closed seas (orca 2 and 1 configurations) 
    4141   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   xind     !: mixed upstream/centered index 
    42     
     42 
    4343   LOGICAL  ::   l_trd   ! flag to compute trends 
    4444   LOGICAL  ::   l_ptr   ! flag to compute poleward transport 
    … …  
    4747   !! * Substitutions 
    4848#  include "do_loop_substitute.h90" 
     49#  include "domzgr_substitute.h90" 
    4950   !!---------------------------------------------------------------------- 
    5051   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    51    !! $Id$  
     52   !! $Id$ 
    5253   !! Software governed by the CeCILL license (see ./LICENSE) 
    5354   !!---------------------------------------------------------------------- 
    … …  
    6465      !! 
    6566      !! ** Method  : MUSCL scheme plus centered scheme at ocean boundaries 
    66       !!              ld_msc_ups=T :  
     67      !!              ld_msc_ups=T : 
    6768      !! 
    6869      !! ** Action : - update pt(:,:,:,:,Krhs)  with the now advective tracer trends 
    … …  
    8889      REAL(wp) ::   zv, z0v, zzwy, z0w           !   -      - 
    8990      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zwx, zslpx   ! 3D workspace 
    90       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zwy, zslpy   ! -      -  
     91      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zwy, zslpy   ! -      - 
    9192      !!---------------------------------------------------------------------- 
    9293      ! 
    … …  
    112113                  &                 upsmsk(:,:)                ) * tmask(:,:,jk)   ! =>0 in some user defined area 
    113114            END DO 
    114          ENDIF  
    115          ! 
    116       ENDIF  
    117       !       
     115         ENDIF 
     116         ! 
     117      ENDIF 
     118      ! 
    118119      l_trd = .FALSE. 
    119120      l_hst = .FALSE. 
    120121      l_ptr = .FALSE. 
    121122      IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) )      l_trd = .TRUE. 
    122       IF(   cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) )  )   l_ptr = .TRUE.  
     123      IF(   cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) )  )   l_ptr = .TRUE. 
    123124      IF(   cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 
    124125         &                          iom_use("uadv_salttr") .OR. iom_use("vadv_salttr")  ) ) l_hst = .TRUE. 
    … …  
    130131         !                                !-- first guess of the slopes 
    131132         zwx(:,:,jpk) = 0._wp                   ! bottom values 
    132          zwy(:,:,jpk) = 0._wp   
     133         zwy(:,:,jpk) = 0._wp 
    133134         DO_3D_10_10( 1, jpkm1 ) 
    134135            zwx(ji,jj,jk) = umask(ji,jj,jk) * ( pt(ji+1,jj,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) 
    … …  
    176177         DO_3D_00_00( 1, jpkm1 ) 
    177178            pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )       & 
    178             &                                     + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  ) )     & 
    179             &                                   * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
     179            &                                           +  zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  ) )     & 
     180            &                           * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
    180181         END_3D 
    181182         !                                ! trend diagnostics 
    … …  
    184185            CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_yad, zwy, pV, pt(:,:,:,jn,Kbb) ) 
    185186         END IF 
    186          !                                 ! "Poleward" heat and salt transports  
     187         !                                 ! "Poleward" heat and salt transports 
    187188         IF( l_ptr )  CALL dia_ptr_hst( jn, 'adv', zwy(:,:,:) ) 
    188189         !                                 !  heat transport 
    … …  
    227228         ! 
    228229         DO_3D_00_00( 1, jpkm1 ) 
    229             pt(ji,jj,jk,jn,Krhs) =  pt(ji,jj,jk,jn,Krhs) - ( zwx(ji,jj,jk) - zwx(ji,jj,jk+1) ) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
     230            pt(ji,jj,jk,jn,Krhs) =  pt(ji,jj,jk,jn,Krhs) - ( zwx(ji,jj,jk) - zwx(ji,jj,jk+1) )   & 
     231               &                                      * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
    230232         END_3D 
    231233         !                                ! send trends for diagnostic 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRA/traadv_qck.F90

    r12377 r13151  
    1919   USE trc_oce         ! share passive tracers/Ocean variables 
    2020   USE trd_oce         ! trends: ocean variables 
    21    USE trdtra          ! trends manager: tracers  
     21   USE trdtra          ! trends manager: tracers 
    2222   USE diaptr          ! poleward transport diagnostics 
    2323   USE iom 
    … …  
    2626   USE lib_mpp         ! distribued memory computing 
    2727   USE lbclnk          ! ocean lateral boundary condition (or mpp link) 
    28    USE lib_fortran     ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)   
     28   USE lib_fortran     ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 
    2929 
    3030   IMPLICIT NONE 
    … …  
    4141   !! * Substitutions 
    4242#  include "do_loop_substitute.h90" 
     43#  include "domzgr_substitute.h90" 
    4344   !!---------------------------------------------------------------------- 
    4445   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    104105      l_ptr = .FALSE. 
    105106      IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) )   l_trd = .TRUE. 
    106       IF(   cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE.  
     107      IF(   cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE. 
    107108      ! 
    108109      ! 
    109110      !        ! horizontal fluxes are computed with the QUICKEST + ULTIMATE scheme 
    110       CALL tra_adv_qck_i( kt, cdtype, p2dt, pU, Kbb, Kmm, pt, kjpt, Krhs )  
    111       CALL tra_adv_qck_j( kt, cdtype, p2dt, pV, Kbb, Kmm, pt, kjpt, Krhs )  
     111      CALL tra_adv_qck_i( kt, cdtype, p2dt, pU, Kbb, Kmm, pt, kjpt, Krhs ) 
     112      CALL tra_adv_qck_j( kt, cdtype, p2dt, pV, Kbb, Kmm, pt, kjpt, Krhs ) 
    112113 
    113114      !        ! vertical fluxes are computed with the 2nd order centered scheme 
    … …  
    137138      DO jn = 1, kjpt                                            ! tracer loop 
    138139         !                                                       ! =========== 
    139          zfu(:,:,:) = 0._wp     ;   zfc(:,:,:) = 0._wp  
    140          zfd(:,:,:) = 0._wp     ;   zwx(:,:,:) = 0._wp    
     140         zfu(:,:,:) = 0._wp     ;   zfc(:,:,:) = 0._wp 
     141         zfd(:,:,:) = 0._wp     ;   zwx(:,:,:) = 0._wp 
    141142         ! 
    142143!!gm why not using a SHIFT instruction... 
    … …  
    145146            zfd(ji,jj,jk) = pt(ji+1,jj,jk,jn,Kbb)        ! Downstream in the x-direction for the tracer 
    146147         END_3D 
    147          CALL lbc_lnk_multi( 'traadv_qck', zfc(:,:,:), 'T', 1. , zfd(:,:,:), 'T', 1. )   ! Lateral boundary conditions  
    148           
     148         CALL lbc_lnk_multi( 'traadv_qck', zfc(:,:,:), 'T', 1. , zfd(:,:,:), 'T', 1. )   ! Lateral boundary conditions 
     149 
    149150         ! 
    150151         ! Horizontal advective fluxes 
    151152         ! --------------------------- 
    152153         DO_3D_00_00( 1, jpkm1 ) 
    153             zdir = 0.5 + SIGN( 0.5, pU(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0  
    154             zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji+1,jj,jk)  ! FU in the x-direction for T  
    155          END_3D 
    156          ! 
    157          DO_3D_00_00( 1, jpkm1 ) 
    158             zdir = 0.5 + SIGN( 0.5, pU(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0  
    159             zdx = ( zdir * e1t(ji,jj) + ( 1. - zdir ) * e1t(ji+1,jj) ) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm) 
     154            zdir = 0.5 + SIGN( 0.5, pU(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0 
     155            zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji+1,jj,jk)  ! FU in the x-direction for T 
     156         END_3D 
     157         ! 
     158         DO_3D_00_00( 1, jpkm1 ) 
     159            zdir = 0.5 + SIGN( 0.5, pU(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0 
     160            zdx = ( zdir * e1t(ji,jj) + ( 1. - zdir ) * e1t(ji+1,jj) )   & 
     161               &         * e2u(ji,jj) * e3u(ji,jj,jk,Kmm) 
    160162            zwx(ji,jj,jk)  = ABS( pU(ji,jj,jk) ) * p2dt / zdx    ! (0<zc_cfl<1 : Courant number on x-direction) 
    161163            zfc(ji,jj,jk)  = zdir * pt(ji  ,jj,jk,jn,Kbb) + ( 1. - zdir ) * pt(ji+1,jj,jk,jn,Kbb)  ! FC in the x-direction for T 
    162164            zfd(ji,jj,jk)  = zdir * pt(ji+1,jj,jk,jn,Kbb) + ( 1. - zdir ) * pt(ji  ,jj,jk,jn,Kbb)  ! FD in the x-direction for T 
    163165         END_3D 
    164          !--- Lateral boundary conditions  
     166         !--- Lateral boundary conditions 
    165167         CALL lbc_lnk_multi( 'traadv_qck', zfu(:,:,:), 'T', 1. , zfd(:,:,:), 'T', 1., zfc(:,:,:), 'T', 1.,  zwx(:,:,:), 'T', 1. ) 
    166168 
    … …  
    172174            zfu(ji,jj,jk) = tmask(ji-1,jj,jk) + tmask(ji,jj,jk) + tmask(ji+1,jj,jk) - 2. 
    173175         END_3D 
    174          CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1. )      ! Lateral boundary conditions  
     176         CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1. )      ! Lateral boundary conditions 
    175177 
    176178         ! 
    177179         ! Tracer flux on the x-direction 
    178          DO jk = 1, jpkm1   
     180         DO jk = 1, jpkm1 
    179181            ! 
    180182            DO_2D_00_00 
    181                zdir = 0.5 + SIGN( 0.5, pU(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0  
     183               zdir = 0.5 + SIGN( 0.5, pU(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0 
    182184               !--- If the second ustream point is a land point 
    183185               !--- the flux is computed by the 1st order UPWIND scheme 
    … …  
    226228      DO jn = 1, kjpt                                            ! tracer loop 
    227229         !                                                       ! =========== 
    228          zfu(:,:,:) = 0.0     ;   zfc(:,:,:) = 0.0   
    229          zfd(:,:,:) = 0.0     ;   zwy(:,:,:) = 0.0      
    230          !                                                   
    231          DO jk = 1, jpkm1                                 
    232             !                                              
     230         zfu(:,:,:) = 0.0     ;   zfc(:,:,:) = 0.0 
     231         zfd(:,:,:) = 0.0     ;   zwy(:,:,:) = 0.0 
     232         ! 
     233         DO jk = 1, jpkm1 
     234            ! 
    233235            !--- Computation of the ustream and downstream value of the tracer and the mask 
    234236            DO_2D_00_00 
    … …  
    239241            END_2D 
    240242         END DO 
    241          CALL lbc_lnk_multi( 'traadv_qck', zfc(:,:,:), 'T', 1. , zfd(:,:,:), 'T', 1. )   ! Lateral boundary conditions  
    242  
    243           
     243         CALL lbc_lnk_multi( 'traadv_qck', zfc(:,:,:), 'T', 1. , zfd(:,:,:), 'T', 1. )   ! Lateral boundary conditions 
     244 
     245 
    244246         ! 
    245247         ! Horizontal advective fluxes 
    … …  
    247249         ! 
    248250         DO_3D_00_00( 1, jpkm1 ) 
    249             zdir = 0.5 + SIGN( 0.5, pV(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0  
    250             zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji,jj+1,jk)  ! FU in the x-direction for T  
    251          END_3D 
    252          ! 
    253          DO_3D_00_00( 1, jpkm1 ) 
    254             zdir = 0.5 + SIGN( 0.5, pV(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0  
    255             zdx = ( zdir * e2t(ji,jj) + ( 1. - zdir ) * e2t(ji,jj+1) ) * e1v(ji,jj) * e3v(ji,jj,jk,Kmm) 
     251            zdir = 0.5 + SIGN( 0.5, pV(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0 
     252            zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji,jj+1,jk)  ! FU in the x-direction for T 
     253         END_3D 
     254         ! 
     255         DO_3D_00_00( 1, jpkm1 ) 
     256            zdir = 0.5 + SIGN( 0.5, pV(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0 
     257            zdx = ( zdir * e2t(ji,jj) + ( 1. - zdir ) * e2t(ji,jj+1) )   & 
     258               &         * e1v(ji,jj) * e3v(ji,jj,jk,Kmm) 
    256259            zwy(ji,jj,jk)  = ABS( pV(ji,jj,jk) ) * p2dt / zdx    ! (0<zc_cfl<1 : Courant number on x-direction) 
    257260            zfc(ji,jj,jk)  = zdir * pt(ji,jj  ,jk,jn,Kbb) + ( 1. - zdir ) * pt(ji,jj+1,jk,jn,Kbb)  ! FC in the x-direction for T 
    … …  
    259262         END_3D 
    260263 
    261          !--- Lateral boundary conditions  
     264         !--- Lateral boundary conditions 
    262265         CALL lbc_lnk_multi( 'traadv_qck', zfu(:,:,:), 'T', 1. , zfd(:,:,:), 'T', 1., zfc(:,:,:), 'T', 1., zwy(:,:,:), 'T', 1. ) 
    263266 
    … …  
    269272            zfu(ji,jj,jk) = tmask(ji,jj-1,jk) + tmask(ji,jj,jk) + tmask(ji,jj+1,jk) - 2. 
    270273         END_3D 
    271          CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1. )    !--- Lateral boundary conditions  
     274         CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1. )    !--- Lateral boundary conditions 
    272275         ! 
    273276         ! Tracer flux on the x-direction 
    274          DO jk = 1, jpkm1   
     277         DO jk = 1, jpkm1 
    275278            ! 
    276279            DO_2D_00_00 
    277                zdir = 0.5 + SIGN( 0.5, pV(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0  
     280               zdir = 0.5 + SIGN( 0.5, pV(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0 
    278281               !--- If the second ustream point is a land point 
    279282               !--- the flux is computed by the 1st order UPWIND scheme 
    … …  
    312315      CHARACTER(len=3)                         , INTENT(in   ) ::   cdtype   ! =TRA or TRC (tracer indicator) 
    313316      INTEGER                                  , INTENT(in   ) ::   kjpt     ! number of tracers 
    314       REAL(wp), DIMENSION(jpi,jpj,jpk         ), INTENT(in   ) ::   pW      ! vertical velocity  
     317      REAL(wp), DIMENSION(jpi,jpj,jpk         ), INTENT(in   ) ::   pW      ! vertical velocity 
    315318      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) ::   pt              ! active tracers and RHS of tracer equation 
    316319      ! 
    … …  
    332335            IF( ln_isfcav ) THEN                  ! ice-shelf cavities (top of the ocean) 
    333336               DO_2D_11_11 
    334                   zwz(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kmm)   ! linear free surface  
     337                  zwz(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kmm)   ! linear free surface 
    335338               END_2D 
    336339            ELSE                                   ! no ocean cavities (only ocean surface) 
    … …  
    356359      !! ** Purpose :  Computation of advective flux with Quickest scheme 
    357360      !! 
    358       !! ** Method :    
     361      !! ** Method : 
    359362      !!---------------------------------------------------------------------- 
    360363      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in   ) ::   pfu   ! second upwind point 
    … …  
    363366      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   puc   ! input as Courant number ; output as flux 
    364367      !! 
    365       INTEGER  ::  ji, jj, jk               ! dummy loop indices  
    366       REAL(wp) ::  zcoef1, zcoef2, zcoef3   ! local scalars           
     368      INTEGER  ::  ji, jj, jk               ! dummy loop indices 
     369      REAL(wp) ::  zcoef1, zcoef2, zcoef3   ! local scalars 
    367370      REAL(wp) ::  zc, zcurv, zfho          !   -      - 
    368371      !---------------------------------------------------------------------- 
    … …  
    374377         zcoef2 = 0.5 * zc * ( pfd(ji,jj,jk) - pfc(ji,jj,jk) ) 
    375378         zcoef3 = ( 1. - ( zc * zc ) ) * r1_6 * zcurv 
    376          zfho   = zcoef1 - zcoef2 - zcoef3              !  phi_f QUICKEST  
     379         zfho   = zcoef1 - zcoef2 - zcoef3              !  phi_f QUICKEST 
    377380         ! 
    378381         zcoef1 = pfd(ji,jj,jk) - pfu(ji,jj,jk) 
    … …  
    380383         zcoef3 = ABS( zcurv ) 
    381384         IF( zcoef3 >= zcoef2 ) THEN 
    382             zfho = pfc(ji,jj,jk)  
     385            zfho = pfc(ji,jj,jk) 
    383386         ELSE 
    384387            zcoef3 = pfu(ji,jj,jk) + ( ( pfc(ji,jj,jk) - pfu(ji,jj,jk) ) / MAX( zc, 1.e-9 ) )    ! phi_REF 
    385388            IF( zcoef1 >= 0. ) THEN 
    386                zfho = MAX( pfc(ji,jj,jk), zfho )  
    387                zfho = MIN( zfho, MIN( zcoef3, pfd(ji,jj,jk) ) )  
     389               zfho = MAX( pfc(ji,jj,jk), zfho ) 
     390               zfho = MIN( zfho, MIN( zcoef3, pfd(ji,jj,jk) ) ) 
    388391            ELSE 
    389                zfho = MIN( pfc(ji,jj,jk), zfho )  
    390                zfho = MAX( zfho, MAX( zcoef3, pfd(ji,jj,jk) ) )  
     392               zfho = MIN( pfc(ji,jj,jk), zfho ) 
     393               zfho = MAX( zfho, MAX( zcoef3, pfd(ji,jj,jk) ) ) 
    391394            ENDIF 
    392395         ENDIF 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRA/traadv_ubs.F90

    r12377 r13151  
    1010   !!---------------------------------------------------------------------- 
    1111   !!   tra_adv_ubs : update the tracer trend with the horizontal 
    12    !!                 advection trends using a third order biaised scheme   
     12   !!                 advection trends using a third order biaised scheme 
    1313   !!---------------------------------------------------------------------- 
    1414   USE oce            ! ocean dynamics and active tracers 
    … …  
    1616   USE trc_oce        ! share passive tracers/Ocean variables 
    1717   USE trd_oce        ! trends: ocean variables 
    18    USE traadv_fct      ! acces to routine interp_4th_cpt  
    19    USE trdtra         ! trends manager: tracers  
     18   USE traadv_fct      ! acces to routine interp_4th_cpt 
     19   USE trdtra         ! trends manager: tracers 
    2020   USE diaptr         ! poleward transport diagnostics 
    2121   USE diaar5         ! AR5 diagnostics 
    … …  
    2525   USE lib_mpp        ! massively parallel library 
    2626   USE lbclnk         ! ocean lateral boundary condition (or mpp link) 
    27    USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)   
     27   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 
    2828 
    2929   IMPLICIT NONE 
    … …  
    3939   !! * Substitutions 
    4040#  include "do_loop_substitute.h90" 
     41#  include "domzgr_substitute.h90" 
    4142   !!---------------------------------------------------------------------- 
    4243   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    5051      !!---------------------------------------------------------------------- 
    5152      !!                  ***  ROUTINE tra_adv_ubs  *** 
    52       !!                  
     53      !! 
    5354      !! ** Purpose :   Compute the now trend due to the advection of tracers 
    5455      !!      and add it to the general trend of passive tracer equations. 
    … …  
    5960      !!      For example the i-component of the advective fluxes are given by : 
    6061      !!                !  e2u e3u un ( mi(Tn) - zltu(i  ) )   if un(i) >= 0 
    61       !!          ztu = !  or  
     62      !!          ztu = !  or 
    6263      !!                !  e2u e3u un ( mi(Tn) - zltu(i+1) )   if un(i) < 0 
    6364      !!      where zltu is the second derivative of the before temperature field: 
    6465      !!          zltu = 1/e3t di[ e2u e3u / e1u di[Tb] ] 
    65       !!        This results in a dissipatively dominant (i.e. hyper-diffusive)  
    66       !!      truncation error. The overall performance of the advection scheme  
    67       !!      is similar to that reported in (Farrow and Stevens, 1995).  
     66      !!        This results in a dissipatively dominant (i.e. hyper-diffusive) 
     67      !!      truncation error. The overall performance of the advection scheme 
     68      !!      is similar to that reported in (Farrow and Stevens, 1995). 
    6869      !!        For stability reasons, the first term of the fluxes which corresponds 
    69       !!      to a second order centered scheme is evaluated using the now velocity  
    70       !!      (centered in time) while the second term which is the diffusive part  
    71       !!      of the scheme, is evaluated using the before velocity (forward in time).  
     70      !!      to a second order centered scheme is evaluated using the now velocity 
     71      !!      (centered in time) while the second term which is the diffusive part 
     72      !!      of the scheme, is evaluated using the before velocity (forward in time). 
    7273      !!      Note that UBS is not positive. Do not use it on passive tracers. 
    7374      !!                On the vertical, the advection is evaluated using a FCT scheme, 
    74       !!      as the UBS have been found to be too diffusive.  
    75       !!                kn_ubs_v argument controles whether the FCT is based on  
    76       !!      a 2nd order centrered scheme (kn_ubs_v=2) or on a 4th order compact  
     75      !!      as the UBS have been found to be too diffusive. 
     76      !!                kn_ubs_v argument controles whether the FCT is based on 
     77      !!      a 2nd order centrered scheme (kn_ubs_v=2) or on a 4th order compact 
    7778      !!      scheme (kn_ubs_v=4). 
    7879      !! 
    … …  
    8182      !!             - poleward advective heat and salt transport (ln_diaptr=T) 
    8283      !! 
    83       !! Reference : Shchepetkin, A. F., J. C. McWilliams, 2005, Ocean Modelling, 9, 347-404.  
    84       !!             Farrow, D.E., Stevens, D.P., 1995, J. Phys. Ocean. 25, 1731Ð1741.  
     84      !! Reference : Shchepetkin, A. F., J. C. McWilliams, 2005, Ocean Modelling, 9, 347-404. 
     85      !!             Farrow, D.E., Stevens, D.P., 1995, J. Phys. Ocean. 25, 1731�1741. 
    8586      !!---------------------------------------------------------------------- 
    8687      INTEGER                                  , INTENT(in   ) ::   kt              ! ocean time-step index 
    … …  
    111112      l_ptr = .FALSE. 
    112113      IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) )      l_trd = .TRUE. 
    113       IF(   cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) )  )   l_ptr = .TRUE.  
     114      IF(   cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) )  )   l_ptr = .TRUE. 
    114115      IF(   cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 
    115116         &                          iom_use("uadv_salttr") .OR. iom_use("vadv_salttr")  ) ) l_hst = .TRUE. 
    … …  
    122123      DO jn = 1, kjpt                                            ! tracer loop 
    123124         !                                                       ! =========== 
    124          !                                               
     125         ! 
    125126         DO jk = 1, jpkm1        !==  horizontal laplacian of before tracer ==! 
    126127            DO_2D_10_10 
    … …  
    135136               zltv(ji,jj,jk) = (  ztv(ji,jj,jk) - ztv(ji,jj-1,jk)  ) * zcoef 
    136137            END_2D 
    137             !                                     
    138          END DO          
     138            ! 
     139         END DO 
    139140         CALL lbc_lnk( 'traadv_ubs', zltu, 'T', 1. )   ;    CALL lbc_lnk( 'traadv_ubs', zltv, 'T', 1. )   ! Lateral boundary cond. (unchanged sgn) 
    140          !     
     141         ! 
    141142         DO_3D_10_10( 1, jpkm1 ) 
    142143            zfp_ui = pU(ji,jj,jk) + ABS( pU(ji,jj,jk) )      ! upstream transport (x2) 
    … …  
    158159               pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs)                        & 
    159160                  &             - (  ztu(ji,jj,jk) - ztu(ji-1,jj  ,jk)    & 
    160                   &                + ztv(ji,jj,jk) - ztv(ji  ,jj-1,jk)  ) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
     161                  &                + ztv(ji,jj,jk) - ztv(ji  ,jj-1,jk)  ) & 
     162                  &                * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
    161163            END_2D 
    162             !                                              
     164            ! 
    163165         END DO 
    164166         ! 
    165167         zltu(:,:,:) = pt(:,:,:,jn,Krhs) - zltu(:,:,:)    ! Horizontal advective trend used in vertical 2nd order FCT case 
    166          !                                            ! and/or in trend diagnostic (l_trd=T)  
    167          !                 
     168         !                                            ! and/or in trend diagnostic (l_trd=T) 
     169         ! 
    168170         IF( l_trd ) THEN                  ! trend diagnostics 
    169171             CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, ztu, pU, pt(:,:,:,jn,Kmm) ) 
    170172             CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_yad, ztv, pV, pt(:,:,:,jn,Kmm) ) 
    171173         END IF 
    172          !      
     174         ! 
    173175         !                                ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    174176         IF( l_ptr )  CALL dia_ptr_hst( jn, 'adv', ztv(:,:,:) ) 
    … …  
    181183         SELECT CASE( kn_ubs_v )       ! select the vertical advection scheme 
    182184         ! 
    183          CASE(  2  )                   ! 2nd order FCT  
    184             !          
     185         CASE(  2  )                   ! 2nd order FCT 
     186            ! 
    185187            IF( l_trd )   zltv(:,:,:) = pt(:,:,:,jn,Krhs)          ! store pt(:,:,:,:,Krhs) if trend diag. 
    186188            ! 
    … …  
    194196               IF( ln_isfcav ) THEN                ! top of the ice-shelf cavities and at the ocean surface 
    195197                  DO_2D_11_11 
    196                      ztw(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kbb)   ! linear free surface  
     198                     ztw(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kbb)   ! linear free surface 
    197199                  END_2D 
    198200               ELSE                                ! no cavities: only at the ocean surface 
    … …  
    202204            ! 
    203205            DO_3D_00_00( 1, jpkm1 ) 
    204                ztak = - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
    205                pt(ji,jj,jk,jn,Krhs) =   pt(ji,jj,jk,jn,Krhs) +  ztak  
     206               ztak = - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) )    & 
     207                  &     * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
     208               pt(ji,jj,jk,jn,Krhs) =   pt(ji,jj,jk,jn,Krhs) +  ztak 
    206209               zti(ji,jj,jk)    = ( pt(ji,jj,jk,jn,Kbb) + p2dt * ( ztak + zltu(ji,jj,jk) ) ) * tmask(ji,jj,jk) 
    207210            END_3D 
    … …  
    228231         ! 
    229232         DO_3D_00_00( 1, jpkm1 ) 
    230             pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
     233            pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) )    & 
     234               &                                        * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
    231235         END_3D 
    232236         ! 
    … …  
    235239               zltv(ji,jj,jk) = pt(ji,jj,jk,jn,Krhs) - zltv(ji,jj,jk)                          & 
    236240                  &           + pt(ji,jj,jk,jn,Kmm) * (  pW(ji,jj,jk) - pW(ji,jj,jk+1)  )   & 
    237                   &                              * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
     241                  &                                * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
    238242            END_3D 
    239243            CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_zad, zltv ) 
    … …  
    248252      !!--------------------------------------------------------------------- 
    249253      !!                    ***  ROUTINE nonosc_z  *** 
    250       !!      
    251       !! **  Purpose :   compute monotonic tracer fluxes from the upstream  
    252       !!       scheme and the before field by a nonoscillatory algorithm  
     254      !! 
     255      !! **  Purpose :   compute monotonic tracer fluxes from the upstream 
     256      !!       scheme and the before field by a nonoscillatory algorithm 
    253257      !! 
    254258      !! **  Method  :   ... ??? 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRA/traatf.F90

    r12489 r13151  
    2626   !!---------------------------------------------------------------------- 
    2727   USE oce             ! ocean dynamics and tracers variables 
    28    USE dom_oce         ! ocean space and time domain variables  
     28   USE dom_oce         ! ocean space and time domain variables 
    2929   USE sbc_oce         ! surface boundary condition: ocean 
    3030   USE sbcrnf          ! river runoffs 
    … …  
    3333   USE domvvl          ! variable volume 
    3434   USE trd_oce         ! trends: ocean variables 
    35    USE trdtra          ! trends manager: tracers  
     35   USE trdtra          ! trends manager: tracers 
    3636   USE traqsr          ! penetrative solar radiation (needed for nksr) 
    3737   USE phycst          ! physical constant 
    … …  
    5858   !! * Substitutions 
    5959#  include "do_loop_substitute.h90" 
     60#  include "domzgr_substitute.h90" 
    6061   !!---------------------------------------------------------------------- 
    6162   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    6970      !!                   ***  ROUTINE traatf  *** 
    7071      !! 
    71       !! ** Purpose :   Apply the boundary condition on the after temperature   
     72      !! ** Purpose :   Apply the boundary condition on the after temperature 
    7273      !!             and salinity fields and add the Asselin time filter on now fields. 
    73       !!  
    74       !! ** Method  :   At this stage of the computation, ta and sa are the  
     74      !! 
     75      !! ** Method  :   At this stage of the computation, ta and sa are the 
    7576      !!             after temperature and salinity as the time stepping has 
    7677      !!             been performed in trazdf_imp or trazdf_exp module. 
    7778      !! 
    78       !!              - Apply lateral boundary conditions on (ta,sa)  
    79       !!             at the local domain   boundaries through lbc_lnk call,  
    80       !!             at the one-way open boundaries (ln_bdy=T),  
     79      !!              - Apply lateral boundary conditions on (ta,sa) 
     80      !!             at the local domain   boundaries through lbc_lnk call, 
     81      !!             at the one-way open boundaries (ln_bdy=T), 
    8182      !!             at the AGRIF zoom   boundaries (lk_agrif=T) 
    8283      !! 
    … …  
    8889      INTEGER                                  , INTENT(in   ) :: kt             ! ocean time-step index 
    8990      INTEGER                                  , INTENT(in   ) :: Kbb, Kmm, Kaa  ! time level indices 
    90       REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts            ! active tracers  
     91      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts            ! active tracers 
    9192      !! 
    9293      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    … …  
    104105 
    105106      ! Update after tracer on domain lateral boundaries 
    106       !  
     107      ! 
    107108#if defined key_agrif 
    108109      CALL Agrif_tra                     ! AGRIF zoom boundaries 
    … …  
    112113      ! 
    113114      IF( ln_bdy )   CALL bdy_tra( kt, Kbb, pts, Kaa )  ! BDY open boundaries 
    114   
     115 
    115116      ! trends computation initialisation 
    116       IF( l_trdtra )   THEN                     
     117      IF( l_trdtra )   THEN 
    117118         ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) 
    118119         ztrdt(:,:,jpk) = 0._wp 
    119120         ztrds(:,:,jpk) = 0._wp 
    120          IF( ln_traldf_iso ) THEN              ! diagnose the "pure" Kz diffusive trend  
     121         IF( ln_traldf_iso ) THEN              ! diagnose the "pure" Kz diffusive trend 
    121122            CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_tem, jptra_zdfp, ztrdt ) 
    122123            CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_sal, jptra_zdfp, ztrds ) 
    123124         ENDIF 
    124          ! total trend for the non-time-filtered variables.  
    125          zfact = 1.0 / rn_Dt 
     125         ! total trend for the non-time-filtered variables. 
     126         zfact = 1._wp / rn_Dt 
    126127         ! G Nurser 23 Mar 2017. Recalculate trend as Delta(e3t*T)/e3tn; e3tn cancel from pts(Kmm) terms 
    127128         DO jk = 1, jpkm1 
    … …  
    132133         CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_sal, jptra_tot, ztrds ) 
    133134         IF( ln_linssh ) THEN       ! linear sea surface height only 
    134             ! Store now fields before applying the Asselin filter  
     135            ! Store now fields before applying the Asselin filter 
    135136            ! in order to calculate Asselin filter trend later. 
    136             ztrdt(:,:,:) = pts(:,:,:,jp_tem,Kmm)  
     137            ztrdt(:,:,:) = pts(:,:,:,jp_tem,Kmm) 
    137138            ztrds(:,:,:) = pts(:,:,:,jp_sal,Kmm) 
    138139         ENDIF 
    … …  
    159160                  &                    pts(:,:,:,jp_tem,Kaa), 'T', 1., pts(:,:,:,jp_sal,Kaa), 'T', 1.  ) 
    160161         ! 
    161       ENDIF      
     162      ENDIF 
    162163      ! 
    163164      IF( l_trdtra .AND. ln_linssh ) THEN      ! trend of the Asselin filter (tb filtered - tb)/dt      
    164          zfact = 1._wp / rDt              
    165165         DO jk = 1, jpkm1 
    166             ztrdt(:,:,jk) = ( pts(:,:,jk,jp_tem,Kmm) - ztrdt(:,:,jk) ) * zfact 
    167             ztrds(:,:,jk) = ( pts(:,:,jk,jp_sal,Kmm) - ztrds(:,:,jk) ) * zfact 
     166            ztrdt(:,:,jk) = ( pts(:,:,jk,jp_tem,Kmm) - ztrdt(:,:,jk) ) * r1_Dt 
     167            ztrds(:,:,jk) = ( pts(:,:,jk,jp_sal,Kmm) - ztrds(:,:,jk) ) * r1_Dt 
    168168         END DO 
    169169         CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_tem, jptra_atf, ztrdt ) 
    … …  
    186186      !! 
    187187      !! ** Purpose :   fixed volume: apply the Asselin time filter to the "now" field 
    188       !!  
     188      !! 
    189189      !! ** Method  : - Apply a Asselin time filter on now fields. 
    190190      !! 
    … …  
    211211         ! 
    212212         DO_3D_00_00( 1, jpkm1 ) 
    213             ztn = pt(ji,jj,jk,jn,Kmm)                                     
     213            ztn = pt(ji,jj,jk,jn,Kmm) 
    214214            ztd = pt(ji,jj,jk,jn,Kaa) - 2._wp * ztn + pt(ji,jj,jk,jn,Kbb)  ! time laplacian on tracers 
    215215            ! 
    … …  
    226226      !!                   ***  ROUTINE tra_atf_vvl  *** 
    227227      !! 
    228       !! ** Purpose :   Time varying volume: apply the Asselin time filter   
    229       !!  
     228      !! ** Purpose :   Time varying volume: apply the Asselin time filter 
     229      !! 
    230230      !! ** Method  : - Apply a thickness weighted Asselin time filter on now fields. 
    231       !!             pt(Kmm)  = ( e3t(Kmm)*pt(Kmm) + rn_atfp*[ e3t(Kbb)*pt(Kbb) - 2 e3t(Kmm)*pt(Kmm) + e3t_a*pt(Kaa) ] ) 
    232       !!                       /( e3t(Kmm)         + rn_atfp*[ e3t(Kbb)         - 2 e3t(Kmm)         + e3t(Kaa)    ] ) 
     231      !!             pt(Kmm)  = ( e3t_Kmm*pt(Kmm) + rn_atfp*[ e3t_Kbb*pt(Kbb) - 2 e3t_Kmm*pt(Kmm) + e3t_Kaa*pt(Kaa) ] ) 
     232      !!                       /( e3t_Kmm         + rn_atfp*[ e3t_Kbb         - 2 e3t_Kmm         + e3t_Kaa    ] ) 
    233233      !! 
    234234      !! ** Action  : - pt(Kmm) ready for the next time step 
    … …  
    257257      ENDIF 
    258258      ! 
    259       IF( cdtype == 'TRA' )  THEN    
     259      IF( cdtype == 'TRA' )  THEN 
    260260         ll_traqsr  = ln_traqsr        ! active  tracers case  and  solar penetration 
    261261         ll_rnf     = ln_rnf           ! active  tracers case  and  river runoffs 
    … …  
    263263      ELSE                          ! passive tracers case 
    264264         ll_traqsr  = .FALSE.          ! NO solar penetration 
    265          ll_rnf     = .FALSE.          ! NO river runoffs ????          !!gm BUG ?   
    266          ll_isf     = .FALSE.          ! NO ice shelf melting/freezing  !!gm BUG ??  
     265         ll_rnf     = .FALSE.          ! NO river runoffs ????          !!gm BUG ? 
     266         ll_isf     = .FALSE.          ! NO ice shelf melting/freezing  !!gm BUG ?? 
    267267      ENDIF 
    268268      ! 
    … …  
    274274      zfact1 = rn_atfp * p2dt 
    275275      zfact2 = zfact1 * r1_rho0 
    276       DO jn = 1, kjpt       
     276      DO jn = 1, kjpt 
    277277         DO_3D_00_00( 1, jpkm1 ) 
    278278            ze3t_b = e3t(ji,jj,jk,Kbb) 
    … …  
    291291            ! 
    292292            ! Add asselin correction on scale factors: 
    293             zscale = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm) / ( ht(ji,jj) + 1._wp - ssmask(ji,jj) )  
    294             ze3t_f = ze3t_f - zfact2 * zscale * ( emp_b(ji,jj) - emp(ji,jj) )  
    295             IF ( ll_rnf ) ze3t_f = ze3t_f + zfact2 * zscale * (    rnf_b(ji,jj) -    rnf(ji,jj) )  
     293            zscale = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm) / ( ht(ji,jj) + 1._wp - ssmask(ji,jj) ) 
     294            ze3t_f = ze3t_f - zfact2 * zscale * ( emp_b(ji,jj) - emp(ji,jj) ) 
     295            IF ( ll_rnf ) ze3t_f = ze3t_f + zfact2 * zscale * (    rnf_b(ji,jj) -    rnf(ji,jj) ) 
    296296            IF ( ll_isf ) THEN 
    297297               IF ( ln_isfcav_mlt ) ze3t_f = ze3t_f - zfact2 * zscale * ( fwfisf_cav_b(ji,jj) - fwfisf_cav(ji,jj) ) 
    … …  
    299299            ENDIF 
    300300            ! 
    301             IF( jk == mikt(ji,jj) ) THEN           ! first level  
     301            IF( jk == mikt(ji,jj) ) THEN           ! first level 
    302302               ztc_f  = ztc_f  - zfact1 * ( psbc_tc(ji,jj,jn) - psbc_tc_b(ji,jj,jn) ) 
    303303            ENDIF 
    304304            ! 
    305305            ! solar penetration (temperature only) 
    306             IF( ll_traqsr .AND. jn == jp_tem .AND. jk <= nksr )                            &  
    307                &     ztc_f  = ztc_f  - zfact1 * ( qsr_hc(ji,jj,jk) - qsr_hc_b(ji,jj,jk) )  
     306            IF( ll_traqsr .AND. jn == jp_tem .AND. jk <= nksr )                            & 
     307               &     ztc_f  = ztc_f  - zfact1 * ( qsr_hc(ji,jj,jk) - qsr_hc_b(ji,jj,jk) ) 
    308308               ! 
    309309            ! 
    310310            IF( ll_rnf .AND. jk <= nk_rnf(ji,jj) )                                          & 
    311                &     ztc_f  = ztc_f  - zfact1 * ( rnf_tsc(ji,jj,jn) - rnf_tsc_b(ji,jj,jn) ) &  
     311               &     ztc_f  = ztc_f  - zfact1 * ( rnf_tsc(ji,jj,jn) - rnf_tsc_b(ji,jj,jn) ) & 
    312312               &                              * e3t(ji,jj,jk,Kmm) / h_rnf(ji,jj) 
    313313 
    … …  
    323323                        &                     * e3t(ji,jj,jk,Kmm) / rhisf_tbl_cav(ji,jj) 
    324324                  END IF 
    325                   ! level partially include in Losch_2008 ice shelf boundary layer  
     325                  ! level partially include in Losch_2008 ice shelf boundary layer 
    326326                  IF ( jk == misfkb_cav(ji,jj) ) THEN 
    327327                     ztc_f  = ztc_f  - zfact1 * ( risf_cav_tsc(ji,jj,jn) - risf_cav_tsc_b(ji,jj,jn) )  & 
    … …  
    337337                            &                 * e3t(ji,jj,jk,Kmm) / rhisf_tbl_par(ji,jj) 
    338338                  END IF 
    339                   ! level partially include in Losch_2008 ice shelf boundary layer  
     339                  ! level partially include in Losch_2008 ice shelf boundary layer 
    340340                  IF ( jk == misfkb_par(ji,jj) ) THEN 
    341341                     ztc_f  = ztc_f  - zfact1 * ( risf_par_tsc(ji,jj,jn) - risf_par_tsc_b(ji,jj,jn) )  & 
    … …  
    366366            ! 
    367367         END_3D 
    368          !  
     368         ! 
    369369      END DO 
    370370      ! 
    371371      IF( ( l_trdtra .AND. cdtype == 'TRA' ) .OR. ( l_trdtrc .AND. cdtype == 'TRC' ) )   THEN 
    372          IF( l_trdtra .AND. cdtype == 'TRA' ) THEN  
     372         IF( l_trdtra .AND. cdtype == 'TRA' ) THEN 
    373373            CALL trd_tra( kt, Kmm, Kaa, cdtype, jp_tem, jptra_atf, ztrd_atf(:,:,:,jp_tem) ) 
    374374            CALL trd_tra( kt, Kmm, Kaa, cdtype, jp_sal, jptra_atf, ztrd_atf(:,:,:,jp_sal) ) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRA/trabbc.F90

    r12489 r13151  
    1212 
    1313   !!---------------------------------------------------------------------- 
    14    !!   tra_bbc       : update the tracer trend at ocean bottom  
     14   !!   tra_bbc       : update the tracer trend at ocean bottom 
    1515   !!   tra_bbc_init  : initialization of geothermal heat flux trend 
    1616   !!---------------------------------------------------------------------- 
    … …  
    1919   USE phycst         ! physical constants 
    2020   USE trd_oce        ! trends: ocean variables 
    21    USE trdtra         ! trends manager: tracers  
     21   USE trdtra         ! trends manager: tracers 
    2222   ! 
    2323   USE in_out_manager ! I/O manager 
    24    USE iom            ! xIOS  
     24   USE iom            ! xIOS 
    2525   USE fldread        ! read input fields 
    2626   USE lbclnk         ! ocean lateral boundary conditions (or mpp link) 
    … …  
    4343 
    4444   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_qgh   ! structure of input qgh (file informations, fields read) 
    45   
     45 
    4646   !! * Substitutions 
    4747#  include "do_loop_substitute.h90" 
     48#  include "domzgr_substitute.h90" 
    4849   !!---------------------------------------------------------------------- 
    4950   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    5758      !!                  ***  ROUTINE tra_bbc  *** 
    5859      !! 
    59       !! ** Purpose :   Compute the bottom boundary contition on temperature  
    60       !!              associated with geothermal heating and add it to the  
     60      !! ** Purpose :   Compute the bottom boundary contition on temperature 
     61      !!              associated with geothermal heating and add it to the 
    6162      !!              general trend of temperature equations. 
    6263      !! 
    63       !! ** Method  :   The geothermal heat flux set to its constant value of  
     64      !! ** Method  :   The geothermal heat flux set to its constant value of 
    6465      !!              86.4 mW/m2 (Stein and Stein 1992, Huang 1999). 
    6566      !!       The temperature trend associated to this heat flux through the 
    … …  
    9192      !                             !  Add the geothermal trend on temperature 
    9293      DO_2D_00_00 
    93          pts(ji,jj,mbkt(ji,jj),jp_tem,Krhs) = pts(ji,jj,mbkt(ji,jj),jp_tem,Krhs) + qgh_trd0(ji,jj) / e3t(ji,jj,mbkt(ji,jj),Kmm) 
     94         pts(ji,jj,mbkt(ji,jj),jp_tem,Krhs) = pts(ji,jj,mbkt(ji,jj),jp_tem,Krhs)   & 
     95            &             + qgh_trd0(ji,jj) / e3t(ji,jj,mbkt(ji,jj),Kmm) 
    9496      END_2D 
    9597      ! 
    … …  
    133135      CHARACTER(len=256) ::   cn_dir    ! Root directory for location of ssr files 
    134136      !! 
    135       NAMELIST/nambbc/ln_trabbc, nn_geoflx, rn_geoflx_cst, sn_qgh, cn_dir  
     137      NAMELIST/nambbc/ln_trabbc, nn_geoflx, rn_geoflx_cst, sn_qgh, cn_dir 
    136138      !!---------------------------------------------------------------------- 
    137139      ! 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRA/trabbl.F90

    r12377 r13151  
    3131   USE trdtra         ! trends: active tracers 
    3232   ! 
    33    USE iom            ! IOM library                
     33   USE iom            ! IOM library 
    3434   USE in_out_manager ! I/O manager 
    3535   USE lbclnk         ! ocean lateral boundary conditions 
    3636   USE prtctl         ! Print control 
    3737   USE timing         ! Timing 
    38    USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)   
     38   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 
    3939 
    4040   IMPLICIT NONE 
    … …  
    6868   !! * Substitutions 
    6969#  include "do_loop_substitute.h90" 
     70#  include "domzgr_substitute.h90" 
    7071   !!---------------------------------------------------------------------- 
    7172   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    195196            zptb(ji,jj) = pt(ji,jj,ik,jn)                ! bottom before T and S 
    196197         END_2D 
    197          !                
     198         ! 
    198199         DO_2D_00_00 
    199200            ik = mbkt(ji,jj)                            ! bottom T-level index 
    … …  
    391392               za = zab(ji+1,jj,jp_tem) + zab(ji,jj,jp_tem)               ! 2*(alpha,beta) at u-point 
    392393               zb = zab(ji+1,jj,jp_sal) + zab(ji,jj,jp_sal) 
    393                !                                                          ! 2*masked bottom density gradient  
     394               !                                                          ! 2*masked bottom density gradient 
    394395               zgdrho = (  za * ( zts(ji+1,jj,jp_tem) - zts(ji,jj,jp_tem) )    & 
    395396                         - zb * ( zts(ji+1,jj,jp_sal) - zts(ji,jj,jp_sal) )  ) * umask(ji,jj,1) 
    … …  
    513514      END_2D 
    514515      ! converte into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk 
    515       zmbku(:,:) = REAL( mbku_d(:,:), wp )   ;     zmbkv(:,:) = REAL( mbkv_d(:,:), wp )   
    516       CALL lbc_lnk_multi( 'trabbl', zmbku,'U',1., zmbkv,'V',1.)  
     516      zmbku(:,:) = REAL( mbku_d(:,:), wp )   ;     zmbkv(:,:) = REAL( mbkv_d(:,:), wp ) 
     517      CALL lbc_lnk_multi( 'trabbl', zmbku,'U',1., zmbkv,'V',1.) 
    517518      mbku_d(:,:) = MAX( INT( zmbku(:,:) ), 1 ) ;  mbkv_d(:,:) = MAX( NINT( zmbkv(:,:) ), 1 ) 
    518519      ! 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRA/traisf.F90

    r12377 r13151  
    1111   !!---------------------------------------------------------------------- 
    1212   USE isf_oce                                     ! Ice shelf variables 
    13    USE dom_oce , ONLY : e3t, r1_e1e2t            ! ocean space domain variables 
     13   USE dom_oce                                     ! ocean space domain variables 
    1414   USE isfutils, ONLY : debug                      ! debug option 
    1515   USE timing  , ONLY : timing_start, timing_stop  ! Timing 
    … …  
    2323   !! * Substitutions 
    2424#  include "do_loop_substitute.h90" 
     25#  include "domzgr_substitute.h90" 
    2526   !!---------------------------------------------------------------------- 
    2627   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    3334      !!---------------------------------------------------------------------- 
    3435      !!                  ***  ROUTINE tra_isf  *** 
    35       !!                    
     36      !! 
    3637      !! ** Purpose :  Compute the temperature trend due to the ice shelf melting (qhoce + qhc) 
    3738      !! 
    … …  
    6162         ! 
    6263         ! Dynamical stability at start up after change in under ice shelf cavity geometry is achieve by correcting the divergence. 
    63          ! This is achieved by applying a volume flux in order to keep the horizontal divergence after remapping  
     64         ! This is achieved by applying a volume flux in order to keep the horizontal divergence after remapping 
    6465         ! the same as at the end of the latest time step. So correction need to be apply at nit000 (euler time step) and 
    6566         ! half of it at nit000+1 (leap frog time step). 
    … …  
    8990      !! *** Purpose :  Compute the temperature trend due to the ice shelf melting (qhoce + qhc) for cav or par case 
    9091      !! 
    91       !! *** Action :: Update pts(:,:,:,:,Krhs) with the surface boundary condition trend  
     92      !! *** Action :: Update pts(:,:,:,:,Krhs) with the surface boundary condition trend 
    9293      !! 
    9394      !!---------------------------------------------------------------------- 
    … …  
    9899      REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT(in   ) :: ptsc , ptsc_b 
    99100      !!---------------------------------------------------------------------- 
    100       INTEGER                      :: ji,jj,jk  ! loop index    
     101      INTEGER                      :: ji,jj,jk  ! loop index 
    101102      INTEGER                      :: ikt, ikb  ! top and bottom level of the tbl 
    102103      REAL(wp), DIMENSION(jpi,jpj) :: ztc       ! total ice shelf tracer trend 
    … …  
    117118         END DO 
    118119         ! 
    119          ! level partially include in ice shelf boundary layer  
     120         ! level partially include in ice shelf boundary layer 
    120121         pts(ji,jj,ikb,jp_tem) = pts(ji,jj,ikb,jp_tem) + ztc(ji,jj) * pfrac(ji,jj) 
    121122         ! 
    … …  
    128129      !!                  ***  ROUTINE tra_isf_cpl  *** 
    129130      !! 
    130       !! *** Action :: Update pts(:,:,:,:,Krhs) with the ice shelf coupling trend  
     131      !! *** Action :: Update pts(:,:,:,:,Krhs) with the ice shelf coupling trend 
    131132      !! 
    132133      !!---------------------------------------------------------------------- 
    … …  
    140141      ! 
    141142      DO jk = 1,jpk 
    142          ptsa(:,:,jk,jp_tem) = ptsa(:,:,jk,jp_tem) + ptsc(:,:,jk,jp_tem) * r1_e1e2t(:,:) / e3t(:,:,jk,Kmm) 
    143          ptsa(:,:,jk,jp_sal) = ptsa(:,:,jk,jp_sal) + ptsc(:,:,jk,jp_sal) * r1_e1e2t(:,:) / e3t(:,:,jk,Kmm) 
     143         ptsa(:,:,jk,jp_tem) =   & 
     144            &  ptsa(:,:,jk,jp_tem) + ptsc(:,:,jk,jp_tem) * r1_e1e2t(:,:) / e3t(:,:,jk,Kmm) 
     145         ptsa(:,:,jk,jp_sal) =   & 
     146            &  ptsa(:,:,jk,jp_sal) + ptsc(:,:,jk,jp_sal) * r1_e1e2t(:,:) / e3t(:,:,jk,Kmm) 
    144147      END DO 
    145148      ! 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRA/traldf_iso.F90

    r12489 r13151  
    1515   !!---------------------------------------------------------------------- 
    1616   !!   tra_ldf_iso   : update the tracer trend with the horizontal component of a iso-neutral laplacian operator 
    17    !!                   and with the vertical part of the isopycnal or geopotential s-coord. operator  
     17   !!                   and with the vertical part of the isopycnal or geopotential s-coord. operator 
    1818   !!---------------------------------------------------------------------- 
    1919   USE oce            ! ocean dynamics and active tracers 
    … …  
    4141   !! * Substitutions 
    4242#  include "do_loop_substitute.h90" 
     43#  include "domzgr_substitute.h90" 
    4344   !!---------------------------------------------------------------------- 
    4445   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    5455      !!                  ***  ROUTINE tra_ldf_iso  *** 
    5556      !! 
    56       !! ** Purpose :   Compute the before horizontal tracer (t & s) diffusive  
    57       !!      trend for a laplacian tensor (ezxcept the dz[ dz[.] ] term) and  
     57      !! ** Purpose :   Compute the before horizontal tracer (t & s) diffusive 
     58      !!      trend for a laplacian tensor (ezxcept the dz[ dz[.] ] term) and 
    5859      !!      add it to the general trend of tracer equation. 
    5960      !! 
    60       !! ** Method  :   The horizontal component of the lateral diffusive trends  
     61      !! ** Method  :   The horizontal component of the lateral diffusive trends 
    6162      !!      is provided by a 2nd order operator rotated along neural or geopo- 
    6263      !!      tential surfaces to which an eddy induced advection can be added 
    … …  
    6970      !! 
    7071      !!      2nd part :  horizontal fluxes of the lateral mixing operator 
    71       !!      ========     
     72      !!      ======== 
    7273      !!         zftu =  pahu e2u*e3u/e1u di[ tb ] 
    7374      !!               - pahu e2u*uslp    dk[ mi(mk(tb)) ] 
    … …  
    111112      REAL(wp) ::  zcoef0, ze3w_2, zsign                 !   -      - 
    112113      REAL(wp), DIMENSION(jpi,jpj)     ::   zdkt, zdk1t, z2d 
    113       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zdit, zdjt, zftu, zftv, ztfw  
     114      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zdit, zdjt, zftu, zftv, ztfw 
    114115      !!---------------------------------------------------------------------- 
    115116      ! 
    … …  
    119120         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 
    120121         ! 
    121          akz     (:,:,:) = 0._wp       
     122         akz     (:,:,:) = 0._wp 
    122123         ah_wslp2(:,:,:) = 0._wp 
    123124      ENDIF 
    124       !    
     125      ! 
    125126      l_hst = .FALSE. 
    126127      l_ptr = .FALSE. 
    127       IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) ) )     l_ptr = .TRUE.  
     128      IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) ) )     l_ptr = .TRUE. 
    128129      IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 
    129130         &                        iom_use("uadv_salttr") .OR. iom_use("vadv_salttr")  ) )   l_hst = .TRUE. 
    … …  
    133134      ELSE                    ;   zsign = -1._wp 
    134135      ENDIF 
    135           
     136 
    136137      !!---------------------------------------------------------------------- 
    137138      !!   0 - calculate  ah_wslp2 and akz 
    … …  
    167168            IF( ln_traldf_blp ) THEN                ! bilaplacian operator 
    168169               DO_3D_10_10( 2, jpkm1 ) 
    169                   akz(ji,jj,jk) = 16._wp * ah_wslp2(ji,jj,jk)   & 
    170                      &          * (  akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ( e3w(ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm) )  ) 
     170                  akz(ji,jj,jk) = 16._wp   & 
     171                     &   * ah_wslp2   (ji,jj,jk)   & 
     172                     &   * (  akz     (ji,jj,jk)   & 
     173                     &      + ah_wslp2(ji,jj,jk)   & 
     174                     &        / ( e3w(ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm) )  ) 
    171175               END_3D 
    172176            ELSEIF( ln_traldf_lap ) THEN              ! laplacian operator 
    … …  
    179183           ! 
    180184         ELSE                                    ! 33 flux set to zero with akz=ah_wslp2 ==>> computed in full implicit 
    181             akz(:,:,:) = ah_wslp2(:,:,:)       
     185            akz(:,:,:) = ah_wslp2(:,:,:) 
    182186         ENDIF 
    183187      ENDIF 
    … …  
    186190      DO jn = 1, kjpt                                            ! tracer loop 
    187191         !                                                       ! =========== 
    188          !                                                
    189          !!---------------------------------------------------------------------- 
    190          !!   I - masked horizontal derivative  
     192         ! 
     193         !!---------------------------------------------------------------------- 
     194         !!   I - masked horizontal derivative 
    191195         !!---------------------------------------------------------------------- 
    192196!!gm : bug.... why (x,:,:)?   (1,jpj,:) and (jpi,1,:) should be sufficient.... 
    … …  
    195199         !!end 
    196200 
    197          ! Horizontal tracer gradient  
     201         ! Horizontal tracer gradient 
    198202         DO_3D_10_10( 1, jpkm1 ) 
    199203            zdit(ji,jj,jk) = ( pt(ji+1,jj  ,jk,jn) - pt(ji,jj,jk,jn) ) * umask(ji,jj,jk) 
    … …  
    202206         IF( ln_zps ) THEN      ! botton and surface ocean correction of the horizontal gradient 
    203207            DO_2D_10_10 
    204                zdit(ji,jj,mbku(ji,jj)) = pgu(ji,jj,jn)           
     208               zdit(ji,jj,mbku(ji,jj)) = pgu(ji,jj,jn) 
    205209               zdjt(ji,jj,mbkv(ji,jj)) = pgv(ji,jj,jn) 
    206210            END_2D 
    207211            IF( ln_isfcav ) THEN      ! first wet level beneath a cavity 
    208212               DO_2D_10_10 
    209                   IF( miku(ji,jj) > 1 )   zdit(ji,jj,miku(ji,jj)) = pgui(ji,jj,jn)           
    210                   IF( mikv(ji,jj) > 1 )   zdjt(ji,jj,mikv(ji,jj)) = pgvi(ji,jj,jn)      
     213                  IF( miku(ji,jj) > 1 )   zdit(ji,jj,miku(ji,jj)) = pgui(ji,jj,jn) 
     214                  IF( mikv(ji,jj) > 1 )   zdjt(ji,jj,mikv(ji,jj)) = pgvi(ji,jj,jn) 
    211215               END_2D 
    212216            ENDIF 
    … …  
    243247               zftv(ji,jj,jk) = (  zabe2 * zdjt(ji,jj,jk)   & 
    244248                  &               + zcof2 * (  zdkt (ji,jj+1) + zdk1t(ji,jj)      & 
    245                   &                          + zdk1t(ji,jj+1) + zdkt (ji,jj)  )  ) * vmask(ji,jj,jk)                   
     249                  &                          + zdk1t(ji,jj+1) + zdkt (ji,jj)  )  ) * vmask(ji,jj,jk) 
    246250            END_2D 
    247251            ! 
    248252            DO_2D_00_00 
    249                pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + zsign * (  zftu(ji,jj,jk) - zftu(ji-1,jj,jk)      & 
    250                   &                                                 + zftv(ji,jj,jk) - zftv(ji,jj-1,jk)  )   & 
    251                   &                                              * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
     253               pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn)    & 
     254                  &       + zsign * (  zftu(ji,jj,jk) - zftu(ji-1,jj,jk) + zftv(ji,jj,jk) - zftv(ji,jj-1,jk)  )   & 
     255                  &               * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
    252256            END_2D 
    253          END DO                                        !   End of slab   
     257         END DO                                        !   End of slab 
    254258 
    255259         !!---------------------------------------------------------------------- 
    … …  
    261265         !                          ! Surface and bottom vertical fluxes set to zero 
    262266         ztfw(:,:, 1 ) = 0._wp      ;      ztfw(:,:,jpk) = 0._wp 
    263           
     267 
    264268         DO_3D_00_00( 2, jpkm1 ) 
    265269            ! 
    … …  
    290294            END_3D 
    291295            ! 
    292          ELSE                                   ! bilaplacian  
     296         ELSE                                   ! bilaplacian 
    293297            SELECT CASE( kpass ) 
    294298            CASE(  1  )                            ! 1st pass : eddy coef = ah_wslp2 
    295299               DO_3D_00_00( 2, jpkm1 ) 
    296                   ztfw(ji,jj,jk) = ztfw(ji,jj,jk)                       & 
    297                      &           + ah_wslp2(ji,jj,jk) * e1e2t(ji,jj)   & 
    298                      &           * ( pt(ji,jj,jk-1,jn) - pt(ji,jj,jk,jn) ) / e3w(ji,jj,jk,Kmm) * wmask(ji,jj,jk) 
     300                  ztfw(ji,jj,jk) =   & 
     301                     &  ztfw(ji,jj,jk) + ah_wslp2(ji,jj,jk) * e1e2t(ji,jj)   & 
     302                     &   * ( pt(ji,jj,jk-1,jn) - pt(ji,jj,jk,jn) ) / e3w(ji,jj,jk,Kmm) * wmask(ji,jj,jk) 
    299303               END_3D 
    300304            CASE(  2  )                         ! 2nd pass : eddy flux = ah_wslp2 and akz applied on pt  and pt2 gradients, resp. 
    301305               DO_3D_00_00( 2, jpkm1 ) 
    302                   ztfw(ji,jj,jk) = ztfw(ji,jj,jk) + e1e2t(ji,jj) / e3w(ji,jj,jk,Kmm) * wmask(ji,jj,jk)                  & 
     306                  ztfw(ji,jj,jk) = ztfw(ji,jj,jk) + e1e2t(ji,jj) / e3w(ji,jj,jk,Kmm) * wmask(ji,jj,jk)   & 
    303307                     &                            * (  ah_wslp2(ji,jj,jk) * ( pt (ji,jj,jk-1,jn) - pt (ji,jj,jk,jn) )   & 
    304308                     &                            +         akz(ji,jj,jk) * ( pt2(ji,jj,jk-1,jn) - pt2(ji,jj,jk,jn) )   ) 
    … …  
    306310            END SELECT 
    307311         ENDIF 
    308          !          
     312         ! 
    309313         DO_3D_00_00( 1, jpkm1 ) 
    310             pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + zsign * (  ztfw (ji,jj,jk) - ztfw(ji,jj,jk+1)  )   & 
    311                &                                              * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
     314            pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + zsign * (  ztfw (ji,jj,jk) - ztfw(ji,jj,jk+1)  ) * r1_e1e2t(ji,jj)   & 
     315               &                                             / e3t(ji,jj,jk,Kmm) 
    312316         END_3D 
    313317         ! 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRA/traldf_lap_blp.F90

    r12377 r13151  
    44   !! Ocean tracers:  lateral diffusivity trend  (laplacian and bilaplacian) 
    55   !!============================================================================== 
    6    !! History :  3.7  ! 2014-01  (G. Madec, S. Masson)  Original code, re-entrant laplacian  
     6   !! History :  3.7  ! 2014-01  (G. Madec, S. Masson)  Original code, re-entrant laplacian 
    77   !!---------------------------------------------------------------------- 
    88 
    … …  
    3838   !! * Substitutions 
    3939#  include "do_loop_substitute.h90" 
     40#  include "domzgr_substitute.h90" 
    4041   !!---------------------------------------------------------------------- 
    4142   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    4748   SUBROUTINE tra_ldf_lap( kt, Kmm, kit000, cdtype, pahu, pahv  ,               & 
    4849      &                                             pgu , pgv   , pgui, pgvi,   & 
    49       &                                             pt  , pt_rhs, kjpt, kpass )  
     50      &                                             pt  , pt_rhs, kjpt, kpass ) 
    5051      !!---------------------------------------------------------------------- 
    5152      !!                  ***  ROUTINE tra_ldf_lap  *** 
    52       !!                    
    53       !! ** Purpose :   Compute the before horizontal tracer (t & s) diffusive  
     53      !! 
     54      !! ** Purpose :   Compute the before horizontal tracer (t & s) diffusive 
    5455      !!      trend and add it to the general trend of tracer equation. 
    5556      !! 
    5657      !! ** Method  :   Second order diffusive operator evaluated using before 
    57       !!      fields (forward time scheme). The horizontal diffusive trends of  
     58      !!      fields (forward time scheme). The horizontal diffusive trends of 
    5859      !!      the tracer is given by: 
    5960      !!          difft = 1/(e1e2t*e3t) {  di-1[ pahu e2u*e3u/e1u di(tb) ] 
    … …  
    6263      !!          pt_rhs = pt_rhs + difft 
    6364      !! 
    64       !! ** Action  : - Update pt_rhs arrays with the before iso-level  
     65      !! ** Action  : - Update pt_rhs arrays with the before iso-level 
    6566      !!                harmonic mixing trend. 
    6667      !!---------------------------------------------------------------------- 
    … …  
    7576      REAL(wp), DIMENSION(jpi,jpj,    kjpt), INTENT(in   ) ::   pgui, pgvi ! tracer gradient at top   levels 
    7677      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   pt         ! before tracer fields 
    77       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pt_rhs     ! tracer trend  
     78      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pt_rhs     ! tracer trend 
    7879      ! 
    7980      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    … …  
    105106      !                             ! =========== ! 
    106107      DO jn = 1, kjpt               ! tracer loop ! 
    107          !                          ! =========== !     
    108          !                                
     108         !                          ! =========== ! 
     109         ! 
    109110         DO_3D_10_10( 1, jpkm1 ) 
    110111            ztu(ji,jj,jk) = zaheeu(ji,jj,jk) * ( pt(ji+1,jj  ,jk,jn) - pt(ji,jj,jk,jn) ) 
    … …  
    118119            IF( ln_isfcav ) THEN                ! top in ocean cavities only 
    119120               DO_2D_10_10 
    120                   IF( miku(ji,jj) > 1 )   ztu(ji,jj,miku(ji,jj)) = zaheeu(ji,jj,miku(ji,jj)) * pgui(ji,jj,jn)  
    121                   IF( mikv(ji,jj) > 1 )   ztv(ji,jj,mikv(ji,jj)) = zaheev(ji,jj,mikv(ji,jj)) * pgvi(ji,jj,jn)  
     121                  IF( miku(ji,jj) > 1 )   ztu(ji,jj,miku(ji,jj)) = zaheeu(ji,jj,miku(ji,jj)) * pgui(ji,jj,jn) 
     122                  IF( mikv(ji,jj) > 1 )   ztv(ji,jj,mikv(ji,jj)) = zaheev(ji,jj,mikv(ji,jj)) * pgvi(ji,jj,jn) 
    122123               END_2D 
    123124            ENDIF 
    … …  
    142143      ! 
    143144   END SUBROUTINE tra_ldf_lap 
    144     
     145 
    145146 
    146147   SUBROUTINE tra_ldf_blp( kt, Kmm, kit000, cdtype, pahu, pahv  ,             & 
    … …  
    149150      !!---------------------------------------------------------------------- 
    150151      !!                 ***  ROUTINE tra_ldf_blp  *** 
    151       !!                     
    152       !! ** Purpose :   Compute the before lateral tracer diffusive  
     152      !! 
     153      !! ** Purpose :   Compute the before lateral tracer diffusive 
    153154      !!      trend and add it to the general trend of tracer equation. 
    154155      !! 
    … …  
    200201      ! 
    201202      CALL lbc_lnk( 'traldf_lap_blp', zlap(:,:,:,:) , 'T', 1. )     ! Lateral boundary conditions (unchanged sign) 
    202       !                                               ! Partial top/bottom cell: GRADh( zlap )   
     203      !                                               ! Partial top/bottom cell: GRADh( zlap ) 
    203204      IF( ln_isfcav .AND. ln_zps ) THEN   ;   CALL zps_hde_isf( kt, Kmm, kjpt, zlap, zglu, zglv, zgui, zgvi )  ! both top & bottom 
    204       ELSEIF(             ln_zps ) THEN   ;   CALL zps_hde    ( kt, Kmm, kjpt, zlap, zglu, zglv )              ! only bottom  
     205      ELSEIF(             ln_zps ) THEN   ;   CALL zps_hde    ( kt, Kmm, kjpt, zlap, zglu, zglv )              ! only bottom 
    205206      ENDIF 
    206207      ! 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRA/traldf_triad.F90

    r12489 r13151  
    4141   !! * Substitutions 
    4242#  include "do_loop_substitute.h90" 
     43#  include "domzgr_substitute.h90" 
    4344   !!---------------------------------------------------------------------- 
    4445   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    108109         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~' 
    109110      ENDIF 
    110       !    
     111      ! 
    111112      l_hst = .FALSE. 
    112113      l_ptr = .FALSE. 
    … …  
    120121      ELSE                    ;   zsign = -1._wp 
    121122      ENDIF 
    122       !     
     123      ! 
    123124      !!---------------------------------------------------------------------- 
    124125      !!   0 - calculate  ah_wslp2, akz, and optionally zpsi_uw, zpsi_vw 
    … …  
    127128      IF( kpass == 1 ) THEN         !==  first pass only  and whatever the tracer is  ==! 
    128129         ! 
    129          akz     (:,:,:) = 0._wp       
     130         akz     (:,:,:) = 0._wp 
    130131         ah_wslp2(:,:,:) = 0._wp 
    131132         IF( ln_ldfeiv_dia ) THEN 
    … …  
    154155         END DO 
    155156         ! 
    156          DO jp = 0, 1                            ! j-k triads  
     157         DO jp = 0, 1                            ! j-k triads 
    157158            DO kp = 0, 1 
    158159               DO_3D_10_10( 1, jpkm1 ) 
    … …  
    179180            IF( ln_traldf_blp ) THEN                ! bilaplacian operator 
    180181               DO_3D_10_10( 2, jpkm1 ) 
    181                   akz(ji,jj,jk) = 16._wp * ah_wslp2(ji,jj,jk)   & 
    182                      &          * (  akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ( e3w(ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm) )  ) 
     182                  akz(ji,jj,jk) = 16._wp           & 
     183                     &   * ah_wslp2   (ji,jj,jk)   & 
     184                     &   * (  akz     (ji,jj,jk)   & 
     185                     &      + ah_wslp2(ji,jj,jk)   & 
     186                     &        / ( e3w (ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm) )  ) 
    183187               END_3D 
    184188            ELSEIF( ln_traldf_lap ) THEN              ! laplacian operator 
    … …  
    191195           ! 
    192196         ELSE                                    ! 33 flux set to zero with akz=ah_wslp2 ==>> computed in full implicit 
    193             akz(:,:,:) = ah_wslp2(:,:,:)       
     197            akz(:,:,:) = ah_wslp2(:,:,:) 
    194198         ENDIF 
    195199         ! 
    … …  
    218222            IF( ln_isfcav ) THEN                   ! top level (ocean cavities only) 
    219223               DO_2D_10_10 
    220                   IF( miku(ji,jj)  > 1 )   zdit(ji,jj,miku(ji,jj) ) = pgui(ji,jj,jn)  
    221                   IF( mikv(ji,jj)  > 1 )   zdjt(ji,jj,mikv(ji,jj) ) = pgvi(ji,jj,jn)  
     224                  IF( miku(ji,jj)  > 1 )   zdit(ji,jj,miku(ji,jj) ) = pgui(ji,jj,jn) 
     225                  IF( mikv(ji,jj)  > 1 )   zdjt(ji,jj,mikv(ji,jj) ) = pgvi(ji,jj,jn) 
    222226               END_2D 
    223227            ENDIF 
    … …  
    326330            !                             !==  horizontal divergence and add to the general trend  ==! 
    327331            DO_2D_00_00 
    328                pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + zsign * (  zftu(ji-1,jj,jk) - zftu(ji,jj,jk)       & 
    329                   &                                           + zftv(ji,jj-1,jk) - zftv(ji,jj,jk)   )   & 
    330                   &                                        / (  e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm)  ) 
     332               pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn)    & 
     333                  &                       + zsign * (  zftu(ji-1,jj  ,jk) - zftu(ji,jj,jk)       & 
     334                  &                                  + zftv(ji  ,jj-1,jk) - zftv(ji,jj,jk)   )   & 
     335                  &                               / (  e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm)  ) 
    331336            END_2D 
    332337            ! 
    … …  
    340345                  &                            * (  pt(ji,jj,jk-1,jn) - pt(ji,jj,jk,jn) ) 
    341346            END_3D 
    342          ELSE                                   ! bilaplacian  
     347         ELSE                                   ! bilaplacian 
    343348            SELECT CASE( kpass ) 
    344349            CASE(  1  )                            ! 1st pass : eddy coef = ah_wslp2 
    345350               DO_3D_10_00( 2, jpkm1 ) 
    346                   ztfw(ji,jj,jk) = ztfw(ji,jj,jk) - e1e2t(ji,jj) / e3w(ji,jj,jk,Kmm) * tmask(ji,jj,jk)             & 
     351                  ztfw(ji,jj,jk) = ztfw(ji,jj,jk) - e1e2t(ji,jj) / e3w(ji,jj,jk,Kmm) * tmask(ji,jj,jk)      & 
    347352                     &                            * ah_wslp2(ji,jj,jk) * ( pt(ji,jj,jk-1,jn) - pt(ji,jj,jk,jn) ) 
    348353               END_3D 
    349354            CASE(  2  )                            ! 2nd pass : eddy flux = ah_wslp2 and akz applied on pt  and pt2 gradients, resp. 
    350355               DO_3D_10_00( 2, jpkm1 ) 
    351                   ztfw(ji,jj,jk) = ztfw(ji,jj,jk) - e1e2t(ji,jj) / e3w(ji,jj,jk,Kmm) * tmask(ji,jj,jk)                      & 
     356                  ztfw(ji,jj,jk) = ztfw(ji,jj,jk) - e1e2t(ji,jj) / e3w(ji,jj,jk,Kmm) * tmask(ji,jj,jk)       & 
    352357                     &                            * (  ah_wslp2(ji,jj,jk) * ( pt (ji,jj,jk-1,jn) - pt (ji,jj,jk,jn) )   & 
    353358                     &                               + akz     (ji,jj,jk) * ( pt2(ji,jj,jk-1,jn) - pt2(ji,jj,jk,jn) )   ) 
    354359               END_3D 
    355             END SELECT  
     360            END SELECT 
    356361         ENDIF 
    357362         ! 
    358363         DO_3D_00_00( 1, jpkm1 ) 
    359             pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + zsign * (  ztfw(ji,jj,jk+1) - ztfw(ji,jj,jk)  )   & 
    360                &                                              / ( e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) ) 
     364            pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn)    & 
     365            &                                  + zsign * (  ztfw(ji,jj,jk+1) - ztfw(ji,jj,jk)  )   & 
     366               &                                       / ( e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) ) 
    361367         END_3D 
    362368         ! 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRA/tramle.F90

    r12489 r13151  
    4949   !! * Substitutions 
    5050#  include "do_loop_substitute.h90" 
     51#  include "domzgr_substitute.h90" 
    5152   !!---------------------------------------------------------------------- 
    5253   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRA/tranpc.F90

    r12489 r13151  
    3535   !! * Substitutions 
    3636#  include "do_loop_substitute.h90" 
     37#  include "domzgr_substitute.h90" 
    3738   !!---------------------------------------------------------------------- 
    3839   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    7172      REAL(wp), DIMENSION(        jpk     )   ::   zvn2         ! vertical profile of N2 at 1 given point... 
    7273      REAL(wp), DIMENSION(        jpk,jpts)   ::   zvts, zvab   ! vertical profile of T & S , and  alpha & betaat 1 given point 
    73       REAL(wp), DIMENSION(jpi,jpj,jpk     )   ::   zn2          ! N^2  
     74      REAL(wp), DIMENSION(jpi,jpj,jpk     )   ::   zn2          ! N^2 
    7475      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts)   ::   zab          ! alpha and beta 
    7576      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   ztrdt, ztrds ! 3D workspace 
    … …  
    8687         IF( l_trdtra )   THEN                    !* Save initial after fields 
    8788            ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) 
    88             ztrdt(:,:,:) = pts(:,:,:,jp_tem,Kaa)  
     89            ztrdt(:,:,:) = pts(:,:,:,jp_tem,Kaa) 
    8990            ztrds(:,:,:) = pts(:,:,:,jp_sal,Kaa) 
    9091         ENDIF 
    … …  
    9293         IF( l_LB_debug ) THEN 
    9394            ! Location of 1 known convection site to follow what's happening in the water column 
    94             ilc1 = 45 ;  jlc1 = 3 ; !  ORCA2 4x4, Antarctic coast, more than 2 unstable portions in the  water column...            
     95            ilc1 = 45 ;  jlc1 = 3 ; !  ORCA2 4x4, Antarctic coast, more than 2 unstable portions in the  water column... 
    9596            nncpu = 1  ;            ! the CPU domain contains the convection spot 
    96             klc1 =  mbkt(ilc1,jlc1) ! bottom of the ocean for debug point...           
     97            klc1 =  mbkt(ilc1,jlc1) ! bottom of the ocean for debug point... 
    9798         ENDIF 
    9899         ! 
    … …  
    105106            ! 
    106107            IF( tmask(ji,jj,2) == 1 ) THEN      ! At least 2 ocean points 
    107                !                                     ! consider one ocean column  
     108               !                                     ! consider one ocean column 
    108109               zvts(:,jp_tem) = pts(ji,jj,:,jp_tem,Kaa)      ! temperature 
    109110               zvts(:,jp_sal) = pts(ji,jj,:,jp_sal,Kaa)      ! salinity 
    110111               ! 
    111                zvab(:,jp_tem)  = zab(ji,jj,:,jp_tem)     ! Alpha  
    112                zvab(:,jp_sal)  = zab(ji,jj,:,jp_sal)     ! Beta   
    113                zvn2(:)         = zn2(ji,jj,:)            ! N^2  
     112               zvab(:,jp_tem)  = zab(ji,jj,:,jp_tem)     ! Alpha 
     113               zvab(:,jp_sal)  = zab(ji,jj,:,jp_sal)     ! Beta 
     114               zvn2(:)         = zn2(ji,jj,:)            ! N^2 
    114115               ! 
    115116               IF( l_LB_debug ) THEN                  !LB debug: 
    … …  
    117118                  IF( ( ji == ilc1 ).AND.( jj == jlc1 ) ) lp_monitor_point = .TRUE. 
    118119                  ! writing only if on CPU domain where conv region is: 
    119                   lp_monitor_point = (narea == nncpu).AND.lp_monitor_point                       
     120                  lp_monitor_point = (narea == nncpu).AND.lp_monitor_point 
    120121               ENDIF                                  !LB debug  end 
    121122               ! 
    … …  
    129130                  ! 
    130131                  jiter = jiter + 1 
    131                   !  
     132                  ! 
    132133                  IF( jiter >= 400 ) EXIT 
    133134                  ! 
    … …  
    144145                        ilayer = ilayer + 1    ! yet another instable portion of the water column found.... 
    145146                        ! 
    146                         IF( lp_monitor_point ) THEN  
     147                        IF( lp_monitor_point ) THEN 
    147148                           WRITE(numout,*) 
    148149                           IF( ilayer == 1 .AND. jiter == 1 ) THEN   ! first time a column is spoted with an instability 
    … …  
    159160                        ENDIF 
    160161                        ! 
    161                         IF( jiter == 1 )   inpcc = inpcc + 1  
     162                        IF( jiter == 1 )   inpcc = inpcc + 1 
    162163                        ! 
    163164                        IF( lp_monitor_point )   WRITE(numout, *) 'Negative N2 at ikp =',ikp,' for layer #', ilayer 
    … …  
    184185                        zsum_beta = 0._wp 
    185186                        zsum_z    = 0._wp 
    186                                                   
     187 
    187188                        DO jk = ikup, ikbot      ! Inside the instable (and overlying neutral) portion of the column 
    188189                           ! 
    … …  
    193194                           zsum_beta = zsum_beta + zvab(jk,jp_sal)*zdz 
    194195                           zsum_z    = zsum_z    + zdz 
    195                            !                               
     196                           ! 
    196197                           IF( jk == ikbot ) EXIT ! avoid array-index overshoot in case ikbot = jpk, cause we're calling jk+1 next line 
    197198                           !! EXIT when we have reached the last layer that is instable (N2<0) or neutral (N2=0): 
    198199                           IF( zvn2(jk+1) > zn2_zero ) EXIT 
    199200                        END DO 
    200                         
     201 
    201202                        ikdown = jk ! for the current unstable layer, ikdown is the deepest point with a negative or neutral N2 
    202203                        IF( ikup == ikdown )   CALL ctl_stop( 'tra_npc :  PROBLEM #2') 
    … …  
    224225                           zvab(jk,jp_sal) = zbeta 
    225226                        END DO 
    226                          
    227                          
     227 
     228 
    228229                        !! Updating N2 in the relvant portion of the water column 
    229230                        !! Temperature, Salinity, Alpha and Beta have been homogenized in the unstable portion 
    230231                        !! => Need to re-compute N2! will use Alpha and Beta! 
    231                          
     232 
    232233                        ikup   = MAX(2,ikup)         ! ikup can never be 1 ! 
    233234                        ik_low = MIN(ikdown+1,ikbot) ! we must go 1 point deeper than ikdown! 
    234                          
     235 
    235236                        DO jk = ikup, ik_low              ! we must go 1 point deeper than ikdown! 
    236237 
    … …  
    252253 
    253254                        END DO 
    254                       
     255 
    255256                        ikp = MIN(ikdown+1,ikbot) 
    256                          
     257 
    257258 
    258259                     ENDIF  !IF( zvn2(ikp) < 0. ) 
    … …  
    264265 
    265266                  IF( ikp /= ikbot )   CALL ctl_stop( 'tra_npc :  PROBLEM #3') 
    266                   
     267 
    267268                  ! ******* At this stage ikp == ikbot ! ******* 
    268                   
     269 
    269270                  IF( ilayer > 0 ) THEN      !! least an unstable layer has been found 
    270271                     ! 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRA/traqsr.F90

    r12489 r13151  
    99   !!   NEMO     1.0  !  2002-06  (G. Madec)  F90: Free form and module 
    1010   !!             -   !  2005-11  (G. Madec) zco, zps, sco coordinate 
    11    !!            3.2  !  2009-04  (G. Madec & NEMO team)  
    12    !!            3.6  !  2012-05  (C. Rousset) store attenuation coef for use in ice model  
     11   !!            3.2  !  2009-04  (G. Madec & NEMO team) 
     12   !!            3.6  !  2012-05  (C. Rousset) store attenuation coef for use in ice model 
    1313   !!            3.6  !  2015-12  (O. Aumont, J. Jouanno, C. Ethe) use vertical profile of chlorophyll 
    14    !!            3.7  !  2015-11  (G. Madec, A. Coward)  remove optimisation for fix volume  
     14   !!            3.7  !  2015-11  (G. Madec, A. Coward)  remove optimisation for fix volume 
    1515   !!---------------------------------------------------------------------- 
    1616 
    1717   !!---------------------------------------------------------------------- 
    18    !!   tra_qsr       : temperature trend due to the penetration of solar radiation  
    19    !!   tra_qsr_init  : initialization of the qsr penetration  
     18   !!   tra_qsr       : temperature trend due to the penetration of solar radiation 
     19   !!   tra_qsr_init  : initialization of the qsr penetration 
    2020   !!---------------------------------------------------------------------- 
    2121   USE oce            ! ocean dynamics and active tracers 
    … …  
    4444   !                                 !!* Namelist namtra_qsr: penetrative solar radiation 
    4545   LOGICAL , PUBLIC ::   ln_traqsr    !: light absorption (qsr) flag 
    46    LOGICAL , PUBLIC ::   ln_qsr_rgb   !: Red-Green-Blue light absorption flag   
     46   LOGICAL , PUBLIC ::   ln_qsr_rgb   !: Red-Green-Blue light absorption flag 
    4747   LOGICAL , PUBLIC ::   ln_qsr_2bd   !: 2 band         light absorption flag 
    4848   LOGICAL , PUBLIC ::   ln_qsr_bio   !: bio-model      light absorption flag 
    … …  
    5353   ! 
    5454   INTEGER , PUBLIC ::   nksr         !: levels below which the light cannot penetrate (depth larger than 391 m) 
    55   
     55 
    5656   INTEGER, PARAMETER ::   np_RGB  = 1   ! R-G-B     light penetration with constant Chlorophyll 
    5757   INTEGER, PARAMETER ::   np_RGBc = 2   ! R-G-B     light penetration with Chlorophyll data 
    … …  
    6868   !! * Substitutions 
    6969#  include "do_loop_substitute.h90" 
     70#  include "domzgr_substitute.h90" 
    7071   !!---------------------------------------------------------------------- 
    7172   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    8687      !!      Considering the 2 wavebands case: 
    8788      !!         I(k) = Qsr*( rn_abs*EXP(z(k)/rn_si0) + (1.-rn_abs)*EXP(z(k)/rn_si1) ) 
    88       !!         The temperature trend associated with the solar radiation penetration  
     89      !!         The temperature trend associated with the solar radiation penetration 
    8990      !!         is given by : zta = 1/e3t dk[ I ] / (rho0*Cp) 
    9091      !!         At the bottom, boudary condition for the radiation is no flux : 
    9192      !!      all heat which has not been absorbed in the above levels is put 
    9293      !!      in the last ocean level. 
    93       !!         The computation is only done down to the level where  
    94       !!      I(k) < 1.e-15 W/m2 (i.e. over the top nksr levels) .  
     94      !!         The computation is only done down to the level where 
     95      !!      I(k) < 1.e-15 W/m2 (i.e. over the top nksr levels) . 
    9596      !! 
    9697      !! ** Action  : - update ta with the penetrative solar radiation trend 
    … …  
    112113      REAL(wp) ::   zz0 , zz1                !    -         - 
    113114      REAL(wp) ::   zCb, zCmax, zze, zpsi, zpsimax, zdelpsi, zCtot, zCze 
    114       REAL(wp) ::   zlogc, zlogc2, zlogc3  
     115      REAL(wp) ::   zlogc, zlogc2, zlogc3 
    115116      REAL(wp), ALLOCATABLE, DIMENSION(:,:)   :: zekb, zekg, zekr 
    116117      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ze0, ze1, ze2, ze3, zea, ztrdt 
    … …  
    127128      ! 
    128129      IF( l_trdtra ) THEN      ! trends diagnostic: save the input temperature trend 
    129          ALLOCATE( ztrdt(jpi,jpj,jpk) )  
     130         ALLOCATE( ztrdt(jpi,jpj,jpk) ) 
    130131         ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) 
    131132      ENDIF 
    … …  
    162163         ALLOCATE( zekb(jpi,jpj)     , zekg(jpi,jpj)     , zekr  (jpi,jpj)     , & 
    163164            &      ze0 (jpi,jpj,jpk) , ze1 (jpi,jpj,jpk) , ze2   (jpi,jpj,jpk) , & 
    164             &      ze3 (jpi,jpj,jpk) , zea (jpi,jpj,jpk) , zchl3d(jpi,jpj,jpk)   )  
     165            &      ze3 (jpi,jpj,jpk) , zea (jpi,jpj,jpk) , zchl3d(jpi,jpj,jpk)   ) 
    165166         ! 
    166167         IF( nqsr == np_RGBc ) THEN          !*  Variable Chlorophyll 
    … …  
    182183                     zpsimax = 0.6   - 0.640 * zlogc + 0.021 * zlogc2 + 0.115 * zlogc3 
    183184                     zdelpsi = 0.710 + 0.159 * zlogc + 0.021 * zlogc2 
    184                      zCze    = 1.12  * (zchl)**0.803  
     185                     zCze    = 1.12  * (zchl)**0.803 
    185186                     ! 
    186187                     zchl3d(ji,jj,jk) = zCze * ( zCb + zCmax * EXP( -( (zpsi - zpsimax) / zdelpsi )**2 ) ) 
    … …  
    191192         ELSE                                !* constant chrlorophyll 
    192193           DO jk = 1, nksr + 1 
    193               zchl3d(:,:,jk) = 0.05  
     194              zchl3d(:,:,jk) = 0.05 
    194195            ENDDO 
    195196         ENDIF 
    … …  
    230231         END_3D 
    231232         ! 
    232          DEALLOCATE( zekb , zekg , zekr , ze0 , ze1 , ze2 , ze3 , zea , zchl3d )  
     233         DEALLOCATE( zekb , zekg , zekr , ze0 , ze1 , ze2 , ze3 , zea , zchl3d ) 
    233234         ! 
    234235      CASE( np_2BD  )            !==  2-bands fluxes  ==! 
    … …  
    239240            zc0 = zz0 * EXP( -gdepw(ji,jj,jk  ,Kmm)*xsi0r ) + zz1 * EXP( -gdepw(ji,jj,jk  ,Kmm)*xsi1r ) 
    240241            zc1 = zz0 * EXP( -gdepw(ji,jj,jk+1,Kmm)*xsi0r ) + zz1 * EXP( -gdepw(ji,jj,jk+1,Kmm)*xsi1r ) 
    241             qsr_hc(ji,jj,jk) = qsr(ji,jj) * ( zc0 * wmask(ji,jj,jk) - zc1 * wmask(ji,jj,jk+1) )  
     242            qsr_hc(ji,jj,jk) = qsr(ji,jj) * ( zc0 * wmask(ji,jj,jk) - zc1 * wmask(ji,jj,jk+1) ) 
    242243         END_3D 
    243244         ! 
    … …  
    247248      DO_3D_00_00( 1, nksr ) 
    248249         pts(ji,jj,jk,jp_tem,Krhs) = pts(ji,jj,jk,jp_tem,Krhs)   & 
    249             &                      + z1_2 * ( qsr_hc_b(ji,jj,jk) + qsr_hc(ji,jj,jk) ) / e3t(ji,jj,jk,Kmm) 
     250            &                      + z1_2 * ( qsr_hc_b(ji,jj,jk) + qsr_hc(ji,jj,jk) )   & 
     251            &                             / e3t(ji,jj,jk,Kmm) 
    250252      END_3D 
    251253      ! 
    … …  
    263265         DO jk = nksr, 1, -1 
    264266            zetot(:,:,jk) = zetot(:,:,jk+1) + qsr_hc(:,:,jk) * rho0_rcp 
    265          END DO          
     267         END DO 
    266268         CALL iom_put( 'qsr3d', zetot )   ! 3D distribution of shortwave Radiation 
    267          DEALLOCATE( zetot )  
     269         DEALLOCATE( zetot ) 
    268270      ENDIF 
    269271      ! 
    … …  
    271273         IF( lwxios ) CALL iom_swap(      cwxios_context          ) 
    272274         CALL iom_rstput( kt, nitrst, numrow, 'qsr_hc_b'   , qsr_hc     , ldxios = lwxios ) 
    273          CALL iom_rstput( kt, nitrst, numrow, 'fraqsr_1lev', fraqsr_1lev, ldxios = lwxios )  
     275         CALL iom_rstput( kt, nitrst, numrow, 'fraqsr_1lev', fraqsr_1lev, ldxios = lwxios ) 
    274276         IF( lwxios ) CALL iom_swap(      cxios_context          ) 
    275277      ENDIF 
    … …  
    278280         ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) - ztrdt(:,:,:) 
    279281         CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_qsr, ztrdt ) 
    280          DEALLOCATE( ztrdt )  
     282         DEALLOCATE( ztrdt ) 
    281283      ENDIF 
    282284      !                       ! print mean trends (used for debugging) 
    … …  
    297299      !!      from two length scale of penetration (rn_si0,rn_si1) and a ratio 
    298300      !!      (rn_abs). These parameters are read in the namtra_qsr namelist. The 
    299       !!      default values correspond to clear water (type I in Jerlov'  
     301      !!      default values correspond to clear water (type I in Jerlov' 
    300302      !!      (1968) classification. 
    301303      !!         called by tra_qsr at the first timestep (nit000) 
    … …  
    347349         &                               ' 2 bands, 3 RGB bands or bio-model light penetration' ) 
    348350      ! 
    349       IF( ln_qsr_rgb .AND. nn_chldta == 0 )   nqsr = np_RGB  
     351      IF( ln_qsr_rgb .AND. nn_chldta == 0 )   nqsr = np_RGB 
    350352      IF( ln_qsr_rgb .AND. nn_chldta == 1 )   nqsr = np_RGBc 
    351353      IF( ln_qsr_2bd                      )   nqsr = np_2BD 
    … …  
    357359      ! 
    358360      SELECT CASE( nqsr ) 
    359       !                                
     361      ! 
    360362      CASE( np_RGB , np_RGBc )         !==  Red-Green-Blue light penetration  ==! 
    361          !                              
     363         ! 
    362364         IF(lwp)   WRITE(numout,*) '   ==>>>   R-G-B   light penetration ' 
    363365         ! 
    364366         CALL trc_oce_rgb( rkrgb )                 ! tabulated attenuation coef. 
    365          !                                    
     367         ! 
    366368         nksr = trc_oce_ext_lev( r_si2, 33._wp )   ! level of light extinction 
    367369         ! 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRA/trasbc.F90

    r12489 r13151  
    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  
     11   !!            3.6  !  2014-11  (P. Mathiot) isf melting forcing 
    1212   !!            4.1  !  2019-09  (P. Mathiot) isf moved in traisf 
    1313   !!---------------------------------------------------------------------- 
    … …  
    2121   USE phycst         ! physical constant 
    2222   USE eosbn2         ! Equation Of State 
    23    USE sbcmod         ! ln_rnf   
    24    USE sbcrnf         ! River runoff   
     23   USE sbcmod         ! ln_rnf 
     24   USE sbcrnf         ! River runoff 
    2525   USE traqsr         ! solar radiation penetration 
    2626   USE trd_oce        ! trends: ocean variables 
    27    USE trdtra         ! trends manager: tracers  
    28 #if defined key_asminc    
     27   USE trdtra         ! trends manager: tracers 
     28#if defined key_asminc 
    2929   USE asminc         ! Assimilation increment 
    3030#endif 
    … …  
    4343   !! * Substitutions 
    4444#  include "do_loop_substitute.h90" 
     45#  include "domzgr_substitute.h90" 
    4546   !!---------------------------------------------------------------------- 
    4647   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    5354      !!---------------------------------------------------------------------- 
    5455      !!                  ***  ROUTINE tra_sbc  *** 
    55       !!                    
     56      !! 
    5657      !! ** Purpose :   Compute the tracer surface boundary condition trend of 
    5758      !!      (flux through the interface, concentration/dilution effect) 
    5859      !!      and add it to the general trend of tracer equations. 
    5960      !! 
    60       !! ** Method :   The (air+ice)-sea flux has two components:  
    61       !!      (1) Fext, external forcing (i.e. flux through the (air+ice)-sea interface);  
    62       !!      (2) Fwe , tracer carried with the water that is exchanged with air+ice.  
     61      !! ** Method :   The (air+ice)-sea flux has two components: 
     62      !!      (1) Fext, external forcing (i.e. flux through the (air+ice)-sea interface); 
     63      !!      (2) Fwe , tracer carried with the water that is exchanged with air+ice. 
    6364      !!               The input forcing fields (emp, rnf, sfx) contain Fext+Fwe, 
    6465      !!             they are simply added to the tracer trend (ts(Krhs)). 
    … …  
    6869      !!             concentration/dilution effect associated with water exchanges. 
    6970      !! 
    70       !! ** Action  : - Update ts(Krhs) with the surface boundary condition trend  
     71      !! ** Action  : - Update ts(Krhs) with the surface boundary condition trend 
    7172      !!              - send trends to trdtra module for further diagnostics(l_trdtra=T) 
    7273      !!---------------------------------------------------------------------- 
    … …  
    7576      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts        ! active tracers and RHS of tracer equation 
    7677      ! 
    77       INTEGER  ::   ji, jj, jk, jn              ! dummy loop indices   
     78      INTEGER  ::   ji, jj, jk, jn              ! dummy loop indices 
    7879      INTEGER  ::   ikt, ikb                    ! local integers 
    7980      REAL(wp) ::   zfact, z1_e3t, zdep, ztim   ! local scalar 
    … …  
    9091      ! 
    9192      IF( l_trdtra ) THEN                    !* Save ta and sa trends 
    92          ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) )  
     93         ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) 
    9394         ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) 
    9495         ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) 
    … …  
    127128         sbc_tsc(ji,jj,jp_sal) = r1_rho0     * sfx(ji,jj)   ! salt flux due to freezing/melting 
    128129      END_2D 
    129       IF( ln_linssh ) THEN                !* linear free surface   
     130      IF( ln_linssh ) THEN                !* linear free surface 
    130131         DO_2D_01_00 
    131132            sbc_tsc(ji,jj,jp_tem) = sbc_tsc(ji,jj,jp_tem) + r1_rho0 * emp(ji,jj) * pts(ji,jj,1,jp_tem,Kmm) 
    … …  
    138139      DO jn = 1, jpts               !==  update tracer trend  ==! 
    139140         DO_2D_01_00 
    140             pts(ji,jj,1,jn,Krhs) = pts(ji,jj,1,jn,Krhs) + zfact * ( sbc_tsc_b(ji,jj,jn) + sbc_tsc(ji,jj,jn) ) / e3t(ji,jj,1,Kmm) 
     141            pts(ji,jj,1,jn,Krhs) = pts(ji,jj,1,jn,Krhs) + zfact * ( sbc_tsc_b(ji,jj,jn) + sbc_tsc(ji,jj,jn) )    & 
     142               &                                                / e3t(ji,jj,1,Kmm) 
    141143         END_2D 
    142144      END DO 
    143       !                   
     145      ! 
    144146      IF( lrst_oce ) THEN           !==  write sbc_tsc in the ocean restart file  ==! 
    145147         IF( lwxios ) CALL iom_swap(      cwxios_context          ) 
    … …  
    153155      !---------------------------------------- 
    154156      ! 
    155       IF( ln_rnf ) THEN         ! input of heat and salt due to river runoff  
     157      IF( ln_rnf ) THEN         ! input of heat and salt due to river runoff 
    156158         zfact = 0.5_wp 
    157159         DO_2D_01_00 
    … …  
    162164                                        &                      +  ( rnf_tsc_b(ji,jj,jp_tem) + rnf_tsc(ji,jj,jp_tem) ) * zdep 
    163165                  IF( ln_rnf_sal )   pts(ji,jj,jk,jp_sal,Krhs) = pts(ji,jj,jk,jp_sal,Krhs)                                  & 
    164                                         &                      +  ( rnf_tsc_b(ji,jj,jp_sal) + rnf_tsc(ji,jj,jp_sal) ) * zdep  
     166                                        &                      +  ( rnf_tsc_b(ji,jj,jp_sal) + rnf_tsc(ji,jj,jp_sal) ) * zdep 
    165167               END DO 
    166168            ENDIF 
    … …  
    179181      IF( ln_sshinc ) THEN         ! input of heat and salt due to assimilation 
    180182          ! 
    181          IF( ln_linssh ) THEN  
     183         IF( ln_linssh ) THEN 
    182184            DO_2D_01_00 
    183185               ztim = ssh_iau(ji,jj) / e3t(ji,jj,1,Kmm) 
    … …  
    202204         CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_nsr, ztrdt ) 
    203205         CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_nsr, ztrds ) 
    204          DEALLOCATE( ztrdt , ztrds )  
     206         DEALLOCATE( ztrdt , ztrds ) 
    205207      ENDIF 
    206208      ! 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRA/trazdf.F90

    r12489 r13151  
    1313   !!---------------------------------------------------------------------- 
    1414   USE oce            ! ocean dynamics and tracers variables 
    15    USE dom_oce        ! ocean space and time domain variables  
     15   USE dom_oce        ! ocean space and time domain variables 
    1616   USE domvvl         ! variable volume 
    1717   USE phycst         ! physical constant 
    … …  
    1919   USE sbc_oce        ! surface boundary condition: ocean 
    2020   USE ldftra         ! lateral diffusion: eddy diffusivity 
    21    USE ldfslp         ! lateral diffusion: iso-neutral slope  
     21   USE ldfslp         ! lateral diffusion: iso-neutral slope 
    2222   USE trd_oce        ! trends: ocean variables 
    2323   USE trdtra         ! trends: tracer trend manager 
    … …  
    3737   !! * Substitutions 
    3838#  include "do_loop_substitute.h90" 
     39#  include "domzgr_substitute.h90" 
    3940   !!---------------------------------------------------------------------- 
    4041   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    8485      IF( l_trdtra )   THEN                      ! save the vertical diffusive trends for further diagnostics 
    8586         DO jk = 1, jpkm1 
    86             ztrdt(:,:,jk) = ( ( pts(:,:,jk,jp_tem,Kaa)*e3t(:,:,jk,Kaa) - pts(:,:,jk,jp_tem,Kbb)*e3t(:,:,jk,Kbb) ) & 
    87                &          / (e3t(:,:,jk,Kmm)*rDt) ) - ztrdt(:,:,jk) 
    88             ztrds(:,:,jk) = ( ( pts(:,:,jk,jp_sal,Kaa)*e3t(:,:,jk,Kaa) - pts(:,:,jk,jp_sal,Kbb)*e3t(:,:,jk,Kbb) ) & 
    89               &           / (e3t(:,:,jk,Kmm)*rDt) ) - ztrds(:,:,jk) 
     87            ztrdt(:,:,jk) = (   (  pts(:,:,jk,jp_tem,Kaa)*e3t(:,:,jk,Kaa)     & 
     88               &                 - pts(:,:,jk,jp_tem,Kbb)*e3t(:,:,jk,Kbb)  )  & 
     89               &              / (  e3t(:,:,jk,Kmm)*rDt  )   )                 & 
     90               &          - ztrdt(:,:,jk) 
     91            ztrds(:,:,jk) = (   (  pts(:,:,jk,jp_sal,Kaa)*e3t(:,:,jk,Kaa)     & 
     92               &                 - pts(:,:,jk,jp_sal,Kbb)*e3t(:,:,jk,Kbb)  )  & 
     93               &             / (   e3t(:,:,jk,Kmm)*rDt  )   )                 & 
     94               &          - ztrds(:,:,jk) 
    9095         END DO 
    9196!!gm this should be moved in trdtra.F90 and done on all trends 
    … …  
    104109   END SUBROUTINE tra_zdf 
    105110 
    106   
    107    SUBROUTINE tra_zdf_imp( kt, kit000, cdtype, p2dt, Kbb, Kmm, Krhs, pt, Kaa, kjpt )  
     111 
     112   SUBROUTINE tra_zdf_imp( kt, kit000, cdtype, p2dt, Kbb, Kmm, Krhs, pt, Kaa, kjpt ) 
    108113      !!---------------------------------------------------------------------- 
    109114      !!                  ***  ROUTINE tra_zdf_imp  *** 
    110115      !! 
    111116      !! ** Purpose :   Compute the after tracer through a implicit computation 
    112       !!     of the vertical tracer diffusion (including the vertical component  
    113       !!     of lateral mixing (only for 2nd order operator, for fourth order  
    114       !!     it is already computed and add to the general trend in traldf)  
     117      !!     of the vertical tracer diffusion (including the vertical component 
     118      !!     of lateral mixing (only for 2nd order operator, for fourth order 
     119      !!     it is already computed and add to the general trend in traldf) 
    115120      !! 
    116121      !! ** Method  :  The vertical diffusion of a tracer ,t , is given by: 
    … …  
    154159            zwt(:,:,1) = 0._wp 
    155160            ! 
    156             IF( l_ldfslp ) THEN            ! isoneutral diffusion: add the contribution  
    157                IF( ln_traldf_msc  ) THEN     ! MSC iso-neutral operator  
     161            IF( l_ldfslp ) THEN            ! isoneutral diffusion: add the contribution 
     162               IF( ln_traldf_msc  ) THEN     ! MSC iso-neutral operator 
    158163                  DO_3D_00_00( 2, jpkm1 ) 
    159                      zwt(ji,jj,jk) = zwt(ji,jj,jk) + akz(ji,jj,jk)   
     164                     zwt(ji,jj,jk) = zwt(ji,jj,jk) + akz(ji,jj,jk) 
    160165                  END_3D 
    161166               ELSE                          ! standard or triad iso-neutral operator 
    … …  
    200205            !   The solution will be in the 4d array pta. 
    201206            !   The 3d array zwt is used as a work space array. 
    202             !   En route to the solution pt(:,:,:,:,Kaa) is used a to evaluate the rhs and then  
     207            !   En route to the solution pt(:,:,:,:,Kaa) is used a to evaluate the rhs and then 
    203208            !   used as a work space array: its value is modified. 
    204209            ! 
    … …  
    210215            END_3D 
    211216            ! 
    212          ENDIF  
    213          !          
     217         ENDIF 
     218         ! 
    214219         DO_2D_00_00 
    215             pt(ji,jj,1,jn,Kaa) = e3t(ji,jj,1,Kbb) * pt(ji,jj,1,jn,Kbb) + p2dt * e3t(ji,jj,1,Kmm) * pt(ji,jj,1,jn,Krhs) 
     220            pt(ji,jj,1,jn,Kaa) =        e3t(ji,jj,1,Kbb) * pt(ji,jj,1,jn,Kbb)    & 
     221               &               + p2dt * e3t(ji,jj,1,Kmm) * pt(ji,jj,1,jn,Krhs) 
    216222         END_2D 
    217223         DO_3D_00_00( 2, jpkm1 ) 
    218             zrhs = e3t(ji,jj,jk,Kbb) * pt(ji,jj,jk,jn,Kbb) + p2dt * e3t(ji,jj,jk,Kmm) * pt(ji,jj,jk,jn,Krhs)   ! zrhs=right hand side 
     224            zrhs =        e3t(ji,jj,jk,Kbb) * pt(ji,jj,jk,jn,Kbb)    &  
     225               & + p2dt * e3t(ji,jj,jk,Kmm) * pt(ji,jj,jk,jn,Krhs)   ! zrhs=right hand side 
    219226            pt(ji,jj,jk,jn,Kaa) = zrhs - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) * pt(ji,jj,jk-1,jn,Kaa) 
    220227         END_3D 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRA/zpshde.F90

    r12377 r13151  
    3232   !! * Substitutions 
    3333#  include "do_loop_substitute.h90" 
     34#  include "domzgr_substitute.h90" 
    3435   !!---------------------------------------------------------------------- 
    3536   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    6566      !!              ___ |   |   |           ___  |   |   | 
    6667      !!                   
    67       !!      case 1->   e3w(i+1) >= e3w(i) ( and e3w(j+1) >= e3w(j) ) then 
    68       !!          t~ = t(i+1,j  ,k) + (e3w(i+1) - e3w(i)) * dk(Ti+1)/e3w(i+1) 
    69       !!        ( t~ = t(i  ,j+1,k) + (e3w(j+1) - e3w(j)) * dk(Tj+1)/e3w(j+1)  ) 
     68      !!      case 1->   e3w(i+1,:,:,Kmm) >= e3w(i,:,:,Kmm) ( and e3w(:,j+1,:,Kmm) >= e3w(:,j,:,Kmm) ) then 
     69      !!          t~ = t(i+1,j  ,k) + (e3w(i+1,j,k,Kmm) - e3w(i,j,k,Kmm)) * dk(Ti+1)/e3w(i+1,j,k,Kmm) 
     70      !!        ( t~ = t(i  ,j+1,k) + (e3w(i,j+1,k,Kmm) - e3w(i,j,k,Kmm)) * dk(Tj+1)/e3w(i,j+1,k,Kmm)  ) 
    7071      !!          or 
    71       !!      case 2->   e3w(i+1) <= e3w(i) ( and e3w(j+1) <= e3w(j) ) then 
    72       !!          t~ = t(i,j,k) + (e3w(i) - e3w(i+1)) * dk(Ti)/e3w(i ) 
    73       !!        ( t~ = t(i,j,k) + (e3w(j) - e3w(j+1)) * dk(Tj)/e3w(j ) ) 
     72      !!      case 2->   e3w(i+1,:,:,Kmm) <= e3w(i,:,:,Kmm) ( and e3w(:,j+1,:,Kmm) <= e3w(:,j,:,Kmm) ) then 
     73      !!          t~ = t(i,j,k) + (e3w(i,j,k,Kmm) - e3w(i+1,j,k,Kmm)) * dk(Ti)/e3w(i,j,k,Kmm) 
     74      !!        ( t~ = t(i,j,k) + (e3w(i,j,k,Kmm) - e3w(i,j+1,k,Kmm)) * dk(Tj)/e3w(i,j,k,Kmm) ) 
    7475      !!          Idem for di(s) and dj(s)           
    7576      !! 
    … …  
    109110            iku = mbku(ji,jj)   ;   ikum1 = MAX( iku - 1 , 1 )    ! last and before last ocean level at u- & v-points 
    110111            ikv = mbkv(ji,jj)   ;   ikvm1 = MAX( ikv - 1 , 1 )    ! if level first is a p-step, ik.m1=1 
    111 !!gm BUG ? when applied to before fields, e3w(:,:,:,Kbb) should be used.... 
     112!!gm BUG ? when applied to before fields, e3w(:,:,k,Kbb) should be used.... 
    112113            ze3wu = e3w(ji+1,jj  ,iku,Kmm) - e3w(ji,jj,iku,Kmm) 
    113114            ze3wv = e3w(ji  ,jj+1,ikv,Kmm) - e3w(ji,jj,ikv,Kmm) 
    … …  
    214215      !!              ___ |   |   |           ___  |   |   | 
    215216      !!                   
    216       !!      case 1->   e3w(i+1) >= e3w(i) ( and e3w(j+1) >= e3w(j) ) then 
    217       !!          t~ = t(i+1,j  ,k) + (e3w(i+1) - e3w(i)) * dk(Ti+1)/e3w(i+1) 
    218       !!        ( t~ = t(i  ,j+1,k) + (e3w(j+1) - e3w(j)) * dk(Tj+1)/e3w(j+1)  ) 
     217      !!      case 1->   e3w(i+1,j,k,Kmm) >= e3w(i,j,k,Kmm) ( and e3w(i,j+1,k,Kmm) >= e3w(i,j,k,Kmm) ) then 
     218      !!          t~ = t(i+1,j  ,k) + (e3w(i+1,j  ,k,Kmm) - e3w(i,j,k,Kmm)) * dk(Ti+1)/e3w(i+1,j  ,k,Kmm) 
     219      !!        ( t~ = t(i  ,j+1,k) + (e3w(i  ,j+1,k,Kmm) - e3w(i,j,k,Kmm)) * dk(Tj+1)/e3w(i  ,j+1,k,Kmm)  ) 
    219220      !!          or 
    220       !!      case 2->   e3w(i+1) <= e3w(i) ( and e3w(j+1) <= e3w(j) ) then 
    221       !!          t~ = t(i,j,k) + (e3w(i) - e3w(i+1)) * dk(Ti)/e3w(i ) 
    222       !!        ( t~ = t(i,j,k) + (e3w(j) - e3w(j+1)) * dk(Tj)/e3w(j ) ) 
     221      !!      case 2->   e3w(i+1,j,k,Kmm) <= e3w(i,j,k,Kmm) ( and e3w(i,j+1,k,Kmm) <= e3w(i,j,k,Kmm) ) then 
     222      !!          t~ = t(i,j,k) + (e3w(i,j,k,Kmm) - e3w(i+1,j  ,k,Kmm)) * dk(Ti)/e3w(i,j,k,Kmm) 
     223      !!        ( t~ = t(i,j,k) + (e3w(i,j,k,Kmm) - e3w(i  ,j+1,k,Kmm)) * dk(Tj)/e3w(i,j,k,Kmm) ) 
    223224      !!          Idem for di(s) and dj(s)           
    224225      !! 
    … …  
    356357            ! (ISF) case partial step top and bottom in adjacent cell in vertical 
    357358            ! cannot used e3w because if 2 cell water column, we have ps at top and bottom 
    358             ! in this case e3w(i,j) - e3w(i,j+1) is not the distance between Tj~ and Tj 
     359            ! in this case e3w(i,j,k,Kmm) - e3w(i,j+1,k,Kmm) is not the distance between Tj~ and Tj 
    359360            ! the only common depth between cells (i,j) and (i,j+1) is gdepw_0 
    360361            ze3wu  =  gdept(ji,jj,iku,Kmm) - gdept(ji+1,jj,iku,Kmm) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRD/trddyn.F90

    r12489 r13151  
    3737   !! * Substitutions 
    3838#  include "do_loop_substitute.h90" 
     39#  include "domzgr_substitute.h90" 
    3940   !!---------------------------------------------------------------------- 
    4041   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRD/trdglo.F90

    r12489 r13151  
    5252   !! * Substitutions 
    5353#  include "do_loop_substitute.h90" 
     54#  include "domzgr_substitute.h90" 
    5455   !!---------------------------------------------------------------------- 
    5556   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    116117            DO_3D_10_10( 1, jpkm1 ) 
    117118               zvt = ptrdx(ji,jj,jk) * tmask_i(ji+1,jj) * tmask_i(ji,jj) * umask(ji,jj,jk)   & 
    118                   &                                     * e1e2u  (ji,jj) * e3u(ji,jj,jk,Kmm) 
     119                  &                  * e1e2u  (ji  ,jj) * e3u(ji,jj,jk,Kmm) 
    119120               zvs = ptrdy(ji,jj,jk) * tmask_i(ji,jj+1) * tmask_i(ji,jj) * vmask(ji,jj,jk)   & 
    120                   &                                     * e1e2v  (ji,jj) * e3u(ji,jj,jk,Kmm) 
     121                  &                  * e1e2v  (ji,jj  ) * e3u(ji,jj,jk,Kmm) 
    121122               umo(ktrd) = umo(ktrd) + zvt 
    122123               vmo(ktrd) = vmo(ktrd) + zvs 
    … …  
    211212         zcof   = 0.5_wp / rho0           ! Density flux at u and v-points 
    212213         DO_3D_10_10( 1, jpkm1 ) 
    213             zkx(ji,jj,jk) = zcof * e2u(ji,jj) * e3u(ji,jj,jk,Kmm) * uu(ji,jj,jk,Kmm) * ( rhop(ji,jj,jk) + rhop(ji+1,jj,jk) ) 
    214             zky(ji,jj,jk) = zcof * e1v(ji,jj) * e3v(ji,jj,jk,Kmm) * vv(ji,jj,jk,Kmm) * ( rhop(ji,jj,jk) + rhop(ji,jj+1,jk) ) 
     214            zkx(ji,jj,jk) = zcof * e2u(ji,jj) * e3u(ji,jj,jk,Kmm)   & 
     215               &                              *  uu(ji,jj,jk,Kmm) * ( rhop(ji,jj,jk) + rhop(ji+1,jj,jk) ) 
     216            zky(ji,jj,jk) = zcof * e1v(ji,jj) * e3v(ji,jj,jk,Kmm)   & 
     217               &                              *  vv(ji,jj,jk,Kmm) * ( rhop(ji,jj,jk) + rhop(ji,jj+1,jk) ) 
    215218         END_3D 
    216219          
    … …  
    219222               &                 + zkx(ji,jj,jk) - zkx(ji-1,jj  ,jk  )               & 
    220223               &                 + zky(ji,jj,jk) - zky(ji  ,jj-1,jk  )   )           & 
    221                &              / ( e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) ) * tmask(ji,jj,jk) * tmask_i(ji,jj) 
     224               &     / ( e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) ) * tmask(ji,jj,jk) * tmask_i(ji,jj) 
    222225         END_3D 
    223226 
    … …  
    226229         peke = 0._wp 
    227230         DO jk = 1, jpkm1 
    228             peke = peke + SUM( zkepe(:,:,jk) * gdept(:,:,jk,Kmm) * e1e2t(:,:) * e3t(:,:,jk,Kmm) ) 
     231            peke = peke + SUM( zkepe(:,:,jk) * gdept(:,:,jk,Kmm) * e1e2t(:,:)   & 
     232               &                               * e3t(:,:,jk,Kmm) ) 
    229233         END DO 
    230234         peke = grav * peke 
    … …  
    524528 
    525529      DO_3D_00_00( 1, jpk ) 
    526          tvolu = tvolu + e1u(ji,jj) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm) * tmask_i(ji+1,jj  ) * tmask_i(ji,jj) * umask(ji,jj,jk) 
    527          tvolv = tvolv + e1v(ji,jj) * e2v(ji,jj) * e3v(ji,jj,jk,Kmm) * tmask_i(ji  ,jj+1) * tmask_i(ji,jj) * vmask(ji,jj,jk) 
     530         tvolu = tvolu + e1u(ji,jj) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm)   & 
     531            &                                       * tmask_i(ji+1,jj  ) * tmask_i(ji,jj) * umask(ji,jj,jk) 
     532         tvolv = tvolv + e1v(ji,jj) * e2v(ji,jj) * e3v(ji,jj,jk,Kmm)   & 
     533            &                                       * tmask_i(ji  ,jj+1) * tmask_i(ji,jj) * vmask(ji,jj,jk) 
    528534      END_3D 
    529535      CALL mpp_sum( 'trdglo', tvolu )   ! sums over the global domain 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRD/trdken.F90

    r12489 r13151  
    4141   !! * Substitutions 
    4242#  include "do_loop_substitute.h90" 
     43#  include "domzgr_substitute.h90" 
    4344   !!---------------------------------------------------------------------- 
    4445   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRD/trdmxl.F90

    r12377 r13151  
    7070   !! * Substitutions 
    7171#  include "do_loop_substitute.h90" 
     72#  include "domzgr_substitute.h90" 
    7273   !!---------------------------------------------------------------------- 
    7374   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    120121         wkx(:,:,:) = 0._wp         !==  now ML weights for vertical averaging  ==! 
    121122         DO_3D_11_11( 1, jpktrd ) 
    122             IF( jk - kmxln(ji,jj) < 0 )   wkx(ji,jj,jk) = e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk) 
     123            IF( jk - kmxln(ji,jj) < 0 )   THEN 
     124               wkx(ji,jj,jk) = e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk) 
     125            ENDIF 
    123126         END_3D 
    124127         hmxl(:,:) = 0._wp               ! NOW mixed-layer depth 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRD/trdpen.F90

    r12377 r13151  
    3535   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   rab_pe   ! partial derivatives of PE anomaly with respect to T and S 
    3636 
     37   !! * Substitutions 
     38#  include "domzgr_substitute.h90" 
    3739   !!---------------------------------------------------------------------- 
    3840   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    4042   !! Software governed by the CeCILL license (see ./LICENSE) 
    4143   !!---------------------------------------------------------------------- 
     44 
    4245CONTAINS 
    4346 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRD/trdtra.F90

    r12489 r13151  
    4242   !! * Substitutions 
    4343#  include "do_loop_substitute.h90" 
     44#  include "domzgr_substitute.h90" 
    4445   !!---------------------------------------------------------------------- 
    4546   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    128129            zwt(:,:,jpk) = 0._wp   ;   zws(:,:,jpk) = 0._wp 
    129130            DO jk = 2, jpk 
    130                zwt(:,:,jk) = avt(:,:,jk) * ( ts(:,:,jk-1,jp_tem,Krhs) - ts(:,:,jk,jp_tem,Krhs) ) / e3w(:,:,jk,Kmm) * tmask(:,:,jk) 
    131                zws(:,:,jk) = avs(:,:,jk) * ( ts(:,:,jk-1,jp_sal,Krhs) - ts(:,:,jk,jp_sal,Krhs) ) / e3w(:,:,jk,Kmm) * tmask(:,:,jk) 
     131               zwt(:,:,jk) = avt(:,:,jk) * ( ts(:,:,jk-1,jp_tem,Krhs) - ts(:,:,jk,jp_tem,Krhs) )   & 
     132                  &        / e3w(:,:,jk,Kmm) * tmask(:,:,jk) 
     133               zws(:,:,jk) = avs(:,:,jk) * ( ts(:,:,jk-1,jp_sal,Krhs) - ts(:,:,jk,jp_sal,Krhs) )   & 
     134                  &        / e3w(:,:,jk,Kmm) * tmask(:,:,jk) 
    132135            END DO 
    133136            ! 
    … …  
    142145            zwt(:,:,:) = 0._wp   ;   zws(:,:,:) = 0._wp            ! vertical diffusive fluxes 
    143146            DO jk = 2, jpk 
    144                zwt(:,:,jk) = avt_evd(:,:,jk) * ( ts(:,:,jk-1,jp_tem,Krhs) - ts(:,:,jk,jp_tem,Krhs) ) / e3w(:,:,jk,Kmm) * tmask(:,:,jk) 
    145                zws(:,:,jk) = avt_evd(:,:,jk) * ( ts(:,:,jk-1,jp_sal,Krhs) - ts(:,:,jk,jp_sal,Krhs) ) / e3w(:,:,jk,Kmm) * tmask(:,:,jk) 
     147               zwt(:,:,jk) = avt_evd(:,:,jk) * ( ts(:,:,jk-1,jp_tem,Krhs) - ts(:,:,jk,jp_tem,Krhs) )   & 
     148                  &            / e3w(:,:,jk,Kmm) * tmask(:,:,jk) 
     149               zws(:,:,jk) = avt_evd(:,:,jk) * ( ts(:,:,jk-1,jp_sal,Krhs) - ts(:,:,jk,jp_sal,Krhs) )   & 
     150                  &            / e3w(:,:,jk,Kmm) * tmask(:,:,jk) 
    146151            END DO 
    147152            ! 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRD/trdvor.F90

    r12489 r13151  
    5757   !! * Substitutions 
    5858#  include "do_loop_substitute.h90" 
     59#  include "domzgr_substitute.h90" 
    5960   !!---------------------------------------------------------------------- 
    6061   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    192193         DO jj = 1, jpjm1 
    193194            vortrd(ji,jj,ktrd) = (    zvdpvor(ji+1,jj) - zvdpvor(ji,jj)       & 
    194                  &                - ( zudpvor(ji,jj+1) - zudpvor(ji,jj) )   ) / ( e1f(ji,jj) * e2f(ji,jj) ) 
     195                 &                - ( zudpvor(ji,jj+1) - zudpvor(ji,jj) )   ) & 
     196                 &                  / ( e1f(ji,jj) * e2f(ji,jj) ) 
    195197         END DO 
    196198      END DO 
    … …  
    268270            DO jj = 1, jpjm1 
    269271               vortrd(ji,jj,jpvor_bev) = (    zvbet(ji+1,jj) - zvbet(ji,jj)     & 
    270                   &                       - ( zubet(ji,jj+1) - zubet(ji,jj) ) ) / ( e1f(ji,jj) * e2f(ji,jj) ) 
     272                  &                       - ( zubet(ji,jj+1) - zubet(ji,jj) ) ) & 
     273                  &                           / ( e1f(ji,jj) * e2f(ji,jj) ) 
    271274            END DO 
    272275         END DO 
    … …  
    283286         DO jj=1,jpjm1 
    284287            vortrd(ji,jj,ktrd) = (    zvdpvor(ji+1,jj) - zvdpvor(ji,jj)     & 
    285                &                  - ( zudpvor(ji,jj+1) - zudpvor(ji,jj) ) ) / ( e1f(ji,jj) * e2f(ji,jj) ) 
     288               &                  - ( zudpvor(ji,jj+1) - zudpvor(ji,jj) ) ) & 
     289               &                         / ( e1f(ji,jj) * e2f(ji,jj) ) 
    286290         END DO 
    287291      END DO 
    … …  
    345349         DO jj = 1, jpjm1 
    346350            vor_avr(ji,jj) = (  ( zvv(ji+1,jj) - zvv(ji,jj) )    & 
    347                &              - ( zuu(ji,jj+1) - zuu(ji,jj) ) ) / ( e1f(ji,jj) * e2f(ji,jj) ) * fmask(ji,jj,1) 
     351               &              - ( zuu(ji,jj+1) - zuu(ji,jj) ) )  & 
     352               &             / ( e1f(ji,jj) * e2f(ji,jj) ) * fmask(ji,jj,1) 
    348353         END DO 
    349354      END DO 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/ZDF/zdfddm.F90

    r12377 r13151  
    9494         DO_2D_11_11 
    9595            zrw =   ( gdepw(ji,jj,jk  ,Kmm) - gdept(ji,jj,jk,Kmm) )   & 
    96 !!gm please, use e3w(:,:,:,Kmm) below  
     96!!gm please, use e3w at Kmm below  
    9797               &  / ( gdept(ji,jj,jk-1,Kmm) - gdept(ji,jj,jk,Kmm) )  
    9898            ! 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/ZDF/zdfdrg.F90

    r12489 r13151  
    7474   !! * Substitutions 
    7575#  include "do_loop_substitute.h90" 
     76#  include "domzgr_substitute.h90" 
    7677   !!---------------------------------------------------------------------- 
    7778   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/ZDF/zdfgls.F90

    r12489 r13151  
    105105   !! * Substitutions 
    106106#  include "do_loop_substitute.h90" 
     107#  include "domzgr_substitute.h90" 
    107108   !!---------------------------------------------------------------------- 
    108109   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    263264         zcof = rfact_tke * tmask(ji,jj,jk) 
    264265         !                                        ! lower diagonal, in fact not used for jk = 2 (see surface conditions) 
    265          zd_lw(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk  ) + p_avm(ji,jj,jk-1) ) / ( e3t(ji,jj,jk-1,Kmm) * e3w(ji,jj,jk,Kmm) ) 
     266         zd_lw(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk  ) + p_avm(ji,jj,jk-1) )   & 
     267            &                 / ( e3t(ji,jj,jk-1,Kmm) * e3w(ji,jj,jk,Kmm) ) 
    266268         !                                        ! upper diagonal, in fact not used for jk = ibotm1 (see bottom conditions) 
    267          zd_up(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk+1) + p_avm(ji,jj,jk  ) ) / ( e3t(ji,jj,jk  ,Kmm) * e3w(ji,jj,jk,Kmm) ) 
     269         zd_up(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk+1) + p_avm(ji,jj,jk  ) )   & 
     270            &                 / ( e3t(ji,jj,jk  ,Kmm) * e3w(ji,jj,jk,Kmm) ) 
    268271         !                                        ! diagonal 
    269272         zdiag(ji,jj,jk) = 1._wp - zd_lw(ji,jj,jk) - zd_up(ji,jj,jk)  + rn_Dt * zdiss * wmask(ji,jj,jk)  
    … …  
    473476         zcof = rfact_psi * zwall_psi(ji,jj,jk) * tmask(ji,jj,jk) 
    474477         !                                               ! lower diagonal 
    475          zd_lw(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk  ) + p_avm(ji,jj,jk-1) ) / ( e3t(ji,jj,jk-1,Kmm) * e3w(ji,jj,jk,Kmm) ) 
     478         zd_lw(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk  ) + p_avm(ji,jj,jk-1) )   & 
     479            &            / ( e3t(ji,jj,jk-1,Kmm) * e3w(ji,jj,jk,Kmm) ) 
    476480         !                                               ! upper diagonal 
    477          zd_up(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk+1) + p_avm(ji,jj,jk  ) ) / ( e3t(ji,jj,jk  ,Kmm) * e3w(ji,jj,jk,Kmm) ) 
     481         zd_up(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk+1) + p_avm(ji,jj,jk  ) )   & 
     482            &            / ( e3t(ji,jj,jk  ,Kmm) * e3w(ji,jj,jk,Kmm) ) 
    478483         !                                               ! diagonal 
    479484         zdiag(ji,jj,jk) = 1._wp - zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) + rn_Dt * zdiss * wmask(ji,jj,jk) 
    … …  
    11001105   !!====================================================================== 
    11011106END MODULE zdfgls 
    1102  

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/ZDF/zdfiwm.F90

    r12510 r13151  
    5151   !! * Substitutions 
    5252#  include "do_loop_substitute.h90" 
     53#  include "domzgr_substitute.h90" 
    5354   !!---------------------------------------------------------------------- 
    5455   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    9495      !!                 2. Pycnocline-intensified low-mode dissipation 
    9596      !!                     zemx_iwm(z) = ( epyc_iwm / rho0 ) * ( sqrt(rn2(z))^nn_zpyc ) 
    96       !!                                   / SUM( sqrt(rn2(z))^nn_zpyc * e3w(z) ) 
     97      !!                                   / SUM( sqrt(rn2(z))^nn_zpyc * e3w[z] ) 
    9798      !!              where epyc_iwm is a map of available power, and nn_zpyc 
    9899      !!              is the chosen stratification-dependence of the internal wave 
    … …  
    100101      !!                 3. WKB-height dependent high mode dissipation 
    101102      !!                     zemx_iwm(z) = ( ebot_iwm / rho0 ) * rn2(z) * EXP(-z_wkb(z)/hbot_iwm) 
    102       !!                                   / SUM( rn2(z) * EXP(-z_wkb(z)/hbot_iwm) * e3w(z) ) 
     103      !!                                   / SUM( rn2(z) * EXP(-z_wkb(z)/hbot_iwm) * e3w[z] ) 
    103104      !!              where hbot_iwm is the characteristic length scale of the WKB bottom  
    104105      !!              intensification, ebot_iwm is a map of available power, and z_wkb is the 
    105106      !!              WKB-stretched height above bottom defined as 
    106       !!                    z_wkb(z) = H * SUM( sqrt(rn2(z'>=z)) * e3w(z'>=z) ) 
    107       !!                                 / SUM( sqrt(rn2(z'))    * e3w(z')    ) 
     107      !!                    z_wkb(z) = H * SUM( sqrt(rn2(z'>=z)) * e3w[z'>=z) ) 
     108      !!                                 / SUM( sqrt(rn2(z'))    * e3w[z')    ) 
    108109      !! 
    109110      !!              - update the model vertical eddy viscosity and diffusivity:  
    … …  
    178179         zfact(:,:) = 0._wp 
    179180         DO jk = 2, jpkm1              ! part independent of the level 
    180             zfact(:,:) = zfact(:,:) + e3w(:,:,jk,Kmm) * SQRT(  MAX( 0._wp, rn2(:,:,jk) )  ) * wmask(:,:,jk) 
     181            zfact(:,:) =   & 
     182               &  zfact(:,:) +   & 
     183               &  e3w(:,:,jk,Kmm) * SQRT(  MAX( 0._wp, rn2(:,:,jk) )  ) * wmask(:,:,jk) 
    181184         END DO 
    182185         ! 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/ZDF/zdfmxl.F90

    r12489 r13151  
    3838   !! * Substitutions 
    3939#  include "do_loop_substitute.h90" 
     40#  include "domzgr_substitute.h90" 
    4041   !!---------------------------------------------------------------------- 
    4142   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    100101      DO_3D_11_11( nlb10, jpkm1 ) 
    101102         ikt = mbkt(ji,jj) 
    102          hmlp(ji,jj) = hmlp(ji,jj) + MAX( rn2b(ji,jj,jk) , 0._wp ) * e3w(ji,jj,jk,Kmm) 
     103         hmlp(ji,jj) =   & 
     104            & hmlp(ji,jj) + MAX( rn2b(ji,jj,jk) , 0._wp ) * e3w(ji,jj,jk,Kmm) 
    103105         IF( hmlp(ji,jj) < zN2_c )   nmln(ji,jj) = MIN( jk , ikt ) + 1   ! Mixed layer level 
    104106      END_3D 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/ZDF/zdfosm.F90

    r12489 r13151  
    103103   INTEGER :: idebug = 236 
    104104   INTEGER :: jdebug = 228 
     105    
    105106   !! * Substitutions 
    106107#  include "do_loop_substitute.h90" 
     108#  include "domzgr_substitute.h90" 
    107109   !!---------------------------------------------------------------------- 
    108110   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    503505                       & - zbeta * ( zs_bl(ji,jj) - ts(ji,jj,jm,jp_sal,Kmm) ) ), 0.0 ) + zvel_max 
    504506 
    505                   zhbl_s = zhbl_s + MIN( - zwb_ent(ji,jj) / zdb * rn_Dt / FLOAT(ibld(ji,jj)-imld(ji,jj) ), e3w(ji,jj,jk,Kmm) ) 
     507                  zhbl_s = zhbl_s + MIN( - zwb_ent(ji,jj) / zdb * rn_Dt / FLOAT(ibld(ji,jj)-imld(ji,jj) ),   & 
     508                     &                     e3w(ji,jj,jk,Kmm) ) 
     509                      
    506510                  zhbl_s = MIN(zhbl_s, ht(ji,jj)) 
    507511 
    … …  
    594598                     zwb_ent(ji,jj) = 0._wp 
    595599                  ENDIF 
    596                   inhml = MAX( INT( zari * zhbl(ji,jj) / e3t(ji,jj,ibld(ji,jj),Kmm) ) , 1 ) 
     600                  inhml = MAX( INT( zari * zhbl(ji,jj)   & 
     601                     &              / e3t(ji,jj,ibld(ji,jj),Kmm) ), 1 ) 
    597602                  imld(ji,jj) = MAX( ibld(ji,jj) - inhml, 1) 
    598603                  zhml(ji,jj) = gdepw(ji,jj,imld(ji,jj),Kmm) 
    … …  
    608613                  IF ( zdb_bl(ji,jj) > 0._wp ) THEN 
    609614               ! pycnocline thickness set by stratification - use same relationship as for neutral conditions. 
    610                      zari = MIN( 4.5 * ( zvstr(ji,jj)**2 ) & 
    611                        & / ( zdb_bl(ji,jj) * zhbl(ji,jj) ) + 0.01  , 0.2 ) 
    612                      inhml = MAX( INT( zari * zhbl(ji,jj) / e3t(ji,jj,ibld(ji,jj),Kmm) ) , 1 ) 
     615                     zari = MIN( 4.5 * ( zvstr(ji,jj)**2 )   & 
     616                        & / ( zdb_bl(ji,jj) * zhbl(ji,jj) ) + 0.01  , 0.2 ) 
     617                     inhml = MAX( INT( zari * zhbl(ji,jj)   & 
     618                        &             / e3t(ji,jj,ibld(ji,jj),Kmm) ), 1 ) 
    613619                     imld(ji,jj) = MAX( ibld(ji,jj) - inhml, 1) 
    614620                     zhml(ji,jj) = gdepw(ji,jj,imld(ji,jj),Kmm) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/ZDF/zdfsh2.F90

    r12377 r13151  
    2424   !! * Substitutions 
    2525#  include "do_loop_substitute.h90" 
     26#  include "domzgr_substitute.h90" 
    2627   !!---------------------------------------------------------------------- 
    2728   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    6263            zsh2u(ji,jj) = ( p_avm(ji+1,jj,jk) + p_avm(ji,jj,jk) ) & 
    6364               &         * (   uu(ji,jj,jk-1,Kmm) -   uu(ji,jj,jk,Kmm) ) & 
    64                &         * (   uu(ji,jj,jk-1,Kbb) -   uu(ji,jj,jk,Kbb) ) / ( e3uw(ji,jj,jk,Kmm) * e3uw(ji,jj,jk,Kbb) ) * wumask(ji,jj,jk) 
     65               &         * (   uu(ji,jj,jk-1,Kbb) -   uu(ji,jj,jk,Kbb) ) &  
     66               &         / ( e3uw(ji,jj,jk  ,Kmm) * e3uw(ji,jj,jk,Kbb) ) & 
     67               &         * wumask(ji,jj,jk) 
    6568            zsh2v(ji,jj) = ( p_avm(ji,jj+1,jk) + p_avm(ji,jj,jk) ) & 
    6669               &         * (   vv(ji,jj,jk-1,Kmm) -   vv(ji,jj,jk,Kmm) ) & 
    67                &         * (   vv(ji,jj,jk-1,Kbb) -   vv(ji,jj,jk,Kbb) ) / ( e3vw(ji,jj,jk,Kmm) * e3vw(ji,jj,jk,Kbb) ) * wvmask(ji,jj,jk) 
     70               &         * (   vv(ji,jj,jk-1,Kbb) -   vv(ji,jj,jk,Kbb) ) & 
     71               &         / ( e3vw(ji,jj,jk  ,Kmm) * e3vw(ji,jj,jk,Kbb) ) & 
     72               &         * wvmask(ji,jj,jk) 
    6873         END_2D 
    6974         DO_2D_00_00 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/ZDF/zdftke.F90

    r12489 r13151  
    9090   !! * Substitutions 
    9191#  include "do_loop_substitute.h90" 
     92#  include "domzgr_substitute.h90" 
    9293   !!---------------------------------------------------------------------- 
    9394   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    214215      !                     !  Surface/top/bottom boundary condition on tke 
    215216      !                     !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    216        
     217      !  
    217218      DO_2D_00_00 
    218219         en(ji,jj,1) = MAX( rn_emin0, zbbrau * taum(ji,jj) ) * tmask(ji,jj,1) 
    219220      END_2D 
    220       IF ( ln_isfcav ) THEN 
    221          DO_2D_00_00 
    222             en(ji,jj,mikt(ji,jj)) = rn_emin * tmask(ji,jj,1) 
    223          END_2D 
    224       ENDIF 
    225221      ! 
    226222      !                     !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    … …  
    249245               zetop = - 0.001875_wp * rCdU_top(ji,jj) * SQRT(  ( zmsku*( uu(ji,jj,mikt(ji,jj),Kbb)+uu(ji-1,jj,mikt(ji,jj),Kbb) ) )**2  & 
    250246                  &                                           + ( zmskv*( vv(ji,jj,mikt(ji,jj),Kbb)+vv(ji,jj-1,mikt(ji,jj),Kbb) ) )**2  ) 
    251                en(ji,jj,mikt(ji,jj)) = MAX( zetop, rn_emin ) * (1._wp - tmask(ji,jj,1))   ! masked at ocean surface 
     247               en(ji,jj,mikt(ji,jj)) = en(ji,jj,1) * tmask(ji,jj,1) + MAX( zetop, rn_emin ) * (1._wp - tmask(ji,jj,1)) * ssmask(ji,jj)   ! masked at ocean surface 
    252248            END_2D 
    253249         ENDIF 
    … …  
    260256         ! 
    261257         !                        !* total energy produce by LC : cumulative sum over jk 
    262          zpelc(:,:,1) =  MAX( rn2b(:,:,1), 0._wp ) * gdepw(:,:,1,Kmm) * e3w(:,:,1,Kmm) 
     258         zpelc(:,:,1) = MAX( rn2b(:,:,1), 0._wp ) * gdepw(:,:,1,Kmm) * e3w(:,:,1,Kmm) 
    263259         DO jk = 2, jpk 
    264             zpelc(:,:,jk)  = zpelc(:,:,jk-1) + MAX( rn2b(:,:,jk), 0._wp ) * gdepw(:,:,jk,Kmm) * e3w(:,:,jk,Kmm) 
     260            zpelc(:,:,jk)  = zpelc(:,:,jk-1) +   & 
     261               &        MAX( rn2b(:,:,jk), 0._wp ) * gdepw(:,:,jk,Kmm) * e3w(:,:,jk,Kmm) 
    265262         END DO 
    266263         !                        !* finite Langmuir Circulation depth 
    … …  
    316313         !                                   ! eddy coefficient (ensure numerical stability) 
    317314         zzd_up = zcof * MAX(  p_avm(ji,jj,jk+1) + p_avm(ji,jj,jk  ) , 2.e-5_wp  )   &  ! upper diagonal 
    318             &          /    (  e3t(ji,jj,jk  ,Kmm) * e3w(ji,jj,jk  ,Kmm)  ) 
     315            &          /    (  e3t(ji,jj,jk  ,Kmm)   & 
     316            &                * e3w(ji,jj,jk  ,Kmm)  ) 
    319317         zzd_lw = zcof * MAX(  p_avm(ji,jj,jk  ) + p_avm(ji,jj,jk-1) , 2.e-5_wp  )   &  ! lower diagonal 
    320             &          /    (  e3t(ji,jj,jk-1,Kmm) * e3w(ji,jj,jk  ,Kmm)  ) 
     318            &          /    (  e3t(ji,jj,jk-1,Kmm)   & 
     319            &                * e3w(ji,jj,jk  ,Kmm)  ) 
    321320         ! 
    322321         zd_up(ji,jj,jk) = zzd_up            ! Matrix (zdiag, zd_up, zd_lw) 
    … …  
    467466            &            gdepw(ji,jj,mbkt(ji,jj)+1,Kmm) - gdepw(ji,jj,jk,Kmm) ) 
    468467            ! wmask prevent zmxlm = 0 if jk = mikt(ji,jj) 
    469             zmxlm(ji,jj,jk) = zemxl * wmask(ji,jj,jk) + MIN( zmxlm(ji,jj,jk) , e3w(ji,jj,jk,Kmm) ) * (1 - wmask(ji,jj,jk)) 
    470             zmxld(ji,jj,jk) = zemxl * wmask(ji,jj,jk) + MIN( zmxlm(ji,jj,jk) , e3w(ji,jj,jk,Kmm) ) * (1 - wmask(ji,jj,jk)) 
     468            zmxlm(ji,jj,jk) = zemxl * wmask(ji,jj,jk)   & 
     469               &            + MIN( zmxlm(ji,jj,jk) , e3w(ji,jj,jk,Kmm) ) * (1 - wmask(ji,jj,jk)) 
     470            zmxld(ji,jj,jk) = zemxl * wmask(ji,jj,jk)   & 
     471               &            + MIN( zmxlm(ji,jj,jk) , e3w(ji,jj,jk,Kmm) ) * (1 - wmask(ji,jj,jk)) 
    471472         END_3D 
    472473         ! 
    … …  
    480481      CASE ( 2 )           ! |dk[xml]| bounded by e3t : 
    481482         DO_3D_00_00( 2, jpkm1 ) 
    482             zmxlm(ji,jj,jk) = MIN( zmxlm(ji,jj,jk-1) + e3t(ji,jj,jk-1,Kmm), zmxlm(ji,jj,jk) ) 
     483            zmxlm(ji,jj,jk) =   & 
     484               &    MIN( zmxlm(ji,jj,jk-1) + e3t(ji,jj,jk-1,Kmm), zmxlm(ji,jj,jk) ) 
    483485         END_3D 
    484486         DO_3DS_00_00( jpkm1, 2, -1 ) 
    … …  
    490492      CASE ( 3 )           ! lup and ldown, |dk[xml]| bounded by e3t : 
    491493         DO_3D_00_00( 2, jpkm1 ) 
    492             zmxld(ji,jj,jk) = MIN( zmxld(ji,jj,jk-1) + e3t(ji,jj,jk-1,Kmm), zmxlm(ji,jj,jk) ) 
     494            zmxld(ji,jj,jk) =    & 
     495               &    MIN( zmxld(ji,jj,jk-1) + e3t(ji,jj,jk-1,Kmm), zmxlm(ji,jj,jk) ) 
    493496         END_3D 
    494497         DO_3DS_00_00( jpkm1, 2, -1 ) 
    495             zmxlm(ji,jj,jk) = MIN( zmxlm(ji,jj,jk+1) + e3t(ji,jj,jk+1,Kmm), zmxlm(ji,jj,jk) ) 
     498            zmxlm(ji,jj,jk) =   & 
     499               &    MIN( zmxlm(ji,jj,jk+1) + e3t(ji,jj,jk+1,Kmm), zmxlm(ji,jj,jk) ) 
    496500         END_3D 
    497501         DO_3D_00_00( 2, jpkm1 ) 
    … …  
    518522      IF( nn_pdl == 1 ) THEN      !* Prandtl number case: update avt 
    519523         DO_3D_00_00( 2, jpkm1 ) 
    520             p_avt(ji,jj,jk)   = MAX( apdlr(ji,jj,jk) * p_avt(ji,jj,jk), avtb_2d(ji,jj) * avtb(jk) ) * tmask(ji,jj,jk) 
     524            p_avt(ji,jj,jk)   = MAX( apdlr(ji,jj,jk) * p_avt(ji,jj,jk), avtb_2d(ji,jj) * avtb(jk) ) * wmask(ji,jj,jk) 
    521525         END_3D 
    522526      ENDIF 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/nemogcm.F90

    r12489 r13151  
    2929   !!            3.3.1! 2011-01  (A. R. Porter, STFC Daresbury) dynamical allocation 
    3030   !!             -   ! 2011-11  (C. Harris) decomposition changes for running with CICE 
    31    !!            3.6  ! 2012-05  (C. Calone, J. Simeon, G. Madec, C. Ethe) Add grid coarsening  
     31   !!            3.6  ! 2012-05  (C. Calone, J. Simeon, G. Madec, C. Ethe) Add grid coarsening 
    3232   !!             -   ! 2014-12  (G. Madec) remove KPP scheme and cross-land advection (cla) 
    3333   !!            4.0  ! 2016-10  (G. Madec, S. Flavoni)  domain configuration / user defined interface 
    … …  
    5353   USE ldftra         ! lateral diffusivity setting    (ldftra_init routine) 
    5454   USE trdini         ! dyn/tra trends initialization     (trd_init routine) 
    55    USE asminc         ! assimilation increments      
     55   USE asminc         ! assimilation increments 
    5656   USE asmbkg         ! writing out state trajectory 
    5757   USE diaptr         ! poleward transports           (dia_ptr_init routine) 
    … …  
    6060   USE diacfl         ! CFL diagnostics               (dia_cfl_init routine) 
    6161   USE diamlr         ! IOM context management for multiple-linear-regression analysis 
    62    USE step           ! NEMO time-stepping                 (stp     routine) 
     62#if defined key_qco 
     63   USE stepMLF        ! NEMO time-stepping               (stp_MLF   routine) 
     64#else 
     65   USE step           ! NEMO time-stepping               (stp       routine) 
     66#endif 
    6367   USE isfstp         ! ice shelf                     (isf_stp_init routine) 
    6468   USE icbini         ! handle bergs, initialisation 
    … …  
    8488#endif 
    8589   ! 
     90   USE in_out_manager ! I/O manager 
    8691   USE lib_mpp        ! distributed memory computing 
    8792   USE mppini         ! shared/distributed memory setting (mpp_init routine) 
    88    USE lbcnfd  , ONLY : isendto, nsndto, nfsloop, nfeloop   ! Setup of north fold exchanges  
     93   USE lbcnfd  , ONLY : isendto, nsndto, nfsloop, nfeloop   ! Setup of north fold exchanges 
    8994   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 
    9095#if defined key_iomput 
    … …  
    143148      Kbb_a = Nbb; Kmm_a = Nnn; Krhs_a = Nrhs   ! agrif_oce module copies of time level indices 
    144149      CALL Agrif_Declare_Var_dom   ! AGRIF: set the meshes for DOM 
    145       CALL Agrif_Declare_Var       !  "      "   "   "      "  DYN/TRA  
     150      CALL Agrif_Declare_Var       !  "      "   "   "      "  DYN/TRA 
    146151# if defined key_top 
    147152      CALL Agrif_Declare_Var_top   !  "      "   "   "      "  TOP 
    … …  
    181186      ! 
    182187      DO WHILE( istp <= nitend .AND. nstop == 0 ) 
     188#if defined key_qco 
     189         CALL stp_MLF 
     190#else 
    183191         CALL stp 
     192#endif 
    184193         istp = istp + 1 
    185194      END DO 
    … …  
    204213               IF ( istp ==         nitend ) elapsed_time = zstptiming - elapsed_time 
    205214            ENDIF 
    206              
    207             CALL stp        ( istp )  
     215 
     216#if defined key_qco 
     217            CALL stp_MLF      ( istp ) 
     218#else 
     219            CALL stp          ( istp ) 
     220#endif 
    208221            istp = istp + 1 
    209222 
    … …  
    215228         ! 
    216229         DO WHILE( istp <= nitend .AND. nstop == 0 ) 
    217             CALL stp_diurnal( istp )   ! time step only the diurnal SST  
     230            CALL stp_diurnal( istp )   ! time step only the diurnal SST 
    218231            istp = istp + 1 
    219232         END DO 
    … …  
    317330      IF( lwm )   CALL ctl_opn(     numond, 'output.namelist.dyn', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) 
    318331      ! open /dev/null file to be able to supress output write easily 
     332      IF( Agrif_Root() ) THEN 
    319333                  CALL ctl_opn(     numnul,           '/dev/null', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) 
    320       ! 
     334#ifdef key_agrif 
     335      ELSE 
     336                  numnul = Agrif_Parent(numnul)    
     337#endif 
     338      ENDIF 
    321339      !                             !--------------------! 
    322340      !                             ! Open listing units !  -> need sn_cfctl from namctl to define lwp 
    … …  
    387405903   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namcfg in reference namelist' ) 
    388406      READ  ( numnam_cfg, namcfg, IOSTAT = ios, ERR = 904 ) 
    389 904   IF( ios >  0 )   CALL ctl_nam ( ios , 'namcfg in configuration namelist' )    
     407904   IF( ios >  0 )   CALL ctl_nam ( ios , 'namcfg in configuration namelist' ) 
    390408      ! 
    391409      IF( ln_read_cfg ) THEN            ! Read sizes in domain configuration file 
    … …  
    423441                           CALL     wad_init        ! Wetting and drying options 
    424442                           CALL     dom_init( Nbb, Nnn, Naa, "OPA") ! Domain 
    425       IF( ln_crs       )   CALL     crs_init(      Nnn )       ! coarsened grid: domain initialization  
     443      IF( ln_crs       )   CALL     crs_init(      Nnn )       ! coarsened grid: domain initialization 
    426444      IF( sn_cfctl%l_prtctl )   & 
    427445         &                 CALL prt_ctl_init        ! Print control 
    428        
     446 
    429447                           CALL diurnal_sst_bulk_init       ! diurnal sst 
    430       IF( ln_diurnal   )   CALL diurnal_sst_coolskin_init   ! cool skin    
    431       !                             
     448      IF( ln_diurnal   )   CALL diurnal_sst_coolskin_init   ! cool skin 
     449      ! 
    432450      IF( ln_diurnal_only ) THEN                    ! diurnal only: a subset of the initialisation routines 
    433451         CALL  istate_init( Nbb, Nnn, Naa )         ! ocean initial state (Dynamics and tracers) 
    … …  
    437455            CALL dia_obs_init( Nnn )                ! Initialize observational data 
    438456            CALL dia_obs( nit000 - 1, Nnn )         ! Observation operator for restart 
    439          ENDIF      
     457         ENDIF 
    440458         IF( lk_asminc )   CALL asm_inc_init( Nbb, Nnn, Nrhs )   ! Assimilation increments 
    441459         ! 
    … …  
    443461      ENDIF 
    444462      ! 
    445        
     463 
    446464                           CALL  istate_init( Nbb, Nnn, Naa )    ! ocean initial state (Dynamics and tracers) 
    447465 
    448       !                                      ! external forcing  
     466      !                                      ! external forcing 
    449467                           CALL    tide_init                     ! tidal harmonics 
    450468                           CALL     sbc_init( Nbb, Nnn, Naa )    ! surface boundary conditions (including sea-ice) 
    … …  
    453471      !                                      ! Ocean physics 
    454472                           CALL zdf_phy_init( Nnn )    ! Vertical physics 
    455                                       
     473 
    456474      !                                         ! Lateral physics 
    457475                           CALL ldf_tra_init      ! Lateral ocean tracer physics 
    … …  
    490508                           CALL sto_par_init    ! Stochastic parametrization 
    491509      IF( ln_sto_eos   )   CALL sto_pts_init    ! RRandom T/S fluctuations 
    492       
     510 
    493511      !                                      ! Diagnostics 
    494512                           CALL     flo_init( Nnn )    ! drifting Floats 
    … …  
    538556         WRITE(numout,*) '                              sn_cfctl%l_prttrc  = ', sn_cfctl%l_prttrc 
    539557         WRITE(numout,*) '                              sn_cfctl%l_oasout  = ', sn_cfctl%l_oasout 
    540          WRITE(numout,*) '                              sn_cfctl%procmin   = ', sn_cfctl%procmin   
    541          WRITE(numout,*) '                              sn_cfctl%procmax   = ', sn_cfctl%procmax   
    542          WRITE(numout,*) '                              sn_cfctl%procincr  = ', sn_cfctl%procincr  
    543          WRITE(numout,*) '                              sn_cfctl%ptimincr  = ', sn_cfctl%ptimincr  
     558         WRITE(numout,*) '                              sn_cfctl%procmin   = ', sn_cfctl%procmin 
     559         WRITE(numout,*) '                              sn_cfctl%procmax   = ', sn_cfctl%procmax 
     560         WRITE(numout,*) '                              sn_cfctl%procincr  = ', sn_cfctl%procincr 
     561         WRITE(numout,*) '                              sn_cfctl%ptimincr  = ', sn_cfctl%ptimincr 
    544562         WRITE(numout,*) '      level of print                  nn_print   = ', nn_print 
    545563         WRITE(numout,*) '      Start i indice for SUM control  nn_ictls   = ', nn_ictls 
    … …  
    665683      !!---------------------------------------------------------------------- 
    666684      ! 
    667       ierr =        oce_alloc    ()    ! ocean  
     685      ierr =        oce_alloc    ()    ! ocean 
    668686      ierr = ierr + dia_wri_alloc() 
    669687      ierr = ierr + dom_oce_alloc()    ! ocean domain 
    … …  
    677695   END SUBROUTINE nemo_alloc 
    678696 
    679     
     697 
    680698   SUBROUTINE nemo_set_cfctl(sn_cfctl, setto, for_all ) 
    681699      !!---------------------------------------------------------------------- 
    … …  
    708726   !!====================================================================== 
    709727END MODULE nemogcm 
    710  

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/oce.F90

    r12489 r13151  
    3232   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   Cu_adv                   !: vertical Courant number (adaptive-implicit) 
    3333 
    34    !! free surface                                      !  before  ! now    ! after  ! 
    35    !! ------------                                      !  fields  ! fields ! fields ! 
     34   !! free surface 
     35   !! ------------ 
    3636   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ssh, uu_b,  vv_b   !: SSH [m] and barotropic velocities [m/s] 
    37  
     37    
    3838   !! Arrays at barotropic time step:                   ! befbefore! before !  now   ! after  ! 
    3939   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ubb_e  ,  ub_e  ,  un_e  , ua_e   !: u-external velocity 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/step.F90

    r12489 r13151  
    3333   !!            4.1  !  2019-08  (A. Coward, D. Storkey) rewrite in preparation for new timestepping scheme 
    3434   !!---------------------------------------------------------------------- 
    35  
     35#if defined key_qco 
     36   !!---------------------------------------------------------------------- 
     37   !!   'key_qco'      EMPTY MODULE      Quasi-Eulerian vertical coordonate 
     38   !!---------------------------------------------------------------------- 
     39#else 
    3640   !!---------------------------------------------------------------------- 
    3741   !!   stp             : OPA system time-stepping 
    … …  
    8791      !! --------------------------------------------------------------------- 
    8892#if defined key_agrif 
     93      IF( nstop > 0 ) return   ! avoid to go further if an error was detected during previous time step  
    8994      kstp = nit000 + Agrif_Nb_Step() 
    9095      Kbb_a = Nbb; Kmm_a = Nnn; Krhs_a = Nrhs   ! agrif_oce module copies of time level indices 
    … …  
    181186                            CALL ssh_nxt       ( kstp, Nbb, Nnn, ssh, Naa )    ! after ssh (includes call to div_hor) 
    182187      IF( .NOT.ln_linssh )  CALL dom_vvl_sf_nxt( kstp, Nbb, Nnn,      Naa )    ! after vertical scale factors  
    183                             CALL wzv           ( kstp, Nbb, Nnn, ww,  Naa )    ! now cross-level velocity  
     188                            CALL wzv           ( kstp, Nbb, Nnn, Naa, ww )    ! now cross-level velocity  
    184189      IF( ln_zad_Aimp )     CALL wAimp         ( kstp,      Nnn           )  ! Adaptive-implicit vertical advection partitioning 
    185190                            CALL eos    ( ts(:,:,:,:,Nnn), rhd, rhop, gdept(:,:,:,Nnn) )  ! now in situ density for hpg computation 
    … …  
    210215                            CALL dyn_zdf    ( kstp, Nbb, Nnn, Nrhs, uu, vv, Naa  )  ! vertical diffusion 
    211216      IF( ln_dynspg_ts ) THEN                                                       ! vertical scale factors and vertical velocity need to be updated 
    212                             CALL wzv        ( kstp, Nbb, Nnn, ww, Naa )             ! now cross-level velocity  
     217                            CALL wzv        ( kstp, Nbb, Nnn, Naa, ww )             ! now cross-level velocity  
    213218         IF( ln_zad_Aimp )  CALL wAimp      ( kstp,      Nnn )                      ! Adaptive-implicit vertical advection partitioning 
    214219      ENDIF 
    … …  
    244249      ! Active tracers                               
    245250      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
     251!!an ne reste que ça, ssh linéaire 
    246252                         ts(:,:,:,:,Nrhs) = 0._wp         ! set tracer trends to zero 
    247253 
    248254      IF(  lk_asminc .AND. ln_asmiau .AND. & 
    249          & ln_trainc )   CALL tra_asm_inc( kstp, Nbb, Nnn, ts, Nrhs )  ! apply tracer assimilation increment 
    250                          CALL tra_sbc    ( kstp,      Nnn, ts, Nrhs )  ! surface boundary condition 
    251       IF( ln_traqsr  )   CALL tra_qsr    ( kstp,      Nnn, ts, Nrhs )  ! penetrative solar radiation qsr 
    252       IF( ln_isf     )   CALL tra_isf    ( kstp,      Nnn, ts, Nrhs )  ! ice shelf heat flux 
    253       IF( ln_trabbc  )   CALL tra_bbc    ( kstp,      Nnn, ts, Nrhs )  ! bottom heat flux 
    254       IF( ln_trabbl  )   CALL tra_bbl    ( kstp, Nbb, Nnn, ts, Nrhs )  ! advective (and/or diffusive) bottom boundary layer scheme 
    255       IF( ln_tradmp  )   CALL tra_dmp    ( kstp, Nbb, Nnn, ts, Nrhs )  ! internal damping trends 
    256       IF( ln_bdy     )   CALL bdy_tra_dmp( kstp, Nbb,      ts, Nrhs )  ! bdy damping trends 
     255!         & ln_trainc )   CALL tra_asm_inc( kstp, Nbb, Nnn, ts, Nrhs )  ! apply tracer assimilation increment 
     256!                         CALL tra_sbc    ( kstp,      Nnn, ts, Nrhs )  ! surface boundary condition 
     257!      IF( ln_traqsr  )   CALL tra_qsr    ( kstp,      Nnn, ts, Nrhs )  ! penetrative solar radiation qsr 
     258!      IF( ln_isf     )   CALL tra_isf    ( kstp,      Nnn, ts, Nrhs )  ! ice shelf heat flux 
     259!      IF( ln_trabbc  )   CALL tra_bbc    ( kstp,      Nnn, ts, Nrhs )  ! bottom heat flux 
     260!      IF( ln_trabbl  )   CALL tra_bbl    ( kstp, Nbb, Nnn, ts, Nrhs )  ! advective (and/or diffusive) bottom boundary layer scheme 
     261!      IF( ln_tradmp  )   CALL tra_dmp    ( kstp, Nbb, Nnn, ts, Nrhs )  ! internal damping trends 
     262!      IF( ln_bdy     )   CALL bdy_tra_dmp( kstp, Nbb,      ts, Nrhs )  ! bdy damping trends 
    257263#if defined key_agrif 
    258264      IF(.NOT. Agrif_Root())  &  
    … …  
    260266#endif 
    261267                         CALL tra_adv    ( kstp, Nbb, Nnn, ts, Nrhs )  ! hor. + vert. advection ==> RHS 
    262       IF( ln_zdfosm  )   CALL tra_osm    ( kstp,      Nnn, ts, Nrhs )  ! OSMOSIS non-local tracer fluxes ==> RHS 
     268 !     IF( ln_zdfosm  )   CALL tra_osm    ( kstp,      Nnn, ts, Nrhs )  ! OSMOSIS non-local tracer fluxes ==> RHS 
    263269      IF( lrst_oce .AND. ln_zdfosm ) & 
    264            &             CALL osm_rst    ( kstp,      Nnn, 'WRITE'  )  ! write OSMOSIS outputs + ww (so must do here) to restarts 
    265                          CALL tra_ldf    ( kstp, Nbb, Nnn, ts, Nrhs )  ! lateral mixing 
    266  
    267                          CALL tra_zdf    ( kstp, Nbb, Nnn, Nrhs, ts, Naa  )  ! vertical mixing and after tracer fields 
    268       IF( ln_zdfnpc  )   CALL tra_npc    ( kstp,      Nnn, Nrhs, ts, Naa  )  ! update after fields by non-penetrative convection 
     270 !          &             CALL osm_rst    ( kstp,      Nnn, 'WRITE'  )  ! write OSMOSIS outputs + ww (so must do here) to restarts 
     271! à voir                         CALL tra_ldf    ( kstp, Nbb, Nnn, ts, Nrhs )  ! lateral mixing 
     272 
     273!                         CALL tra_zdf    ( kstp, Nbb, Nnn, Nrhs, ts, Naa  )  ! vertical mixing and after tracer fields 
     274!      IF( ln_zdfnpc  )   CALL tra_npc    ( kstp,      Nnn, Nrhs, ts, Naa  )  ! update after fields by non-penetrative convection 
    269275 
    270276      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    … …  
    285291!!  
    286292!!jc2: dynnxt must be the latest call. e3t(:,:,:,Nbb) are indeed updated in that routine 
    287                          CALL tra_atf       ( kstp, Nbb, Nnn, Naa, ts )                      ! time filtering of "now" tracer arrays 
    288                          CALL dyn_atf       ( kstp, Nbb, Nnn, Naa, uu, vv, e3t, e3u, e3v  )  ! time filtering of "now" velocities and scale factors 
    289                          CALL ssh_atf       ( kstp, Nbb, Nnn, Naa, ssh )                     ! time filtering of "now" sea surface height 
     293! écrire à la main                         CALL tra_atf       ( kstp, Nbb, Nnn, Naa, ts )                      ! time filtering of "now" tracer arrays 
     294!                         CALL dyn_atf       ( kstp, Nbb, Nnn, Naa, uu, vv, e3t, e3u, e3v  )  ! time filtering of "now" velocities and scale factors 
     295!                         CALL ssh_atf       ( kstp, Nbb, Nnn, Naa, ssh )                     ! time filtering of "now" sea surface height 
    290296      ! 
    291297      ! Swap time levels 
    … …  
    309315#if defined key_agrif 
    310316      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    311       ! AGRIF 
     317      ! AGRIF recursive integration 
    312318      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<       
    313319                         Kbb_a = Nbb; Kmm_a = Nnn; Krhs_a = Nrhs      ! agrif_oce module copies of time level indices 
    314320                         CALL Agrif_Integrate_ChildGrids( stp )       ! allows to finish all the Child Grids before updating 
    315  
    316                          IF( Agrif_NbStepint() == 0 ) THEN 
    317                             CALL Agrif_update_all( )                  ! Update all components 
    318                          ENDIF 
     321#endif 
     322      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
     323      ! Control 
     324      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
     325                         CALL stp_ctl      ( kstp, Nbb, Nnn, indic ) 
     326#if defined key_agrif 
     327      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
     328      ! AGRIF update 
     329      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<       
     330      IF( Agrif_NbStepint() == 0 .AND. nstop == 0 ) THEN 
     331                         CALL Agrif_update_all( )                  ! Update all components 
     332      ENDIF 
    319333#endif 
    320334      IF( ln_diaobs  )   CALL dia_obs      ( kstp, Nnn )      ! obs-minus-model (assimilation) diagnostics (call after dynamics update) 
    321335 
    322336      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    323       ! Control 
    324       !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    325                          CALL stp_ctl      ( kstp, Nbb, Nnn, indic ) 
    326                           
     337      ! File manipulation at the end of the first time step 
     338      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<                          
    327339      IF( kstp == nit000 ) THEN                          ! 1st time step only 
    328340                                        CALL iom_close( numror )   ! close input  ocean restart file 
    … …  
    338350      ! 
    339351#if defined key_iomput 
     352      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
     353      ! Finalize contextes if end of simulation or error detected 
     354      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<                          
    340355      IF( kstp == nitend .OR. indic < 0 ) THEN  
    341356                      CALL iom_context_finalize(      cxios_context          ) ! needed for XIOS+AGRIF 
    342                       IF(lrxios) CALL iom_context_finalize(      crxios_context          ) 
     357         IF( lrxios ) CALL iom_context_finalize(      crxios_context         ) 
    343358         IF( ln_crs ) CALL iom_context_finalize( trim(cxios_context)//"_crs" ) !  
    344359      ENDIF 
    … …  
    355370   END SUBROUTINE stp 
    356371   ! 
     372#endif 
    357373   !!====================================================================== 
    358374END MODULE step 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OFF/dtadyn.F90

    r12489 r13151  
    2323   USE c1d             ! 1D configuration: lk_c1d 
    2424   USE dom_oce         ! ocean domain: variables 
     25#if ! defined key_qco  
    2526   USE domvvl          ! variable volume 
     27#else 
     28   USE domqco 
     29#endif 
    2630   USE zdf_oce         ! ocean vertical physics: variables 
    2731   USE sbc_oce         ! surface module: variables 
    … …  
    5256   PUBLIC   dta_dyn_sed        ! called by nemo_gcm 
    5357   PUBLIC   dta_dyn_atf        ! called by nemo_gcm 
     58#if ! defined key_qco 
    5459   PUBLIC   dta_dyn_sf_interp  ! called by nemo_gcm 
     60#endif 
    5561 
    5662   CHARACTER(len=100) ::   cn_dir          !: Root directory for location of ssr files 
    … …  
    128134      IF( l_ldfslp .AND. .NOT.lk_c1d )   CALL  dta_dyn_slp( kt, Kbb, Kmm )    ! Computation of slopes 
    129135      ! 
    130       ts(:,:,:,jp_tem,Kmm) = sf_dyn(jf_tem)%fnow(:,:,:) * tmask(:,:,:)    ! temperature 
    131       ts(:,:,:,jp_sal,Kmm) = sf_dyn(jf_sal)%fnow(:,:,:) * tmask(:,:,:)    ! salinity 
    132       wndm(:,:)         = sf_dyn(jf_wnd)%fnow(:,:,1) * tmask(:,:,1)    ! wind speed - needed for gas exchange 
    133       fmmflx(:,:)       = sf_dyn(jf_fmf)%fnow(:,:,1) * tmask(:,:,1)    ! downward salt flux (v3.5+) 
    134       fr_i(:,:)         = sf_dyn(jf_ice)%fnow(:,:,1) * tmask(:,:,1)    ! Sea-ice fraction 
    135       qsr (:,:)         = sf_dyn(jf_qsr)%fnow(:,:,1) * tmask(:,:,1)    ! solar radiation 
    136       emp (:,:)         = sf_dyn(jf_emp)%fnow(:,:,1) * tmask(:,:,1)    ! E-P 
     136      ts    (:,:,:,jp_tem,Kmm) = sf_dyn(jf_tem)%fnow(:,:,:) * tmask(:,:,:)    ! temperature 
     137      ts    (:,:,:,jp_sal,Kmm) = sf_dyn(jf_sal)%fnow(:,:,:) * tmask(:,:,:)    ! salinity 
     138      wndm  (:,:)              = sf_dyn(jf_wnd)%fnow(:,:,1) * tmask(:,:,1)    ! wind speed - needed for gas exchange 
     139      fmmflx(:,:)              = sf_dyn(jf_fmf)%fnow(:,:,1) * tmask(:,:,1)    ! downward salt flux (v3.5+) 
     140      fr_i  (:,:)              = sf_dyn(jf_ice)%fnow(:,:,1) * tmask(:,:,1)    ! Sea-ice fraction 
     141      qsr   (:,:)              = sf_dyn(jf_qsr)%fnow(:,:,1) * tmask(:,:,1)    ! solar radiation 
     142      emp   (:,:)              = sf_dyn(jf_emp)%fnow(:,:,1) * tmask(:,:,1)    ! E-P 
    137143      IF( ln_dynrnf ) THEN  
    138          rnf (:,:)      = sf_dyn(jf_rnf)%fnow(:,:,1) * tmask(:,:,1)    ! E-P 
    139          IF( ln_dynrnf_depth .AND. .NOT. ln_linssh )    CALL  dta_dyn_hrnf(Kmm) 
    140       ENDIF 
    141       ! 
    142       uu(:,:,:,Kmm)        = sf_dyn(jf_uwd)%fnow(:,:,:) * umask(:,:,:)    ! effective u-transport 
    143       vv(:,:,:,Kmm)        = sf_dyn(jf_vwd)%fnow(:,:,:) * vmask(:,:,:)    ! effective v-transport 
    144       ww(:,:,:)        = sf_dyn(jf_wwd)%fnow(:,:,:) * tmask(:,:,:)    ! effective v-transport 
     144         rnf(:,:)              = sf_dyn(jf_rnf)%fnow(:,:,1) * tmask(:,:,1)    ! E-P 
     145         IF( ln_dynrnf_depth .AND. .NOT.ln_linssh )   CALL dta_dyn_hrnf( Kmm ) 
     146      ENDIF 
     147      ! 
     148      uu(:,:,:,Kmm)            = sf_dyn(jf_uwd)%fnow(:,:,:) * umask(:,:,:)    ! effective u-transport 
     149      vv(:,:,:,Kmm)            = sf_dyn(jf_vwd)%fnow(:,:,:) * vmask(:,:,:)    ! effective v-transport 
     150      ww(:,:,:)                = sf_dyn(jf_wwd)%fnow(:,:,:) * tmask(:,:,:)    ! effective v-transport 
    145151      ! 
    146152      IF( .NOT.ln_linssh ) THEN 
    147153         ALLOCATE( zemp(jpi,jpj) , zhdivtr(jpi,jpj,jpk) ) 
    148          zhdivtr(:,:,:) = sf_dyn(jf_div)%fnow(:,:,:) * tmask(:,:,:)    ! effective u-transport 
     154         zhdivtr(:,:,:) = sf_dyn(jf_div )%fnow(:,:,:) * tmask(:,:,:)    ! effective u-transport 
    149155         emp_b  (:,:)   = sf_dyn(jf_empb)%fnow(:,:,1) * tmask(:,:,1)    ! E-P 
    150156         zemp   (:,:)   = ( 0.5_wp * ( emp(:,:) + emp_b(:,:) ) + rnf(:,:) + fwbcorr ) * tmask(:,:,1) 
    151          CALL dta_dyn_ssh( kt, zhdivtr, ssh(:,:,Kbb), zemp, ssh(:,:,Kaa), e3t(:,:,:,Kaa) )  !=  ssh, vertical scale factor & vertical transport 
     157#if defined key_qco 
     158         CALL dta_dyn_ssh( kt, zhdivtr, ssh(:,:,Kbb), zemp, ssh(:,:,Kaa) ) 
     159         CALL dom_qco_r3c( ssh(:,:,Kaa), r3t(:,:,Kaa), r3u(:,:,Kaa), r3v(:,:,Kaa) ) 
     160#else 
     161         CALL dta_dyn_ssh( kt, zhdivtr, ssh(:,:,Kbb), zemp, ssh(:,:,Kaa), e3t(:,:,:,Kaa) )  !=  ssh, vertical scale factor 
     162#endif 
    152163         DEALLOCATE( zemp , zhdivtr ) 
    153164         !                                           Write in the tracer restart file 
    … …  
    329340        ENDIF 
    330341        ! 
     342#if defined key_qco 
     343        CALL dom_qco_r3c( ssh(:,:,Kbb), r3t(:,:,Kbb), r3u(:,:,Kbb), r3v(:,:,Kbb) ) 
     344        CALL dom_qco_r3c( ssh(:,:,Kmm), r3t(:,:,Kmm), r3u(:,:,Kmm), r3v(:,:,Kmm) ) 
     345#else 
    331346        DO jk = 1, jpkm1 
    332            e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * ( 1._wp + ssh(:,:,Kmm) * tmask(:,:,1) / ( ht_0(:,:) + 1.0 - tmask(:,:,1) ) ) 
    333         ENDDO 
     347           e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * ( 1._wp + ssh(:,:,Kmm) * r1_ht_0(:,:) * tmask(:,:,jk) ) 
     348        END DO 
    334349        e3t(:,:,jpk,Kaa) = e3t_0(:,:,jpk) 
    335350 
    … …  
    342357        ! ------------------------------------ 
    343358        CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3w(:,:,:,Kmm), 'W' ) 
    344    
     359!!gm this should be computed from ssh(Kbb)   
    345360        e3t(:,:,:,Kbb)  = e3t(:,:,:,Kmm) 
    346361        e3u(:,:,:,Kbb)  = e3u(:,:,:,Kmm) 
    … …  
    366381        gdepw(:,:,:,Kbb) = gdepw(:,:,:,Kmm) 
    367382        ! 
    368       ENDIF 
     383     ENDIF 
     384#endif 
    369385      ! 
    370386      IF( ln_dynrnf .AND. ln_dynrnf_depth ) THEN       ! read depht over which runoffs are distributed 
    … …  
    389405            ENDIF 
    390406         END_2D 
     407!!st pourquoi on n'utilise pas le gde3w ici plutôt que de faire une boucle ?  
    391408         DO_2D_11_11 
    392409            h_rnf(ji,jj) = 0._wp 
    … …  
    413430   END SUBROUTINE dta_dyn_init 
    414431 
     432    
    415433   SUBROUTINE dta_dyn_sed( kt, Kmm ) 
    416434      !!---------------------------------------------------------------------- 
    … …  
    529547   END SUBROUTINE dta_dyn_sed_init 
    530548 
     549    
    531550   SUBROUTINE dta_dyn_atf( kt, Kbb, Kmm, Kaa ) 
    532551     !!--------------------------------------------------------------------- 
    … …  
    551570      ! 
    552571   END SUBROUTINE dta_dyn_atf 
     572 
    553573    
     574#if ! defined key_qco     
    554575   SUBROUTINE dta_dyn_sf_interp( kt, Kmm ) 
    555576      !!--------------------------------------------------------------------- 
    … …  
    588609      ! 
    589610   END SUBROUTINE dta_dyn_sf_interp 
    590  
     611#endif 
     612 
     613    
    591614   SUBROUTINE dta_dyn_ssh( kt, phdivtr, psshb,  pemp, pssha, pe3ta ) 
    592615      !!---------------------------------------------------------------------- 
    … …  
    606629      !!          The boundary conditions are w=0 at the bottom (no flux) 
    607630      !! 
    608       !! ** action  :   ssh(:,:,Kaa) / e3t(:,:,:,Kaa) / ww 
     631      !! ** action  :   ssh(:,:,Kaa) / e3t(:,:,k,Kaa) / ww 
    609632      !! 
    610633      !! Reference  : Leclair, M., and G. Madec, 2009, Ocean Modelling. 
    … …  
    630653      !                                                ! Sea surface  elevation time-stepping 
    631654      pssha(:,:) = ( psshb(:,:) - z2dt * ( r1_rho0 * pemp(:,:)  + zhdiv(:,:) ) ) * ssmask(:,:) 
    632       !                                                 !  
    633       !                                                 ! After acale factors at t-points ( z_star coordinate ) 
    634       DO jk = 1, jpkm1 
    635         pe3ta(:,:,jk) = e3t_0(:,:,jk) * ( 1._wp + pssha(:,:) * tmask(:,:,1) / ( ht_0(:,:) + 1.0 - tmask(:,:,1) ) ) 
    636       END DO 
     655      ! 
     656      IF( PRESENT( pe3ta ) ) THEN                      ! After acale factors at t-points ( z_star coordinate ) 
     657         DO jk = 1, jpkm1 
     658            pe3ta(:,:,jk) = e3t_0(:,:,jk) * ( 1._wp + pssha(:,:) * r1_ht_0(:,:) * tmask(:,:,jk) ) 
     659         END DO 
     660      ENDIF 
    637661      ! 
    638662   END SUBROUTINE dta_dyn_ssh 
    … …  
    657681      !!---------------------------------------------------------------------- 
    658682      ! 
     683!!st code dupliqué même remarque que plus haut pourquoi ne pas utiliser gdepw ? 
    659684      DO_2D_11_11 
    660685         h_rnf(ji,jj) = 0._wp 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OFF/nemogcm.F90

    r12377 r13151  
    2828   USE usrdef_nam     ! user defined configuration 
    2929   USE eosbn2         ! equation of state            (eos bn2 routine) 
     30#if defined key_qco 
     31   USE domqco         ! tools for scale factor         (dom_qco_r3c  routine) 
     32#endif 
    3033   !              ! ocean physics 
    3134   USE ldftra         ! lateral diffusivity setting    (ldf_tra_init routine) 
    … …  
    117120                                CALL dta_dyn    ( istp, Nbb, Nnn, Naa )       ! Interpolation of the dynamical fields 
    118121#endif 
     122#if ! defined key_sed_off 
     123         IF( .NOT.ln_linssh ) THEN 
     124                                CALL dta_dyn_atf( istp, Nbb, Nnn, Naa )       ! time filter of sea  surface height and vertical scale factors 
     125# if defined key_qco 
     126                                CALL dom_qco_r3c( ssh(:,:,Kmm), r3t_f, r3u_f, r3v_f ) 
     127# endif 
     128         ENDIF 
    119129                                CALL trc_stp    ( istp, Nbb, Nnn, Nrhs, Naa ) ! time-stepping 
    120 #if ! defined key_sed_off 
    121          IF( .NOT.ln_linssh )   CALL dta_dyn_atf( istp, Nbb, Nnn, Naa )       ! time filter of sea  surface height and vertical scale factors 
     130# if defined key_qco 
     131                                !r3t(:,:,Kmm) = r3t_f(:,:)                     ! update ssh to h0 ratio 
     132                                !r3u(:,:,Kmm) = r3u_f(:,:) 
     133                                !r3v(:,:,Kmm) = r3v_f(:,:) 
     134# endif 
    122135#endif 
    123136         ! Swap time levels 
    … …  
    127140         Naa = Nrhs 
    128141         ! 
    129 #if ! defined key_sed_off 
     142#if ! defined key_qco 
     143# if ! defined key_sed_off 
    130144         IF( .NOT.ln_linssh )   CALL dta_dyn_sf_interp( istp, Nnn )  ! calculate now grid parameters 
    131 #endif 
     145# endif 
     146#endif          
    132147                                CALL stp_ctl    ( istp, indic )  ! Time loop: control and print 
    133148         istp = istp + 1 
    … …  
    209224      IF( lwm )   CALL ctl_opn(     numond, 'output.namelist.dyn', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) 
    210225      ! open /dev/null file to be able to supress output write easily 
     226      IF( Agrif_Root() ) THEN 
    211227                  CALL ctl_opn(     numnul,           '/dev/null', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) 
     228#ifdef key_agrif 
     229      ELSE 
     230                  numnul = Agrif_Parent(numnul)    
     231#endif 
     232      ENDIF 
    212233      ! 
    213234      !                             !--------------------! 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/SAO/nemogcm.F90

    r12377 r13151  
    2929   USE sao_intp 
    3030   ! 
     31   USE in_out_manager ! I/O manager 
    3132   USE lib_mpp        ! distributed memory computing 
    3233   USE mppini         ! shared/distributed memory setting (mpp_init routine) 
    … …  
    139140      IF( lwm )   CALL ctl_opn(     numond, 'output.namelist.dyn', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) 
    140141      ! open /dev/null file to be able to supress output write easily 
     142      IF( Agrif_Root() ) THEN 
    141143                  CALL ctl_opn(     numnul,           '/dev/null', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) 
     144#ifdef key_agrif 
     145      ELSE 
     146                  numnul = Agrif_Parent(numnul)    
     147#endif 
     148      ENDIF 
    142149      ! 
    143150      !                             !--------------------! 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/SAS/diawri.F90

    r12489 r13151  
    9999      ! Output the initial state and forcings 
    100100      IF( ninist == 1 ) THEN 
    101          CALL dia_wri_state( 'output.init', Kmm ) 
     101         CALL dia_wri_state( Kmm, 'output.init' ) 
    102102         ninist = 0 
    103103      ENDIF 
    … …  
    126126   END FUNCTION dia_wri_alloc_abl 
    127127   
    128    SUBROUTINE dia_wri( kt ) 
     128   SUBROUTINE dia_wri( kt, Kmm ) 
    129129      !!--------------------------------------------------------------------- 
    130130      !!                  ***  ROUTINE dia_wri  *** 
    … …  
    140140      !! 
    141141      INTEGER, INTENT( in ) ::   kt      ! ocean time-step index 
     142      INTEGER, INTENT( in ) ::   Kmm  ! ocean time level index 
    142143      !! 
    143144      LOGICAL ::   ll_print = .FALSE.                        ! =T print and flush numout 
    … …  
    154155      ! Output the initial state and forcings 
    155156      IF( ninist == 1 ) THEN                        
    156          CALL dia_wri_state( 'output.init' ) 
     157         CALL dia_wri_state( Kmm, 'output.init' ) 
    157158         ninist = 0 
    158159      ENDIF 
    … …  
    257258         IF( ln_abl ) THEN  
    258259         ! Define the ABL grid FILE ( nid_A ) 
    259             CALL dia_nam( clhstnam, nwrite, 'grid_ABL' ) 
     260            CALL dia_nam( clhstnam, nn_write, 'grid_ABL' ) 
    260261            IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam    ! filename 
    261262            CALL histbeg( clhstnam, jpi, glamt, jpj, gphit,           &  ! Horizontal grid: glamt and gphit 
    … …  
    414415#endif 
    415416 
    416    SUBROUTINE dia_wri_state( cdfile_name, Kmm ) 
     417   SUBROUTINE dia_wri_state( Kmm, cdfile_name ) 
    417418      !!--------------------------------------------------------------------- 
    418419      !!                 ***  ROUTINE dia_wri_state  *** 
    … …  
    427428      !!      File 'output.abort.nc' is created in case of abnormal job end 
    428429      !!---------------------------------------------------------------------- 
     430      INTEGER           , INTENT( in ) ::   Kmm              ! ocean time levelindex 
    429431      CHARACTER (len=* ), INTENT( in ) ::   cdfile_name      ! name of the file created 
    430       INTEGER           , INTENT( in ) ::   Kmm              ! ocean time levelindex 
    431432      !! 
    432433      INTEGER :: inum 
    … …  
    437438      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~   and forcing fields file created ' 
    438439      IF(lwp) WRITE(numout,*) '                and named :', cdfile_name, '...nc' 
    439  
    440 #if defined key_si3 
    441      CALL iom_open( TRIM(cdfile_name), inum, ldwrt = .TRUE., kdlev = jpl ) 
    442 #else 
    443      CALL iom_open( TRIM(cdfile_name), inum, ldwrt = .TRUE. ) 
    444 #endif 
    445  
     440      ! 
     441      CALL iom_open( TRIM(cdfile_name), inum, ldwrt = .TRUE. ) 
     442      ! 
    446443      CALL iom_rstput( 0, 0, inum, 'votemper', ts (:,:,:,jp_tem,Kmm) )    ! now temperature 
    447444      CALL iom_rstput( 0, 0, inum, 'vosaline', ts (:,:,:,jp_sal,Kmm) )    ! now salinity 
    … …  
    456453      CALL iom_rstput( 0, 0, inum, 'sozotaux', utau                  )    ! i-wind stress 
    457454      CALL iom_rstput( 0, 0, inum, 'sometauy', vtau                  )    ! j-wind stress 
    458   
     455      ! 
     456      CALL iom_close( inum ) 
     457      ! 
    459458#if defined key_si3 
    460459      IF( nn_ice == 2 ) THEN   ! condition needed in case agrif + ice-model but no-ice in child grid 
     460         CALL iom_open( TRIM(cdfile_name)//'_ice', inum, ldwrt = .TRUE., kdlev = jpl, cdcomp = 'ICE' ) 
    461461         CALL ice_wri_state( inum ) 
    462       ENDIF 
    463 #endif 
    464       ! 
    465       CALL iom_close( inum ) 
    466       ! 
     462         CALL iom_close( inum ) 
     463      ENDIF 
     464#endif 
     465 
    467466   END SUBROUTINE dia_wri_state 
    468467 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/SAS/nemogcm.F90

    r12489 r13151  
    3535   USE step_diu       ! diurnal bulk SST timestepping (called from here if run offline) 
    3636   ! 
     37   USE in_out_manager ! I/O manager 
    3738   USE lib_mpp        ! distributed memory computing 
    3839   USE mppini         ! shared/distributed memory setting (mpp_init routine) 
    … …  
    256257      ENDIF 
    257258      ! open /dev/null file to be able to supress output write easily 
     259      IF( Agrif_Root() ) THEN 
    258260                     CALL ctl_opn(     numnul,               '/dev/null', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) 
     261#ifdef key_agrif 
     262      ELSE 
     263                  numnul = Agrif_Parent(numnul)    
     264#endif 
     265      ENDIF 
    259266      ! 
    260267      !                             !--------------------! 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/SAS/sbcssm.F90

    r12377 r13151  
    2626   USE lib_mpp        ! distributed memory computing library 
    2727   USE prtctl         ! print control 
    28    USE fldread        ! read input fields  
     28   USE fldread        ! read input fields 
    2929   USE timing         ! Timing 
    3030 
    … …  
    3838   LOGICAL            ::   ln_3d_uve     ! specify whether input velocity data is 3D 
    3939   LOGICAL            ::   ln_read_frq   ! specify whether we must read frq or not 
    40     
     40 
    4141   LOGICAL            ::   l_sasread     ! Ice intilisation: =T read a file ; =F anaytical initilaistion 
    4242   LOGICAL            ::   l_initdone = .false. 
    … …  
    6969      !!               for an off-line simulation using surface processes only 
    7070      !! 
    71       !! ** Method : calculates the position of data  
     71      !! ** Method : calculates the position of data 
    7272      !!             - interpolates data if needed 
    7373      !!---------------------------------------------------------------------- 
    7474      INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
    7575      INTEGER, INTENT(in) ::   Kbb, Kmm   ! ocean time level indices 
    76                           ! (not needed for SAS but needed to keep a consistent interface in sbcmod.F90) 
     76      ! (not needed for SAS but needed to keep a consistent interface in sbcmod.F90) 
    7777      ! 
    7878      INTEGER  ::   ji, jj     ! dummy loop indices 
    … …  
    8282      ! 
    8383      IF( ln_timing )   CALL timing_start( 'sbc_ssm') 
    84       
     84 
    8585      IF ( l_sasread ) THEN 
    8686         IF( nfld_3d > 0 ) CALL fld_read( kt, 1, sf_ssm_3d )      !==   read data at kt time step   ==! 
    8787         IF( nfld_2d > 0 ) CALL fld_read( kt, 1, sf_ssm_2d )      !==   read data at kt time step   ==! 
    88          !  
     88         ! 
    8989         IF( ln_3d_uve ) THEN 
    9090            IF( .NOT. ln_linssh ) THEN 
    91                e3t_m(:,:) = sf_ssm_3d(jf_e3t)%fnow(:,:,1) * tmask(:,:,1) ! vertical scale factor  
     91               e3t_m(:,:) = sf_ssm_3d(jf_e3t)%fnow(:,:,1) * tmask(:,:,1) ! vertical scale factor 
    9292            ELSE 
    9393               e3t_m(:,:) = e3t_0(:,:,1)                                 ! vertical scale factor 
    9494            ENDIF 
    9595            ssu_m(:,:) = sf_ssm_3d(jf_usp)%fnow(:,:,1) * umask(:,:,1)    ! u-velocity 
    96             ssv_m(:,:) = sf_ssm_3d(jf_vsp)%fnow(:,:,1) * vmask(:,:,1)    ! v-velocity  
     96            ssv_m(:,:) = sf_ssm_3d(jf_vsp)%fnow(:,:,1) * vmask(:,:,1)    ! v-velocity 
    9797         ELSE 
    9898            IF( .NOT. ln_linssh ) THEN 
    99                e3t_m(:,:) = sf_ssm_2d(jf_e3t)%fnow(:,:,1) * tmask(:,:,1) ! vertical scale factor  
     99               e3t_m(:,:) = sf_ssm_2d(jf_e3t)%fnow(:,:,1) * tmask(:,:,1) ! vertical scale factor 
    100100            ELSE 
    101101               e3t_m(:,:) = e3t_0(:,:,1)                                 ! vertical scale factor 
    102102            ENDIF 
    103103            ssu_m(:,:) = sf_ssm_2d(jf_usp)%fnow(:,:,1) * umask(:,:,1)    ! u-velocity 
    104             ssv_m(:,:) = sf_ssm_2d(jf_vsp)%fnow(:,:,1) * vmask(:,:,1)    ! v-velocity  
     104            ssv_m(:,:) = sf_ssm_2d(jf_vsp)%fnow(:,:,1) * vmask(:,:,1)    ! v-velocity 
    105105         ENDIF 
    106106         ! 
    … …  
    123123         ssh  (:,:,Kmm) = 0._wp                              !              - - 
    124124      ENDIF 
    125        
     125 
    126126      IF ( nn_ice == 1 ) THEN 
    127127         ts(:,:,1,jp_tem,Kmm) = sst_m(:,:) 
    … …  
    132132      uu (:,:,1,Kbb) = ssu_m(:,:) 
    133133      vv (:,:,1,Kbb) = ssv_m(:,:) 
    134   
     134 
    135135      IF(sn_cfctl%l_prtctl) THEN            ! print control 
    136136         CALL prt_ctl(tab2d_1=sst_m, clinfo1=' sst_m   - : ', mask1=tmask   ) 
    … …  
    162162      !!                  ***  ROUTINE sbc_ssm_init  *** 
    163163      !! 
    164       !! ** Purpose :   Initialisation of sea surface mean data      
    165       !!---------------------------------------------------------------------- 
    166       INTEGER, INTENT(in) ::   Kbb, Kmm   ! ocean time level indices  
    167                           ! (not needed for SAS but needed to keep a consistent interface in sbcmod.F90) 
     164      !! ** Purpose :   Initialisation of sea surface mean data 
     165      !!---------------------------------------------------------------------- 
     166      INTEGER, INTENT(in) ::   Kbb, Kmm   ! ocean time level indices 
     167      ! (not needed for SAS but needed to keep a consistent interface in sbcmod.F90) 
    168168      INTEGER  :: ierr, ierr0, ierr1, ierr2, ierr3   ! return error code 
    169169      INTEGER  :: ifpr                               ! dummy loop indice 
    … …  
    195195902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_sas in configuration namelist' ) 
    196196      IF(lwm) WRITE ( numond, namsbc_sas ) 
    197       !            
     197      ! 
    198198      IF(lwp) THEN                              ! Control print 
    199199         WRITE(numout,*) '   Namelist namsbc_sas' 
    200          WRITE(numout,*) '      Initialisation using an input file                                 l_sasread   = ', l_sasread  
     200         WRITE(numout,*) '      Initialisation using an input file                                 l_sasread   = ', l_sasread 
    201201         WRITE(numout,*) '      Are we supplying a 3D u,v and e3 field                             ln_3d_uve   = ', ln_3d_uve 
    202202         WRITE(numout,*) '      Are we reading frq (fraction of qsr absorbed in the 1st T level)   ln_read_frq = ', ln_read_frq 
    … …  
    226226         ln_closea = .false. 
    227227      ENDIF 
    228        
    229       !                   
     228 
     229      ! 
    230230      IF( l_sasread ) THEN                       ! store namelist information in an array 
    231          !  
     231         ! 
    232232         !! following code is a bit messy, but distinguishes between when u,v are 3d arrays and 
    233233         !! when we have other 3d arrays that we need to read in 
    … …  
    275275         ENDIF 
    276276         ! 
    277          ierr1 = 0    ! default definition if slf_?d(ifpr)%ln_tint = .false.  
     277         ierr1 = 0    ! default definition if slf_?d(ifpr)%ln_tint = .false. 
    278278         IF( nfld_3d > 0 ) THEN 
    279279            ALLOCATE( sf_ssm_3d(nfld_3d), STAT=ierr )         ! set sf structure 
    … …  
    282282            ENDIF 
    283283            DO ifpr = 1, nfld_3d 
    284                                             ALLOCATE( sf_ssm_3d(ifpr)%fnow(jpi,jpj,jpk)    , STAT=ierr0 ) 
     284               ALLOCATE( sf_ssm_3d(ifpr)%fnow(jpi,jpj,jpk)    , STAT=ierr0 ) 
    285285               IF( slf_3d(ifpr)%ln_tint )   ALLOCATE( sf_ssm_3d(ifpr)%fdta(jpi,jpj,jpk,2)  , STAT=ierr1 ) 
    286286               IF( ierr0 + ierr1 > 0 ) THEN 
    … …  
    298298            ENDIF 
    299299            DO ifpr = 1, nfld_2d 
    300                                             ALLOCATE( sf_ssm_2d(ifpr)%fnow(jpi,jpj,1)    , STAT=ierr0 ) 
     300               ALLOCATE( sf_ssm_2d(ifpr)%fnow(jpi,jpj,1)    , STAT=ierr0 ) 
    301301               IF( slf_2d(ifpr)%ln_tint )   ALLOCATE( sf_ssm_2d(ifpr)%fdta(jpi,jpj,1,2)  , STAT=ierr1 ) 
    302302               IF( ierr0 + ierr1 > 0 ) THEN 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/SAS/step.F90

    r12377 r13151  
    7878 
    7979#if defined key_agrif 
     80      IF( nstop > 0 ) return   ! avoid to go further if an error was detected during previous time step  
    8081      kstp = nit000 + Agrif_Nb_Step() 
    8182      Kbb_a = Nbb; Kmm_a = Nnn; Krhs_a = Nrhs   ! agrif_oce module copies of time level indices 
    … …  
    109110#if defined key_agrif 
    110111      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    111       ! AGRIF 
     112      ! AGRIF recursive integration 
    112113      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<       
    113114                             CALL Agrif_Integrate_ChildGrids( stp )   
    114  
    115       IF( Agrif_NbStepint() == 0 ) THEN               ! AGRIF Update from zoom N to zoom 1 then to Parent  
    116 #if defined key_si3 
    117                              CALL Agrif_Update_ice( )   ! update sea-ice 
    118 #endif 
    119       ENDIF 
    120115#endif 
    121116                              
    … …  
    126121      IF( indic < 0  )  THEN 
    127122                             CALL ctl_stop( 'step: indic < 0' ) 
    128                              CALL dia_wri_state( 'output.abort', Nnn ) 
     123                             CALL dia_wri_state( Nnn, 'output.abort' ) 
    129124      ENDIF 
    130       IF( kstp == nit000   ) CALL iom_close( numror )           ! close input  ocean restart file 
     125#if defined key_agrif 
     126      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
     127      ! AGRIF update 
     128      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<       
     129      IF( Agrif_NbStepint() == 0 .AND. nstop == 0 ) THEN                       ! AGRIF Update from zoom N to zoom 1 then to Parent  
     130#if defined key_si3 
     131                             CALL Agrif_Update_ice( )   ! update sea-ice 
     132#endif 
     133      ENDIF 
     134#endif 
     135      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
     136      ! File manipulation at the end of the first time step 
     137      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<                          
     138      IF( kstp == nit000   ) CALL iom_close( numror )                          ! close input  ocean restart file 
    131139       
    132140      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/SWE/asminc.F90

    r12614 r13151  
    9595   !! * Substitutions 
    9696#  include "do_loop_substitute.h90" 
     97!!st10 
     98#  include "domzgr_substitute.h90" 
     99!!st10 
    97100   !!---------------------------------------------------------------------- 
    98101   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    417420                     &            - e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm) * u_bkginc(ji-1,jj,jk)    & 
    418421                     &            + e1v(ji,jj  ) * e3v(ji,jj  ,jk,Kmm) * v_bkginc(ji,jj  ,jk)    & 
    419                      &            - e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) * v_bkginc(ji,jj-1,jk)  ) / e3t(ji,jj,jk,Kmm) 
     422                     &            - e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) * v_bkginc(ji,jj-1,jk)  ) & 
     423                     &            / e3t(ji,jj,jk,Kmm) 
    420424               END_2D 
    421425               CALL lbc_lnk( 'asminc', zhdiv, 'T', 1. )   ! lateral boundary cond. (no sign change) 
    … …  
    758762            ! 
    759763            ssh(:,:,Kbb) = ssh(:,:,Kmm)                        ! Update before fields 
     764!!st11 
     765#if ! defined key_qco 
    760766            e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 
    761 !!gm why not e3u(:,:,:,Kbb), e3v(:,:,:,Kbb), gdept(:,:,:,Kbb) ???? 
     767#endif 
     768!!st11 
     769!!gm why not e3u(:,:,:,Kbb), e3v(:,:,:,Kbb), gdept(:,:,jk,Kbb) ???? 
    762770            ! 
    763771            DEALLOCATE( ssh_bkg    ) 
    … …  
    970978!           ! set to bottom of a level  
    971979!                 DO jk = jpk-1, 2, -1 
    972 !                   IF ((mld > gdepw(ji,jj,jk)) .and. (mld < gdepw(ji,jj,jk+1))) THEN  
    973 !                     mld=gdepw(ji,jj,jk+1) 
     980!                   IF ((mld > gdepw(ji,jj,jk,Kmm)) .and. (mld < gdepw(ji,jj,jk+1,Kmm))) THEN  
     981!                     mld=gdepw(ji,jj,jk+1,Kmm) 
    974982!                     jkmax=jk 
    975983!                   ENDIF 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/SWE/diawri.F90

    r12667 r13151  
    8585   !! * Substitutions 
    8686#  include "do_loop_substitute.h90" 
     87!!st12 
     88#  include "domzgr_substitute.h90" 
    8789   !!---------------------------------------------------------------------- 
    8890   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    137139      CALL iom_put("e3v_0", e3v_0(:,:,:) ) 
    138140      ! 
    139       CALL iom_put( "e3t" , e3t(:,:,:,Kmm) ) 
    140       CALL iom_put( "e3u" , e3u(:,:,:,Kmm) ) 
    141       CALL iom_put( "e3v" , e3v(:,:,:,Kmm) ) 
    142       CALL iom_put( "e3w" , e3w(:,:,:,Kmm) ) 
    143       IF( iom_use("e3tdef") )   & 
    144          CALL iom_put( "e3tdef"  , ( ( e3t(:,:,:,Kmm) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 ) 
    145  
     141!!st13 
     142#if ! defined key_qco 
     143      IF ( iom_use("e3t") .OR. iom_use("e3tdef") ) THEN  ! time-varying e3t 
     144         DO jk = 1, jpk 
     145            z3d(:,:,jk) =  e3t(:,:,jk,Kmm) 
     146         END DO 
     147         CALL iom_put( "e3t"     ,     z3d(:,:,:) ) 
     148         CALL iom_put( "e3tdef"  , ( ( z3d(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 )  
     149      ENDIF  
     150      IF ( iom_use("e3u") ) THEN                         ! time-varying e3u 
     151         DO jk = 1, jpk 
     152            z3d(:,:,jk) =  e3u(:,:,jk,Kmm) 
     153         END DO  
     154         CALL iom_put( "e3u" , z3d(:,:,:) ) 
     155      ENDIF 
     156      IF ( iom_use("e3v") ) THEN                         ! time-varying e3v 
     157         DO jk = 1, jpk 
     158            z3d(:,:,jk) =  e3v(:,:,jk,Kmm) 
     159         END DO  
     160         CALL iom_put( "e3v" , z3d(:,:,:) ) 
     161      ENDIF 
     162      IF ( iom_use("e3w") ) THEN                         ! time-varying e3w 
     163         DO jk = 1, jpk 
     164            z3d(:,:,jk) =  e3w(:,:,jk,Kmm) 
     165         END DO  
     166         CALL iom_put( "e3w" , z3d(:,:,:) ) 
     167      ENDIF 
     168#endif  
     169!!st13 
    146170      IF( ll_wd ) THEN 
    147171         CALL iom_put( "ssh" , (ssh(:,:,Kmm)+ssh_ref)*tmask(:,:,1) )   ! sea surface height (brought back to the reference used for wetting and drying) 
    … …  
    351375      ! 
    352376      REAL(wp), DIMENSION(jpi,jpj)   :: zw2d       ! 2D workspace 
    353       REAL(wp), DIMENSION(jpi,jpj,jpk) :: zw3d       ! 3D workspace 
     377!!st14 
     378      REAL(wp), DIMENSION(jpi,jpj,jpk) :: zw3d, ze3t, zgdept       ! 3D workspace 
    354379      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zw3d_abl   ! ABL 3D workspace 
    355380      !!---------------------------------------------------------------------- 
    … …  
    391416      it = kt 
    392417      itmod = kt - nit000 + 1 
    393  
     418!!st15 
     419      ! store e3t for subsitute 
     420      DO jk = 1, jpk 
     421         ze3t  (:,:,jk) =  e3t  (:,:,jk,Kmm) 
     422         zgdept(:,:,jk) =  gdept(:,:,jk,Kmm) 
     423      END DO 
     424!!st15 
    394425 
    395426      ! 1. Define NETCDF files and fields at beginning of first time step 
    … …  
    514545            &          jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout ) 
    515546         IF(  .NOT.ln_linssh  ) THEN 
    516             CALL histdef( nid_T, "vovvle3t", "Level thickness"                    , "m"      ,&  ! e3t(:,:,:,Kmm) 
     547            CALL histdef( nid_T, "vovvle3t", "Level thickness"                    , "m"      ,&  ! ze3t(:,:,:,Kmm) 
    517548            &             jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout ) 
    518             CALL histdef( nid_T, "vovvldep", "T point depth"                      , "m"      ,&  ! e3t(:,:,:,Kmm) 
     549            CALL histdef( nid_T, "vovvldep", "T point depth"                      , "m"      ,&  ! ze3t(:,:,:,Kmm) 
    519550            &             jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout ) 
    520             CALL histdef( nid_T, "vovvldef", "Squared level deformation"          , "%^2"    ,&  ! e3t(:,:,:,Kmm) 
     551            CALL histdef( nid_T, "vovvldef", "Squared level deformation"          , "%^2"    ,&  ! ze3t(:,:,:,Kmm) 
    521552            &             jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout ) 
    522553         ENDIF 
    … …  
    700731         WRITE(numout,*) '~~~~~~ ' 
    701732      ENDIF 
    702  
     733!!st16 
    703734      IF( .NOT.ln_linssh ) THEN 
    704          CALL histwrite( nid_T, "votemper", it, ts(:,:,:,jp_tem,Kmm) * e3t(:,:,:,Kmm) , ndim_T , ndex_T  )   ! heat content 
    705          CALL histwrite( nid_T, "vosaline", it, ts(:,:,:,jp_sal,Kmm) * e3t(:,:,:,Kmm) , ndim_T , ndex_T  )   ! salt content 
    706          CALL histwrite( nid_T, "sosstsst", it, ts(:,:,1,jp_tem,Kmm) * e3t(:,:,1,Kmm) , ndim_hT, ndex_hT )   ! sea surface heat content 
    707          CALL histwrite( nid_T, "sosaline", it, ts(:,:,1,jp_sal,Kmm) * e3t(:,:,1,Kmm) , ndim_hT, ndex_hT )   ! sea surface salinity content 
     735         CALL histwrite( nid_T, "votemper", it, ts(:,:,:,jp_tem,Kmm) * ze3t(:,:,:) , ndim_T , ndex_T  )   ! heat content 
     736         CALL histwrite( nid_T, "vosaline", it, ts(:,:,:,jp_sal,Kmm) * ze3t(:,:,:) , ndim_T , ndex_T  )   ! salt content 
     737         CALL histwrite( nid_T, "sosstsst", it, ts(:,:,1,jp_tem,Kmm) * ze3t(:,:,1) , ndim_hT, ndex_hT )   ! sea surface heat content 
     738         CALL histwrite( nid_T, "sosaline", it, ts(:,:,1,jp_sal,Kmm) * ze3t(:,:,1) , ndim_hT, ndex_hT )   ! sea surface salinity content 
     739!!st16 
    708740      ELSE 
    709741         CALL histwrite( nid_T, "votemper", it, ts(:,:,:,jp_tem,Kmm) , ndim_T , ndex_T  )   ! temperature 
    … …  
    713745      ENDIF 
    714746      IF( .NOT.ln_linssh ) THEN 
    715          zw3d(:,:,:) = ( ( e3t(:,:,:,Kmm) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 
    716          CALL histwrite( nid_T, "vovvle3t", it, e3t (:,:,:,Kmm) , ndim_T , ndex_T  )   ! level thickness 
    717          CALL histwrite( nid_T, "vovvldep", it, gdept(:,:,:,Kmm) , ndim_T , ndex_T  )   ! t-point depth 
     747!!st17 if ! defined key_qco  
     748         zw3d(:,:,:) = ( ( ze3t(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 
     749         CALL histwrite( nid_T, "vovvle3t", it, ze3t (:,:,:)     , ndim_T , ndex_T  )   ! level thickness 
     750         CALL histwrite( nid_T, "vovvldep", it, zgdept , ndim_T , ndex_T  )   ! t-point depth  
     751!!st17 
    718752         CALL histwrite( nid_T, "vovvldef", it, zw3d             , ndim_T , ndex_T  )   ! level thickness deformation 
    719753      ENDIF 
    … …  
    854888      !! 
    855889      INTEGER :: inum, jk 
     890!!st18  TBR 
     891      REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t, zgdept      ! 3D workspace !!st patch to use substitution 
    856892      !!---------------------------------------------------------------------- 
    857893      !  
    … …  
    860896      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~   and forcing fields file created ' 
    861897      IF(lwp) WRITE(numout,*) '                and named :', cdfile_name, '...nc' 
    862  
     898!!st19 TBR 
     899      DO jk = 1, jpk 
     900         ze3t(:,:,jk) =  e3t(:,:,jk,Kmm) 
     901         zgdept(:,:,jk) =  gdept(:,:,jk,Kmm) 
     902      END DO 
     903!!st19 
    863904#if defined key_si3 
    864905     CALL iom_open( TRIM(cdfile_name), inum, ldwrt = .TRUE., kdlev = jpl ) 
    … …  
    878919      ENDIF 
    879920      CALL iom_rstput( 0, 0, inum, 'risfdep', risfdep            )    ! now k-velocity 
    880       CALL iom_rstput( 0, 0, inum, 'ht'     , ht                 )    ! now water column height 
     921      CALL iom_rstput( 0, 0, inum, 'ht'     , ht(:,:)            )    ! now water column height 
    881922 
    882923      IF ( ln_isf ) THEN 
    … …  
    885926            CALL iom_rstput( 0, 0, inum, 'rhisf_cav_tbl', rhisf_tbl_cav    )    ! now k-velocity 
    886927            CALL iom_rstput( 0, 0, inum, 'rfrac_cav_tbl', rfrac_tbl_cav    )    ! now k-velocity 
    887             CALL iom_rstput( 0, 0, inum, 'misfkb_cav', REAL(misfkb_cav,8)    )    ! now k-velocity 
    888             CALL iom_rstput( 0, 0, inum, 'misfkt_cav', REAL(misfkt_cav,8)    )    ! now k-velocity 
    889             CALL iom_rstput( 0, 0, inum, 'mskisf_cav', REAL(mskisf_cav,8), ktype = jp_i1 ) 
     928            CALL iom_rstput( 0, 0, inum, 'misfkb_cav', REAL(misfkb_cav,wp) )    ! now k-velocity 
     929            CALL iom_rstput( 0, 0, inum, 'misfkt_cav', REAL(misfkt_cav,wp) )    ! now k-velocity 
     930            CALL iom_rstput( 0, 0, inum, 'mskisf_cav', REAL(mskisf_cav,wp), ktype = jp_i1 ) 
    890931         END IF 
    891932         IF (ln_isfpar_mlt) THEN 
    892             CALL iom_rstput( 0, 0, inum, 'isfmsk_par', REAL(mskisf_par,8) )    ! now k-velocity 
     933            CALL iom_rstput( 0, 0, inum, 'isfmsk_par', REAL(mskisf_par,wp) )    ! now k-velocity 
    893934            CALL iom_rstput( 0, 0, inum, 'fwfisf_par', fwfisf_par          )    ! now k-velocity 
    894935            CALL iom_rstput( 0, 0, inum, 'rhisf_par_tbl', rhisf_tbl_par    )    ! now k-velocity 
    895936            CALL iom_rstput( 0, 0, inum, 'rfrac_par_tbl', rfrac_tbl_par    )    ! now k-velocity 
    896             CALL iom_rstput( 0, 0, inum, 'misfkb_par', REAL(misfkb_par,8)    )    ! now k-velocity 
    897             CALL iom_rstput( 0, 0, inum, 'misfkt_par', REAL(misfkt_par,8)    )    ! now k-velocity 
    898             CALL iom_rstput( 0, 0, inum, 'mskisf_par', REAL(mskisf_par,8), ktype = jp_i1 ) 
     937            CALL iom_rstput( 0, 0, inum, 'misfkb_par', REAL(misfkb_par,wp) )    ! now k-velocity 
     938            CALL iom_rstput( 0, 0, inum, 'misfkt_par', REAL(misfkt_par,wp) )    ! now k-velocity 
     939            CALL iom_rstput( 0, 0, inum, 'mskisf_par', REAL(mskisf_par,wp), ktype = jp_i1 ) 
    899940         END IF 
    900941      END IF 
    901  
     942      ! 
    902943      IF( ALLOCATED(ahtu) ) THEN 
    903944         CALL iom_rstput( 0, 0, inum,  'ahtu', ahtu              )    ! aht at u-point 
    … …  
    914955      CALL iom_rstput( 0, 0, inum, 'sozotaux', utau              )    ! i-wind stress 
    915956      CALL iom_rstput( 0, 0, inum, 'sometauy', vtau              )    ! j-wind stress 
    916       IF(  .NOT.ln_linssh  ) THEN              
    917          CALL iom_rstput( 0, 0, inum, 'vovvldep', gdept(:,:,:,Kmm)        )    !  T-cell depth  
    918          CALL iom_rstput( 0, 0, inum, 'vovvle3t', e3t(:,:,:,Kmm)          )    !  T-cell thickness   
     957!!st20 TBR 
     958      IF(  .NOT.ln_linssh  ) THEN 
     959         CALL iom_rstput( 0, 0, inum, 'vovvldep', zgdept        )    !  T-cell depth  
     960         CALL iom_rstput( 0, 0, inum, 'vovvle3t', ze3t          )    !  T-cell thickness   
    919961      END IF 
    920962      IF( ln_wave .AND. ln_sdw ) THEN 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/SWE/dom_oce.F90

    r12614 r13151  
    7171   !                                !  = 6 cyclic East-West AND North fold F-point pivot 
    7272   !                                !  = 7 bi-cyclic East-West AND North-South 
    73    LOGICAL, PUBLIC ::   l_Iperio, l_Jperio   !   should we explicitely take care I/J periodicity  
    74  
    75    !                                 ! domain MPP decomposition parameters 
     73   LOGICAL, PUBLIC ::   l_Iperio, l_Jperio   !   should we explicitely take care I/J periodicity 
     74 
     75   !                             !: domain MPP decomposition parameters 
    7676   INTEGER             , PUBLIC ::   nimpp, njmpp     !: i- & j-indexes for mpp-subdomain left bottom 
    7777   INTEGER             , PUBLIC ::   nreci, nrecj     !: overlap region in i and j 
    … …  
    136136   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::    e3vw_0   !: vw-vert. scale factor [m] 
    137137   !                                                        !  time-dependent scale factors 
     138!!st1 
     139#if ! defined key_qco 
    138140   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   e3t, e3u, e3v, e3w, e3uw, e3vw  !: vert. scale factor [m] 
    139141   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   e3f                             !: F-point vert. scale factor [m] 
     142#endif 
     143   !                                                        !  time-dependent ratio ssh / h_0 
     144   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   r3t, r3u, r3v                   !: time-dependent    ratio at t-, u- and v-point [-] 
     145   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   r3f                             !: mid-time-level    ratio at f-point            [-] 
     146   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   r3t_f, r3u_f, r3v_f             !: now time-filtered ratio at t-, u- and v-point [-] 
    140147 
    141148   !                                                        !  reference depths of cells 
    142    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   gdept_0  !: t- depth              [m] 
    143    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   gdepw_0  !: w- depth              [m] 
    144    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   gde3w_0  !: w- depth (sum of e3w) [m] 
     149   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   gdept_0  !: t- depth              [m] 
     150   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   gdepw_0  !: w- depth              [m] 
     151   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   gde3w_0  !: w- depth (sum of e3w) [m] 
    145152   !                                                        !  time-dependent depths of cells 
    146    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::  gdept, gdepw   
    147    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::  gde3w   
     153   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   gdept, gdepw 
     154   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   gde3w 
     155!!st2 
     156   !                                                        !  reference heights of ocean water column and its inverse 
     157   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   ht_0, r1_ht_0   !: t-depth        [m] and [1/m] 
     158   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   hu_0, r1_hu_0   !: u-depth        [m] and [1/m] 
     159   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   hv_0, r1_hv_0   !: v-depth        [m] and [1/m] 
     160   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   hf_0, r1_hf_0   !: f-depth        [m] and [1/m] 
     161   !                                                        ! time-dependent heights of ocean water column 
     162#if ! defined key_qco 
     163   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   ht          !: t-points           [m] 
     164   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   hu, r1_hu   !: u-depth            [m] and [1/m] 
     165   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   hv, r1_hv   !: v-depth            [m] and [1/m] 
     166#endif 
     167!!st2 
    148168    
    149    !                                                      !  reference heights of water column 
    150    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ht_0  !: t-depth              [m] 
    151    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hu_0  !: u-depth              [m] 
    152    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hv_0  !: v-depth              [m] 
    153    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hf_0  !: f-depth              [m] 
    154    !                                                      !  inverse of reference heights of water column 
    155    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   r1_ht_0  !: t-depth              [1/m] 
    156    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   r1_hu_0  !: u-depth              [1/m] 
    157    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   r1_hv_0  !: v-depth              [1/m] 
    158    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   r1_hf_0  !: f-depth              [1/m] 
    159     
    160                                                           ! time-dependent heights of water column 
    161    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ht                     !: height of water column at T-points [m] 
    162    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   hu, hv, r1_hu, r1_hv   !: height of water column [m] and reciprocal [1/m] 
    163  
    164169   INTEGER, PUBLIC ::   nla10              !: deepest    W level Above  ~10m (nlb10 - 1) 
    165170   INTEGER, PUBLIC ::   nlb10              !: shallowest W level Bellow ~10m (nla10 + 1)  
    … …  
    176181   !! --------------------------------------------------------------------- 
    177182!!gm Proposition of new name for top/bottom vertical indices 
    178 !   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   mtk_t, mtk_u, mtk_v   !: top first wet T-, U-, V-, F-level (ISF) 
    179 !   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   mbk_t, mbk_u, mbk_v   !: bottom last wet T-, U- and V-level 
     183!   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   mtk_t, mtk_u, mtk_v   !: top    first wet T-, U-, and V-level (ISF) 
     184!   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   mbk_t, mbk_u, mbk_v   !: bottom last  wet T-, U-, and V-level 
    180185!!gm 
    181186   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   mbkt, mbku, mbkv   !: bottom last wet T-, U- and V-level 
    … …  
    244249   END FUNCTION Agrif_CFixed 
    245250#endif 
    246  
     251!!st3: dom_oce_alloc modified to ease the ifdef if necessary (gm stuff) 
    247252   INTEGER FUNCTION dom_oce_alloc() 
    248253      !!---------------------------------------------------------------------- 
    249       INTEGER, DIMENSION(12) :: ierr 
     254      INTEGER                ::   ii 
     255      INTEGER, DIMENSION(30) :: ierr 
    250256      !!---------------------------------------------------------------------- 
    251       ierr(:) = 0 
     257      ii = 0   ;   ierr(:) = 0 
    252258      ! 
    253       ALLOCATE( mig(jpi), mjg(jpj), STAT=ierr(1) ) 
    254          ! 
    255       ALLOCATE( mi0(jpiglo)   , mi1 (jpiglo),  mj0(jpjglo)   , mj1 (jpjglo) ,     & 
    256          &      tpol(jpiglo)  , fpol(jpiglo)                                , STAT=ierr(2) ) 
    257          ! 
     259      ii = ii+1 
     260      ALLOCATE( mig(jpi), mjg(jpj), STAT=ierr(ii) ) 
     261         ! 
     262      ii = ii+1 
     263      ALLOCATE( mi0 (jpiglo) , mi1 (jpiglo),  mj0(jpjglo) , mj1 (jpjglo) ,     & 
     264         &      tpol(jpiglo) , fpol(jpiglo)                              , STAT=ierr(ii) ) 
     265         ! 
     266      ii = ii+1 
    258267      ALLOCATE( glamt(jpi,jpj) ,    glamu(jpi,jpj) ,  glamv(jpi,jpj) ,  glamf(jpi,jpj) ,     & 
    259268         &      gphit(jpi,jpj) ,    gphiu(jpi,jpj) ,  gphiv(jpi,jpj) ,  gphif(jpi,jpj) ,     & 
    … …  
    266275         &      e1e2v(jpi,jpj) , r1_e1e2v(jpi,jpj) , e1_e2v(jpi,jpj)                   ,     & 
    267276         &      e1e2f(jpi,jpj) , r1_e1e2f(jpi,jpj)                                     ,     & 
    268          &      ff_f (jpi,jpj) ,    ff_t (jpi,jpj)                                     , STAT=ierr(3) ) 
    269          ! 
     277         &      ff_f (jpi,jpj) ,    ff_t (jpi,jpj)                                     , STAT=ierr(ii) ) 
     278         ! 
     279      ii = ii+1 
     280      ALLOCATE(  e3t_0(jpi,jpj,jpk) , e3u_0 (jpi,jpj,jpk) , e3v_0 (jpi,jpj,jpk) , e3f_0(jpi,jpj,jpk) ,      & 
     281         &       e3w_0(jpi,jpj,jpk) , e3uw_0(jpi,jpj,jpk) , e3vw_0(jpi,jpj,jpk)                      ,  STAT=ierr(ii) ) 
     282         ! 
     283      ii = ii+1 
    270284      ALLOCATE( gdept_0(jpi,jpj,jpk)     , gdepw_0(jpi,jpj,jpk)     , gde3w_0(jpi,jpj,jpk) ,      & 
    271          &      gdept  (jpi,jpj,jpk,jpt) , gdepw  (jpi,jpj,jpk,jpt) , gde3w  (jpi,jpj,jpk) , STAT=ierr(4) ) 
    272          ! 
    273       ALLOCATE( e3t_0(jpi,jpj,jpk)     , e3u_0(jpi,jpj,jpk)     , e3v_0(jpi,jpj,jpk)     , e3f_0(jpi,jpj,jpk) , e3w_0(jpi,jpj,jpk)     ,   & 
    274          &      e3t  (jpi,jpj,jpk,jpt) , e3u  (jpi,jpj,jpk,jpt) , e3v  (jpi,jpj,jpk,jpt) , e3f  (jpi,jpj,jpk) , e3w  (jpi,jpj,jpk,jpt) ,   &  
    275          &      e3uw_0(jpi,jpj,jpk)     , e3vw_0(jpi,jpj,jpk)     ,         & 
    276          &      e3uw  (jpi,jpj,jpk,jpt) , e3vw  (jpi,jpj,jpk,jpt) ,    STAT=ierr(5) )                        
    277          !     
    278       ALLOCATE(    ht_0(jpi,jpj) ,    hu_0(jpi,jpj)     ,    hv_0(jpi,jpj)     ,    hf_0(jpi,jpj) ,     & 
    279          &      r1_ht_0(jpi,jpj) , r1_hu_0(jpi,jpj)     , r1_hv_0(jpi,jpj)     , r1_hf_0(jpi,jpj) ,     & 
    280          &         ht  (jpi,jpj) ,    hu  (jpi,jpj,jpt) ,    hv  (jpi,jpj,jpt)                    ,     & 
    281          &                         r1_hu  (jpi,jpj,jpt) , r1_hv  (jpi,jpj,jpt)                    , STAT=ierr(6)  ) 
    282          ! 
    283       ALLOCATE( risfdep(jpi,jpj) , bathy(jpi,jpj) , STAT=ierr(7)  )  
    284          ! 
    285       ALLOCATE( gdept_1d(jpk) , gdepw_1d(jpk) , e3t_1d(jpk) , e3w_1d(jpk) , STAT=ierr(8) ) 
    286          ! 
    287       ALLOCATE( tmask_i(jpi,jpj) , tmask_h(jpi,jpj) ,                                           &  
     285         &      gdept  (jpi,jpj,jpk,jpt) , gdepw  (jpi,jpj,jpk,jpt) , gde3w  (jpi,jpj,jpk) , STAT=ierr(ii) ) 
     286         ! 
     287!!st4 
     288#if ! defined key_qco 
     289      ii = ii+1 
     290      ALLOCATE( e3t(jpi,jpj,jpk,jpt) , e3u (jpi,jpj,jpk,jpt) , e3v (jpi,jpj,jpk,jpt) , e3f(jpi,jpj,jpk) ,      & 
     291         &      e3w(jpi,jpj,jpk,jpt) , e3uw(jpi,jpj,jpk,jpt) , e3vw(jpi,jpj,jpk,jpt)                    ,  STAT=ierr(ii) ) 
     292#endif 
     293!!st4 
     294         ! 
     295      ii = ii+1 
     296      ALLOCATE( r3t  (jpi,jpj,jpt)   , r3u  (jpi,jpj,jpt)    , r3v  (jpi,jpj,jpt)    , r3f  (jpi,jpj) ,  & 
     297         &      r3t_f(jpi,jpj)       , r3u_f(jpi,jpj)        , r3v_f(jpi,jpj)                         ,  STAT=ierr(ii) )        
     298         ! 
     299      ii = ii+1 
     300      ALLOCATE( ht_0(jpi,jpj) ,    hu_0(jpi,jpj)    ,    hv_0(jpi,jpj)     , hf_0(jpi,jpj) ,       & 
     301         &   r1_ht_0(jpi,jpj) , r1_hu_0(jpi,jpj) ,    r1_hv_0(jpi,jpj),   r1_hf_0(jpi,jpj) ,   STAT=ierr(ii)  ) 
     302         ! 
     303#if ! defined key_qco 
     304      ii = ii+1 
     305      ALLOCATE( ht  (jpi,jpj) ,    hu  (jpi,jpj,jpt),    hv  (jpi,jpj,jpt)                 ,       & 
     306         &                      r1_hu  (jpi,jpj,jpt), r1_hv  (jpi,jpj,jpt)                 ,   STAT=ierr(ii)  ) 
     307#endif 
     308         ! 
     309      ii = ii+1 
     310      ALLOCATE( risfdep(jpi,jpj) , bathy(jpi,jpj) , STAT=ierr(ii)  )  
     311         ! 
     312      ii = ii+1 
     313      ALLOCATE( gdept_1d(jpk) , gdepw_1d(jpk) , e3t_1d(jpk) , e3w_1d(jpk) , STAT=ierr(ii) ) 
     314         ! 
     315      ii = ii+1 
     316      ALLOCATE( tmask_i(jpi,jpj) , tmask_h(jpi,jpj) ,                                           & 
    288317         &      ssmask (jpi,jpj) , ssumask(jpi,jpj) , ssvmask(jpi,jpj) , ssfmask(jpi,jpj) ,     & 
    289          &      mbkt   (jpi,jpj) , mbku   (jpi,jpj) , mbkv   (jpi,jpj)                    , STAT=ierr(9) ) 
    290          ! 
    291       ALLOCATE( mikt(jpi,jpj), miku(jpi,jpj), mikv(jpi,jpj), mikf(jpi,jpj), STAT=ierr(10) ) 
    292          ! 
    293       ALLOCATE( tmask(jpi,jpj,jpk) , umask(jpi,jpj,jpk) ,     &  
    294          &      vmask(jpi,jpj,jpk) , fmask(jpi,jpj,jpk) , STAT=ierr(11) ) 
    295          ! 
    296       ALLOCATE( wmask(jpi,jpj,jpk) , wumask(jpi,jpj,jpk), wvmask(jpi,jpj,jpk) , STAT=ierr(12) ) 
     318         &      mbkt   (jpi,jpj) , mbku   (jpi,jpj) , mbkv   (jpi,jpj) ,                    STAT=ierr(ii) ) 
     319         ! 
     320      ii = ii+1 
     321      ALLOCATE( mikt(jpi,jpj), miku(jpi,jpj), mikv(jpi,jpj), mikf(jpi,jpj), STAT=ierr(ii) ) 
     322         ! 
     323      ii = ii+1 
     324      ALLOCATE( tmask(jpi,jpj,jpk) , umask(jpi,jpj,jpk) ,     & 
     325         &      vmask(jpi,jpj,jpk) , fmask(jpi,jpj,jpk) , STAT=ierr(ii) ) 
     326         ! 
     327      ii = ii+1 
     328      ALLOCATE( wmask(jpi,jpj,jpk) , wumask(jpi,jpj,jpk), wvmask(jpi,jpj,jpk) , STAT=ierr(ii) ) 
    297329      ! 
    298330      dom_oce_alloc = MAXVAL(ierr) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/SWE/domain.F90

    r12822 r13151  
    3434   USE dommsk         ! domain: set the mask system 
    3535   USE domwri         ! domain: write the meshmask file 
     36!!st5 
     37#if ! defined key_qco 
    3638   USE domvvl         ! variable volume 
     39#else 
     40   USE domqco          ! variable volume 
     41#endif 
     42!!st5 
    3743   USE c1d            ! 1D configuration 
    3844   USE dyncor_c1d     ! 1D configuration: Coriolis term    (cor_c1d routine) 
    … …  
    7884      CHARACTER (len=*), INTENT(in) :: cdstr                  ! model: NEMO or SAS. Determines core restart variables 
    7985      ! 
    80       INTEGER ::   ji, jj, jk, ik   ! dummy loop indices 
     86!!st6 
     87      INTEGER ::   ji, jj, jk, jt   ! dummy loop indices 
     88!!st6 
    8189      INTEGER ::   iconf = 0    ! local integers 
    8290      CHARACTER (len=64) ::   cform = "(A12, 3(A13, I7))"  
    … …  
    114122         CASE( 7 )   ;   WRITE(numout,*) '         (i.e. cyclic east-west and north-south)' 
    115123         CASE DEFAULT 
    116             CALL ctl_stop( 'jperio is out of range' ) 
     124            CALL ctl_stop( 'dom_init:   jperio is out of range' ) 
    117125         END SELECT 
    118126         WRITE(numout,*)     '      Ocean model configuration used:' 
    … …  
    144152      IF( ln_closea ) CALL dom_clo      ! Read in masks to define closed seas and lakes 
    145153 
    146       CALL dom_zgr( ik_top, ik_bot )    ! Vertical mesh and bathymetry 
     154      CALL dom_zgr( ik_top, ik_bot )    ! Vertical mesh and bathymetry (return top and bottom ocean t-level indices) 
    147155 
    148156      CALL dom_msk( ik_top, ik_bot )    ! Masks 
    149  
    150       ht_0(:,:) = 0._wp                 ! Reference ocean thickness 
     157      ! 
     158      ht_0(:,:) = 0._wp  ! Reference ocean thickness 
    151159      hu_0(:,:) = 0._wp 
    152160      hv_0(:,:) = 0._wp 
    … …  
    190198!            r1_e1e2t(ji,jj) = r1_e1e2t(ji,jj) / zcoeff 
    191199!!an45 
     200!!st7 : make it easier to use key_qco condition (gm stuff) 
     201#if defined key_qco 
     202      !           !==  initialisation of time varying coordinate  ==!   Quasi-Euerian coordinate case 
     203      ! 
     204      IF( .NOT.l_offline )   CALL dom_qco_init( Kbb, Kmm, Kaa ) 
     205      ! 
     206      IF( ln_linssh )        CALL ctl_stop('STOP','domain: key_qco and ln_linssh = T are incompatible') 
     207      ! 
     208#else 
    192209      !           !==  time varying part of coordinate system  ==! 
    193210      ! 
    194211      IF( ln_linssh ) THEN       != Fix in time : set to the reference one for all 
    195       ! 
    196          !       before        !          now          !       after         ! 
    197             gdept(:,:,:,Kbb) = gdept_0  ;   gdept(:,:,:,Kmm) = gdept_0   ;   gdept(:,:,:,Kaa) = gdept_0   ! depth of grid-points 
    198             gdepw(:,:,:,Kbb) = gdepw_0  ;   gdepw(:,:,:,Kmm) = gdepw_0   ;   gdepw(:,:,:,Kaa) = gdepw_0   ! 
    199                                    gde3w = gde3w_0   !        ---          ! 
    200          !                                                                   
    201               e3t(:,:,:,Kbb) =   e3t_0  ;     e3t(:,:,:,Kmm) =   e3t_0   ;   e3t(:,:,:,Kaa) =  e3t_0    ! scale factors 
    202               e3u(:,:,:,Kbb) =   e3u_0  ;     e3u(:,:,:,Kmm) =   e3u_0   ;   e3u(:,:,:,Kaa) =  e3u_0    ! 
    203               e3v(:,:,:,Kbb) =   e3v_0  ;     e3v(:,:,:,Kmm) =   e3v_0   ;   e3v(:,:,:,Kaa) =  e3v_0    ! 
    204                                      e3f =   e3f_0   !        ---          ! 
    205               e3w(:,:,:,Kbb) =   e3w_0  ;     e3w(:,:,:,Kmm) =   e3w_0   ;    e3w(:,:,:,Kaa) =   e3w_0   !  
    206              e3uw(:,:,:,Kbb) =  e3uw_0  ;    e3uw(:,:,:,Kmm) =  e3uw_0   ;   e3uw(:,:,:,Kaa) =  e3uw_0   !   
    207              e3vw(:,:,:,Kbb) =  e3vw_0  ;    e3vw(:,:,:,Kmm) =  e3vw_0   ;   e3vw(:,:,:,Kaa) =  e3vw_0   ! 
    208          ! 
    209          z1_hu_0(:,:) = ssumask(:,:) / ( hu_0(:,:) + 1._wp - ssumask(:,:) )     ! _i mask due to ISF 
    210          z1_hv_0(:,:) = ssvmask(:,:) / ( hv_0(:,:) + 1._wp - ssvmask(:,:) ) 
    211          ! 
    212          !        before       !          now          !       after         ! 
    213                                       ht =    ht_0   !                     ! water column thickness 
    214                hu(:,:,Kbb) =    hu_0  ;      hu(:,:,Kmm) =    hu_0   ;    hu(:,:,Kaa) =    hu_0   !  
    215                hv(:,:,Kbb) =    hv_0  ;      hv(:,:,Kmm) =    hv_0   ;    hv(:,:,Kaa) =    hv_0   ! 
    216             r1_hu(:,:,Kbb) = z1_hu_0  ;   r1_hu(:,:,Kmm) = z1_hu_0   ; r1_hu(:,:,Kaa) = z1_hu_0   ! inverse of water column thickness 
    217             r1_hv(:,:,Kbb) = z1_hv_0  ;   r1_hv(:,:,Kmm) = z1_hv_0   ; r1_hv(:,:,Kaa) = z1_hv_0   ! 
    218          ! 
     212         ! 
     213         DO jt = 1, jpt                         ! depth of t- and w-grid-points 
     214            gdept(:,:,:,jt) = gdept_0(:,:,:) 
     215            gdepw(:,:,:,jt) = gdepw_0(:,:,:) 
     216         END DO 
     217            gde3w(:,:,:)    = gde3w_0(:,:,:)    ! = gdept as the sum of e3t 
     218         ! 
     219         DO jt = 1, jpt                         ! vertical scale factors 
     220            e3t(:,:,:,jt) =  e3t_0(:,:,:) 
     221            e3u(:,:,:,jt) =  e3u_0(:,:,:) 
     222            e3v(:,:,:,jt) =  e3v_0(:,:,:) 
     223            e3w(:,:,:,jt) =  e3w_0(:,:,:) 
     224            e3uw(:,:,:,jt) = e3uw_0(:,:,:) 
     225            e3vw(:,:,:,jt) = e3vw_0(:,:,:) 
     226         END DO 
     227            e3f(:,:,:)    =  e3f_0(:,:,:) 
     228         ! 
     229         DO jt = 1, jpt                         ! water column thickness and its inverse 
     230            hu(:,:,jt)    =    hu_0(:,:) 
     231            hv(:,:,jt)    =    hv_0(:,:) 
     232            r1_hu(:,:,jt) = r1_hu_0(:,:) 
     233            r1_hv(:,:,jt) = r1_hv_0(:,:) 
     234         END DO 
     235            ht(:,:) =    ht_0(:,:) 
    219236         ! 
    220237      ELSE                       != time varying : initialize before/now/after variables 
    221238         ! 
    222          IF( .NOT.l_offline )  CALL dom_vvl_init( Kbb, Kmm, Kaa ) 
    223          ! 
    224       ENDIF 
     239         IF( .NOT.l_offline )   CALL dom_vvl_init( Kbb, Kmm, Kaa ) 
     240         ! 
     241      ENDIF 
     242#endif 
     243!!st7 
    225244      ! 
    226245      IF( lk_c1d         )   CALL cor_c1d       ! 1D configuration: Coriolis set at T-point 
    … …  
    238257         WRITE(numout,*)  
    239258      ENDIF 
    240        
    241259      ! 
    242260   END SUBROUTINE dom_init 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/SWE/domvvl.F90

    r13005 r13151  
     1 
    12MODULE domvvl 
    23   !!====================================================================== 
    … …  
    1112   !!---------------------------------------------------------------------- 
    1213 
    13    !!---------------------------------------------------------------------- 
    14    !!   dom_vvl_init     : define initial vertical scale factors, depths and column thickness 
    15    !!   dom_vvl_sf_nxt   : Compute next vertical scale factors 
    16    !!   dom_vvl_sf_update   : Swap vertical scale factors and update the vertical grid 
    17    !!   dom_vvl_interpol : Interpolate vertical scale factors from one grid point to another 
    18    !!   dom_vvl_rst      : read/write restart file 
    19    !!   dom_vvl_ctl      : Check the vvl options 
    20    !!---------------------------------------------------------------------- 
    2114   USE oce             ! ocean dynamics and tracers 
    2215   USE phycst          ! physical constant 
    … …  
    3629   PRIVATE 
    3730 
    38    PUBLIC  dom_vvl_init       ! called by domain.F90 
    39    PUBLIC  dom_vvl_zgr        ! called by isfcpl.F90 
    40    PUBLIC  dom_vvl_sf_nxt     ! called by step.F90 
    41    PUBLIC  dom_vvl_sf_update  ! called by step.F90 
    42    PUBLIC  dom_vvl_interpol   ! called by dynnxt.F90 
    43  
    4431   !                                                      !!* Namelist nam_vvl 
    4532   LOGICAL , PUBLIC :: ln_vvl_zstar           = .FALSE.    ! zstar  vertical coordinate 
    … …  
    6249   REAL(wp)        , ALLOCATABLE, SAVE, DIMENSION(:,:)   :: frq_rst_e3t                 ! retoring period for scale factors 
    6350   REAL(wp)        , ALLOCATABLE, SAVE, DIMENSION(:,:)   :: frq_rst_hdv                 ! retoring period for low freq. divergence 
    64  
     51!!stoops 
     52#if defined key_qco 
     53   !!---------------------------------------------------------------------- 
     54   !!   'key_qco'      EMPTY MODULE      Quasi-Eulerian vertical coordonate 
     55   !!---------------------------------------------------------------------- 
     56#else 
     57   !!---------------------------------------------------------------------- 
     58   !!   Default key      Old management of time varying vertical coordinate 
     59   !!---------------------------------------------------------------------- 
     60!!st 
     61   !!---------------------------------------------------------------------- 
     62   !!   dom_vvl_init     : define initial vertical scale factors, depths and column thickness 
     63   !!   dom_vvl_sf_nxt   : Compute next vertical scale factors 
     64   !!   dom_vvl_sf_update   : Swap vertical scale factors and update the vertical grid 
     65   !!   dom_vvl_interpol : Interpolate vertical scale factors from one grid point to another 
     66   !!   dom_vvl_rst      : read/write restart file 
     67   !!   dom_vvl_ctl      : Check the vvl options 
     68   !!---------------------------------------------------------------------- 
     69   
     70   PUBLIC  dom_vvl_init       ! called by domain.F90 
     71   PUBLIC  dom_vvl_zgr        ! called by isfcpl.F90 
     72   PUBLIC  dom_vvl_sf_nxt     ! called by step.F90 
     73   PUBLIC  dom_vvl_sf_update  ! called by step.F90 
     74   PUBLIC  dom_vvl_interpol   ! called by dynnxt.F90 
     75   PUBLIC  dom_vvl_interpol_st! called by dynnxt.F90 
     76   PUBLIC  dom_vvl_sf_nxt_st  ! called by step.F90 
     77   PUBLIC  dom_vvl_sf_update_st 
     78!!st 
     79    
    6580   !! * Substitutions 
    6681#  include "do_loop_substitute.h90" 
    … …  
    132147      e3t(:,:,jpk,Kaa) = e3t_0(:,:,jpk)  ! last level always inside the sea floor set one for all 
    133148      ! 
    134       CALL dom_vvl_zgr(Kbb, Kmm, Kaa) ! interpolation scale factor, depth and water column 
     149      CALL dom_vvl_zgr_st(Kbb, Kmm, Kaa) ! interpolation scale factor, depth and water column 
    135150      ! 
    136151   END SUBROUTINE dom_vvl_init 
    … …  
    290305   END SUBROUTINE dom_vvl_zgr 
    291306 
     307    
     308   SUBROUTINE dom_vvl_zgr_st(Kbb, Kmm, Kaa) 
     309      !!---------------------------------------------------------------------- 
     310      !!                ***  ROUTINE dom_vvl_init  *** 
     311      !!                    
     312      !! ** Purpose :  Interpolation of all scale factors,  
     313      !!               depths and water column heights 
     314      !! 
     315      !! ** Method  :  - interpolate scale factors 
     316      !! 
     317      !! ** Action  : - e3t_(n/b) and tilde_e3t_(n/b) 
     318      !!              - Regrid: e3(u/v)_n 
     319      !!                        e3(u/v)_b        
     320      !!                        e3w_n            
     321      !!                        e3(u/v)w_b       
     322      !!                        e3(u/v)w_n       
     323      !!                        gdept_n, gdepw_n and gde3w_n 
     324      !!              - h(t/u/v)_0 
     325      !!              - frq_rst_e3t and frq_rst_hdv 
     326      !! 
     327      !! Reference  : Leclair, M., and G. Madec, 2011, Ocean Modelling. 
     328      !!---------------------------------------------------------------------- 
     329      INTEGER, INTENT(in) :: Kbb, Kmm, Kaa 
     330      !!---------------------------------------------------------------------- 
     331      INTEGER ::   ji, jj, jk 
     332      INTEGER ::   ii0, ii1, ij0, ij1 
     333      REAL(wp)::   zcoef 
     334      !!---------------------------------------------------------------------- 
     335      ! 
     336      !                    !== Set of all other vertical scale factors  ==!  (now and before) 
     337      !                                ! Horizontal interpolation of e3t 
     338      CALL dom_vvl_interpol_st( r3u(:,:,Kbb), e3u(:,:,:,Kbb), 'U' )    ! from T to U 
     339      CALL dom_vvl_interpol_st( r3u(:,:,Kmm), e3u(:,:,:,Kmm), 'U' ) 
     340      CALL dom_vvl_interpol_st( r3v(:,:,Kbb), e3v(:,:,:,Kbb), 'V' )    ! from T to V  
     341      CALL dom_vvl_interpol_st( r3v(:,:,Kmm), e3v(:,:,:,Kmm), 'V' ) 
     342      CALL dom_vvl_interpol_st( r3f(:,:), e3f(:,:,:), 'F' )    ! from U to F 
     343      !                                ! Vertical interpolation of e3t,u,v  
     344      CALL dom_vvl_interpol_st( r3t(:,:,Kmm), e3w (:,:,:,Kmm), 'W'  )  ! from T to W 
     345      CALL dom_vvl_interpol_st( r3t(:,:,Kbb), e3w (:,:,:,Kbb), 'W'  ) 
     346      CALL dom_vvl_interpol_st( r3u(:,:,Kmm), e3uw(:,:,:,Kmm), 'UW' )  ! from U to UW 
     347      CALL dom_vvl_interpol_st( r3u(:,:,Kbb), e3uw(:,:,:,Kbb), 'UW' ) 
     348      CALL dom_vvl_interpol_st( r3v(:,:,Kmm), e3vw(:,:,:,Kmm), 'VW' )  ! from V to UW 
     349      CALL dom_vvl_interpol_st( r3v(:,:,Kbb), e3vw(:,:,:,Kbb), 'VW' ) 
     350 
     351      ! We need to define e3[tuv]_a for AGRIF initialisation (should not be a problem for the restartability...) 
     352      e3t(:,:,:,Kaa) = e3t(:,:,:,Kmm) 
     353      e3u(:,:,:,Kaa) = e3u(:,:,:,Kmm) 
     354      e3v(:,:,:,Kaa) = e3v(:,:,:,Kmm) 
     355      ! 
     356      DO_3D_11_11( 1, jpk ) 
     357         gdepw(ji,jj,jk,Kmm) =  gdepw_0(ji,jj,jk) * (1._wp + r3t(ji,jj,Kmm)) 
     358         gdept(ji,jj,jk,Kmm) =  gdept_0(ji,jj,jk) * (1._wp + r3t(ji,jj,Kmm))  
     359         gde3w(ji,jj,jk    ) =  gdept(ji,jj,jk,Kmm) - ssh(ji,jj,Kmm) 
     360         gdepw(ji,jj,jk,Kbb) =  gdepw_0(ji,jj,jk) * (1._wp + r3t(ji,jj,Kbb)) 
     361         gdept(ji,jj,jk,Kbb) =  gdept_0(ji,jj,jk) * (1._wp + r3t(ji,jj,Kbb))  
     362      END_3D      
     363      ! 
     364      !                    !==  thickness of the water column  !!   (ocean portion only) 
     365      ht(:,:) = ht_0(:,:) + ssh(:,:,Kmm) 
     366      hu(:,:,Kbb) = (hu_0(:,:)*(1._wp+r3u(:,:,Kbb))) 
     367      hv(:,:,Kbb) = (hv_0(:,:)*(1._wp+r3v(:,:,Kbb))) 
     368      hu(:,:,Kbb) = (hu_0(:,:)*(1._wp+r3u(:,:,Kmm))) 
     369      hv(:,:,Kbb) = (hv_0(:,:)*(1._wp+r3v(:,:,Kmm))) 
     370      !                    !==  inverse of water column thickness   ==!   (u- and v- points) 
     371      r1_hu(:,:,Kbb) = ssumask(:,:) / ( hu(:,:,Kbb) + 1._wp - ssumask(:,:) )    ! _i mask due to ISF 
     372      r1_hu(:,:,Kmm) = ssumask(:,:) / ( hu(:,:,Kmm) + 1._wp - ssumask(:,:) ) 
     373      r1_hv(:,:,Kbb) = ssvmask(:,:) / ( hv(:,:,Kbb) + 1._wp - ssvmask(:,:) ) 
     374      r1_hv(:,:,Kmm) = ssvmask(:,:) / ( hv(:,:,Kmm) + 1._wp - ssvmask(:,:) )  
     375      ! 
     376      IF(lwxios) THEN 
     377! define variables in restart file when writing with XIOS 
     378         CALL iom_set_rstw_var_active('e3t_b') 
     379         CALL iom_set_rstw_var_active('e3t_n') 
     380         ! 
     381      ENDIF 
     382      ! 
     383   END SUBROUTINE dom_vvl_zgr_st 
     384    
    292385 
    293386   SUBROUTINE dom_vvl_sf_nxt( kt, Kbb, Kmm, Kaa, kcall )  
    … …  
    572665 
    573666 
     667 
     668   SUBROUTINE dom_vvl_sf_nxt_st( kt, Kbb, Kmm, Kaa, kcall )  
     669      !!---------------------------------------------------------------------- 
     670      !!                ***  ROUTINE dom_vvl_sf_nxt  *** 
     671      !!                    
     672      !! ** Purpose :  - compute the after scale factors used in tra_zdf, dynnxt, 
     673      !!                 tranxt and dynspg routines 
     674      !! 
     675      !! ** Method  :  - z_star case:  Repartition of ssh INCREMENT proportionnaly to the level thickness. 
     676      !!               - z_tilde_case: after scale factor increment =  
     677      !!                                    high frequency part of horizontal divergence 
     678      !!                                  + retsoring towards the background grid 
     679      !!                                  + thickness difusion 
     680      !!                               Then repartition of ssh INCREMENT proportionnaly 
     681      !!                               to the "baroclinic" level thickness. 
     682      !! 
     683      !! ** Action  :  - hdiv_lf    : restoring towards full baroclinic divergence in z_tilde case 
     684      !!               - tilde_e3t_a: after increment of vertical scale factor  
     685      !!                              in z_tilde case 
     686      !!               - e3(t/u/v)_a 
     687      !! 
     688      !! Reference  : Leclair, M., and Madec, G. 2011, Ocean Modelling. 
     689      !!---------------------------------------------------------------------- 
     690      INTEGER, INTENT( in )           ::   kt             ! time step 
     691      INTEGER, INTENT( in )           ::   Kbb, Kmm, Kaa  ! time step 
     692      INTEGER, INTENT( in ), OPTIONAL ::   kcall          ! optional argument indicating call sequence 
     693      ! 
     694      INTEGER                ::   ji, jj, jk            ! dummy loop indices 
     695      INTEGER , DIMENSION(3) ::   ijk_max, ijk_min      ! temporary integers 
     696      REAL(wp)               ::   z_tmin, z_tmax        ! local scalars 
     697      LOGICAL                ::   ll_do_bclinic         ! local logical 
     698      REAL(wp), DIMENSION(jpi,jpj)     ::   zht, z_scale, zwu, zwv, zhdiv 
     699      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   ze3t 
     700      !!---------------------------------------------------------------------- 
     701      ! 
     702      IF( ln_linssh )   RETURN      ! No calculation in linear free surface 
     703      ! 
     704      IF( ln_timing )   CALL timing_start('dom_vvl_sf_nxt') 
     705      ! 
     706      IF( kt == nit000 ) THEN 
     707         IF(lwp) WRITE(numout,*) 
     708         IF(lwp) WRITE(numout,*) 'dom_vvl_sf_nxt : compute after scale factors' 
     709         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~' 
     710      ENDIF 
     711 
     712      ll_do_bclinic = .TRUE. 
     713      IF( PRESENT(kcall) ) THEN 
     714         IF( kcall == 2 .AND. ln_vvl_ztilde )   ll_do_bclinic = .FALSE. 
     715      ENDIF 
     716 
     717      ! ******************************* ! 
     718      ! After acale factors at t-points ! 
     719      ! ******************************* ! 
     720      ! 
     721      DO jk = 1, jpkm1 
     722         e3t(:,:,jk,Kaa) = e3t_0(:,:,jk) * ( 1._wp + r3t(:,:,Kaa) ) 
     723         e3u(:,:,jk,Kaa) = e3u_0(:,:,jk) * ( 1._wp + r3u(:,:,Kaa) ) 
     724         e3v(:,:,jk,Kaa) = e3v_0(:,:,jk) * ( 1._wp + r3v(:,:,Kaa) ) 
     725      END DO 
     726      ! 
     727      ! *********************************** ! 
     728      ! After scale factors at u- v- points ! 
     729      ! *********************************** ! 
     730       
     731      !!st CALL dom_vvl_interpol_st( r3u(:,:,Kaa), e3u(:,:,:,Kaa), 'U' ) 
     732      !!st CALL dom_vvl_interpol_st( r3v(:,:,Kaa), e3v(:,:,:,Kaa), 'V' ) 
     733 
     734      ! *********************************** ! 
     735      ! After depths at u- v points         ! 
     736      ! *********************************** ! 
     737 
     738      !!st hu(:,:,Kaa) = e3u(:,:,1,Kaa) * umask(:,:,1) 
     739      !!st hv(:,:,Kaa) = e3v(:,:,1,Kaa) * vmask(:,:,1) 
     740      !!st DO jk = 2, jpkm1 
     741      !!st    hu(:,:,Kaa) = hu(:,:,Kaa) + e3u(:,:,jk,Kaa) * umask(:,:,jk) 
     742      !!st    hv(:,:,Kaa) = hv(:,:,Kaa) + e3v(:,:,jk,Kaa) * vmask(:,:,jk) 
     743      !!st     
     744      !!st END DO 
     745      hu(:,:,Kaa) = (hu_0(:,:)*(1._wp+r3u(:,:,Kaa))) 
     746      hv(:,:,Kaa) = (hv_0(:,:)*(1._wp+r3v(:,:,Kaa))) 
     747      !                                        ! Inverse of the local depth 
     748!!gm BUG ?  don't understand the use of umask_i here ..... 
     749      r1_hu(:,:,Kaa) = ssumask(:,:) / ( hu(:,:,Kaa) + 1._wp - ssumask(:,:) ) 
     750      r1_hv(:,:,Kaa) = ssvmask(:,:) / ( hv(:,:,Kaa) + 1._wp - ssvmask(:,:) ) 
     751      ! 
     752      IF( ln_timing )   CALL timing_stop('dom_vvl_sf_nxt') 
     753      ! 
     754   END SUBROUTINE dom_vvl_sf_nxt_st 
     755    
     756 
     757 
    574758   SUBROUTINE dom_vvl_sf_update( kt, Kbb, Kmm, Kaa ) 
    575759      !!---------------------------------------------------------------------- 
    … …  
    672856      ! 
    673857   END SUBROUTINE dom_vvl_sf_update 
    674  
     858    
     859 
     860   SUBROUTINE dom_vvl_sf_update_st( kt, Kbb, Kmm, Kaa ) 
     861      !!---------------------------------------------------------------------- 
     862      !!                ***  ROUTINE dom_vvl_sf_update  *** 
     863      !!                    
     864      !! ** Purpose :  for z tilde case: compute time filter and swap of scale factors  
     865      !!               compute all depths and related variables for next time step 
     866      !!               write outputs and restart file 
     867      !! 
     868      !! ** Method  :  - swap of e3t with trick for volume/tracer conservation (ONLY FOR Z TILDE CASE) 
     869      !!               - reconstruct scale factor at other grid points (interpolate) 
     870      !!               - recompute depths and water height fields 
     871      !! 
     872      !! ** Action  :  - tilde_e3t_(b/n) ready for next time step 
     873      !!               - Recompute: 
     874      !!                    e3(u/v)_b        
     875      !!                    e3w(:,:,:,Kmm)            
     876      !!                    e3(u/v)w_b       
     877      !!                    e3(u/v)w_n       
     878      !!                    gdept(:,:,:,Kmm), gdepw(:,:,:,Kmm)  and gde3w 
     879      !!                    h(u/v) and h(u/v)r 
     880      !! 
     881      !! Reference  : Leclair, M., and G. Madec, 2009, Ocean Modelling. 
     882      !!              Leclair, M., and G. Madec, 2011, Ocean Modelling. 
     883      !!---------------------------------------------------------------------- 
     884      INTEGER, INTENT( in ) ::   kt              ! time step 
     885      INTEGER, INTENT( in ) ::   Kbb, Kmm, Kaa   ! time level indices 
     886      ! 
     887      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
     888      REAL(wp) ::   zcoef        ! local scalar 
     889      !!---------------------------------------------------------------------- 
     890      ! 
     891      IF( ln_linssh )   RETURN      ! No calculation in linear free surface 
     892      ! 
     893      IF( ln_timing )   CALL timing_start('dom_vvl_sf_update') 
     894      ! 
     895      IF( kt == nit000 )   THEN 
     896         IF(lwp) WRITE(numout,*) 
     897         IF(lwp) WRITE(numout,*) 'dom_vvl_sf_update : - interpolate scale factors and compute depths for next time step' 
     898         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~~' 
     899      ENDIF 
     900      ! 
     901 
     902      ! Compute all missing vertical scale factor and depths 
     903      ! ==================================================== 
     904      ! Horizontal scale factor interpolations 
     905      ! -------------------------------------- 
     906      ! - ML - e3u(:,:,:,Kbb) and e3v(:,:,:,Kbb) are already computed in dynnxt 
     907      ! - JC - hu(:,:,:,Kbb), hv(:,:,:,:,Kbb), hur_b, hvr_b also 
     908       
     909      CALL dom_vvl_interpol_st( r3f(:,:), e3f(:,:,:), 'F'  ) 
     910 
     911      ! Vertical scale factor interpolations 
     912      CALL dom_vvl_interpol_st( r3t(:,:,Kmm),  e3w(:,:,:,Kmm), 'W'  ) 
     913      CALL dom_vvl_interpol_st( r3u(:,:,Kmm), e3uw(:,:,:,Kmm), 'UW' ) 
     914      CALL dom_vvl_interpol_st( r3v(:,:,Kmm), e3vw(:,:,:,Kmm), 'VW' ) 
     915      CALL dom_vvl_interpol_st( r3t(:,:,Kbb),  e3w(:,:,:,Kbb), 'W'  ) 
     916      CALL dom_vvl_interpol_st( r3u(:,:,Kbb), e3uw(:,:,:,Kbb), 'UW' ) 
     917      CALL dom_vvl_interpol_st( r3v(:,:,Kbb), e3vw(:,:,:,Kbb), 'VW' ) 
     918 
     919      ! t- and w- points depth (set the isf depth as it is in the initial step) 
     920      DO_3D_11_11( 1, jpk ) 
     921         gdepw(ji,jj,jk,Kmm) =  gdepw_0(ji,jj,jk) * (1._wp + r3t(ji,jj,Kmm)) 
     922         gdept(ji,jj,jk,Kmm) =  gdept_0(ji,jj,jk) * (1._wp + r3t(ji,jj,Kmm))  
     923         gde3w(ji,jj,jk    ) =  gdept(ji,jj,jk,Kmm) - ssh(ji,jj,Kmm) 
     924      END_3D 
     925 
     926      ! Local depth and Inverse of the local depth of the water 
     927      ! ------------------------------------------------------- 
     928      ! 
     929      ht(:,:) = ht_0(:,:) + ssh(:,:,Kmm) 
     930 
     931      ! write restart file 
     932      ! ================== 
     933      IF( lrst_oce  )   CALL dom_vvl_rst( kt, Kbb, Kmm, 'WRITE' ) 
     934      ! 
     935      IF( ln_timing )   CALL timing_stop('dom_vvl_sf_update') 
     936      ! 
     937   END SUBROUTINE dom_vvl_sf_update_st 
     938    
     939 
     940     
     941   SUBROUTINE dom_vvl_interpol_st( rc3, pe3, cdp ) 
     942      !!--------------------------------------------------------------------- 
     943      !!                  ***  ROUTINE dom_vvl__interpol  *** 
     944      !! 
     945      !! ** Purpose :   interpolate scale factors from one grid point to another 
     946      !! 
     947      !! ** Method  :   e3_out = e3_0 + interpolation(e3_in - e3_0) 
     948      !!                - horizontal interpolation: grid cell surface averaging 
     949      !!                - vertical interpolation: simple averaging 
     950      !!---------------------------------------------------------------------- 
     951      REAL(wp), DIMENSION(:,:)  , INTENT(in   ) ::   rc3     ! input e3   NOT used here (ssh is used instead) 
     952      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pe3     ! scale factor e3 to be updated   [m] 
     953      CHARACTER(LEN=*)          , INTENT(in   ) ::   cdp     ! grid point of the scale factor ( 'U', 'V', 'W, 'F', 'UW' or 'VW' ) 
     954      ! 
     955      INTEGER ::   ji, jj, jk                 ! dummy loop indices 
     956      REAL(wp), DIMENSION(jpi,jpj) ::   zc3   ! 2D workspace 
     957      !!---------------------------------------------------------------------- 
     958      ! 
     959      SELECT CASE ( cdp )     !==  type of interpolation  ==! 
     960         ! 
     961      CASE( 'U' )                   !* from T- to U-point : hor. surface weighted mean 
     962         DO jk = 1, jpkm1 
     963            pe3(:,:,jk) = e3u_0(:,:,jk) * ( 1.0_wp + rc3(:,:) ) 
     964         END DO 
     965         ! 
     966      CASE( 'V' )                   !* from T- to V-point : hor. surface weighted mean 
     967         DO jk = 1, jpkm1 
     968            pe3(:,:,jk) = e3v_0(:,:,jk) * ( 1.0_wp + rc3(:,:) ) 
     969         END DO 
     970         ! 
     971      CASE( 'F' )                   !* from U-point to F-point : hor. surface weighted mean 
     972         DO jk = 1, jpkm1                    ! Horizontal interpolation of e3f from ssh 
     973            e3f(:,:,jk) = e3f_0(:,:,jk) * ( 1._wp + rc3(:,:) ) 
     974         END DO 
     975         ! 
     976      CASE( 'W' )                   !* from T- to W-point : vertical simple mean 
     977         DO jk = 1, jpk 
     978            pe3(:,:,jk) = e3w_0(:,:,jk) * ( 1.0_wp + rc3(:,:) ) 
     979         END DO 
     980         ! 
     981      CASE( 'UW' )                  !* from U- to UW-point 
     982         DO jk = 1, jpk 
     983            pe3(:,:,jk) = e3uw_0(:,:,jk) * ( 1.0_wp + rc3(:,:) ) 
     984         END DO 
     985      CASE( 'VW' )                  !* from U- to UW-point : vertical simple mean 
     986         DO jk = 1, jpk 
     987            pe3(:,:,jk) = e3vw_0(:,:,jk) * ( 1.0_wp + rc3(:,:) ) 
     988         END DO 
     989         ! 
     990      END SELECT 
     991      ! 
     992   END SUBROUTINE dom_vvl_interpol_st 
     993    
    675994 
    676995   SUBROUTINE dom_vvl_interpol( pssh, pe3, cdp ) 
    … …  
    7231042               &                    + e1e2t(ji+1,jj+1) * pssh(ji+1,jj+1)  ) * r1_hf_0(ji,jj) * r1_e1e2f(ji,jj) 
    7241043         END_2D 
    725 !!an   dans le cas tourné, hf augmente et trend VOR diminue 
    726 !         DO_2D_10_10 
    727 !            zc3(ji,jj) =           (  e1e2t(ji  ,jj  ) * pssh(ji  ,jj  )  & 
    728 !               &                    + e1e2t(ji+1,jj  ) * pssh(ji+1,jj  )  & 
    729 !               &                    + e1e2t(ji  ,jj+1) * pssh(ji  ,jj+1)  & 
    730 !               &                    + e1e2t(ji+1,jj+1) * pssh(ji+1,jj+1)  ) * r1_hf_0(ji,jj) * r1_e1e2f(ji,jj) & 
    731 !               &           / MAX( tmask(ji,jj) + tmask(ji+1,jj) + tmask(ji,jj+1) + tmask(ji+1,jj+1), 1._wp )  
    732 !         END_2D 
    733           
    7341044         CALL lbc_lnk( 'domvvl', zc3(:,:), 'F', 1._wp ) 
    7351045         ! 
    … …  
    7711081      ! 
    7721082   END SUBROUTINE dom_vvl_interpol 
    773  
     1083    
    7741084 
    7751085   SUBROUTINE dom_vvl_rst( kt, Kbb, Kmm, cdrw ) 
    … …  
    10361346   END SUBROUTINE dom_vvl_ctl 
    10371347 
     1348#endif 
     1349!!stoops 
     1350 
    10381351   !!====================================================================== 
    10391352END MODULE domvvl 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/SWE/dynadv.F90

    r13005 r13151  
    7474      CASE( np_VEC_c2  )      
    7575         CALL dyn_keg     ( kt, nn_dynkeg,      Kmm, puu, pvv, Krhs )    ! vector form : horizontal gradient of kinetic energy 
    76 !!an SWE : w = 0 
    7776         CALL dyn_zad     ( kt,                 Kmm, puu, pvv, Krhs )    ! vector form : vertical advection 
    7877      CASE( np_FLX_c2  )  

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/SWE/dynatf.F90

    r12614 r13151  
    5858 
    5959   PUBLIC    dyn_atf   ! routine called by step.F90 
     60!!st22 
     61#if defined key_qco 
     62   !!---------------------------------------------------------------------- 
     63   !!   'key_qco'      EMPTY ROUTINE     Quasi-Eulerian vertical coordonate 
     64   !!---------------------------------------------------------------------- 
     65CONTAINS 
     66 
     67   SUBROUTINE dyn_atf ( kt, Kbb, Kmm, Kaa, puu, pvv, pe3t, pe3u, pe3v ) 
     68      INTEGER                             , INTENT(in   ) :: kt               ! ocean time-step index 
     69      INTEGER                             , INTENT(in   ) :: Kbb, Kmm, Kaa    ! before and after time level indices 
     70      REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv         ! velocities to be time filtered 
     71      REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: pe3t, pe3u, pe3v ! scale factors to be time filtered 
     72 
     73      WRITE(*,*) 'dyn_atf: You should not have seen this print! error?', kt 
     74   END SUBROUTINE dyn_atf 
     75 
     76#else 
    6077 
    6178   !! * Substitutions 
    … …  
    312329   END SUBROUTINE dyn_atf 
    313330 
     331#endif 
     332!!st22 
    314333   !!========================================================================= 
    315334END MODULE dynatf 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/SWE/dynkeg.F90

    r13005 r13151  
    2929 
    3030   PUBLIC   dyn_keg    ! routine called by step module 
    31    PUBLIC   dyn_kegAD   ! routine called by step module 
    3231    
    3332   INTEGER, PARAMETER, PUBLIC  ::   nkeg_C2     = 0   !: 2nd order centered scheme (standard scheme) 
    … …  
    156155      ! 
    157156   END SUBROUTINE dyn_keg 
    158     
    159     
    160    SUBROUTINE dyn_kegAD( kt, kscheme, puu, pvv, pu_rhs, pv_rhs ) 
    161       !!---------------------------------------------------------------------- 
    162       !!                  ***  ROUTINE dyn_kegAD  *** 
    163       !! 
    164       !! ** Purpose :   Compute the now momentum trend due to the horizontal 
    165       !!      gradient of the horizontal kinetic energy and add it to the  
    166       !!      general momentum trend. 
    167       !! 
    168       !! ** Method  : * kscheme = nkeg_C2 : 2nd order centered scheme that  
    169       !!      conserve kinetic energy. Compute the now horizontal kinetic energy  
    170       !!         zhke = 1/2 [ mi-1( un^2 ) + mj-1( vn^2 ) ] 
    171       !!              * kscheme = nkeg_HW : Hollingsworth correction following 
    172       !!      Arakawa (2001). The now horizontal kinetic energy is given by: 
    173       !!         zhke = 1/6 [ mi-1(  2 * un^2 + ((u(j+1)+u(j-1))/2)^2  ) 
    174       !!                    + mj-1(  2 * vn^2 + ((v(i+1)+v(i-1))/2)^2  ) ] 
    175       !!       
    176       !!      Take its horizontal gradient and add it to the general momentum 
    177       !!      trend. 
    178       !!         u(rhs) = u(rhs) - 1/e1u di[ zhke ] 
    179       !!         v(rhs) = v(rhs) - 1/e2v dj[ zhke ] 
    180       !! 
    181       !! ** Action : - Update the (puu(:,:,:,Krhs), pvv(:,:,:,Krhs)) with the hor. ke gradient trend 
    182       !!             - send this trends to trd_dyn (l_trddyn=T) for post-processing 
    183       !! 
    184       !! ** References : Arakawa, A., International Geophysics 2001. 
    185       !!                 Hollingsworth et al., Quart. J. Roy. Meteor. Soc., 1983. 
    186       !!---------------------------------------------------------------------- 
    187       ! 
    188       INTEGER                                  , INTENT( in )  ::  kt               ! ocean time-step index 
    189       INTEGER                                  , INTENT( in )  ::  kscheme          ! =0/1/2   type of KEG scheme  
    190       REAL(wp), DIMENSION(jpi,jpj,jpk)         , INTENT(inout) ::  puu, pvv         ! ocean velocities at Kmm 
    191       REAL(wp), DIMENSION(jpi,jpj,jpk),OPTIONAL, INTENT(inout) ::  pu_rhs, pv_rhs   ! RHS  
    192       ! 
    193       INTEGER  ::   ji, jj, jk             ! dummy loop indices 
    194       REAL(wp) ::   zu, zv                   ! local scalars 
    195       REAL(wp), DIMENSION(jpi,jpj,jpk)        ::   zhke 
    196       REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   ztrdu, ztrdv  
    197       !!---------------------------------------------------------------------- 
    198       ! 
    199       IF( ln_timing )   CALL timing_start('dyn_keg') 
    200       ! 
    201       IF( kt == nit000 ) THEN 
    202          IF(lwp) WRITE(numout,*) 
    203          IF(lwp) WRITE(numout,*) 'dyn_kegAD : kinetic energy gradient trend, scheme number=', kscheme 
    204          IF(lwp) WRITE(numout,*) '~~~~~~~~~' 
    205       ENDIF 
    206        
    207       zhke(:,:,jpk) = 0._wp 
    208157 
    209       SELECT CASE ( kscheme )             !== Horizontal kinetic energy at T-point  ==! 
    210 !!an45 to be ADDED : que cas C2 - "wet points only" il suffit de x2 le terme quadratic a la coast (nn_dynkeg_adv = 2) 
    211       CASE ( nkeg_C2_wpo )                          !--  Standard scheme  --! 
    212          DO_3D_01_01( 1, jpkm1 ) 
    213             zu =  (   puu(ji-1,jj  ,jk) * puu(ji-1,jj  ,jk)   & 
    214                &    + puu(ji  ,jj  ,jk) * puu(ji  ,jj  ,jk)   ) * ( 2._wp - umask(ji-1,jj,jk) * umask(ji,jj,jk) ) 
    215             zv =  (   pvv(ji  ,jj-1,jk) * pvv(ji  ,jj-1,jk)   & 
    216                &    + pvv(ji  ,jj  ,jk) * pvv(ji  ,jj  ,jk)   ) * ( 2._wp - vmask(ji,jj-1,jk) * vmask(ji,jj,jk) ) 
    217             zhke(ji,jj,jk) = 0.25_wp * ( zv + zu ) 
    218          END_3D 
    219 !!an45          
    220       ! 
    221       CASE ( nkeg_C2 )                          !--  Standard scheme  --! 
    222          DO_3D_01_01( 1, jpkm1 ) 
    223             zu =    puu(ji-1,jj  ,jk) * puu(ji-1,jj  ,jk)   & 
    224                &  + puu(ji  ,jj  ,jk) * puu(ji  ,jj  ,jk) 
    225             zv =    pvv(ji  ,jj-1,jk) * pvv(ji  ,jj-1,jk)   & 
    226                &  + pvv(ji  ,jj  ,jk) * pvv(ji  ,jj  ,jk) 
    227             zhke(ji,jj,jk) = 0.25_wp * ( zv + zu ) 
    228          END_3D 
    229 !!an 00_00 ? 
    230       CASE ( nkeg_HW )                          !--  Hollingsworth scheme  --! 
    231          DO_3D_00_00( 1, jpkm1 ) 
    232             zu = 8._wp * ( puu(ji-1,jj  ,jk) * puu(ji-1,jj  ,jk)    & 
    233                &         + puu(ji  ,jj  ,jk) * puu(ji  ,jj  ,jk) )  & 
    234                &   +     ( puu(ji-1,jj-1,jk) + puu(ji-1,jj+1,jk) ) * ( puu(ji-1,jj-1,jk) + puu(ji-1,jj+1,jk) )   & 
    235                &   +     ( puu(ji  ,jj-1,jk) + puu(ji  ,jj+1,jk) ) * ( puu(ji  ,jj-1,jk) + puu(ji  ,jj+1,jk) ) 
    236                ! 
    237             zv = 8._wp * ( pvv(ji  ,jj-1,jk) * pvv(ji  ,jj-1,jk)    & 
    238                &         + pvv(ji  ,jj  ,jk) * pvv(ji  ,jj  ,jk) )  & 
    239                &  +      ( pvv(ji-1,jj-1,jk) + pvv(ji+1,jj-1,jk) ) * ( pvv(ji-1,jj-1,jk) + pvv(ji+1,jj-1,jk) )   & 
    240                &  +      ( pvv(ji-1,jj  ,jk) + pvv(ji+1,jj  ,jk) ) * ( pvv(ji-1,jj  ,jk) + pvv(ji+1,jj  ,jk) ) 
    241             zhke(ji,jj,jk) = r1_48 * ( zv + zu ) 
    242          END_3D 
    243          CALL lbc_lnk( 'dynkeg', zhke, 'T', 1. ) 
    244          ! 
    245       END SELECT  
    246       ! 
    247          IF( PRESENT( pu_rhs ) .AND. PRESENT( pv_rhs ) ) THEN     !***  NO alternating direction  ***! 
    248             ! 
    249             DO_3D_00_00( 1, jpkm1 ) 
    250                pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) - ( zhke(ji+1,jj  ,jk) - zhke(ji,jj,jk) ) / e1u(ji,jj) 
    251                pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) - ( zhke(ji  ,jj+1,jk) - zhke(ji,jj,jk) ) / e2v(ji,jj) 
    252             END_3D 
    253             ! 
    254          ELSEIF(       PRESENT( pu_rhs ) .AND. .NOT. PRESENT( pv_rhs ) ) THEN            !***  Alternating direction : i-component  ***! 
    255             ! 
    256             DO_3D_00_00( 1, jpkm1 ) 
    257                pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) - ( zhke(ji+1,jj  ,jk) - zhke(ji,jj,jk) ) / e1u(ji,jj) 
    258             END_3D 
    259             ! 
    260          ELSEIF( .NOT. PRESENT( pu_rhs ) .AND.       PRESENT( pv_rhs ) ) THEN            !***  Alternating direction : j-component  ***! 
    261             ! 
    262             DO_3D_00_00( 1, jpkm1 ) 
    263                pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) - ( zhke(ji  ,jj+1,jk) - zhke(ji,jj,jk) ) / e2v(ji,jj) 
    264             END_3D 
    265             ! 
    266          ENDIF 
    267       IF( ln_timing )   CALL timing_stop('dyn_kegAD') 
    268       ! 
    269    END SUBROUTINE dyn_kegAD 
    270158   !!====================================================================== 
    271159END MODULE dynkeg 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/SWE/dynldf_lap_blp.F90

    r13005 r13151  
    2020   USE in_out_manager ! I/O manager 
    2121   USE lbclnk         ! ocean lateral boundary conditions (or mpp link) 
    22    USE lib_mpp        ! MPP library 
    23    ! 
    24    USE usrdef_nam , ONLY : nn_dynldf_lap_typ    ! use laplacian parameter 
    25    ! 
     22 
    2623   IMPLICIT NONE 
    2724   PRIVATE 
    … …  
    3431   INTEGER, PUBLIC, PARAMETER ::   np_dynldf_lap_symN = 3         ! symmetric laplacian (cartesian) 
    3532    
    36    !INTEGER, PUBLIC, PARAMETER ::   nn_dynldf_lap_typ = 1         ! choose type of laplacian (ideally from namelist) 
     33   INTEGER, PUBLIC, PARAMETER ::   ln_dynldf_lap_typ = 1         ! choose type of laplacian (ideally from namelist) 
    3734!!anSYM 
    3835   !! * Substitutions 
    3936#  include "do_loop_substitute.h90" 
     37!!st21 
     38#  include "domzgr_substitute.h90" 
    4039   !!---------------------------------------------------------------------- 
    4140   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    8079         WRITE(numout,*) 'dyn_ldf : iso-level harmonic (laplacian) operator, pass=', kpass 
    8180         WRITE(numout,*) '~~~~~~~ ' 
    82          WRITE(numout,*) '                  nn_dynldf_lap_typ = ', nn_dynldf_lap_typ 
    83          SELECT CASE( nn_dynldf_lap_typ )             ! print the choice of operator 
     81         WRITE(numout,*) '                  ln_dynldf_lap_typ = ', ln_dynldf_lap_typ 
     82         SELECT CASE( ln_dynldf_lap_typ )             ! print the choice of operator 
    8483         CASE( np_dynldf_lap_rot )   ;   WRITE(numout,*) '   ==>>>   div-rot   laplacian' 
    8584         CASE( np_dynldf_lap_sym )   ;   WRITE(numout,*) '   ==>>>   symmetric laplacian (covariant form)' 
    86          CASE( np_dynldf_lap_symN)   ;   WRITE(numout,*) '   ==>>>   symmetric laplacian (cartesian form)' 
     85         CASE( np_dynldf_lap_symN)   ;   WRITE(numout,*) '   ==>>>   symmetric laplacian (simple form)' 
    8786         END SELECT 
    8887      ENDIF 
    … …  
    9291      ENDIF 
    9392      ! 
    94       SELECT CASE( nn_dynldf_lap_typ )   
     93      SELECT CASE( ln_dynldf_lap_typ )   
    9594         !               
    9695         CASE ( np_dynldf_lap_rot )       !==  Vorticity-Divergence form  ==! 
    … …  
    102101!!gm open question here : e3f  at before or now ?    probably now...  
    103102!!gm note that ahmf has already been multiplied by fmask 
    104                   zcur(ji-1,jj-1) = ahmf(ji-1,jj-1,jk) * e3f(ji-1,jj-1,jk) * r1_e1e2f(ji-1,jj-1)       & 
    105                      &     * (  e2v(ji  ,jj-1) * pv(ji  ,jj-1,jk) - e2v(ji-1,jj-1) * pv(ji-1,jj-1,jk)  & 
    106                      &        - e1u(ji-1,jj  ) * pu(ji-1,jj  ,jk) + e1u(ji-1,jj-1) * pu(ji-1,jj-1,jk)  ) 
    107                   !                                      ! ahm * div        (computed from 2 to jpi/jpj) 
     103            zcur(ji-1,jj-1) =  & 
     104               &      ahmf(ji-1,jj-1,jk) * e3f(ji-1,jj-1,jk) * r1_e1e2f(ji-1,jj-1)      & 
     105               &  * (  e2v(ji  ,jj-1) * pv(ji  ,jj-1,jk) - e2v(ji-1,jj-1) * pv(ji-1,jj-1,jk)  & 
     106               &     - e1u(ji-1,jj  ) * pu(ji-1,jj  ,jk) + e1u(ji-1,jj-1) * pu(ji-1,jj-1,jk)  ) 
     107            !                                      ! ahm * div        (computed from 2 to jpi/jpj) 
    108108!!gm note that ahmt has already been multiplied by tmask 
    109109                  zdiv(ji,jj)     = ahmt(ji,jj,jk) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kbb)                                         & 
    … …  
    160160            END DO                                           !   End of slab 
    161161            ! 
    162          CASE ( np_dynldf_lap_symN )       !==  Symmetric form  ==!   (cartesian way) 
     162         CASE ( np_dynldf_lap_symN )       !==  Symmetric form  ==!   (naive way) 
    163163            ! 
    164164            DO jk = 1, jpkm1                                 ! Horizontal slab 
    … …  
    193193            !   
    194194         CASE DEFAULT                                     ! error 
    195             CALL ctl_stop('STOP','dyn_ldf_lap: wrong value for nn_dynldf_lap_typ'  ) 
     195            CALL ctl_stop('STOP','dyn_ldf_lap: wrong value for ln_dynldf_lap_typ'  ) 
    196196         END SELECT 
    197197         ! 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/SWE/dynvor.F90

    r13005 r13151  
    2222   !!             -   ! 2018-04  (G. Madec)  add pre-computed gradient for metric term calculation 
    2323   !!            4.x  ! 2020-03  (G. Madec, A. Nasser)  make ln_dynvor_msk truly efficient on relative vorticity 
    24    !!            4.x  ! 2020-03  (G. Madec, A. Nasser)  alternate direction computation of vorticity tendancy 
    25    !!                 !                                 for ENS, ENE 
    2624   !!---------------------------------------------------------------------- 
    2725 
    … …  
    4745   USE lib_mpp        ! MPP library 
    4846   USE timing         ! Timing 
    49 !!anAD only 
    50    USE dynkeg, ONLY : dyn_kegAD 
    51    USE dynadv, ONLY : nn_dynkeg 
    5247 
    5348   IMPLICIT NONE 
    … …  
    5853 
    5954   !                                   !!* Namelist namdyn_vor: vorticity term 
    60    LOGICAL, PUBLIC ::   ln_dynvor_ens      !: enstrophy conserving scheme          (ENS) 
    61    LOGICAL, PUBLIC ::   ln_dynvor_ens_adVO   = .FALSE.   !: AD enstrophy conserving scheme       (ENS_ad) 
    62    LOGICAL, PUBLIC ::   ln_dynvor_ens_adKE   = .FALSE.   !: AD enstrophy conserving scheme       (ENS_ad) 
    63    LOGICAL, PUBLIC ::   ln_dynvor_ens_adKEVO = .FALSE.   !: AD enstrophy conserving scheme       (ENS_ad) 
    64    LOGICAL, PUBLIC ::   ln_dynvor_ene      !: f-point energy conserving scheme     (ENE) 
    65    LOGICAL, PUBLIC ::   ln_dynvor_ene_adVO   = .FALSE.   !: f-point AD energy conserving scheme  (ENE_ad) 
    66    LOGICAL, PUBLIC ::   ln_dynvor_ene_adKE   = .FALSE.   !: f-point AD energy conserving scheme  (ENE_ad) 
    67    LOGICAL, PUBLIC ::   ln_dynvor_ene_adKEVO = .FALSE.   !: f-point AD energy conserving scheme  (ENE_ad) 
    68    LOGICAL, PUBLIC ::   ln_dynvor_enT      !: t-point energy conserving scheme     (ENT) 
    69    LOGICAL, PUBLIC ::   ln_dynvor_eeT      !: t-point energy conserving scheme     (EET) 
    70    LOGICAL, PUBLIC ::   ln_dynvor_een      !: energy & enstrophy conserving scheme (EEN) 
    71    INTEGER, PUBLIC ::      nn_een_e3f         !: e3f=masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) 
    72    LOGICAL, PUBLIC ::   ln_dynvor_mix      !: mixed scheme                         (MIX) 
    73    LOGICAL, PUBLIC ::   ln_dynvor_msk      !: vorticity multiplied by fmask (=T) or not (=F) (all vorticity schemes) 
     55   LOGICAL, PUBLIC ::   ln_dynvor_ens   !: enstrophy conserving scheme          (ENS) 
     56   LOGICAL, PUBLIC ::   ln_dynvor_ene   !: f-point energy conserving scheme     (ENE) 
     57   LOGICAL, PUBLIC ::   ln_dynvor_enT   !: t-point energy conserving scheme     (ENT) 
     58   LOGICAL, PUBLIC ::   ln_dynvor_eeT   !: t-point energy conserving scheme     (EET) 
     59   LOGICAL, PUBLIC ::   ln_dynvor_een   !: energy & enstrophy conserving scheme (EEN) 
     60   INTEGER, PUBLIC ::      nn_een_e3f      !: e3f=masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) 
     61   LOGICAL, PUBLIC ::   ln_dynvor_mix   !: mixed scheme                         (MIX) 
     62   LOGICAL, PUBLIC ::   ln_dynvor_msk   !: vorticity multiplied by fmask (=T) or not (=F) (all vorticity schemes) 
    7463 
    7564   INTEGER, PUBLIC ::   nvor_scheme     !: choice of the type of advection scheme 
    … …  
    8170   INTEGER, PUBLIC, PARAMETER ::   np_EEN = 4   ! EEN scheme 
    8271   INTEGER, PUBLIC, PARAMETER ::   np_MIX = 5   ! MIX scheme 
    83 !!an 
    84    INTEGER, PUBLIC, PARAMETER ::   np_ENS_adKE   = 11   ! ENS scheme - AD scheme (KE only) 
    85    INTEGER, PUBLIC, PARAMETER ::   np_ENS_adVO   = 12   ! ENS scheme - AD scheme (VOR only) 
    86    INTEGER, PUBLIC, PARAMETER ::   np_ENS_adKEVO = 13   ! ENS scheme - AD scheme (KE+VOR) 
    87    INTEGER, PUBLIC, PARAMETER ::   np_ENE_adKE   = 21   ! ENE scheme - AD scheme (KE only) 
    88    INTEGER, PUBLIC, PARAMETER ::   np_ENE_adVO   = 22   ! ENE scheme - AD scheme (VOR only) 
    89    INTEGER, PUBLIC, PARAMETER ::   np_ENE_adKEVO = 23   ! ENE scheme - AD scheme (KE+VOR) 
    90 !!an       
    91     
    92 !!an ds step on pourra spécifier la valeur de ntot = np_COR ou np_COR + np_RVO 
    93    INTEGER, PUBLIC ::   ncor, nrvm, ntot   ! choice of calculated vorticity  
     72 
     73   INTEGER ::   ncor, nrvm, ntot   ! choice of calculated vorticity  
    9474   !                               ! associated indices: 
    9575   INTEGER, PUBLIC, PARAMETER ::   np_COR = 1         ! Coriolis (planetary) 
    … …  
    11090   !! * Substitutions 
    11191#  include "do_loop_substitute.h90" 
     92!!st23 
     93#  include "domzgr_substitute.h90" 
    11294   !!---------------------------------------------------------------------- 
    11395   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    11799CONTAINS 
    118100 
    119    SUBROUTINE dyn_vor( kt, Kbb, Kmm, puu, pvv, Krhs) 
     101   SUBROUTINE dyn_vor( kt, Kmm, puu, pvv, Krhs ) 
    120102      !!---------------------------------------------------------------------- 
    121103      !! 
    … …  
    127109      !!               for futher diagnostics (l_trddyn=T) 
    128110      !!---------------------------------------------------------------------- 
    129       INTEGER ::   ji, jj, jk   ! dummy loop indice 
    130       INTEGER                             , INTENT( in  ) ::   kt               ! ocean time-step index 
    131       INTEGER                             , INTENT( in  ) ::   Kmm, Krhs, Kbb   ! ocean time level indices 
    132       REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) ::   puu, pvv         ! ocean velocity field and RHS of momentum equation 
     111      INTEGER                             , INTENT( in  ) ::   kt          ! ocean time-step index 
     112      INTEGER                             , INTENT( in  ) ::   Kmm, Krhs   ! ocean time level indices 
     113      REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) ::   puu, pvv    ! ocean velocity field and RHS of momentum equation 
    133114      ! 
    134115      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::  ztrdu, ztrdv 
    135       REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::  zuu, zvv 
    136116      !!---------------------------------------------------------------------- 
    137117      ! 
    … …  
    187167            IF( ln_stcor )   CALL vor_eeT( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! add the Stokes-Coriolis trend 
    188168         CASE( np_ENE )                        !* energy conserving scheme 
    189                              CALL dyn_kegAD( kt, nn_dynkeg, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pu_rhs=puu(:,:,:,Krhs), pv_rhs=pvv(:,:,:,Krhs) )   
    190                              CALL vor_ene(   kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! total vorticity trend 
     169                             CALL vor_ene( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! total vorticity trend 
    191170            IF( ln_stcor )   CALL vor_ene( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! add the Stokes-Coriolis trend 
    192              
    193          CASE( np_ENE_adVO )                     !* energy conserving scheme with alternating direction 
    194             IF( MOD( kt , 2 ) ==  1 ) THEN           ! even time step:  u-vor then v-vor components 
    195                                
    196                               !==  Alternative direction - VOR only  ==! 
    197  
    198                              CALL dyn_kegAD( kt, nn_dynkeg, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pu_rhs=puu(:,:,:,Krhs), pv_rhs=pvv(:,:,:,Krhs) )   ! compute and add uu-vorticity trend 
    199  
    200                              ALLOCATE( zuu(jpi,jpj,jpk) ) 
    201                              CALL vor_ene( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pu_rhs=puu(:,:,:,Krhs) )   ! compute and add uu-vorticity trend 
    202                              zuu(:,:,:) = puu(:,:,:,Kbb) + rDt * puu(:,:,:,Krhs) * umask(:,:,:) 
    203                              CALL lbc_lnk( 'dynvor', zuu(:,:,:) , 'U', -1._wp ) 
    204                              CALL vor_ene( kt, Kmm, ntot, zuu(:,:,:)     , pvv(:,:,:,Kmm) , pv_rhs=pvv(:,:,:,Krhs) )   ! compute and add vv-vorticity trend 
    205                              DEALLOCATE( zuu ) 
    206             ELSE 
    207                              CALL dyn_kegAD( kt, nn_dynkeg, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pu_rhs=puu(:,:,:,Krhs), pv_rhs=pvv(:,:,:,Krhs) )   ! compute and add uu-vorticity trend 
    208  
    209                              ALLOCATE( zvv(jpi,jpj,jpk) )  
    210                              CALL vor_ene( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pv_rhs=pvv(:,:,:,Krhs) )   ! compute and add vv-vorticity trend 
    211                              zvv(:,:,:) = pvv(:,:,:,Kbb) + rDt * pvv(:,:,:,Krhs) * vmask(:,:,:) 
    212                              CALL lbc_lnk( 'dynvor', zvv(:,:,:) , 'V', -1._wp ) 
    213                              CALL vor_ene( kt, Kmm, ntot, puu(:,:,:,Kmm), zvv(:,:,:) , pu_rhs=puu(:,:,:,Krhs) )   ! compute and add uu-vorticity trend 
    214                              DEALLOCATE( zvv ) 
    215             ENDIF 
    216             IF( ln_stcor )   CALL vor_ene( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! add the Stokes-Coriolis trend 
    217          CASE( np_ENE_adKE )                     !* energy conserving scheme with alternating direction 
    218             IF( MOD( kt , 2 ) ==  1 ) THEN           ! even time step:  u-vor then v-vor components 
    219                                   
    220                                  !==  Alternative direction - KEG only  ==! 
    221  
    222                              CALL vor_ene( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! total vorticity trend 
    223  
    224                              ALLOCATE( zuu(jpi,jpj,jpk) ) 
    225                              CALL dyn_kegAD( kt, nn_dynkeg, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pu_rhs=puu(:,:,:,Krhs) )   ! compute and add uu-vorticity trend 
    226                              zuu(:,:,:) = puu(:,:,:,Kbb) + rDt * puu(:,:,:,Krhs) * umask(:,:,:) 
    227                              CALL lbc_lnk( 'dynvor', zuu(:,:,:) , 'U', -1._wp ) 
    228                              CALL dyn_kegAD( kt, nn_dynkeg, zuu(:,:,:)     , pvv(:,:,:,Kmm) , pv_rhs=pvv(:,:,:,Krhs) )   ! compute and add vv-vorticity trend 
    229                              DEALLOCATE( zuu ) 
    230             ELSE 
    231  
    232                              CALL vor_ene( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! total vorticity trend                       
    233  
    234                              ALLOCATE( zvv(jpi,jpj,jpk) ) 
    235                              CALL dyn_kegAD( kt, nn_dynkeg, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pv_rhs=pvv(:,:,:,Krhs) )   ! compute and add vv-vorticity trend 
    236                              zvv(:,:,:) = pvv(:,:,:,Kbb) + rDt * pvv(:,:,:,Krhs) * vmask(:,:,:) 
    237                              CALL lbc_lnk( 'dynvor', zvv(:,:,:) , 'V', -1._wp ) 
    238                              CALL dyn_kegAD( kt, nn_dynkeg, puu(:,:,:,Kmm)  , zvv(:,:,:) , pu_rhs=puu(:,:,:,Krhs) )   ! compute and add uu-vorticity trend 
    239                              DEALLOCATE( zvv ) 
    240             ENDIF 
    241             IF( ln_stcor )   CALL vor_ene( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! add the Stokes-Coriolis trend 
    242              
    243          CASE( np_ENE_adKEVO )                     !* energy conserving scheme with alternating direction 
    244             IF( MOD( kt , 2 ) ==  1 ) THEN           ! even time step:  u-vor then v-vor components 
    245                                
    246                               !==  Alternative direction - KE + VOR  ==! 
    247  
    248                              ALLOCATE( zuu(jpi,jpj,jpk) ) 
    249                              CALL vor_ene(   kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pu_rhs=puu(:,:,:,Krhs) )   ! compute and add uu-vorticity trend 
    250                              CALL dyn_kegAD( kt, nn_dynkeg, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pu_rhs=puu(:,:,:,Krhs) )   !  
    251                              zuu(:,:,:) = puu(:,:,:,Kbb) + rDt * puu(:,:,:,Krhs) * umask(:,:,:) 
    252                              CALL lbc_lnk( 'dynvor', zuu(:,:,:) , 'U', -1._wp ) 
    253                              CALL vor_ene(   kt, Kmm, ntot, zuu(:,:,:) , pvv(:,:,:,Kmm) , pv_rhs=pvv(:,:,:,Krhs) )   ! compute and add vv-vorticity trend 
    254                              CALL dyn_kegAD( kt, nn_dynkeg, zuu(:,:,:) , pvv(:,:,:,Kmm) , pv_rhs=pvv(:,:,:,Krhs) )    
    255                              DEALLOCATE( zuu ) 
    256             ELSE 
    257  
    258                              ALLOCATE( zvv(jpi,jpj,jpk) )  
    259                              CALL vor_ene(   kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pv_rhs=pvv(:,:,:,Krhs) )   ! compute and add vv-vorticity trend 
    260                              CALL dyn_kegAD( kt, nn_dynkeg, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pv_rhs=pvv(:,:,:,Krhs) )    
    261                              zvv(:,:,:) = pvv(:,:,:,Kbb) + rDt * pvv(:,:,:,Krhs) * vmask(:,:,:) 
    262                              CALL lbc_lnk( 'dynvor', zvv(:,:,:) , 'V', -1._wp ) 
    263                              CALL vor_ene(   kt, Kmm, ntot, puu(:,:,:,Kmm), zvv(:,:,:) , pu_rhs=puu(:,:,:,Krhs) )   ! compute and add uu-vorticity trend 
    264                              CALL dyn_kegAD( kt, nn_dynkeg, puu(:,:,:,Kmm), zvv(:,:,:) , pu_rhs=puu(:,:,:,Krhs) )    
    265                              DEALLOCATE( zvv ) 
    266             ENDIF    
    267171         CASE( np_ENS )                        !* enstrophy conserving scheme 
    268                              CALL dyn_kegAD( kt, nn_dynkeg, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pu_rhs=puu(:,:,:,Krhs), pv_rhs=pvv(:,:,:,Krhs) )   
    269                              CALL vor_ens(   kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )  ! total vorticity trend 
    270             IF( ln_stcor )   CALL vor_ens( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )  ! add the Stokes-Coriolis trend 
    271          CASE( np_ENS_adVO )                     !* enstrophy conserving scheme with alternating direction 
    272             IF( MOD( kt , 2 ) ==  1 ) THEN           ! even time step:  u-vor then v-vor components 
    273     
    274                                  !==  Alternative direction - VOR only  ==! 
    275  
    276                              CALL dyn_kegAD( kt, nn_dynkeg, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pu_rhs=puu(:,:,:,Krhs), pv_rhs=pvv(:,:,:,Krhs) )   
    277  
    278                              ALLOCATE( zuu(jpi,jpj,jpk) ) 
    279                              CALL vor_ens( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pu_rhs=puu(:,:,:,Krhs) )   ! compute and add uu-vorticity trend 
    280                              zuu(:,:,:) = puu(:,:,:,Kbb) + rDt * puu(:,:,:,Krhs) * umask(:,:,:) 
    281                              CALL lbc_lnk( 'dynvor', zuu(:,:,:) , 'U', -1._wp ) 
    282                              CALL vor_ens( kt, Kmm, ntot, zuu(:,:,:)     , pvv(:,:,:,Kmm) , pv_rhs=pvv(:,:,:,Krhs) )   ! compute and add vv-vorticity trend 
    283                              DEALLOCATE( zuu ) 
    284             ELSE 
    285                              CALL dyn_kegAD( kt, nn_dynkeg, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pu_rhs=puu(:,:,:,Krhs), pv_rhs=pvv(:,:,:,Krhs) ) 
    286  
    287                              ALLOCATE( zvv(jpi,jpj,jpk) ) 
    288                              CALL vor_ens( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pv_rhs=pvv(:,:,:,Krhs) )   ! compute and add vv-vorticity trend 
    289                              zvv(:,:,:) = pvv(:,:,:,Kbb) + rDt * pvv(:,:,:,Krhs) * vmask(:,:,:) 
    290                              CALL lbc_lnk( 'dynvor', zvv(:,:,:) , 'V', -1._wp ) 
    291                              CALL vor_ens( kt, Kmm, ntot, puu(:,:,:,Kmm) , zvv(:,:,:), pu_rhs=puu(:,:,:,Krhs) )   ! compute and add uu-vorticity trend 
    292                              DEALLOCATE( zvv ) 
    293             ENDIF 
    294             IF( ln_stcor )   CALL vor_ens( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )  ! add the Stokes-Coriolis trend 
    295          CASE( np_ENS_adKE )                     !* enstrophy conserving scheme with alternating direction 
    296             IF( MOD( kt , 2 ) ==  1 ) THEN           ! even time step:  u-vor then v-vor components 
    297              
    298                                 !==  Alternative direction - KEG only  ==! 
    299  
    300172                             CALL vor_ens( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )  ! total vorticity trend 
    301  
    302                              ALLOCATE( zuu(jpi,jpj,jpk) ) 
    303                              CALL dyn_kegAD( kt, nn_dynkeg, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pu_rhs=puu(:,:,:,Krhs) )   ! compute and add uu-vorticity trend 
    304                              zuu(:,:,:) = puu(:,:,:,Kbb) + rDt * puu(:,:,:,Krhs) * umask(:,:,:) 
    305                              CALL lbc_lnk( 'dynvor', zuu(:,:,:) , 'U', -1._wp ) 
    306                              CALL dyn_kegAD( kt, nn_dynkeg, zuu(:,:,:)     , pvv(:,:,:,Kmm) , pv_rhs=pvv(:,:,:,Krhs) )   ! compute and add vv-vorticity trend 
    307                              DEALLOCATE( zuu ) 
    308             ELSE 
    309  
    310                              CALL vor_ens( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )  ! total vorticity trend                                                           
    311  
    312                              ALLOCATE( zvv(jpi,jpj,jpk) ) 
    313                              CALL dyn_kegAD( kt, nn_dynkeg, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pv_rhs=pvv(:,:,:,Krhs) )   ! compute and add vv-vorticity trend 
    314                              zvv(:,:,:) = pvv(:,:,:,Kbb) + rDt * pvv(:,:,:,Krhs) * vmask(:,:,:) 
    315                              CALL lbc_lnk( 'dynvor', zvv(:,:,:) , 'V', -1._wp ) 
    316                              CALL dyn_kegAD( kt, nn_dynkeg, puu(:,:,:,Kmm) , zvv(:,:,:)  , pu_rhs=puu(:,:,:,Krhs) )   ! compute and add uu-vorticity trend 
    317                              DEALLOCATE( zvv ) 
    318             ENDIF 
    319          CASE( np_ENS_adKEVO )                     !* enstrophy conserving scheme with alternating direction 
    320             IF( MOD( kt , 2 ) ==  1 ) THEN           ! even time step:  u-vor then v-vor components 
    321                                
    322                               !==  Alternative direction - KE + VOR  ==! 
    323  
    324                              ALLOCATE( zuu(jpi,jpj,jpk) ) 
    325                              CALL vor_ens(   kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pu_rhs=puu(:,:,:,Krhs) )   ! compute and add uu-vorticity trend 
    326                              CALL dyn_kegAD( kt, nn_dynkeg, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pu_rhs=puu(:,:,:,Krhs) )   !  
    327                              zuu(:,:,:) = puu(:,:,:,Kbb) + rDt * puu(:,:,:,Krhs) * umask(:,:,:) 
    328                              CALL lbc_lnk( 'dynvor', zuu(:,:,:) , 'U', -1._wp ) 
    329                              CALL vor_ens(   kt, Kmm, ntot, zuu(:,:,:) , pvv(:,:,:,Kmm) , pv_rhs=pvv(:,:,:,Krhs) )   ! compute and add vv-vorticity trend 
    330                              CALL dyn_kegAD( kt, nn_dynkeg, zuu(:,:,:) , pvv(:,:,:,Kmm) , pv_rhs=pvv(:,:,:,Krhs) )    
    331                              DEALLOCATE( zuu ) 
    332             ELSE 
    333  
    334                              ALLOCATE( zvv(jpi,jpj,jpk) )  
    335                              CALL vor_ens(   kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pv_rhs=pvv(:,:,:,Krhs) )   ! compute and add vv-vorticity trend 
    336                              CALL dyn_kegAD( kt, nn_dynkeg, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pv_rhs=pvv(:,:,:,Krhs) )    
    337                              zvv(:,:,:) = pvv(:,:,:,Kbb) + rDt * pvv(:,:,:,Krhs) * vmask(:,:,:) 
    338                              CALL lbc_lnk( 'dynvor', zvv(:,:,:) , 'V', -1._wp ) 
    339                              CALL vor_ens(   kt, Kmm, ntot, puu(:,:,:,Kmm), zvv(:,:,:) , pu_rhs=puu(:,:,:,Krhs) )   ! compute and add uu-vorticity trend 
    340                              CALL dyn_kegAD( kt, nn_dynkeg, puu(:,:,:,Kmm), zvv(:,:,:) , pu_rhs=puu(:,:,:,Krhs) )    
    341                              DEALLOCATE( zvv ) 
    342             ENDIF    
    343173            IF( ln_stcor )   CALL vor_ens( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )  ! add the Stokes-Coriolis trend 
    344174         CASE( np_MIX )                        !* mixed ene-ens scheme 
    … …  
    427257            DO_2D_01_01 
    428258               zwt(ji,jj) = r1_4 * (   zwz(ji-1,jj  ,jk) + zwz(ji,jj  ,jk)   & 
    429                   &                  + zwz(ji-1,jj-1,jk) + zwz(ji,jj-1,jk) ) * e1e2t(ji,jj)*e3t(ji,jj,jk,Kmm) 
     259                  &                  + zwz(ji-1,jj-1,jk) + zwz(ji,jj-1,jk) ) & 
     260                  &                * e1e2t(ji,jj)*e3t(ji,jj,jk,Kmm) 
    430261            END_2D 
    431262         CASE ( np_MET )                           !* metric term 
    432263            DO_2D_01_01 
    433                zwt(ji,jj) = (   ( pv(ji,jj,jk) + pv(ji,jj-1,jk) ) * di_e2u_2(ji,jj)   & 
    434                   &           - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj)   ) * e3t(ji,jj,jk,Kmm) 
     264               zwt(ji,jj) = (   ( pv(ji,jj,jk) + pv(ji,jj-1,jk) ) * di_e2u_2(ji,jj)     & 
     265                  &           - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj)   ) & 
     266                  &         * e3t(ji,jj,jk,Kmm) 
    435267            END_2D 
    436268         CASE ( np_CRV )                           !* Coriolis + relative vorticity 
    437269            DO_2D_01_01 
    438                zwt(ji,jj) = (  ff_t(ji,jj) + r1_4 * ( zwz(ji-1,jj  ,jk) + zwz(ji,jj  ,jk)    & 
    439                   &                                 + zwz(ji-1,jj-1,jk) + zwz(ji,jj-1,jk) )  ) * e1e2t(ji,jj)*e3t(ji,jj,jk,Kmm) 
     270               zwt(ji,jj) = (  ff_t(ji,jj) + r1_4 * ( zwz(ji-1,jj  ,jk) + zwz(ji,jj  ,jk)      & 
     271                  &                                 + zwz(ji-1,jj-1,jk) + zwz(ji,jj-1,jk) )  ) & 
     272                  &         * e1e2t(ji,jj)*e3t(ji,jj,jk,Kmm) 
    440273            END_2D 
    441274         CASE ( np_CME )                           !* Coriolis + metric 
    442275            DO_2D_01_01 
    443                zwt(ji,jj) = (  ff_t(ji,jj) * e1e2t(ji,jj)                           & 
    444                     &        + ( pv(ji,jj,jk) + pv(ji,jj-1,jk) ) * di_e2u_2(ji,jj)  & 
    445                     &        - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj)  ) * e3t(ji,jj,jk,Kmm) 
     276               zwt(ji,jj) = (  ff_t(ji,jj) * e1e2t(ji,jj)                             & 
     277                    &        + ( pv(ji,jj,jk) + pv(ji,jj-1,jk) ) * di_e2u_2(ji,jj)    & 
     278                    &        - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj)  ) & 
     279                    &       * e3t(ji,jj,jk,Kmm) 
    446280            END_2D 
    447281         CASE DEFAULT                                             ! error 
    … …  
    485319      !! References : Sadourny, r., 1975, j. atmos. sciences, 32, 680-689. 
    486320      !!---------------------------------------------------------------------- 
    487       INTEGER                                  , INTENT(in   ) ::   kt          ! ocean time-step index 
    488       INTEGER                                  , INTENT(in   ) ::   Kmm              ! ocean time level index 
    489       INTEGER                                  , INTENT(in   ) ::   kvor        ! total, planetary, relative, or metric 
    490       REAL(wp), DIMENSION(jpi,jpj,jpk)         , INTENT(inout) ::   pu, pv    ! now velocities 
    491       REAL(wp), DIMENSION(jpi,jpj,jpk),OPTIONAL, INTENT(inout) ::   pu_rhs, pv_rhs    ! total v-trend 
     321      INTEGER                         , INTENT(in   ) ::   kt          ! ocean time-step index 
     322      INTEGER                         , INTENT(in   ) ::   Kmm              ! ocean time level index 
     323      INTEGER                         , INTENT(in   ) ::   kvor        ! total, planetary, relative, or metric 
     324      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pu, pv    ! now velocities 
     325      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pu_rhs, pv_rhs    ! total v-trend 
    492326      ! 
    493327      INTEGER  ::   ji, jj, jk           ! dummy loop indices 
    … …  
    543377         END SELECT 
    544378         ! 
    545          IF( PRESENT( pu_rhs ) .AND. PRESENT( pv_rhs ) ) THEN     !***  NO alternating direction  ***! 
    546             ! 
    547             !                                   !==  horizontal fluxes and potential vorticity ==! 
    548             zwx(:,:) = e2u(:,:) * e3u(:,:,jk,Kmm) * pu(:,:,jk) 
    549             zwy(:,:) = e1v(:,:) * e3v(:,:,jk,Kmm) * pv(:,:,jk) 
    550             zwz(:,:) = zwz(:,:) / e3f(:,:,jk) 
    551             ! 
    552             !                                   !==  compute and add the vorticity term trend  =! 
    553             DO_2D_00_00 
    554                zy1 = zwy(ji,jj-1) + zwy(ji+1,jj-1) 
    555                zy2 = zwy(ji,jj  ) + zwy(ji+1,jj  ) 
    556                zx1 = zwx(ji-1,jj) + zwx(ji-1,jj+1) 
    557                zx2 = zwx(ji  ,jj) + zwx(ji  ,jj+1) 
    558                pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + r1_4 * r1_e1u(ji,jj) * ( zwz(ji  ,jj-1) * zy1 + zwz(ji,jj) * zy2 ) 
    559                pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) - r1_4 * r1_e2v(ji,jj) * ( zwz(ji-1,jj  ) * zx1 + zwz(ji,jj) * zx2 )  
    560             END_2D 
    561             !             
    562             ! 
    563          ELSEIF(       PRESENT( pu_rhs ) .AND. .NOT. PRESENT( pv_rhs ) ) THEN            !***  Alternating direction : i-component  ***! 
    564             ! 
    565             ! 
    566             !                                   !==  horizontal fluxes and potential vorticity ==! 
    567             zwy(:,:) = e1v(:,:) * e3v(:,:,jk,Kmm) * pv(:,:,jk) 
    568             zwz(:,:) = zwz(:,:) / e3f(:,:,jk) 
    569             ! 
    570             !                                   !==  compute and add the vorticity term trend  =! 
    571             DO_2D_00_00 
    572                zy1 = zwy(ji,jj-1) + zwy(ji+1,jj-1) 
    573                zy2 = zwy(ji,jj  ) + zwy(ji+1,jj  ) 
    574                pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + r1_4 * r1_e1u(ji,jj) * ( zwz(ji  ,jj-1) * zy1 + zwz(ji,jj) * zy2 ) 
    575             END_2D 
    576             ! 
    577          ELSEIF( .NOT. PRESENT( pu_rhs ) .AND.       PRESENT( pv_rhs ) ) THEN            !***  Alternating direction : j-component  ***! 
    578             ! 
    579             ! 
    580             !                                   !==  horizontal fluxes and potential vorticity ==! 
    581             zwx(:,:) = e2u(:,:) * e3u(:,:,jk,Kmm) * pu(:,:,jk) 
    582             zwz(:,:) = zwz(:,:) / e3f(:,:,jk) 
    583             ! 
    584             !                                   !==  compute and add the vorticity term trend  =! 
    585             DO_2D_00_00 
    586                zx1 = zwx(ji-1,jj) + zwx(ji-1,jj+1) 
    587                zx2 = zwx(ji  ,jj) + zwx(ji  ,jj+1) 
    588                pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) - r1_4 * r1_e2v(ji,jj) * ( zwz(ji-1,jj  ) * zx1 + zwz(ji,jj) * zx2 )  
    589             END_2D 
    590             ! 
    591          ENDIF 
     379         !                                   !==  horizontal fluxes and potential vorticity ==! 
     380         zwx(:,:) = e2u(:,:) * e3u(:,:,jk,Kmm) * pu(:,:,jk) 
     381         zwy(:,:) = e1v(:,:) * e3v(:,:,jk,Kmm) * pv(:,:,jk) 
     382         zwz(:,:) = zwz(:,:) / e3f(:,:,jk) 
     383         ! 
     384         !                                   !==  compute and add the vorticity term trend  =! 
     385         DO_2D_00_00 
     386            zy1 = zwy(ji,jj-1) + zwy(ji+1,jj-1) 
     387            zy2 = zwy(ji,jj  ) + zwy(ji+1,jj  ) 
     388            zx1 = zwx(ji-1,jj) + zwx(ji-1,jj+1) 
     389            zx2 = zwx(ji  ,jj) + zwx(ji  ,jj+1) 
     390            pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + r1_4 * r1_e1u(ji,jj) * ( zwz(ji  ,jj-1) * zy1 + zwz(ji,jj) * zy2 ) 
     391            pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) - r1_4 * r1_e2v(ji,jj) * ( zwz(ji-1,jj  ) * zx1 + zwz(ji,jj) * zx2 )  
     392         END_2D 
    592393         !                                             ! =============== 
    593394      END DO                                           !   End of slab 
    … …  
    616417      !! References : Sadourny, r., 1975, j. atmos. sciences, 32, 680-689. 
    617418      !!---------------------------------------------------------------------- 
    618       INTEGER                                  , INTENT(in   ) ::   kt          ! ocean time-step index 
    619       INTEGER                                  , INTENT(in   ) ::   Kmm              ! ocean time level index 
    620       INTEGER                                  , INTENT(in   ) ::   kvor        ! total, planetary, relative, or metric 
    621       REAL(wp), DIMENSION(jpi,jpj,jpk)         , INTENT(inout) ::   pu, pv    ! now velocities 
    622       REAL(wp), DIMENSION(jpi,jpj,jpk),OPTIONAL, INTENT(inout) ::   pu_rhs, pv_rhs    ! total v-trend 
     419      INTEGER                         , INTENT(in   ) ::   kt          ! ocean time-step index 
     420      INTEGER                         , INTENT(in   ) ::   Kmm              ! ocean time level index 
     421      INTEGER                         , INTENT(in   ) ::   kvor        ! total, planetary, relative, or metric 
     422      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pu, pv    ! now velocities 
     423      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pu_rhs, pv_rhs    ! total v-trend 
    623424      ! 
    624425      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    … …  
    674475         ! 
    675476         ! 
    676 !!an wut ? v et u  
    677          IF( PRESENT( pu_rhs ) .AND. PRESENT( pv_rhs ) ) THEN     !***  NO alternating direction  ***! 
    678             ! 
    679             !                                   !==  horizontal fluxes and potential vorticity ==! 
    680             zwx(:,:) = e2u(:,:) * e3u(:,:,jk,Kmm) * pu(:,:,jk) 
    681             zwy(:,:) = e1v(:,:) * e3v(:,:,jk,Kmm) * pv(:,:,jk) 
    682             zwz(:,:) = zwz(:,:) / e3f(:,:,jk) 
    683             ! 
    684             !                                   !==  compute and add the vorticity term trend  =! 
    685             DO_2D_00_00 
    686                zuav = r1_8 * r1_e1u(ji,jj) * (  zwy(ji  ,jj-1) + zwy(ji+1,jj-1)  & 
    687                   &                           + zwy(ji  ,jj  ) + zwy(ji+1,jj  )  ) 
    688                zvau =-r1_8 * r1_e2v(ji,jj) * (  zwx(ji-1,jj  ) + zwx(ji-1,jj+1)  & 
    689                   &                           + zwx(ji  ,jj  ) + zwx(ji  ,jj+1)  ) 
    690                pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zuav * ( zwz(ji  ,jj-1) + zwz(ji,jj) ) 
    691                pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zvau * ( zwz(ji-1,jj  ) + zwz(ji,jj) ) 
    692             END_2D 
    693             ! 
    694          ELSEIF(       PRESENT( pu_rhs ) .AND. .NOT. PRESENT( pv_rhs ) ) THEN            !***  Alternating direction : i-component  ***! 
    695             ! 
    696             ! 
    697             !                                   !==  horizontal fluxes and potential vorticity ==! 
    698             zwy(:,:) = e1v(:,:) * e3v(:,:,jk,Kmm) * pv(:,:,jk) 
    699             zwz(:,:) = zwz(:,:) / e3f(:,:,jk) 
    700             ! 
    701             !                                   !==  compute and add the vorticity term trend  =! 
    702             DO_2D_00_00 
    703                zuav = r1_8 * r1_e1u(ji,jj) * (  zwy(ji  ,jj-1) + zwy(ji+1,jj-1)  & 
    704                   &                           + zwy(ji  ,jj  ) + zwy(ji+1,jj  )  ) 
    705                pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zuav * ( zwz(ji  ,jj-1) + zwz(ji,jj) ) 
    706             END_2D 
    707             ! 
    708          ELSEIF( .NOT. PRESENT( pu_rhs ) .AND.       PRESENT( pv_rhs ) ) THEN            !***  Alternating direction : j-component  ***! 
    709             ! 
    710             ! 
    711             !                                   !==  horizontal fluxes and potential vorticity ==! 
    712             zwx(:,:) = e2u(:,:) * e3u(:,:,jk,Kmm) * pu(:,:,jk) 
    713             zwz(:,:) = zwz(:,:) / e3f(:,:,jk) 
    714             ! 
    715             !                                   !==  compute and add the vorticity term trend  =! 
    716             DO_2D_00_00 
    717                zvau =-r1_8 * r1_e2v(ji,jj) * (  zwx(ji-1,jj  ) + zwx(ji-1,jj+1)  & 
    718                   &                           + zwx(ji  ,jj  ) + zwx(ji  ,jj+1)  ) 
    719                pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zvau * ( zwz(ji-1,jj  ) + zwz(ji,jj) ) 
    720             END_2D 
    721             ! 
    722          ENDIF 
     477         !                                   !==  horizontal fluxes and potential vorticity ==! 
     478         zwx(:,:) = e2u(:,:) * e3u(:,:,jk,Kmm) * pu(:,:,jk) 
     479         zwy(:,:) = e1v(:,:) * e3v(:,:,jk,Kmm) * pv(:,:,jk) 
     480         zwz(:,:) = zwz(:,:) / e3f(:,:,jk) 
     481         ! 
     482         !                                   !==  compute and add the vorticity term trend  =! 
     483         DO_2D_00_00 
     484            zuav = r1_8 * r1_e1u(ji,jj) * (  zwy(ji  ,jj-1) + zwy(ji+1,jj-1)  & 
     485               &                           + zwy(ji  ,jj  ) + zwy(ji+1,jj  )  ) 
     486            zvau =-r1_8 * r1_e2v(ji,jj) * (  zwx(ji-1,jj  ) + zwx(ji-1,jj+1)  & 
     487               &                           + zwx(ji  ,jj  ) + zwx(ji  ,jj+1)  ) 
     488            pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zuav * ( zwz(ji  ,jj-1) + zwz(ji,jj) ) 
     489            pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zvau * ( zwz(ji-1,jj  ) + zwz(ji,jj) ) 
     490         END_2D 
    723491         !                                             ! =============== 
    724492      END DO                                           !   End of slab 
    … …  
    772540         CASE ( 0 )                                   ! original formulation  (masked averaging of e3t divided by 4) 
    773541            DO_2D_10_10 
    774                ze3f = (  e3t(ji,jj+1,jk,Kmm)*tmask(ji,jj+1,jk) + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk)   & 
    775                   &    + e3t(ji,jj  ,jk,Kmm)*tmask(ji,jj  ,jk) + e3t(ji+1,jj  ,jk,Kmm)*tmask(ji+1,jj  ,jk)  ) 
     542               ze3f = (  e3t(ji  ,jj+1,jk,Kmm)*tmask(ji  ,jj+1,jk)   & 
     543                  &    + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk)   & 
     544                  &    + e3t(ji  ,jj  ,jk,Kmm)*tmask(ji  ,jj  ,jk)   & 
     545                  &    + e3t(ji+1,jj  ,jk,Kmm)*tmask(ji+1,jj  ,jk)  ) 
    776546               IF( ze3f /= 0._wp ) THEN   ;   z1_e3f(ji,jj) = 4._wp / ze3f 
    777547               ELSE                       ;   z1_e3f(ji,jj) = 0._wp 
    … …  
    780550         CASE ( 1 )                                   ! new formulation  (masked averaging of e3t divided by the sum of mask) 
    781551            DO_2D_10_10 
    782                ze3f = (  e3t(ji,jj+1,jk,Kmm)*tmask(ji,jj+1,jk) + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk)   & 
    783                   &    + e3t(ji,jj  ,jk,Kmm)*tmask(ji,jj  ,jk) + e3t(ji+1,jj  ,jk,Kmm)*tmask(ji+1,jj  ,jk)  ) 
     552               ze3f = (  e3t(ji  ,jj+1,jk,Kmm)*tmask(ji  ,jj+1,jk)   & 
     553                  &    + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk)   & 
     554                  &    + e3t(ji  ,jj  ,jk,Kmm)*tmask(ji  ,jj  ,jk)   & 
     555                  &    + e3t(ji+1,jj  ,jk,Kmm)*tmask(ji+1,jj  ,jk)  ) 
    784556               zmsk = (                    tmask(ji,jj+1,jk) +                     tmask(ji+1,jj+1,jk)   & 
    785557                  &                      + tmask(ji,jj  ,jk) +                     tmask(ji+1,jj  ,jk)  ) 
    … …  
    1000772      !! 
    1001773      NAMELIST/namdyn_vor/ ln_dynvor_ens, ln_dynvor_ene, ln_dynvor_enT, ln_dynvor_eeT,   & 
    1002          &                 ln_dynvor_een, nn_een_e3f   , ln_dynvor_mix, ln_dynvor_msk,   & 
    1003          &                 ln_dynvor_ens_adVO, ln_dynvor_ens_adKE, ln_dynvor_ens_adKEVO, &   ! Alternative direction parameters 
    1004          &                 ln_dynvor_ene_adVO, ln_dynvor_ene_adKE, ln_dynvor_ene_adKEVO 
     774         &                 ln_dynvor_een, nn_een_e3f   , ln_dynvor_mix, ln_dynvor_msk 
    1005775      !!---------------------------------------------------------------------- 
    1006776      ! 
    … …  
    1019789      IF(lwp) THEN                    ! Namelist print 
    1020790         WRITE(numout,*) '   Namelist namdyn_vor : choice of the vorticity term scheme' 
    1021          WRITE(numout,*) '      enstrophy conserving scheme                    ln_dynvor_ens    = ', ln_dynvor_ens 
    1022          WRITE(numout,*) '      f-point energy conserving scheme               ln_dynvor_ene    = ', ln_dynvor_ene 
    1023          WRITE(numout,*) '      t-point energy conserving scheme               ln_dynvor_enT    = ', ln_dynvor_enT 
    1024          WRITE(numout,*) '      energy conserving scheme  (een using e3t)      ln_dynvor_eeT    = ', ln_dynvor_eeT 
    1025          WRITE(numout,*) '      enstrophy and energy conserving scheme         ln_dynvor_een    = ', ln_dynvor_een 
    1026          WRITE(numout,*) '         e3f = averaging /4 (=0) or /sum(tmask) (=1)    nn_een_e3f    = ', nn_een_e3f 
    1027          WRITE(numout,*) '      mixed enstrophy/energy conserving scheme       ln_dynvor_mix    = ', ln_dynvor_mix 
    1028          WRITE(numout,*) '      masked (=T) or unmasked(=F) vorticity          ln_dynvor_msk    = ', ln_dynvor_msk 
     791         WRITE(numout,*) '      enstrophy conserving scheme                    ln_dynvor_ens = ', ln_dynvor_ens 
     792         WRITE(numout,*) '      f-point energy conserving scheme               ln_dynvor_ene = ', ln_dynvor_ene 
     793         WRITE(numout,*) '      t-point energy conserving scheme               ln_dynvor_enT = ', ln_dynvor_enT 
     794         WRITE(numout,*) '      energy conserving scheme  (een using e3t)      ln_dynvor_eeT = ', ln_dynvor_eeT 
     795         WRITE(numout,*) '      enstrophy and energy conserving scheme         ln_dynvor_een = ', ln_dynvor_een 
     796         WRITE(numout,*) '         e3f = averaging /4 (=0) or /sum(tmask) (=1)    nn_een_e3f = ', nn_een_e3f 
     797         WRITE(numout,*) '      mixed enstrophy/energy conserving scheme       ln_dynvor_mix = ', ln_dynvor_mix 
     798         WRITE(numout,*) '      masked (=T) or unmasked(=F) vorticity          ln_dynvor_msk = ', ln_dynvor_msk 
    1029799      ENDIF 
    1030800 
    … …  
    1039809         DO_3D_10_10( 1, jpk ) 
    1040810            IF(    tmask(ji,jj+1,jk) + tmask(ji+1,jj+1,jk)              & 
    1041                & + tmask(ji,jj  ,jk) + tmask(ji+1,jj  ,jk) == 3._wp )   fmask(ji,jj,jk) = 1._wp 
     811               & + tmask(ji,jj  ,jk) + tmask(ji+1,jj+1,jk) == 3._wp )   fmask(ji,jj,jk) = 1._wp 
    1042812         END_3D 
    1043813         ! 
    … …  
    1049819      ioptio = 0                     ! type of scheme for vorticity (set nvor_scheme) 
    1050820      IF( ln_dynvor_ens ) THEN   ;   ioptio = ioptio + 1   ;   nvor_scheme = np_ENS   ;   ENDIF 
    1051       IF( ln_dynvor_ens_adVO ) THEN   ;   ioptio = ioptio + 1     ;   nvor_scheme = np_ENS_adVO   ;   ENDIF 
    1052       IF( ln_dynvor_ens_adKE ) THEN   ;   ioptio = ioptio + 1     ;   nvor_scheme = np_ENS_adKE   ;   ENDIF 
    1053       IF( ln_dynvor_ens_adKEVO ) THEN   ;   ioptio = ioptio + 1   ;   nvor_scheme = np_ENS_adKEVO   ;   ENDIF 
    1054821      IF( ln_dynvor_ene ) THEN   ;   ioptio = ioptio + 1   ;   nvor_scheme = np_ENE   ;   ENDIF 
    1055       IF( ln_dynvor_ene_adVO ) THEN   ;   ioptio = ioptio + 1     ;   nvor_scheme = np_ENE_adVO   ;   ENDIF 
    1056       IF( ln_dynvor_ene_adKE ) THEN   ;   ioptio = ioptio + 1     ;   nvor_scheme = np_ENE_adKE   ;   ENDIF 
    1057       IF( ln_dynvor_ene_adKEVO ) THEN   ;   ioptio = ioptio + 1   ;   nvor_scheme = np_ENE_adKEVO   ;   ENDIF 
    1058822      IF( ln_dynvor_enT ) THEN   ;   ioptio = ioptio + 1   ;   nvor_scheme = np_ENT   ;   ENDIF 
    1059823      IF( ln_dynvor_eeT ) THEN   ;   ioptio = ioptio + 1   ;   nvor_scheme = np_EET   ;   ENDIF 
    … …  
    1072836      CASE( np_VEC_c2  ) 
    1073837         IF(lwp) WRITE(numout,*) '   ==>>>   vector form dynamics : total vorticity = Coriolis + relative vorticity'  
    1074          nrvm = np_RVO        ! relative vorticity       
     838         nrvm = np_RVO        ! relative vorticity 
    1075839         ntot = np_CRV        ! relative + planetary vorticity          
    1076840      CASE( np_FLX_c2 , np_FLX_ubs  ) 
    … …  
    1102866         WRITE(numout,*) 
    1103867         SELECT CASE( nvor_scheme ) 
    1104           
    1105          CASE( np_ENS    )   ;   WRITE(numout,*) '   ==>>>   enstrophy conserving scheme (ENS)' 
    1106          CASE( np_ENS_adVO ) ;   WRITE(numout,*) '   ==>>>   AD enstrophy conserving scheme (ENS_adVO) on vorticity only' 
    1107          CASE( np_ENS_adKE ) ;   WRITE(numout,*) '   ==>>>   AD enstrophy conserving scheme (ENS_adKE) on kinetic energy only' 
    1108          CASE( np_ENS_adKEVO ) ;   WRITE(numout,*) '   ==>>>   AD enstrophy conserving scheme (ENS_adKEVO) on kinetic energy and vorticity' 
    1109           
    1110          CASE( np_ENE    )   ;   WRITE(numout,*) '   ==>>>   energy conserving scheme (Coriolis at F-points) (ENE)' 
    1111          CASE( np_ENE_adVO ) ;   WRITE(numout,*) '   ==>>>   AD energy conserving scheme (Coriolis at F-points) (ENE_adVO) on vorticity only' 
    1112          CASE( np_ENE_adKE ) ;   WRITE(numout,*) '   ==>>>   AD energy conserving scheme (Coriolis at F-points) (ENE_adKE) on kinetic energy only' 
    1113          CASE( np_ENE_adKEVO ) ;   WRITE(numout,*) '   ==>>>   AD energy conserving scheme (Coriolis at F-points) (ENE_adKEVO) on kinetic energy and vorticity' 
    1114           
    1115          CASE( np_ENT    )   ;   WRITE(numout,*) '   ==>>>   energy conserving scheme (Coriolis at T-points) (ENT)' 
    1116          CASE( np_EET    )   ;   WRITE(numout,*) '   ==>>>   energy conserving scheme (EEN scheme using e3t) (EET)' 
    1117          CASE( np_EEN    )   ;   WRITE(numout,*) '   ==>>>   energy and enstrophy conserving scheme (EEN)' 
    1118          CASE( np_MIX    )   ;   WRITE(numout,*) '   ==>>>   mixed enstrophy/energy conserving scheme (MIX)' 
     868         CASE( np_ENS )   ;   WRITE(numout,*) '   ==>>>   enstrophy conserving scheme (ENS)' 
     869         CASE( np_ENE )   ;   WRITE(numout,*) '   ==>>>   energy conserving scheme (Coriolis at F-points) (ENE)' 
     870         CASE( np_ENT )   ;   WRITE(numout,*) '   ==>>>   energy conserving scheme (Coriolis at T-points) (ENT)' 
     871         CASE( np_EET )   ;   WRITE(numout,*) '   ==>>>   energy conserving scheme (EEN scheme using e3t) (EET)' 
     872         CASE( np_EEN )   ;   WRITE(numout,*) '   ==>>>   energy and enstrophy conserving scheme (EEN)' 
     873         CASE( np_MIX )   ;   WRITE(numout,*) '   ==>>>   mixed enstrophy/energy conserving scheme (MIX)' 
    1119874         END SELECT          
    1120875      ENDIF 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/SWE/ldfdyn.F90

    r13005 r13151  
    2525   USE lib_mpp         ! distribued memory computing library 
    2626   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    27    ! 
    28    USE usrdef_nam , ONLY : ln_dynldf_lap_PM 
    29    ! 
     27 
    3028   IMPLICIT NONE 
    3129   PRIVATE 
    … …  
    6260   INTEGER           , PUBLIC ::   nldf_dyn         !: type of lateral diffusion used defined from ln_dynldf_... (namlist logicals) 
    6361   LOGICAL           , PUBLIC ::   l_ldfdyn_time    !: flag for time variation of the lateral eddy viscosity coef. 
    64 !!an 
    65    !LOGICAL           , PUBLIC ::   ll_dynldf_lap_PM !: flag for P.Marchand modification on viscosity 
    66 !!an 
     62 
    6763   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ahmt, ahmf   !: eddy viscosity coef. at T- and F-points [m2/s or m4/s] 
    6864   REAL(wp),         ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   dtensq       !: horizontal tension squared         (Smagorinsky only) 
    … …  
    327323         IF( .NOT.l_ldfdyn_time ) THEN             !* No time variation  
    328324            IF(     ln_dynldf_lap ) THEN                 !   laplacian operator (mask only) 
    329 !!an          ! 
    330             WRITE(numout,*) '   ln_dynldf_lap_PM = ',ln_dynldf_lap_PM  
    331                IF(     ln_dynldf_lap_PM ) THEN                 !   laplacian operator (mask only) 
     325               ahmt(:,:,1:jpkm1) =       ahmt(:,:,1:jpkm1)   * tmask(:,:,1:jpkm1) 
     326               WRITE(numout,*) ' ahmt tmask ' 
    332327!! mask tension at the coast (equivalent of ghostpoints at T) 
    333                   DO jk = 1, jpk 
    334                      DO jj = 1, jpjm1 
    335                         DO ji = 1, jpim1      ! NO vector opt. 
    336                            ! si sum(fmask)==3 = mouillé (on touche pas) 
    337                            ! si sum = 2 alors on met a 0 zsum = fmask + fmask + fmask,.. et si zsum < 2 -> 0 sinon = 1 
    338                            zsum =   fmask(ji,jj  ,jk) + fmask(ji+1,jj  ,jk)   & 
    339                               &   + fmask(ji,jj+1,jk) + fmask(ji+1,jj+1,jk) 
    340                            IF ( zsum < 2._wp )   ahmt(ji,jj,jk) = 0 
    341                            ! 
    342                            !ahmt(ji,jj,jk) = ahmt(ji,jj,jk) * fmask(ji,jj  ,jk) * fmask(ji+1,jj  ,jk)   & 
    343                            !   &                            * fmask(ji,jj+1,jk) * fmask(ji+1,jj+1,jk) 
    344                         END DO 
    345                      END DO 
    346                   END DO 
    347                   ahmt(jpi,:,1:jpkm1) =  0._wp 
    348                   ahmt(:,jpj,1:jpkm1) =  0._wp 
    349                   WRITE(numout,*) '  ahmt x0' 
    350 !! apply no slip at the coast (ssfmask = 1 within the domain and at the coast contrary to fmask in free slip) 
    351                    DO jk = 1, jpkm1 
    352                       ahmf(:,:,jk) =    ahmf(:,:,jk) * ( 2._wp * ssfmask(:,:) - fmask(:,:,jk) ) 
    353                    END DO 
    354                    WRITE(numout,*) '  ahmf x2' 
    355                ELSE 
    356                ! classic boundary condition on the viscosity coefficient 
    357                   ahmt(:,:,1:jpkm1) =       ahmt(:,:,1:jpkm1)   * tmask(:,:,1:jpkm1) 
    358                   WRITE(numout,*) ' ahmt tmasked ' 
    359                   ahmf(:,:,1:jpkm1) =       ahmf(:,:,1:jpkm1)   * fmask(:,:,1:jpkm1) 
    360                   WRITE(numout,*) ' ahmf fmasked ' 
    361                ENDIF 
    362 !!an         !                  
     328!              DO jk = 1, jpk 
     329!                 DO jj = 1, jpjm1 
     330!                    DO ji = 1, jpim1      ! NO vector opt. 
     331!                       ! si sum(fmask)==3 = mouillé (on touche pas) 
     332!                       ! si sum = 2 alors on met a 0 zsum = fmask + fmask + fmask,.. et si zsum < 2 -> 0 sinon = 1 
     333!                       zsum =   fmask(ji,jj  ,jk) + fmask(ji+1,jj  ,jk)   & 
     334!                          &   + fmask(ji,jj+1,jk) + fmask(ji+1,jj+1,jk) 
     335!                       IF ( zsum < 2._wp )   ahmt(ji,jj,jk) = 0 
     336!                       ! 
     337!                       !ahmt(ji,jj,jk) = ahmt(ji,jj,jk) * fmask(ji,jj  ,jk) * fmask(ji+1,jj  ,jk)   & 
     338!                       !   &                            * fmask(ji,jj+1,jk) * fmask(ji+1,jj+1,jk) 
     339!                    END DO 
     340!                 END DO 
     341!              END DO 
     342!              ahmt(jpi,:,1:jpkm1) =  0._wp 
     343!              ahmt(:,jpj,1:jpkm1) =  0._wp 
     344!              WRITE(numout,*) '   an45 ahmt x0' 
     345 
     346               ahmf(:,:,1:jpkm1) =       ahmf(:,:,1:jpkm1)   * fmask(:,:,1:jpkm1) 
     347               WRITE(numout,*) ' ahmf fmask ' 
     348!!an apply no slip at the coast (ssfmask = 1 within the domain and at the coast contrary to fmask in free slip) 
     349!               DO jk = 1, jpkm1 
     350!                  ahmf(:,:,jk) =    ahmf(:,:,jk) * ( 2._wp * ssfmask(:,:) - fmask(:,:,jk) ) 
     351!               END DO 
     352!               WRITE(numout,*) '   an45 ahmf x2' 
     353 
    363354            ELSEIF( ln_dynldf_blp ) THEN                 ! bilaplacian operator (square root + mask) 
    364355               ahmt(:,:,1:jpkm1) = SQRT( ahmt(:,:,1:jpkm1) ) * tmask(:,:,1:jpkm1) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/SWE/nemogcm.F90

    r12614 r13151  
    6060   USE diacfl         ! CFL diagnostics               (dia_cfl_init routine) 
    6161   USE diamlr         ! IOM context management for multiple-linear-regression analysis 
     62#if defined key_RK3 
     63   USE stpRK3 
     64#elif defined key_qco 
     65   USE stpLF 
     66#else 
    6267   USE step           ! NEMO time-stepping                 (stp     routine) 
     68#endif 
    6369   USE isfstp         ! ice shelf                     (isf_stp_init routine) 
    6470   USE icbini         ! handle bergs, initialisation 
    … …  
    175181            IF ( istp ==         nitend ) elapsed_time = zstptiming - elapsed_time 
    176182         ENDIF 
    177           
    178          CALL stp        ( istp )  
     183#if defined key_RK3 
     184         CALL stp_RK3    ( istp ) 
     185#elif defined key_qco 
     186         CALL stp_LF     ( istp ) 
     187#else 
     188         CALL stp        ( istp ) 
     189#endif 
    179190         istp = istp + 1 
    180191 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/SWE/sbcice_cice.F90

    r12614 r13151  
    1212   USE oce             ! ocean dynamics and tracers 
    1313   USE dom_oce         ! ocean space and time domain 
     14!!st8 
     15# if ! defined key_qco 
    1416   USE domvvl 
     17# else 
     18   USE domqco 
     19# endif 
     20!!st8 
    1521   USE phycst, only : rcp, rho0, r1_rho0, rhos, rhoi 
    1622   USE in_out_manager  ! I/O manager 
    … …  
    233239!!gm This should be put elsewhere....   (same remark for limsbc) 
    234240!!gm especially here it is assumed zstar coordinate, but it can be ztilde.... 
     241!!st9 
     242#if defined key_qco 
     243            IF( .NOT.ln_linssh )   CALL dom_qco_zgr( Kbb, Kmm, Kaa )   ! interpolation scale factor, depth and water column 
     244#else 
    235245            IF( .NOT.ln_linssh ) THEN 
    236246               ! 
    237247               DO jk = 1,jpkm1                     ! adjust initial vertical scale factors 
    238                   e3t(:,:,jk,Kmm) = e3t_0(:,:,jk)*( 1._wp + ssh(:,:,Kmm)*tmask(:,:,1)/(ht_0(:,:) + 1.0 - tmask(:,:,1)) ) 
    239                   e3t(:,:,jk,Kbb) = e3t_0(:,:,jk)*( 1._wp + ssh(:,:,Kbb)*tmask(:,:,1)/(ht_0(:,:) + 1.0 - tmask(:,:,1)) ) 
    240                ENDDO 
     248                  e3t(:,:,jk,Kmm) = e3t_0(:,:,jk)*( 1._wp + ssh(:,:,Kmm)*r1_ht_0(:,:)*tmask(:,:,jk) ) 
     249                  e3t(:,:,jk,Kbb) = e3t_0(:,:,jk)*( 1._wp + ssh(:,:,Kbb)*r1_ht_0(:,:)*tmask(:,:,jk) ) 
     250               END DO 
    241251               e3t(:,:,:,Krhs) = e3t(:,:,:,Kbb) 
    242252               ! Reconstruction of all vertical scale factors at now and before time-steps 
    … …  
    267277               END DO 
    268278            ENDIF 
     279#endif 
     280!!st9 
    269281         ENDIF 
    270282      ENDIF 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/SWE/step.F90

    r13005 r13151  
    66   !! History :  NEMO !  2020-03  (A. Nasser, G. Madec)  Original code from  4.0.2 
    77   !!---------------------------------------------------------------------- 
    8  
     8#if defined key_qco 
     9   !!---------------------------------------------------------------------- 
     10   !!   'key_qco'      EMPTY MODULE      Quasi-Eulerian vertical coordonate 
     11   !!---------------------------------------------------------------------- 
     12#else 
    913   !!---------------------------------------------------------------------- 
    1014   !!   stp             : Shallow Water time-stepping 
    … …  
    1317   USE phycst           ! physical constants 
    1418   USE usrdef_nam 
    15    USE lib_mpp        ! MPP library 
    16    USE dynvor , ONLY : ln_dynvor_ens_adVO, ln_dynvor_ens_adKE, ln_dynvor_ens_adKEVO, & 
    17     &                  ln_dynvor_ene_adVO, ln_dynvor_ene_adKE, ln_dynvor_ene_adKEVO     
    1819   ! 
    1920   USE iom              ! xIOs server  
    … …  
    122123      !  LATERAL  PHYSICS 
    123124      !                                                                        ! eddy diffusivity coeff. 
    124       IF( l_ldfdyn_time                    )   CALL ldf_dyn( kstp, Nbb )       ! eddy viscosity coeff.  
     125      IF( l_ldfdyn_time )   CALL ldf_dyn( kstp, Nbb )                          ! eddy viscosity coeff.  
    125126 
    126127      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    … …  
    129130 
    130131                            CALL ssh_nxt       ( kstp, Nbb, Nnn, ssh, Naa )    ! after ssh (includes call to div_hor) 
    131  
    132       IF( .NOT.ln_linssh )  CALL dom_vvl_sf_nxt( kstp, Nbb, Nnn,      Naa )    ! after vertical scale factors  
    133                                                         
    134132                         uu(:,:,:,Nrhs) = 0._wp            ! set dynamics trends to zero 
    135133                         vv(:,:,:,Nrhs) = 0._wp 
    136134 
    137       IF( ln_bdy     )   CALL bdy_dyn3d_dmp ( kstp, Nbb,      uu, vv, Nrhs )  ! bdy damping trends 
     135      IF( .NOT.ln_linssh )  CALL dom_vvl_sf_nxt( kstp, Nbb, Nnn,      Naa )    ! after vertical scale factors  
     136 
     137      IF( ln_bdy     )      CALL bdy_dyn3d_dmp ( kstp, Nbb,      uu, vv, Nrhs )  ! bdy damping trends 
    138138 
    139139#if defined key_agrif 
    140140      IF(.NOT. Agrif_Root())  &  
    141                &         CALL Agrif_Sponge_dyn        ! momentum sponge 
    142 #endif 
     141               &            CALL Agrif_Sponge_dyn        ! momentum sponge 
     142#endif 
     143                            CALL dyn_adv( kstp, Nbb, Nnn      , uu, vv, Nrhs )  ! advection (VF or FF)   ==> RHS 
     144  
     145                            CALL dyn_vor( kstp,      Nnn      , uu, vv, Nrhs )  ! vorticity              ==> RHS 
     146  
     147                            CALL dyn_ldf( kstp, Nbb, Nnn      , uu, vv, Nrhs )  ! lateral mixing 
    143148 
    144149!!an - calcul du gradient de pression horizontal (explicit) 
    … …  
    148153      END_3D 
    149154      ! 
    150        
    151 !      IF( kstp == nit000 .AND. lwp ) THEN 
    152 !         WRITE(numout,*) 
    153 !         WRITE(numout,*) 'step.F90 : classic script used' 
    154 !         WRITE(numout,*) '~~~~~~~' 
    155 !         IF(       ln_dynvor_ens_adVO .OR. ln_dynvor_ens_adKE .OR. ln_dynvor_ens_adKEVO   & 
    156 !         &    .OR. ln_dynvor_ene_adVO .OR. ln_dynvor_ene_adKE .OR. ln_dynvor_ene_adKEVO   ) THEN 
    157 !            CALL ctl_stop('STOP','step : alternative direction asked but classis step'  ) 
    158 !         ENDIF 
    159 !      ENDIF 
    160 !!an      
    161 !                         CALL dyn_adv( kstp, Nbb, Nnn      , uu, vv, Nrhs )  ! advection (VF or FF)  ==> RHS 
    162 !  
    163 !                         CALL dyn_vor( kstp, Nbb, Nnn      , uu, vv, Nrhs )  ! vorticity             ==> RHS 
    164 !  
    165 !!an     In dynvor, dynkegAD is called even if not AD, so we keep the same step.F90 
    166    
    167                          CALL dyn_vor( kstp, Nbb, Nnn      , uu, vv, Nrhs)  ! vorticity            ==> RHS 
    168    
    169                          CALL dyn_ldf( kstp, Nbb, Nnn      , uu, vv, Nrhs )  ! lateral mixing 
    170  
    171155      ! add wind stress forcing and layer linear friction to the RHS  
    172156      z1_2rho0 = 0.5_wp * r1_rho0 
    … …  
    175159            &                                  - rn_rfr * uu(ji,jj,jk,Nbb) 
    176160         vv(ji,jj,jk,Nrhs) = vv(ji,jj,jk,Nrhs) + z1_2rho0 * ( vtau_b(ji,jj) + vtau(ji,jj) ) / e3v(ji,jj,jk,Nnn)   & 
    177             &                                  - rn_rfr * vv(ji,jj,jk,Nbb)   
     161            &                                  - rn_rfr * vv(ji,jj,jk,Nbb) 
    178162      END_3D    
    179163!!an          
    … …  
    182166      ! Leap-Frog time splitting + Robert-Asselin time filter on u,v,e3  
    183167      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    184        
     168           
     169!! what about  IF( .NOT.ln_linssh )  ? 
    185170!!an futur module dyn_nxt (a la place de dyn_atf) 
    186171       
    … …  
    209194               uu(ji,jj,jk,Naa) = zua 
    210195               vv(ji,jj,jk,Naa) = zva 
    211              END_3D    
     196            END_3D 
    212197         ENDIF 
    213198         ! 
    … …  
    220205               zue3a = zue3b + rDt * e3u(ji,jj,jk,Nrhs) * uu(ji,jj,jk,Nrhs) * umask(ji,jj,jk) 
    221206               zve3a = zve3b + rDt * e3v(ji,jj,jk,Nrhs) * vv(ji,jj,jk,Nrhs) * vmask(ji,jj,jk) 
    222                !                                                 
     207               ! 
    223208               uu(ji,jj,jk,Naa) = zue3a / e3u(ji,jj,jk,Naa)     
    224                vv(ji,jj,jk,Naa) = zve3a / e3v(ji,jj,jk,Naa)      
    225              END_3D           
    226          ELSE                             ! Leap Frog time stepping + Asselin filter          
     209               vv(ji,jj,jk,Naa) = zve3a / e3v(ji,jj,jk,Naa) 
     210            END_3D 
     211         ELSE                             ! Leap Frog time stepping + Asselin filter 
    227212            DO_3D_11_11(1,jpkm1) 
    228213               zue3n = e3u(ji,jj,jk,Nnn) * uu(ji,jj,jk,Nnn) 
    … …  
    239224               !                                                ! Asselin time filter on u,v (Nnn) 
    240225               uu(ji,jj,jk,Nnn) = ( zue3n + rn_atfp * ( zue3b - 2._wp * zue3n  + zue3a ) ) / ze3u_tf 
    241                vv(ji,jj,jk,Nnn) = ( zve3n + rn_atfp * ( zve3b - 2._wp * zve3n  + zve3a ) ) / ze3v_tf            
     226               vv(ji,jj,jk,Nnn) = ( zve3n + rn_atfp * ( zve3b - 2._wp * zve3n  + zve3a ) ) / ze3v_tf 
    242227               ! 
    243228               e3u(ji,jj,jk,Nnn) = ze3u_tf 
    … …  
    246231               ! 
    247232               uu(ji,jj,jk,Naa) = zue3a / e3u(ji,jj,jk,Naa)     
    248                vv(ji,jj,jk,Naa) = zve3a / e3v(ji,jj,jk,Naa)      
    249              END_3D    
     233               vv(ji,jj,jk,Naa) = zve3a / e3v(ji,jj,jk,Naa) 
     234            END_3D        
    250235         ENDIF 
    251236      ENDIF 
    252        
     237 
     238 
    253239      CALL lbc_lnk_multi( 'stp', uu(:,:,:,Nnn), 'U', -1., vv(:,:,:,Nnn), 'V', -1.,   &   !* local domain boundaries 
    254240         &                       uu(:,:,:,Naa), 'U', -1., vv(:,:,:,Naa), 'V', -1.    )      
    … …  
    263249!!                         CALL dyn_atf       ( kstp, Nbb, Nnn, Naa, uu, vv, e3t, e3u, e3v  )  ! time filtering of "now" velocities and scale factors 
    264250!!an TO BE ADDED : a simplifier 
    265 !                         CALL ssh_atf       ( kstp, Nbb, Nnn, Naa, ssh )                     ! time filtering of "now" sea surface height 
    266   
     251!!                         CALL ssh_atf       ( kstp, Nbb, Nnn, Naa, ssh )                     ! time filtering of "now" sea surface height 
    267252      IF ( .NOT.( l_1st_euler ) ) THEN   ! Only do time filtering for leapfrog timesteps 
    268253         !                                                  ! filtering "now" field 
    269254         ssh(:,:,Nnn) = ssh(:,:,Nnn) + rn_atfp * ( ssh(:,:,Nbb) - 2 * ssh(:,:,Nnn) + ssh(:,:,Naa) ) 
    270255      ENDIF 
    271        
    272256!!an  
    273257 
    … …  
    280264      ! 
    281265                         CALL dom_vvl_sf_update( kstp, Nbb, Nnn, Naa )  ! recompute vertical scale factors 
    282  
    283266      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    284267      ! diagnostics and outputs 
    … …  
    287270      IF( ln_diacfl  )   CALL dia_cfl   ( kstp,      Nnn )      ! Courant number diagnostics 
    288271     
    289                         CALL dia_wri   ( kstp,      Nnn )      ! ocean model: outputs 
    290  
     272                         CALL dia_wri   ( kstp,      Nnn )      ! ocean model: outputs 
    291273      ! 
    292274      IF( lrst_oce   )   CALL rst_write    ( kstp, Nbb, Nnn )   ! write output ocean restart file 
    … …  
    335317      ! 
    336318   END SUBROUTINE stp 
     319#endif 
    337320   ! 
    338321   !!====================================================================== 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/SWE/stpctl.F90

    r12614 r13151  
    3535   INTEGER  ::   idrun, idtime, idssh, idu, ids1, ids2, idt1, idt2, idc1, idw1, istatus 
    3636   LOGICAL  ::   lsomeoce 
     37!!stoops 
     38#  include "domzgr_substitute.h90" 
    3739   !!---------------------------------------------------------------------- 
    3840   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/C14/trcsms_c14.F90

    r12489 r13151  
    2828   !! * Substitutions 
    2929#  include "do_loop_substitute.h90" 
     30#  include "domzgr_substitute.h90" 
    3031   !!---------------------------------------------------------------------- 
    3132   !! NEMO/TOP 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/CFC/trcsms_cfc.F90

    r12489 r13151  
    4949   !! * Substitutions 
    5050#  include "do_loop_substitute.h90" 
     51#  include "domzgr_substitute.h90" 
    5152   !!---------------------------------------------------------------------- 
    5253   !! NEMO/TOP 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/PISCES/P2Z/p2zbio.F90

    r12377 r13151  
    5858   !! * Substitutions 
    5959#  include "do_loop_substitute.h90" 
     60#  include "domzgr_substitute.h90" 
    6061   !!---------------------------------------------------------------------- 
    6162   !! NEMO/TOP 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/PISCES/P2Z/p2zexp.F90

    r12489 r13151  
    3939   !! * Substitutions 
    4040#  include "do_loop_substitute.h90" 
     41#  include "domzgr_substitute.h90" 
    4142   !!---------------------------------------------------------------------- 
    4243   !! NEMO/TOP 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/PISCES/P2Z/p2zopt.F90

    r12377 r13151  
    4040   !! * Substitutions 
    4141#  include "do_loop_substitute.h90" 
     42#  include "domzgr_substitute.h90" 
    4243   !!---------------------------------------------------------------------- 
    4344   !! NEMO/TOP 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/PISCES/P2Z/p2zsed.F90

    r12377 r13151  
    3333   !! * Substitutions 
    3434#  include "do_loop_substitute.h90" 
     35#  include "domzgr_substitute.h90" 
    3536   !!---------------------------------------------------------------------- 
    3637   !! NEMO/TOP 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/PISCES/P4Z/p4zbc.F90

    r12377 r13151  
    4848   !! * Substitutions 
    4949#  include "do_loop_substitute.h90" 
     50#  include "domzgr_substitute.h90" 
    5051   !!---------------------------------------------------------------------- 
    5152   !! NEMO/TOP 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/PISCES/P4Z/p4zbio.F90

    r12377 r13151  
    4040   !! * Substitutions 
    4141#  include "do_loop_substitute.h90" 
     42#  include "domzgr_substitute.h90" 
    4243   !!---------------------------------------------------------------------- 
    4344   !! NEMO/TOP 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/PISCES/P4Z/p4zche.F90

    r12377 r13151  
    132132   !! * Substitutions 
    133133#  include "do_loop_substitute.h90" 
     134#  include "domzgr_substitute.h90" 
    134135   !!---------------------------------------------------------------------- 
    135136   !! NEMO/TOP 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/PISCES/P4Z/p4zfechem.F90

    r12377 r13151  
    3333   !! * Substitutions 
    3434#  include "do_loop_substitute.h90" 
     35#  include "domzgr_substitute.h90" 
    3536   !!---------------------------------------------------------------------- 
    3637   !! NEMO/TOP 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/PISCES/P4Z/p4zflx.F90

    r12377 r13151  
    5454   !! * Substitutions 
    5555#  include "do_loop_substitute.h90" 
     56#  include "domzgr_substitute.h90" 
    5657   !!---------------------------------------------------------------------- 
    5758   !! NEMO/TOP 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/PISCES/P4Z/p4zopt.F90

    r12377 r13151  
    4444   !! * Substitutions 
    4545#  include "do_loop_substitute.h90" 
     46#  include "domzgr_substitute.h90" 
    4647   !!---------------------------------------------------------------------- 
    4748   !! NEMO/TOP 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/PISCES/P4Z/p4zpoc.F90

    r12377 r13151  
    3939   !! * Substitutions 
    4040#  include "do_loop_substitute.h90" 
     41#  include "domzgr_substitute.h90" 
    4142   !!---------------------------------------------------------------------- 
    4243   !! NEMO/TOP 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/PISCES/P4Z/p4zprod.F90

    r12377 r13151  
    4848   !! * Substitutions 
    4949#  include "do_loop_substitute.h90" 
     50#  include "domzgr_substitute.h90" 
    5051   !!---------------------------------------------------------------------- 
    5152   !! NEMO/TOP 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/PISCES/P4Z/p4zrem.F90

    r12377 r13151  
    4444   !! * Substitutions 
    4545#  include "do_loop_substitute.h90" 
     46#  include "domzgr_substitute.h90" 
    4647   !!---------------------------------------------------------------------- 
    4748   !! NEMO/TOP 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/PISCES/P4Z/p4zsed.F90

    r12377 r13151  
    3939   !! * Substitutions 
    4040#  include "do_loop_substitute.h90" 
     41#  include "domzgr_substitute.h90" 
    4142   !!---------------------------------------------------------------------- 
    4243   !! NEMO/TOP 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/PISCES/P4Z/p4zsink.F90

    r12377 r13151  
    4040   !! * Substitutions 
    4141#  include "do_loop_substitute.h90" 
     42#  include "domzgr_substitute.h90" 
    4243   !!---------------------------------------------------------------------- 
    4344   !! NEMO/TOP 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/PISCES/P4Z/p4zsms.F90

    r12489 r13151  
    4141   !! * Substitutions 
    4242#  include "do_loop_substitute.h90" 
     43#  include "domzgr_substitute.h90" 
    4344   !!---------------------------------------------------------------------- 
    4445   !! NEMO/TOP 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/PISCES/P4Z/p5zprod.F90

    r12377 r13151  
    5252   !! * Substitutions 
    5353#  include "do_loop_substitute.h90" 
     54#  include "domzgr_substitute.h90" 
    5455   !!---------------------------------------------------------------------- 
    5556   !! NEMO/TOP 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/PISCES/SED/oce_sed.F90

    r12489 r13151  
    1313   USE dom_oce , ONLY :   glamt     =>   glamt          !: longitude of t-point (degre) 
    1414   USE dom_oce , ONLY :   gphit     =>   gphit          !: latitude  of t-point (degre) 
     15!!st  
     16#if ! defined key_qco 
    1517   USE dom_oce , ONLY :   e3t       =>   e3t            !: latitude  of t-point (degre) 
     18#endif 
    1619   USE dom_oce , ONLY :   e3t_1d    =>   e3t_1d         !: reference depth of t-points (m) 
    1720   USE dom_oce , ONLY :   gdepw_0   =>   gdepw_0        !: reference depth of t-points (m) 
    … …  
    5356 
    5457END MODULE oce_sed 
    55  
    56  

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/PISCES/SED/seddta.F90

    r12489 r13151  
    2424   !! * Substitutions 
    2525#  include "do_loop_substitute.h90" 
     26#  include "domzgr_substitute.h90" 
    2627   !! $Id$ 
    2728CONTAINS 
    … …  
    164165      CALL pack_arr ( jpoce,  rainrm_dta(1:jpoce,jscal), trc_data(1:jpi,1:jpj,14), iarroce(1:jpoce) ) 
    165166      rainrm_dta(1:jpoce,jscal) = rainrm_dta(1:jpoce,jscal) * 1e-4 
    166       ! vector temperature [°C] and salinity  
     167      ! vector temperature [�C] and salinity  
    167168      CALL pack_arr ( jpoce,  temp(1:jpoce), trc_data(1:jpi,1:jpj,15), iarroce(1:jpoce) ) 
    168169      CALL pack_arr ( jpoce,  salt(1:jpoce), trc_data(1:jpi,1:jpj,16), iarroce(1:jpoce) ) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/PISCES/SED/sedrst.F90

    r12489 r13151  
    8080         IF(lwp) WRITE(numsed,*) & 
    8181             '             open sed restart.output NetCDF file: ',TRIM(clpath)//clname 
    82          CALL iom_open( TRIM(clpath)//TRIM(clname), numrsw, ldwrt = .TRUE., kdlev = jpksed ) 
     82         CALL iom_open( TRIM(clpath)//TRIM(clname), numrsw, ldwrt = .TRUE., kdlev = jpksed, cdcomp = 'SED' ) 
    8383         lrst_sed = .TRUE. 
    8484      ENDIF 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/PISCES/trcwri_pisces.F90

    r12377 r13151  
    2121   !! * Substitutions 
    2222#  include "do_loop_substitute.h90" 
     23#  include "domzgr_substitute.h90" 
    2324   !!---------------------------------------------------------------------- 
    2425   !! NEMO/TOP 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/TRP/trcadv.F90

    r12489 r13151  
    5858   INTEGER, PARAMETER ::   np_UBS     = 4   ! 3rd order Upstream Biased Scheme 
    5959   INTEGER, PARAMETER ::   np_QCK     = 5   ! QUICK scheme 
    60     
     60 
     61#  include "domzgr_substitute.h90" 
    6162   !!---------------------------------------------------------------------- 
    6263   !! NEMO/TOP 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/TRP/trcatf.F90

    r12489 r13151  
    3131   USE trd_oce 
    3232   USE trdtra 
     33# if defined key_qco 
     34   USE traatfqco 
     35# else 
    3336   USE traatf 
     37# endif 
    3438   USE bdy_oce   , ONLY: ln_bdy 
    3539   USE trcbdy          ! BDY open boundaries 
    … …  
    5054   !! * Substitutions 
    5155#  include "do_loop_substitute.h90" 
     56#  include "domzgr_substitute.h90" 
    5257   !!---------------------------------------------------------------------- 
    5358   !! NEMO/TOP 4.0 , NEMO Consortium (2018) 
    … …  
    107112            DO jn = 1, jptra 
    108113               CALL trd_tra( kt, Kmm, Kaa, 'TRC', jn, jptra_zdfp, ztrdt(:,:,:,jn) ) 
    109             ENDDO 
     114            END DO 
    110115         ENDIF 
    111116 
    112117         ! total trend for the non-time-filtered variables.  
    113118         zfact = 1.0 / rn_Dt 
    114          ! G Nurser 23 Mar 2017. Recalculate trend as Delta(e3t*T)/e3tn; e3tn cancel from ts(Kmm) terms 
     119         ! G Nurser 23 Mar 2017. Recalculate trend as Delta(e3ta*Ta)/e3tn; e3tn cancel from ts(Kmm) terms 
    115120         IF( ln_linssh ) THEN       ! linear sea surface height only 
    116121            DO jn = 1, jptra 
    … …  
    129134         DO jn = 1, jptra 
    130135            CALL trd_tra( kt, Kmm, Kaa, 'TRC', jn, jptra_tot, ztrdt(:,:,:,jn) ) 
    131          ENDDO 
     136         END DO 
    132137         ! 
    133138         IF( ln_linssh ) THEN       ! linear sea surface height only 
    … …  
    146151            DO jn = 1, jptra 
    147152               CALL trd_tra( kt, Kmm, Kaa, 'TRC', jn, jptra_atf, ztrdt(:,:,:,jn) ) 
    148             ENDDO 
     153            END DO 
    149154         END IF 
    150155         ! 
    151156      ELSE      
    152157         IF( .NOT. l_offline ) THEN ! Leap-Frog + Asselin filter time stepping 
     158<<<<<<< .working 
    153159            IF( ln_linssh ) THEN   ;   CALL tra_atf_fix( kt, Kbb, Kmm, Kaa, nittrc000,         'TRC', ptr, jptra )                     !     linear ssh 
    154160            ELSE                   ;   CALL tra_atf_vvl( kt, Kbb, Kmm, Kaa, nittrc000, rn_Dt, 'TRC', ptr, sbc_trc, sbc_trc_b, jptra ) ! non-linear ssh 
     161======= 
     162# if defined key_qco 
     163            IF( ln_linssh ) THEN   ;   CALL tra_atf_fix_lf( kt, Kbb, Kmm, Kaa, nittrc000,        'TRC', ptr, jptra )                     !     linear ssh 
     164            ELSE                   ;   CALL tra_atf_qco_lf( kt, Kbb, Kmm, Kaa, nittrc000, rn_Dt, 'TRC', ptr, sbc_trc, sbc_trc_b, jptra ) ! non-linear ssh 
     165# else 
     166            IF( ln_linssh ) THEN   ;   CALL tra_atf_fix   ( kt, Kbb, Kmm, Kaa, nittrc000,        'TRC', ptr, jptra )                     !     linear ssh 
     167            ELSE                   ;   CALL tra_atf_vvl   ( kt, Kbb, Kmm, Kaa, nittrc000, rn_Dt, 'TRC', ptr, sbc_trc, sbc_trc_b, jptra ) ! non-linear ssh 
     168# endif 
     169>>>>>>> .merge-right.r13092 
    155170            ENDIF 
    156171         ELSE 
    157                                        CALL trc_atf_off( kt, Kbb, Kmm, Kaa, ptr )       ! offline  
     172                                       CALL trc_atf_off   ( kt, Kbb, Kmm, Kaa, ptr )       ! offline 
    158173         ENDIF 
    159174         ! 
    … …  
    182197   END SUBROUTINE trc_atf 
    183198 
    184  
     199# if ! defined key_qco 
    185200   SUBROUTINE trc_atf_off( kt, Kbb, Kmm, Kaa, ptr ) 
    186201      !!---------------------------------------------------------------------- 
    … …  
    198213      !!                This can be summurized for tempearture as: 
    199214      !!             ztm = ( e3t_n*tn + rbcp*[ e3t_b*tb - 2 e3t_n*tn + e3t_a*ta ] )   ln_dynhpg_imp = T 
    200       !!                  /( e3t(:,:,:,Kmm)    + rbcp*[ e3t(:,:,:,Kbb)    - 2 e3t(:,:,:,Kmm)    + e3t(:,:,:,Kaa)    ] )    
     215      !!                  /( e3t(:,:,jk,Kmm)    + rbcp*[ e3t(:,:,jk,Kbb)    - 2 e3t(:,:,jk,Kmm)    + e3t(:,:,jk,Kaa)    ] )    
    201216      !!             ztm = 0                                                       otherwise 
     217<<<<<<< .working 
    202218      !!             tb  = ( e3t_n*tn + rn_atfp*[ e3t_b*tb - 2 e3t_n*tn + e3t_a*ta ] ) 
    203219      !!                  /( e3t(:,:,:,Kmm)    + rn_atfp*[ e3t(:,:,:,Kbb)    - 2 e3t(:,:,:,Kmm)    + e3t(:,:,:,Kaa)    ] ) 
     220======= 
     221      !!             tb  = ( e3t_n*tn + rn_atfp*[ e3t_b*tb - 2 e3t_n*tn + e3t_a*ta ] ) 
     222      !!                  /( e3t(:,:,jk,Kmm)    + rn_atfp*[ e3t(:,:,jk,Kbb)    - 2 e3t(:,:,jk,Kmm)    + e3t(:,:,jk,Kaa)    ] ) 
     223>>>>>>> .merge-right.r13092 
    204224      !!             tn  = ta  
    205225      !!             ta  = zt        (NB: reset to 0 after eos_bn2 call) 
    … …  
    257277      ! 
    258278   END SUBROUTINE trc_atf_off 
    259  
     279# else 
     280   SUBROUTINE trc_atf_off( kt, Kbb, Kmm, Kaa, ptr ) 
     281      !!---------------------------------------------------------------------- 
     282      !!                   ***  ROUTINE tra_atf_off  *** 
     283      !! 
     284      !!          !!!!!!!!!!!!!!!!! REWRITE HEADER COMMENTS !!!!!!!!!!!!!! 
     285      !! 
     286      !! ** Purpose :   Time varying volume: apply the Asselin time filter   
     287      !!  
     288      !! ** Method  : - Apply a thickness weighted Asselin time filter on now fields. 
     289      !!              - save in (ta,sa) a thickness weighted average over the three  
     290      !!             time levels which will be used to compute rdn and thus the semi- 
     291      !!             implicit hydrostatic pressure gradient (ln_dynhpg_imp = T) 
     292      !!              - swap tracer fields to prepare the next time_step. 
     293      !!                This can be summurized for tempearture as: 
     294      !!             ztm = ( e3t_n*tn + rbcp*[ e3t_b*tb - 2 e3t_n*tn + e3t_a*ta ] )   ln_dynhpg_imp = T 
     295      !!                  /( e3t(:,:,jk,Kmm)    + rbcp*[ e3t(:,:,jk,Kbb)    - 2 e3t(:,:,jk,Kmm)    + e3t(:,:,jk,Kaa)    ] )    
     296      !!             ztm = 0                                                       otherwise 
     297      !!             tb  = ( e3t_n*tn + rn_atfp*[ e3t_b*tb - 2 e3t_n*tn + e3t_a*ta ] ) 
     298      !!                  /( e3t(:,:,jk,Kmm)    + rn_atfp*[ e3t(:,:,jk,Kbb)    - 2 e3t(:,:,jk,Kmm)    + e3t(:,:,jk,Kaa)    ] ) 
     299      !!             tn  = ta  
     300      !!             ta  = zt        (NB: reset to 0 after eos_bn2 call) 
     301      !! 
     302      !! ** Action  : - (tb,sb) and (tn,sn) ready for the next time step 
     303      !!              - (ta,sa) time averaged (t,s)   (ln_dynhpg_imp = T) 
     304      !!---------------------------------------------------------------------- 
     305      INTEGER                                   , INTENT(in   ) ::  kt            ! ocean time-step index 
     306      INTEGER                                   , INTENT(in   ) ::  Kbb, Kmm, Kaa ! time level indices 
     307      REAL(wp), DIMENSION(jpi,jpj,jpk,jptra,jpt), INTENT(inout) ::  ptr           ! passive tracers 
     308      !!      
     309      INTEGER  ::   ji, jj, jk, jn              ! dummy loop indices 
     310      REAL(wp) ::   ztc_a , ztc_n , ztc_b , ztc_f , ztc_d    ! local scalar 
     311      REAL(wp) ::   ze3t_b, ze3t_n, ze3t_a, ze3t_f           !   -      - 
     312      !!---------------------------------------------------------------------- 
     313      ! 
     314      IF( kt == nittrc000 )  THEN 
     315         IF(lwp) WRITE(numout,*) 
     316         IF(lwp) WRITE(numout,*) 'trc_atf_off : Asselin time filtering' 
     317         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 
     318         IF( .NOT. ln_linssh ) THEN 
     319            rfact1 = rn_atfp * rn_Dt 
     320            rfact2 = rfact1 / rho0 
     321         ENDIF 
     322        !   
     323      ENDIF 
     324      ! 
     325      DO jn = 1, jptra       
     326         DO_3D_11_11( 1, jpkm1 ) 
     327            ze3t_b = 1._wp + r3t(ji,jj,Kbb) * tmask(ji,jj,jk) 
     328            ze3t_n = 1._wp + r3t(ji,jj,Kmm) * tmask(ji,jj,jk) 
     329            ze3t_a = 1._wp + r3t(ji,jj,Kaa) * tmask(ji,jj,jk) 
     330            !                                         ! tracer content at Before, now and after 
     331            ztc_b  = ptr(ji,jj,jk,jn,Kbb) * ze3t_b 
     332            ztc_n  = ptr(ji,jj,jk,jn,Kmm) * ze3t_n 
     333            ztc_a  = ptr(ji,jj,jk,jn,Kaa) * ze3t_a 
     334            ! 
     335            ztc_d  = ztc_a  - 2. * ztc_n  + ztc_b 
     336            ! 
     337            ze3t_f = 1._wp + r3t_f(ji,jj)*tmask(ji,jj,jk) 
     338            ztc_f  = ztc_n  + rn_atfp * ztc_d 
     339            ! 
     340            IF( .NOT. ln_linssh .AND. jk == mikt(ji,jj) ) THEN           ! first level  
     341               ztc_f  = ztc_f  - rfact1 * ( sbc_trc(ji,jj,jn) - sbc_trc_b(ji,jj,jn) ) 
     342            ENDIF 
     343 
     344            ze3t_f = 1.e0 / ze3t_f 
     345            ptr(ji,jj,jk,jn,Kmm) = ztc_f * ze3t_f     ! time filtered "now" field 
     346            ! 
     347         END_3D 
     348         !  
     349      END DO 
     350      ! 
     351   END SUBROUTINE trc_atf_off 
     352# endif 
     353    
    260354#else 
    261355   !!---------------------------------------------------------------------- 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/TRP/trcdmp.F90

    r12377 r13151  
    4545   !! * Substitutions 
    4646#  include "do_loop_substitute.h90" 
     47#  include "domzgr_substitute.h90" 
    4748   !!---------------------------------------------------------------------- 
    4849   !! NEMO/TOP 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/TRP/trcldf.F90

    r12377 r13151  
    4444   !! * Substitutions 
    4545#  include "do_loop_substitute.h90" 
     46#  include "domzgr_substitute.h90" 
    4647   !!---------------------------------------------------------------------- 
    4748   !! NEMO/TOP 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/TRP/trcsbc.F90

    r12489 r13151  
    3030   !! * Substitutions 
    3131#  include "do_loop_substitute.h90" 
     32#  include "domzgr_substitute.h90" 
    3233   !!---------------------------------------------------------------------- 
    3334   !! NEMO/TOP 4.0 , NEMO Consortium (2018) 
    … …  
    4950      !!            The surface freshwater flux modify the ocean volume 
    5051      !!         and thus the concentration of a tracer as : 
    51       !!            tr(Krhs) = tr(Krhs) + emp * tr(Kmm) / e3t   for k=1 
     52      !!            tr(Krhs) = tr(Krhs) + emp * tr(Kmm) / e3t_   for k=1 
    5253      !!         where emp, the surface freshwater budget (evaporation minus 
    5354      !!         precipitation ) given in kg/m2/s is divided 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/TRP/trcsink.F90

    r12377 r13151  
    2626   !! * Substitutions 
    2727#  include "do_loop_substitute.h90" 
     28#  include "domzgr_substitute.h90" 
    2829   !!---------------------------------------------------------------------- 
    2930   !! NEMO/TOP 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/TRP/trdmxl_trc.F90

    r12489 r13151  
    5151   !! * Substitutions 
    5252#  include "do_loop_substitute.h90" 
     53#  include "domzgr_substitute.h90" 
    5354   !!---------------------------------------------------------------------- 
    5455   !! NEMO/TOP 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/trcbc.F90

    r12489 r13151  
    4848   !! * Substitutions 
    4949#  include "do_loop_substitute.h90" 
     50#  include "domzgr_substitute.h90" 
    5051   !!---------------------------------------------------------------------- 
    5152   !! NEMO/TOP 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/trcdta.F90

    r12377 r13151  
    4141   !! Substitutions 
    4242#include "do_loop_substitute.h90" 
     43#include "domzgr_substitute.h90" 
    4344   !!---------------------------------------------------------------------- 
    4445   !! NEMO/TOP 4.0 , NEMO Consortium (2018) 
    … …  
    206207                     ztp(jk) = ptrcdta(ji,jj,jpkm1) 
    207208                  ELSE                                      ! inbetween : vertical interpolation between jkk & jkk+1 
    208                      DO jkk = 1, jpkm1                                  ! when  gdept(jkk) < zl < gdept(jkk+1) 
     209                     DO jkk = 1, jpkm1                                  ! when  gdept_1d(jkk) < zl < gdept_1d(jkk+1) 
    209210                        IF( (zl-gdept_1d(jkk)) * (zl-gdept_1d(jkk+1)) <= 0._wp ) THEN 
    210211                           zi = ( zl - gdept_1d(jkk) ) / (gdept_1d(jkk+1)-gdept_1d(jkk)) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/trcini.F90

    r12377 r13151  
    3030    
    3131   PUBLIC   trc_init   ! called by opa 
    32  
     32    
     33#  include "domzgr_substitute.h90" 
    3334   !!---------------------------------------------------------------------- 
    3435   !! NEMO/TOP 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/trcrst.F90

    r12489 r13151  
    3333   PUBLIC   trc_rst_cal 
    3434 
     35#  include "domzgr_substitute.h90" 
    3536   !!---------------------------------------------------------------------- 
    3637   !! NEMO/TOP 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/trcstp.F90

    r12489 r13151  
    3636   REAL(wp) ::   rsecfst, rseclast       ! ??? 
    3737   REAL(wp), DIMENSION(:,:,:), SAVE, ALLOCATABLE ::   qsr_arr   ! save qsr during TOP time-step 
    38  
     38    
     39#  include "domzgr_substitute.h90" 
    3940   !!---------------------------------------------------------------------- 
    4041   !! NEMO/TOP 4.0 , NEMO Consortium (2018) 
    … …  
    142143      ! 
    143144      ! Define logical parameter ton control dirunal cycle in TOP 
    144       l_trcdm2dc = ln_dm2dc .OR. ( ln_cpl .AND. ncpl_qsr_freq /= 1 ) 
    145       l_trcdm2dc = l_trcdm2dc  .AND. .NOT. l_offline 
     145      l_trcdm2dc = ln_dm2dc .OR. ( ln_cpl .AND. ncpl_qsr_freq /= 1 .AND. ncpl_qsr_freq /= 0 ) 
     146      l_trcdm2dc = l_trcdm2dc .AND. .NOT. l_offline 
     147      ! 
    146148      IF( l_trcdm2dc .AND. lwp )   CALL ctl_warn( 'Coupling with passive tracers and used of diurnal cycle.',   & 
    147149         &                           'Computation of a daily mean shortwave for some biogeochemical models ' ) 

  • NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/trcwri.F90

    r12377 r13151  
    6060       CALL iom_put( "e3v_0", e3v_0(:,:,:) ) 
    6161       ! 
     62#if ! defined key_qco 
    6263       CALL iom_put( "e3t" , e3t(:,:,:,Kmm) ) 
    6364       CALL iom_put( "e3u" , e3u(:,:,:,Kmm) ) 
    6465       CALL iom_put( "e3v" , e3v(:,:,:,Kmm) ) 
     66#endif  
    6567       ! 
    6668      ENDIF 
Note: See TracChangeset for help on using the changeset viewer.