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 4292 for branches/2013/dev_MERGE_2013/NEMOGCM – NEMO

Ignore:
Timestamp:
2013-11-20T17:28:04+01:00 (10 years ago)
Author:
cetlod
Message:

dev_MERGE_2013 : 1st step of the merge, see ticket #1185

Location:
branches/2013/dev_MERGE_2013/NEMOGCM
Files:
1 deleted
88 edited
2 copied

Legend:

Unmodified
Added
Removed

  • branches/2013/dev_MERGE_2013/NEMOGCM/CONFIG/SHARED/1_namelist_ref

    r4230 r4292  
    507507!----------------------------------------------------------------------- 
    508508   ln_tide_pot   = .true.   !  use tidal potential forcing 
     509   nb_harmo      =    11    !  number of constituents used 
    509510   clname(1)     =   'M2'   !  name of constituent 
    510511   clname(2)     =   'S2' 
    … …  
    700701   ln_dynadv_cen2= .false. !  flux form - 2nd order centered scheme 
    701702   ln_dynadv_ubs = .false. !  flux form - 3rd order UBS      scheme 
     703/ 
     704!----------------------------------------------------------------------- 
     705&nam_vvl    !   vertical coordinate options 
     706!----------------------------------------------------------------------- 
     707   ln_vvl_zstar  = .true.           !  zstar vertical coordinate                    
     708   ln_vvl_ztilde = .false.          !  ztilde vertical coordinate: only high frequency variations 
     709   ln_vvl_layer  = .false.          !  full layer vertical coordinate 
     710   ln_vvl_ztilde_as_zstar = .false. !  ztilde vertical coordinate emulating zstar 
     711   rn_ahe3       = 0.0e0            !  thickness diffusion coefficient 
     712   rn_rst_e3t    = 30.e0            !  ztilde to zstar restoration timescale [days] 
     713   rn_lf_cutoff  = 5.0e0            !  cutoff frequency for low-pass filter  [days] 
     714   rn_zdef_max   = 0.9e0            !  maximum fractional e3t deformation 
     715   ln_vvl_dbg    = .true.           !  debug prints    (T/F) 
    702716/ 
    703717!----------------------------------------------------------------------- 

  • branches/2013/dev_MERGE_2013/NEMOGCM/CONFIG/SHARED/namelist_ref

    r4245 r4292  
    513513!----------------------------------------------------------------------- 
    514514   ln_tide_pot   = .true.   !  use tidal potential forcing 
     515   nb_harmo      =    11    !  number of constituents used 
    515516   clname(1)     =   'M2'   !  name of constituent 
    516517   clname(2)     =   'S2' 
    … …  
    712713   ln_dynadv_cen2= .false. !  flux form - 2nd order centered scheme 
    713714   ln_dynadv_ubs = .false. !  flux form - 3rd order UBS      scheme 
     715/ 
     716!----------------------------------------------------------------------- 
     717&nam_vvl    !   vertical coordinate options 
     718!----------------------------------------------------------------------- 
     719   ln_vvl_zstar  = .true.           !  zstar vertical coordinate                    
     720   ln_vvl_ztilde = .false.          !  ztilde vertical coordinate: only high frequency variations 
     721   ln_vvl_layer  = .false.          !  full layer vertical coordinate 
     722   ln_vvl_ztilde_as_zstar = .false. !  ztilde vertical coordinate emulating zstar 
     723   rn_ahe3       = 0.0e0            !  thickness diffusion coefficient 
     724   rn_rst_e3t    = 30.e0            !  ztilde to zstar restoration timescale [days] 
     725   rn_lf_cutoff  = 5.0e0            !  cutoff frequency for low-pass filter  [days] 
     726   rn_zdef_max   = 0.9e0            !  maximum fractional e3t deformation 
     727   ln_vvl_dbg    = .true.           !  debug prints    (T/F) 
    714728/ 
    715729!----------------------------------------------------------------------- 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/LIM_SRC_2/limsbc_2.F90

    r4148 r4292  
    2424   USE phycst           ! physical constants 
    2525   USE dom_oce          ! ocean domain 
     26   USE domvvl           ! ocean vertical scale factors 
    2627   USE dom_ice_2        ! LIM-2: ice domain 
    2728   USE ice_2            ! LIM-2: ice variables 
    … …  
    5960   !! * Substitutions 
    6061#  include "vectopt_loop_substitute.h90" 
     62#  include "domzgr_substitute.h90" 
    6163   !!---------------------------------------------------------------------- 
    6264   !! NEMO/LIM2 4.0 , UCL - NEMO Consortium (2011) 
    … …  
    446448      !!------------------------------------------------------------------- 
    447449      ! 
     450      INTEGER :: jk           ! local integer 
     451      ! 
    448452      IF(lwp) WRITE(numout,*) 
    449453      IF(lwp) WRITE(numout,*) 'lim_sbc_init_2 : LIM-2 sea-ice - surface boundary condition' 
    … …  
    472476         snwice_mass  (:,:) = 0.e0           ! no mass exchanges 
    473477         snwice_mass_b(:,:) = 0.e0           ! no mass exchanges 
     478         snwice_fmass (:,:) = 0.e0           ! no mass exchanges 
    474479      ENDIF 
    475480      IF( nn_ice_embd == 2 .AND.          &  ! full embedment (case 2) & no restart :  
    … …  
    477482         sshn(:,:) = sshn(:,:) - snwice_mass(:,:) * r1_rau0 
    478483         sshb(:,:) = sshb(:,:) - snwice_mass(:,:) * r1_rau0 
     484         do jk = 1,jpkm1                     ! adjust initial vertical scale factors 
     485          fse3t_n(:,:,jk) = e3t_0(:,:,jk)*( 1._wp + sshn(:,:)*tmask(:,:,1)/(ht_0(:,:) + 1.0 - tmask(:,:,1)) ) 
     486          fse3t_b(:,:,jk) = e3t_0(:,:,jk)*( 1._wp + sshb(:,:)*tmask(:,:,1)/(ht_0(:,:) + 1.0 - tmask(:,:,1)) ) 
     487         end do 
     488         fse3t_a(:,:,:) = fse3t_b(:,:,:) 
     489         ! Reconstruction of all vertical scale factors at now and before time steps 
     490         ! ============================================================================= 
     491         ! Horizontal scale factor interpolations 
     492         ! -------------------------------------- 
     493         CALL dom_vvl_interpol( fse3t_b(:,:,:), fse3u_b(:,:,:), 'U' ) 
     494         CALL dom_vvl_interpol( fse3t_b(:,:,:), fse3v_b(:,:,:), 'V' ) 
     495         CALL dom_vvl_interpol( fse3t_n(:,:,:), fse3u_n(:,:,:), 'U' ) 
     496         CALL dom_vvl_interpol( fse3t_n(:,:,:), fse3v_n(:,:,:), 'V' ) 
     497         CALL dom_vvl_interpol( fse3u_n(:,:,:), fse3f_n(:,:,:), 'F' ) 
     498         ! Vertical scale factor interpolations 
     499         ! ------------------------------------ 
     500         CALL dom_vvl_interpol( fse3t_n(:,:,:), fse3w_n (:,:,:), 'W'  ) 
     501         CALL dom_vvl_interpol( fse3u_n(:,:,:), fse3uw_n(:,:,:), 'UW' ) 
     502         CALL dom_vvl_interpol( fse3v_n(:,:,:), fse3vw_n(:,:,:), 'VW' ) 
     503         CALL dom_vvl_interpol( fse3u_b(:,:,:), fse3uw_b(:,:,:), 'UW' ) 
     504         CALL dom_vvl_interpol( fse3v_b(:,:,:), fse3vw_b(:,:,:), 'VW' ) 
     505         ! t- and w- points depth 
     506         ! ---------------------- 
     507         fsdept_n(:,:,1) = 0.5_wp * fse3w_n(:,:,1) 
     508         fsdepw_n(:,:,1) = 0.0_wp 
     509         fsde3w_n(:,:,1) = fsdept_n(:,:,1) - sshn(:,:) 
     510         DO jk = 2, jpk 
     511            fsdept_n(:,:,jk) = fsdept_n(:,:,jk-1) + fse3w_n(:,:,jk) 
     512            fsdepw_n(:,:,jk) = fsdepw_n(:,:,jk-1) + fse3t_n(:,:,jk-1) 
     513            fsde3w_n(:,:,jk) = fsdept_n(:,:,jk  ) - sshn   (:,:) 
     514         END DO 
    479515      ENDIF 
    480516      ! 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/LIM_SRC_2/limthd_2.F90

    r4147 r4292  
    237237             
    238238            !  energy needed to bring ocean surface layer until its freezing 
    239             qcmif  (ji,jj) =  rau0 * rcp * fse3t_m(ji,jj,1) * ( tfu(ji,jj) - sst_m(ji,jj) - rt0 ) * ( 1 - zinda ) 
     239            qcmif  (ji,jj) =  rau0 * rcp * fse3t_m(ji,jj) * ( tfu(ji,jj) - sst_m(ji,jj) - rt0 ) * ( 1 - zinda ) 
    240240             
    241241            !  calculate oceanic heat flux. 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/NST_SRC/agrif_oce.F90

    r4147 r4292  
    4040   INTEGER :: e1u_id, e2v_id, sshn_id, gcb_id 
    4141   INTEGER :: trn_id, trb_id, tra_id 
     42   INTEGER :: unb_id, vnb_id 
    4243 
    4344   !!---------------------------------------------------------------------- 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90

    r3294 r4292  
    2727   USE agrif_opa_sponge 
    2828   USE lib_mpp 
    29    USE wrk_nemo   
     29   USE wrk_nemo 
     30   USE dynspg_oce   
    3031 
    3132   IMPLICIT NONE 
    3233   PRIVATE 
     34 
     35   ! Barotropic arrays used to store open boundary data during 
     36   ! time-splitting loop: 
     37   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) ::  ubdy_w, vbdy_w, hbdy_w 
     38   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) ::  ubdy_e, vbdy_e, hbdy_e 
     39   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) ::  ubdy_n, vbdy_n, hbdy_n 
     40   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) ::  ubdy_s, vbdy_s, hbdy_s 
    3341     
    34    PUBLIC   Agrif_tra, Agrif_dyn, Agrif_ssh, interpu, interpv 
     42   PUBLIC   Agrif_tra, Agrif_dyn, Agrif_ssh, Agrif_dyn_ts, Agrif_ssh_ts 
     43   PUBLIC   interpu, interpv, interpunb, interpvnb, interpsshn 
    3544 
    3645#  include "domzgr_substitute.h90"   
    … …  
    169178      REAL(wp) :: timeref 
    170179      REAL(wp) :: z2dt, znugdt 
    171       REAL(wp) :: zrhox, rhoy 
     180      REAL(wp) :: zrhox, zrhoy 
    172181      REAL(wp), POINTER, DIMENSION(:,:,:) :: zua, zva 
    173182      REAL(wp), POINTER, DIMENSION(:,:) :: spgv1, spgu1, zua2d, zva2d 
    … …  
    180189 
    181190      zrhox = Agrif_Rhox() 
    182       rhoy = Agrif_Rhoy() 
     191      zrhoy = Agrif_Rhoy() 
    183192 
    184193      timeref = 1. 
    … …  
    201210      zva2d = 0. 
    202211 
     212#if defined key_dynspg_flt 
    203213      Agrif_SpecialValue=0. 
    204214      Agrif_UseSpecialValue = ln_spc_dyn 
    205215      CALL Agrif_Bc_variable(zua2d,e1u_id,calledweight=1.,procname=interpu2d) 
    206216      CALL Agrif_Bc_variable(zva2d,e2v_id,calledweight=1.,procname=interpv2d) 
     217#endif 
    207218      Agrif_UseSpecialValue = .FALSE. 
    208219 
    … …  
    210221      IF((nbondi == -1).OR.(nbondi == 2)) THEN 
    211222 
     223#if defined key_dynspg_flt 
    212224         DO jj=1,jpj 
    213             laplacu(2,jj) = timeref * (zua2d(2,jj)/(rhoy*e2u(2,jj)))*umask(2,jj,1) 
    214          END DO 
    215  
    216          DO jk=1,jpkm1 
    217             DO jj=1,jpj 
    218                ua(1:2,jj,jk) = (zua(1:2,jj,jk)/(rhoy*e2u(1:2,jj))) 
     225            laplacu(2,jj) = timeref * (zua2d(2,jj)/(zrhoy*e2u(2,jj)))*umask(2,jj,1) 
     226         END DO 
     227#endif 
     228 
     229         DO jk=1,jpkm1 
     230            DO jj=1,jpj 
     231               ua(1:2,jj,jk) = (zua(1:2,jj,jk)/(zrhoy*e2u(1:2,jj))) 
    219232               ua(1:2,jj,jk) = ua(1:2,jj,jk) / fse3u(1:2,jj,jk) 
    220233            END DO 
    221234         END DO 
    222235 
     236#if defined key_dynspg_flt 
    223237         DO jk=1,jpkm1 
    224238            DO jj=1,jpj 
    … …  
    240254            ENDIF 
    241255         END DO 
     256#else 
     257         spgu(2,:) = ua_b(2,:) 
     258#endif 
    242259 
    243260         DO jk=1,jpkm1 
    … …  
    278295 
    279296      IF((nbondi == 1).OR.(nbondi == 2)) THEN 
    280  
     297#if defined key_dynspg_flt 
    281298         DO jj=1,jpj 
    282             laplacu(nlci-2,jj) = timeref * (zua2d(nlci-2,jj)/(rhoy*e2u(nlci-2,jj))) 
    283          END DO 
    284  
    285          DO jk=1,jpkm1 
    286             DO jj=1,jpj 
    287                ua(nlci-2:nlci-1,jj,jk) = (zua(nlci-2:nlci-1,jj,jk)/(rhoy*e2u(nlci-2:nlci-1,jj))) 
     299            laplacu(nlci-2,jj) = timeref * (zua2d(nlci-2,jj)/(zrhoy*e2u(nlci-2,jj))) 
     300         END DO 
     301#endif 
     302 
     303         DO jk=1,jpkm1 
     304            DO jj=1,jpj 
     305               ua(nlci-2:nlci-1,jj,jk) = (zua(nlci-2:nlci-1,jj,jk)/(zrhoy*e2u(nlci-2:nlci-1,jj))) 
    288306 
    289307               ua(nlci-2:nlci-1,jj,jk) = ua(nlci-2:nlci-1,jj,jk) / fse3u(nlci-2:nlci-1,jj,jk) 
    … …  
    292310         END DO 
    293311 
     312#if defined key_dynspg_flt 
    294313         DO jk=1,jpkm1 
    295314            DO jj=1,jpj 
    … …  
    312331            ENDIF 
    313332         END DO 
     333#else 
     334         spgu(nlci-2,:) = ua_b(nlci-2,:) 
     335#endif 
    314336 
    315337         DO jk=1,jpkm1 
    … …  
    353375      IF((nbondj == -1).OR.(nbondj == 2)) THEN 
    354376 
     377#if defined key_dynspg_flt 
    355378         DO ji=1,jpi 
    356379            laplacv(ji,2) = timeref * (zva2d(ji,2)/(zrhox*e1v(ji,2))) 
    357380         END DO 
     381#endif 
    358382 
    359383         DO jk=1,jpkm1 
    … …  
    364388         END DO 
    365389 
     390#if defined key_dynspg_flt 
    366391         DO jk=1,jpkm1 
    367392            DO ji=1,jpi 
    … …  
    383408            ENDIF 
    384409         END DO 
     410#else 
     411         spgv(:,2)=va_b(:,2) 
     412#endif 
    385413 
    386414         DO jk=1,jpkm1 
    … …  
    413441         DO jk=1,jpkm1 
    414442            DO ji=1,jpi 
    415                ua(ji,2,jk) = (zua(ji,2,jk)/(rhoy*e2u(ji,2)))*umask(ji,2,jk)  
     443               ua(ji,2,jk) = (zua(ji,2,jk)/(zrhoy*e2u(ji,2)))*umask(ji,2,jk)  
    416444               ua(ji,2,jk) = ua(ji,2,jk) / fse3u(ji,2,jk) 
    417445            END DO 
    … …  
    422450      IF((nbondj == 1).OR.(nbondj == 2)) THEN 
    423451 
     452#if defined key_dynspg_flt 
    424453         DO ji=1,jpi 
    425454            laplacv(ji,nlcj-2) = timeref * (zva2d(ji,nlcj-2)/(zrhox*e1v(ji,nlcj-2))) 
    426455         END DO 
     456#endif 
    427457 
    428458         DO jk=1,jpkm1 
    … …  
    433463         END DO 
    434464 
     465#if defined key_dynspg_flt 
    435466         DO jk=1,jpkm1 
    436467            DO ji=1,jpi 
    … …  
    438469            END DO 
    439470         END DO 
    440  
    441471 
    442472         spgv(:,nlcj-2)=0. 
    … …  
    453483            ENDIF 
    454484         END DO 
     485#else 
     486         spgv(:,nlcj-2)=va_b(:,nlcj-2) 
     487#endif 
    455488 
    456489         DO jk=1,jpkm1 
    … …  
    483516         DO jk=1,jpkm1 
    484517            DO ji=1,jpi 
    485                ua(ji,nlcj-1,jk) = (zua(ji,nlcj-1,jk)/(rhoy*e2u(ji,nlcj-1)))*umask(ji,nlcj-1,jk) 
     518               ua(ji,nlcj-1,jk) = (zua(ji,nlcj-1,jk)/(zrhoy*e2u(ji,nlcj-1)))*umask(ji,nlcj-1,jk) 
    486519               ua(ji,nlcj-1,jk) = ua(ji,nlcj-1,jk) / fse3u(ji,nlcj-1,jk) 
    487520            END DO 
    … …  
    495528   END SUBROUTINE Agrif_dyn 
    496529 
     530   SUBROUTINE Agrif_dyn_ts( kt, jn ) 
     531      !!---------------------------------------------------------------------- 
     532      !!                  ***  ROUTINE Agrif_dyn_ts  *** 
     533      !!----------------------------------------------------------------------   
     534      !!  
     535      INTEGER, INTENT(in) ::   kt, jn 
     536      !! 
     537      INTEGER :: ji, jj 
     538      REAL(wp) :: zrhox, zrhoy 
     539      REAL(wp), POINTER, DIMENSION(:,:) :: spgv1, spgu1 
     540      REAL(wp), POINTER, DIMENSION(:,:) :: zunb, zvnb, zsshn 
     541      !!----------------------------------------------------------------------   
     542 
     543      IF( Agrif_Root() )   RETURN 
     544 
     545      IF ((kt==nit000).AND.(jn==1)) THEN 
     546         ALLOCATE( ubdy_w(jpj), vbdy_w(jpj), hbdy_w(jpj)) 
     547         ALLOCATE( ubdy_e(jpj), vbdy_e(jpj), hbdy_e(jpj)) 
     548         ALLOCATE( ubdy_n(jpi), vbdy_n(jpi), hbdy_n(jpi)) 
     549         ALLOCATE( ubdy_s(jpi), vbdy_s(jpi), hbdy_s(jpi)) 
     550      ENDIF 
     551 
     552      IF (jn==1) THEN  
     553         ! Fill boundary arrays at each baroclinic step  
     554         ! with Parent grid barotropic fluxes and sea level 
     555         ! 
     556         CALL wrk_alloc( jpi, jpj, zunb, zvnb, zsshn ) 
     557 
     558         zrhox = Agrif_Rhox() 
     559         zrhoy = Agrif_Rhoy() 
     560 
     561!alt         Agrif_SpecialValue    = 0.e0 
     562!alt         Agrif_UseSpecialValue = .TRUE. 
     563!alt         CALL Agrif_Bc_variable(zsshn, sshn_id, procname=interpsshn ) 
     564!alt         Agrif_UseSpecialValue = .FALSE. 
     565 
     566         Agrif_SpecialValue=0. 
     567         Agrif_UseSpecialValue = ln_spc_dyn 
     568         zunb(:,:) = 0._wp ; zvnb(:,:) = 0._wp 
     569         CALL Agrif_Bc_variable(zunb,unb_id,procname=interpunb) 
     570         CALL Agrif_Bc_variable(zvnb,vnb_id,procname=interpvnb) 
     571         Agrif_UseSpecialValue = .FALSE. 
     572 
     573         IF((nbondi == -1).OR.(nbondi == 2)) THEN 
     574            DO jj=1,jpj 
     575               ubdy_w(jj) = (zunb(2,jj)/(zrhoy*e2u(2,jj))) 
     576               vbdy_w(jj) = (zvnb(2,jj)/(zrhox*e1v(2,jj))) 
     577               hbdy_w(jj) = zsshn(2,jj) 
     578            END DO 
     579         ENDIF 
     580 
     581         IF((nbondi == 1).OR.(nbondi == 2)) THEN 
     582            DO jj=1,jpj 
     583               ubdy_e(jj) = zunb(nlci-2,jj)/(zrhoy*e2u(nlci-2,jj)) 
     584               vbdy_e(jj) = zvnb(nlci-1,jj)/(zrhox*e1v(nlci-1,jj)) 
     585               hbdy_e(jj) = zsshn(nlci-1,jj) 
     586            END DO 
     587         ENDIF 
     588 
     589         IF((nbondj == -1).OR.(nbondj == 2)) THEN 
     590            DO ji=1,jpi 
     591               ubdy_s(ji) = zunb(ji,2)/(zrhoy*e2u(ji,2)) 
     592               vbdy_s(ji) = zvnb(ji,2)/(zrhox*e1v(ji,2)) 
     593               hbdy_s(ji) = zsshn(ji,2) 
     594            END DO 
     595         ENDIF 
     596 
     597         IF((nbondj == 1).OR.(nbondj == 2)) THEN 
     598            DO ji=1,jpi 
     599               ubdy_n(ji) = zunb(ji,nlcj-1)/(zrhoy*e2u(ji,nlcj-1)) 
     600               vbdy_n(ji) = zvnb(ji,nlcj-2)/(zrhox*e1v(ji,nlcj-2)) 
     601               hbdy_n(ji) = zsshn(ji,nlcj-1) 
     602            END DO 
     603         ENDIF 
     604 
     605         CALL wrk_dealloc( jpi, jpj, zunb, zvnb, zsshn ) 
     606      ENDIF ! jn==1 
     607 
     608      ! Then update velocities at each barotropic time step 
     609      IF((nbondi == -1).OR.(nbondi == 2)) THEN 
     610         DO jj=1,jpj 
     611            va_e(2,jj) = vbdy_w(jj) * hvr_e(2,jj) 
     612! Specified fluxes: 
     613            ua_e(2,jj) = ubdy_w(jj) * hur_e(2,jj) 
     614! Characteristics method: 
     615!alt            ua_e(2,jj) = 0.5_wp * ( ubdy_w(jj) * hur_e(2,jj) + ua_e(3,jj) & 
     616!alt                       &           - sqrt(grav * hur_e(2,jj)) * (sshn_e(3,jj) - hbdy_w(jj)) ) 
     617         END DO 
     618      ENDIF 
     619 
     620      IF((nbondi == 1).OR.(nbondi == 2)) THEN 
     621         DO jj=1,jpj 
     622            va_e(nlci-1,jj) = vbdy_e(jj) * hvr_e(nlci-1,jj) 
     623! Specified fluxes: 
     624            ua_e(nlci-2,jj) = ubdy_e(jj) * hur_e(nlci-2,jj) 
     625! Characteristics method: 
     626!alt            ua_e(nlci-2,jj) = 0.5_wp * ( ubdy_e(jj) * hur_e(nlci-2,jj) + ua_e(nlci-3,jj) & 
     627!alt                            &           + sqrt(grav * hur_e(nlci-2,jj)) * (sshn_e(nlci-2,jj) - hbdy_e(jj)) ) 
     628         END DO 
     629      ENDIF 
     630 
     631      IF((nbondj == -1).OR.(nbondj == 2)) THEN 
     632         DO ji=1,jpi 
     633            ua_e(ji,2) = ubdy_s(ji) * hur_e(ji,2) 
     634! Specified fluxes: 
     635            va_e(ji,2) = vbdy_s(ji) * hvr_e(ji,2) 
     636! Characteristics method: 
     637!alt            va_e(ji,2) = 0.5_wp * ( vbdy_s(ji) * hvr_e(ji,2) + va_e(ji,3) & 
     638!alt                       &           - sqrt(grav * hvr_e(ji,2)) * (sshn_e(ji,3) - hbdy_s(ji)) ) 
     639         END DO 
     640      ENDIF 
     641 
     642      IF((nbondj == 1).OR.(nbondj == 2)) THEN 
     643         DO ji=1,jpi 
     644            ua_e(ji,nlcj-1) = ubdy_n(ji) * hur_e(ji,nlcj-1) 
     645! Specified fluxes: 
     646            va_e(ji,nlcj-2) = vbdy_n(ji) * hvr_e(ji,nlcj-2) 
     647! Characteristics method: 
     648!alt            va_e(ji,nlcj-2) = 0.5_wp * ( vbdy_n(ji) * hvr_e(ji,nlcj-2)  + va_e(ji,nlcj-3) & 
     649!alt                            &           + sqrt(grav * hvr_e(ji,nlcj-2)) * (sshn_e(ji,nlcj-2) - hbdy_n(ji)) ) 
     650         END DO 
     651      ENDIF 
     652      ! 
     653   END SUBROUTINE Agrif_dyn_ts 
    497654 
    498655   SUBROUTINE Agrif_ssh( kt ) 
    … …  
    518675 
    519676      IF((nbondj == -1).OR.(nbondj == 2)) THEN 
    520          ssha(:,2)=sshn(:,3) 
    521          sshn(:,2)=sshb(:,3) 
     677         ssha(:,2)=ssha(:,3) 
     678         sshn(:,2)=sshn(:,3) 
    522679      ENDIF 
    523680 
    524681      IF((nbondj == 1).OR.(nbondj == 2)) THEN 
    525682         ssha(:,nlcj-1)=ssha(:,nlcj-2) 
    526          ssha(:,nlcj-1)=sshn(:,nlcj-2)                 
     683         sshn(:,nlcj-1)=sshn(:,nlcj-2)                 
    527684      ENDIF 
    528685 
    529686   END SUBROUTINE Agrif_ssh 
    530687 
     688   SUBROUTINE Agrif_ssh_ts( kt ) 
     689      !!---------------------------------------------------------------------- 
     690      !!                  ***  ROUTINE Agrif_ssh_ts  *** 
     691      !!----------------------------------------------------------------------   
     692      INTEGER, INTENT(in) ::   kt 
     693      !! 
     694      !!----------------------------------------------------------------------   
     695 
     696      IF((nbondi == -1).OR.(nbondi == 2)) THEN 
     697         ssha_e(2,:) = ssha_e(3,:) 
     698      ENDIF 
     699 
     700      IF((nbondi == 1).OR.(nbondi == 2)) THEN 
     701         ssha_e(nlci-1,:) = ssha_e(nlci-2,:)     
     702      ENDIF 
     703 
     704      IF((nbondj == -1).OR.(nbondj == 2)) THEN 
     705         ssha_e(:,2) = ssha_e(:,3) 
     706      ENDIF 
     707 
     708      IF((nbondj == 1).OR.(nbondj == 2)) THEN 
     709         ssha_e(:,nlcj-1) = ssha_e(:,nlcj-2)             
     710      ENDIF 
     711 
     712   END SUBROUTINE Agrif_ssh_ts 
     713 
     714   SUBROUTINE interpsshn(tabres,i1,i2,j1,j2) 
     715      !!---------------------------------------------------------------------- 
     716      !!                  ***  ROUTINE interpsshn  *** 
     717      !!----------------------------------------------------------------------   
     718      INTEGER, INTENT(in) :: i1,i2,j1,j2 
     719      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
     720      !! 
     721      INTEGER :: ji,jj 
     722      !!----------------------------------------------------------------------   
     723 
     724      tabres(i1:i2,j1:j2) = sshn(i1:i2,j1:j2) 
     725 
     726   END SUBROUTINE interpsshn 
    531727 
    532728   SUBROUTINE interpu(tabres,i1,i2,j1,j2,k1,k2) 
    … …  
    611807 
    612808   END SUBROUTINE interpv2d 
     809 
     810   SUBROUTINE interpunb(tabres,i1,i2,j1,j2) 
     811      !!---------------------------------------------------------------------- 
     812      !!                  ***  ROUTINE interpunb  *** 
     813      !!----------------------------------------------------------------------   
     814      INTEGER, INTENT(in) :: i1,i2,j1,j2 
     815      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
     816      !! 
     817      INTEGER :: ji,jj,jk 
     818      !!----------------------------------------------------------------------   
     819 
     820      tabres(:,:) = 0.e0 
     821      DO jk=1,jpkm1 
     822         DO jj=j1,j2 
     823            DO ji=i1,i2 
     824               tabres(ji,jj) = tabres(ji,jj) + e2u(ji,jj) * un(ji,jj,jk) & 
     825                  * umask(ji,jj,jk) * fse3u(ji,jj,jk) 
     826            END DO 
     827         END DO 
     828      END DO 
     829 
     830   END SUBROUTINE interpunb 
     831 
     832   SUBROUTINE interpvnb(tabres,i1,i2,j1,j2) 
     833      !!---------------------------------------------------------------------- 
     834      !!                  ***  ROUTINE interpvnb  *** 
     835      !!----------------------------------------------------------------------   
     836      INTEGER, INTENT(in) :: i1,i2,j1,j2 
     837      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
     838      !! 
     839      INTEGER :: ji,jj,jk 
     840      !!----------------------------------------------------------------------   
     841 
     842      tabres(:,:) = 0.e0 
     843      DO jk=1,jpkm1 
     844         DO jj=j1,j2 
     845            DO ji=i1,i2 
     846               tabres(ji,jj) = tabres(ji,jj) + e1v(ji,jj) * vn(ji,jj,jk) & 
     847                  * vmask(ji,jj,jk) * fse3v(ji,jj,jk) 
     848            END DO 
     849         END DO 
     850      END DO 
     851 
     852   END SUBROUTINE interpvnb 
    613853 
    614854#else 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OFF_SRC/domain.F90

    r4248 r4292  
    295295      !!      vertical scale factors. 
    296296      !! 
    297       !! ** Method  : - reference 1D vertical coordinate (gdep._0, e3._0) 
     297      !! ** Method  : - reference 1D vertical coordinate (gdep._1d, e3._1d) 
    298298      !!              - read/set ocean depth and ocean levels (bathy, mbathy) 
    299299      !!              - vertical coordinate (gdep., e3.) depending on the  

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OFF_SRC/domrea.F90

    r3680 r4292  
    2525 
    2626   PUBLIC   dom_rea    ! routine called by inidom.F90 
     27  !! * Substitutions 
     28#  include "domzgr_substitute.h90" 
    2729   !!---------------------------------------------------------------------- 
    2830   !! NEMO/OFF 3.3 , NEMO Consortium (2010) 
    … …  
    173175            CALL iom_get( inum4, jpdom_unknown, 'esigw', esigw ) 
    174176 
    175             CALL iom_get( inum4, jpdom_data, 'e3t', e3t ) ! scale factors 
    176             CALL iom_get( inum4, jpdom_data, 'e3u', e3u ) 
    177             CALL iom_get( inum4, jpdom_data, 'e3v', e3v ) 
    178             CALL iom_get( inum4, jpdom_data, 'e3w', e3w ) 
    179  
    180             CALL iom_get( inum4, jpdom_unknown, 'gdept_0', gdept_0 ) ! depth 
    181             CALL iom_get( inum4, jpdom_unknown, 'gdepw_0', gdepw_0 ) 
     177            CALL iom_get( inum4, jpdom_data, 'e3t', fse3t_n(:,:,:) ) ! scale factors 
     178            CALL iom_get( inum4, jpdom_data, 'e3u', fse3u_n(:,:,:) ) 
     179            CALL iom_get( inum4, jpdom_data, 'e3v', fse3v_n(:,:,:) ) 
     180            CALL iom_get( inum4, jpdom_data, 'e3w', fse3w_n(:,:,:) ) 
     181 
     182            CALL iom_get( inum4, jpdom_unknown, 'gdept_1d', gdept_1d ) ! depth 
     183            CALL iom_get( inum4, jpdom_unknown, 'gdepw_1d', gdepw_1d ) 
    182184         ENDIF 
    183185 
    184186  
    185187         IF( ln_zps ) THEN                                           ! z-coordinate - partial steps 
    186             CALL iom_get( inum4, jpdom_unknown, 'gdept_0', gdept_0 )    ! reference depth 
    187             CALL iom_get( inum4, jpdom_unknown, 'gdepw_0', gdepw_0 ) 
    188             CALL iom_get( inum4, jpdom_unknown, 'e3t_0'  , e3t_0   )    ! reference scale factors 
    189             CALL iom_get( inum4, jpdom_unknown, 'e3w_0'  , e3w_0   ) 
     188            CALL iom_get( inum4, jpdom_unknown, 'gdept_1d', gdept_1d )  ! reference depth 
     189            CALL iom_get( inum4, jpdom_unknown, 'gdepw_1d', gdepw_1d ) 
     190            CALL iom_get( inum4, jpdom_unknown, 'e3t_1d'  , e3t_1d   )    ! reference scale factors 
     191            CALL iom_get( inum4, jpdom_unknown, 'e3w_1d'  , e3w_1d   ) 
    190192            ! 
    191193            IF( nmsh <= 6 ) THEN                                        ! 3D vertical scale factors 
    192                CALL iom_get( inum4, jpdom_data, 'e3t', e3t ) 
    193                CALL iom_get( inum4, jpdom_data, 'e3u', e3u ) 
    194                CALL iom_get( inum4, jpdom_data, 'e3v', e3v ) 
    195                CALL iom_get( inum4, jpdom_data, 'e3w', e3w ) 
     194               CALL iom_get( inum4, jpdom_data, 'e3t', fse3t_n(:,:,:) ) 
     195               CALL iom_get( inum4, jpdom_data, 'e3u', fse3u_n(:,:,:) ) 
     196               CALL iom_get( inum4, jpdom_data, 'e3v', fse3v_n(:,:,:) ) 
     197               CALL iom_get( inum4, jpdom_data, 'e3w', fse3w_n(:,:,:) ) 
    196198            ELSE                                                        ! 2D bottom scale factors 
    197199               CALL iom_get( inum4, jpdom_data, 'e3t_ps', e3tp ) 
    … …  
    199201               !                                                        ! deduces the 3D scale factors 
    200202               DO jk = 1, jpk 
    201                   e3t(:,:,jk) = e3t_0(jk)                                     ! set to the ref. factors 
    202                   e3u(:,:,jk) = e3t_0(jk) 
    203                   e3v(:,:,jk) = e3t_0(jk) 
    204                   e3w(:,:,jk) = e3w_0(jk) 
     203                  fse3t_n(:,:,jk) = e3t_1d(jk)                                    ! set to the ref. factors 
     204                  fse3u_n(:,:,jk) = e3t_1d(jk) 
     205                  fse3v_n(:,:,jk) = e3t_1d(jk) 
     206                  fse3w_n(:,:,jk) = e3w_1d(jk) 
    205207               END DO 
    206208               DO jj = 1,jpj                                                  ! adjust the deepest values 
    207209                  DO ji = 1,jpi 
    208210                     ik = mbkt(ji,jj) 
    209                      e3t(ji,jj,ik) = e3tp(ji,jj) * tmask(ji,jj,1) + e3t_0(1) * ( 1._wp - tmask(ji,jj,1) ) 
    210                      e3w(ji,jj,ik) = e3wp(ji,jj) * tmask(ji,jj,1) + e3w_0(1) * ( 1._wp - tmask(ji,jj,1) ) 
     211                     fse3t_n(ji,jj,ik) = e3tp(ji,jj) * tmask(ji,jj,1) + e3t_1d(1) * ( 1._wp - tmask(ji,jj,1) ) 
     212                     fse3w_n(ji,jj,ik) = e3wp(ji,jj) * tmask(ji,jj,1) + e3w_1d(1) * ( 1._wp - tmask(ji,jj,1) ) 
    211213                  END DO 
    212214               END DO 
    … …  
    214216                  DO jj = 1, jpjm1 
    215217                     DO ji = 1, jpim1 
    216                         e3u(ji,jj,jk) = MIN( e3t(ji,jj,jk), e3t(ji+1,jj,jk) ) 
    217                         e3v(ji,jj,jk) = MIN( e3t(ji,jj,jk), e3t(ji,jj+1,jk) ) 
     218                        fse3u_n(ji,jj,jk) = MIN( fse3t_n(ji,jj,jk), fse3t_n(ji+1,jj,jk) ) 
     219                        fse3v_n(ji,jj,jk) = MIN( fse3t_n(ji,jj,jk), fse3t_n(ji,jj+1,jk) ) 
    218220                     END DO 
    219221                  END DO 
    220222               END DO 
    221                CALL lbc_lnk( e3u , 'U', 1._wp )   ;   CALL lbc_lnk( e3uw, 'U', 1._wp )   ! lateral boundary conditions 
    222                CALL lbc_lnk( e3v , 'V', 1._wp )   ;   CALL lbc_lnk( e3vw, 'V', 1._wp ) 
     223               CALL lbc_lnk( fse3u_n(:,:,:) , 'U', 1._wp )   ;   CALL lbc_lnk( fse3uw_n(:,:,:), 'U', 1._wp )   ! lateral boundary conditions 
     224               CALL lbc_lnk( fse3v_n(:,:,:) , 'V', 1._wp )   ;   CALL lbc_lnk( fse3vw_n(:,:,:), 'V', 1._wp ) 
    223225               ! 
    224226               DO jk = 1, jpk                        ! set to z-scale factor if zero (i.e. along closed boundaries) 
    225                   WHERE( e3u(:,:,jk) == 0._wp )   e3u(:,:,jk) = e3t_0(jk) 
    226                   WHERE( e3v(:,:,jk) == 0._wp )   e3v(:,:,jk) = e3t_0(jk) 
     227                  WHERE( fse3u_n(:,:,jk) == 0._wp )   fse3u_n(:,:,jk) = e3t_1d(jk) 
     228                  WHERE( fse3v_n(:,:,jk) == 0._wp )   fse3v_n(:,:,jk) = e3t_1d(jk) 
    227229               END DO 
    228230            END IF 
    229231 
    230232            IF( iom_varid( inum4, 'gdept', ldstop = .FALSE. ) > 0 ) THEN   ! 3D depth of t- and w-level 
    231                CALL iom_get( inum4, jpdom_data, 'gdept', gdept ) 
    232                CALL iom_get( inum4, jpdom_data, 'gdepw', gdepw ) 
     233               CALL iom_get( inum4, jpdom_data, 'gdept', fsdept_n(:,:,:) ) 
     234               CALL iom_get( inum4, jpdom_data, 'gdepw', fsdepw_n(:,:,:) ) 
    233235            ELSE                                                           ! 2D bottom depth 
    234236               CALL iom_get( inum4, jpdom_data, 'hdept', zprt ) 
    … …  
    236238               ! 
    237239               DO jk = 1, jpk                                              ! deduces the 3D depth 
    238                   gdept(:,:,jk) = gdept_0(jk) 
    239                   gdepw(:,:,jk) = gdepw_0(jk) 
     240                  fsdept_n(:,:,jk) = gdept_1d(jk) 
     241                  fsdepw_n(:,:,jk) = gdepw_1d(jk) 
    240242               END DO 
    241243               DO jj = 1, jpj 
    … …  
    243245                     ik = mbkt(ji,jj) 
    244246                     IF( ik > 0 ) THEN 
    245                         gdepw(ji,jj,ik+1) = zprw(ji,jj) 
    246                         gdept(ji,jj,ik  ) = zprt(ji,jj) 
    247                         gdept(ji,jj,ik+1) = gdept(ji,jj,ik) + e3t(ji,jj,ik) 
     247                        fsdepw_n(ji,jj,ik+1) = zprw(ji,jj) 
     248                        fsdept_n(ji,jj,ik  ) = zprt(ji,jj) 
     249                        fsdept_n(ji,jj,ik+1) = fsdept_n(ji,jj,ik) + fse3t_n(ji,jj,ik) 
    248250                     ENDIF 
    249251                  END DO 
    … …  
    254256 
    255257         IF( ln_zco ) THEN           ! Vertical coordinates and scales factors 
    256             CALL iom_get( inum4, jpdom_unknown, 'gdept_0', gdept_0 ) ! depth 
    257             CALL iom_get( inum4, jpdom_unknown, 'gdepw_0', gdepw_0 ) 
    258             CALL iom_get( inum4, jpdom_unknown, 'e3t_0'  , e3t_0   ) 
    259             CALL iom_get( inum4, jpdom_unknown, 'e3w_0'  , e3w_0   ) 
     258            CALL iom_get( inum4, jpdom_unknown, 'gdept_1d', gdept_1d ) ! depth 
     259            CALL iom_get( inum4, jpdom_unknown, 'gdepw_1d', gdepw_1d ) 
     260            CALL iom_get( inum4, jpdom_unknown, 'e3t_1d'  , e3t_1d   ) 
     261            CALL iom_get( inum4, jpdom_unknown, 'e3w_1d'  , e3w_1d   ) 
    260262            DO jk = 1, jpk 
    261                e3t  (:,:,jk) = e3t_0(jk)                                     ! set to the ref. factors 
    262                e3u  (:,:,jk) = e3t_0(jk) 
    263                e3v  (:,:,jk) = e3t_0(jk) 
    264                e3w  (:,:,jk) = e3w_0(jk) 
    265                gdept(:,:,jk) = gdept_0(jk) 
    266                gdepw(:,:,jk) = gdepw_0(jk) 
     263               fse3t_n(:,:,jk) = e3t_1d(jk)                              ! set to the ref. factors 
     264               fse3u_n(:,:,jk) = e3t_1d(jk) 
     265               fse3v_n(:,:,jk) = e3t_1d(jk) 
     266               fse3w_n(:,:,jk) = e3w_1d(jk) 
     267               fsdept_n(:,:,jk) = gdept_1d(jk) 
     268               fsdepw_n(:,:,jk) = gdepw_1d(jk) 
    267269            END DO 
    268270         ENDIF 
    … …  
    270272!!gm BUG in s-coordinate this does not work! 
    271273      ! deepest/shallowest W level Above/Below ~10m 
    272       zrefdep = 10._wp - ( 0.1_wp * MINVAL(e3w_0) )                  ! ref. depth with tolerance (10% of minimum layer thickness) 
    273       nlb10 = MINLOC( gdepw_0, mask = gdepw_0 > zrefdep, dim = 1 )  ! shallowest W level Below ~10m 
     274      zrefdep = 10._wp - ( 0.1_wp * MINVAL(e3w_1d) )                 ! ref. depth with tolerance (10% of minimum layer thickness) 
     275      nlb10 = MINLOC( gdepw_1d, mask = gdepw_1d > zrefdep, dim = 1 ) ! shallowest W level Below ~10m 
    274276      nla10 = nlb10 - 1                                              ! deepest    W level Above ~10m 
    275277!!gm end bug 
    … …  
    312314         WRITE(numout,*) '              Reference z-coordinate depth and scale factors:' 
    313315         WRITE(numout, "(9x,' level   gdept    gdepw     e3t      e3w  ')" ) 
    314          WRITE(numout, "(10x, i4, 4f9.2)" ) ( jk, gdept_0(jk), gdepw_0(jk), e3t_0(jk), e3w_0(jk), jk = 1, jpk ) 
     316         WRITE(numout, "(10x, i4, 4f9.2)" ) ( jk, gdept_1d(jk), gdepw_1d(jk), e3t_1d(jk), e3w_1d(jk), jk = 1, jpk ) 
    315317      ENDIF 
    316318 
    317319      DO jk = 1, jpk 
    318          IF( e3w_0  (jk) <= 0._wp .OR. e3t_0  (jk) <= 0._wp )   CALL ctl_stop( ' e3w_0 or e3t_0 =< 0 ' ) 
    319          IF( gdepw_0(jk) <  0._wp .OR. gdept_0(jk) <  0._wp )   CALL ctl_stop( ' gdepw_0 or gdept_0 < 0 ' ) 
     320         IF( e3w_1d  (jk) <= 0._wp .OR. e3t_1d  (jk) <= 0._wp )   CALL ctl_stop( ' e3w_1d or e3t_1d =< 0 ' ) 
     321         IF( gdepw_1d(jk) <  0._wp .OR. gdept_1d(jk) <  0._wp )   CALL ctl_stop( ' gdepw_1d or gdept_1d < 0 ' ) 
    320322      END DO 
    321323      !                                     ! ============================ 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/BDY/bdy_oce.F90

    r3651 r4292  
    88   !!            3.3  !  2010-09  (D. Storkey) add ice boundary conditions 
    99   !!            3.4  !  2011     (D. Storkey) rewrite in preparation for OBC-BDY merge 
     10   !!            3.6  !  2012-01  (C. Rousset) add ice boundary conditions for lim3 
    1011   !!---------------------------------------------------------------------- 
    1112#if defined key_bdy  
    … …  
    2728      INTEGER, POINTER, DIMENSION(:,:)   ::  nbr 
    2829      INTEGER, POINTER, DIMENSION(:,:)   ::  nbmap 
    29       REAL   , POINTER, DIMENSION(:,:)   ::  nbw 
    30       REAL   , POINTER, DIMENSION(:,:)   ::  nbd 
    31       REAL   , POINTER, DIMENSION(:)     ::  flagu 
    32       REAL   , POINTER, DIMENSION(:)     ::  flagv 
     30      REAL(wp)   , POINTER, DIMENSION(:,:)   ::  nbw 
     31      REAL(wp)   , POINTER, DIMENSION(:,:)   ::  nbd 
     32      REAL(wp)   , POINTER, DIMENSION(:,:)   ::  nbdout 
     33      REAL(wp)   , POINTER, DIMENSION(:,:)   ::  flagu 
     34      REAL(wp)   , POINTER, DIMENSION(:,:)   ::  flagv 
    3335   END TYPE OBC_INDEX 
    3436 
     37   !! Logicals in OBC_DATA structure are true if the chosen algorithm requires this 
     38   !! field as external data. If true the data can come from external files 
     39   !! or model initial conditions. If false then no "external" data array 
     40   !! is required for this field.  
     41 
    3542   TYPE, PUBLIC ::   OBC_DATA     !: Storage for external data 
    36       REAL, POINTER, DIMENSION(:)     ::  ssh 
    37       REAL, POINTER, DIMENSION(:)     ::  u2d 
    38       REAL, POINTER, DIMENSION(:)     ::  v2d 
    39       REAL, POINTER, DIMENSION(:,:)   ::  u3d 
    40       REAL, POINTER, DIMENSION(:,:)   ::  v3d 
    41       REAL, POINTER, DIMENSION(:,:)   ::  tem 
    42       REAL, POINTER, DIMENSION(:,:)   ::  sal 
     43      INTEGER,       DIMENSION(2)     ::  nread 
     44      LOGICAL                         ::  ll_ssh 
     45      LOGICAL                         ::  ll_u2d 
     46      LOGICAL                         ::  ll_v2d 
     47      LOGICAL                         ::  ll_u3d 
     48      LOGICAL                         ::  ll_v3d 
     49      LOGICAL                         ::  ll_tem 
     50      LOGICAL                         ::  ll_sal 
     51      REAL(wp), POINTER, DIMENSION(:)     ::  ssh 
     52      REAL(wp), POINTER, DIMENSION(:)     ::  u2d 
     53      REAL(wp), POINTER, DIMENSION(:)     ::  v2d 
     54      REAL(wp), POINTER, DIMENSION(:,:)   ::  u3d 
     55      REAL(wp), POINTER, DIMENSION(:,:)   ::  v3d 
     56      REAL(wp), POINTER, DIMENSION(:,:)   ::  tem 
     57      REAL(wp), POINTER, DIMENSION(:,:)   ::  sal 
    4358#if defined key_lim2 
    44       REAL, POINTER, DIMENSION(:)     ::  frld 
    45       REAL, POINTER, DIMENSION(:)     ::  hicif 
    46       REAL, POINTER, DIMENSION(:)     ::  hsnif 
     59      LOGICAL                         ::  ll_frld 
     60      LOGICAL                         ::  ll_hicif 
     61      LOGICAL                         ::  ll_hsnif 
     62      REAL(wp), POINTER, DIMENSION(:)     ::  frld 
     63      REAL(wp), POINTER, DIMENSION(:)     ::  hicif 
     64      REAL(wp), POINTER, DIMENSION(:)     ::  hsnif 
     65#elif defined key_lim3 
     66      LOGICAL                         ::  ll_a_i 
     67      LOGICAL                         ::  ll_ht_i 
     68      LOGICAL                         ::  ll_ht_s 
     69      REAL, POINTER, DIMENSION(:,:)   ::  a_i   !: now ice leads fraction climatology 
     70      REAL, POINTER, DIMENSION(:,:)   ::  ht_i  !: Now ice  thickness climatology 
     71      REAL, POINTER, DIMENSION(:,:)   ::  ht_s  !: now snow thickness 
    4772#endif 
    4873   END TYPE OBC_DATA 
    … …  
    6388   INTEGER                    ::   nn_volctl                !: = 0 the total volume will have the variability of the surface Flux E-P  
    6489   !                                                        !  = 1 the volume will be constant during all the integration. 
    65    INTEGER, DIMENSION(jp_bdy) ::   nn_dyn2d                 ! Choice of boundary condition for barotropic variables (U,V,SSH) 
    66    INTEGER, DIMENSION(jp_bdy) ::   nn_dyn2d_dta           !: = 0 use the initial state as bdy dta ;  
     90   CHARACTER(len=20), DIMENSION(jp_bdy) ::   cn_dyn2d       ! Choice of boundary condition for barotropic variables (U,V,SSH) 
     91   INTEGER, DIMENSION(jp_bdy)           ::   nn_dyn2d_dta   !: = 0 use the initial state as bdy dta ;  
    6792                                                            !: = 1 read it in a NetCDF file 
    6893                                                            !: = 2 read tidal harmonic forcing from a NetCDF file 
    6994                                                            !: = 3 read external data AND tidal harmonic forcing from NetCDF files 
    70    INTEGER, DIMENSION(jp_bdy) ::   nn_dyn3d                 ! Choice of boundary condition for baroclinic velocities  
    71    INTEGER, DIMENSION(jp_bdy) ::   nn_dyn3d_dta           !: = 0 use the initial state as bdy dta ;  
     95   CHARACTER(len=20), DIMENSION(jp_bdy) ::   cn_dyn3d       ! Choice of boundary condition for baroclinic velocities  
     96   INTEGER, DIMENSION(jp_bdy)           ::   nn_dyn3d_dta   !: = 0 use the initial state as bdy dta ;  
    7297                                                            !: = 1 read it in a NetCDF file 
    73    INTEGER, DIMENSION(jp_bdy) ::   nn_tra                   ! Choice of boundary condition for active tracers (T and S) 
    74    INTEGER, DIMENSION(jp_bdy) ::   nn_tra_dta             !: = 0 use the initial state as bdy dta ;  
     98   CHARACTER(len=20), DIMENSION(jp_bdy) ::   cn_tra         ! Choice of boundary condition for active tracers (T and S) 
     99   INTEGER, DIMENSION(jp_bdy)           ::   nn_tra_dta     !: = 0 use the initial state as bdy dta ;  
    75100                                                            !: = 1 read it in a NetCDF file 
    76101   LOGICAL, DIMENSION(jp_bdy) ::   ln_tra_dmp               !: =T Tracer damping 
    77102   LOGICAL, DIMENSION(jp_bdy) ::   ln_dyn3d_dmp             !: =T Baroclinic velocity damping 
    78    REAL,    DIMENSION(jp_bdy) ::   rn_time_dmp              !: Damping time scale in days 
     103   REAL(wp),    DIMENSION(jp_bdy) ::   rn_time_dmp              !: Damping time scale in days 
     104   REAL(wp),    DIMENSION(jp_bdy) ::   rn_time_dmp_out          !: Damping time scale in days at radiation outflow points 
    79105 
    80106#if defined key_lim2 
    81    INTEGER, DIMENSION(jp_bdy) ::   nn_ice_lim2              ! Choice of boundary condition for sea ice variables  
    82    INTEGER, DIMENSION(jp_bdy) ::   nn_ice_lim2_dta          !: = 0 use the initial state as bdy dta ;  
    83                                                             !: = 1 read it in a NetCDF file 
     107   CHARACTER(len=20), DIMENSION(jp_bdy) ::   nn_ice_lim2      ! Choice of boundary condition for sea ice variables  
     108   INTEGER, DIMENSION(jp_bdy)           ::   nn_ice_lim2_dta  !: = 0 use the initial state as bdy dta ;  
     109                                                              !: = 1 read it in a NetCDF file 
    84110#endif 
    85111   ! 
    … …  
    88114   !! Global variables 
    89115   !!---------------------------------------------------------------------- 
    90    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   bdytmask   !: Mask defining computational domain at T-points 
    91    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   bdyumask   !: Mask defining computational domain at U-points 
    92    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   bdyvmask   !: Mask defining computational domain at V-points 
     116   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET ::   bdytmask   !: Mask defining computational domain at T-points 
     117   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET ::   bdyumask   !: Mask defining computational domain at U-points 
     118   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET ::   bdyvmask   !: Mask defining computational domain at V-points 
    93119 
    94120   REAL(wp)                                    ::   bdysurftot !: Lateral surface of unstructured open boundary 
    95121 
    96    REAL(wp), POINTER, DIMENSION(:,:)           ::   pssh       !:  
    97    REAL(wp), POINTER, DIMENSION(:,:)           ::   phur       !:  
    98    REAL(wp), POINTER, DIMENSION(:,:)           ::   phvr       !: Pointers for barotropic fields  
    99    REAL(wp), POINTER, DIMENSION(:,:)           ::   pu2d       !:  
    100    REAL(wp), POINTER, DIMENSION(:,:)           ::   pv2d       !:  
     122   REAL(wp), POINTER, DIMENSION(:,:)           ::   pssh                  !:  
     123   REAL(wp), POINTER, DIMENSION(:,:)           ::   phur                  !:  
     124   REAL(wp), POINTER, DIMENSION(:,:)           ::   phvr                  !: Pointers for barotropic fields  
     125   REAL(wp), POINTER, DIMENSION(:,:)           ::   pub2d, pun2d, pua2d   !:  
     126   REAL(wp), POINTER, DIMENSION(:,:)           ::   pvb2d, pvn2d, pva2d   !:  
    101127 
    102128   !!---------------------------------------------------------------------- 
    … …  
    109135   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET ::   dta_global2       !: workspace for reading in global data arrays (struct. bdy) 
    110136   TYPE(OBC_INDEX), DIMENSION(jp_bdy), TARGET      ::   idx_bdy           !: bdy indices (local process) 
    111    TYPE(OBC_DATA) , DIMENSION(jp_bdy)              ::   dta_bdy           !: bdy external data (local process) 
     137   TYPE(OBC_DATA) , DIMENSION(jp_bdy), TARGET      ::   dta_bdy           !: bdy external data (local process) 
    112138 
    113139   !!---------------------------------------------------------------------- 
    … …  
    125151      !!---------------------------------------------------------------------- 
    126152      ! 
    127       ALLOCATE( bdytmask(jpi,jpj) , bdyumask(jpi,jpj), bdyvmask(jpi,jpj),                    &   
     153      ALLOCATE( bdytmask(jpi,jpj) , bdyumask(jpi,jpj), bdyvmask(jpi,jpj),     &   
    128154         &      STAT=bdy_oce_alloc ) 
    129155         ! 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/BDY/bdy_par.F90

    r3294 r4292  
    2323# endif 
    2424   INTEGER, PUBLIC, PARAMETER ::   jp_bdy  = 10       !: Maximum number of bdy sets 
    25    INTEGER, PUBLIC, PARAMETER ::   jpbtime = 1000     !: Max number of time dumps per file 
    2625   INTEGER, PUBLIC, PARAMETER ::   jpbgrd  = 3        !: Number of horizontal grid types used  (T, U, V) 
    2726 
    28    !! Flags for choice of schemes 
    29    INTEGER, PUBLIC, PARAMETER ::   jp_none         = 0        !: Flag for no open boundary condition 
    30    INTEGER, PUBLIC, PARAMETER ::   jp_frs          = 1        !: Flag for Flow Relaxation Scheme 
    31    INTEGER, PUBLIC, PARAMETER ::   jp_flather      = 2        !: Flag for Flather 
    3227#else 
    3328   !!---------------------------------------------------------------------- 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/BDY/bdydta.F90

    r4230 r4292  
    1111   !!            3.3  !  2010-09  (D.Storkey) add ice boundary conditions 
    1212   !!            3.4  !  2011     (D. Storkey) rewrite in preparation for OBC-BDY merge 
     13   !!            3.6  !  2012-01  (C. Rousset) add ice boundary conditions for lim3 
    1314   !!---------------------------------------------------------------------- 
    1415#if defined key_bdy 
    … …  
    2930   USE iom             ! IOM library 
    3031   USE in_out_manager  ! I/O logical units 
     32   USE dynspg_oce, ONLY: lk_dynspg_ts ! Split-explicit free surface flag 
    3133#if defined key_lim2 
    3234   USE ice_2 
     35#elif defined key_lim3 
     36   USE par_ice 
     37   USE ice 
     38   USE limcat_1D          ! redistribute ice input into categories 
    3339#endif 
    3440   USE sbcapr 
    … …  
    4955 
    5056   TYPE(MAP_POINTER), ALLOCATABLE, DIMENSION(:) :: nbmap_ptr   ! array of pointers to nbmap 
     57 
     58#if defined key_lim3 
     59   LOGICAL :: ll_bdylim3                  ! determine whether ice input is lim2 (F) or lim3 (T) type 
     60   INTEGER :: jfld_hti, jfld_hts, jfld_ai ! indices of ice thickness, snow thickness and concentration in bf structure 
     61#endif 
    5162 
    5263#  include "domzgr_substitute.h90" 
    … …  
    7788                                                        ! etc. 
    7889      !! 
    79       INTEGER     ::  ib_bdy, jfld, jstart, jend, ib, ii, ij, ik, igrd  ! local indices 
     90      INTEGER     ::  ib_bdy, jfld, jstart, jend, ib, ii, ij, ik, igrd, jl  ! local indices 
    8091      INTEGER,          DIMENSION(jpbgrd) ::   ilen1  
    8192      INTEGER, POINTER, DIMENSION(:)      ::   nblen, nblenrim  ! short cuts 
     93      TYPE(OBC_DATA), POINTER             ::   dta              ! short cut 
    8294      !! 
    8395      !!--------------------------------------------------------------------------- 
    … …  
    91103         ! Calculate depth-mean currents 
    92104         !----------------------------- 
    93          CALL wrk_alloc(jpi,jpj,pu2d,pv2d)  
    94  
    95          pu2d(:,:) = 0.e0 
    96          pv2d(:,:) = 0.e0 
    97  
     105         CALL wrk_alloc(jpi,jpj,pun2d,pvn2d)  
     106 
     107         pun2d(:,:) = 0.e0 
     108         pvn2d(:,:) = 0.e0 
    98109         DO ik = 1, jpkm1   !! Vertically integrated momentum trends 
    99              pu2d(:,:) = pu2d(:,:) + fse3u(:,:,ik) * umask(:,:,ik) * un(:,:,ik) 
    100              pv2d(:,:) = pv2d(:,:) + fse3v(:,:,ik) * vmask(:,:,ik) * vn(:,:,ik) 
     110             pun2d(:,:) = pun2d(:,:) + fse3u(:,:,ik) * umask(:,:,ik) * un(:,:,ik) 
     111             pvn2d(:,:) = pvn2d(:,:) + fse3v(:,:,ik) * vmask(:,:,ik) * vn(:,:,ik) 
    101112         END DO 
    102          pu2d(:,:) = pu2d(:,:) * hur(:,:) 
    103          pv2d(:,:) = pv2d(:,:) * hvr(:,:) 
     113         pun2d(:,:) = pun2d(:,:) * hur(:,:) 
     114         pvn2d(:,:) = pvn2d(:,:) * hvr(:,:) 
    104115          
    105116         DO ib_bdy = 1, nb_bdy 
    … …  
    107118            nblen => idx_bdy(ib_bdy)%nblen 
    108119            nblenrim => idx_bdy(ib_bdy)%nblenrim 
    109  
    110             IF( nn_dyn2d(ib_bdy) .gt. 0 .and. nn_dyn2d_dta(ib_bdy) .eq. 0 ) THEN  
     120            dta => dta_bdy(ib_bdy) 
     121 
     122            IF( nn_dyn2d_dta(ib_bdy) .eq. 0 ) THEN  
    111123               ilen1(:) = nblen(:) 
    112                igrd = 1 
    113                DO ib = 1, ilen1(igrd) 
    114                   ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
    115                   ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
    116                   dta_bdy(ib_bdy)%ssh(ib) = sshn(ii,ij) * tmask(ii,ij,1)          
    117                END DO  
    118                igrd = 2 
    119                DO ib = 1, ilen1(igrd) 
    120                   ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
    121                   ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
    122                   dta_bdy(ib_bdy)%u2d(ib) = pu2d(ii,ij) * umask(ii,ij,1)          
    123                END DO  
    124                igrd = 3 
    125                DO ib = 1, ilen1(igrd) 
    126                   ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
    127                   ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
    128                   dta_bdy(ib_bdy)%v2d(ib) = pv2d(ii,ij) * vmask(ii,ij,1)          
    129                END DO  
    130             ENDIF 
    131  
    132             IF( nn_dyn3d(ib_bdy) .gt. 0 .and. nn_dyn3d_dta(ib_bdy) .eq. 0 ) THEN  
    133                ilen1(:) = nblen(:) 
    134                igrd = 2  
    135                DO ib = 1, ilen1(igrd) 
    136                   DO ik = 1, jpkm1 
     124               IF( dta%ll_ssh ) THEN  
     125                  igrd = 1 
     126                  DO ib = 1, ilen1(igrd) 
    137127                     ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
    138128                     ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
    139                      dta_bdy(ib_bdy)%u3d(ib,ik) =  ( un(ii,ij,ik) - pu2d(ii,ij) ) * umask(ii,ij,ik)          
    140                   END DO 
    141                END DO  
    142                igrd = 3  
    143                DO ib = 1, ilen1(igrd) 
    144                   DO ik = 1, jpkm1 
     129                     dta_bdy(ib_bdy)%ssh(ib) = sshn(ii,ij) * tmask(ii,ij,1)          
     130                  END DO  
     131               END IF 
     132               IF( dta%ll_u2d ) THEN  
     133                  igrd = 2 
     134                  DO ib = 1, ilen1(igrd) 
    145135                     ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
    146136                     ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
    147                      dta_bdy(ib_bdy)%v3d(ib,ik) =  ( vn(ii,ij,ik) - pv2d(ii,ij) ) * vmask(ii,ij,ik)          
    148                      END DO 
    149                END DO  
    150             ENDIF 
    151  
    152             IF( nn_tra(ib_bdy) .gt. 0 .and. nn_tra_dta(ib_bdy) .eq. 0 ) THEN  
    153                ilen1(:) = nblen(:) 
    154                igrd = 1                       ! Everything is at T-points here 
    155                DO ib = 1, ilen1(igrd) 
    156                   DO ik = 1, jpkm1 
     137                     dta_bdy(ib_bdy)%u2d(ib) = pun2d(ii,ij) * umask(ii,ij,1)          
     138                  END DO  
     139               END IF 
     140               IF( dta%ll_v2d ) THEN  
     141                  igrd = 3 
     142                  DO ib = 1, ilen1(igrd) 
    157143                     ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
    158144                     ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
    159                      dta_bdy(ib_bdy)%tem(ib,ik) = tsn(ii,ij,ik,jp_tem) * tmask(ii,ij,ik)          
    160                      dta_bdy(ib_bdy)%sal(ib,ik) = tsn(ii,ij,ik,jp_sal) * tmask(ii,ij,ik)          
     145                     dta_bdy(ib_bdy)%v2d(ib) = pvn2d(ii,ij) * vmask(ii,ij,1)          
     146                  END DO  
     147               END IF 
     148            ENDIF 
     149 
     150            IF( nn_dyn3d_dta(ib_bdy) .eq. 0 ) THEN  
     151               ilen1(:) = nblen(:) 
     152               IF( dta%ll_u3d ) THEN  
     153                  igrd = 2  
     154                  DO ib = 1, ilen1(igrd) 
     155                     DO ik = 1, jpkm1 
     156                        ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
     157                        ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
     158                        dta_bdy(ib_bdy)%u3d(ib,ik) =  ( un(ii,ij,ik) - pun2d(ii,ij) ) * umask(ii,ij,ik)          
     159                     END DO 
     160                  END DO  
     161               END IF 
     162               IF( dta%ll_v3d ) THEN  
     163                  igrd = 3  
     164                  DO ib = 1, ilen1(igrd) 
     165                     DO ik = 1, jpkm1 
     166                        ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
     167                        ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
     168                        dta_bdy(ib_bdy)%v3d(ib,ik) =  ( vn(ii,ij,ik) - pvn2d(ii,ij) ) * vmask(ii,ij,ik)          
     169                        END DO 
     170                  END DO  
     171               END IF 
     172            ENDIF 
     173 
     174            IF( nn_tra_dta(ib_bdy) .eq. 0 ) THEN  
     175               ilen1(:) = nblen(:) 
     176               IF( dta%ll_tem ) THEN 
     177                  igrd = 1  
     178                  DO ib = 1, ilen1(igrd) 
     179                     DO ik = 1, jpkm1 
     180                        ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
     181                        ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
     182                        dta_bdy(ib_bdy)%tem(ib,ik) = tsn(ii,ij,ik,jp_tem) * tmask(ii,ij,ik)          
     183                     END DO 
     184                  END DO  
     185               END IF 
     186               IF( dta%ll_sal ) THEN 
     187                  igrd = 1  
     188                  DO ib = 1, ilen1(igrd) 
     189                     DO ik = 1, jpkm1 
     190                        ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
     191                        ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
     192                        dta_bdy(ib_bdy)%sal(ib,ik) = tsn(ii,ij,ik,jp_sal) * tmask(ii,ij,ik)          
     193                     END DO 
     194                  END DO  
     195               END IF 
     196            ENDIF 
     197 
     198#if defined key_lim2 
     199            IF( nn_ice_lim2_dta(ib_bdy) .eq. 0 ) THEN  
     200               ilen1(:) = nblen(:) 
     201               IF( dta%ll_frld ) THEN 
     202                  igrd = 1  
     203                  DO ib = 1, ilen1(igrd) 
     204                     ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
     205                     ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
     206                     dta_bdy(ib_bdy)%frld(ib) = frld(ii,ij) * tmask(ii,ij,1)          
     207                  END DO  
     208               END IF 
     209               IF( dta%ll_hicif ) THEN 
     210                  igrd = 1  
     211                  DO ib = 1, ilen1(igrd) 
     212                     ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
     213                     ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
     214                     dta_bdy(ib_bdy)%hicif(ib) = hicif(ii,ij) * tmask(ii,ij,1)          
     215                  END DO  
     216               END IF 
     217               IF( dta%ll_hsnif ) THEN 
     218                  igrd = 1  
     219                  DO ib = 1, ilen1(igrd) 
     220                     ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
     221                     ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
     222                     dta_bdy(ib_bdy)%hsnif(ib) = hsnif(ii,ij) * tmask(ii,ij,1)          
     223                  END DO  
     224               END IF 
     225            ENDIF 
     226#elif defined key_lim3 
     227            IF( nn_ice_lim_dta(ib_bdy) .eq. 0 ) THEN  
     228               ilen1(:) = nblen(:) 
     229               IF( dta%ll_a_i ) THEN 
     230                  igrd = 1    
     231                  DO jl = 1, jpl 
     232                     DO ib = 1, ilen1(igrd) 
     233                        ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
     234                        ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
     235                        dta_bdy(ib_bdy)%a_i (ib,jl) =  a_i(ii,ij,jl) * tmask(ii,ij,1)  
     236                     END DO 
    161237                  END DO 
    162                END DO  
    163             ENDIF 
    164  
    165 #if defined key_lim2 
    166             IF( nn_ice_lim2(ib_bdy) .gt. 0 .and. nn_ice_lim2_dta(ib_bdy) .eq. 0 ) THEN  
    167                ilen1(:) = nblen(:) 
    168                igrd = 1                       ! Everything is at T-points here 
    169                DO ib = 1, ilen1(igrd) 
    170                   ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
    171                   ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
    172                   dta_bdy(ib_bdy)%frld(ib) = frld(ii,ij) * tmask(ii,ij,1)          
    173                   dta_bdy(ib_bdy)%hicif(ib) = hicif(ii,ij) * tmask(ii,ij,1)          
    174                   dta_bdy(ib_bdy)%hsnif(ib) = hsnif(ii,ij) * tmask(ii,ij,1)          
    175                END DO  
     238               ENDIF 
     239               IF( dta%ll_ht_i ) THEN 
     240                  igrd = 1    
     241                  DO jl = 1, jpl 
     242                     DO ib = 1, ilen1(igrd) 
     243                        ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
     244                        ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
     245                        dta_bdy(ib_bdy)%ht_i (ib,jl) =  ht_i(ii,ij,jl) * tmask(ii,ij,1)  
     246                     END DO 
     247                  END DO 
     248               ENDIF 
     249               IF( dta%ll_ht_s ) THEN 
     250                  igrd = 1    
     251                  DO jl = 1, jpl 
     252                     DO ib = 1, ilen1(igrd) 
     253                        ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
     254                        ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
     255                        dta_bdy(ib_bdy)%ht_s (ib,jl) =  ht_s(ii,ij,jl) * tmask(ii,ij,1)  
     256                     END DO 
     257                  END DO 
     258               ENDIF 
    176259            ENDIF 
    177260#endif 
    … …  
    179262         ENDDO ! ib_bdy 
    180263 
    181          CALL wrk_dealloc(jpi,jpj,pu2d,pv2d)  
     264         CALL wrk_dealloc(jpi,jpj,pun2d,pvn2d)  
    182265 
    183266      ENDIF ! kt .eq. nit000 
    … …  
    188271      jstart = 1 
    189272      DO ib_bdy = 1, nb_bdy    
     273         dta => dta_bdy(ib_bdy) 
    190274         IF( nn_dta(ib_bdy) .eq. 1 ) THEN ! skip this bit if no external data required 
    191275       
    … …  
    193277               ! Update barotropic boundary conditions only 
    194278               ! jit is optional argument for fld_read and bdytide_update 
    195                IF( nn_dyn2d(ib_bdy) .gt. 0 ) THEN 
     279               IF( cn_dyn2d(ib_bdy) /= 'none' ) THEN 
    196280                  IF( nn_dyn2d_dta(ib_bdy) .eq. 2 ) THEN ! tidal harmonic forcing ONLY: initialise arrays 
    197                      dta_bdy(ib_bdy)%ssh(:) = 0.0 
    198                      dta_bdy(ib_bdy)%u2d(:) = 0.0 
    199                      dta_bdy(ib_bdy)%v2d(:) = 0.0 
     281                     IF( dta%ll_ssh ) dta%ssh(:) = 0.0 
     282                     IF( dta%ll_u2d ) dta%u2d(:) = 0.0 
     283                     IF( dta%ll_u3d ) dta%v2d(:) = 0.0 
    200284                  ENDIF 
    201                   IF (nn_tra(ib_bdy).ne.4) THEN 
    202                      IF( nn_dyn2d_dta(ib_bdy) .EQ. 1 .OR. nn_dyn2d_dta(ib_bdy) .EQ. 3 .OR.  & 
    203                        & (ln_full_vel_array(ib_bdy) .AND. nn_dyn3d_dta(ib_bdy).eq.1) )THEN 
    204  
    205                         ! For the runoff case, no need to update the forcing (already done in the baroclinic part) 
    206                         jend = nb_bdy_fld(ib_bdy) 
    207                         IF ( nn_tra(ib_bdy) .GT. 0 .AND. nn_tra_dta(ib_bdy) .GE. 1 ) jend = jend - 2 
     285                  IF (cn_tra(ib_bdy) /= 'runoff') THEN 
     286                     IF( nn_dyn2d_dta(ib_bdy) .EQ. 1 .OR. nn_dyn2d_dta(ib_bdy) .EQ. 3 ) THEN 
     287 
     288                        jend = jstart + dta%nread(2) - 1 
    208289                        CALL fld_read( kt=kt, kn_fsbc=1, sd=bf(jstart:jend), map=nbmap_ptr(jstart:jend),  & 
    209290                                     & kit=jit, kt_offset=time_offset ) 
    210                         IF ( nn_tra(ib_bdy) .GT. 0 .AND. nn_tra_dta(ib_bdy) .GE. 1 ) jend = jend + 2 
    211  
    212                         ! If full velocities in boundary data then split into barotropic and baroclinic data 
     291 
     292                        ! If full velocities in boundary data then extract barotropic velocities from 3D fields 
    213293                        IF( ln_full_vel_array(ib_bdy) .AND.                                             & 
    214294                          &    ( nn_dyn2d_dta(ib_bdy) .EQ. 1 .OR. nn_dyn2d_dta(ib_bdy) .EQ. 3 .OR.  & 
    … …  
    216296 
    217297                           igrd = 2                      ! zonal velocity 
    218                            dta_bdy(ib_bdy)%u2d(:) = 0.0 
     298                           dta%u2d(:) = 0.0 
    219299                           DO ib = 1, idx_bdy(ib_bdy)%nblen(igrd) 
    220300                              ii   = idx_bdy(ib_bdy)%nbi(ib,igrd) 
    221301                              ij   = idx_bdy(ib_bdy)%nbj(ib,igrd) 
    222302                              DO ik = 1, jpkm1 
    223                                  dta_bdy(ib_bdy)%u2d(ib) = dta_bdy(ib_bdy)%u2d(ib) & 
    224                        &                          + fse3u(ii,ij,ik) * umask(ii,ij,ik) * dta_bdy(ib_bdy)%u3d(ib,ik) 
     303                                 dta%u2d(ib) = dta%u2d(ib) & 
     304                       &                          + fse3u(ii,ij,ik) * umask(ii,ij,ik) * dta%u3d(ib,ik) 
    225305                              END DO 
    226                               dta_bdy(ib_bdy)%u2d(ib) =  dta_bdy(ib_bdy)%u2d(ib) * hur(ii,ij) 
    227                               DO ik = 1, jpkm1 
    228                                  dta_bdy(ib_bdy)%u3d(ib,ik) = dta_bdy(ib_bdy)%u3d(ib,ik) - dta_bdy(ib_bdy)%u2d(ib) 
    229                               END DO 
     306                              dta%u2d(ib) =  dta%u2d(ib) * hur(ii,ij) 
    230307                           END DO 
    231308                           igrd = 3                      ! meridional velocity 
    232                            dta_bdy(ib_bdy)%v2d(:) = 0.0 
     309                           dta%v2d(:) = 0.0 
    233310                           DO ib = 1, idx_bdy(ib_bdy)%nblen(igrd) 
    234311                              ii   = idx_bdy(ib_bdy)%nbi(ib,igrd) 
    235312                              ij   = idx_bdy(ib_bdy)%nbj(ib,igrd) 
    236313                              DO ik = 1, jpkm1 
    237                                  dta_bdy(ib_bdy)%v2d(ib) = dta_bdy(ib_bdy)%v2d(ib) & 
    238                        &                       + fse3v(ii,ij,ik) * vmask(ii,ij,ik) * dta_bdy(ib_bdy)%v3d(ib,ik) 
     314                                 dta%v2d(ib) = dta%v2d(ib) & 
     315                       &                       + fse3v(ii,ij,ik) * vmask(ii,ij,ik) * dta%v3d(ib,ik) 
    239316                              END DO 
    240                               dta_bdy(ib_bdy)%v2d(ib) =  dta_bdy(ib_bdy)%v2d(ib) * hvr(ii,ij) 
    241                               DO ik = 1, jpkm1 
    242                                  dta_bdy(ib_bdy)%v3d(ib,ik) = dta_bdy(ib_bdy)%v3d(ib,ik) - dta_bdy(ib_bdy)%v2d(ib) 
    243                               END DO 
     317                              dta%v2d(ib) =  dta%v2d(ib) * hvr(ii,ij) 
    244318                           END DO 
    245319                        ENDIF                     
    246320                     ENDIF 
    247321                     IF( nn_dyn2d_dta(ib_bdy) .ge. 2 ) THEN ! update tidal harmonic forcing 
    248                         CALL bdytide_update( kt=kt, idx=idx_bdy(ib_bdy), dta=dta_bdy(ib_bdy), td=tides(ib_bdy),   &  
     322                        CALL bdytide_update( kt=kt, idx=idx_bdy(ib_bdy), dta=dta, td=tides(ib_bdy),   &  
    249323                          &                 jit=jit, time_offset=time_offset ) 
    250324                     ENDIF 
    … …  
    252326               ENDIF 
    253327            ELSE 
    254                IF (nn_tra(ib_bdy).eq.4) then      ! runoff condition 
     328               IF (cn_tra(ib_bdy) == 'runoff') then      ! runoff condition 
    255329                  jend = nb_bdy_fld(ib_bdy) 
    256330                  CALL fld_read( kt=kt, kn_fsbc=1, sd=bf(jstart:jend),  & 
    … …  
    261335                     ii   = idx_bdy(ib_bdy)%nbi(ib,igrd) 
    262336                     ij   = idx_bdy(ib_bdy)%nbj(ib,igrd) 
    263                      dta_bdy(ib_bdy)%u2d(ib) = dta_bdy(ib_bdy)%u2d(ib) / ( e2u(ii,ij) * hu_0(ii,ij) ) 
     337                     dta%u2d(ib) = dta%u2d(ib) / ( e2u(ii,ij) * hu_0(ii,ij) ) 
    264338                  END DO 
    265339                  ! 
    … …  
    268342                     ii   = idx_bdy(ib_bdy)%nbi(ib,igrd) 
    269343                     ij   = idx_bdy(ib_bdy)%nbj(ib,igrd) 
    270                      dta_bdy(ib_bdy)%v2d(ib) = dta_bdy(ib_bdy)%v2d(ib) / ( e1v(ii,ij) * hv_0(ii,ij) ) 
     344                     dta%v2d(ib) = dta%v2d(ib) / ( e1v(ii,ij) * hv_0(ii,ij) ) 
    271345                  END DO 
    272346               ELSE 
    273                   IF( nn_dyn2d(ib_bdy) .gt. 0 .and. nn_dyn2d_dta(ib_bdy) .eq. 2 ) THEN ! tidal harmonic forcing ONLY: initialise arrays 
    274                      dta_bdy(ib_bdy)%ssh(:) = 0.0 
    275                      dta_bdy(ib_bdy)%u2d(:) = 0.0 
    276                      dta_bdy(ib_bdy)%v2d(:) = 0.0 
     347                  IF( nn_dyn2d_dta(ib_bdy) .eq. 2 ) THEN ! tidal harmonic forcing ONLY: initialise arrays 
     348                     IF( dta%ll_ssh ) dta%ssh(:) = 0.0 
     349                     IF( dta%ll_u2d ) dta%u2d(:) = 0.0 
     350                     IF( dta%ll_v2d ) dta%v2d(:) = 0.0 
    277351                  ENDIF 
    278                   IF( nb_bdy_fld(ib_bdy) .gt. 0 ) THEN ! update external data 
    279                      jend = nb_bdy_fld(ib_bdy) 
     352                  IF( dta%nread(1) .gt. 0 ) THEN ! update external data 
     353                     jend = jstart + dta%nread(1) - 1 
    280354                     CALL fld_read( kt=kt, kn_fsbc=1, sd=bf(jstart:jend), & 
    281355                                  & map=nbmap_ptr(jstart:jend), kt_offset=time_offset ) 
    … …  
    286360                    &   nn_dyn3d_dta(ib_bdy) .EQ. 1 ) ) THEN 
    287361                     igrd = 2                      ! zonal velocity 
    288                      dta_bdy(ib_bdy)%u2d(:) = 0.0 
     362                     dta%u2d(:) = 0.0 
    289363                     DO ib = 1, idx_bdy(ib_bdy)%nblen(igrd) 
    290364                        ii   = idx_bdy(ib_bdy)%nbi(ib,igrd) 
    291365                        ij   = idx_bdy(ib_bdy)%nbj(ib,igrd) 
    292366                        DO ik = 1, jpkm1 
    293                            dta_bdy(ib_bdy)%u2d(ib) = dta_bdy(ib_bdy)%u2d(ib) & 
    294                  &                       + fse3u(ii,ij,ik) * umask(ii,ij,ik) * dta_bdy(ib_bdy)%u3d(ib,ik) 
     367                           dta%u2d(ib) = dta%u2d(ib) & 
     368                 &                       + fse3u(ii,ij,ik) * umask(ii,ij,ik) * dta%u3d(ib,ik) 
    295369                        END DO 
    296                         dta_bdy(ib_bdy)%u2d(ib) =  dta_bdy(ib_bdy)%u2d(ib) * hur(ii,ij) 
     370                        dta%u2d(ib) =  dta%u2d(ib) * hur(ii,ij) 
    297371                        DO ik = 1, jpkm1 
    298                            dta_bdy(ib_bdy)%u3d(ib,ik) = dta_bdy(ib_bdy)%u3d(ib,ik) - dta_bdy(ib_bdy)%u2d(ib) 
     372                           dta%u3d(ib,ik) = dta%u3d(ib,ik) - dta%u2d(ib) 
    299373                        END DO 
    300374                     END DO 
    301375                     igrd = 3                      ! meridional velocity 
    302                      dta_bdy(ib_bdy)%v2d(:) = 0.0 
     376                     dta%v2d(:) = 0.0 
    303377                     DO ib = 1, idx_bdy(ib_bdy)%nblen(igrd) 
    304378                        ii   = idx_bdy(ib_bdy)%nbi(ib,igrd) 
    305379                        ij   = idx_bdy(ib_bdy)%nbj(ib,igrd) 
    306380                        DO ik = 1, jpkm1 
    307                            dta_bdy(ib_bdy)%v2d(ib) = dta_bdy(ib_bdy)%v2d(ib) & 
    308                  &                       + fse3v(ii,ij,ik) * vmask(ii,ij,ik) * dta_bdy(ib_bdy)%v3d(ib,ik) 
     381                           dta%v2d(ib) = dta%v2d(ib) & 
     382                 &                       + fse3v(ii,ij,ik) * vmask(ii,ij,ik) * dta%v3d(ib,ik) 
    309383                        END DO 
    310                         dta_bdy(ib_bdy)%v2d(ib) =  dta_bdy(ib_bdy)%v2d(ib) * hvr(ii,ij) 
     384                        dta%v2d(ib) =  dta%v2d(ib) * hvr(ii,ij) 
    311385                        DO ik = 1, jpkm1 
    312                            dta_bdy(ib_bdy)%v3d(ib,ik) = dta_bdy(ib_bdy)%v3d(ib,ik) - dta_bdy(ib_bdy)%v2d(ib) 
     386                           dta%v3d(ib,ik) = dta%v3d(ib,ik) - dta%v2d(ib) 
    313387                        END DO 
    314388                     END DO 
    315389                  ENDIF 
    316                   IF( nn_dyn2d(ib_bdy) .gt. 0 .and. nn_dyn2d_dta(ib_bdy) .ge. 2 ) THEN ! update tidal harmonic forcing 
    317                      CALL bdytide_update( kt=kt, idx=idx_bdy(ib_bdy), dta=dta_bdy(ib_bdy),  & 
    318                                         & td=tides(ib_bdy), time_offset=time_offset ) 
    319                   ENDIF 
    320                ENDIF 
    321             ENDIF 
    322             jstart = jend+1 
     390 
     391               ENDIF 
     392#if defined key_lim3 
     393               IF( .NOT. ll_bdylim3 .AND. nn_ice_lim(ib_bdy) > 0 .AND. nn_ice_lim_dta(ib_bdy) == 1 ) THEN ! bdy ice input (case input is lim2 type) 
     394                CALL lim_cat_1D ( bf(jfld_hti)%fnow(:,1,1), bf(jfld_hts)%fnow(:,1,1), bf(jfld_ai)%fnow(:,1,1), & 
     395                                  & dta_bdy(ib_bdy)%ht_i,     dta_bdy(ib_bdy)%ht_s,     dta_bdy(ib_bdy)%a_i     ) 
     396               ENDIF 
     397#endif 
     398            ENDIF 
     399            jstart = jstart + dta%nread(1) 
    323400         END IF ! nn_dta(ib_bdy) = 1 
    324401      END DO  ! ib_bdy 
    325402 
     403      ! bg jchanut tschanges 
     404#if defined key_tide 
     405      ! Add tides if not split-explicit free surface else this is done in ts loop 
     406      IF (.NOT.lk_dynspg_ts) CALL bdy_dta_tides( kt=kt, time_offset=time_offset ) 
     407#endif 
     408      ! end jchanut tschanges 
     409 
    326410      IF ( ln_apr_obc ) THEN 
    327411         DO ib_bdy = 1, nb_bdy 
    328             IF (nn_tra(ib_bdy).NE.4)THEN 
     412            IF (cn_tra(ib_bdy) /= 'runoff')THEN 
    329413               igrd = 1                      ! meridional velocity 
    330414               DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) 
    … …  
    349433      !!                for open boundary conditions 
    350434      !! 
    351       !! ** Method  :   Use fldread.F90 
     435      !! ** Method  :    
    352436      !!                 
    353437      !!---------------------------------------------------------------------- 
    … …  
    362446                                                                ! =F => baroclinic velocities in 3D boundary data 
    363447      INTEGER                                ::   ilen_global   ! Max length required for global bdy dta arrays 
    364       INTEGER,              DIMENSION(jpbgrd) ::  ilen0         ! size of local arrays 
    365448      INTEGER, ALLOCATABLE, DIMENSION(:)     ::   ilen1, ilen3  ! size of 1st and 3rd dimensions of local arrays 
    366449      INTEGER, ALLOCATABLE, DIMENSION(:)     ::   ibdy           ! bdy set for a particular jfld 
    367450      INTEGER, ALLOCATABLE, DIMENSION(:)     ::   igrid         ! index for grid type (1,2,3 = T,U,V) 
    368451      INTEGER, POINTER, DIMENSION(:)         ::   nblen, nblenrim  ! short cuts 
     452      TYPE(OBC_DATA), POINTER                ::   dta           ! short cut 
     453#if defined key_lim3 
     454      INTEGER, DIMENSION(3) ::   zdimsz   ! number of elements in each of the 4 dimensions (i.e. i,j,t,ice-cat) for an array 
     455      INTEGER               ::   zndims   ! number of dimensions in an array (i.e. 3 = wo ice cat; 4 = w ice cat) 
     456      INTEGER               ::   inum,id1 ! local integer 
     457#endif 
    369458      TYPE(FLD_N), ALLOCATABLE, DIMENSION(:) ::   blf_i         !  array of namelist information structures 
    370459      TYPE(FLD_N) ::   bn_tem, bn_sal, bn_u3d, bn_v3d   !  
    … …  
    372461#if defined key_lim2 
    373462      TYPE(FLD_N) ::   bn_frld, bn_hicif, bn_hsnif      ! 
     463#elif defined key_lim3 
     464      TYPE(FLD_N) ::   bn_a_i, bn_ht_i, bn_ht_s       
    374465#endif 
    375466      NAMELIST/nambdy_dta/ cn_dir, bn_tem, bn_sal, bn_u3d, bn_v3d, bn_ssh, bn_u2d, bn_v2d  
    376467#if defined key_lim2 
    377468      NAMELIST/nambdy_dta/ bn_frld, bn_hicif, bn_hsnif 
     469#elif defined key_lim3 
     470      NAMELIST/nambdy_dta/ bn_a_i, bn_ht_i, bn_ht_s 
    378471#endif 
    379472      NAMELIST/nambdy_dta/ ln_full_vel 
    … …  
    392485                               ,nn_dyn3d_dta(ib_bdy)       & 
    393486                               ,nn_tra_dta(ib_bdy)         & 
    394 #if defined key_lim2 
    395                                ,nn_ice_lim2_dta(ib_bdy)    & 
     487#if ( defined key_lim2 || defined key_lim3 ) 
     488                              ,nn_ice_lim_dta(ib_bdy)    & 
    396489#endif 
    397490                              ) 
    … …  
    404497      nb_bdy_fld(:) = 0 
    405498      DO ib_bdy = 1, nb_bdy          
    406          IF( nn_dyn2d(ib_bdy) .gt. 0 .and. ( nn_dyn2d_dta(ib_bdy) .eq. 1 .or. nn_dyn2d_dta(ib_bdy) .eq. 3 ) ) THEN 
     499         IF( cn_dyn2d(ib_bdy) /= 'none' .and. ( nn_dyn2d_dta(ib_bdy) .eq. 1 .or. nn_dyn2d_dta(ib_bdy) .eq. 3 ) ) THEN 
    407500            nb_bdy_fld(ib_bdy) = nb_bdy_fld(ib_bdy) + 3 
    408501         ENDIF 
    409          IF( nn_dyn3d(ib_bdy) .gt. 0 .and. nn_dyn3d_dta(ib_bdy) .eq. 1 ) THEN 
     502         IF( cn_dyn3d(ib_bdy) /= 'none' .and. nn_dyn3d_dta(ib_bdy) .eq. 1 ) THEN 
    410503            nb_bdy_fld(ib_bdy) = nb_bdy_fld(ib_bdy) + 2 
    411504         ENDIF 
    412          IF( nn_tra(ib_bdy) .gt. 0 .and. nn_tra_dta(ib_bdy) .eq. 1  ) THEN 
     505         IF( cn_tra(ib_bdy) /= 'none' .and. nn_tra_dta(ib_bdy) .eq. 1  ) THEN 
    413506            nb_bdy_fld(ib_bdy) = nb_bdy_fld(ib_bdy) + 2 
    414507         ENDIF 
    415 #if defined key_lim2 
    416          IF( nn_ice_lim2(ib_bdy) .gt. 0 .and. nn_ice_lim2_dta(ib_bdy) .eq. 1  ) THEN 
     508#if ( defined key_lim2 || defined key_lim3 ) 
     509         IF( cn_ice_lim(ib_bdy) /= 'none' .and. nn_ice_lim_dta(ib_bdy) .eq. 1  ) THEN 
    417510            nb_bdy_fld(ib_bdy) = nb_bdy_fld(ib_bdy) + 3 
    418511         ENDIF 
    … …  
    458551            nblen => idx_bdy(ib_bdy)%nblen 
    459552            nblenrim => idx_bdy(ib_bdy)%nblenrim 
     553            dta => dta_bdy(ib_bdy) 
     554            dta%nread(2) = 0 
    460555 
    461556            ! Only read in necessary fields for this set. 
    462557            ! Important that barotropic variables come first. 
    463             IF( nn_dyn2d(ib_bdy) .gt. 0 .and. ( nn_dyn2d_dta(ib_bdy) .eq. 1 .or. nn_dyn2d_dta(ib_bdy) .eq. 3 ) ) THEN  
    464  
    465                IF( nn_dyn2d(ib_bdy) .ne. jp_frs .and. nn_tra(ib_bdy) .ne. 4 ) THEN ! runoff condition : no ssh reading 
     558            IF( nn_dyn2d_dta(ib_bdy) .eq. 1 .or. nn_dyn2d_dta(ib_bdy) .eq. 3 ) THEN  
     559 
     560               IF( dta%ll_ssh ) THEN  
     561                  if(lwp) write(numout,*) '++++++ reading in ssh field' 
    466562                  jfld = jfld + 1 
    467563                  blf_i(jfld) = bn_ssh 
    … …  
    470566                  ilen1(jfld) = nblen(igrid(jfld)) 
    471567                  ilen3(jfld) = 1 
    472                ENDIF 
    473  
    474                IF( .not. ln_full_vel_array(ib_bdy) ) THEN 
     568                  dta%nread(2) = dta%nread(2) + 1 
     569               ENDIF 
     570 
     571               IF( dta%ll_u2d .and. .not. ln_full_vel_array(ib_bdy) ) THEN 
     572                  if(lwp) write(numout,*) '++++++ reading in u2d field' 
    475573                  jfld = jfld + 1 
    476574                  blf_i(jfld) = bn_u2d 
    … …  
    479577                  ilen1(jfld) = nblen(igrid(jfld)) 
    480578                  ilen3(jfld) = 1 
    481  
     579                  dta%nread(2) = dta%nread(2) + 1 
     580               ENDIF 
     581 
     582               IF( dta%ll_v2d .and. .not. ln_full_vel_array(ib_bdy) ) THEN 
     583                  if(lwp) write(numout,*) '++++++ reading in v2d field' 
    482584                  jfld = jfld + 1 
    483585                  blf_i(jfld) = bn_v2d 
    … …  
    486588                  ilen1(jfld) = nblen(igrid(jfld)) 
    487589                  ilen3(jfld) = 1 
    488                ENDIF 
    489  
    490             ENDIF 
    491  
    492             ! baroclinic velocities 
    493             IF( ( nn_dyn3d(ib_bdy) .gt. 0 .and. nn_dyn3d_dta(ib_bdy) .eq. 1 ) .or. & 
    494            &      ( ln_full_vel_array(ib_bdy) .and. nn_dyn2d(ib_bdy) .gt. 0 .and.  & 
    495            &        ( nn_dyn2d_dta(ib_bdy) .eq. 1 .or. nn_dyn2d_dta(ib_bdy) .eq. 3 ) ) ) THEN 
    496  
    497                jfld = jfld + 1 
    498                blf_i(jfld) = bn_u3d 
    499                ibdy(jfld) = ib_bdy 
    500                igrid(jfld) = 2 
    501                ilen1(jfld) = nblen(igrid(jfld)) 
    502                ilen3(jfld) = jpk 
    503  
    504                jfld = jfld + 1 
    505                blf_i(jfld) = bn_v3d 
    506                ibdy(jfld) = ib_bdy 
    507                igrid(jfld) = 3 
    508                ilen1(jfld) = nblen(igrid(jfld)) 
    509                ilen3(jfld) = jpk 
     590                  dta%nread(2) = dta%nread(2) + 1 
     591               ENDIF 
     592 
     593            ENDIF 
     594 
     595            ! read 3D velocities if baroclinic velocities require OR if 
     596            ! barotropic velocities required and ln_full_vel set to .true. 
     597            IF( nn_dyn3d_dta(ib_bdy) .eq. 1 .or. & 
     598           &  ( ln_full_vel_array(ib_bdy) .and. ( nn_dyn2d_dta(ib_bdy) .eq. 1 .or. nn_dyn2d_dta(ib_bdy) .eq. 3 ) ) ) THEN 
     599 
     600               IF( dta%ll_u3d .or. ( ln_full_vel_array(ib_bdy) .and. dta%ll_u2d ) ) THEN 
     601                  if(lwp) write(numout,*) '++++++ reading in u3d field' 
     602                  jfld = jfld + 1 
     603                  blf_i(jfld) = bn_u3d 
     604                  ibdy(jfld) = ib_bdy 
     605                  igrid(jfld) = 2 
     606                  ilen1(jfld) = nblen(igrid(jfld)) 
     607                  ilen3(jfld) = jpk 
     608                  IF( ln_full_vel_array(ib_bdy) .and. dta%ll_u2d ) dta%nread(2) = dta%nread(2) + 1 
     609               ENDIF 
     610 
     611               IF( dta%ll_v3d .or. ( ln_full_vel_array(ib_bdy) .and. dta%ll_v2d ) ) THEN 
     612                  if(lwp) write(numout,*) '++++++ reading in v3d field' 
     613                  jfld = jfld + 1 
     614                  blf_i(jfld) = bn_v3d 
     615                  ibdy(jfld) = ib_bdy 
     616                  igrid(jfld) = 3 
     617                  ilen1(jfld) = nblen(igrid(jfld)) 
     618                  ilen3(jfld) = jpk 
     619                  IF( ln_full_vel_array(ib_bdy) .and. dta%ll_v2d ) dta%nread(2) = dta%nread(2) + 1 
     620               ENDIF 
    510621 
    511622            ENDIF 
    512623 
    513624            ! temperature and salinity 
    514             IF( nn_tra(ib_bdy) .gt. 0 .and. nn_tra_dta(ib_bdy) .eq. 1 ) THEN 
    515  
    516                jfld = jfld + 1 
    517                blf_i(jfld) = bn_tem 
    518                ibdy(jfld) = ib_bdy 
    519                igrid(jfld) = 1 
    520                ilen1(jfld) = nblen(igrid(jfld)) 
    521                ilen3(jfld) = jpk 
    522  
    523                jfld = jfld + 1 
    524                blf_i(jfld) = bn_sal 
    525                ibdy(jfld) = ib_bdy 
    526                igrid(jfld) = 1 
    527                ilen1(jfld) = nblen(igrid(jfld)) 
    528                ilen3(jfld) = jpk 
     625            IF( nn_tra_dta(ib_bdy) .eq. 1 ) THEN 
     626 
     627               IF( dta%ll_tem ) THEN 
     628                  if(lwp) write(numout,*) '++++++ reading in tem field' 
     629                  jfld = jfld + 1 
     630                  blf_i(jfld) = bn_tem 
     631                  ibdy(jfld) = ib_bdy 
     632                  igrid(jfld) = 1 
     633                  ilen1(jfld) = nblen(igrid(jfld)) 
     634                  ilen3(jfld) = jpk 
     635               ENDIF 
     636 
     637               IF( dta%ll_sal ) THEN 
     638                  if(lwp) write(numout,*) '++++++ reading in sal field' 
     639                  jfld = jfld + 1 
     640                  blf_i(jfld) = bn_sal 
     641                  ibdy(jfld) = ib_bdy 
     642                  igrid(jfld) = 1 
     643                  ilen1(jfld) = nblen(igrid(jfld)) 
     644                  ilen3(jfld) = jpk 
     645               ENDIF 
    529646 
    530647            ENDIF 
    … …  
    532649#if defined key_lim2 
    533650            ! sea ice 
    534             IF( nn_ice_lim2(ib_bdy) .gt. 0 .and. nn_ice_lim2_dta(ib_bdy) .eq. 1 ) THEN 
    535  
    536                jfld = jfld + 1 
    537                blf_i(jfld) = bn_frld 
    538                ibdy(jfld) = ib_bdy 
    539                igrid(jfld) = 1 
    540                ilen1(jfld) = nblen(igrid(jfld)) 
    541                ilen3(jfld) = 1 
    542  
    543                jfld = jfld + 1 
    544                blf_i(jfld) = bn_hicif 
    545                ibdy(jfld) = ib_bdy 
    546                igrid(jfld) = 1 
    547                ilen1(jfld) = nblen(igrid(jfld)) 
    548                ilen3(jfld) = 1 
    549  
    550                jfld = jfld + 1 
    551                blf_i(jfld) = bn_hsnif 
    552                ibdy(jfld) = ib_bdy 
    553                igrid(jfld) = 1 
    554                ilen1(jfld) = nblen(igrid(jfld)) 
    555                ilen3(jfld) = 1 
    556  
    557             ENDIF 
     651            IF( nn_ice_lim2_dta(ib_bdy) .eq. 1 ) THEN 
     652 
     653               IF( dta%ll_frld ) THEN 
     654                  jfld = jfld + 1 
     655                  blf_i(jfld) = bn_frld 
     656                  ibdy(jfld) = ib_bdy 
     657                  igrid(jfld) = 1 
     658                  ilen1(jfld) = nblen(igrid(jfld)) 
     659                  ilen3(jfld) = 1 
     660               ENDIF 
     661 
     662               IF( dta%ll_hicif ) THEN 
     663                  jfld = jfld + 1 
     664                  blf_i(jfld) = bn_hicif 
     665                  ibdy(jfld) = ib_bdy 
     666                  igrid(jfld) = 1 
     667                  ilen1(jfld) = nblen(igrid(jfld)) 
     668                  ilen3(jfld) = 1 
     669               ENDIF 
     670 
     671               IF( dta%ll_hsnif ) THEN 
     672                  jfld = jfld + 1 
     673                  blf_i(jfld) = bn_hsnif 
     674                  ibdy(jfld) = ib_bdy 
     675                  igrid(jfld) = 1 
     676                  ilen1(jfld) = nblen(igrid(jfld)) 
     677                  ilen3(jfld) = 1 
     678               ENDIF 
     679 
     680            ENDIF 
     681#elif defined key_lim3 
     682            ! sea ice 
     683            IF( nn_ice_lim_dta(ib_bdy) .eq. 1 ) THEN 
     684 
     685               ! Test for types of ice input (lim2 or lim3)  
     686               CALL iom_open ( bn_a_i%clname, inum ) 
     687               id1 = iom_varid ( inum, bn_a_i%clvar, kdimsz=zdimsz, kndims=zndims, ldstop = .FALSE. ) 
     688               CALL iom_close ( inum ) 
     689               !CALL fld_clopn ( bn_a_i, nyear, nmonth, nday, ldstop=.TRUE. ) 
     690               !CALL iom_open ( bn_a_i %clname, inum ) 
     691               !id1 = iom_varid ( bn_a_i%num, bn_a_i%clvar, kdimsz=zdimsz, kndims=zndims, ldstop = .FALSE. ) 
     692                IF ( zndims == 4 ) THEN 
     693                 ll_bdylim3 = .TRUE.   ! lim3 input 
     694               ELSE 
     695                 ll_bdylim3 = .FALSE.  ! lim2 input       
     696               ENDIF 
     697               ! End test 
     698 
     699               IF( dta%ll_a_i ) THEN 
     700                  jfld = jfld + 1 
     701                  blf_i(jfld) = bn_a_i 
     702                  ibdy(jfld) = ib_bdy 
     703                  igrid(jfld) = 1 
     704                  ilen1(jfld) = nblen(igrid(jfld)) 
     705                  IF ( ll_bdylim3 ) THEN ; ilen3(jfld)=jpl ; ELSE ; ilen3(jfld)=1 ; ENDIF 
     706               ENDIF 
     707 
     708               IF( dta%ll_ht_i ) THEN 
     709                  jfld = jfld + 1 
     710                  blf_i(jfld) = bn_ht_i 
     711                  ibdy(jfld) = ib_bdy 
     712                  igrid(jfld) = 1 
     713                  ilen1(jfld) = nblen(igrid(jfld)) 
     714                  IF ( ll_bdylim3 ) THEN ; ilen3(jfld)=jpl ; ELSE ; ilen3(jfld)=1 ; ENDIF 
     715               ENDIF 
     716 
     717               IF( dta%ll_ht_s ) THEN 
     718                  jfld = jfld + 1 
     719                   blf_i(jfld) = bn_ht_s 
     720                  ibdy(jfld) = ib_bdy 
     721                  igrid(jfld) = 1 
     722                  ilen1(jfld) = nblen(igrid(jfld)) 
     723                  IF ( ll_bdylim3 ) THEN ; ilen3(jfld)=jpl ; ELSE ; ilen3(jfld)=1 ; ENDIF 
     724               ENDIF 
     725 
    558726#endif 
    559727            ! Recalculate field counts 
    … …  
    568736            ENDIF 
    569737 
     738            dta%nread(1) = nb_bdy_fld(ib_bdy) 
     739 
    570740         ENDIF ! nn_dta .eq. 1 
    571741      ENDDO ! ib_bdy 
    … …  
    596766 
    597767         nblen => idx_bdy(ib_bdy)%nblen 
    598          nblenrim => idx_bdy(ib_bdy)%nblenrim 
    599  
    600          IF (nn_dyn2d(ib_bdy) .gt. 0) THEN 
    601             IF( nn_dyn2d_dta(ib_bdy) .eq. 0 .or. nn_dyn2d_dta(ib_bdy) .eq. 2 .or. ln_full_vel_array(ib_bdy) ) THEN 
    602                ilen0(1:3) = nblen(1:3) 
    603                ALLOCATE( dta_bdy(ib_bdy)%u2d(ilen0(2)) ) 
    604                ALLOCATE( dta_bdy(ib_bdy)%v2d(ilen0(3)) ) 
    605                IF ( nn_dyn2d(ib_bdy) .ne. jp_frs .and. (nn_dyn2d_dta(ib_bdy).eq.1.or.nn_dyn2d_dta(ib_bdy).eq.3) ) THEN 
    606                   jfld = jfld + 1 
    607                   dta_bdy(ib_bdy)%ssh => bf(jfld)%fnow(:,1,1) 
     768         dta => dta_bdy(ib_bdy) 
     769 
     770         if(lwp) then 
     771            write(numout,*) '++++++ dta%ll_ssh = ',dta%ll_ssh 
     772            write(numout,*) '++++++ dta%ll_u2d = ',dta%ll_u2d 
     773            write(numout,*) '++++++ dta%ll_v2d = ',dta%ll_v2d 
     774            write(numout,*) '++++++ dta%ll_u3d = ',dta%ll_u3d 
     775            write(numout,*) '++++++ dta%ll_v3d = ',dta%ll_v3d 
     776            write(numout,*) '++++++ dta%ll_tem = ',dta%ll_tem 
     777            write(numout,*) '++++++ dta%ll_sal = ',dta%ll_sal 
     778         endif 
     779 
     780         IF ( nn_dyn2d_dta(ib_bdy) .eq. 0 .or. nn_dyn2d_dta(ib_bdy) .eq. 2 ) THEN 
     781            if(lwp) write(numout,*) '++++++ dta%ssh/u2d/u3d allocated space' 
     782            IF( dta%ll_ssh ) ALLOCATE( dta%ssh(nblen(1)) ) 
     783            IF( dta%ll_u2d ) ALLOCATE( dta%u2d(nblen(2)) ) 
     784            IF( dta%ll_v2d ) ALLOCATE( dta%v2d(nblen(3)) ) 
     785         ENDIF 
     786         IF ( nn_dyn2d_dta(ib_bdy) .eq. 1 .or. nn_dyn2d_dta(ib_bdy) .eq. 3 ) THEN 
     787            IF( dta%ll_ssh ) THEN 
     788               if(lwp) write(numout,*) '++++++ dta%ssh pointing to fnow' 
     789               jfld = jfld + 1 
     790               dta%ssh => bf(jfld)%fnow(:,1,1) 
     791            ENDIF 
     792            IF ( dta%ll_u2d ) THEN 
     793               IF ( ln_full_vel_array(ib_bdy) ) THEN 
     794                  if(lwp) write(numout,*) '++++++ dta%u2d allocated space' 
     795                  ALLOCATE( dta%u2d(nblen(2)) ) 
    608796               ELSE 
    609                   ALLOCATE( dta_bdy(ib_bdy)%ssh(nblen(1)) ) 
    610                ENDIF 
    611             ELSE 
    612                IF( nn_dyn2d(ib_bdy) .ne. jp_frs ) THEN 
    613                   jfld = jfld + 1 
    614                   dta_bdy(ib_bdy)%ssh => bf(jfld)%fnow(:,1,1) 
    615                ENDIF 
     797                  if(lwp) write(numout,*) '++++++ dta%u2d pointing to fnow' 
     798                  jfld = jfld + 1 
     799                  dta%u2d => bf(jfld)%fnow(:,1,1) 
     800               ENDIF 
     801            ENDIF 
     802            IF ( dta%ll_v2d ) THEN 
     803               IF ( ln_full_vel_array(ib_bdy) ) THEN 
     804                  if(lwp) write(numout,*) '++++++ dta%v2d allocated space' 
     805                  ALLOCATE( dta%v2d(nblen(3)) ) 
     806               ELSE 
     807                  if(lwp) write(numout,*) '++++++ dta%v2d pointing to fnow' 
     808                  jfld = jfld + 1 
     809                  dta%v2d => bf(jfld)%fnow(:,1,1) 
     810               ENDIF 
     811            ENDIF 
     812         ENDIF 
     813 
     814         IF ( nn_dyn3d_dta(ib_bdy) .eq. 0 ) THEN 
     815            if(lwp) write(numout,*) '++++++ dta%u3d/v3d allocated space' 
     816            IF( dta%ll_u3d ) ALLOCATE( dta_bdy(ib_bdy)%u3d(nblen(2),jpk) ) 
     817            IF( dta%ll_v3d ) ALLOCATE( dta_bdy(ib_bdy)%v3d(nblen(3),jpk) ) 
     818         ENDIF 
     819         IF ( nn_dyn3d_dta(ib_bdy) .eq. 1 .or. & 
     820           &  ( ln_full_vel_array(ib_bdy) .and. ( nn_dyn2d_dta(ib_bdy) .eq. 1 .or. nn_dyn2d_dta(ib_bdy) .eq. 3 ) ) ) THEN 
     821            IF ( dta%ll_u3d .or. ( ln_full_vel_array(ib_bdy) .and. dta%ll_u2d ) ) THEN 
     822               if(lwp) write(numout,*) '++++++ dta%u3d pointing to fnow' 
    616823               jfld = jfld + 1 
    617                dta_bdy(ib_bdy)%u2d => bf(jfld)%fnow(:,1,1) 
     824               dta_bdy(ib_bdy)%u3d => bf(jfld)%fnow(:,1,:) 
     825            ENDIF 
     826            IF ( dta%ll_v3d .or. ( ln_full_vel_array(ib_bdy) .and. dta%ll_v2d ) ) THEN 
     827               if(lwp) write(numout,*) '++++++ dta%v3d pointing to fnow' 
    618828               jfld = jfld + 1 
    619                dta_bdy(ib_bdy)%v2d => bf(jfld)%fnow(:,1,1) 
    620             ENDIF 
    621          ENDIF 
    622  
    623          IF ( nn_dyn3d(ib_bdy) .gt. 0 .and. nn_dyn3d_dta(ib_bdy) .eq. 0 ) THEN 
    624             ilen0(1:3) = nblen(1:3) 
    625             ALLOCATE( dta_bdy(ib_bdy)%u3d(ilen0(2),jpk) ) 
    626             ALLOCATE( dta_bdy(ib_bdy)%v3d(ilen0(3),jpk) ) 
    627          ENDIF 
    628          IF ( ( nn_dyn3d(ib_bdy) .gt. 0 .and. nn_dyn3d_dta(ib_bdy) .eq. 1 ).or. & 
    629            &  ( ln_full_vel_array(ib_bdy) .and. nn_dyn2d(ib_bdy) .gt. 0 .and.   & 
    630            &    ( nn_dyn2d_dta(ib_bdy) .eq. 1 .or. nn_dyn2d_dta(ib_bdy) .eq. 3 ) ) ) THEN 
    631             jfld = jfld + 1 
    632             dta_bdy(ib_bdy)%u3d => bf(jfld)%fnow(:,1,:) 
    633             jfld = jfld + 1 
    634             dta_bdy(ib_bdy)%v3d => bf(jfld)%fnow(:,1,:) 
    635          ENDIF 
    636  
    637          IF (nn_tra(ib_bdy) .gt. 0) THEN 
    638             IF( nn_tra_dta(ib_bdy) .eq. 0 ) THEN 
    639                ilen0(1:3) = nblen(1:3) 
    640                ALLOCATE( dta_bdy(ib_bdy)%tem(ilen0(1),jpk) ) 
    641                ALLOCATE( dta_bdy(ib_bdy)%sal(ilen0(1),jpk) ) 
    642             ELSE 
     829               dta_bdy(ib_bdy)%v3d => bf(jfld)%fnow(:,1,:) 
     830            ENDIF 
     831         ENDIF 
     832 
     833         IF( nn_tra_dta(ib_bdy) .eq. 0 ) THEN 
     834            if(lwp) write(numout,*) '++++++ dta%tem/sal allocated space' 
     835            IF( dta%ll_tem ) ALLOCATE( dta_bdy(ib_bdy)%tem(nblen(1),jpk) ) 
     836            IF( dta%ll_sal ) ALLOCATE( dta_bdy(ib_bdy)%sal(nblen(1),jpk) ) 
     837         ELSE 
     838            IF( dta%ll_tem ) THEN 
     839               if(lwp) write(numout,*) '++++++ dta%tem pointing to fnow' 
    643840               jfld = jfld + 1 
    644841               dta_bdy(ib_bdy)%tem => bf(jfld)%fnow(:,1,:) 
     842            ENDIF 
     843            IF( dta%ll_sal ) THEN  
     844               if(lwp) write(numout,*) '++++++ dta%sal pointing to fnow' 
    645845               jfld = jfld + 1 
    646846               dta_bdy(ib_bdy)%sal => bf(jfld)%fnow(:,1,:) 
    … …  
    649849 
    650850#if defined key_lim2 
    651          IF (nn_ice_lim2(ib_bdy) .gt. 0) THEN 
     851         IF (nn_ice_lim(ib_bdy) .gt. 0) THEN 
    652852            IF( nn_ice_lim2_dta(ib_bdy) .eq. 0 ) THEN 
    653                ilen0(1:3) = nblen(1:3) 
    654                ALLOCATE( dta_bdy(ib_bdy)%frld(ilen0(1)) ) 
    655                ALLOCATE( dta_bdy(ib_bdy)%hicif(ilen0(1)) ) 
    656                ALLOCATE( dta_bdy(ib_bdy)%hsnif(ilen0(1)) ) 
     853               ALLOCATE( dta_bdy(ib_bdy)%frld(nblen(1)) ) 
     854               ALLOCATE( dta_bdy(ib_bdy)%hicif(nblen(1)) ) 
     855               ALLOCATE( dta_bdy(ib_bdy)%hsnif(nblen(1)) ) 
    657856            ELSE 
    658857               jfld = jfld + 1 
    … …  
    662861               jfld = jfld + 1 
    663862               dta_bdy(ib_bdy)%hsnif => bf(jfld)%fnow(:,1,1) 
     863            ENDIF 
     864         ENDIF 
     865#elif defined key_lim3 
     866         IF (nn_ice_lim(ib_bdy) .gt. 0) THEN 
     867            IF( nn_ice_lim_dta(ib_bdy) .eq. 0 ) THEN 
     868               ALLOCATE( dta_bdy(ib_bdy)%a_i (nblen(1),jpl) ) 
     869               ALLOCATE( dta_bdy(ib_bdy)%ht_i(nblen(1),jpl) ) 
     870               ALLOCATE( dta_bdy(ib_bdy)%ht_s(nblen(1),jpl) ) 
     871            ELSE 
     872               IF ( ll_bdylim3 ) THEN ! case input is lim3 type 
     873                  jfld = jfld + 1 
     874                  dta_bdy(ib_bdy)%a_i  => bf(jfld)%fnow(:,1,:) 
     875                  jfld = jfld + 1 
     876                  dta_bdy(ib_bdy)%ht_i => bf(jfld)%fnow(:,1,:) 
     877                  jfld = jfld + 1 
     878                  dta_bdy(ib_bdy)%ht_s => bf(jfld)%fnow(:,1,:) 
     879               ELSE ! case input is lim2 type 
     880                  jfld_ai  = jfld + 1 
     881                  jfld_hti = jfld + 2 
     882                  jfld_hts = jfld + 3 
     883                  jfld     = jfld + 3 
     884                  ALLOCATE( dta_bdy(ib_bdy)%a_i (nblen(1),jpl) ) 
     885                  ALLOCATE( dta_bdy(ib_bdy)%ht_i(nblen(1),jpl) ) 
     886                  ALLOCATE( dta_bdy(ib_bdy)%ht_s(nblen(1),jpl) ) 
     887                  dta_bdy(ib_bdy)%a_i (:,:) = 0.0 
     888                  dta_bdy(ib_bdy)%ht_i(:,:) = 0.0 
     889                  dta_bdy(ib_bdy)%ht_s(:,:) = 0.0 
     890               ENDIF 
     891 
    664892            ENDIF 
    665893         ENDIF 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/BDY/bdydyn.F90

    r4153 r4292  
    3030   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    3131   USE in_out_manager  ! 
    32    USE domvvl          ! variable volume 
     32   USE domvvl 
    3333 
    3434   IMPLICIT NONE 
    … …  
    5757      LOGICAL, INTENT( in ), OPTIONAL :: dyn3d_only       ! T => only update baroclinic velocities 
    5858      !! 
    59       INTEGER               :: jk,ii,ij,ib,igrd     ! Loop counter 
    60       LOGICAL               :: ll_dyn2d, ll_dyn3d   
    61       !! 
     59      INTEGER               :: jk,ii,ij,ib_bdy,ib,igrd     ! Loop counter 
     60      LOGICAL               :: ll_dyn2d, ll_dyn3d, ll_orlanski 
     61      !! 
     62      REAL(wp), POINTER, DIMENSION(:,:) :: phur1, phvr1     ! inverse depth at u and v points 
    6263 
    6364      IF( nn_timing == 1 ) CALL timing_start('bdy_dyn') 
    … …  
    7071      ENDIF 
    7172 
     73      ll_orlanski = .false. 
     74      DO ib_bdy = 1, nb_bdy 
     75         IF ( cn_dyn2d(ib_bdy) == 'orlanski' .or. cn_dyn2d(ib_bdy) == 'orlanski_npo' & 
     76     &   .or. cn_dyn3d(ib_bdy) == 'orlanski' .or. cn_dyn3d(ib_bdy) == 'orlanski_npo') ll_orlanski = .true. 
     77      ENDDO 
     78 
    7279      !------------------------------------------------------- 
    7380      ! Set pointers 
    … …  
    7784      phur => hur 
    7885      phvr => hvr 
    79       CALL wrk_alloc(jpi,jpj,pu2d,pv2d)  
     86      CALL wrk_alloc(jpi,jpj,pua2d,pva2d)  
     87      IF ( ll_orlanski ) CALL wrk_alloc(jpi,jpj,pub2d,pvb2d,phur1,phvr1)  
    8088 
    8189      !------------------------------------------------------- 
    … …  
    8391      !------------------------------------------------------- 
    8492 
    85       pu2d(:,:) = 0.e0 
    86       pv2d(:,:) = 0.e0 
     93      ! "After" velocities:  
     94 
     95      pua2d(:,:) = 0.e0 
     96      pva2d(:,:) = 0.e0 
     97       
    8798      IF (lk_vvl) THEN 
    88          DO jk = 1, jpkm1   !! Vertically integrated momentum trends 
    89             pu2d(:,:) = pu2d(:,:) + fse3u_a(:,:,jk) * umask(:,:,jk) * ua(:,:,jk) 
    90             pv2d(:,:) = pv2d(:,:) + fse3v_a(:,:,jk) * vmask(:,:,jk) * va(:,:,jk) 
    91          END DO 
    92          pu2d(:,:) = pu2d(:,:) / ( hu_0(:,:) + sshu_a(:,:) + 1._wp - umask(:,:,1) ) 
    93          pv2d(:,:) = pv2d(:,:) / ( hv_0(:,:) + sshv_a(:,:) + 1._wp - vmask(:,:,1) ) 
     99         phur1(:,:) = 0. 
     100         phvr1(:,:) = 0. 
     101         DO jk = 1, jpkm1 
     102            phur1(:,:) = phur1(:,:) + fse3u_a(:,:,jk) * umask(:,:,jk) 
     103            phvr1(:,:) = phvr1(:,:) + fse3v_a(:,:,jk) * vmask(:,:,jk) 
     104            pua2d(:,:) = pua2d(:,:) + fse3u_a(:,:,jk) * umask(:,:,jk) * ua(:,:,jk) 
     105            pva2d(:,:) = pva2d(:,:) + fse3v_a(:,:,jk) * vmask(:,:,jk) * va(:,:,jk) 
     106         END DO 
     107         phur1(:,:) = umask(:,:,1) / ( phur1(:,:) + 1. - umask(:,:,1) ) 
     108         phvr1(:,:) = vmask(:,:,1) / ( phvr1(:,:) + 1. - vmask(:,:,1) ) 
     109         pua2d(:,:) = pua2d(:,:) * phur1(:,:) 
     110         pva2d(:,:) = pva2d(:,:) * phvr1(:,:) 
    94111      ELSE 
    95          DO jk = 1, jpkm1   !! Vertically integrated momentum trends 
    96             pu2d(:,:) = pu2d(:,:) + fse3u(:,:,jk) * umask(:,:,jk) * ua(:,:,jk) 
    97             pv2d(:,:) = pv2d(:,:) + fse3v(:,:,jk) * vmask(:,:,jk) * va(:,:,jk) 
    98          END DO 
    99          pu2d(:,:) = pu2d(:,:) * phur(:,:) 
    100          pv2d(:,:) = pv2d(:,:) * phvr(:,:) 
     112         DO jk = 1, jpkm1 
     113            pua2d(:,:) = pua2d(:,:) + fse3u(:,:,jk) * umask(:,:,jk) * ua(:,:,jk) 
     114            pva2d(:,:) = pva2d(:,:) + fse3v(:,:,jk) * vmask(:,:,jk) * va(:,:,jk) 
     115         END DO 
     116         pua2d(:,:) = pua2d(:,:) * phur(:,:) 
     117         pva2d(:,:) = pva2d(:,:) * phvr(:,:) 
    101118      ENDIF 
     119 
    102120      DO jk = 1 , jpkm1 
    103          ua(:,:,jk) = ua(:,:,jk) - pu2d(:,:) * umask(:,:,jk) 
    104          va(:,:,jk) = va(:,:,jk) - pv2d(:,:) * vmask(:,:,jk) 
     121         ua(:,:,jk) = ua(:,:,jk) - pua2d(:,:) 
     122         va(:,:,jk) = va(:,:,jk) - pva2d(:,:) 
    105123      END DO 
     124 
     125      ! "Before" velocities (required for Orlanski condition):  
     126 
     127      IF ( ll_orlanski ) THEN           
     128         pub2d(:,:) = 0.e0 
     129         pvb2d(:,:) = 0.e0 
     130 
     131         IF (lk_vvl) THEN 
     132            phur1(:,:) = 0. 
     133            phvr1(:,:) = 0. 
     134            DO jk = 1, jpkm1   !! Vertically integrated momentum trends 
     135               phur1(:,:) = phur1(:,:) + fse3u_b(:,:,jk) * umask(:,:,jk) 
     136               phvr1(:,:) = phvr1(:,:) + fse3v_b(:,:,jk) * vmask(:,:,jk) 
     137               pub2d(:,:) = pub2d(:,:) + fse3u_b(:,:,jk) * umask(:,:,jk) * ub(:,:,jk) 
     138               pvb2d(:,:) = pvb2d(:,:) + fse3v_b(:,:,jk) * vmask(:,:,jk) * vb(:,:,jk) 
     139            END DO 
     140            phur1(:,:) = umask(:,:,1) / ( phur1(:,:) + 1. - umask(:,:,1) ) 
     141            phvr1(:,:) = vmask(:,:,1) / ( phvr1(:,:) + 1. - vmask(:,:,1) ) 
     142            pub2d(:,:) = pub2d(:,:) * phur1(:,:) 
     143            pvb2d(:,:) = pvb2d(:,:) * phvr1(:,:) 
     144         ELSE 
     145            DO jk = 1, jpkm1   !! Vertically integrated momentum trends 
     146               pub2d(:,:) = pub2d(:,:) + fse3u(:,:,jk) * umask(:,:,jk) * ub(:,:,jk) 
     147               pvb2d(:,:) = pvb2d(:,:) + fse3v(:,:,jk) * vmask(:,:,jk) * vb(:,:,jk) 
     148            END DO 
     149            pub2d(:,:) = pub2d(:,:) * phur(:,:) 
     150            pvb2d(:,:) = pvb2d(:,:) * phvr(:,:) 
     151         ENDIF 
     152 
     153         DO jk = 1 , jpkm1 
     154            ub(:,:,jk) = ub(:,:,jk) - pub2d(:,:) 
     155            vb(:,:,jk) = vb(:,:,jk) - pvb2d(:,:) 
     156         END DO 
     157      END IF 
    106158 
    107159      !------------------------------------------------------- 
    … …  
    119171 
    120172      DO jk = 1 , jpkm1 
    121          ua(:,:,jk) = ( ua(:,:,jk) + pu2d(:,:) ) * umask(:,:,jk) 
    122          va(:,:,jk) = ( va(:,:,jk) + pv2d(:,:) ) * vmask(:,:,jk) 
     173         ua(:,:,jk) = ( ua(:,:,jk) + pua2d(:,:) ) * umask(:,:,jk) 
     174         va(:,:,jk) = ( va(:,:,jk) + pva2d(:,:) ) * vmask(:,:,jk) 
    123175      END DO 
    124176 
    125       CALL wrk_dealloc(jpi,jpj,pu2d,pv2d)  
     177      IF ( ll_orlanski ) THEN 
     178         DO jk = 1 , jpkm1 
     179            ub(:,:,jk) = ( ub(:,:,jk) + pub2d(:,:) ) * umask(:,:,jk) 
     180            vb(:,:,jk) = ( vb(:,:,jk) + pvb2d(:,:) ) * vmask(:,:,jk) 
     181         END DO 
     182      END IF 
     183 
     184      CALL wrk_dealloc(jpi,jpj,pua2d,pva2d)  
     185      IF ( ll_orlanski ) CALL wrk_dealloc(jpi,jpj,pub2d,pvb2d)  
    126186 
    127187      IF( nn_timing == 1 ) CALL timing_stop('bdy_dyn') 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/BDY/bdydyn2d.F90

    r3680 r4292  
    66   !! History :  3.4  !  2011     (D. Storkey) new module as part of BDY rewrite 
    77   !!            3.5  !  2012     (S. Mocavero, I. Epicoco) Optimization of BDY communications 
     8   !!            3.5  !  2013-07  (J. Chanut) Compliant with time splitting changes 
    89   !!---------------------------------------------------------------------- 
    910#if defined key_bdy  
    … …  
    1112   !!   'key_bdy' :                    Unstructured Open Boundary Condition 
    1213   !!---------------------------------------------------------------------- 
    13    !!   bdy_dyn2d      : Apply open boundary conditions to barotropic variables. 
    14    !!   bdy_dyn2d_fla    : Apply Flather condition 
     14   !!   bdy_dyn2d          : Apply open boundary conditions to barotropic variables. 
     15   !!   bdy_dyn2d_frs      : Apply Flow Relaxation Scheme  
     16   !!   bdy_dyn2d_fla      : Apply Flather condition 
     17   !!   bdy_dyn2d_orlanski : Orlanski Radiation 
     18   !!   bdy_ssh            : Duplicate sea level across open boundaries 
    1519   !!---------------------------------------------------------------------- 
    1620   USE timing          ! Timing 
    … …  
    1822   USE dom_oce         ! ocean space and time domain 
    1923   USE bdy_oce         ! ocean open boundary conditions 
     24   USE bdylib          ! BDY library routines 
    2025   USE dynspg_oce      ! for barotropic variables 
    2126   USE phycst          ! physical constants 
    … …  
    2631   PRIVATE 
    2732 
    28    PUBLIC   bdy_dyn2d     ! routine called in dynspg_ts and bdy_dyn 
     33   PUBLIC   bdy_dyn2d   ! routine called in dynspg_ts and bdy_dyn 
     34   PUBLIC   bdy_ssh       ! routine called in dynspg_ts or sshwzv 
    2935 
    3036   !!---------------------------------------------------------------------- 
    … …  
    4854      DO ib_bdy=1, nb_bdy 
    4955 
    50          SELECT CASE( nn_dyn2d(ib_bdy) ) 
    51          CASE(jp_none) 
     56         SELECT CASE( cn_dyn2d(ib_bdy) ) 
     57         CASE('none') 
    5258            CYCLE 
    53          CASE(jp_frs) 
     59         CASE('frs') 
    5460            CALL bdy_dyn2d_frs( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy ) 
    55          CASE(jp_flather) 
     61         CASE('flather') 
    5662            CALL bdy_dyn2d_fla( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy ) 
     63         CASE('orlanski') 
     64            CALL bdy_dyn2d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, ll_npo=.false. ) 
     65         CASE('orlanski_npo') 
     66            CALL bdy_dyn2d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, ll_npo=.true. ) 
    5767         CASE DEFAULT 
    5868            CALL ctl_stop( 'bdy_dyn2d : unrecognised option for open boundaries for barotropic variables' ) 
    … …  
    8999         ij   = idx%nbj(jb,igrd) 
    90100         zwgt = idx%nbw(jb,igrd) 
    91          pu2d(ii,ij) = ( pu2d(ii,ij) + zwgt * ( dta%u2d(jb) - pu2d(ii,ij) ) ) * umask(ii,ij,1) 
     101         pua2d(ii,ij) = ( pua2d(ii,ij) + zwgt * ( dta%u2d(jb) - pua2d(ii,ij) ) ) * umask(ii,ij,1) 
    92102      END DO 
    93103      ! 
    … …  
    97107         ij   = idx%nbj(jb,igrd) 
    98108         zwgt = idx%nbw(jb,igrd) 
    99          pv2d(ii,ij) = ( pv2d(ii,ij) + zwgt * ( dta%v2d(jb) - pv2d(ii,ij) ) ) * vmask(ii,ij,1) 
     109         pva2d(ii,ij) = ( pva2d(ii,ij) + zwgt * ( dta%v2d(jb) - pva2d(ii,ij) ) ) * vmask(ii,ij,1) 
    100110      END DO  
    101       CALL lbc_bdy_lnk( pu2d, 'U', -1., ib_bdy )  
    102       CALL lbc_bdy_lnk( pv2d, 'V', -1., ib_bdy)   ! Boundary points should be updated 
     111      CALL lbc_bdy_lnk( pua2d, 'U', -1., ib_bdy )  
     112      CALL lbc_bdy_lnk( pva2d, 'V', -1., ib_bdy)   ! Boundary points should be updated 
    103113      ! 
    104114      IF( nn_timing == 1 ) CALL timing_stop('bdy_dyn2d_frs') 
    … …  
    133143      INTEGER  ::   jb, igrd                         ! dummy loop indices 
    134144      INTEGER  ::   ii, ij, iim1, iip1, ijm1, ijp1   ! 2D addresses 
     145      REAL(wp), POINTER :: flagu, flagv              ! short cuts 
    135146      REAL(wp) ::   zcorr                            ! Flather correction 
    136147      REAL(wp) ::   zforc                            ! temporary scalar 
     148      REAL(wp) ::   zflag, z1_2                      !    "        " 
    137149      !!---------------------------------------------------------------------- 
    138150 
    139151      IF( nn_timing == 1 ) CALL timing_start('bdy_dyn2d_fla') 
     152 
     153      z1_2 = 0.5_wp 
    140154 
    141155      ! ---------------------------------! 
    … …  
    160174         ii  = idx%nbi(jb,igrd) 
    161175         ij  = idx%nbj(jb,igrd)  
    162          iim1 = ii + MAX( 0, INT( idx%flagu(jb) ) )   ! T pts i-indice inside the boundary 
    163          iip1 = ii - MIN( 0, INT( idx%flagu(jb) ) )   ! T pts i-indice outside the boundary  
     176         flagu => idx%flagu(jb,igrd) 
     177         iim1 = ii + MAX( 0, INT( flagu ) )   ! T pts i-indice inside the boundary 
     178         iip1 = ii - MIN( 0, INT( flagu ) )   ! T pts i-indice outside the boundary  
    164179         ! 
    165          zcorr = - idx%flagu(jb) * SQRT( grav * phur(ii, ij) ) * ( pssh(iim1, ij) - spgu(iip1,ij) ) 
    166          zforc = dta%u2d(jb) 
    167          pu2d(ii,ij) = zforc + zcorr * umask(ii,ij,1)  
     180         zcorr = - flagu * SQRT( grav * phur(ii, ij) ) * ( pssh(iim1, ij) - spgu(iip1,ij) ) 
     181 
     182         ! jchanut tschanges: Set zflag to 0 below to revert to Flather scheme 
     183         ! Use characteristics method instead 
     184         zflag = ABS(flagu) 
     185         zforc = dta%u2d(jb) * (1._wp - z1_2*zflag) + z1_2 * zflag * pua2d(iim1,ij) 
     186         pua2d(ii,ij) = zforc + (1._wp - z1_2*zflag) * zcorr * umask(ii,ij,1)  
    168187      END DO 
    169188      ! 
    … …  
    173192         ii  = idx%nbi(jb,igrd) 
    174193         ij  = idx%nbj(jb,igrd)  
    175          ijm1 = ij + MAX( 0, INT( idx%flagv(jb) ) )   ! T pts j-indice inside the boundary 
    176          ijp1 = ij - MIN( 0, INT( idx%flagv(jb) ) )   ! T pts j-indice outside the boundary  
     194         flagv => idx%flagv(jb,igrd) 
     195         ijm1 = ij + MAX( 0, INT( flagv ) )   ! T pts j-indice inside the boundary 
     196         ijp1 = ij - MIN( 0, INT( flagv ) )   ! T pts j-indice outside the boundary  
    177197         ! 
    178          zcorr = - idx%flagv(jb) * SQRT( grav * phvr(ii, ij) ) * ( pssh(ii, ijm1) - spgu(ii,ijp1) ) 
    179          zforc = dta%v2d(jb) 
    180          pv2d(ii,ij) = zforc + zcorr * vmask(ii,ij,1) 
    181       END DO 
    182       CALL lbc_bdy_lnk( pu2d, 'U', -1., ib_bdy )   ! Boundary points should be updated 
    183       CALL lbc_bdy_lnk( pv2d, 'V', -1., ib_bdy )   ! 
     198         zcorr = - flagv * SQRT( grav * phvr(ii, ij) ) * ( pssh(ii, ijm1) - spgu(ii,ijp1) ) 
     199 
     200         ! jchanut tschanges: Set zflag to 0 below to revert to std Flather scheme 
     201         ! Use characteristics method instead 
     202         zflag = ABS(flagv) 
     203         zforc  = dta%v2d(jb) * (1._wp - z1_2*zflag) + z1_2 * zflag * pva2d(ii,ijm1) 
     204         pva2d(ii,ij) = zforc + (1._wp - z1_2*zflag) * zcorr * vmask(ii,ij,1) 
     205      END DO 
     206      CALL lbc_bdy_lnk( pua2d, 'U', -1., ib_bdy )   ! Boundary points should be updated 
     207      CALL lbc_bdy_lnk( pva2d, 'V', -1., ib_bdy )   ! 
    184208      ! 
    185209      IF( nn_timing == 1 ) CALL timing_stop('bdy_dyn2d_fla') 
    186210      ! 
    187211   END SUBROUTINE bdy_dyn2d_fla 
     212 
     213 
     214   SUBROUTINE bdy_dyn2d_orlanski( idx, dta, ib_bdy, ll_npo ) 
     215      !!---------------------------------------------------------------------- 
     216      !!                 ***  SUBROUTINE bdy_dyn2d_orlanski  *** 
     217      !!              
     218      !!              - Apply Orlanski radiation condition adaptively: 
     219      !!                  - radiation plus weak nudging at outflow points 
     220      !!                  - no radiation and strong nudging at inflow points 
     221      !!  
     222      !! 
     223      !! References:  Marchesiello, McWilliams and Shchepetkin, Ocean Modelling vol. 3 (2001)     
     224      !!---------------------------------------------------------------------- 
     225      TYPE(OBC_INDEX),              INTENT(in) ::   idx  ! OBC indices 
     226      TYPE(OBC_DATA),               INTENT(in) ::   dta  ! OBC external data 
     227      INTEGER,                      INTENT(in) ::   ib_bdy  ! number of current open boundary set 
     228      LOGICAL,                      INTENT(in) ::   ll_npo  ! flag for NPO version 
     229 
     230      INTEGER  ::   ib, igrd                               ! dummy loop indices 
     231      INTEGER  ::   ii, ij, iibm1, ijbm1                   ! indices 
     232      !!---------------------------------------------------------------------- 
     233 
     234      IF( nn_timing == 1 ) CALL timing_start('bdy_dyn2d_orlanski') 
     235      ! 
     236      igrd = 2      ! Orlanski bc on u-velocity;  
     237      !             
     238      CALL bdy_orlanski_2d( idx, igrd, pub2d, pua2d, dta%u2d, ll_npo ) 
     239 
     240      igrd = 3      ! Orlanski bc on v-velocity 
     241      !   
     242      CALL bdy_orlanski_2d( idx, igrd, pvb2d, pva2d, dta%v2d, ll_npo ) 
     243      ! 
     244      IF( nn_timing == 1 ) CALL timing_stop('bdy_dyn2d_orlanski') 
     245      ! 
     246      CALL lbc_bdy_lnk( pua2d, 'U', -1., ib_bdy )   ! Boundary points should be updated 
     247      CALL lbc_bdy_lnk( pva2d, 'V', -1., ib_bdy )   ! 
     248      ! 
     249      IF( nn_timing == 1 ) CALL timing_stop('bdy_dyn2d_orlanski') 
     250      ! 
     251   END SUBROUTINE bdy_dyn2d_orlanski 
     252 
     253   SUBROUTINE bdy_ssh( zssh ) 
     254      !!---------------------------------------------------------------------- 
     255      !!                  ***  SUBROUTINE bdy_ssh  *** 
     256      !! 
     257      !! ** Purpose : Duplicate sea level across open boundaries 
     258      !! 
     259      !!---------------------------------------------------------------------- 
     260      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   zssh ! Sea level 
     261      !! 
     262      INTEGER  ::   ib_bdy, ib, igrd                        ! local integers 
     263      INTEGER  ::   ii, ij, zcoef, zcoef1, zcoef2, ip, jp   !   "       " 
     264 
     265      igrd = 1                       ! Everything is at T-points here 
     266 
     267      DO ib_bdy = 1, nb_bdy 
     268         DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) 
     269            ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
     270            ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
     271            ! Set gradient direction: 
     272            zcoef1 = bdytmask(ii-1,ij  ) +  bdytmask(ii+1,ij  ) 
     273            zcoef2 = bdytmask(ii  ,ij-1) +  bdytmask(ii  ,ij+1) 
     274            IF ( zcoef1+zcoef2 == 0 ) THEN 
     275               ! corner 
     276!               zcoef = tmask(ii-1,ij,1) + tmask(ii+1,ij,1) +  tmask(ii,ij-1,1) +  tmask(ii,ij+1,1) 
     277!               zssh(ii,ij) = zssh(ii-1,ij  ) * tmask(ii-1,ij  ,1) + & 
     278!                 &           zssh(ii+1,ij  ) * tmask(ii+1,ij  ,1) + & 
     279!                 &           zssh(ii  ,ij-1) * tmask(ii  ,ij-1,1) + & 
     280!                 &           zssh(ii  ,ij+1) * tmask(ii  ,ij+1,1) 
     281               zcoef = bdytmask(ii-1,ij) + bdytmask(ii+1,ij) +  bdytmask(ii,ij-1) +  bdytmask(ii,ij+1) 
     282               zssh(ii,ij) = zssh(ii-1,ij  ) * bdytmask(ii-1,ij  ) + & 
     283                 &           zssh(ii+1,ij  ) * bdytmask(ii+1,ij  ) + & 
     284                 &           zssh(ii  ,ij-1) * bdytmask(ii  ,ij-1) + & 
     285                 &           zssh(ii  ,ij+1) * bdytmask(ii  ,ij+1) 
     286               zssh(ii,ij) = ( zssh(ii,ij) / MAX( 1, zcoef) ) * tmask(ii,ij,1) 
     287            ELSE 
     288               ip = bdytmask(ii+1,ij  ) - bdytmask(ii-1,ij  ) 
     289               jp = bdytmask(ii  ,ij+1) - bdytmask(ii  ,ij-1) 
     290               zssh(ii,ij) = zssh(ii+ip,ij+jp) * tmask(ii+ip,ij+jp,1) 
     291            ENDIF 
     292         END DO 
     293 
     294         ! Boundary points should be updated 
     295         CALL lbc_bdy_lnk( zssh(:,:), 'T', 1., ib_bdy ) 
     296      END DO 
     297 
     298   END SUBROUTINE bdy_ssh 
     299 
    188300#else 
    189301   !!---------------------------------------------------------------------- 
    … …  
    192304CONTAINS 
    193305   SUBROUTINE bdy_dyn2d( kt )      ! Empty routine 
    194       WRITE(*,*) 'bdy_dyn_frs: You should not have seen this print! error?', kt 
     306      INTEGER, intent(in) :: kt 
     307      WRITE(*,*) 'bdy_dyn2d: You should not have seen this print! error?', kt 
    195308   END SUBROUTINE bdy_dyn2d 
     309 
    196310#endif 
    197311 
    198312   !!====================================================================== 
    199313END MODULE bdydyn2d 
     314 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/BDY/bdydyn3d.F90

    r3703 r4292  
    1919   USE dom_oce         ! ocean space and time domain 
    2020   USE bdy_oce         ! ocean open boundary conditions 
     21   USE bdylib          ! for orlanski library routines 
    2122   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    2223   USE in_out_manager  ! 
    … …  
    5253      DO ib_bdy=1, nb_bdy 
    5354 
    54 !!$         IF ( using Orlanski radiation conditions ) THEN  
    55 !!$            CALL bdy_rad( kt,  bdyidx(ib_bdy) ) 
    56 !!$         ENDIF 
    57  
    58          SELECT CASE( nn_dyn3d(ib_bdy) ) 
    59          CASE(jp_none) 
     55         SELECT CASE( cn_dyn3d(ib_bdy) ) 
     56         CASE('none') 
    6057            CYCLE 
    61          CASE(jp_frs) 
     58         CASE('frs') 
    6259            CALL bdy_dyn3d_frs( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) 
    63          CASE(2) 
     60         CASE('specified') 
    6461            CALL bdy_dyn3d_spe( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) 
    65          CASE(3) 
     62         CASE('zero') 
    6663            CALL bdy_dyn3d_zro( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) 
     64         CASE('orlanski') 
     65            CALL bdy_dyn3d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, ll_npo=.false. ) 
     66         CASE('orlanski_npo') 
     67            CALL bdy_dyn3d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, ll_npo=.true. ) 
    6768         CASE DEFAULT 
    6869            CALL ctl_stop( 'bdy_dyn3d : unrecognised option for open boundaries for baroclinic velocities' ) 
    … …  
    109110         END DO 
    110111      END DO 
    111       CALL lbc_bdy_lnk( ua, 'U', -1., ib_bdy )   ;   CALL lbc_bdy_lnk( va, 'V', -1.,ib_bdy )   ! Boundary points should be updated 
     112      CALL lbc_bdy_lnk( ua, 'U', -1., ib_bdy )   ! Boundary points should be updated   
     113      CALL lbc_bdy_lnk( va, 'V', -1., ib_bdy )    
    112114      ! 
    113115      IF( kt .eq. nit000 ) CLOSE( unit = 102 ) 
    … …  
    204206         END DO 
    205207      END DO  
    206       CALL lbc_bdy_lnk( ua, 'U', -1., ib_bdy )   ;   CALL lbc_bdy_lnk( va, 'V', -1.,ib_bdy )   ! Boundary points should be updated 
     208      CALL lbc_bdy_lnk( ua, 'U', -1., ib_bdy )    ! Boundary points should be updated 
     209      CALL lbc_bdy_lnk( va, 'V', -1., ib_bdy )    
    207210      ! 
    208211      IF( kt .eq. nit000 ) CLOSE( unit = 102 ) 
    … …  
    211214 
    212215   END SUBROUTINE bdy_dyn3d_frs 
     216 
     217   SUBROUTINE bdy_dyn3d_orlanski( idx, dta, ib_bdy, ll_npo ) 
     218      !!---------------------------------------------------------------------- 
     219      !!                 ***  SUBROUTINE bdy_dyn3d_orlanski  *** 
     220      !!              
     221      !!              - Apply Orlanski radiation to baroclinic velocities.  
     222      !!              - Wrapper routine for bdy_orlanski_3d 
     223      !!  
     224      !! 
     225      !! References:  Marchesiello, McWilliams and Shchepetkin, Ocean Modelling vol. 3 (2001)     
     226      !!---------------------------------------------------------------------- 
     227      TYPE(OBC_INDEX),              INTENT(in) ::   idx  ! OBC indices 
     228      TYPE(OBC_DATA),               INTENT(in) ::   dta  ! OBC external data 
     229      INTEGER,                      INTENT(in) ::   ib_bdy  ! BDY set index 
     230      LOGICAL,                      INTENT(in) ::   ll_npo  ! switch for NPO version 
     231 
     232      INTEGER  ::   jb, igrd                               ! dummy loop indices 
     233      !!---------------------------------------------------------------------- 
     234 
     235      IF( nn_timing == 1 ) CALL timing_start('bdy_dyn3d_orlanski') 
     236      ! 
     237      !! Note that at this stage the ub and ua arrays contain the baroclinic velocities.  
     238      ! 
     239      igrd = 2      ! Orlanski bc on u-velocity;  
     240      !             
     241      CALL bdy_orlanski_3d( idx, igrd, ub, ua, dta%u3d, ll_npo ) 
     242 
     243      igrd = 3      ! Orlanski bc on v-velocity 
     244      !   
     245      CALL bdy_orlanski_3d( idx, igrd, vb, va, dta%v3d, ll_npo ) 
     246      ! 
     247      CALL lbc_bdy_lnk( ua, 'U', -1., ib_bdy )    ! Boundary points should be updated 
     248      CALL lbc_bdy_lnk( va, 'V', -1., ib_bdy )    
     249      ! 
     250      IF( nn_timing == 1 ) CALL timing_stop('bdy_dyn3d_orlanski') 
     251      ! 
     252   END SUBROUTINE bdy_dyn3d_orlanski 
     253 
    213254 
    214255   SUBROUTINE bdy_dyn3d_dmp( kt ) 
    … …  
    225266      REAL(wp) ::   zwgt           ! boundary weight 
    226267      INTEGER  ::  ib_bdy          ! loop index 
     268      REAL(wp), POINTER, DIMENSION(:,:) :: phur1, phvr1     ! inverse depth at u and v points 
    227269      !!---------------------------------------------------------------------- 
    228270      ! 
    … …  
    232274      ! Remove barotropic part from before velocity 
    233275      !------------------------------------------------------- 
    234       CALL wrk_alloc(jpi,jpj,pu2d,pv2d)  
    235  
    236       pu2d(:,:) = 0.e0 
    237       pv2d(:,:) = 0.e0 
    238  
     276      CALL wrk_alloc(jpi,jpj,pub2d,pvb2d,phur1,phvr1)  
     277 
     278      pub2d(:,:) = 0.e0 
     279      pvb2d(:,:) = 0.e0 
     280 
     281      phur1(:,:) = 0. 
     282      phvr1(:,:) = 0. 
    239283      DO jk = 1, jpkm1 
    240284#if defined key_vvl 
    241          pu2d(:,:) = pu2d(:,:) + fse3u_b(:,:,jk)* ub(:,:,jk)   *umask(:,:,jk)  
    242          pv2d(:,:) = pv2d(:,:) + fse3v_b(:,:,jk)* vb(:,:,jk)   *vmask(:,:,jk) 
     285         phur1(:,:) = phur1(:,:) + fse3u_a(:,:,jk) * umask(:,:,jk) 
     286         phvr1(:,:) = phvr1(:,:) + fse3v_a(:,:,jk) * vmask(:,:,jk) 
     287         pub2d(:,:) = pub2d(:,:) + fse3u_b(:,:,jk)* ub(:,:,jk)   *umask(:,:,jk)  
     288         pvb2d(:,:) = pvb2d(:,:) + fse3v_b(:,:,jk)* vb(:,:,jk)   *vmask(:,:,jk) 
    243289#else 
    244          pu2d(:,:) = pu2d(:,:) + fse3u_0(:,:,jk) * ub(:,:,jk)  * umask(:,:,jk) 
    245          pv2d(:,:) = pv2d(:,:) + fse3v_0(:,:,jk) * vb(:,:,jk)  * vmask(:,:,jk) 
     290         pub2d(:,:) = pub2d(:,:) + fse3u_0(:,:,jk) * ub(:,:,jk)  * umask(:,:,jk) 
     291         pvb2d(:,:) = pvb2d(:,:) + fse3v_0(:,:,jk) * vb(:,:,jk)  * vmask(:,:,jk) 
    246292#endif 
    247293      END DO 
    248294 
    249295      IF( lk_vvl ) THEN 
    250          pu2d(:,:) = pu2d(:,:) * umask(:,:,1) / ( hu_0(:,:) + sshu_b(:,:) + 1._wp - umask(:,:,1) ) 
    251          pv2d(:,:) = pv2d(:,:) * vmask(:,:,1) / ( hv_0(:,:) + sshv_b(:,:) + 1._wp - vmask(:,:,1) ) 
     296         phur1(:,:) = umask(:,:,1) / ( phur1(:,:) + 1. - umask(:,:,1) ) 
     297         phvr1(:,:) = vmask(:,:,1) / ( phvr1(:,:) + 1. - vmask(:,:,1) ) 
     298         pub2d(:,:) = pub2d(:,:) * umask(:,:,1) * phur1(:,:) 
     299         pvb2d(:,:) = pvb2d(:,:) * vmask(:,:,1) * phvr1(:,:) 
    252300      ELSE 
    253          pu2d(:,:) = pv2d(:,:) * hur(:,:) 
    254          pv2d(:,:) = pu2d(:,:) * hvr(:,:) 
     301         pub2d(:,:) = pvb2d(:,:) * hur(:,:) 
     302         pvb2d(:,:) = pub2d(:,:) * hvr(:,:) 
    255303      ENDIF 
    256304 
    257305      DO ib_bdy=1, nb_bdy 
    258          IF ( ln_dyn3d_dmp(ib_bdy).and.nn_dyn3d(ib_bdy).gt.0 ) THEN 
     306         IF ( ln_dyn3d_dmp(ib_bdy) .and. cn_dyn3d(ib_bdy) /= 'none' ) THEN 
    259307            igrd = 2                      ! Relaxation of zonal velocity 
    260308            DO jb = 1, idx_bdy(ib_bdy)%nblen(igrd) 
    … …  
    264312               DO jk = 1, jpkm1 
    265313                  ua(ii,ij,jk) = ( ua(ii,ij,jk) + zwgt * ( dta_bdy(ib_bdy)%u3d(jb,jk) - & 
    266                                    ub(ii,ij,jk) + pu2d(ii,ij)) ) * umask(ii,ij,jk) 
     314                                   ub(ii,ij,jk) + pub2d(ii,ij)) ) * umask(ii,ij,jk) 
    267315               END DO 
    268316            END DO 
    … …  
    275323               DO jk = 1, jpkm1 
    276324                  va(ii,ij,jk) = ( va(ii,ij,jk) + zwgt * ( dta_bdy(ib_bdy)%v3d(jb,jk) -  & 
    277                                    vb(ii,ij,jk) + pv2d(ii,ij)) ) * vmask(ii,ij,jk) 
     325                                   vb(ii,ij,jk) + pvb2d(ii,ij)) ) * vmask(ii,ij,jk) 
    278326               END DO 
    279327            END DO 
    … …  
    281329      ENDDO 
    282330      ! 
    283       CALL wrk_dealloc(jpi,jpj,pu2d,pv2d)  
     331      CALL wrk_dealloc(jpi,jpj,pub2d,pvb2d)  
    284332      ! 
    285333      CALL lbc_lnk( ua, 'U', -1. )   ;   CALL lbc_lnk( va, 'V', -1. )   ! Boundary points should be updated 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/BDY/bdyini.F90

    r4148 r4292  
    2121   !!   bdy_init       : Initialization of unstructured open boundaries 
    2222   !!---------------------------------------------------------------------- 
     23   USE wrk_nemo        ! Memory Allocation 
    2324   USE timing          ! Timing 
    2425   USE oce             ! ocean dynamics and tracers variables 
    … …  
    7980      INTEGER  ::   jpbdtau, jpbdtas                       !   -       - 
    8081      INTEGER  ::   ib_bdy1, ib_bdy2, ib1, ib2             !   -       - 
     82      INTEGER  ::   i_offset, j_offset                     !   -       - 
    8183      INTEGER, POINTER  ::  nbi, nbj, nbr                  ! short cuts 
    82       REAL   , POINTER  ::  flagu, flagv                   !    -   - 
     84      REAL(wp), POINTER  ::  flagu, flagv                  !    -   - 
     85      REAL(wp), POINTER, DIMENSION(:,:)       ::   pmask    ! pointer to 2D mask fields 
    8386      REAL(wp) ::   zefl, zwfl, znfl, zsfl                 ! local scalars 
    8487      INTEGER, DIMENSION (2)                  ::   kdimsz 
    … …  
    9093      INTEGER :: com_east_b, com_west_b, com_south_b, com_north_b  ! Flags for boundaries receiving 
    9194      INTEGER :: iw_b(4), ie_b(4), is_b(4), in_b(4)                ! Arrays for neighbours coordinates 
     95      REAL(wp), POINTER, DIMENSION(:,:)       ::   zfmask  ! temporary fmask array excluding coastal boundary condition (shlat) 
    9296 
    9397      !! 
    94       NAMELIST/nambdy/ nb_bdy, ln_coords_file, cn_coords_file,             & 
    95          &             ln_mask_file, cn_mask_file, nn_dyn2d, nn_dyn2d_dta, & 
    96          &             nn_dyn3d, nn_dyn3d_dta, nn_tra, nn_tra_dta,         &   
    97          &             ln_tra_dmp, ln_dyn3d_dmp, rn_time_dmp,             & 
    98 #if defined key_lim2 
    99          &             nn_ice_lim2, nn_ice_lim2_dta,                       & 
     98      NAMELIST/nambdy/ nb_bdy, ln_coords_file, cn_coords_file,                 & 
     99         &             ln_mask_file, cn_mask_file, cn_dyn2d, nn_dyn2d_dta,    & 
     100         &             cn_dyn3d, nn_dyn3d_dta, cn_tra, nn_tra_dta,             &   
     101         &             ln_tra_dmp, ln_dyn3d_dmp, rn_time_dmp, rn_time_dmp_out, & 
     102#if ( defined key_lim2 || defined key_lim3 ) 
     103         &             cn_ice_lim, nn_ice_lim_dta,                           & 
    100104#endif 
    101105         &             ln_vol, nn_volctl, nn_rimwidth 
    … …  
    156160 
    157161        IF(lwp) WRITE(numout,*) 'Boundary conditions for barotropic solution:  ' 
    158         SELECT CASE( nn_dyn2d(ib_bdy) )                   
    159           CASE(jp_none)         ;   IF(lwp) WRITE(numout,*) '      no open boundary condition'         
    160           CASE(jp_frs)          ;   IF(lwp) WRITE(numout,*) '      Flow Relaxation Scheme' 
    161           CASE(jp_flather)      ;   IF(lwp) WRITE(numout,*) '      Flather radiation condition' 
    162           CASE DEFAULT   ;   CALL ctl_stop( 'unrecognised value for nn_dyn2d' ) 
     162        SELECT CASE( cn_dyn2d(ib_bdy) )                   
     163          CASE('none')          
     164             IF(lwp) WRITE(numout,*) '      no open boundary condition'         
     165             dta_bdy(ib_bdy)%ll_ssh = .false. 
     166             dta_bdy(ib_bdy)%ll_u2d = .false. 
     167             dta_bdy(ib_bdy)%ll_v2d = .false. 
     168          CASE('frs')           
     169             IF(lwp) WRITE(numout,*) '      Flow Relaxation Scheme' 
     170             dta_bdy(ib_bdy)%ll_ssh = .false. 
     171             dta_bdy(ib_bdy)%ll_u2d = .true. 
     172             dta_bdy(ib_bdy)%ll_v2d = .true. 
     173          CASE('flather')       
     174             IF(lwp) WRITE(numout,*) '      Flather radiation condition' 
     175             dta_bdy(ib_bdy)%ll_ssh = .true. 
     176             dta_bdy(ib_bdy)%ll_u2d = .true. 
     177             dta_bdy(ib_bdy)%ll_v2d = .true. 
     178          CASE('orlanski')      
     179             IF(lwp) WRITE(numout,*) '      Orlanski (fully oblique) radiation condition with adaptive nudging' 
     180             dta_bdy(ib_bdy)%ll_ssh = .false. 
     181             dta_bdy(ib_bdy)%ll_u2d = .true. 
     182             dta_bdy(ib_bdy)%ll_v2d = .true. 
     183          CASE('orlanski_npo')  
     184             IF(lwp) WRITE(numout,*) '      Orlanski (NPO) radiation condition with adaptive nudging' 
     185             dta_bdy(ib_bdy)%ll_ssh = .false. 
     186             dta_bdy(ib_bdy)%ll_u2d = .true. 
     187             dta_bdy(ib_bdy)%ll_v2d = .true. 
     188          CASE DEFAULT   ;   CALL ctl_stop( 'unrecognised value for cn_dyn2d' ) 
    163189        END SELECT 
    164         IF( nn_dyn2d(ib_bdy) .gt. 0 ) THEN 
     190        IF( cn_dyn2d(ib_bdy) /= 'none' ) THEN 
    165191           SELECT CASE( nn_dyn2d_dta(ib_bdy) )                   !  
    166192              CASE( 0 )      ;   IF(lwp) WRITE(numout,*) '      initial state used for bdy data'         
    … …  
    177203 
    178204        IF(lwp) WRITE(numout,*) 'Boundary conditions for baroclinic velocities:  ' 
    179         SELECT CASE( nn_dyn3d(ib_bdy) )                   
    180           CASE(jp_none)  ;   IF(lwp) WRITE(numout,*) '      no open boundary condition'         
    181           CASE(jp_frs)   ;   IF(lwp) WRITE(numout,*) '      Flow Relaxation Scheme' 
    182           CASE( 2 )      ;   IF(lwp) WRITE(numout,*) '      Specified value' 
    183           CASE( 3 )      ;   IF(lwp) WRITE(numout,*) '      Zero baroclinic velocities (runoff case)' 
    184           CASE DEFAULT   ;   CALL ctl_stop( 'unrecognised value for nn_dyn3d' ) 
     205        SELECT CASE( cn_dyn3d(ib_bdy) )                   
     206          CASE('none') 
     207             IF(lwp) WRITE(numout,*) '      no open boundary condition'         
     208             dta_bdy(ib_bdy)%ll_u3d = .false. 
     209             dta_bdy(ib_bdy)%ll_v3d = .false. 
     210          CASE('frs')        
     211             IF(lwp) WRITE(numout,*) '      Flow Relaxation Scheme' 
     212             dta_bdy(ib_bdy)%ll_u3d = .true. 
     213             dta_bdy(ib_bdy)%ll_v3d = .true. 
     214          CASE('specified') 
     215             IF(lwp) WRITE(numout,*) '      Specified value' 
     216             dta_bdy(ib_bdy)%ll_u3d = .true. 
     217             dta_bdy(ib_bdy)%ll_v3d = .true. 
     218          CASE('zero') 
     219             IF(lwp) WRITE(numout,*) '      Zero baroclinic velocities (runoff case)' 
     220             dta_bdy(ib_bdy)%ll_u3d = .false. 
     221             dta_bdy(ib_bdy)%ll_v3d = .false. 
     222          CASE('orlanski') 
     223             IF(lwp) WRITE(numout,*) '      Orlanski (fully oblique) radiation condition with adaptive nudging' 
     224             dta_bdy(ib_bdy)%ll_u3d = .true. 
     225             dta_bdy(ib_bdy)%ll_v3d = .true. 
     226          CASE('orlanski_npo') 
     227             IF(lwp) WRITE(numout,*) '      Orlanski (NPO) radiation condition with adaptive nudging' 
     228             dta_bdy(ib_bdy)%ll_u3d = .true. 
     229             dta_bdy(ib_bdy)%ll_v3d = .true. 
     230          CASE DEFAULT   ;   CALL ctl_stop( 'unrecognised value for cn_dyn3d' ) 
    185231        END SELECT 
    186         IF( nn_dyn3d(ib_bdy) .gt. 0 ) THEN 
     232        IF( cn_dyn3d(ib_bdy) /= 'none' ) THEN 
    187233           SELECT CASE( nn_dyn3d_dta(ib_bdy) )                   !  
    188234              CASE( 0 )      ;   IF(lwp) WRITE(numout,*) '      initial state used for bdy data'         
    … …  
    193239 
    194240        IF ( ln_dyn3d_dmp(ib_bdy) ) THEN 
    195            IF ( nn_dyn3d(ib_bdy).EQ.0 ) THEN 
     241           IF ( cn_dyn3d(ib_bdy) == 'none' ) THEN 
    196242              IF(lwp) WRITE(numout,*) 'No open boundary condition for baroclinic velocities: ln_dyn3d_dmp is set to .false.' 
    197243              ln_dyn3d_dmp(ib_bdy)=.false. 
    198            ELSEIF ( nn_dyn3d(ib_bdy).EQ.1 ) THEN 
     244           ELSEIF ( cn_dyn3d(ib_bdy) == 'frs' ) THEN 
    199245              CALL ctl_stop( 'Use FRS OR relaxation' ) 
    200246           ELSE 
    … …  
    202248              IF(lwp) WRITE(numout,*) '      Damping time scale: ',rn_time_dmp(ib_bdy),' days' 
    203249              IF((lwp).AND.rn_time_dmp(ib_bdy)<0) CALL ctl_stop( 'Time scale must be positive' ) 
     250              dta_bdy(ib_bdy)%ll_u3d = .true. 
     251              dta_bdy(ib_bdy)%ll_v3d = .true. 
    204252           ENDIF 
    205253        ELSE 
    … …  
    209257 
    210258        IF(lwp) WRITE(numout,*) 'Boundary conditions for temperature and salinity:  ' 
    211         SELECT CASE( nn_tra(ib_bdy) )                   
    212           CASE(jp_none)  ;   IF(lwp) WRITE(numout,*) '      no open boundary condition'         
    213           CASE(jp_frs)   ;   IF(lwp) WRITE(numout,*) '      Flow Relaxation Scheme' 
    214           CASE( 2 )      ;   IF(lwp) WRITE(numout,*) '      Specified value' 
    215           CASE( 3 )      ;   IF(lwp) WRITE(numout,*) '      Neumann conditions' 
    216           CASE( 4 )      ;   IF(lwp) WRITE(numout,*) '      Runoff conditions : Neumann for T and specified to 0.1 for salinity' 
    217           CASE DEFAULT   ;   CALL ctl_stop( 'unrecognised value for nn_tra' ) 
     259        SELECT CASE( cn_tra(ib_bdy) )                   
     260          CASE('none') 
     261             IF(lwp) WRITE(numout,*) '      no open boundary condition'         
     262             dta_bdy(ib_bdy)%ll_tem = .false. 
     263             dta_bdy(ib_bdy)%ll_sal = .false. 
     264          CASE('frs') 
     265             IF(lwp) WRITE(numout,*) '      Flow Relaxation Scheme' 
     266             dta_bdy(ib_bdy)%ll_tem = .true. 
     267             dta_bdy(ib_bdy)%ll_sal = .true. 
     268          CASE('specified') 
     269             IF(lwp) WRITE(numout,*) '      Specified value' 
     270             dta_bdy(ib_bdy)%ll_tem = .true. 
     271             dta_bdy(ib_bdy)%ll_sal = .true. 
     272          CASE('neumann') 
     273             IF(lwp) WRITE(numout,*) '      Neumann conditions' 
     274             dta_bdy(ib_bdy)%ll_tem = .false. 
     275             dta_bdy(ib_bdy)%ll_sal = .false. 
     276          CASE('runoff') 
     277             IF(lwp) WRITE(numout,*) '      Runoff conditions : Neumann for T and specified to 0.1 for salinity' 
     278             dta_bdy(ib_bdy)%ll_tem = .false. 
     279             dta_bdy(ib_bdy)%ll_sal = .false. 
     280          CASE('orlanski') 
     281             IF(lwp) WRITE(numout,*) '      Orlanski (fully oblique) radiation condition with adaptive nudging' 
     282             dta_bdy(ib_bdy)%ll_tem = .true. 
     283             dta_bdy(ib_bdy)%ll_sal = .true. 
     284          CASE('orlanski_npo') 
     285             IF(lwp) WRITE(numout,*) '      Orlanski (NPO) radiation condition with adaptive nudging' 
     286             dta_bdy(ib_bdy)%ll_tem = .true. 
     287             dta_bdy(ib_bdy)%ll_sal = .true. 
     288          CASE DEFAULT   ;   CALL ctl_stop( 'unrecognised value for cn_tra' ) 
    218289        END SELECT 
    219         IF( nn_tra(ib_bdy) .gt. 0 ) THEN 
     290        IF( cn_tra(ib_bdy) /= 'none' ) THEN 
    220291           SELECT CASE( nn_tra_dta(ib_bdy) )                   !  
    221292              CASE( 0 )      ;   IF(lwp) WRITE(numout,*) '      initial state used for bdy data'         
    … …  
    226297 
    227298        IF ( ln_tra_dmp(ib_bdy) ) THEN 
    228            IF ( nn_tra(ib_bdy).EQ.0 ) THEN 
     299           IF ( cn_tra(ib_bdy) == 'none' ) THEN 
    229300              IF(lwp) WRITE(numout,*) 'No open boundary condition for tracers: ln_tra_dmp is set to .false.' 
    230301              ln_tra_dmp(ib_bdy)=.false. 
    231            ELSEIF ( nn_tra(ib_bdy).EQ.1 ) THEN 
     302           ELSEIF ( cn_tra(ib_bdy) == 'frs' ) THEN 
    232303              CALL ctl_stop( 'Use FRS OR relaxation' ) 
    233304           ELSE 
    234305              IF(lwp) WRITE(numout,*) '      + T/S relaxation zone' 
    235306              IF(lwp) WRITE(numout,*) '      Damping time scale: ',rn_time_dmp(ib_bdy),' days' 
     307              IF(lwp) WRITE(numout,*) '      Outflow damping time scale: ',rn_time_dmp_out(ib_bdy),' days' 
    236308              IF((lwp).AND.rn_time_dmp(ib_bdy)<0) CALL ctl_stop( 'Time scale must be positive' ) 
     309              dta_bdy(ib_bdy)%ll_tem = .true. 
     310              dta_bdy(ib_bdy)%ll_sal = .true. 
    237311           ENDIF 
    238312        ELSE 
    … …  
    243317#if defined key_lim2 
    244318        IF(lwp) WRITE(numout,*) 'Boundary conditions for sea ice:  ' 
    245         SELECT CASE( nn_ice_lim2(ib_bdy) )                   
    246           CASE( 0 )      ;   IF(lwp) WRITE(numout,*) '      no open boundary condition'         
    247           CASE( 1 )      ;   IF(lwp) WRITE(numout,*) '      Flow Relaxation Scheme' 
    248           CASE DEFAULT   ;   CALL ctl_stop( 'unrecognised value for nn_tra' ) 
     319        SELECT CASE( cn_ice_lim(ib_bdy) )                   
     320          CASE('none') 
     321             IF(lwp) WRITE(numout,*) '      no open boundary condition'         
     322             dta_bdy(ib_bdy)%ll_frld  = .false. 
     323             dta_bdy(ib_bdy)%ll_hicif = .false. 
     324             dta_bdy(ib_bdy)%ll_hsnif = .false. 
     325          CASE('frs') 
     326             IF(lwp) WRITE(numout,*) '      Flow Relaxation Scheme' 
     327             dta_bdy(ib_bdy)%ll_frld  = .true. 
     328             dta_bdy(ib_bdy)%ll_hicif = .true. 
     329             dta_bdy(ib_bdy)%ll_hsnif = .true. 
     330          CASE DEFAULT   ;   CALL ctl_stop( 'unrecognised value for cn_ice_lim' ) 
    249331        END SELECT 
    250         IF( nn_ice_lim2(ib_bdy) .gt. 0 ) THEN  
    251            SELECT CASE( nn_ice_lim2_dta(ib_bdy) )                   !  
     332        IF( cn_ice_lim(ib_bdy) /= 'none' ) THEN  
     333           SELECT CASE( nn_ice_lim_dta(ib_bdy) )                   !  
    252334              CASE( 0 )      ;   IF(lwp) WRITE(numout,*) '      initial state used for bdy data'         
    253335              CASE( 1 )      ;   IF(lwp) WRITE(numout,*) '      boundary data taken from file' 
    254               CASE DEFAULT   ;   CALL ctl_stop( 'nn_ice_lim2_dta must be 0 or 1' ) 
     336              CASE DEFAULT   ;   CALL ctl_stop( 'nn_ice_lim_dta must be 0 or 1' ) 
     337           END SELECT 
     338        ENDIF 
     339        IF(lwp) WRITE(numout,*) 
     340#elif defined key_lim3 
     341        IF(lwp) WRITE(numout,*) 'Boundary conditions for sea ice:  ' 
     342        SELECT CASE( cn_ice_lim(ib_bdy) )                   
     343          CASE('none') 
     344             IF(lwp) WRITE(numout,*) '      no open boundary condition'         
     345             dta_bdy(ib_bdy)%ll_a_i  = .false. 
     346             dta_bdy(ib_bdy)%ll_ht_i = .false. 
     347             dta_bdy(ib_bdy)%ll_ht_s = .false. 
     348          CASE('frs') 
     349             IF(lwp) WRITE(numout,*) '      Flow Relaxation Scheme' 
     350             dta_bdy(ib_bdy)%ll_a_i  = .true. 
     351             dta_bdy(ib_bdy)%ll_ht_i = .true. 
     352             dta_bdy(ib_bdy)%ll_ht_s = .true. 
     353          CASE DEFAULT   ;   CALL ctl_stop( 'unrecognised value for cn_ice_lim' ) 
     354        END SELECT 
     355        IF( cn_ice_lim(ib_bdy) /= 'none' ) THEN  
     356           SELECT CASE( nn_ice_lim_dta(ib_bdy) )                   !  
     357              CASE( 0 )      ;   IF(lwp) WRITE(numout,*) '      initial state used for bdy data'         
     358              CASE( 1 )      ;   IF(lwp) WRITE(numout,*) '      boundary data taken from file' 
     359              CASE DEFAULT   ;   CALL ctl_stop( 'nn_ice_lim_dta must be 0 or 1' ) 
    255360           END SELECT 
    256361        ENDIF 
    … …  
    740845               IF(lwp) THEN         ! Since all procs read global data only need to do this check on one proc... 
    741846                  IF( nbrdta(ib,igrd,ib_bdy) < nbrdta(ibm1,igrd,ib_bdy) ) THEN 
    742                      CALL ctl_stop('bdy_init : ERROR : boundary data in file  & 
    743                                     must be defined in order of distance from edge nbr.', & 
    744                                    'A utility for re-ordering boundary coordinates and data & 
    745                                     files exists in the TOOLS/OBC directory') 
     847                     CALL ctl_stop('bdy_init : ERROR : boundary data in file must be defined in order of distance from edge nbr.', & 
     848                                   'A utility for re-ordering boundary coordinates and data files exists in the TOOLS/OBC directory') 
    746849                  ENDIF     
    747850               ENDIF 
    … …  
    766869         ALLOCATE( idx_bdy(ib_bdy)%nbr(ilen1,jpbgrd) ) 
    767870         ALLOCATE( idx_bdy(ib_bdy)%nbd(ilen1,jpbgrd) ) 
     871         ALLOCATE( idx_bdy(ib_bdy)%nbdout(ilen1,jpbgrd) ) 
    768872         ALLOCATE( idx_bdy(ib_bdy)%nbmap(ilen1,jpbgrd) ) 
    769873         ALLOCATE( idx_bdy(ib_bdy)%nbw(ilen1,jpbgrd) ) 
    770          ALLOCATE( idx_bdy(ib_bdy)%flagu(ilen1) ) 
    771          ALLOCATE( idx_bdy(ib_bdy)%flagv(ilen1) ) 
     874         ALLOCATE( idx_bdy(ib_bdy)%flagu(ilen1,jpbgrd) ) 
     875         ALLOCATE( idx_bdy(ib_bdy)%flagv(ilen1,jpbgrd) ) 
    772876 
    773877         ! Dispatch mapping indices and discrete distances on each processor 
    … …  
    9371041            ENDDO 
    9381042         ENDDO  
     1043 
    9391044         ! definition of the i- and j- direction local boundaries arrays 
    9401045         ! used for sending the boudaries 
    … …  
    9901095               nbr => idx_bdy(ib_bdy)%nbr(ib,igrd) 
    9911096               idx_bdy(ib_bdy)%nbd(ib,igrd) = 1. / ( rn_time_dmp(ib_bdy) * rday ) &  
     1097               & *(FLOAT(nn_rimwidth(ib_bdy)+1-nbr)/FLOAT(nn_rimwidth(ib_bdy)))**2.   ! quadratic 
     1098               idx_bdy(ib_bdy)%nbdout(ib,igrd) = 1. / ( rn_time_dmp_out(ib_bdy) * rday ) &  
    9921099               & *(FLOAT(nn_rimwidth(ib_bdy)+1-nbr)/FLOAT(nn_rimwidth(ib_bdy)))**2.   ! quadratic 
    9931100            END DO 
    … …  
    10921199      ENDDO 
    10931200 
     1201      ! For the flagu/flagv calculation below we require a version of fmask without 
     1202      ! the land boundary condition (shlat) included: 
     1203      CALL wrk_alloc(jpi,jpj,zfmask)  
     1204      DO ij = 2, jpjm1 
     1205         DO ii = 2, jpim1 
     1206            zfmask(ii,ij) = tmask(ii,ij  ,1) * tmask(ii+1,ij  ,1)   & 
     1207           &              * tmask(ii,ij+1,1) * tmask(ii+1,ij+1,1) 
     1208         END DO       
     1209      END DO 
     1210 
    10941211      ! Lateral boundary conditions 
     1212      CALL lbc_lnk( zfmask       , 'F', 1. ) 
    10951213      CALL lbc_lnk( fmask        , 'F', 1. )   ;   CALL lbc_lnk( bdytmask(:,:), 'T', 1. ) 
    10961214      CALL lbc_lnk( bdyumask(:,:), 'U', 1. )   ;   CALL lbc_lnk( bdyvmask(:,:), 'V', 1. ) 
    … …  
    10981216      DO ib_bdy = 1, nb_bdy       ! Indices and directions of rim velocity components 
    10991217 
    1100          idx_bdy(ib_bdy)%flagu(:) = 0.e0 
    1101          idx_bdy(ib_bdy)%flagv(:) = 0.e0 
     1218         idx_bdy(ib_bdy)%flagu(:,:) = 0.e0 
     1219         idx_bdy(ib_bdy)%flagv(:,:) = 0.e0 
    11021220         icount = 0  
    11031221 
    1104          !flagu = -1 : u component is normal to the dynamical boundary but its direction is outward 
    1105          !flagu =  0 : u is tangential 
    1106          !flagu =  1 : u is normal to the boundary and is direction is inward 
     1222         ! Calculate relationship of U direction to the local orientation of the boundary 
     1223         ! flagu = -1 : u component is normal to the dynamical boundary and its direction is outward 
     1224         ! flagu =  0 : u is tangential 
     1225         ! flagu =  1 : u is normal to the boundary and is direction is inward 
    11071226   
    1108          igrd = 2      ! u-component  
    1109          DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd)   
    1110             nbi => idx_bdy(ib_bdy)%nbi(ib,igrd) 
    1111             nbj => idx_bdy(ib_bdy)%nbj(ib,igrd) 
    1112             zefl = bdytmask(nbi  ,nbj) 
    1113             zwfl = bdytmask(nbi+1,nbj) 
    1114             IF( zefl + zwfl == 2 ) THEN 
    1115                icount = icount + 1 
    1116             ELSE 
    1117                idx_bdy(ib_bdy)%flagu(ib)=-zefl+zwfl 
    1118             ENDIF 
     1227         DO igrd = 1,jpbgrd  
     1228            SELECT CASE( igrd ) 
     1229               CASE( 1 ) 
     1230                  pmask => umask(:,:,1) 
     1231                  i_offset = 0 
     1232               CASE( 2 )  
     1233                  pmask => bdytmask 
     1234                  i_offset = 1 
     1235               CASE( 3 )  
     1236                  pmask => zfmask(:,:) 
     1237                  i_offset = 0 
     1238            END SELECT  
     1239            icount = 0 
     1240            DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd)   
     1241               nbi => idx_bdy(ib_bdy)%nbi(ib,igrd) 
     1242               nbj => idx_bdy(ib_bdy)%nbj(ib,igrd) 
     1243               zefl = pmask(nbi+i_offset-1,nbj) 
     1244               zwfl = pmask(nbi+i_offset,nbj) 
     1245               ! This error check only works if you are using the bdyXmask arrays 
     1246               IF( i_offset == 1 .and. zefl + zwfl == 2 ) THEN 
     1247                  icount = icount + 1 
     1248                  IF(lwp) WRITE(numout,*) 'Problem with igrd = ',igrd,' at (global) nbi, nbj : ',mig(nbi),mjg(nbj) 
     1249               ELSE 
     1250                  idx_bdy(ib_bdy)%flagu(ib,igrd) = -zefl + zwfl 
     1251               ENDIF 
     1252            END DO 
     1253            IF( icount /= 0 ) THEN 
     1254               IF(lwp) WRITE(numout,*) 
     1255               IF(lwp) WRITE(numout,*) ' E R R O R : Some ',cgrid(igrd),' grid points,',   & 
     1256                  ' are not boundary points (flagu calculation). Check nbi, nbj, indices for boundary set ',ib_bdy 
     1257               IF(lwp) WRITE(numout,*) ' ========== ' 
     1258               IF(lwp) WRITE(numout,*) 
     1259               nstop = nstop + 1 
     1260            ENDIF  
    11191261         END DO 
    11201262 
    1121          !flagv = -1 : u component is normal to the dynamical boundary but its direction is outward 
    1122          !flagv =  0 : u is tangential 
    1123          !flagv =  1 : u is normal to the boundary and is direction is inward 
    1124  
    1125          igrd = 3      ! v-component 
    1126          DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd)   
    1127             nbi => idx_bdy(ib_bdy)%nbi(ib,igrd) 
    1128             nbj => idx_bdy(ib_bdy)%nbj(ib,igrd) 
    1129             znfl = bdytmask(nbi,nbj  ) 
    1130             zsfl = bdytmask(nbi,nbj+1) 
    1131             IF( znfl + zsfl == 2 ) THEN 
    1132                icount = icount + 1 
    1133             ELSE 
    1134                idx_bdy(ib_bdy)%flagv(ib) = -znfl + zsfl 
    1135             END IF 
     1263         ! Calculate relationship of V direction to the local orientation of the boundary 
     1264         ! flagv = -1 : v component is normal to the dynamical boundary but its direction is outward 
     1265         ! flagv =  0 : v is tangential 
     1266         ! flagv =  1 : v is normal to the boundary and is direction is inward 
     1267 
     1268         DO igrd = 1,jpbgrd  
     1269            SELECT CASE( igrd ) 
     1270               CASE( 1 ) 
     1271                  pmask => vmask(:,:,1) 
     1272                  j_offset = 0 
     1273               CASE( 2 ) 
     1274                  pmask => zfmask(:,:) 
     1275                  j_offset = 0 
     1276               CASE( 3 ) 
     1277                  pmask => bdytmask 
     1278                  j_offset = 1 
     1279            END SELECT  
     1280            icount = 0 
     1281            DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd)   
     1282               nbi => idx_bdy(ib_bdy)%nbi(ib,igrd) 
     1283               nbj => idx_bdy(ib_bdy)%nbj(ib,igrd) 
     1284               znfl = pmask(nbi,nbj+j_offset-1  ) 
     1285               zsfl = pmask(nbi,nbj+j_offset) 
     1286               ! This error check only works if you are using the bdyXmask arrays 
     1287               IF( j_offset == 1 .and. znfl + zsfl == 2 ) THEN 
     1288                  IF(lwp) WRITE(numout,*) 'Problem with igrd = ',igrd,' at (global) nbi, nbj : ',mig(nbi),mjg(nbj) 
     1289                  icount = icount + 1 
     1290               ELSE 
     1291                  idx_bdy(ib_bdy)%flagv(ib,igrd) = -znfl + zsfl 
     1292               END IF 
     1293            END DO 
     1294            IF( icount /= 0 ) THEN 
     1295               IF(lwp) WRITE(numout,*) 
     1296               IF(lwp) WRITE(numout,*) ' E R R O R : Some ',cgrid(igrd),' grid points,',   & 
     1297                  ' are not boundary points (flagv calculation). Check nbi, nbj, indices for boundary set ',ib_bdy 
     1298               IF(lwp) WRITE(numout,*) ' ========== ' 
     1299               IF(lwp) WRITE(numout,*) 
     1300               nstop = nstop + 1 
     1301            ENDIF  
    11361302         END DO 
    11371303 
    1138          IF( icount /= 0 ) THEN 
    1139             IF(lwp) WRITE(numout,*) 
    1140             IF(lwp) WRITE(numout,*) ' E R R O R : Some data velocity points,',   & 
    1141                ' are not boundary points. Check nbi, nbj, indices for boundary set ',ib_bdy 
    1142             IF(lwp) WRITE(numout,*) ' ========== ' 
    1143             IF(lwp) WRITE(numout,*) 
    1144             nstop = nstop + 1 
    1145          ENDIF  
    1146      
    1147       ENDDO 
     1304      END DO 
    11481305 
    11491306      ! Compute total lateral surface for volume correction: 
    … …  
    11571314               nbi => idx_bdy(ib_bdy)%nbi(ib,igrd) 
    11581315               nbj => idx_bdy(ib_bdy)%nbj(ib,igrd) 
    1159                flagu => idx_bdy(ib_bdy)%flagu(ib) 
     1316               flagu => idx_bdy(ib_bdy)%flagu(ib,igrd) 
    11601317               bdysurftot = bdysurftot + hu     (nbi  , nbj)                           & 
    11611318                  &                    * e2u    (nbi  , nbj) * ABS( flagu ) & 
    … …  
    11701327               nbi => idx_bdy(ib_bdy)%nbi(ib,igrd) 
    11711328               nbj => idx_bdy(ib_bdy)%nbj(ib,igrd) 
    1172                flagv => idx_bdy(ib_bdy)%flagv(ib) 
     1329               flagv => idx_bdy(ib_bdy)%flagv(ib,igrd) 
    11731330               bdysurftot = bdysurftot + hv     (nbi, nbj  )                           & 
    11741331                  &                    * e1v    (nbi, nbj  ) * ABS( flagv ) & 
    … …  
    11861343         DEALLOCATE(nbidta, nbjdta, nbrdta) 
    11871344      ENDIF 
     1345 
     1346      CALL wrk_dealloc(jpi,jpj,zfmask)  
    11881347 
    11891348      IF( nn_timing == 1 ) CALL timing_stop('bdy_init') 
    … …  
    15801739      itest = 0 
    15811740 
    1582       IF (nn_dyn2d(ib1)/=nn_dyn2d(ib2)) itest = itest + 1 
    1583       IF (nn_dyn3d(ib1)/=nn_dyn3d(ib2)) itest = itest + 1 
    1584       IF (nn_tra(ib1)/=nn_tra(ib2)) itest = itest + 1 
     1741      IF (cn_dyn2d(ib1)/=cn_dyn2d(ib2)) itest = itest + 1 
     1742      IF (cn_dyn3d(ib1)/=cn_dyn3d(ib2)) itest = itest + 1 
     1743      IF (cn_tra(ib1)/=cn_tra(ib2)) itest = itest + 1 
    15851744      ! 
    15861745      IF (nn_dyn2d_dta(ib1)/=nn_dyn2d_dta(ib2)) itest = itest + 1 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/BDY/bdytides.F90

    r4147 r4292  
    99   !!            3.3  !  2010-09  (D.Storkey and E.O'Dea)  bug fixes 
    1010   !!            3.4  !  2012-09  (G. Reffray and J. Chanut) New inputs + mods 
     11   !!            3.5  !  2013-07  (J. Chanut) Compliant with time splitting changes 
    1112   !!---------------------------------------------------------------------- 
    1213#if defined key_bdy 
    … …  
    3233!   USE tide_mod       ! Useless ?? 
    3334   USE fldread, ONLY: fld_map 
     35   USE dynspg_oce, ONLY: lk_dynspg_ts 
    3436 
    3537   IMPLICIT NONE 
    … …  
    3840   PUBLIC   bdytide_init     ! routine called in bdy_init 
    3941   PUBLIC   bdytide_update   ! routine called in bdy_dta 
     42   PUBLIC   bdy_dta_tides    ! routine called in dyn_spg_ts 
    4043 
    4144   TYPE, PUBLIC ::   TIDES_DATA     !: Storage for external tidal harmonics data 
    … …  
    4952 
    5053   TYPE(TIDES_DATA), PUBLIC, DIMENSION(jp_bdy), TARGET :: tides  !: External tidal harmonics data 
     54   TYPE(OBC_DATA)  , PRIVATE, DIMENSION(jp_bdy) :: dta_bdy_s  !: bdy external data (slow component) 
    5155 
    5256   !!---------------------------------------------------------------------- 
    … …  
    131135            ! JC: If FRS scheme is used, we assume that tidal is needed over the whole 
    132136            ! relaxation area       
    133             IF( nn_dyn2d(ib_bdy) .eq. jp_frs ) THEN 
     137            IF( cn_dyn2d(ib_bdy) == 'frs' ) THEN 
    134138               ilen0(:)=nblen(:) 
    135139            ELSE 
    … …  
    146150            ALLOCATE( td%v ( ilen0(3), nb_harmo, 2 ) ) 
    147151 
    148             td%ssh0(:,:,:) = 0.e0 
    149             td%ssh(:,:,:) = 0.e0 
    150             td%u0(:,:,:) = 0.e0 
    151             td%u(:,:,:) = 0.e0 
    152             td%v0(:,:,:) = 0.e0 
    153             td%v(:,:,:) = 0.e0 
     152            td%ssh0(:,:,:) = 0._wp 
     153            td%ssh (:,:,:) = 0._wp 
     154            td%u0  (:,:,:) = 0._wp 
     155            td%u   (:,:,:) = 0._wp 
     156            td%v0  (:,:,:) = 0._wp 
     157            td%v   (:,:,:) = 0._wp 
    154158 
    155159            IF (ln_bdytide_2ddta) THEN 
    … …  
    255259            ENDIF 
    256260            ! 
     261            IF ( lk_dynspg_ts ) THEN ! Allocate arrays to save slowly varying boundary data during 
     262                                     ! time splitting integration 
     263               ALLOCATE( dta_bdy_s(ib_bdy)%ssh ( ilen0(1) ) ) 
     264               ALLOCATE( dta_bdy_s(ib_bdy)%u2d ( ilen0(2) ) ) 
     265               ALLOCATE( dta_bdy_s(ib_bdy)%v2d ( ilen0(3) ) ) 
     266               dta_bdy_s(ib_bdy)%ssh(:) = 0.e0 
     267               dta_bdy_s(ib_bdy)%u2d(:) = 0.e0 
     268               dta_bdy_s(ib_bdy)%v2d(:) = 0.e0 
     269            ENDIF 
     270            ! 
    257271         ENDIF ! nn_dyn2d_dta(ib_bdy) .ge. 2 
    258272         ! 
    … …  
    300314      ENDIF 
    301315 
    302       IF ( nsec_day == NINT(0.5 * rdttra(1)) .AND. zflag==1 ) THEN 
     316      IF ( nsec_day == NINT(0.5_wp * rdttra(1)) .AND. zflag==1 ) THEN 
    303317        ! 
    304318        kt_tide = kt 
    … …  
    321335          
    322336      IF( PRESENT(jit) ) THEN   
    323          z_arg = ( ((kt-kt_tide)-1) * rdt + (jit+time_add) * rdt / REAL(nn_baro,wp) ) 
     337         z_arg = ((kt-kt_tide) * rdt + (jit+0.5_wp*(time_add-1)) * rdt / REAL(nn_baro,wp) ) 
    324338      ELSE                               
    325339         z_arg = ((kt-kt_tide)+time_add) * rdt 
    … …  
    327341 
    328342      ! Linear ramp on tidal component at open boundaries  
    329       zramp = 1. 
    330       IF (ln_tide_ramp) zramp = MIN(MAX( (z_arg + (kt_tide-nit000)*rdt)/(rdttideramp*rday),0.),1.) 
     343      zramp = 1._wp 
     344      IF (ln_tide_ramp) zramp = MIN(MAX( (z_arg + (kt_tide-nit000)*rdt)/(rdttideramp*rday),0._wp),1._wp) 
    331345 
    332346      DO itide = 1, nb_harmo 
    … …  
    354368      ! 
    355369   END SUBROUTINE bdytide_update 
     370 
     371   SUBROUTINE bdy_dta_tides( kt, kit, time_offset ) 
     372      !!---------------------------------------------------------------------- 
     373      !!                 ***  SUBROUTINE bdy_dta_tides  *** 
     374      !!                 
     375      !! ** Purpose : - Add tidal forcing to ssh, u2d and v2d OBC data arrays.  
     376      !!                 
     377      !!---------------------------------------------------------------------- 
     378      INTEGER, INTENT( in )            ::   kt          ! Main timestep counter 
     379      INTEGER, INTENT( in ),OPTIONAL   ::   kit         ! Barotropic timestep counter (for timesplitting option) 
     380      INTEGER, INTENT( in ),OPTIONAL   ::   time_offset ! time offset in units of timesteps. NB. if kit 
     381                                                        ! is present then units = subcycle timesteps. 
     382                                                        ! time_offset = 0  => get data at "now"    time level 
     383                                                        ! time_offset = -1 => get data at "before" time level 
     384                                                        ! time_offset = +1 => get data at "after"  time level 
     385                                                        ! etc. 
     386      !! 
     387      LOGICAL  :: lk_first_btstp  ! =.TRUE. if time splitting and first barotropic step 
     388      INTEGER,          DIMENSION(jpbgrd) :: ilen0  
     389      INTEGER, DIMENSION(1:jpbgrd) :: nblen, nblenrim  ! short cuts 
     390      INTEGER  :: itide, ib_bdy, ib, igrd                     ! loop indices 
     391      INTEGER  :: time_add                                    ! time offset in units of timesteps 
     392      REAL(wp) :: z_arg, z_sarg, zramp, zoff, z_cost, z_sist       
     393      !!---------------------------------------------------------------------- 
     394 
     395      IF( nn_timing == 1 ) CALL timing_start('bdy_dta_tides') 
     396 
     397      lk_first_btstp=.TRUE. 
     398      IF ( PRESENT(kit).AND.( kit /= 1 ) ) THEN ; lk_first_btstp=.FALSE. ; ENDIF 
     399 
     400      time_add = 0 
     401      IF( PRESENT(time_offset) ) THEN 
     402         time_add = time_offset 
     403      ENDIF 
     404       
     405      ! Absolute time from model initialization:    
     406      IF( PRESENT(kit) ) THEN   
     407         z_arg = ( kt + (kit+0.5_wp*(time_add-1)) / REAL(nn_baro,wp) ) * rdt 
     408      ELSE                               
     409         z_arg = ( kt + time_add ) * rdt 
     410      ENDIF 
     411 
     412      ! Linear ramp on tidal component at open boundaries  
     413      zramp = 1. 
     414      IF (ln_tide_ramp) zramp = MIN(MAX( (z_arg - nit000*rdt)/(rdttideramp*rday),0.),1.) 
     415 
     416      DO ib_bdy = 1,nb_bdy 
     417 
     418         ! line below should be simplified (runoff case) 
     419!! CHANUT: TO BE SORTED OUT 
     420!!         IF (( nn_dyn2d_dta(ib_bdy) .ge. 2 ).AND.(nn_tra(ib_bdy).NE.4)) THEN 
     421         IF ( nn_dyn2d_dta(ib_bdy) .ge. 2 ) THEN 
     422 
     423            nblen(1:jpbgrd) = idx_bdy(ib_bdy)%nblen(1:jpbgrd) 
     424            nblenrim(1:jpbgrd) = idx_bdy(ib_bdy)%nblenrim(1:jpbgrd) 
     425 
     426            IF( cn_dyn2d(ib_bdy) == 'frs' ) THEN 
     427               ilen0(:)=nblen(:) 
     428            ELSE 
     429               ilen0(:)=nblenrim(:) 
     430            ENDIF      
     431 
     432            ! We refresh nodal factors every day below 
     433            ! This should be done somewhere else 
     434            IF ( nsec_day == NINT(0.5_wp * rdttra(1)) .AND. lk_first_btstp ) THEN 
     435               ! 
     436               kt_tide = kt                
     437               ! 
     438               IF(lwp) THEN 
     439               WRITE(numout,*) 
     440               WRITE(numout,*) 'bdy_tide_dta : Refresh nodal factors for tidal open bdy data at kt=',kt 
     441               WRITE(numout,*) '~~~~~~~~~~~~~~ ' 
     442               ENDIF 
     443               ! 
     444               CALL tide_init_elevation ( idx=idx_bdy(ib_bdy), td=tides(ib_bdy) ) 
     445               CALL tide_init_velocities( idx=idx_bdy(ib_bdy), td=tides(ib_bdy) ) 
     446               ! 
     447            ENDIF 
     448            zoff = -kt_tide * rdt ! time offset relative to nodal factor computation time 
     449            ! 
     450            ! If time splitting, save data at first barotropic iteration 
     451            IF ( PRESENT(kit) ) THEN 
     452               IF ( lk_first_btstp ) THEN ! Save slow varying open boundary data: 
     453                  dta_bdy_s(ib_bdy)%ssh(1:ilen0(1)) = dta_bdy(ib_bdy)%ssh(1:ilen0(1)) 
     454                  dta_bdy_s(ib_bdy)%u2d(1:ilen0(2)) = dta_bdy(ib_bdy)%u2d(1:ilen0(2)) 
     455                  dta_bdy_s(ib_bdy)%v2d(1:ilen0(3)) = dta_bdy(ib_bdy)%v2d(1:ilen0(3)) 
     456 
     457               ELSE ! Initialize arrays from slow varying open boundary data:             
     458                  dta_bdy(ib_bdy)%ssh(1:ilen0(1)) = dta_bdy_s(ib_bdy)%ssh(1:ilen0(1)) 
     459                  dta_bdy(ib_bdy)%u2d(1:ilen0(2)) = dta_bdy_s(ib_bdy)%u2d(1:ilen0(2)) 
     460                  dta_bdy(ib_bdy)%v2d(1:ilen0(3)) = dta_bdy_s(ib_bdy)%v2d(1:ilen0(3)) 
     461               ENDIF 
     462            ENDIF 
     463            ! 
     464            ! Update open boundary data arrays: 
     465            DO itide = 1, nb_harmo 
     466               ! 
     467               z_sarg = (z_arg + zoff) * omega_tide(itide) 
     468               z_cost = zramp * COS( z_sarg ) 
     469               z_sist = zramp * SIN( z_sarg ) 
     470               ! 
     471               igrd=1                              ! SSH on tracer grid 
     472               DO ib = 1, ilen0(igrd) 
     473                  dta_bdy(ib_bdy)%ssh(ib) = dta_bdy(ib_bdy)%ssh(ib) + & 
     474                     &                      ( tides(ib_bdy)%ssh(ib,itide,1)*z_cost + & 
     475                     &                        tides(ib_bdy)%ssh(ib,itide,2)*z_sist ) 
     476               END DO 
     477               ! 
     478               igrd=2                              ! U grid 
     479               DO ib = 1, ilen0(igrd) 
     480                  dta_bdy(ib_bdy)%u2d(ib) = dta_bdy(ib_bdy)%u2d(ib) + & 
     481                     &                      ( tides(ib_bdy)%u(ib,itide,1)*z_cost + & 
     482                     &                        tides(ib_bdy)%u(ib,itide,2)*z_sist ) 
     483               END DO 
     484               ! 
     485               igrd=3                              ! V grid 
     486               DO ib = 1, ilen0(igrd)  
     487                  dta_bdy(ib_bdy)%v2d(ib) = dta_bdy(ib_bdy)%v2d(ib) + & 
     488                     &                      ( tides(ib_bdy)%v(ib,itide,1)*z_cost + & 
     489                     &                        tides(ib_bdy)%v(ib,itide,2)*z_sist ) 
     490               END DO 
     491            END DO 
     492         END IF 
     493      END DO 
     494      ! 
     495      IF( nn_timing == 1 ) CALL timing_stop('bdy_dta_tides') 
     496      ! 
     497   END SUBROUTINE bdy_dta_tides 
    356498 
    357499   SUBROUTINE tide_init_elevation( idx, td ) 
    … …  
    460602      WRITE(*,*) 'bdytide_update: You should not have seen this print! error?', kt, jit 
    461603   END SUBROUTINE bdytide_update 
     604   SUBROUTINE bdy_dta_tides( kt, kit, time_offset )     ! Empty routine 
     605      INTEGER, INTENT( in )            ::   kt          ! Dummy argument empty routine       
     606      INTEGER, INTENT( in ),OPTIONAL   ::   kit         ! Dummy argument empty routine 
     607      INTEGER, INTENT( in ),OPTIONAL   ::   time_offset ! Dummy argument empty routine 
     608      WRITE(*,*) 'bdy_dta_tides: You should not have seen this print! error?', kt, jit 
     609   END SUBROUTINE bdy_dta_tides 
    462610#endif 
    463611 
    464612   !!====================================================================== 
    465613END MODULE bdytides 
     614 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/BDY/bdytra.F90

    r3777 r4292  
    2020   USE dom_oce         ! ocean space and time domain variables  
    2121   USE bdy_oce         ! ocean open boundary conditions 
     22   USE bdylib          ! for orlanski library routines 
    2223   USE bdydta, ONLY:   bf 
    2324   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    … …  
    5152      DO ib_bdy=1, nb_bdy 
    5253 
    53          SELECT CASE( nn_tra(ib_bdy) ) 
    54          CASE(jp_none) 
     54         SELECT CASE( cn_tra(ib_bdy) ) 
     55         CASE('none') 
    5556            CYCLE 
    56          CASE(jp_frs) 
     57         CASE('frs') 
    5758            CALL bdy_tra_frs( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt ) 
    58          CASE(2) 
     59         CASE('specified') 
    5960            CALL bdy_tra_spe( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt ) 
    60          CASE(3) 
     61         CASE('neumann') 
    6162            CALL bdy_tra_nmn( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt ) 
    62          CASE(4) 
     63         CASE('orlanski') 
     64            CALL bdy_tra_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ll_npo=.false. ) 
     65         CASE('orlanski_npo') 
     66            CALL bdy_tra_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ll_npo=.true. ) 
     67         CASE('runoff') 
    6368            CALL bdy_tra_rnf( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt ) 
    6469         CASE DEFAULT 
    … …  
    196201      ! 
    197202   END SUBROUTINE bdy_tra_nmn 
     203  
     204 
     205   SUBROUTINE bdy_tra_orlanski( idx, dta, ll_npo ) 
     206      !!---------------------------------------------------------------------- 
     207      !!                 ***  SUBROUTINE bdy_tra_orlanski  *** 
     208      !!              
     209      !!              - Apply Orlanski radiation to temperature and salinity.  
     210      !!              - Wrapper routine for bdy_orlanski_3d 
     211      !!  
     212      !! 
     213      !! References:  Marchesiello, McWilliams and Shchepetkin, Ocean Modelling vol. 3 (2001)     
     214      !!---------------------------------------------------------------------- 
     215      TYPE(OBC_INDEX),              INTENT(in) ::   idx  ! OBC indices 
     216      TYPE(OBC_DATA),               INTENT(in) ::   dta  ! OBC external data 
     217      LOGICAL,                      INTENT(in) ::   ll_npo  ! switch for NPO version 
     218 
     219      INTEGER  ::   igrd                                    ! grid index 
     220      !!---------------------------------------------------------------------- 
     221 
     222      IF( nn_timing == 1 ) CALL timing_start('bdy_tra_orlanski') 
     223      ! 
     224      igrd = 1      ! Orlanski bc on temperature;  
     225      !             
     226      CALL bdy_orlanski_3d( idx, igrd, tsb(:,:,:,jp_tem), tsa(:,:,:,jp_tem), dta%tem, ll_npo ) 
     227 
     228      igrd = 1      ! Orlanski bc on salinity; 
     229      !   
     230      CALL bdy_orlanski_3d( idx, igrd, tsb(:,:,:,jp_sal), tsa(:,:,:,jp_sal), dta%sal, ll_npo ) 
     231      ! 
     232      IF( nn_timing == 1 ) CALL timing_stop('bdy_tra_orlanski') 
     233      ! 
     234 
     235   END SUBROUTINE bdy_tra_orlanski 
     236 
    198237 
    199238   SUBROUTINE bdy_tra_rnf( idx, dta, kt ) 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/BDY/bdyvol.F90

    r3294 r4292  
    104104               ii = idx%nbi(jb,jgrd) 
    105105               ij = idx%nbj(jb,jgrd) 
    106                zubtpecor = zubtpecor + idx%flagu(jb) * ua(ii,ij, jk) * e2u(ii,ij) * fse3u(ii,ij,jk) 
     106               zubtpecor = zubtpecor + idx%flagu(jb,jgrd) * ua(ii,ij, jk) * e2u(ii,ij) * fse3u(ii,ij,jk) 
    107107            END DO 
    108108         END DO 
    … …  
    112112               ii = idx%nbi(jb,jgrd) 
    113113               ij = idx%nbj(jb,jgrd) 
    114                zubtpecor = zubtpecor + idx%flagv(jb) * va(ii,ij, jk) * e1v(ii,ij) * fse3v(ii,ij,jk)  
     114               zubtpecor = zubtpecor + idx%flagv(jb,jgrd) * va(ii,ij, jk) * e1v(ii,ij) * fse3v(ii,ij,jk)  
    115115            END DO 
    116116         END DO 
    … …  
    136136               ii = idx%nbi(jb,jgrd) 
    137137               ij = idx%nbj(jb,jgrd) 
    138                ua(ii,ij,jk) = ua(ii,ij,jk) - idx%flagu(jb) * zubtpecor * umask(ii,ij,jk) 
    139                ztranst = ztranst + idx%flagu(jb) * ua(ii,ij,jk) * e2u(ii,ij) * fse3u(ii,ij,jk) 
     138               ua(ii,ij,jk) = ua(ii,ij,jk) - idx%flagu(jb,jgrd) * zubtpecor * umask(ii,ij,jk) 
     139               ztranst = ztranst + idx%flagu(jb,jgrd) * ua(ii,ij,jk) * e2u(ii,ij) * fse3u(ii,ij,jk) 
    140140            END DO 
    141141         END DO 
    … …  
    145145               ii = idx%nbi(jb,jgrd) 
    146146               ij = idx%nbj(jb,jgrd) 
    147                va(ii,ij,jk) = va(ii,ij,jk) -idx%flagv(jb) * zubtpecor * vmask(ii,ij,jk) 
    148                ztranst = ztranst + idx%flagv(jb) * va(ii,ij,jk) * e1v(ii,ij) * fse3v(ii,ij,jk) 
     147               va(ii,ij,jk) = va(ii,ij,jk) -idx%flagv(jb,jgrd) * zubtpecor * vmask(ii,ij,jk) 
     148               ztranst = ztranst + idx%flagv(jb,jgrd) * va(ii,ij,jk) * e1v(ii,ij) * fse3v(ii,ij,jk) 
    149149            END DO 
    150150         END DO 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DIA/diaar5.F90

    r3294 r4292  
    196196      thick0(:,:) = 0._wp 
    197197      DO jk = 1, jpkm1 
    198          vol0        = vol0        + SUM( area (:,:) * tmask(:,:,jk) * fse3t_0(:,:,jk) ) 
    199          thick0(:,:) = thick0(:,:) +    tmask_i(:,:) * tmask(:,:,jk) * fse3t_0(:,:,jk) 
     198         vol0        = vol0        + SUM( area (:,:) * tmask(:,:,jk) * e3t_0(:,:,jk) ) 
     199         thick0(:,:) = thick0(:,:) +    tmask_i(:,:) * tmask(:,:,jk) * e3t_0(:,:,jk) 
    200200      END DO 
    201201      IF( lk_mpp )   CALL mpp_sum( vol0 ) 
    … …  
    212212               ik = mbkt(ji,jj) 
    213213               IF( ik > 1 ) THEN 
    214                   zztmp = ( gdept_0(ik) - fsdept_0(ji,jj,ik) ) / ( gdept_0(ik) - gdept_0(ik-1) ) 
     214                  zztmp = ( gdept_1d(ik) - gdept_0(ji,jj,ik) ) / ( gdept_1d(ik) - gdept_1d(ik-1) ) 
    215215                  sn0(ji,jj,ik) = ( 1._wp - zztmp ) * sn0(ji,jj,ik) + zztmp * sn0(ji,jj,ik-1) 
    216216               ENDIF 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DIA/diadimg.F90

    r3294 r4292  
    112112 
    113113    CASE ( 'T') 
    114        z4dep(:)=gdept_0(:) 
     114       z4dep(:)=gdept_1d(:) 
    115115 
    116116    CASE ( 'W' ) 
    117        z4dep(:)=gdepw_0(:) 
     117       z4dep(:)=gdepw_1d(:) 
    118118 
    119119    CASE ( '2' ) 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DIA/diaharm.F90

    r4147 r4292  
    11MODULE diaharm  
    2  
    3 #if defined key_diaharm && defined key_tide 
    4    !!================================================================================= 
     2   !!====================================================================== 
    53   !!                       ***  MODULE  diaharm  *** 
    64   !! Harmonic analysis of tidal constituents  
    7    !!================================================================================= 
    8    !! * Modules used 
     5   !!====================================================================== 
     6   !! History :  3.1  !  2007  (O. Le Galloudec, J. Chanut)  Original code 
     7   !!---------------------------------------------------------------------- 
     8#if defined key_diaharm && defined key_tide 
     9   !!---------------------------------------------------------------------- 
     10   !!   'key_diaharm' 
     11   !!   'key_tide' 
     12   !!---------------------------------------------------------------------- 
    913   USE oce             ! ocean dynamics and tracers variables 
    1014   USE dom_oce         ! ocean space and time domain 
    11    USE in_out_manager  ! I/O units 
    12    USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    13    USE ioipsl          ! NetCDF IPSL library 
    14    USE diadimg         ! To write dimg 
    1515   USE phycst 
    1616   USE dynspg_oce 
    … …  
    1818   USE daymod 
    1919   USE tide_mod 
    20    USE iom  
     20   USE in_out_manager  ! I/O units 
     21   USE iom             ! I/0 library 
     22   USE ioipsl          ! NetCDF IPSL library 
     23   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
     24   USE diadimg         ! To write dimg 
    2125   USE timing          ! preformance summary 
    2226   USE wrk_nemo        ! working arrays 
    … …  
    3034   INTEGER, PARAMETER :: jpdimsparse  = jpincomax*300*24 
    3135 
    32    INTEGER ::                            & !! namelist variables 
    33                          nit000_han    , & ! First time step used for harmonic analysis 
    34                          nitend_han    , & ! Last time step used for harmonic analysis 
    35                          nstep_han     , & ! Time step frequency for harmonic analysis 
    36                          nb_ana            ! Number of harmonics to analyse 
    37  
    38    INTEGER , ALLOCATABLE, DIMENSION(:)       :: name 
    39    REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: ana_temp 
    40    REAL(wp), ALLOCATABLE, DIMENSION(:)       :: ana_freq, vt, ut, ft 
    41    REAL(wp), ALLOCATABLE, DIMENSION(:,:,:)   :: out_eta, & 
    42                                                 out_u  , & 
    43                                                 out_v 
    44  
    45    INTEGER :: ninco, nsparse 
    46    INTEGER ,       DIMENSION(jpdimsparse)         :: njsparse, nisparse 
    47    INTEGER , SAVE, DIMENSION(jpincomax)           :: ipos1 
    48    REAL(wp),       DIMENSION(jpdimsparse)         :: valuesparse 
    49    REAL(wp),       DIMENSION(jpincomax)           :: ztmp4 , ztmp7 
    50    REAL(wp), SAVE, DIMENSION(jpincomax,jpincomax) :: ztmp3 , zpilier 
    51    REAL(wp), SAVE, DIMENSION(jpincomax)           :: zpivot 
    52  
    53    CHARACTER (LEN=4), DIMENSION(jpmax_harmo) ::   & 
    54        tname         ! Names of tidal constituents ('M2', 'K1',...) 
    55  
    56  
    57 !! * Routine accessibility 
    58    PUBLIC  dia_harm    ! routine called by step.F90 
    59  
    60    !!--------------------------------------------------------------------------------- 
    61    !!   
    62    !!--------------------------------------------------------------------------------- 
    63  
     36   !                            !!!namelist variables 
     37   INTEGER ::   nit000_han    ! First time step used for harmonic analysis 
     38   INTEGER ::   nitend_han    ! Last time step used for harmonic analysis 
     39   INTEGER ::   nstep_han     ! Time step frequency for harmonic analysis 
     40   INTEGER ::   nb_ana           ! Number of harmonics to analyse 
     41 
     42   INTEGER , ALLOCATABLE, DIMENSION(:)       ::   name 
     43   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) ::   ana_temp 
     44   REAL(wp), ALLOCATABLE, DIMENSION(:)       ::   ana_freq, ut   , vt   , ft 
     45   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:)   ::   out_eta , out_u, out_v 
     46 
     47   INTEGER ::   ninco, nsparse 
     48   INTEGER ,       DIMENSION(jpdimsparse)         ::   njsparse, nisparse 
     49   INTEGER , SAVE, DIMENSION(jpincomax)           ::   ipos1 
     50   REAL(wp),       DIMENSION(jpdimsparse)         ::   valuesparse 
     51   REAL(wp),       DIMENSION(jpincomax)           ::   ztmp4 , ztmp7 
     52   REAL(wp), SAVE, DIMENSION(jpincomax,jpincomax) ::   ztmp3 , zpilier 
     53   REAL(wp), SAVE, DIMENSION(jpincomax)           ::   zpivot 
     54 
     55   CHARACTER (LEN=4), DIMENSION(jpmax_harmo) ::   tname   ! Names of tidal constituents ('M2', 'K1',...) 
     56 
     57   PUBLIC   dia_harm   ! routine called by step.F90 
     58 
     59   !!---------------------------------------------------------------------- 
     60   !! NEMO/OPA 3.5 , NEMO Consortium (2013) 
     61   !! $Id:$ 
     62   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
     63   !!---------------------------------------------------------------------- 
    6464CONTAINS 
    6565 
    … …  
    6767      !!---------------------------------------------------------------------- 
    6868      !!                 ***  ROUTINE dia_harm_init  *** 
    69       !!---------------------------------------------------------------------- 
    7069      !!          
    7170      !! ** Purpose :   Initialization of tidal harmonic analysis 
    … …  
    7372      !! ** Method  :   Initialize frequency array and  nodal factor for nit000_han 
    7473      !! 
    75       !! History : 
    76       !!   9.0  O. Le Galloudec and J. Chanut (Original) 
    77       !!-------------------------------------------------------------------- 
    78       !! * Local declarations  
     74      !!-------------------------------------------------------------------- 
    7975      INTEGER :: jh, nhan, jk, ji 
    8076      INTEGER ::   ios                 ! Local integer output status for namelist read 
    … …  
    108104      ! Basic checks on harmonic analysis time window: 
    109105      ! ---------------------------------------------- 
    110       IF (nit000 > nit000_han) THEN 
    111         IF(lwp) WRITE(numout,*) ' E R R O R dia_harm_init : nit000_han must be greater than nit000, stop' 
    112         IF(lwp) WRITE(numout,*) ' restart capability not implemented' 
    113         nstop = nstop + 1 
    114       ENDIF 
    115       IF (nitend < nitend_han) THEN 
    116         IF(lwp) WRITE(numout,*) ' E R R O R dia_harm_init : nitend_han must be lower than nitend, stop' 
    117         IF(lwp) WRITE(numout,*) ' restart capability not implemented' 
    118         nstop = nstop + 1 
    119       ENDIF 
    120  
    121       IF (MOD(nitend_han-nit000_han+1,nstep_han).NE.0) THEN 
    122         IF(lwp) WRITE(numout,*) ' E R R O R dia_harm_init : analysis time span must be a multiple of nstep_han, stop' 
    123         nstop = nstop + 1 
    124       END IF 
    125  
    126       nb_ana=0 
     106      IF( nit000 > nit000_han )   CALL ctl_stop( 'dia_harm_init : nit000_han must be greater than nit000',   & 
     107         &                                       ' restart capability not implemented' ) 
     108      IF( nitend < nitend_han )   CALL ctl_stop( 'dia_harm_init : nitend_han must be lower than nitend',   & 
     109         &                                       'restart capability not implemented' ) 
     110 
     111      IF( MOD( nitend_han-nit000_han+1 , nstep_han ) /= 0 )   & 
     112         &                        CALL ctl_stop( 'dia_harm_init : analysis time span must be a multiple of nstep_han' ) 
     113 
     114      nb_ana = 0 
    127115      DO jk=1,jpmax_harmo 
    128116         DO ji=1,jpmax_harmo 
    … …  
    157145      ! Initialize frequency array: 
    158146      ! --------------------------- 
    159       ALLOCATE(ana_freq(nb_ana)) 
    160       ALLOCATE(vt      (nb_ana)) 
    161       ALLOCATE(ut      (nb_ana)) 
    162       ALLOCATE(ft      (nb_ana)) 
    163  
    164       CALL tide_harmo(ana_freq, vt, ut , ft, name ,nb_ana) 
     147      ALLOCATE( ana_freq(nb_ana), ut(nb_ana), vt(nb_ana), ft(nb_ana) ) 
     148 
     149      CALL tide_harmo( ana_freq, vt, ut, ft, name, nb_ana ) 
    165150 
    166151      IF(lwp) WRITE(numout,*) 'Analysed frequency  : ',nb_ana ,'Frequency ' 
    … …  
    172157      ! Initialize temporary arrays: 
    173158      ! ---------------------------- 
    174       ALLOCATE( ana_temp(jpi,jpj,nb_ana*2,3)) 
     159      ALLOCATE( ana_temp(jpi,jpj,2*nb_ana,3) ) 
    175160      ana_temp(:,:,:,:) = 0.e0 
    176161 
    177162   END SUBROUTINE dia_harm_init 
    178     
     163 
     164 
    179165   SUBROUTINE dia_harm ( kt ) 
    180166      !!---------------------------------------------------------------------- 
    181167      !!                 ***  ROUTINE dia_harm  *** 
    182       !!---------------------------------------------------------------------- 
    183168      !!          
    184169      !! ** Purpose :   Tidal harmonic analysis main routine 
    … …  
    186171      !! ** Action  :   Sums ssh/u/v over time analysis [nit000_han,nitend_han] 
    187172      !! 
    188       !! History : 
    189       !!   9.0  O. Le Galloudec and J. Chanut (Original) 
    190       !!-------------------------------------------------------------------- 
    191       !! * Argument: 
     173      !!-------------------------------------------------------------------- 
    192174      INTEGER, INTENT( IN ) :: kt 
    193  
    194       !! * Local declarations 
     175      ! 
    195176      INTEGER  :: ji, jj, jh, jc, nhc 
    196177      REAL(wp) :: ztime, ztemp 
    … …  
    198179      IF( nn_timing == 1 )   CALL timing_start('dia_harm') 
    199180 
    200       IF ( kt .EQ. nit000 ) CALL dia_harm_init 
     181      IF ( kt == nit000 ) CALL dia_harm_init 
    201182 
    202183      IF ( ((kt.GE.nit000_han).AND.(kt.LE.nitend_han)).AND. & 
    … …  
    215196              DO ji = 1,jpi 
    216197                ! Elevation 
    217                 ana_temp(ji,jj,nhc,1) = ana_temp(ji,jj,nhc,1)                & 
    218                                         + ztemp*sshn(ji,jj)*tmask(ji,jj,1)         
     198                ana_temp(ji,jj,nhc,1) = ana_temp(ji,jj,nhc,1) + ztemp*sshn(ji,jj)           *tmask(ji,jj,1)         
    219199#if defined key_dynspg_ts 
    220                 ! ubar 
    221                 ana_temp(ji,jj,nhc,2) = ana_temp(ji,jj,nhc,2)                & 
    222                                         + ztemp*un_b(ji,jj)*hur(ji,jj)*umask(ji,jj,1) 
    223                 ! vbar 
    224                 ana_temp(ji,jj,nhc,3) = ana_temp(ji,jj,nhc,3)                & 
    225                                         + ztemp*vn_b(ji,jj)*hvr(ji,jj)*vmask(ji,jj,1) 
     200                ana_temp(ji,jj,nhc,2) = ana_temp(ji,jj,nhc,2) + ztemp*un_b(ji,jj)*hur(ji,jj)*umask(ji,jj,1) 
     201                ana_temp(ji,jj,nhc,3) = ana_temp(ji,jj,nhc,3) + ztemp*vn_b(ji,jj)*hvr(ji,jj)*vmask(ji,jj,1) 
    226202#endif 
    227203              END DO 
    … …  
    233209      END IF 
    234210 
    235       IF ( kt .EQ. nitend_han ) CALL dia_harm_end 
     211      IF ( kt == nitend_han )  CALL dia_harm_end 
    236212 
    237213      IF( nn_timing == 1 )   CALL timing_stop('dia_harm') 
    … …  
    239215   END SUBROUTINE dia_harm 
    240216 
     217 
    241218   SUBROUTINE dia_harm_end 
    242219      !!---------------------------------------------------------------------- 
    243220      !!                 ***  ROUTINE diaharm_end  *** 
    244       !!---------------------------------------------------------------------- 
    245221      !!          
    246222      !! ** Purpose :  Compute the Real and Imaginary part of tidal constituents 
    … …  
    248224      !! ** Action  :  Decompose the signal on the harmonic constituents  
    249225      !! 
    250       !! History : 
    251       !!   9.0  O. Le Galloudec and J. Chanut (Original) 
    252       !!-------------------------------------------------------------------- 
    253  
    254       !! * Local declarations 
     226      !!-------------------------------------------------------------------- 
    255227      INTEGER :: ji, jj, jh, jc, jn, nhan, jl 
    256228      INTEGER :: ksp, kun, keq 
    … …  
    283255               nisparse(ksp) = keq 
    284256               njsparse(ksp) = kun 
    285                valuesparse(ksp)= & 
    286                    +(   MOD(jc,2) * ft(jh) * COS(ana_freq(jh)*ztime + vt(jh) + ut(jh)) & 
    287                    +(1.-MOD(jc,2))* ft(jh) * SIN(ana_freq(jh)*ztime + vt(jh) + ut(jh))) 
     257               valuesparse(ksp) = (   MOD(jc,2) * ft(jh) * COS(ana_freq(jh)*ztime + vt(jh) + ut(jh))   & 
     258                  &             + (1.-MOD(jc,2))* ft(jh) * SIN(ana_freq(jh)*ztime + vt(jh) + ut(jh)) ) 
    288259            END DO 
    289260         END DO 
    290261      END DO 
    291262 
    292       nsparse=ksp 
     263      nsparse = ksp 
    293264 
    294265      ! Elevation: 
    … …  
    296267         DO ji = 1, jpi 
    297268            ! Fill input array 
    298             kun=0 
    299             DO jh = 1,nb_ana 
    300                DO jc = 1,2 
     269            kun = 0 
     270            DO jh = 1, nb_ana 
     271               DO jc = 1, 2 
    301272                  kun = kun + 1 
    302273                  ztmp4(kun)=ana_temp(ji,jj,kun,1) 
    303                ENDDO 
    304             ENDDO 
     274               END DO 
     275            END DO 
    305276 
    306277            CALL SUR_DETERMINE(jj) 
    … …  
    314285      END DO 
    315286 
    316       ALLOCATE(out_eta(jpi,jpj,2*nb_ana)) 
    317       ALLOCATE(out_u  (jpi,jpj,2*nb_ana)) 
    318       ALLOCATE(out_v  (jpi,jpj,2*nb_ana)) 
     287      ALLOCATE( out_eta(jpi,jpj,2*nb_ana),   &  
     288         &      out_u  (jpi,jpj,2*nb_ana),   & 
     289         &      out_v  (jpi,jpj,2*nb_ana)  ) 
    319290 
    320291      DO jj = 1, jpj 
    321292         DO ji = 1, jpi 
    322293            DO jh = 1, nb_ana  
    323                X1=ana_amp(ji,jj,jh,1) 
    324                X2=-ana_amp(ji,jj,jh,2) 
    325                out_eta(ji,jj,jh)=X1 * tmask(ji,jj,1) 
    326                out_eta(ji,jj,nb_ana+jh)=X2 * tmask(ji,jj,1) 
     294               X1 = ana_amp(ji,jj,jh,1) 
     295               X2 =-ana_amp(ji,jj,jh,2) 
     296               out_eta(ji,jj,jh       ) = X1 * tmask(ji,jj,1) 
     297               out_eta(ji,jj,jh+nb_ana) = X2 * tmask(ji,jj,1) 
    327298            ENDDO 
    328299         ENDDO 
    … …  
    402373   END SUBROUTINE dia_harm_end 
    403374 
     375 
    404376   SUBROUTINE dia_wri_harm 
    405377      !!-------------------------------------------------------------------- 
    406378      !!                 ***  ROUTINE dia_wri_harm  *** 
    407       !!-------------------------------------------------------------------- 
    408379      !!          
    409380      !! ** Purpose : Write tidal harmonic analysis results in a netcdf file 
    410       !! 
    411       !! 
    412       !! History : 
    413       !!   9.0  O. Le Galloudec and J. Chanut (Original) 
    414       !!-------------------------------------------------------------------- 
    415  
    416       !! * Local declarations 
     381      !!-------------------------------------------------------------------- 
    417382      CHARACTER(LEN=lc) :: cltext 
    418383      CHARACTER(LEN=lc) ::   & 
    … …  
    472437#else 
    473438      DO jh = 1, nb_ana 
    474       CALL iom_put( TRIM(tname(jh))//'x_v', out_u(:,:,jh) ) 
    475       CALL iom_put( TRIM(tname(jh))//'y_v', out_u(:,:,nb_ana+jh) ) 
     439         CALL iom_put( TRIM(tname(jh))//'x_v', out_u(:,:,jh       ) ) 
     440         CALL iom_put( TRIM(tname(jh))//'y_v', out_u(:,:,jh+nb_ana) ) 
    476441      END DO 
    477442#endif 
    478443 
    479444   END SUBROUTINE dia_wri_harm 
     445 
    480446 
    481447   SUBROUTINE SUR_DETERMINE(init) 
    … …  
    486452   !!        
    487453   !!--------------------------------------------------------------------------------- 
    488    INTEGER, INTENT(in) :: init  
    489                 
     454   INTEGER, INTENT(in) ::   init  
     455   ! 
    490456   INTEGER                         :: ji_sd, jj_sd, ji1_sd, ji2_sd, jk1_sd, jk2_sd 
    491457   REAL(wp)                        :: zval1, zval2, zx1 
    … …  
    496462   CALL wrk_alloc( jpincomax , ipos2 , ipivot        ) 
    497463             
    498    IF( init==1 )THEN 
    499  
    500       IF( nsparse .GT. jpdimsparse ) & 
    501          CALL ctl_stop( 'STOP', 'SUR_DETERMINE : nsparse .GT. jpdimsparse') 
    502  
    503       IF( ninco .GT. jpincomax ) & 
    504          CALL ctl_stop( 'STOP', 'SUR_DETERMINE : ninco .GT. jpincomax') 
    505  
    506       ztmp3(:,:)=0.e0 
    507  
     464   IF( init == 1 ) THEN 
     465      IF( nsparse > jpdimsparse )   CALL ctl_stop( 'STOP', 'SUR_DETERMINE : nsparse .GT. jpdimsparse') 
     466      IF( ninco   > jpincomax   )   CALL ctl_stop( 'STOP', 'SUR_DETERMINE : ninco .GT. jpincomax') 
     467      ! 
     468      ztmp3(:,:) = 0._wp 
     469      ! 
    508470      DO jk1_sd = 1, nsparse 
    509471         DO jk2_sd = 1, nsparse 
    510  
    511             nisparse(jk2_sd)=nisparse(jk2_sd) 
    512             njsparse(jk2_sd)=njsparse(jk2_sd) 
    513  
     472            nisparse(jk2_sd) = nisparse(jk2_sd) 
     473            njsparse(jk2_sd) = njsparse(jk2_sd) 
    514474            IF( nisparse(jk2_sd) == nisparse(jk1_sd) ) THEN 
    515475               ztmp3(njsparse(jk1_sd),njsparse(jk2_sd)) = ztmp3(njsparse(jk1_sd),njsparse(jk2_sd))  & 
    516476                                                        + valuesparse(jk1_sd)*valuesparse(jk2_sd) 
    517477            ENDIF 
    518  
    519          ENDDO 
    520       ENDDO 
     478         END DO 
     479      END DO 
    521480 
    522481      DO jj_sd = 1 ,ninco 
    … …  
    588547   ENDDO 
    589548 
    590  
    591549   CALL wrk_dealloc( jpincomax , ztmpx , zcol1 , zcol2 ) 
    592550   CALL wrk_dealloc( jpincomax , ipos2 , ipivot        ) 
    … …  
    594552  END SUBROUTINE SUR_DETERMINE 
    595553 
    596  
    597554#else 
    598555   !!---------------------------------------------------------------------- 
    … …  
    601558   LOGICAL, PUBLIC, PARAMETER ::   lk_diaharm = .FALSE. 
    602559CONTAINS 
    603  
    604560   SUBROUTINE dia_harm ( kt )     ! Empty routine 
    605561      INTEGER, INTENT( IN ) :: kt   
    606562      WRITE(*,*) 'dia_harm: you should not have seen this print' 
    607563   END SUBROUTINE dia_harm 
    608  
    609  
    610 #endif 
     564#endif 
     565 
    611566   !!====================================================================== 
    612567END MODULE diaharm 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DIA/diahth.F90

    r3764 r4292  
    304304      ! ----------------------------- ! 
    305305 
    306       ! find ilevel with (ilevel+1) the deepest W-level above 300m (we assume we can use e3t_0 to do this search...) 
     306      ! find ilevel with (ilevel+1) the deepest W-level above 300m (we assume we can use e3t_1d to do this search...) 
    307307      ilevel   = 0 
    308308      zthick_0 = 0._wp 
    309309      DO jk = 1, jpkm1                       
    310          zthick_0 = zthick_0 + e3t_0(jk) 
     310         zthick_0 = zthick_0 + e3t_1d(jk) 
    311311         IF( zthick_0 < 300. )   ilevel = jk 
    312312      END DO 
    … …  
    326326            htc3(ji,jj) = htc3(ji,jj) + tsn(ji,jj,ilevel+1,jp_tem) * MIN( fse3t(ji,jj,ilevel+1), zthick(ji,jj) )  & 
    327327                                                                   * tmask(ji,jj,ilevel+1) 
    328             htc3(ji,jj) = htc3(ji,jj) + tsn(ji,jj,ilevel+1,jp_tem) * MIN( fse3t(ji,jj,ilevel+1), zthick(ji,jj) )   & 
    329                &                                                   * tmask(ji,jj,ilevel+1) 
    330328         END DO 
    331329      END DO 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DIA/diaptr.F90

    r4148 r4292  
    259259      ! 
    260260#if defined key_mpp_mpi 
     261      ijpjjpk = jpj*jpk 
    261262      ish(1) = ijpjjpk  ;   ish2(1) = jpj   ;   ish2(2) = jpk 
    262263      zwork(1:ijpjjpk) = RESHAPE( p_fval, ish ) 
    … …  
    314315      END DO 
    315316#if defined key_mpp_mpi 
     317      ijpjjpk = jpj*jpk 
    316318      ish(1) = jpj*jpk   ;   ish2(1) = jpj   ;   ish2(2) = jpk 
    317319      zwork(1:ijpjjpk)= RESHAPE( p_fval, ish ) 
    … …  
    670672            CALL histbeg(clhstnam, 1, zfoo, jpj, zphi,   & 
    671673               1, 1, 1, jpj, niter, zjulian, zdt*nn_fptr, nhoridz, numptr, domain_id=nidom_ptr) 
    672             ! Vertical grids : gdept_0, gdepw_0 
     674            ! Vertical grids : gdept_1d, gdepw_1d 
    673675            CALL histvert( numptr, "deptht", "Vertical T levels",   & 
    674                &                   "m", jpk, gdept_0, ndepidzt, "down" ) 
     676               &                   "m", jpk, gdept_1d, ndepidzt, "down" ) 
    675677            CALL histvert( numptr, "depthw", "Vertical W levels",   & 
    676                &                   "m", jpk, gdepw_0, ndepidzw, "down" ) 
     678               &                   "m", jpk, gdepw_1d, ndepidzw, "down" ) 
    677679            ! 
    678680            CALL wheneq ( jpj*jpk, MIN(sjk(:,:,1), 1._wp), 1, 1., ndex  , ndim  )      ! Lat-Depth 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DIA/diawri.F90

    r4161 r4292  
    2525   USE oce             ! ocean dynamics and tracers  
    2626   USE dom_oce         ! ocean space and time domain 
     27   USE dynadv, ONLY: ln_dynadv_vec 
    2728   USE zdf_oce         ! ocean vertical physics 
    2829   USE ldftra_oce      ! ocean active tracers: lateral physics 
    … …  
    4445   USE diadimg         ! dimg direct access file format output 
    4546   USE diaar5, ONLY :   lk_diaar5 
     47   USE dynadv, ONLY :   ln_dynadv_vec 
    4648   USE iom 
    4749   USE ioipsl 
    … …  
    144146      ENDIF 
    145147 
    146       CALL iom_put( "toce"   , tsn(:,:,:,jp_tem)                     )    ! temperature 
    147       CALL iom_put( "soce"   , tsn(:,:,:,jp_sal)                     )    ! salinity 
    148       CALL iom_put( "sst"    , tsn(:,:,1,jp_tem)                     )    ! sea surface temperature 
    149       CALL iom_put( "sst2"   , tsn(:,:,1,jp_tem) * tsn(:,:,1,jp_tem) )    ! square of sea surface temperature 
    150       CALL iom_put( "sss"    , tsn(:,:,1,jp_sal)                     )    ! sea surface salinity 
    151       CALL iom_put( "sss2"   , tsn(:,:,1,jp_sal) * tsn(:,:,1,jp_sal) )    ! square of sea surface salinity 
    152       CALL iom_put( "uoce"   , un                                    )    ! i-current       
    153       CALL iom_put( "suoce"  , un(:,:,1)                             )    ! surface i-current       
    154       CALL iom_put( "voce"   , vn                                    )    ! j-current 
    155       CALL iom_put( "svoce"  , vn(:,:,1)                             )    ! surface j-current 
    156   
    157       CALL iom_put( "avt"    , avt                                   )    ! T vert. eddy diff. coef. 
    158       CALL iom_put( "avm"    , avmu                                  )    ! T vert. eddy visc. coef. 
     148      IF( lk_vvl ) THEN 
     149         z3d(:,:,:) = tsn(:,:,:,jp_tem) * fse3t_n(:,:,:) 
     150         CALL iom_put( "toce" , z3d                        )   ! heat content 
     151         CALL iom_put( "sst"  , z3d(:,:,1)                 )   ! sea surface heat content 
     152         z3d(:,:,1) = tsn(:,:,1,jp_tem) * z3d(:,:,1) 
     153         CALL iom_put( "sst2" , z3d(:,:,1)                 )   ! sea surface content of squared temperature 
     154         z3d(:,:,:) = tsn(:,:,:,jp_sal) * fse3t_n(:,:,:)             
     155         CALL iom_put( "soce" , z3d                        )   ! salinity content 
     156         CALL iom_put( "sss"  , z3d(:,:,1)                 )   ! sea surface salinity content 
     157         z3d(:,:,1) = tsn(:,:,1,jp_sal) * z3d(:,:,1) 
     158         CALL iom_put( "sss2" , z3d(:,:,1)                 )   ! sea surface content of squared salinity 
     159      ELSE 
     160         CALL iom_put( "toce" , tsn(:,:,:,jp_tem)          )   ! temperature 
     161         CALL iom_put( "sst"  , tsn(:,:,1,jp_tem)          )   ! sea surface temperature 
     162         CALL iom_put( "sst2" , tsn(:,:,1,jp_tem) * tsn(:,:,1,jp_tem) ) ! square of sea surface temperature 
     163         CALL iom_put( "soce" , tsn(:,:,:,jp_sal)          )   ! salinity 
     164         CALL iom_put( "sss"  , tsn(:,:,1,jp_sal)          )   ! sea surface salinity 
     165         CALL iom_put( "sss2" , tsn(:,:,1,jp_sal) * tsn(:,:,1,jp_sal) ) ! square of sea surface salinity 
     166      END IF 
     167      IF( lk_vvl .AND. (.NOT. ln_dynadv_vec) ) THEN 
     168         CALL iom_put( "uoce" , un(:,:,:) * fse3u_n(:,:,:) )    ! i-transport 
     169         CALL iom_put( "voce" , vn(:,:,:) * fse3v_n(:,:,:) )    ! j-transport 
     170      ELSE 
     171         CALL iom_put( "uoce" , un                         )    ! i-current 
     172         CALL iom_put( "voce" , vn                         )    ! j-current 
     173      END IF 
     174      CALL iom_put(    "avt"  , avt                        )    ! T vert. eddy diff. coef. 
     175      CALL iom_put(    "avm"  , avmu                       )    ! T vert. eddy visc. coef. 
    159176      IF( lk_zdfddm ) THEN 
    160177         CALL iom_put( "avs" , fsavs(:,:,:)                          )    ! S vert. eddy diff. coef. 
    … …  
    252269      ! 
    253270      CALL wrk_alloc( jpi , jpj      , zw2d ) 
    254       IF ( ln_traldf_gdia )  call wrk_alloc( jpi , jpj , jpk  , zw3d ) 
     271      IF ( ln_traldf_gdia .OR. lk_vvl )  call wrk_alloc( jpi , jpj , jpk  , zw3d ) 
    255272      ! 
    256273      ! Output the initial state and forcings 
    … …  
    325342            &          nit000-1, zjulian, zdt, nh_T, nid_T, domain_id=nidom, snc4chunks=snc4set ) 
    326343         CALL histvert( nid_T, "deptht", "Vertical T levels",      &  ! Vertical grid: gdept 
    327             &           "m", ipk, gdept_0, nz_T, "down" ) 
     344            &           "m", ipk, gdept_1d, nz_T, "down" ) 
    328345         !                                                            ! Index of ocean points 
    329346         CALL wheneq( jpi*jpj*ipk, tmask, 1, 1., ndex_T , ndim_T  )      ! volume 
    … …  
    361378            &          nit000-1, zjulian, zdt, nh_U, nid_U, domain_id=nidom, snc4chunks=snc4set ) 
    362379         CALL histvert( nid_U, "depthu", "Vertical U levels",      &  ! Vertical grid: gdept 
    363             &           "m", ipk, gdept_0, nz_U, "down" ) 
     380            &           "m", ipk, gdept_1d, nz_U, "down" ) 
    364381         !                                                            ! Index of ocean points 
    365382         CALL wheneq( jpi*jpj*ipk, umask, 1, 1., ndex_U , ndim_U  )      ! volume 
    … …  
    374391            &          nit000-1, zjulian, zdt, nh_V, nid_V, domain_id=nidom, snc4chunks=snc4set ) 
    375392         CALL histvert( nid_V, "depthv", "Vertical V levels",      &  ! Vertical grid : gdept 
    376             &          "m", ipk, gdept_0, nz_V, "down" ) 
     393            &          "m", ipk, gdept_1d, nz_V, "down" ) 
    377394         !                                                            ! Index of ocean points 
    378395         CALL wheneq( jpi*jpj*ipk, vmask, 1, 1., ndex_V , ndim_V  )      ! volume 
    … …  
    387404            &          nit000-1, zjulian, zdt, nh_W, nid_W, domain_id=nidom, snc4chunks=snc4set ) 
    388405         CALL histvert( nid_W, "depthw", "Vertical W levels",      &  ! Vertical grid: gdepw 
    389             &          "m", ipk, gdepw_0, nz_W, "down" ) 
     406            &          "m", ipk, gdepw_1d, nz_W, "down" ) 
    390407 
    391408 
    … …  
    397414         CALL histdef( nid_T, "vosaline", "Salinity"                           , "PSU"    ,   &  ! sn 
    398415            &          jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout ) 
     416         IF(  lk_vvl  ) THEN 
     417            CALL histdef( nid_T, "vovvle3t", "Level thickness"                    , "m"      ,&  ! e3t_n 
     418            &             jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout ) 
     419            CALL histdef( nid_T, "vovvldep", "T point depth"                      , "m"      ,&  ! e3t_n 
     420            &             jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout ) 
     421            CALL histdef( nid_T, "vovvldef", "Squared level deformation"          , "%^2"    ,&  ! e3t_n 
     422            &             jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout ) 
     423         ENDIF 
    399424         !                                                                                      !!! nid_T : 2D 
    400425         CALL histdef( nid_T, "sosstsst", "Sea Surface temperature"            , "C"      ,   &  ! sst 
    … …  
    408433         CALL histdef( nid_T, "sosfldow", "downward salt flux"                 , "PSU/m2/s",  &  ! sfx 
    409434            &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout ) 
    410 #if ! defined key_vvl 
    411          CALL histdef( nid_T, "sosst_cd", "Concentration/Dilution term on temperature"        &  ! emp * tsn(:,:,1,jp_tem) 
     435         IF(  .NOT. lk_vvl  ) THEN 
     436            CALL histdef( nid_T, "sosst_cd", "Concentration/Dilution term on temperature"     &  ! emp * tsn(:,:,1,jp_tem) 
    412437            &                                                                  , "KgC/m2/s",  &  ! sosst_cd 
    413             &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout ) 
    414          CALL histdef( nid_T, "sosss_cd", "Concentration/Dilution term on salinity"           &  ! emp * tsn(:,:,1,jp_sal) 
     438            &             jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout ) 
     439            CALL histdef( nid_T, "sosss_cd", "Concentration/Dilution term on salinity"        &  ! emp * tsn(:,:,1,jp_sal) 
    415440            &                                                                  , "KgPSU/m2/s",&  ! sosss_cd 
    416             &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout ) 
    417 #endif 
     441            &             jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout ) 
     442         ENDIF 
    418443         CALL histdef( nid_T, "sohefldo", "Net Downward Heat Flux"             , "W/m2"   ,   &  ! qns + qsr 
    419444            &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout ) 
    … …  
    587612      ! --------------------- 
    588613 
    589       ! ndex(1) est utilise ssi l'avant dernier argument est diffferent de  
     614      ! ndex(1) est utilise ssi l'avant dernier argument est different de  
    590615      ! la taille du tableau en sortie. Dans ce cas , l'avant dernier argument 
    591616      ! donne le nombre d'elements, et ndex la liste des indices a sortir 
    … …  
    597622 
    598623      ! Write fields on T grid 
    599       CALL histwrite( nid_T, "votemper", it, tsn(:,:,:,jp_tem), ndim_T , ndex_T  )   ! temperature 
    600       CALL histwrite( nid_T, "vosaline", it, tsn(:,:,:,jp_sal), ndim_T , ndex_T  )   ! salinity 
    601       CALL histwrite( nid_T, "sosstsst", it, tsn(:,:,1,jp_tem), ndim_hT, ndex_hT )   ! sea surface temperature 
    602       CALL histwrite( nid_T, "sosaline", it, tsn(:,:,1,jp_sal), ndim_hT, ndex_hT )   ! sea surface salinity 
     624      IF( lk_vvl ) THEN 
     625         CALL histwrite( nid_T, "votemper", it, tsn(:,:,:,jp_tem) * fse3t_n(:,:,:) , ndim_T , ndex_T  )   ! heat content 
     626         CALL histwrite( nid_T, "vosaline", it, tsn(:,:,:,jp_sal) * fse3t_n(:,:,:) , ndim_T , ndex_T  )   ! salt content 
     627         CALL histwrite( nid_T, "sosstsst", it, tsn(:,:,1,jp_tem) * fse3t_n(:,:,1) , ndim_hT, ndex_hT )   ! sea surface heat content 
     628         CALL histwrite( nid_T, "sosaline", it, tsn(:,:,1,jp_sal) * fse3t_n(:,:,1) , ndim_hT, ndex_hT )   ! sea surface salinity content 
     629      ELSE 
     630         CALL histwrite( nid_T, "votemper", it, tsn(:,:,:,jp_tem) , ndim_T , ndex_T  )   ! temperature 
     631         CALL histwrite( nid_T, "vosaline", it, tsn(:,:,:,jp_sal) , ndim_T , ndex_T  )   ! salinity 
     632         CALL histwrite( nid_T, "sosstsst", it, tsn(:,:,1,jp_tem) , ndim_hT, ndex_hT )   ! sea surface temperature 
     633         CALL histwrite( nid_T, "sosaline", it, tsn(:,:,1,jp_sal) , ndim_hT, ndex_hT )   ! sea surface salinity 
     634 
     635      ENDIF 
     636      IF( lk_vvl ) THEN 
     637         zw3d(:,:,:) = ( ( fse3t_n(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 
     638         CALL histwrite( nid_T, "vovvle3t", it, fse3t_n (:,:,:) , ndim_T , ndex_T  )   ! level thickness 
     639         CALL histwrite( nid_T, "vovvldep", it, fsdept_n(:,:,:) , ndim_T , ndex_T  )   ! t-point depth 
     640         CALL histwrite( nid_T, "vovvldef", it, zw3d             , ndim_T , ndex_T  )   ! level thickness deformation 
     641      ENDIF 
    603642      CALL histwrite( nid_T, "sossheig", it, sshn          , ndim_hT, ndex_hT )   ! sea surface height 
    604643      CALL histwrite( nid_T, "sowaflup", it, ( emp-rnf )   , ndim_hT, ndex_hT )   ! upward water flux 
    … …  
    606645                                                                                  ! (includes virtual salt flux beneath ice  
    607646                                                                                  ! in linear free surface case) 
    608 #if ! defined key_vvl 
    609       zw2d(:,:) = emp (:,:) * tsn(:,:,1,jp_tem) 
    610       CALL histwrite( nid_T, "sosst_cd", it, zw2d, ndim_hT, ndex_hT )             ! c/d term on sst 
    611       zw2d(:,:) = emp (:,:) * tsn(:,:,1,jp_sal) 
    612       CALL histwrite( nid_T, "sosss_cd", it, zw2d, ndim_hT, ndex_hT )             ! c/d term on sss 
    613 #endif 
     647      IF( .NOT. lk_vvl ) THEN 
     648         zw2d(:,:) = emp (:,:) * tsn(:,:,1,jp_tem) 
     649         CALL histwrite( nid_T, "sosst_cd", it, zw2d, ndim_hT, ndex_hT )          ! c/d term on sst 
     650         zw2d(:,:) = emp (:,:) * tsn(:,:,1,jp_sal) 
     651         CALL histwrite( nid_T, "sosss_cd", it, zw2d, ndim_hT, ndex_hT )          ! c/d term on sss 
     652      ENDIF 
    614653      CALL histwrite( nid_T, "sohefldo", it, qns + qsr     , ndim_hT, ndex_hT )   ! total heat flux 
    615654      CALL histwrite( nid_T, "soshfldo", it, qsr           , ndim_hT, ndex_hT )   ! solar heat flux 
    … …  
    752791      ! 
    753792      CALL wrk_dealloc( jpi , jpj      , zw2d ) 
    754       IF ( ln_traldf_gdia )  call wrk_dealloc( jpi , jpj , jpk  , zw3d ) 
     793      IF ( ln_traldf_gdia .OR. lk_vvl )  call wrk_dealloc( jpi , jpj , jpk  , zw3d ) 
    755794      ! 
    756795      IF( nn_timing == 1 )   CALL timing_stop('dia_wri') 
    … …  
    813852          1, jpi, 1, jpj, nit000-1, zjulian, zdt, nh_i, id_i, domain_id=nidom, snc4chunks=snc4set ) ! Horizontal grid : glamt and gphit 
    814853      CALL histvert( id_i, "deptht", "Vertical T levels",   &    ! Vertical grid : gdept 
    815           "m", jpk, gdept_0, nz_i, "down") 
     854          "m", jpk, gdept_1d, nz_i, "down") 
    816855 
    817856      ! Declare all the output fields as NetCDF variables 
    … …  
    841880      CALL histdef( id_i, "sometauy", "Meridional Wind Stress", "N/m2"   ,   &   ! j-wind stress 
    842881         &          jpi, jpj, nh_i, 1  , 1, 1  , -99 , 32, clop, zsto, zout ) 
     882      IF( lk_vvl ) THEN 
     883         CALL histdef( id_i, "vovvldep", "T point depth"         , "m"      ,   &   ! t-point depth 
     884            &          jpi, jpj, nh_i, jpk, 1, jpk, nz_i, 32, clop, zsto, zout ) 
     885      END IF 
    843886 
    844887#if defined key_lim2 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DOM/dom_oce.F90

    r4247 r4292  
    152152   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::  gphit, gphiu   !: latitude  of t-, u-, v- and f-points (degre) 
    153153   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::  gphiv, gphif   !: 
    154    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::  e1t, e2t       !: horizontal scale factors at t-point (m) 
    155    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::  e1u, e2u       !: horizontal scale factors at u-point (m) 
    156    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::  e1v, e2v       !: horizontal scale factors at v-point (m) 
    157    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::  e1f, e2f       !: horizontal scale factors at f-point (m) 
     154   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) ::  e1t, e2t       !: horizontal scale factors at t-point (m) 
     155   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) ::  e1u, e2u       !: horizontal scale factors at u-point (m) 
     156   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) ::  e1v, e2v       !: horizontal scale factors at v-point (m) 
     157   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) ::  e1f, e2f       !: horizontal scale factors at f-point (m) 
    158158   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::  e1e2t          !: surface at t-point (m2) 
    159159   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::  ff             !: coriolis factor (2.*omega*sin(yphi) ) (s-1) 
    … …  
    169169   !! All coordinates 
    170170   !! --------------- 
    171    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   gdep3w          !: depth of T-points (sum of e3w) (m) 
    172    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   gdept , gdepw   !: analytical depth at T-W  points (m) 
    173    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e3v   , e3f     !: analytical vertical scale factors at  V--F 
    174    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e3t   , e3u     !:                                       T--U  points (m) 
    175    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e3vw            !: analytical vertical scale factors at  VW-- 
    176    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e3w   , e3uw    !:                                        W--UW points (m) 
     171   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   gdep3w_0           !: depth of t-points (sum of e3w) (m) 
     172   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   gdept_0, gdepw_0   !: analytical (time invariant) depth at t-w  points (m) 
     173   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e3v_0  , e3f_0     !: analytical (time invariant) vertical scale factors at  v-f 
     174   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e3t_0  , e3u_0     !:                                      t-u  points (m) 
     175   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e3vw_0             !: analytical (time invariant) vertical scale factors at  vw 
     176   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e3w_0  , e3uw_0    !:                                      w-uw points (m) 
    177177#if defined key_vvl 
    178178   LOGICAL, PUBLIC, PARAMETER ::   lk_vvl = .TRUE.    !: variable grid flag 
    … …  
    180180   !! All coordinates 
    181181   !! --------------- 
    182    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   gdep3w_1           !: depth of T-points (sum of e3w) (m) 
    183    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   gdept_1, gdepw_1   !: analytical depth at T-W  points (m) 
    184    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e3v_1  , e3f_1     !: analytical vertical scale factors at  V--F 
    185    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e3t_1  , e3u_1     !:                                       T--U  points (m) 
    186    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e3vw_1             !: analytical vertical scale factors at  VW-- 
    187    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e3w_1  , e3uw_1    !:                                       W--UW  points (m) 
    188    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e3t_b              !: before         -      -      -    -   T      points (m) 
    189    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e3u_b  , e3v_b     !:   -            -      -      -    -   U--V   points (m) 
     182   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   gdep3w_n           !: now depth of T-points (sum of e3w) (m) 
     183   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   gdept_n, gdepw_n   !: now depth at T-W  points (m) 
     184   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e3t_n              !: now    vertical scale factors at  t       point  (m) 
     185   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e3u_n  , e3v_n     !:            -      -      -    -   u --v   points (m) 
     186   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e3w_n  , e3f_n     !:            -      -      -    -   w --f   points (m) 
     187   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e3uw_n , e3vw_n    !:            -      -      -    -   uw--vw  points (m) 
     188   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e3t_b              !: before     -      -      -    -   t       points (m) 
     189   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e3u_b  , e3v_b     !:   -        -      -      -    -   u --v   points (m) 
     190   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e3uw_b , e3vw_b    !:   -        -      -      -    -   uw--vw  points (m) 
     191   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e3t_a              !: after      -      -      -    -   t       point  (m) 
     192   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e3u_a  , e3v_a     !:   -        -      -      -    -   u --v   points (m) 
    190193#else 
    191194   LOGICAL, PUBLIC, PARAMETER ::   lk_vvl = .FALSE.   !: fixed grid flag 
    192195#endif 
    193    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET ::   hur  , hvr    !: inverse of u and v-points ocean depth (1/m) 
    194    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)         ::   hu   , hv     !: depth at u- and v-points (meters) 
    195    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)         ::   hu_0 , hv_0   !: refernce depth at u- and v-points (meters) 
     196   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET ::   hur  , hvr     !: inverse of u and v-points ocean depth (1/m) 
     197   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)         ::   hu   , hv      !: depth at u- and v-points (meters) 
     198   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)         ::   ht_0           !: reference depth at t-       points (meters) 
     199   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)         ::   hu_0 , hv_0    !: reference depth at u- and v-points (meters) 
     200   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)         ::   re2u_e1u       !: scale factor coeffs at u points (e2u/e1u) 
     201   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)         ::   re1v_e2v       !: scale factor coeffs at v points (e1v/e2v) 
     202   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)         ::   e12t , r1_e12t !: horizontal cell surface and inverse at t points 
     203   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)         ::   e12u , r1_e12u !: horizontal cell surface and inverse at u points 
     204   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)         ::   e12v , r1_e12v !: horizontal cell surface and inverse at v points 
     205   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)         ::   e12f , r1_e12f !: horizontal cell surface and inverse at f points 
    196206 
    197207   INTEGER, PUBLIC ::   nla10              !: deepest    W level Above  ~10m (nlb10 - 1) 
    … …  
    200210   !! z-coordinate with full steps (also used in the other cases as reference z-coordinate) 
    201211   !! =-----------------====------ 
    202    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)   :: gdept_0, gdepw_0 !: reference depth of t- and w-points (m) 
    203    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)   :: e3t_0  , e3w_0   !: reference vertical scale factors at T- and W-pts (m) 
    204    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: e3tp   , e3wp    !: ocean bottom level thickness at T and W points 
     212   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)   ::   gdept_1d, gdepw_1d !: reference depth of t- and w-points (m) 
     213   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)   ::   e3t_1d  , e3w_1d   !: reference vertical scale factors at T- and W-pts (m) 
     214   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   e3tp    , e3wp     !: ocean bottom level thickness at T and W points 
    205215 
    206216   !! s-coordinate and hybrid z-s-coordinate 
    207217   !! =----------------======--------------- 
    208    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   gsigt, gsigw   !: model level depth coefficient at t-, w-levels (analytic) 
    209    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   gsi3w          !: model level depth coefficient at w-level (sum of gsigw) 
    210    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   esigt, esigw   !: vertical scale factor coef. at t-, w-levels 
    211  
    212    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hbatv , hbatf    !: ocean depth at the vertical of  V--F 
    213    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hbatt , hbatu    !:                                 T--U points (m) 
    214    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   scosrf, scobot   !: ocean surface and bottom topographies  
    215    !                                        !  (if deviating from coordinate surfaces in HYBRID) 
    216    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hifv  , hiff     !: interface depth between stretching at  V--F 
    217    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hift  , hifu     !: and quasi-uniform spacing              T--U points (m) 
    218    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   rx1              !: Maximum grid stiffness ratio 
     218   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)   ::   gsigt, gsigw       !: model level depth coefficient at t-, w-levels (analytic) 
     219   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)   ::   gsi3w              !: model level depth coefficient at w-level (sum of gsigw) 
     220   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)   ::   esigt, esigw       !: vertical scale factor coef. at t-, w-levels 
     221 
     222   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hbatv , hbatf      !: ocean depth at the vertical of  v--f 
     223   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hbatt , hbatu      !:                                 t--u points (m) 
     224   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   scosrf, scobot     !: ocean surface and bottom topographies  
     225   !                                                                           !  (if deviating from coordinate surfaces in HYBRID) 
     226   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hifv  , hiff       !: interface depth between stretching at v--f 
     227   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hift  , hifu       !: and quasi-uniform spacing             t--u points (m) 
     228   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   rx1                !: Maximum grid stiffness ratio 
    219229 
    220230   !!---------------------------------------------------------------------- 
    221231   !! masks, bathymetry 
    222232   !! --------------------------------------------------------------------- 
    223    INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   mbathy       !: number of ocean level (=0, 1, ... , jpk-1) 
    224    INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   mbkt         !: vertical index of the bottom last T- ocean level 
    225    INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   mbku, mbkv   !: vertical index of the bottom last U- and W- ocean level 
    226    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   bathy        !: ocean depth (meters) 
    227    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   tmask_i      !: interior domain T-point mask 
    228    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   bmask        !: land/ocean mask of barotropic stream function 
    229  
    230    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tmask, umask, vmask, fmask   !: land/ocean mask at T-, U-, V- and F-pts 
     233   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   mbathy             !: number of ocean level (=0, 1, ... , jpk-1) 
     234   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   mbkt               !: vertical index of the bottom last T- ocean level 
     235   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   mbku, mbkv         !: vertical index of the bottom last U- and W- ocean level 
     236   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   bathy              !: ocean depth (meters) 
     237   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   tmask_i            !: interior domain T-point mask 
     238   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   bmask              !: land/ocean mask of barotropic stream function 
     239 
     240   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: tmask, umask, vmask, fmask   !: land/ocean mask at T-, U-, V- and F-pts 
    231241 
    232242   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   tpol, fpol          !: north fold mask (jperio= 3 or 4) 
    233243 
    234244#if defined key_noslip_accurate 
    235    INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:  ) :: npcoa        !: ??? 
    236    INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: nicoa, njcoa !: ??? 
     245   INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:  )  :: npcoa              !: ??? 
     246   INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  :: nicoa, njcoa      !: ??? 
    237247#endif 
    238248 
    … …  
    316326         &      glamf(jpi,jpj) , gphif(jpi,jpj) , e1f(jpi,jpj) , e2f(jpi,jpj) , ff   (jpi,jpj) , STAT=ierr(3) )      
    317327         ! 
    318       ALLOCATE( gdep3w(jpi,jpj,jpk) , e3v(jpi,jpj,jpk) , e3f (jpi,jpj,jpk) ,                         & 
    319          &      gdept (jpi,jpj,jpk) , e3t(jpi,jpj,jpk) , e3u (jpi,jpj,jpk) ,                         & 
    320          &      gdepw (jpi,jpj,jpk) , e3w(jpi,jpj,jpk) , e3vw(jpi,jpj,jpk) , e3uw(jpi,jpj,jpk) , STAT=ierr(4) ) 
     328      ALLOCATE( gdep3w_0(jpi,jpj,jpk) , e3v_0(jpi,jpj,jpk) , e3f_0 (jpi,jpj,jpk) ,                         & 
     329         &      gdept_0 (jpi,jpj,jpk) , e3t_0(jpi,jpj,jpk) , e3u_0 (jpi,jpj,jpk) ,                         & 
     330         &      gdepw_0 (jpi,jpj,jpk) , e3w_0(jpi,jpj,jpk) , e3vw_0(jpi,jpj,jpk) , e3uw_0(jpi,jpj,jpk) , STAT=ierr(4) ) 
    321331         ! 
    322332#if defined key_vvl 
    323       ALLOCATE( gdep3w_1(jpi,jpj,jpk) , e3v_1(jpi,jpj,jpk) , e3f_1 (jpi,jpj,jpk) ,                           & 
    324          &      gdept_1 (jpi,jpj,jpk) , e3t_1(jpi,jpj,jpk) , e3u_1 (jpi,jpj,jpk) ,                           & 
    325          &      gdepw_1 (jpi,jpj,jpk) , e3w_1(jpi,jpj,jpk) , e3vw_1(jpi,jpj,jpk) , e3uw_1(jpi,jpj,jpk) ,     & 
    326          &      e3t_b   (jpi,jpj,jpk) , e3u_b(jpi,jpj,jpk) , e3v_b (jpi,jpj,jpk)                       , STAT=ierr(5) ) 
    327 #endif 
    328          ! 
    329       ALLOCATE( hu(jpi,jpj) , hur(jpi,jpj) , hu_0(jpi,jpj) ,     & 
    330          &      hv(jpi,jpj) , hvr(jpi,jpj) , hv_0(jpi,jpj) , STAT=ierr(6) ) 
    331          ! 
    332       ALLOCATE( gdept_0(jpk) , gdepw_0(jpk) ,                                     & 
    333          &      e3t_0  (jpk) , e3w_0  (jpk) , e3tp (jpi,jpj), e3wp(jpi,jpj) ,     & 
    334          &      gsigt  (jpk) , gsigw  (jpk) , gsi3w(jpk)    ,                     & 
    335          &      esigt  (jpk) , esigw  (jpk)                                 , STAT=ierr(7) ) 
     333      ALLOCATE( gdep3w_n(jpi,jpj,jpk) , e3t_n (jpi,jpj,jpk) , e3u_n (jpi,jpj,jpk) ,                           & 
     334         &      gdept_n (jpi,jpj,jpk) , e3v_n (jpi,jpj,jpk) , e3w_n (jpi,jpj,jpk) ,                           & 
     335         &      gdepw_n (jpi,jpj,jpk) , e3f_n (jpi,jpj,jpk) , e3vw_n(jpi,jpj,jpk) , e3uw_n(jpi,jpj,jpk) ,     & 
     336         &      e3t_b   (jpi,jpj,jpk) , e3u_b (jpi,jpj,jpk) , e3v_b (jpi,jpj,jpk) ,                           & 
     337         &      e3uw_b  (jpi,jpj,jpk) , e3vw_b(jpi,jpj,jpk) ,                                                 & 
     338         &      e3t_a   (jpi,jpj,jpk) , e3u_a (jpi,jpj,jpk) , e3v_a (jpi,jpj,jpk)                       , STAT=ierr(5) ) 
     339#endif 
     340         ! 
     341      ALLOCATE( hu      (jpi,jpj) , hur     (jpi,jpj) , hu_0(jpi,jpj) , ht_0  (jpi,jpj) ,     & 
     342         &      hv      (jpi,jpj) , hvr     (jpi,jpj) , hv_0(jpi,jpj) ,                       & 
     343         &      re2u_e1u(jpi,jpj) , re1v_e2v(jpi,jpj) ,                                       & 
     344         &      e12t    (jpi,jpj) , r1_e12t (jpi,jpj) ,                                       & 
     345         &      e12u    (jpi,jpj) , r1_e12u (jpi,jpj) ,                                       & 
     346         &      e12v    (jpi,jpj) , r1_e12v (jpi,jpj) ,                                       & 
     347         &      e12f    (jpi,jpj) , r1_e12f (jpi,jpj) ,                                   STAT=ierr(6)  ) 
     348         ! 
     349      ALLOCATE( gdept_1d(jpk) , gdepw_1d(jpk) ,                                     & 
     350         &      e3t_1d  (jpk) , e3w_1d  (jpk) , e3tp (jpi,jpj), e3wp(jpi,jpj) ,     & 
     351         &      gsigt   (jpk) , gsigw   (jpk) , gsi3w(jpk)    ,                     & 
     352         &      esigt   (jpk) , esigw   (jpk)                                 , STAT=ierr(7) ) 
    336353         ! 
    337354      ALLOCATE( hbatv (jpi,jpj) , hbatf (jpi,jpj) ,     & 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DOM/domain.F90

    r4245 r4292  
    8787                             CALL dom_msk      ! Masks 
    8888      IF( ln_sco )           CALL dom_stiff    ! Maximum stiffness ratio/hydrostatic consistency 
    89       IF( lk_vvl         )   CALL dom_vvl      ! Vertical variable mesh 
     89      IF( lk_vvl )           CALL dom_vvl_init ! Vertical variable mesh 
    9090      ! 
    9191      IF( lk_c1d         )   CALL cor_c1d      ! 1D configuration: Coriolis set at T-point 
     92      ! 
     93      ! - ML - Used in dom_vvl_sf_nxt and lateral diffusion routines 
     94      !        but could be usefull in many other routines 
     95      e12t    (:,:) = e1t(:,:) * e2t(:,:) 
     96      e12u    (:,:) = e1u(:,:) * e2u(:,:) 
     97      e12v    (:,:) = e1v(:,:) * e2v(:,:) 
     98      e12f    (:,:) = e1f(:,:) * e2f(:,:) 
     99      r1_e12t (:,:) = 1._wp    / e12t(:,:) 
     100      r1_e12u (:,:) = 1._wp    / e12u(:,:) 
     101      r1_e12v (:,:) = 1._wp    / e12v(:,:) 
     102      r1_e12f (:,:) = 1._wp    / e12f(:,:) 
     103      re2u_e1u(:,:) = e2u(:,:) / e1u(:,:) 
     104      re1v_e2v(:,:) = e1v(:,:) / e2v(:,:) 
    92105      ! 
    93106      hu(:,:) = 0._wp                          ! Ocean depth at U- and V-points 
    94107      hv(:,:) = 0._wp 
    95108      DO jk = 1, jpk 
    96          hu(:,:) = hu(:,:) + fse3u(:,:,jk) * umask(:,:,jk) 
    97          hv(:,:) = hv(:,:) + fse3v(:,:,jk) * vmask(:,:,jk) 
     109         hu(:,:) = hu(:,:) + fse3u_n(:,:,jk) * umask(:,:,jk) 
     110         hv(:,:) = hv(:,:) + fse3v_n(:,:,jk) * vmask(:,:,jk) 
    98111      END DO 
    99112      !                                        ! Inverse of the local depth 
    … …  
    407420         DO jj = 2, jpjm1 
    408421            DO jk = 1, jpkm1 
    409                zr1(1) = umask(ji-1,jj  ,jk) *abs( (gdepw(ji  ,jj  ,jk  )-gdepw(ji-1,jj  ,jk  )  &  
    410                     &                         +gdepw(ji  ,jj  ,jk+1)-gdepw(ji-1,jj  ,jk+1)) & 
    411                     &                        /(gdepw(ji  ,jj  ,jk  )+gdepw(ji-1,jj  ,jk  )  & 
    412                     &                         -gdepw(ji  ,jj  ,jk+1)-gdepw(ji-1,jj  ,jk+1) + rsmall) ) 
    413                zr1(2) = umask(ji  ,jj  ,jk) *abs( (gdepw(ji+1,jj  ,jk  )-gdepw(ji  ,jj  ,jk  )  & 
    414                     &                         +gdepw(ji+1,jj  ,jk+1)-gdepw(ji  ,jj  ,jk+1)) & 
    415                     &                        /(gdepw(ji+1,jj  ,jk  )+gdepw(ji  ,jj  ,jk  )  & 
    416                     &                         -gdepw(ji+1,jj  ,jk+1)-gdepw(ji  ,jj  ,jk+1) + rsmall) ) 
    417                zr1(3) = vmask(ji  ,jj  ,jk) *abs( (gdepw(ji  ,jj+1,jk  )-gdepw(ji  ,jj  ,jk  )  & 
    418                     &                         +gdepw(ji  ,jj+1,jk+1)-gdepw(ji  ,jj  ,jk+1)) & 
    419                     &                        /(gdepw(ji  ,jj+1,jk  )+gdepw(ji  ,jj  ,jk  )  & 
    420                     &                         -gdepw(ji  ,jj+1,jk+1)-gdepw(ji  ,jj  ,jk+1) + rsmall) ) 
    421                zr1(4) = vmask(ji  ,jj-1,jk) *abs( (gdepw(ji  ,jj  ,jk  )-gdepw(ji  ,jj-1,jk  )  & 
    422                     &                         +gdepw(ji  ,jj  ,jk+1)-gdepw(ji  ,jj-1,jk+1)) & 
    423                     &                        /(gdepw(ji  ,jj  ,jk  )+gdepw(ji  ,jj-1,jk  )  & 
    424                     &                         -gdepw(ji,  jj  ,jk+1)-gdepw(ji  ,jj-1,jk+1) + rsmall) ) 
     422               zr1(1) = umask(ji-1,jj  ,jk) *abs( (gdepw_0(ji  ,jj  ,jk  )-gdepw_0(ji-1,jj  ,jk  )  &  
     423                    &                         +gdepw_0(ji  ,jj  ,jk+1)-gdepw_0(ji-1,jj  ,jk+1)) & 
     424                    &                        /(gdepw_0(ji  ,jj  ,jk  )+gdepw_0(ji-1,jj  ,jk  )  & 
     425                    &                         -gdepw_0(ji  ,jj  ,jk+1)-gdepw_0(ji-1,jj  ,jk+1) + rsmall) ) 
     426               zr1(2) = umask(ji  ,jj  ,jk) *abs( (gdepw_0(ji+1,jj  ,jk  )-gdepw_0(ji  ,jj  ,jk  )  & 
     427                    &                         +gdepw_0(ji+1,jj  ,jk+1)-gdepw_0(ji  ,jj  ,jk+1)) & 
     428                    &                        /(gdepw_0(ji+1,jj  ,jk  )+gdepw_0(ji  ,jj  ,jk  )  & 
     429                    &                         -gdepw_0(ji+1,jj  ,jk+1)-gdepw_0(ji  ,jj  ,jk+1) + rsmall) ) 
     430               zr1(3) = vmask(ji  ,jj  ,jk) *abs( (gdepw_0(ji  ,jj+1,jk  )-gdepw_0(ji  ,jj  ,jk  )  & 
     431                    &                         +gdepw_0(ji  ,jj+1,jk+1)-gdepw_0(ji  ,jj  ,jk+1)) & 
     432                    &                        /(gdepw_0(ji  ,jj+1,jk  )+gdepw_0(ji  ,jj  ,jk  )  & 
     433                    &                         -gdepw_0(ji  ,jj+1,jk+1)-gdepw_0(ji  ,jj  ,jk+1) + rsmall) ) 
     434               zr1(4) = vmask(ji  ,jj-1,jk) *abs( (gdepw_0(ji  ,jj  ,jk  )-gdepw_0(ji  ,jj-1,jk  )  & 
     435                    &                         +gdepw_0(ji  ,jj  ,jk+1)-gdepw_0(ji  ,jj-1,jk+1)) & 
     436                    &                        /(gdepw_0(ji  ,jj  ,jk  )+gdepw_0(ji  ,jj-1,jk  )  & 
     437                    &                         -gdepw_0(ji,  jj  ,jk+1)-gdepw_0(ji  ,jj-1,jk+1) + rsmall) ) 
    425438               zrxmax = MAXVAL(zr1(1:4)) 
    426439               rx1(ji,jj) = MAX(rx1(ji,jj), zrxmax) 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DOM/domstp.F90

    r2715 r4292  
    9090 
    9191            DO jk = 1, jpk 
    92                IF( gdept_0(jk) <= rdth ) rdttra(jk) = rdtmin 
    93                IF( gdept_0(jk) >  rdth ) THEN 
     92               IF( gdept_1d(jk) <= rdth ) rdttra(jk) = rdtmin 
     93               IF( gdept_1d(jk) >  rdth ) THEN 
    9494                  rdttra(jk) = rdtmin + ( rdtmax - rdtmin )   & 
    95                                       * ( EXP( ( gdept_0(jk ) - rdth ) / rdth ) - 1. )   & 
    96                                       / ( EXP( ( gdept_0(jpk) - rdth ) / rdth ) - 1. ) 
     95                                      * ( EXP( ( gdept_1d(jk ) - rdth ) / rdth ) - 1. )   & 
     96                                      / ( EXP( ( gdept_1d(jpk) - rdth ) / rdth ) - 1. ) 
    9797               ENDIF 
    9898               IF(lwp) WRITE(numout,"(36x,f5.2,5x,i3)") rdttra(jk)/3600., jk 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DOM/domvvl.F90

    r4153 r4292  
    66   !! History :  2.0  !  2006-06  (B. Levier, L. Marie)  original code 
    77   !!            3.1  !  2009-02  (G. Madec, M. Leclair, R. Benshila)  pure z* coordinate 
    8    !!---------------------------------------------------------------------- 
    9 #if defined key_vvl 
     8   !!            3.3  !  2011-10  (M. Leclair) totally rewrote domvvl: 
     9   !!                                          vvl option includes z_star and z_tilde coordinates 
    1010   !!---------------------------------------------------------------------- 
    1111   !!   'key_vvl'                              variable volume 
    1212   !!---------------------------------------------------------------------- 
    13    !!   dom_vvl     : defined coefficients to distribute ssh on each layers 
    1413   !!---------------------------------------------------------------------- 
     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_swp   : 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   !!   dom_vvl_orca_fix : Recompute some area-weighted interpolations of vertical scale factors  
     21   !!                    : to account for manual changes to e[1,2][u,v] in some Straits  
     22   !!---------------------------------------------------------------------- 
     23   !! * Modules used 
    1524   USE oce             ! ocean dynamics and tracers 
    1625   USE dom_oce         ! ocean space and time domain 
    17    USE sbc_oce         ! surface boundary condition: ocean 
    18    USE phycst          ! physical constants 
     26   USE sbc_oce         ! ocean surface boundary condition 
    1927   USE in_out_manager  ! I/O manager 
     28   USE iom             ! I/O manager library 
     29   USE restart         ! ocean restart 
    2030   USE lib_mpp         ! distributed memory computing library 
    2131   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    … …  
    2636   PRIVATE 
    2737 
    28    PUBLIC   dom_vvl         ! called by domain.F90 
    29    PUBLIC   dom_vvl_2       ! called by domain.F90 
    30    PUBLIC   dom_vvl_alloc   ! called by nemogcm.F90 
    31  
    32    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   mut , muu , muv , muf    !: 1/H_0 at t-,u-,v-,f-points  
    33  
    34    REAL(wp),         ALLOCATABLE, SAVE, DIMENSION(:)     ::   r2dt   ! vertical profile time-step, = 2 rdttra  
    35       !                                                              ! except at nit000 (=rdttra) if neuler=0 
     38   !! * Routine accessibility 
     39   PUBLIC  dom_vvl_init       ! called by domain.F90 
     40   PUBLIC  dom_vvl_sf_nxt     ! called by step.F90 
     41   PUBLIC  dom_vvl_sf_swp     ! called by step.F90 
     42   PUBLIC  dom_vvl_interpol   ! called by dynnxt.F90 
     43   PRIVATE dom_vvl_orca_fix   ! called by dom_vvl_interpol 
     44 
     45   !!* Namelist nam_vvl 
     46   LOGICAL , PUBLIC                                      :: ln_vvl_zstar           = .FALSE.   ! zstar  vertical coordinate 
     47   LOGICAL , PUBLIC                                      :: ln_vvl_ztilde          = .FALSE.   ! ztilde vertical coordinate 
     48   LOGICAL , PUBLIC                                      :: ln_vvl_layer           = .FALSE.   ! level  vertical coordinate 
     49   LOGICAL , PUBLIC                                      :: ln_vvl_ztilde_as_zstar = .FALSE.   ! ztilde vertical coordinate 
     50   LOGICAL , PUBLIC                                      :: ln_vvl_zstar_at_eqtor  = .FALSE.   ! ztilde vertical coordinate 
     51   LOGICAL , PUBLIC                                      :: ln_vvl_kepe            = .FALSE.   ! kinetic/potential energy transfer 
     52   !                                                                                           ! conservation: not used yet 
     53   REAL(wp)                                              :: rn_ahe3                =  0.0_wp   ! thickness diffusion coefficient 
     54   REAL(wp)                                              :: rn_rst_e3t             =  30._wp   ! ztilde to zstar restoration timescale [days] 
     55   REAL(wp)                                              :: rn_lf_cutoff           =  5.0_wp   ! cutoff frequency for low-pass filter  [days] 
     56   REAL(wp)                                              :: rn_zdef_max            =  0.9_wp   ! maximum fractional e3t deformation 
     57   LOGICAL , PUBLIC                                      :: ln_vvl_dbg             = .FALSE.   ! debug control prints 
     58 
     59   !! * Module variables 
     60   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: un_td, vn_td                       ! thickness diffusion transport 
     61   REAL(wp)        , ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hdiv_lf                            ! low frequency part of hz divergence 
     62   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tilde_e3t_b, tilde_e3t_n           ! baroclinic scale factors 
     63   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tilde_e3t_a                        ! baroclinic scale factors 
     64   REAL(wp)        , ALLOCATABLE, SAVE, DIMENSION(:,:)   :: frq_rst_e3t                        ! retoring period for scale factors 
     65   REAL(wp)        , ALLOCATABLE, SAVE, DIMENSION(:,:)   :: frq_rst_hdv                        ! retoring period for low freq. divergence 
    3666 
    3767   !! * Substitutions 
    … …  
    3969#  include "vectopt_loop_substitute.h90" 
    4070   !!---------------------------------------------------------------------- 
    41    !! NEMO/OPA 4.0 , NEMO Consortium (2011) 
     71   !! NEMO/OPA 3.3 , NEMO-Consortium (2010)  
    4272   !! $Id$ 
    4373   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    4474   !!---------------------------------------------------------------------- 
    45 CONTAINS        
     75 
     76CONTAINS 
    4677 
    4778   INTEGER FUNCTION dom_vvl_alloc() 
    4879      !!---------------------------------------------------------------------- 
    49       !!                ***  ROUTINE dom_vvl_alloc  *** 
    50       !!---------------------------------------------------------------------- 
     80      !!                ***  FUNCTION dom_vvl_alloc  *** 
     81      !!---------------------------------------------------------------------- 
     82      IF( ln_vvl_zstar ) dom_vvl_alloc = 0 
     83      IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN 
     84         ALLOCATE( tilde_e3t_b(jpi,jpj,jpk) , tilde_e3t_n(jpi,jpj,jpk) , tilde_e3t_a(jpi,jpj,jpk) ,   & 
     85            &      un_td  (jpi,jpj,jpk)     , vn_td  (jpi,jpj,jpk)     , STAT = dom_vvl_alloc        ) 
     86         IF( lk_mpp             )   CALL mpp_sum ( dom_vvl_alloc ) 
     87         IF( dom_vvl_alloc /= 0 )   CALL ctl_warn('dom_vvl_alloc: failed to allocate arrays') 
     88         un_td = 0.0_wp 
     89         vn_td = 0.0_wp 
     90      ENDIF 
     91      IF( ln_vvl_ztilde ) THEN 
     92         ALLOCATE( frq_rst_e3t(jpi,jpj) , frq_rst_hdv(jpi,jpj) , hdiv_lf(jpi,jpj,jpk) , STAT= dom_vvl_alloc ) 
     93         IF( lk_mpp             )   CALL mpp_sum ( dom_vvl_alloc ) 
     94         IF( dom_vvl_alloc /= 0 )   CALL ctl_warn('dom_vvl_alloc: failed to allocate arrays') 
     95      ENDIF 
     96 
     97   END FUNCTION dom_vvl_alloc 
     98 
     99 
     100   SUBROUTINE dom_vvl_init 
     101      !!---------------------------------------------------------------------- 
     102      !!                ***  ROUTINE dom_vvl_init  *** 
     103      !!                    
     104      !! ** Purpose :  Initialization of all scale factors, depths 
     105      !!               and water column heights 
     106      !! 
     107      !! ** Method  :  - use restart file and/or initialize 
     108      !!               - interpolate scale factors 
     109      !! 
     110      !! ** Action  : - fse3t_(n/b) and tilde_e3t_(n/b) 
     111      !!              - Regrid: fse3(u/v)_n 
     112      !!                        fse3(u/v)_b        
     113      !!                        fse3w_n            
     114      !!                        fse3(u/v)w_b       
     115      !!                        fse3(u/v)w_n       
     116      !!                        fsdept_n, fsdepw_n and fsde3w_n 
     117      !!              - h(t/u/v)_0 
     118      !!              - frq_rst_e3t and frq_rst_hdv 
     119      !! 
     120      !! Reference  : Leclair, M., and G. Madec, 2011, Ocean Modelling. 
     121      !!---------------------------------------------------------------------- 
     122      USE phycst,  ONLY : rpi, rsmall, rad 
     123      !! * Local declarations 
     124      INTEGER ::   ji,jj,jk 
     125      INTEGER ::   ii0, ii1, ij0, ij1 
     126      !!---------------------------------------------------------------------- 
     127      IF( nn_timing == 1 )  CALL timing_start('dom_vvl_init') 
     128 
     129      IF(lwp) WRITE(numout,*) 
     130      IF(lwp) WRITE(numout,*) 'dom_vvl_init : Variable volume activated' 
     131      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' 
     132 
     133      ! choose vertical coordinate (z_star, z_tilde or layer) 
     134      ! ========================== 
     135      CALL dom_vvl_ctl 
     136 
     137      ! Allocate module arrays 
     138      ! ====================== 
     139      IF( dom_vvl_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'dom_vvl_init : unable to allocate arrays' ) 
     140 
     141      ! Read or initialize fse3t_(b/n), tilde_e3t_(b/n) and hdiv_lf (and e3t_a(jpk)) 
     142      ! ============================================================================ 
     143      CALL dom_vvl_rst( nit000, 'READ' ) 
     144      fse3t_a(:,:,jpk) = e3t_0(:,:,jpk) 
     145 
     146      ! Reconstruction of all vertical scale factors at now and before time steps 
     147      ! ============================================================================= 
     148      ! Horizontal scale factor interpolations 
     149      ! -------------------------------------- 
     150      CALL dom_vvl_interpol( fse3t_b(:,:,:), fse3u_b(:,:,:), 'U' ) 
     151      CALL dom_vvl_interpol( fse3t_b(:,:,:), fse3v_b(:,:,:), 'V' ) 
     152      CALL dom_vvl_interpol( fse3t_n(:,:,:), fse3u_n(:,:,:), 'U' ) 
     153      CALL dom_vvl_interpol( fse3t_n(:,:,:), fse3v_n(:,:,:), 'V' ) 
     154      CALL dom_vvl_interpol( fse3u_n(:,:,:), fse3f_n(:,:,:), 'F' ) 
     155      ! Vertical scale factor interpolations 
     156      ! ------------------------------------ 
     157      CALL dom_vvl_interpol( fse3t_n(:,:,:), fse3w_n (:,:,:), 'W'  ) 
     158      CALL dom_vvl_interpol( fse3u_n(:,:,:), fse3uw_n(:,:,:), 'UW' ) 
     159      CALL dom_vvl_interpol( fse3v_n(:,:,:), fse3vw_n(:,:,:), 'VW' ) 
     160      CALL dom_vvl_interpol( fse3u_b(:,:,:), fse3uw_b(:,:,:), 'UW' ) 
     161      CALL dom_vvl_interpol( fse3v_b(:,:,:), fse3vw_b(:,:,:), 'VW' ) 
     162      ! t- and w- points depth 
     163      ! ---------------------- 
     164      fsdept_n(:,:,1) = 0.5_wp * fse3w_n(:,:,1) 
     165      fsdepw_n(:,:,1) = 0.0_wp 
     166      fsde3w_n(:,:,1) = fsdept_n(:,:,1) - sshn(:,:) 
     167      DO jk = 2, jpk 
     168         fsdept_n(:,:,jk) = fsdept_n(:,:,jk-1) + fse3w_n(:,:,jk) 
     169         fsdepw_n(:,:,jk) = fsdepw_n(:,:,jk-1) + fse3t_n(:,:,jk-1) 
     170         fsde3w_n(:,:,jk) = fsdept_n(:,:,jk  ) - sshn   (:,:) 
     171      END DO 
     172      ! Reference water column height at t-, u- and v- point 
     173      ! ---------------------------------------------------- 
     174      ht_0(:,:) = 0.0_wp 
     175      hu_0(:,:) = 0.0_wp 
     176      hv_0(:,:) = 0.0_wp 
     177      DO jk = 1, jpk 
     178         ht_0(:,:) = ht_0(:,:) + e3t_0(:,:,jk) * tmask(:,:,jk) 
     179         hu_0(:,:) = hu_0(:,:) + e3u_0(:,:,jk) * umask(:,:,jk) 
     180         hv_0(:,:) = hv_0(:,:) + e3v_0(:,:,jk) * vmask(:,:,jk) 
     181      END DO 
     182 
     183      ! Restoring frequencies for z_tilde coordinate 
     184      ! ============================================ 
     185      IF( ln_vvl_ztilde ) THEN 
     186         ! Values in days provided via the namelist; use rsmall to avoid possible division by zero errors with faulty settings 
     187         frq_rst_e3t(:,:) = 2.0_wp * rpi / ( MAX( rn_rst_e3t  , rsmall ) * 86400.0_wp ) 
     188         frq_rst_hdv(:,:) = 2.0_wp * rpi / ( MAX( rn_lf_cutoff, rsmall ) * 86400.0_wp ) 
     189         IF( ln_vvl_ztilde_as_zstar ) THEN 
     190            ! Ignore namelist settings and use these next two to emulate z-star using z-tilde 
     191            frq_rst_e3t(:,:) = 0.0_wp  
     192            frq_rst_hdv(:,:) = 1.0_wp / rdt 
     193         ENDIF 
     194         IF ( ln_vvl_zstar_at_eqtor ) THEN 
     195            DO jj = 1, jpj 
     196               DO ji = 1, jpi 
     197                  IF( ABS(gphit(ji,jj)) >= 6.) THEN 
     198                     ! values outside the equatorial band and transition zone (ztilde) 
     199                     frq_rst_e3t(ji,jj) =  2.0_wp * rpi / ( MAX( rn_rst_e3t  , rsmall ) * 86400.e0_wp ) 
     200                     frq_rst_hdv(ji,jj) =  2.0_wp * rpi / ( MAX( rn_lf_cutoff, rsmall ) * 86400.e0_wp ) 
     201                  ELSEIF( ABS(gphit(ji,jj)) <= 2.5) THEN 
     202                     ! values inside the equatorial band (ztilde as zstar) 
     203                     frq_rst_e3t(ji,jj) =  0.0_wp 
     204                     frq_rst_hdv(ji,jj) =  1.0_wp / rdt 
     205                  ELSE 
     206                     ! values in the transition band (linearly vary from ztilde to ztilde as zstar values) 
     207                     frq_rst_e3t(ji,jj) = 0.0_wp + (frq_rst_e3t(ji,jj)-0.0_wp)*0.5_wp   & 
     208                        &            * (  1.0_wp - COS( rad*(ABS(gphit(ji,jj))-2.5_wp)  & 
     209                        &                                          * 180._wp / 3.5_wp ) ) 
     210                     frq_rst_hdv(ji,jj) = (1.0_wp / rdt)                                & 
     211                        &            + (  frq_rst_hdv(ji,jj)-(1.e0_wp / rdt) )*0.5_wp   & 
     212                        &            * (  1._wp  - COS( rad*(ABS(gphit(ji,jj))-2.5_wp)  & 
     213                        &                                          * 180._wp / 3.5_wp ) ) 
     214                  ENDIF 
     215               END DO 
     216            END DO 
     217            IF( cp_cfg == "orca" .AND. jp_cfg == 2 ) THEN 
     218               ii0 = 103   ;   ii1 = 111        ! Suppress ztilde in the Foxe Basin for ORCA2 
     219               ij0 = 128   ;   ij1 = 135   ;    
     220               frq_rst_e3t( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  0.0_wp 
     221               frq_rst_hdv( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  1.e0_wp / rdt 
     222            ENDIF 
     223         ENDIF 
     224      ENDIF 
     225 
     226      IF( nn_timing == 1 )  CALL timing_stop('dom_vvl_init') 
     227 
     228   END SUBROUTINE dom_vvl_init 
     229 
     230 
     231   SUBROUTINE dom_vvl_sf_nxt( kt )  
     232      !!---------------------------------------------------------------------- 
     233      !!                ***  ROUTINE dom_vvl_sf_nxt  *** 
     234      !!                    
     235      !! ** Purpose :  - compute the after scale factors used in tra_zdf, dynnxt, 
     236      !!                 tranxt and dynspg routines 
     237      !! 
     238      !! ** Method  :  - z_star case:  Repartition of ssh INCREMENT proportionnaly to the level thickness. 
     239      !!               - z_tilde_case: after scale factor increment =  
     240      !!                                    high frequency part of horizontal divergence 
     241      !!                                  + retsoring towards the background grid 
     242      !!                                  + thickness difusion 
     243      !!                               Then repartition of ssh INCREMENT proportionnaly 
     244      !!                               to the "baroclinic" level thickness. 
     245      !! 
     246      !! ** Action  :  - hdiv_lf    : restoring towards full baroclinic divergence in z_tilde case 
     247      !!               - tilde_e3t_a: after increment of vertical scale factor  
     248      !!                              in z_tilde case 
     249      !!               - fse3(t/u/v)_a 
     250      !! 
     251      !! Reference  : Leclair, M., and Madec, G. 2011, Ocean Modelling. 
     252      !!---------------------------------------------------------------------- 
     253      REAL(wp), POINTER, DIMENSION(:,:,:) :: ze3t 
     254      REAL(wp), POINTER, DIMENSION(:,:  ) :: zht, z_scale, zwu, zwv, zhdiv 
     255      !! * Arguments 
     256      INTEGER, INTENT( in )                  :: kt                    ! time step 
     257      !! * Local declarations 
     258      INTEGER                                :: ji, jj, jk            ! dummy loop indices 
     259      INTEGER , DIMENSION(3)                 :: ijk_max, ijk_min      ! temporary integers 
     260      REAL(wp)                               :: z2dt                  ! temporary scalars 
     261      REAL(wp)                               :: z_tmin, z_tmax        ! temporary scalars 
     262      !!---------------------------------------------------------------------- 
     263      IF( nn_timing == 1 )  CALL timing_start('dom_vvl_sf_nxt') 
     264      CALL wrk_alloc( jpi, jpj, zht, z_scale, zwu, zwv, zhdiv ) 
     265      CALL wrk_alloc( jpi, jpj, jpk, ze3t                     ) 
     266 
     267      IF(kt == nit000)   THEN 
     268         IF(lwp) WRITE(numout,*) 
     269         IF(lwp) WRITE(numout,*) 'dom_vvl_sf_nxt : compute after scale factors' 
     270         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~' 
     271      ENDIF 
     272 
     273      ! ******************************* ! 
     274      ! After acale factors at t-points ! 
     275      ! ******************************* ! 
     276 
     277      !                                                ! ----------------- ! 
     278      IF( ln_vvl_zstar ) THEN                          ! z_star coordinate ! 
     279         !                                             ! ----------------- ! 
     280 
     281         z_scale(:,:) = ( ssha(:,:) - sshb(:,:) ) * tmask(:,:,1) / ( ht_0(:,:) + sshn(:,:) + 1. - tmask(:,:,1) ) 
     282         DO jk = 1, jpkm1 
     283            fse3t_a(:,:,jk) = fse3t_b(:,:,jk) + fse3t_n(:,:,jk) * z_scale(:,:) * tmask(:,:,jk) 
     284         END DO 
     285 
     286      !                                                ! --------------------------- ! 
     287      ELSEIF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN   ! z_tilde or layer coordinate ! 
     288         !                                             ! --------------------------- ! 
     289 
     290         ! I - initialization 
     291         ! ================== 
     292 
     293         ! 1 - barotropic divergence 
     294         ! ------------------------- 
     295         zhdiv(:,:) = 0. 
     296         zht(:,:)   = 0. 
     297         DO jk = 1, jpkm1 
     298            zhdiv(:,:) = zhdiv(:,:) + fse3t_n(:,:,jk) * hdivn(:,:,jk) 
     299            zht  (:,:) = zht  (:,:) + fse3t_n(:,:,jk) * tmask(:,:,jk) 
     300         END DO 
     301         zhdiv(:,:) = zhdiv(:,:) / ( zht(:,:) + 1. - tmask(:,:,1) ) 
     302 
     303         ! 2 - Low frequency baroclinic horizontal divergence  (z-tilde case only) 
     304         ! -------------------------------------------------- 
     305         IF( ln_vvl_ztilde ) THEN 
     306            IF( kt .GT. nit000 ) THEN 
     307               DO jk = 1, jpkm1 
     308                  hdiv_lf(:,:,jk) = hdiv_lf(:,:,jk) - rdt * frq_rst_hdv(:,:)   & 
     309                     &          * ( hdiv_lf(:,:,jk) - fse3t_n(:,:,jk) * ( hdivn(:,:,jk) - zhdiv(:,:) ) ) 
     310               END DO 
     311            ENDIF 
     312         END IF 
     313 
     314         ! II - after z_tilde increments of vertical scale factors 
     315         ! ======================================================= 
     316         tilde_e3t_a(:,:,:) = 0.0_wp  ! tilde_e3t_a used to store tendency terms 
     317 
     318         ! 1 - High frequency divergence term 
     319         ! ---------------------------------- 
     320         IF( ln_vvl_ztilde ) THEN     ! z_tilde case 
     321            DO jk = 1, jpkm1 
     322               tilde_e3t_a(:,:,jk) = tilde_e3t_a(:,:,jk) - ( fse3t_n(:,:,jk) * ( hdivn(:,:,jk) - zhdiv(:,:) ) - hdiv_lf(:,:,jk) ) 
     323            END DO 
     324         ELSE                         ! layer case 
     325            DO jk = 1, jpkm1 
     326               tilde_e3t_a(:,:,jk) = tilde_e3t_a(:,:,jk) -   fse3t_n(:,:,jk) * ( hdivn(:,:,jk) - zhdiv(:,:) ) 
     327            END DO 
     328         END IF 
     329 
     330         ! 2 - Restoring term (z-tilde case only) 
     331         ! ------------------ 
     332         IF( ln_vvl_ztilde ) THEN 
     333            DO jk = 1, jpk 
     334               tilde_e3t_a(:,:,jk) = tilde_e3t_a(:,:,jk) - frq_rst_e3t(:,:) * tilde_e3t_b(:,:,jk) 
     335            END DO 
     336         END IF 
     337 
     338         ! 3 - Thickness diffusion term 
     339         ! ---------------------------- 
     340         zwu(:,:) = 0.0_wp 
     341         zwv(:,:) = 0.0_wp 
     342         ! a - first derivative: diffusive fluxes 
     343         DO jk = 1, jpkm1 
     344            DO jj = 1, jpjm1 
     345               DO ji = 1, fs_jpim1   ! vector opt. 
     346                  un_td(ji,jj,jk) = rn_ahe3 * umask(ji,jj,jk) * re2u_e1u(ji,jj) & 
     347                                  & * ( tilde_e3t_b(ji,jj,jk) - tilde_e3t_b(ji+1,jj  ,jk) ) 
     348                  vn_td(ji,jj,jk) = rn_ahe3 * vmask(ji,jj,jk) * re1v_e2v(ji,jj) &  
     349                                  & * ( tilde_e3t_b(ji,jj,jk) - tilde_e3t_b(ji  ,jj+1,jk) ) 
     350                  zwu(ji,jj) = zwu(ji,jj) + un_td(ji,jj,jk) 
     351                  zwv(ji,jj) = zwv(ji,jj) + vn_td(ji,jj,jk) 
     352               END DO 
     353            END DO 
     354         END DO 
     355         ! b - correction for last oceanic u-v points 
     356         DO jj = 1, jpj 
     357            DO ji = 1, jpi 
     358               un_td(ji,jj,mbku(ji,jj)) = un_td(ji,jj,mbku(ji,jj)) - zwu(ji,jj) 
     359               vn_td(ji,jj,mbkv(ji,jj)) = vn_td(ji,jj,mbkv(ji,jj)) - zwv(ji,jj) 
     360            END DO 
     361         END DO 
     362         ! c - second derivative: divergence of diffusive fluxes 
     363         DO jk = 1, jpkm1 
     364            DO jj = 2, jpjm1 
     365               DO ji = fs_2, fs_jpim1   ! vector opt. 
     366                  tilde_e3t_a(ji,jj,jk) = tilde_e3t_a(ji,jj,jk) + (   un_td(ji-1,jj  ,jk) - un_td(ji,jj,jk)    & 
     367                     &                                          +     vn_td(ji  ,jj-1,jk) - vn_td(ji,jj,jk)    & 
     368                     &                                            ) * r1_e12t(ji,jj) 
     369               END DO 
     370            END DO 
     371         END DO 
     372         ! d - thickness diffusion transport: boundary conditions 
     373         !     (stored for tracer advction and continuity equation) 
     374         CALL lbc_lnk( un_td , 'U' , -1.) 
     375         CALL lbc_lnk( vn_td , 'V' , -1.) 
     376 
     377         ! 4 - Time stepping of baroclinic scale factors 
     378         ! --------------------------------------------- 
     379         ! Leapfrog time stepping 
     380         ! ~~~~~~~~~~~~~~~~~~~~~~ 
     381         IF( neuler == 0 .AND. kt == nit000 ) THEN 
     382            z2dt =  rdt 
     383         ELSE 
     384            z2dt = 2.0_wp * rdt 
     385         ENDIF 
     386         CALL lbc_lnk( tilde_e3t_a(:,:,:), 'T', 1. ) 
     387         tilde_e3t_a(:,:,:) = tilde_e3t_b(:,:,:) + z2dt * tmask(:,:,:) * tilde_e3t_a(:,:,:) 
     388 
     389         ! Maximum deformation control 
     390         ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
     391         ze3t(:,:,jpk) = 0.0_wp 
     392         DO jk = 1, jpkm1 
     393            ze3t(:,:,jk) = tilde_e3t_a(:,:,jk) / e3t_0(:,:,jk) * tmask(:,:,jk) * tmask_i(:,:) 
     394         END DO 
     395         z_tmax = MAXVAL( ze3t(:,:,:) ) 
     396         IF( lk_mpp )   CALL mpp_max( z_tmax )                 ! max over the global domain 
     397         z_tmin = MINVAL( ze3t(:,:,:) ) 
     398         IF( lk_mpp )   CALL mpp_min( z_tmin )                 ! min over the global domain 
     399         ! - ML - test: for the moment, stop simulation for too large e3_t variations 
     400         IF( ( z_tmax .GT. rn_zdef_max ) .OR. ( z_tmin .LT. - rn_zdef_max ) ) THEN 
     401            IF( lk_mpp ) THEN 
     402               CALL mpp_maxloc( ze3t, tmask, z_tmax, ijk_max(1), ijk_max(2), ijk_max(3) ) 
     403               CALL mpp_minloc( ze3t, tmask, z_tmin, ijk_min(1), ijk_min(2), ijk_min(3) ) 
     404            ELSE 
     405               ijk_max = MAXLOC( ze3t(:,:,:) ) 
     406               ijk_max(1) = ijk_max(1) + nimpp - 1 
     407               ijk_max(2) = ijk_max(2) + njmpp - 1 
     408               ijk_min = MINLOC( ze3t(:,:,:) ) 
     409               ijk_min(1) = ijk_min(1) + nimpp - 1 
     410               ijk_min(2) = ijk_min(2) + njmpp - 1 
     411            ENDIF 
     412            IF (lwp) THEN 
     413               WRITE(numout, *) 'MAX( tilde_e3t_a(:,:,:) / e3t_0(:,:,:) ) =', z_tmax 
     414               WRITE(numout, *) 'at i, j, k=', ijk_max 
     415               WRITE(numout, *) 'MIN( tilde_e3t_a(:,:,:) / e3t_0(:,:,:) ) =', z_tmin 
     416               WRITE(numout, *) 'at i, j, k=', ijk_min             
     417               CALL ctl_warn('MAX( ABS( tilde_e3t_a(:,:,:) ) / e3t_0(:,:,:) ) too high') 
     418            ENDIF 
     419         ENDIF 
     420         ! - ML - end test 
     421         ! - ML - Imposing these limits will cause a baroclinicity error which is corrected for below 
     422         tilde_e3t_a(:,:,:) = MIN( tilde_e3t_a(:,:,:),   rn_zdef_max * e3t_0(:,:,:) ) 
     423         tilde_e3t_a(:,:,:) = MAX( tilde_e3t_a(:,:,:), - rn_zdef_max * e3t_0(:,:,:) ) 
     424 
     425         ! Add "tilda" part to the after scale factor 
     426         ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
     427         fse3t_a(:,:,:) = e3t_0(:,:,:) + tilde_e3t_a(:,:,:) 
     428 
     429         ! III - Barotropic repartition of the sea surface height over the baroclinic profile 
     430         ! ================================================================================== 
     431         ! add e3t(n-1) "star" Asselin-filtered 
     432         DO jk = 1, jpkm1 
     433            fse3t_a(:,:,jk) = fse3t_a(:,:,jk) + fse3t_b(:,:,jk) - e3t_0(:,:,jk) - tilde_e3t_b(:,:,jk) 
     434         END DO 
     435         ! add ( ssh increment + "baroclinicity error" ) proportionnaly to e3t(n) 
     436         ! - ML - baroclinicity error should be better treated in the future 
     437         !        i.e. locally and not spread over the water column. 
     438         !        (keep in mind that the idea is to reduce Eulerian velocity as much as possible) 
     439         zht(:,:) = 0. 
     440         DO jk = 1, jpkm1 
     441            zht(:,:)  = zht(:,:) + tilde_e3t_a(:,:,jk) * tmask(:,:,jk) 
     442         END DO 
     443         z_scale(:,:) = ( ssha(:,:) - sshb(:,:) - zht(:,:) ) / ( ht_0(:,:) + sshn(:,:) + 1. - tmask(:,:,1) ) 
     444         DO jk = 1, jpkm1 
     445            fse3t_a(:,:,jk) = fse3t_a(:,:,jk) + fse3t_n(:,:,jk) * z_scale(:,:) * tmask(:,:,jk) 
     446         END DO 
     447 
     448      ENDIF 
     449 
     450      IF( ln_vvl_dbg ) THEN   ! - ML - test: control prints for debuging 
     451         ! 
     452         IF( lwp ) WRITE(numout, *) 'kt =', kt 
     453         IF ( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN 
     454            z_tmax = MAXVAL( tmask(:,:,1) * tmask_i(:,:) * ABS( zht(:,:) ) ) 
     455            IF( lk_mpp ) CALL mpp_max( z_tmax )                             ! max over the global domain 
     456            IF( lwp    ) WRITE(numout, *) kt,' MAXVAL(abs(SUM(tilde_e3t_a))) =', z_tmax 
     457         END IF 
     458         ! 
     459         zht(:,:) = 0.0_wp 
     460         DO jk = 1, jpkm1 
     461            zht(:,:) = zht(:,:) + fse3t_n(:,:,jk) * tmask(:,:,jk) 
     462         END DO 
     463         z_tmax = MAXVAL( tmask(:,:,1) * tmask_i(:,:) * ABS( ht_0(:,:) + sshn(:,:) - zht(:,:) ) ) 
     464         IF( lk_mpp ) CALL mpp_max( z_tmax )                                ! max over the global domain 
     465         IF( lwp    ) WRITE(numout, *) kt,' MAXVAL(abs(ht_0+sshn-SUM(fse3t_n))) =', z_tmax 
     466         ! 
     467         zht(:,:) = 0.0_wp 
     468         DO jk = 1, jpkm1 
     469            zht(:,:) = zht(:,:) + fse3t_a(:,:,jk) * tmask(:,:,jk) 
     470         END DO 
     471         z_tmax = MAXVAL( tmask(:,:,1) * tmask_i(:,:) * ABS( ht_0(:,:) + ssha(:,:) - zht(:,:) ) ) 
     472         IF( lk_mpp ) CALL mpp_max( z_tmax )                                ! max over the global domain 
     473         IF( lwp    ) WRITE(numout, *) kt,' MAXVAL(abs(ht_0+ssha-SUM(fse3t_a))) =', z_tmax 
     474         ! 
     475         zht(:,:) = 0.0_wp 
     476         DO jk = 1, jpkm1 
     477            zht(:,:) = zht(:,:) + fse3t_b(:,:,jk) * tmask(:,:,jk) 
     478         END DO 
     479         z_tmax = MAXVAL( tmask(:,:,1) * tmask_i(:,:) * ABS( ht_0(:,:) + sshb(:,:) - zht(:,:) ) ) 
     480         IF( lk_mpp ) CALL mpp_max( z_tmax )                                ! max over the global domain 
     481         IF( lwp    ) WRITE(numout, *) kt,' MAXVAL(abs(ht_0+sshb-SUM(fse3t_b))) =', z_tmax 
     482         ! 
     483         z_tmax = MAXVAL( tmask(:,:,1) *  ABS( sshb(:,:) ) ) 
     484         IF( lk_mpp ) CALL mpp_max( z_tmax )                                ! max over the global domain 
     485         IF( lwp    ) WRITE(numout, *) kt,' MAXVAL(abs(sshb))) =', z_tmax 
     486         ! 
     487         z_tmax = MAXVAL( tmask(:,:,1) *  ABS( sshn(:,:) ) ) 
     488         IF( lk_mpp ) CALL mpp_max( z_tmax )                                ! max over the global domain 
     489         IF( lwp    ) WRITE(numout, *) kt,' MAXVAL(abs(sshn))) =', z_tmax 
     490         ! 
     491         z_tmax = MAXVAL( tmask(:,:,1) *  ABS( ssha(:,:) ) ) 
     492         IF( lk_mpp ) CALL mpp_max( z_tmax )                                ! max over the global domain 
     493         IF( lwp    ) WRITE(numout, *) kt,' MAXVAL(abs(ssha))) =', z_tmax 
     494      END IF 
     495 
     496      ! *********************************** ! 
     497      ! After scale factors at u- v- points ! 
     498      ! *********************************** ! 
     499 
     500      CALL dom_vvl_interpol( fse3t_a(:,:,:), fse3u_a(:,:,:), 'U' ) 
     501      CALL dom_vvl_interpol( fse3t_a(:,:,:), fse3v_a(:,:,:), 'V' ) 
     502 
     503      CALL wrk_dealloc( jpi, jpj, zht, z_scale, zwu, zwv, zhdiv ) 
     504      CALL wrk_dealloc( jpi, jpj, jpk, ze3t                     ) 
     505 
     506      IF( nn_timing == 1 )  CALL timing_start('dom_vvl_sf_nxt') 
     507 
     508   END SUBROUTINE dom_vvl_sf_nxt 
     509 
     510 
     511   SUBROUTINE dom_vvl_sf_swp( kt ) 
     512      !!---------------------------------------------------------------------- 
     513      !!                ***  ROUTINE dom_vvl_sf_swp  *** 
     514      !!                    
     515      !! ** Purpose :  compute time filter and swap of scale factors  
     516      !!               compute all depths and related variables for next time step 
     517      !!               write outputs and restart file 
     518      !! 
     519      !! ** Method  :  - swap of e3t with trick for volume/tracer conservation 
     520      !!               - reconstruct scale factor at other grid points (interpolate) 
     521      !!               - recompute depths and water height fields 
     522      !! 
     523      !! ** Action  :  - fse3t_(b/n), tilde_e3t_(b/n) and fse3(u/v)_n ready for next time step 
     524      !!               - Recompute: 
     525      !!                    fse3(u/v)_b        
     526      !!                    fse3w_n            
     527      !!                    fse3(u/v)w_b       
     528      !!                    fse3(u/v)w_n       
     529      !!                    fsdept_n, fsdepw_n  and fsde3w_n 
     530      !!                    h(u/v) and h(u/v)r 
     531      !! 
     532      !! Reference  : Leclair, M., and G. Madec, 2009, Ocean Modelling. 
     533      !!              Leclair, M., and G. Madec, 2011, Ocean Modelling. 
     534      !!---------------------------------------------------------------------- 
     535      !! * Arguments 
     536      INTEGER, INTENT( in )               :: kt       ! time step 
     537      !! * Local declarations 
     538      REAL(wp), POINTER, DIMENSION(:,:,:) :: z_e3t_def 
     539      INTEGER                             :: jk       ! dummy loop indices 
     540      !!---------------------------------------------------------------------- 
     541 
     542      IF( nn_timing == 1 )  CALL timing_start('dom_vvl_sf_swp') 
    51543      ! 
    52       ALLOCATE( mut (jpi,jpj,jpk) , muu (jpi,jpj,jpk) , muv (jpi,jpj,jpk) , muf (jpi,jpj,jpk) ,     & 
    53          &      r2dt        (jpk)                                                             , STAT=dom_vvl_alloc ) 
    54          ! 
    55       IF( lk_mpp             )   CALL mpp_sum ( dom_vvl_alloc ) 
    56       IF( dom_vvl_alloc /= 0 )   CALL ctl_warn('dom_vvl_alloc: failed to allocate arrays') 
     544      CALL wrk_alloc( jpi, jpj, jpk, z_e3t_def                ) 
    57545      ! 
    58    END FUNCTION dom_vvl_alloc 
    59  
    60  
    61    SUBROUTINE dom_vvl 
    62       !!---------------------------------------------------------------------- 
    63       !!                ***  ROUTINE dom_vvl  *** 
    64       !!                    
    65       !! ** Purpose :   compute mu coefficients at t-, u-, v- and f-points to  
    66       !!              spread ssh over the whole water column (scale factors) 
    67       !!                set the before and now ssh at u- and v-points  
    68       !!              (also f-point in now case) 
    69       !!---------------------------------------------------------------------- 
     546      IF( kt == nit000 )   THEN 
     547         IF(lwp) WRITE(numout,*) 
     548         IF(lwp) WRITE(numout,*) 'dom_vvl_sf_swp : - time filter and swap of scale factors' 
     549         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~   - interpolate scale factors and compute depths for next time step' 
     550      ENDIF 
    70551      ! 
    71       INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    72       REAL(wp) ::   zcoefu, zcoefv , zcoeff                ! local scalars 
    73       REAL(wp) ::   zvt   , zvt_ip1, zvt_jp1, zvt_ip1jp1   !   -      - 
    74       REAL(wp), POINTER, DIMENSION(:,:) ::  zee_t, zee_u, zee_v, zee_f   ! 2D workspace 
    75       !!---------------------------------------------------------------------- 
     552      ! Time filter and swap of scale factors 
     553      ! ===================================== 
     554      ! - ML - fse3(t/u/v)_b are allready computed in dynnxt. 
     555      IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN 
     556         IF( neuler == 0 .AND. kt == nit000 ) THEN 
     557            tilde_e3t_b(:,:,:) = tilde_e3t_n(:,:,:) 
     558         ELSE 
     559            tilde_e3t_b(:,:,:) = tilde_e3t_n(:,:,:) &  
     560            &         + atfp * ( tilde_e3t_b(:,:,:) - 2.0_wp * tilde_e3t_n(:,:,:) + tilde_e3t_a(:,:,:) ) 
     561         ENDIF 
     562         tilde_e3t_n(:,:,:) = tilde_e3t_a(:,:,:) 
     563      ENDIF 
     564      fse3t_n(:,:,:) = fse3t_a(:,:,:) 
     565      fse3u_n(:,:,:) = fse3u_a(:,:,:) 
     566      fse3v_n(:,:,:) = fse3v_a(:,:,:) 
     567 
     568      ! Compute all missing vertical scale factor and depths 
     569      ! ==================================================== 
     570      ! Horizontal scale factor interpolations 
     571      ! -------------------------------------- 
     572      ! - ML - fse3u_b and fse3v_b are allready computed in dynnxt 
     573      CALL dom_vvl_interpol( fse3u_n(:,:,:), fse3f_n (:,:,:), 'F'  ) 
     574      ! Vertical scale factor interpolations 
     575      ! ------------------------------------ 
     576      CALL dom_vvl_interpol( fse3t_n(:,:,:), fse3w_n (:,:,:), 'W'  ) 
     577      CALL dom_vvl_interpol( fse3u_n(:,:,:), fse3uw_n(:,:,:), 'UW' ) 
     578      CALL dom_vvl_interpol( fse3v_n(:,:,:), fse3vw_n(:,:,:), 'VW' ) 
     579      CALL dom_vvl_interpol( fse3u_b(:,:,:), fse3uw_b(:,:,:), 'UW' ) 
     580      CALL dom_vvl_interpol( fse3v_b(:,:,:), fse3vw_b(:,:,:), 'VW' ) 
     581      ! t- and w- points depth 
     582      ! ---------------------- 
     583      fsdept_n(:,:,1) = 0.5_wp * fse3w_n(:,:,1) 
     584      fsdepw_n(:,:,1) = 0.0_wp 
     585      fsde3w_n(:,:,1) = fsdept_n(:,:,1) - sshn(:,:) 
     586      DO jk = 2, jpk 
     587         fsdept_n(:,:,jk) = fsdept_n(:,:,jk-1) + fse3w_n(:,:,jk) 
     588         fsdepw_n(:,:,jk) = fsdepw_n(:,:,jk-1) + fse3t_n(:,:,jk-1) 
     589         fsde3w_n(:,:,jk) = fsdept_n(:,:,jk  ) - sshn   (:,:) 
     590      END DO 
     591      ! Local depth and Inverse of the local depth of the water column at u- and v- points 
     592      ! ---------------------------------------------------------------------------------- 
     593      hu(:,:) = 0. 
     594      hv(:,:) = 0. 
     595      DO jk = 1, jpk 
     596         hu(:,:) = hu(:,:) + fse3u_n(:,:,jk) * umask(:,:,jk) 
     597         hv(:,:) = hv(:,:) + fse3v_n(:,:,jk) * vmask(:,:,jk) 
     598      END DO 
     599      ! Inverse of the local depth 
     600      hur(:,:) = umask(:,:,1) / ( hu(:,:) + 1. - umask(:,:,1) ) 
     601      hvr(:,:) = vmask(:,:,1) / ( hv(:,:) + 1. - vmask(:,:,1) ) 
     602 
     603      ! Write outputs 
     604      ! ============= 
     605      z_e3t_def(:,:,:) = ( ( fse3t_n(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 
     606      CALL iom_put( "e3t_n"  , fse3t_n  (:,:,:) ) 
     607      CALL iom_put( "dept_n" , fsde3w_n (:,:,:) ) 
     608      CALL iom_put( "e3tdef" , z_e3t_def(:,:,:) ) 
     609 
     610      ! write restart file 
     611      ! ================== 
     612      IF( lrst_oce ) CALL dom_vvl_rst( kt, 'WRITE' ) 
    76613      ! 
    77       IF( nn_timing == 1 )  CALL timing_start('dom_vvl') 
     614      CALL wrk_dealloc( jpi, jpj, jpk, z_e3t_def ) 
    78615      ! 
    79       CALL wrk_alloc( jpi, jpj, zee_t, zee_u, zee_v, zee_f ) 
     616      IF( nn_timing == 1 )  CALL timing_stop('dom_vvl_sf_swp') 
     617 
     618   END SUBROUTINE dom_vvl_sf_swp 
     619 
     620 
     621   SUBROUTINE dom_vvl_interpol( pe3_in, pe3_out, pout ) 
     622      !!--------------------------------------------------------------------- 
     623      !!                  ***  ROUTINE dom_vvl__interpol  *** 
     624      !! 
     625      !! ** Purpose :   interpolate scale factors from one grid point to another 
     626      !! 
     627      !! ** Method  :   e3_out = e3_0 + interpolation(e3_in - e3_0) 
     628      !!                - horizontal interpolation: grid cell surface averaging 
     629      !!                - vertical interpolation: simple averaging 
     630      !!---------------------------------------------------------------------- 
     631      !! * Arguments 
     632      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( in    ) ::  pe3_in     ! input e3 to be interpolated 
     633      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( inout ) ::  pe3_out    ! output interpolated e3 
     634      CHARACTER(LEN=*), INTENT( in )                    ::  pout       ! grid point of out scale factors 
     635      !                                                                !   =  'U', 'V', 'W, 'F', 'UW' or 'VW' 
     636      !! * Local declarations 
     637      INTEGER ::   ji, jj, jk                                          ! dummy loop indices 
     638      LOGICAL ::   l_is_orca                                           ! local logical 
     639      !!---------------------------------------------------------------------- 
     640      IF( nn_timing == 1 )  CALL timing_start('dom_vvl_interpol') 
     641         ! 
     642      l_is_orca = .FALSE. 
     643      IF( cp_cfg == "orca" .AND. jp_cfg == 2 ) l_is_orca = .TRUE.      ! ORCA R2 configuration - will need to correct some locations 
     644 
     645      SELECT CASE ( pout ) 
     646         !               ! ------------------------------------- ! 
     647      CASE( 'U' )        ! interpolation from T-point to U-point ! 
     648         !               ! ------------------------------------- ! 
     649         ! horizontal surface weighted interpolation 
     650         DO jk = 1, jpk 
     651            DO jj = 1, jpjm1 
     652               DO ji = 1, fs_jpim1   ! vector opt. 
     653                  pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk) * r1_e12u(ji,jj)                                   & 
     654                     &                       * (   e12t(ji  ,jj) * ( pe3_in(ji  ,jj,jk) - e3t_0(ji  ,jj,jk) )     & 
     655                     &                           + e12t(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3t_0(ji+1,jj,jk) ) ) 
     656               END DO 
     657            END DO 
     658         END DO 
     659         ! 
     660         IF( l_is_orca ) CALL dom_vvl_orca_fix( pe3_in, pe3_out, pout ) 
     661         ! boundary conditions 
     662         CALL lbc_lnk( pe3_out(:,:,:), 'U', 1. ) 
     663         pe3_out(:,:,:) = pe3_out(:,:,:) + e3u_0(:,:,:) 
     664         !               ! ------------------------------------- ! 
     665      CASE( 'V' )        ! interpolation from T-point to V-point ! 
     666         !               ! ------------------------------------- ! 
     667         ! horizontal surface weighted interpolation 
     668         DO jk = 1, jpk 
     669            DO jj = 1, jpjm1 
     670               DO ji = 1, fs_jpim1   ! vector opt. 
     671                  pe3_out(ji,jj,jk) = 0.5_wp * vmask(ji,jj,jk) * r1_e12v(ji,jj)                                   & 
     672                     &                       * (   e12t(ji,jj  ) * ( pe3_in(ji,jj  ,jk) - e3t_0(ji,jj  ,jk) )     & 
     673                     &                           + e12t(ji,jj+1) * ( pe3_in(ji,jj+1,jk) - e3t_0(ji,jj+1,jk) ) ) 
     674               END DO 
     675            END DO 
     676         END DO 
     677         ! 
     678         IF( l_is_orca ) CALL dom_vvl_orca_fix( pe3_in, pe3_out, pout ) 
     679         ! boundary conditions 
     680         CALL lbc_lnk( pe3_out(:,:,:), 'V', 1. ) 
     681         pe3_out(:,:,:) = pe3_out(:,:,:) + e3v_0(:,:,:) 
     682         !               ! ------------------------------------- ! 
     683      CASE( 'F' )        ! interpolation from U-point to F-point ! 
     684         !               ! ------------------------------------- ! 
     685         ! horizontal surface weighted interpolation 
     686         DO jk = 1, jpk 
     687            DO jj = 1, jpjm1 
     688               DO ji = 1, fs_jpim1   ! vector opt. 
     689                  pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk) * umask(ji,jj+1,jk) * r1_e12f(ji,jj)               & 
     690                     &                       * (   e12u(ji,jj  ) * ( pe3_in(ji,jj  ,jk) - e3u_0(ji,jj  ,jk) )     & 
     691                     &                           + e12u(ji,jj+1) * ( pe3_in(ji,jj+1,jk) - e3u_0(ji,jj+1,jk) ) ) 
     692               END DO 
     693            END DO 
     694         END DO 
     695         ! 
     696         IF( l_is_orca ) CALL dom_vvl_orca_fix( pe3_in, pe3_out, pout ) 
     697         ! boundary conditions 
     698         CALL lbc_lnk( pe3_out(:,:,:), 'F', 1. ) 
     699         pe3_out(:,:,:) = pe3_out(:,:,:) + e3f_0(:,:,:) 
     700         !               ! ------------------------------------- ! 
     701      CASE( 'W' )        ! interpolation from T-point to W-point ! 
     702         !               ! ------------------------------------- ! 
     703         ! vertical simple interpolation 
     704         pe3_out(:,:,1) = e3w_0(:,:,1) + pe3_in(:,:,1) - e3t_0(:,:,1) 
     705         ! - ML - The use of mask in this formaula enables the special treatment of the last w- point without indirect adressing 
     706         DO jk = 2, jpk 
     707            pe3_out(:,:,jk) = e3w_0(:,:,jk) + ( 1.0_wp - 0.5_wp * tmask(:,:,jk) ) * ( pe3_in(:,:,jk-1) - e3t_0(:,:,jk-1) )   & 
     708               &                            +            0.5_wp * tmask(:,:,jk)   * ( pe3_in(:,:,jk  ) - e3t_0(:,:,jk  ) ) 
     709         END DO 
     710         !               ! -------------------------------------- ! 
     711      CASE( 'UW' )       ! interpolation from U-point to UW-point ! 
     712         !               ! -------------------------------------- ! 
     713         ! vertical simple interpolation 
     714         pe3_out(:,:,1) = e3uw_0(:,:,1) + pe3_in(:,:,1) - e3u_0(:,:,1) 
     715         ! - ML - The use of mask in this formaula enables the special treatment of the last w- point without indirect adressing 
     716         DO jk = 2, jpk 
     717            pe3_out(:,:,jk) = e3uw_0(:,:,jk) + ( 1.0_wp - 0.5_wp * umask(:,:,jk) ) * ( pe3_in(:,:,jk-1) - e3u_0(:,:,jk-1) )   & 
     718               &                             +            0.5_wp * umask(:,:,jk)   * ( pe3_in(:,:,jk  ) - e3u_0(:,:,jk  ) ) 
     719         END DO 
     720         !               ! -------------------------------------- ! 
     721      CASE( 'VW' )       ! interpolation from V-point to VW-point ! 
     722         !               ! -------------------------------------- ! 
     723         ! vertical simple interpolation 
     724         pe3_out(:,:,1) = e3vw_0(:,:,1) + pe3_in(:,:,1) - e3v_0(:,:,1) 
     725         ! - ML - The use of mask in this formaula enables the special treatment of the last w- point without indirect adressing 
     726         DO jk = 2, jpk 
     727            pe3_out(:,:,jk) = e3vw_0(:,:,jk) + ( 1.0_wp - 0.5_wp * vmask(:,:,jk) ) * ( pe3_in(:,:,jk-1) - e3v_0(:,:,jk-1) )   & 
     728               &                             +            0.5_wp * vmask(:,:,jk)   * ( pe3_in(:,:,jk  ) - e3v_0(:,:,jk  ) ) 
     729         END DO 
     730      END SELECT 
    80731      ! 
    81       IF(lwp) THEN 
     732 
     733      IF( nn_timing == 1 )  CALL timing_stop('dom_vvl_interpol') 
     734 
     735   END SUBROUTINE dom_vvl_interpol 
     736 
     737   SUBROUTINE dom_vvl_rst( kt, cdrw ) 
     738      !!--------------------------------------------------------------------- 
     739      !!                   ***  ROUTINE dom_vvl_rst  *** 
     740      !!                      
     741      !! ** Purpose :   Read or write VVL file in restart file 
     742      !! 
     743      !! ** Method  :   use of IOM library 
     744      !!                if the restart does not contain vertical scale factors, 
     745      !!                they are set to the _0 values 
     746      !!                if the restart does not contain vertical scale factors increments (z_tilde), 
     747      !!                they are set to 0. 
     748      !!---------------------------------------------------------------------- 
     749      !! * Arguments 
     750      INTEGER         , INTENT(in) ::   kt     ! ocean time-step 
     751      CHARACTER(len=*), INTENT(in) ::   cdrw   ! "READ"/"WRITE" flag 
     752      !! * Local declarations 
     753      INTEGER ::   id1, id2, id3, id4, id5     ! local integers 
     754      !!---------------------------------------------------------------------- 
     755      ! 
     756      IF( nn_timing == 1 )  CALL timing_start('dom_vvl_rst') 
     757      IF( TRIM(cdrw) == 'READ' ) THEN        ! Read/initialise  
     758         !                                   ! =============== 
     759         IF( ln_rstart ) THEN                   !* Read the restart file 
     760            CALL rst_read_open                  !  open the restart file if necessary 
     761            id1 = iom_varid( numror, 'fse3t_b', ldstop = .FALSE. ) 
     762            id2 = iom_varid( numror, 'fse3t_n', ldstop = .FALSE. ) 
     763            id3 = iom_varid( numror, 'tilde_e3t_b', ldstop = .FALSE. ) 
     764            id4 = iom_varid( numror, 'tilde_e3t_n', ldstop = .FALSE. ) 
     765            id5 = iom_varid( numror, 'hdif_lf', ldstop = .FALSE. ) 
     766            !                             ! --------- ! 
     767            !                             ! all cases ! 
     768            !                             ! --------- ! 
     769            IF( MIN( id1, id2 ) > 0 ) THEN       ! all required arrays exist 
     770               CALL iom_get( numror, jpdom_autoglo, 'fse3t_b', fse3t_b(:,:,:) ) 
     771               CALL iom_get( numror, jpdom_autoglo, 'fse3t_n', fse3t_n(:,:,:) ) 
     772               IF( neuler == 0 ) THEN 
     773                  fse3t_b(:,:,:) = fse3t_n(:,:,:) 
     774               ENDIF 
     775            ELSE IF( id1 > 0 ) THEN 
     776               IF(lwp) write(numout,*) 'dom_vvl_rst WARNING : fse3t_n not found in restart files' 
     777               IF(lwp) write(numout,*) 'fse3t_n set equal to fse3t_b.' 
     778               fse3t_b(:,:,:) = fse3t_n(:,:,:) 
     779            ELSE                                 ! one at least array is missing 
     780               CALL ctl_stop( 'dom_vvl_rst: vvl cannot restart from a non vvl run' ) 
     781            ENDIF 
     782            !                             ! ----------- ! 
     783            IF( ln_vvl_zstar ) THEN       ! z_star case ! 
     784               !                          ! ----------- ! 
     785               IF( MIN( id3, id4 ) > 0 ) THEN 
     786                  CALL ctl_stop( 'dom_vvl_rst: z_star cannot restart from a z_tilde or layer run' ) 
     787               ENDIF 
     788               !                          ! ----------------------- ! 
     789            ELSE                          ! z_tilde and layer cases ! 
     790               !                          ! ----------------------- ! 
     791               IF( MIN( id3, id4 ) > 0 ) THEN  ! all required arrays exist 
     792                  CALL iom_get( numror, jpdom_autoglo, 'tilde_e3t_b', tilde_e3t_b(:,:,:) ) 
     793                  CALL iom_get( numror, jpdom_autoglo, 'tilde_e3t_n', tilde_e3t_n(:,:,:) ) 
     794               ELSE                            ! one at least array is missing 
     795                  tilde_e3t_b(:,:,:) = 0.0_wp 
     796                  tilde_e3t_n(:,:,:) = 0.0_wp 
     797               ENDIF 
     798               !                          ! ------------ ! 
     799               IF( ln_vvl_ztilde ) THEN   ! z_tilde case ! 
     800                  !                       ! ------------ ! 
     801                  IF( id5 > 0 ) THEN  ! required array exists 
     802                     CALL iom_get( numror, jpdom_autoglo, 'hdiv_lf', hdiv_lf(:,:,:) ) 
     803                  ELSE                ! array is missing 
     804                     hdiv_lf(:,:,:) = 0.0_wp 
     805                  ENDIF 
     806               ENDIF 
     807            ENDIF 
     808            ! 
     809         ELSE                                   !* Initialize at "rest" 
     810            fse3t_b(:,:,:) = e3t_0(:,:,:) 
     811            fse3t_n(:,:,:) = e3t_0(:,:,:) 
     812            IF( ln_vvl_ztilde .OR. ln_vvl_layer) THEN 
     813               tilde_e3t_b(:,:,:) = 0.0_wp 
     814               tilde_e3t_n(:,:,:) = 0.0_wp 
     815               IF( ln_vvl_ztilde ) hdiv_lf(:,:,:) = 0.0_wp 
     816            END IF 
     817         ENDIF 
     818 
     819      ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN   ! Create restart file 
     820         !                                   ! =================== 
     821         IF(lwp) WRITE(numout,*) '---- dom_vvl_rst ----' 
     822         !                                           ! --------- ! 
     823         !                                           ! all cases ! 
     824         !                                           ! --------- ! 
     825         CALL iom_rstput( kt, nitrst, numrow, 'fse3t_b', fse3t_b(:,:,:) ) 
     826         CALL iom_rstput( kt, nitrst, numrow, 'fse3t_n', fse3t_n(:,:,:) ) 
     827         !                                           ! ----------------------- ! 
     828         IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN  ! z_tilde and layer cases ! 
     829            !                                        ! ----------------------- ! 
     830            CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_b', tilde_e3t_b(:,:,:) ) 
     831            CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_n', tilde_e3t_n(:,:,:) ) 
     832         END IF 
     833         !                                           ! -------------!     
     834         IF( ln_vvl_ztilde ) THEN                    ! z_tilde case ! 
     835            !                                        ! ------------ ! 
     836            CALL iom_rstput( kt, nitrst, numrow, 'hdiv_lf', hdiv_lf(:,:,:) ) 
     837         ENDIF 
     838 
     839      ENDIF 
     840      IF( nn_timing == 1 )  CALL timing_stop('dom_vvl_rst') 
     841 
     842   END SUBROUTINE dom_vvl_rst 
     843 
     844 
     845   SUBROUTINE dom_vvl_ctl 
     846      !!--------------------------------------------------------------------- 
     847      !!                  ***  ROUTINE dom_vvl_ctl  *** 
     848      !!                 
     849      !! ** Purpose :   Control the consistency between namelist options 
     850      !!                for vertical coordinate 
     851      !!---------------------------------------------------------------------- 
     852      INTEGER ::   ioptio 
     853 
     854      NAMELIST/nam_vvl/ ln_vvl_zstar, ln_vvl_ztilde, ln_vvl_layer, ln_vvl_ztilde_as_zstar, & 
     855                      & ln_vvl_zstar_at_eqtor      , rn_ahe3     , rn_rst_e3t            , & 
     856                      & rn_lf_cutoff               , rn_zdef_max , ln_vvl_dbg                ! not yet implemented: ln_vvl_kepe 
     857      !!----------------------------------------------------------------------  
     858 
     859      REWIND ( numnam )               ! Read Namelist nam_vvl : vertical coordinate 
     860      READ   ( numnam, nam_vvl ) 
     861 
     862      IF(lwp) THEN                    ! Namelist print 
    82863         WRITE(numout,*) 
    83          WRITE(numout,*) 'dom_vvl : Variable volume initialization' 
    84          WRITE(numout,*) '~~~~~~~~  compute coef. used to spread ssh over each layers' 
     864         WRITE(numout,*) 'dom_vvl_ctl : choice/control of the variable vertical coordinate' 
     865         WRITE(numout,*) '~~~~~~~~~~~' 
     866         WRITE(numout,*) '           Namelist nam_vvl : chose a vertical coordinate' 
     867         WRITE(numout,*) '              zstar                      ln_vvl_zstar   = ', ln_vvl_zstar 
     868         WRITE(numout,*) '              ztilde                     ln_vvl_ztilde  = ', ln_vvl_ztilde 
     869         WRITE(numout,*) '              layer                      ln_vvl_layer   = ', ln_vvl_layer 
     870         WRITE(numout,*) '              ztilde as zstar   ln_vvl_ztilde_as_zstar  = ', ln_vvl_ztilde_as_zstar 
     871         WRITE(numout,*) '      ztilde near the equator    ln_vvl_zstar_at_eqtor  = ', ln_vvl_zstar_at_eqtor 
     872         ! WRITE(numout,*) '           Namelist nam_vvl : chose kinetic-to-potential energy conservation' 
     873         ! WRITE(numout,*) '                                         ln_vvl_kepe    = ', ln_vvl_kepe 
     874         WRITE(numout,*) '           Namelist nam_vvl : thickness diffusion coefficient' 
     875         WRITE(numout,*) '                                         rn_ahe3        = ', rn_ahe3 
     876         WRITE(numout,*) '           Namelist nam_vvl : maximum e3t deformation fractional change' 
     877         WRITE(numout,*) '                                         rn_zdef_max    = ', rn_zdef_max 
     878         IF( ln_vvl_ztilde_as_zstar ) THEN 
     879            WRITE(numout,*) '           ztilde running in zstar emulation mode; ' 
     880            WRITE(numout,*) '           ignoring namelist timescale parameters and using:' 
     881            WRITE(numout,*) '                 hard-wired : z-tilde to zstar restoration timescale (days)' 
     882            WRITE(numout,*) '                                         rn_rst_e3t     =    0.0' 
     883            WRITE(numout,*) '                 hard-wired : z-tilde cutoff frequency of low-pass filter (days)' 
     884            WRITE(numout,*) '                                         rn_lf_cutoff   =    1.0/rdt' 
     885         ELSE 
     886            WRITE(numout,*) '           Namelist nam_vvl : z-tilde to zstar restoration timescale (days)' 
     887            WRITE(numout,*) '                                         rn_rst_e3t     = ', rn_rst_e3t 
     888            WRITE(numout,*) '           Namelist nam_vvl : z-tilde cutoff frequency of low-pass filter (days)' 
     889            WRITE(numout,*) '                                         rn_lf_cutoff   = ', rn_lf_cutoff 
     890         ENDIF 
     891         WRITE(numout,*) '           Namelist nam_vvl : debug prints' 
     892         WRITE(numout,*) '                                         ln_vvl_dbg     = ', ln_vvl_dbg 
    85893      ENDIF 
    86        
    87       IF( dom_vvl_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'dom_vvl : unable to allocate arrays' ) 
    88  
    89       fsdept(:,:,:) = gdept (:,:,:) 
    90       fsdepw(:,:,:) = gdepw (:,:,:) 
    91       fsde3w(:,:,:) = gdep3w(:,:,:) 
    92       fse3t (:,:,:) = e3t   (:,:,:) 
    93       fse3u (:,:,:) = e3u   (:,:,:) 
    94       fse3v (:,:,:) = e3v   (:,:,:) 
    95       fse3f (:,:,:) = e3f   (:,:,:) 
    96       fse3w (:,:,:) = e3w   (:,:,:) 
    97       fse3uw(:,:,:) = e3uw  (:,:,:) 
    98       fse3vw(:,:,:) = e3vw  (:,:,:) 
    99  
    100       !                                 !==  mu computation  ==! 
    101       zee_t(:,:) = fse3t_0(:,:,1)                ! Lower bound : thickness of the first model level 
    102       zee_u(:,:) = fse3u_0(:,:,1) 
    103       zee_v(:,:) = fse3v_0(:,:,1) 
    104       zee_f(:,:) = fse3f_0(:,:,1) 
    105       DO jk = 2, jpkm1                          ! Sum of the masked vertical scale factors 
    106          zee_t(:,:) = zee_t(:,:) + fse3t_0(:,:,jk) * tmask(:,:,jk) 
    107          zee_u(:,:) = zee_u(:,:) + fse3u_0(:,:,jk) * umask(:,:,jk) 
    108          zee_v(:,:) = zee_v(:,:) + fse3v_0(:,:,jk) * vmask(:,:,jk) 
    109          DO jj = 1, jpjm1                      ! f-point : fmask=shlat at coasts, use the product of umask 
    110             zee_f(:,jj) = zee_f(:,jj) + fse3f_0(:,jj,jk) *  umask(:,jj,jk) * umask(:,jj+1,jk) 
    111          END DO 
    112       END DO   
    113       !                                         ! Compute and mask the inverse of the local depth at T, U, V and F points 
    114       zee_t(:,:) = 1._wp / zee_t(:,:) * tmask(:,:,1) 
    115       zee_u(:,:) = 1._wp / zee_u(:,:) * umask(:,:,1) 
    116       zee_v(:,:) = 1._wp / zee_v(:,:) * vmask(:,:,1) 
    117       DO jj = 1, jpjm1                               ! f-point case fmask cannot be used  
    118          zee_f(:,jj) = 1._wp / zee_f(:,jj) * umask(:,jj,1) * umask(:,jj+1,1) 
    119       END DO 
    120       CALL lbc_lnk( zee_f, 'F', 1. )                 ! lateral boundary condition on ee_f 
    121       ! 
    122       DO jk = 1, jpk                            ! mu coefficients 
    123          mut(:,:,jk) = zee_t(:,:) * tmask(:,:,jk)     ! T-point at T levels 
    124          muu(:,:,jk) = zee_u(:,:) * umask(:,:,jk)     ! U-point at T levels 
    125          muv(:,:,jk) = zee_v(:,:) * vmask(:,:,jk)     ! V-point at T levels 
    126       END DO 
    127       DO jk = 1, jpk                                 ! F-point : fmask=shlat at coasts, use the product of umask 
    128          DO jj = 1, jpjm1 
    129                muf(:,jj,jk) = zee_f(:,jj) * umask(:,jj,jk) * umask(:,jj+1,jk)   ! at T levels 
    130          END DO 
    131          muf(:,jpj,jk) = 0._wp 
    132       END DO 
    133       CALL lbc_lnk( muf, 'F', 1. )                   ! lateral boundary condition 
    134  
    135  
    136       hu_0(:,:) = 0.e0                          ! Reference ocean depth at U- and V-points 
    137       hv_0(:,:) = 0.e0 
    138       DO jk = 1, jpk 
    139          hu_0(:,:) = hu_0(:,:) + fse3u_0(:,:,jk) * umask(:,:,jk) 
    140          hv_0(:,:) = hv_0(:,:) + fse3v_0(:,:,jk) * vmask(:,:,jk) 
    141       END DO 
    142        
    143       DO jj = 1, jpjm1                          ! initialise before and now Sea Surface Height at u-, v-, f-points 
    144          DO ji = 1, jpim1   ! NO vector opt. 
    145             zcoefu = 0.50_wp / ( e1u(ji,jj) * e2u(ji,jj) ) * umask(ji,jj,1) 
    146             zcoefv = 0.50_wp / ( e1v(ji,jj) * e2v(ji,jj) ) * vmask(ji,jj,1) 
    147             zcoeff = 0.25_wp / ( e1f(ji,jj) * e2f(ji,jj) ) * umask(ji,jj,1) * umask(ji,jj+1,1) 
    148             ! 
    149             zvt           = e1e2t(ji  ,jj  ) * sshb(ji  ,jj  )    ! before fields 
    150             zvt_ip1       = e1e2t(ji+1,jj  ) * sshb(ji+1,jj  ) 
    151             zvt_jp1       = e1e2t(ji  ,jj+1) * sshb(ji  ,jj+1) 
    152             sshu_b(ji,jj) = zcoefu * ( zvt + zvt_ip1 ) 
    153             sshv_b(ji,jj) = zcoefv * ( zvt + zvt_jp1 ) 
    154             ! 
    155             zvt           = e1e2t(ji  ,jj  ) * sshn(ji  ,jj  )    ! now fields 
    156             zvt_ip1       = e1e2t(ji+1,jj  ) * sshn(ji+1,jj  ) 
    157             zvt_jp1       = e1e2t(ji  ,jj+1) * sshn(ji  ,jj+1) 
    158             zvt_ip1jp1    = e1e2t(ji+1,jj+1) * sshn(ji+1,jj+1) 
    159             sshu_n(ji,jj) = zcoefu * ( zvt + zvt_ip1 ) 
    160             sshv_n(ji,jj) = zcoefv * ( zvt + zvt_jp1 ) 
    161             sshf_n(ji,jj) = zcoeff * ( zvt + zvt_ip1 + zvt_jp1 + zvt_ip1jp1 ) 
    162          END DO 
    163       END DO 
    164       CALL lbc_lnk( sshu_n, 'U', 1. )   ;   CALL lbc_lnk( sshu_b, 'U', 1. )      ! lateral boundary conditions 
    165       CALL lbc_lnk( sshv_n, 'V', 1. )   ;   CALL lbc_lnk( sshv_b, 'V', 1. ) 
    166       CALL lbc_lnk( sshf_n, 'F', 1. ) 
    167       ! 
    168       CALL wrk_dealloc( jpi, jpj, zee_t, zee_u, zee_v, zee_f ) 
    169       ! 
    170       IF( nn_timing == 1 )  CALL timing_stop('dom_vvl') 
    171       ! 
    172    END SUBROUTINE dom_vvl 
    173  
    174  
    175    SUBROUTINE dom_vvl_2( kt, pe3u_b, pe3v_b ) 
    176       !!---------------------------------------------------------------------- 
    177       !!                ***  ROUTINE dom_vvl_2  *** 
    178       !!                    
    179       !! ** Purpose :   compute the vertical scale factors at u- and v-points 
    180       !!              in variable volume case. 
    181       !! 
    182       !! ** Method  :   In variable volume case (non linear sea surface) the  
    183       !!              the vertical scale factor at velocity points is computed 
    184       !!              as the average of the cell surface weighted e3t. 
    185       !!                It uses the sea surface heigth so it have to be initialized 
    186       !!              after ssh is read/set 
    187       !!---------------------------------------------------------------------- 
    188       INTEGER                   , INTENT(in   ) ::   kt               ! ocean time-step index 
    189       REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pe3u_b, pe3v_b   ! before vertical scale factor at u- & v-pts 
    190       ! 
    191       INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    192       INTEGER  ::   iku, ikv     ! local integers     
    193       INTEGER  ::   ii0, ii1, ij0, ij1   ! temporary integers 
    194       REAL(wp) ::   zvt, zvtip1, zvtjp1  ! local scalars 
    195       !!---------------------------------------------------------------------- 
    196       ! 
    197       IF( nn_timing == 1 )  CALL timing_start('dom_vvl_2') 
    198       ! 
    199       IF( lwp .AND. kt == nit000 ) THEN 
     894 
     895      ioptio = 0                      ! Parameter control 
     896      IF( ln_vvl_ztilde_as_zstar ) ln_vvl_ztilde = .true. 
     897      IF( ln_vvl_zstar           )        ioptio = ioptio + 1 
     898      IF( ln_vvl_ztilde          )        ioptio = ioptio + 1 
     899      IF( ln_vvl_layer           )        ioptio = ioptio + 1 
     900 
     901      IF( ioptio /= 1 )   CALL ctl_stop( 'Choose ONE vertical coordinate in namelist nam_vvl' ) 
     902 
     903      IF(lwp) THEN                   ! Print the choice 
    200904         WRITE(numout,*) 
    201          WRITE(numout,*) 'dom_vvl_2 : Variable volume, fse3t_b initialization' 
    202          WRITE(numout,*) '~~~~~~~~~ ' 
    203          pe3u_b(:,:,jpk) = fse3u_0(:,:,jpk) 
    204          pe3v_b(:,:,jpk) = fse3v_0(:,:,jpk) 
     905         IF( ln_vvl_zstar           ) WRITE(numout,*) '              zstar vertical coordinate is used' 
     906         IF( ln_vvl_ztilde          ) WRITE(numout,*) '              ztilde vertical coordinate is used' 
     907         IF( ln_vvl_layer           ) WRITE(numout,*) '              layer vertical coordinate is used' 
     908         IF( ln_vvl_ztilde_as_zstar ) WRITE(numout,*) '              to emulate a zstar coordinate' 
     909         ! - ML - Option not developed yet 
     910         ! IF(       ln_vvl_kepe ) WRITE(numout,*) '              kinetic to potential energy transfer : option used' 
     911         ! IF( .NOT. ln_vvl_kepe ) WRITE(numout,*) '              kinetic to potential energy transfer : option not used' 
    205912      ENDIF 
    206        
    207       DO jk = 1, jpkm1           ! set the before scale factors at u- & v-points 
    208          DO jj = 2, jpjm1 
    209             DO ji = fs_2, fs_jpim1 
    210                zvt    = ( fse3t_b(ji  ,jj  ,jk) - fse3t_0(ji  ,jj  ,jk) ) * e1e2t(ji  ,jj  ) 
    211                zvtip1 = ( fse3t_b(ji+1,jj  ,jk) - fse3t_0(ji+1,jj  ,jk) ) * e1e2t(ji+1,jj  ) 
    212                zvtjp1 = ( fse3t_b(ji  ,jj+1,jk) - fse3t_0(ji  ,jj+1,jk) ) * e1e2t(ji  ,jj+1) 
    213                pe3u_b(ji,jj,jk) = fse3u_0(ji,jj,jk) + 0.5_wp * ( zvt + zvtip1 ) / ( e1u(ji,jj) * e2u(ji,jj) ) 
    214                pe3v_b(ji,jj,jk) = fse3v_0(ji,jj,jk) + 0.5_wp * ( zvt + zvtjp1 ) / ( e1v(ji,jj) * e2v(ji,jj) ) 
    215             END DO 
    216          END DO 
    217       END DO 
    218  
    219       ! Correct scale factors at locations that have been individually modified in domhgr 
    220       ! Such modifications break the relationship between e1e2t and e1u*e2u etc. Recompute 
    221       ! scale factors ignoring the modified metric. 
     913 
     914   END SUBROUTINE dom_vvl_ctl 
     915 
     916   SUBROUTINE dom_vvl_orca_fix( pe3_in, pe3_out, pout ) 
     917      !!--------------------------------------------------------------------- 
     918      !!                   ***  ROUTINE dom_vvl_orca_fix  *** 
     919      !!                      
     920      !! ** Purpose :   Correct surface weighted, horizontally interpolated,  
     921      !!                scale factors at locations that have been individually 
     922      !!                modified in domhgr. Such modifications break the 
     923      !!                relationship between e12t and e1u*e2u etc. 
     924      !!                Recompute some scale factors ignoring the modified metric. 
     925      !!---------------------------------------------------------------------- 
     926      !! * Arguments 
     927      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( in    ) ::  pe3_in     ! input e3 to be interpolated 
     928      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( inout ) ::  pe3_out    ! output interpolated e3 
     929      CHARACTER(LEN=*), INTENT( in )                    ::  pout       ! grid point of out scale factors 
     930      !                                                                !   =  'U', 'V', 'W, 'F', 'UW' or 'VW' 
     931      !! * Local declarations 
     932      INTEGER ::   ji, jj, jk                                          ! dummy loop indices 
     933      INTEGER ::   ij0, ij1, ii0, ii1                                  ! dummy loop indices 
     934      !! acc 
     935      !! Hmm with the time splitting these "fixes" seem to do more harm than good. Temporarily disabled for 
     936      !! the ORCA2 tests (by changing jp_cfg test from 2 to 3) pending further investigations 
     937      !!  
    222938      !                                                ! ===================== 
    223939      IF( cp_cfg == "orca" .AND. jp_cfg == 2 ) THEN    ! ORCA R2 configuration 
    224940         !                                             ! ===================== 
     941      !! acc 
    225942         IF( nn_cla == 0 ) THEN 
    226943            ! 
    227944            ii0 = 139   ;   ii1 = 140        ! Gibraltar Strait (e2u was modified) 
    228             ij0 = 102   ;   ij1 = 102    
    229             DO jk = 1, jpkm1                 ! set the before scale factors at u-points 
     945            ij0 = 102   ;   ij1 = 102 
     946            DO jk = 1, jpkm1 
    230947               DO jj = mj0(ij0), mj1(ij1) 
    231948                  DO ji = mi0(ii0), mi1(ii1) 
    232                      zvt = fse3t_b(ji,jj,jk) * e1t(ji,jj) 
    233                      pe3u_b(ji,jj,jk) = 0.5_wp * ( zvt + fse3t_b(ji+1,jj,jk) * e1t(ji+1,jj) ) / ( e1u(ji,jj) ) 
     949                     SELECT CASE ( pout ) 
     950                     CASE( 'U' ) 
     951                        pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk)                                        & 
     952                       &                    * (   e1t(ji  ,jj) * ( pe3_in(ji  ,jj,jk) - e3t_0(ji  ,jj,jk) ) & 
     953                       &                    +     e1t(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3t_0(ji+1,jj,jk) ) & 
     954                       &                      ) / e1u(ji,jj)   +   e3u_0(ji,jj,jk) 
     955                     CASE( 'F' ) 
     956                        pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk) * umask(ji,jj+1,jk)                    & 
     957                       &                    * (   e1u(ji  ,jj) * ( pe3_in(ji  ,jj,jk) - e3u_0(ji  ,jj,jk) ) & 
     958                       &                    +     e1u(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3u_0(ji+1,jj,jk) ) & 
     959                       &                      ) / e1f(ji,jj)   +   e3f_0(ji,jj,jk) 
     960                     END SELECT 
    234961                  END DO 
    235962               END DO 
    … …  
    237964            ! 
    238965            ii0 = 160   ;   ii1 = 160        ! Bab el Mandeb (e2u and e1v were modified) 
    239             ij0 =  88   ;   ij1 =  88    
    240             DO jk = 1, jpkm1                 ! set the before scale factors at u-points 
     966            ij0 =  88   ;   ij1 =  88 
     967            DO jk = 1, jpkm1 
    241968               DO jj = mj0(ij0), mj1(ij1) 
    242969                  DO ji = mi0(ii0), mi1(ii1) 
    243                      zvt = fse3t_b(ji,jj,jk) * e1t(ji,jj) 
    244                      pe3u_b(ji,jj,jk) = 0.5_wp * ( zvt + fse3t_b(ji+1,jj,jk) * e1t(ji+1,jj) ) / ( e1u(ji,jj) ) 
     970                     SELECT CASE ( pout ) 
     971                     CASE( 'U' ) 
     972                        pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk)                                        & 
     973                       &                    * (   e1t(ji  ,jj) * ( pe3_in(ji  ,jj,jk) - e3t_0(ji  ,jj,jk) ) & 
     974                       &                    +     e1t(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3t_0(ji+1,jj,jk) ) & 
     975                       &                      ) / e1u(ji,jj)   +   e3u_0(ji,jj,jk) 
     976                     CASE( 'V' ) 
     977                        pe3_out(ji,jj,jk) = 0.5_wp * vmask(ji,jj,jk)                                        & 
     978                       &                    * (   e2t(ji,jj  ) * ( pe3_in(ji,jj  ,jk) - e3t_0(ji,jj  ,jk) ) & 
     979                       &                    +     e2t(ji,jj+1) * ( pe3_in(ji,jj+1,jk) - e3t_0(ji,jj+1,jk) ) & 
     980                       &                      ) / e2v(ji,jj)   +   e3v_0(ji,jj,jk) 
     981                     CASE( 'F' ) 
     982                        pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk) * umask(ji,jj+1,jk)                    & 
     983                       &                    * (   e1u(ji  ,jj) * ( pe3_in(ji  ,jj,jk) - e3u_0(ji  ,jj,jk) ) & 
     984                       &                    +     e1u(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3u_0(ji+1,jj,jk) ) & 
     985                       &                      ) / e1f(ji,jj)   +   e3f_0(ji,jj,jk) 
     986                     END SELECT 
    245987                  END DO 
    246988               END DO 
    247989            END DO 
    248             DO jk = 1, jpkm1                 ! set the before scale factors at v-points 
    249                DO jj = mj0(ij0), mj1(ij1) 
    250                   DO ji = mi0(ii0), mi1(ii1) 
    251                      zvt = fse3t_b(ji,jj,jk) * e2t(ji,jj) 
    252                      pe3v_b(ji,jj,jk) = 0.5_wp * ( zvt + fse3t_b(ji,jj+1,jk) * e2t(ji,jj+1) ) / ( e2v(ji,jj) ) 
    253                   END DO 
    254                END DO 
    255             END DO 
    256990         ENDIF 
    257991 
    258992         ii0 = 145   ;   ii1 = 146        ! Danish Straits (e2u was modified) 
    259          ij0 = 116   ;   ij1 = 116    
    260          DO jk = 1, jpkm1                 ! set the before scale factors at u-points 
    261             DO jj = mj0(ij0), mj1(ij1) 
    262                DO ji = mi0(ii0), mi1(ii1) 
    263                   zvt = fse3t_b(ji,jj,jk) * e1t(ji,jj) 
    264                   pe3u_b(ji,jj,jk) = 0.5_wp * ( zvt + fse3t_b(ji+1,jj,jk) * e1t(ji+1,jj) ) / ( e1u(ji,jj) ) 
    265                END DO 
    266             END DO 
    267          END DO 
    268          ! 
     993         ij0 = 116   ;   ij1 = 116 
     994         DO jk = 1, jpkm1 
     995            DO jj = mj0(ij0), mj1(ij1) 
     996               DO ji = mi0(ii0), mi1(ii1) 
     997                  SELECT CASE ( pout ) 
     998                  CASE( 'U' ) 
     999                     pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk)                                        & 
     1000                    &                    * (   e1t(ji  ,jj) * ( pe3_in(ji  ,jj,jk) - e3t_0(ji  ,jj,jk) ) & 
     1001                    &                    +     e1t(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3t_0(ji+1,jj,jk) ) & 
     1002                    &                      ) / e1u(ji,jj)   +   e3u_0(ji,jj,jk) 
     1003                  CASE( 'F' ) 
     1004                     pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk) * umask(ji,jj+1,jk)                    & 
     1005                    &                    * (   e1u(ji  ,jj) * ( pe3_in(ji  ,jj,jk) - e3u_0(ji  ,jj,jk) ) & 
     1006                    &                    +     e1u(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3u_0(ji+1,jj,jk) ) & 
     1007                    &                      ) / e1f(ji,jj)   +   e3f_0(ji,jj,jk) 
     1008                  END SELECT 
     1009               END DO 
     1010            END DO 
     1011         END DO 
    2691012      ENDIF 
     1013      ! 
    2701014         !                                             ! ===================== 
    2711015      IF( cp_cfg == "orca" .AND. jp_cfg == 1 ) THEN    ! ORCA R1 configuration 
    2721016         !                                             ! ===================== 
    273  
     1017         ! 
    2741018         ii0 = 281   ;   ii1 = 282        ! Gibraltar Strait (e2u was modified) 
    275          ij0 = 200   ;   ij1 = 200    
    276          DO jk = 1, jpkm1                 ! set the before scale factors at u-points 
    277             DO jj = mj0(ij0), mj1(ij1) 
    278                DO ji = mi0(ii0), mi1(ii1) 
    279                   zvt = fse3t_b(ji,jj,jk) * e1t(ji,jj) 
    280                   pe3u_b(ji,jj,jk) = 0.5_wp * ( zvt + fse3t_b(ji+1,jj,jk) * e1t(ji+1,jj) ) / ( e1u(ji,jj) ) 
    281                END DO 
    282             END DO 
    283          END DO 
    284  
     1019         ij0 = 200   ;   ij1 = 200 
     1020         DO jk = 1, jpkm1 
     1021            DO jj = mj0(ij0), mj1(ij1) 
     1022               DO ji = mi0(ii0), mi1(ii1) 
     1023                  SELECT CASE ( pout ) 
     1024                  CASE( 'U' ) 
     1025                     pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk)                                        & 
     1026                    &                    * (   e1t(ji  ,jj) * ( pe3_in(ji  ,jj,jk) - e3t_0(ji  ,jj,jk) ) & 
     1027                    &                    +     e1t(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3t_0(ji+1,jj,jk) ) & 
     1028                    &                      ) / e1u(ji,jj)   +   e3u_0(ji,jj,jk) 
     1029                  CASE( 'F' ) 
     1030                     pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk) * umask(ji,jj+1,jk)                    & 
     1031                    &                    * (   e1u(ji  ,jj) * ( pe3_in(ji  ,jj,jk) - e3u_0(ji  ,jj,jk) ) & 
     1032                    &                    +     e1u(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3u_0(ji+1,jj,jk) ) & 
     1033                    &                      ) / e1f(ji,jj)   +   e3f_0(ji,jj,jk) 
     1034                  END SELECT 
     1035               END DO 
     1036            END DO 
     1037         END DO 
     1038         ! 
    2851039         ii0 = 314   ;   ii1 = 315        ! Bhosporus Strait (e2u was modified) 
    286          ij0 = 208   ;   ij1 = 208    
    287          DO jk = 1, jpkm1                 ! set the before scale factors at u-points 
    288             DO jj = mj0(ij0), mj1(ij1) 
    289                DO ji = mi0(ii0), mi1(ii1) 
    290                   zvt = fse3t_b(ji,jj,jk) * e1t(ji,jj) 
    291                   pe3u_b(ji,jj,jk) = 0.5_wp * ( zvt + fse3t_b(ji+1,jj,jk) * e1t(ji+1,jj) ) / ( e1u(ji,jj) ) 
    292                END DO 
    293             END DO 
    294          END DO 
    295  
     1040         ij0 = 208   ;   ij1 = 208 
     1041         DO jk = 1, jpkm1 
     1042            DO jj = mj0(ij0), mj1(ij1) 
     1043               DO ji = mi0(ii0), mi1(ii1) 
     1044                  SELECT CASE ( pout ) 
     1045                  CASE( 'U' ) 
     1046                     pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk)                                        &   
     1047                    &                    * (   e1t(ji  ,jj) * ( pe3_in(ji  ,jj,jk) - e3t_0(ji  ,jj,jk) ) & 
     1048                    &                    +     e1t(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3t_0(ji+1,jj,jk) ) & 
     1049                    &                      ) / e1u(ji,jj)   +   e3u_0(ji,jj,jk) 
     1050                  CASE( 'F' ) 
     1051                     pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk) * umask(ji,jj+1,jk)                    &   
     1052                    &                    * (   e1u(ji  ,jj) * ( pe3_in(ji  ,jj,jk) - e3u_0(ji  ,jj,jk) ) & 
     1053                    &                    +     e1u(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3u_0(ji+1,jj,jk) ) & 
     1054                    &                      ) / e1f(ji,jj)   +   e3f_0(ji,jj,jk) 
     1055                  END SELECT 
     1056               END DO 
     1057            END DO 
     1058         END DO 
     1059         ! 
    2961060         ii0 =  44   ;   ii1 =  44        ! Lombok Strait (e1v was modified) 
    297          ij0 = 124   ;   ij1 = 125    
    298          DO jk = 1, jpkm1                 ! set the before scale factors at v-points 
    299             DO jj = mj0(ij0), mj1(ij1) 
    300                DO ji = mi0(ii0), mi1(ii1) 
    301                   zvt = fse3t_b(ji,jj,jk) * e2t(ji,jj) 
    302                   pe3v_b(ji,jj,jk) = 0.5_wp * ( zvt + fse3t_b(ji,jj+1,jk) * e2t(ji,jj+1) ) / ( e2v(ji,jj) ) 
    303                END DO 
    304             END DO 
    305          END DO 
    306  
     1061         ij0 = 124   ;   ij1 = 125 
     1062         DO jk = 1, jpkm1 
     1063            DO jj = mj0(ij0), mj1(ij1) 
     1064               DO ji = mi0(ii0), mi1(ii1) 
     1065                  SELECT CASE ( pout ) 
     1066                  CASE( 'V' ) 
     1067                     pe3_out(ji,jj,jk) = 0.5_wp * vmask(ji,jj,jk)                                        & 
     1068                    &                    * (   e2t(ji,jj  ) * ( pe3_in(ji,jj  ,jk) - e3t_0(ji,jj  ,jk) ) & 
     1069                    &                    +     e2t(ji,jj+1) * ( pe3_in(ji,jj+1,jk) - e3t_0(ji,jj+1,jk) ) & 
     1070                    &                      ) / e2v(ji,jj)   +   e3v_0(ji,jj,jk) 
     1071                  END SELECT 
     1072               END DO 
     1073            END DO 
     1074         END DO 
     1075         ! 
    3071076         ii0 =  48   ;   ii1 =  48        ! Sumba Strait (e1v was modified) [closed from bathy_11 on] 
    308          ij0 = 124   ;   ij1 = 125    
    309          DO jk = 1, jpkm1                 ! set the before scale factors at v-points 
    310             DO jj = mj0(ij0), mj1(ij1) 
    311                DO ji = mi0(ii0), mi1(ii1) 
    312                   zvt = fse3t_b(ji,jj,jk) * e2t(ji,jj) 
    313                   pe3v_b(ji,jj,jk) = 0.5_wp * ( zvt + fse3t_b(ji,jj+1,jk) * e2t(ji,jj+1) ) / ( e2v(ji,jj) ) 
    314                END DO 
    315             END DO 
    316          END DO 
    317  
     1077         ij0 = 124   ;   ij1 = 125 
     1078         DO jk = 1, jpkm1 
     1079            DO jj = mj0(ij0), mj1(ij1) 
     1080               DO ji = mi0(ii0), mi1(ii1) 
     1081                  SELECT CASE ( pout ) 
     1082                  CASE( 'V' ) 
     1083                     pe3_out(ji,jj,jk) = 0.5_wp * vmask(ji,jj,jk)                                        & 
     1084                    &                    * (   e2t(ji,jj  ) * ( pe3_in(ji,jj  ,jk) - e3t_0(ji,jj  ,jk) ) & 
     1085                    &                    +     e2t(ji,jj+1) * ( pe3_in(ji,jj+1,jk) - e3t_0(ji,jj+1,jk) ) & 
     1086                    &                      ) / e2v(ji,jj)   +   e3v_0(ji,jj,jk) 
     1087                  END SELECT 
     1088               END DO 
     1089            END DO 
     1090         END DO 
     1091         ! 
    3181092         ii0 =  53   ;   ii1 =  53        ! Ombai Strait (e1v was modified) 
    319          ij0 = 124   ;   ij1 = 125    
    320          DO jk = 1, jpkm1                 ! set the before scale factors at v-points 
    321             DO jj = mj0(ij0), mj1(ij1) 
    322                DO ji = mi0(ii0), mi1(ii1) 
    323                   zvt = fse3t_b(ji,jj,jk) * e2t(ji,jj) 
    324                   pe3v_b(ji,jj,jk) = 0.5_wp * ( zvt + fse3t_b(ji,jj+1,jk) * e2t(ji,jj+1) ) / ( e2v(ji,jj) ) 
    325                END DO 
    326             END DO 
    327          END DO 
    328  
     1093         ij0 = 124   ;   ij1 = 125 
     1094         DO jk = 1, jpkm1 
     1095            DO jj = mj0(ij0), mj1(ij1) 
     1096               DO ji = mi0(ii0), mi1(ii1) 
     1097                  SELECT CASE ( pout ) 
     1098                  CASE( 'V' ) 
     1099                     pe3_out(ji,jj,jk) = 0.5_wp * vmask(ji,jj,jk)                                        & 
     1100                    &                    * (   e2t(ji,jj  ) * ( pe3_in(ji,jj  ,jk) - e3t_0(ji,jj  ,jk) ) & 
     1101                    &                    +     e2t(ji,jj+1) * ( pe3_in(ji,jj+1,jk) - e3t_0(ji,jj+1,jk) ) & 
     1102                    &                      ) / e2v(ji,jj)   +   e3v_0(ji,jj,jk) 
     1103                  END SELECT 
     1104               END DO 
     1105            END DO 
     1106         END DO 
     1107         ! 
    3291108         ii0 =  56   ;   ii1 =  56        ! Timor Passage (e1v was modified) 
    330          ij0 = 124   ;   ij1 = 125    
    331          DO jk = 1, jpkm1                 ! set the before scale factors at v-points 
    332             DO jj = mj0(ij0), mj1(ij1) 
    333                DO ji = mi0(ii0), mi1(ii1) 
    334                   zvt = fse3t_b(ji,jj,jk) * e2t(ji,jj) 
    335                   pe3v_b(ji,jj,jk) = 0.5_wp * ( zvt + fse3t_b(ji,jj+1,jk) * e2t(ji,jj+1) ) / ( e2v(ji,jj) ) 
    336                END DO 
    337             END DO 
    338          END DO 
    339  
     1109         ij0 = 124   ;   ij1 = 125 
     1110         DO jk = 1, jpkm1 
     1111            DO jj = mj0(ij0), mj1(ij1) 
     1112               DO ji = mi0(ii0), mi1(ii1) 
     1113                  SELECT CASE ( pout ) 
     1114                  CASE( 'V' ) 
     1115                     pe3_out(ji,jj,jk) = 0.5_wp * vmask(ji,jj,jk)                                        & 
     1116                    &                    * (   e2t(ji,jj  ) * ( pe3_in(ji,jj  ,jk) - e3t_0(ji,jj  ,jk) ) & 
     1117                    &                    +     e2t(ji,jj+1) * ( pe3_in(ji,jj+1,jk) - e3t_0(ji,jj+1,jk) ) & 
     1118                    &                      ) / e2v(ji,jj)   +   e3v_0(ji,jj,jk) 
     1119                  END SELECT 
     1120               END DO 
     1121            END DO 
     1122         END DO 
     1123         ! 
    3401124         ii0 =  55   ;   ii1 =  55        ! West Halmahera Strait (e1v was modified) 
    341          ij0 = 141   ;   ij1 = 142    
    342          DO jk = 1, jpkm1                 ! set the before scale factors at v-points 
    343             DO jj = mj0(ij0), mj1(ij1) 
    344                DO ji = mi0(ii0), mi1(ii1) 
    345                   zvt = fse3t_b(ji,jj,jk) * e2t(ji,jj) 
    346                   pe3v_b(ji,jj,jk) = 0.5_wp * ( zvt + fse3t_b(ji,jj+1,jk) * e2t(ji,jj+1) ) / ( e2v(ji,jj) ) 
    347                END DO 
    348             END DO 
    349          END DO 
    350  
     1125         ij0 = 141   ;   ij1 = 142 
     1126         DO jk = 1, jpkm1 
     1127            DO jj = mj0(ij0), mj1(ij1) 
     1128               DO ji = mi0(ii0), mi1(ii1) 
     1129                  SELECT CASE ( pout ) 
     1130                  CASE( 'V' ) 
     1131                     pe3_out(ji,jj,jk) = 0.5_wp * vmask(ji,jj,jk)                                        & 
     1132                    &                    * (   e2t(ji,jj  ) * ( pe3_in(ji,jj  ,jk) - e3t_0(ji,jj  ,jk) ) & 
     1133                    &                    +     e2t(ji,jj+1) * ( pe3_in(ji,jj+1,jk) - e3t_0(ji,jj+1,jk) ) & 
     1134                    &                      ) / e2v(ji,jj)   +   e3v_0(ji,jj,jk) 
     1135                  END SELECT 
     1136               END DO 
     1137            END DO 
     1138         END DO 
     1139         ! 
    3511140         ii0 =  58   ;   ii1 =  58        ! East Halmahera Strait (e1v was modified) 
    352          ij0 = 141   ;   ij1 = 142    
    353          DO jk = 1, jpkm1                 ! set the before scale factors at v-points 
    354             DO jj = mj0(ij0), mj1(ij1) 
    355                DO ji = mi0(ii0), mi1(ii1) 
    356                   zvt = fse3t_b(ji,jj,jk) * e2t(ji,jj) 
    357                   pe3v_b(ji,jj,jk) = 0.5_wp * ( zvt + fse3t_b(ji,jj+1,jk) * e2t(ji,jj+1) ) / ( e2v(ji,jj) ) 
    358                END DO 
    359             END DO 
    360          END DO 
    361  
    362          ! 
     1141         ij0 = 141   ;   ij1 = 142 
     1142         DO jk = 1, jpkm1 
     1143            DO jj = mj0(ij0), mj1(ij1) 
     1144               DO ji = mi0(ii0), mi1(ii1) 
     1145                  SELECT CASE ( pout ) 
     1146                  CASE( 'V' ) 
     1147                     pe3_out(ji,jj,jk) = 0.5_wp * vmask(ji,jj,jk)                                        & 
     1148                    &                    * (   e2t(ji,jj  ) * ( pe3_in(ji,jj  ,jk) - e3t_0(ji,jj  ,jk) ) & 
     1149                    &                    +     e2t(ji,jj+1) * ( pe3_in(ji,jj+1,jk) - e3t_0(ji,jj+1,jk) ) & 
     1150                    &                      ) / e2v(ji,jj)   +   e3v_0(ji,jj,jk) 
     1151                  END SELECT 
     1152               END DO 
     1153            END DO 
     1154         END DO 
    3631155      ENDIF 
    364       !                                                ! ====================== 
     1156         !                                             ! ===================== 
    3651157      IF( cp_cfg == "orca" .AND. jp_cfg == 05 ) THEN   ! ORCA R05 configuration 
    366          !                                             ! ====================== 
     1158         !                                             ! ===================== 
     1159         ! 
    3671160         ii0 = 563   ;   ii1 = 564        ! Gibraltar Strait (e2u was modified) 
    368          ij0 = 327   ;   ij1 = 327    
    369          DO jk = 1, jpkm1                 ! set the before scale factors at u-points 
    370             DO jj = mj0(ij0), mj1(ij1) 
    371                DO ji = mi0(ii0), mi1(ii1) 
    372                   zvt = fse3t_b(ji,jj,jk) * e1t(ji,jj) 
    373                   pe3u_b(ji,jj,jk) = 0.5_wp * ( zvt + fse3t_b(ji+1,jj,jk) * e1t(ji+1,jj) ) / ( e1u(ji,jj) ) 
    374                END DO 
    375             END DO 
    376          END DO 
    377          ! 
    378          ii0 = 627   ;   ii1 = 628        ! Bosphore Strait (e2u was modified) 
    379          ij0 = 343   ;   ij1 = 343    
    380          DO jk = 1, jpkm1                 ! set the before scale factors at u-points 
    381             DO jj = mj0(ij0), mj1(ij1) 
    382                DO ji = mi0(ii0), mi1(ii1) 
    383                   zvt = fse3t_b(ji,jj,jk) * e1t(ji,jj) 
    384                   pe3u_b(ji,jj,jk) = 0.5_wp * ( zvt + fse3t_b(ji+1,jj,jk) * e1t(ji+1,jj) ) / ( e1u(ji,jj) ) 
     1161         ij0 = 327   ;   ij1 = 327 
     1162         DO jk = 1, jpkm1 
     1163            DO jj = mj0(ij0), mj1(ij1) 
     1164               DO ji = mi0(ii0), mi1(ii1) 
     1165                  SELECT CASE ( pout ) 
     1166                  CASE( 'U' ) 
     1167                     pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk)                                        & 
     1168                    &                    * (   e1t(ji  ,jj) * ( pe3_in(ji  ,jj,jk) - e3t_0(ji  ,jj,jk) ) & 
     1169                    &                    +     e1t(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3t_0(ji+1,jj,jk) ) & 
     1170                    &                      ) / e1u(ji,jj)   +   e3u_0(ji,jj,jk) 
     1171                  CASE( 'F' ) 
     1172                     pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk) * umask(ji,jj+1,jk)                    & 
     1173                    &                    * (   e1u(ji  ,jj) * ( pe3_in(ji  ,jj,jk) - e3u_0(ji  ,jj,jk) ) & 
     1174                    &                    +     e1u(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3u_0(ji+1,jj,jk) ) & 
     1175                    &                      ) / e1f(ji,jj)   +   e3f_0(ji,jj,jk) 
     1176                  END SELECT 
     1177               END DO 
     1178            END DO 
     1179         END DO 
     1180         ! 
     1181         ii0 = 627   ;   ii1 = 628        ! Bosphorus Strait (e2u was modified) 
     1182         ij0 = 343   ;   ij1 = 343 
     1183         DO jk = 1, jpkm1 
     1184            DO jj = mj0(ij0), mj1(ij1) 
     1185               DO ji = mi0(ii0), mi1(ii1) 
     1186                  SELECT CASE ( pout ) 
     1187                  CASE( 'U' ) 
     1188                     pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk)                                        &   
     1189                    &                    * (   e1t(ji  ,jj) * ( pe3_in(ji  ,jj,jk) - e3t_0(ji  ,jj,jk) ) & 
     1190                    &                    +     e1t(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3t_0(ji+1,jj,jk) ) & 
     1191                    &                      ) / e1u(ji,jj)   +   e3u_0(ji,jj,jk) 
     1192                  CASE( 'F' ) 
     1193                     pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk) * umask(ji,jj+1,jk)                    &   
     1194                    &                    * (   e1u(ji  ,jj) * ( pe3_in(ji  ,jj,jk) - e3u_0(ji  ,jj,jk) ) & 
     1195                    &                    +     e1u(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3u_0(ji+1,jj,jk) ) & 
     1196                    &                      ) / e1f(ji,jj)   +   e3f_0(ji,jj,jk) 
     1197                  END SELECT 
    3851198               END DO 
    3861199            END DO 
    … …  
    3881201         ! 
    3891202         ii0 =  93   ;   ii1 =  94        ! Sumba Strait (e2u was modified) 
    390          ij0 = 232   ;   ij1 = 232    
    391          DO jk = 1, jpkm1                 ! set the before scale factors at u-points 
    392             DO jj = mj0(ij0), mj1(ij1) 
    393                DO ji = mi0(ii0), mi1(ii1) 
    394                   zvt = fse3t_b(ji,jj,jk) * e1t(ji,jj) 
    395                   pe3u_b(ji,jj,jk) = 0.5_wp * ( zvt + fse3t_b(ji+1,jj,jk) * e1t(ji+1,jj) ) / ( e1u(ji,jj) ) 
     1203         ij0 = 232   ;   ij1 = 232 
     1204         DO jk = 1, jpkm1 
     1205            DO jj = mj0(ij0), mj1(ij1) 
     1206               DO ji = mi0(ii0), mi1(ii1) 
     1207                  SELECT CASE ( pout ) 
     1208                  CASE( 'U' ) 
     1209                     pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk)                                        & 
     1210                    &                    * (   e1t(ji  ,jj) * ( pe3_in(ji  ,jj,jk) - e3t_0(ji  ,jj,jk) ) & 
     1211                    &                    +     e1t(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3t_0(ji+1,jj,jk) ) & 
     1212                    &                      ) / e1u(ji,jj)   +   e3u_0(ji,jj,jk) 
     1213                  CASE( 'F' ) 
     1214                     pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk) * umask(ji,jj+1,jk)                    & 
     1215                    &                    * (   e1u(ji  ,jj) * ( pe3_in(ji  ,jj,jk) - e3u_0(ji  ,jj,jk) ) & 
     1216                    &                    +     e1u(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3u_0(ji+1,jj,jk) ) & 
     1217                    &                      ) / e1f(ji,jj)   +   e3f_0(ji,jj,jk) 
     1218                  END SELECT 
    3961219               END DO 
    3971220            END DO 
    … …  
    3991222         ! 
    4001223         ii0 = 103   ;   ii1 = 103        ! Ombai Strait (e2u was modified) 
    401          ij0 = 232   ;   ij1 = 232    
    402          DO jk = 1, jpkm1                 ! set the before scale factors at u-points 
    403             DO jj = mj0(ij0), mj1(ij1) 
    404                DO ji = mi0(ii0), mi1(ii1) 
    405                   zvt = fse3t_b(ji,jj,jk) * e1t(ji,jj) 
    406                   pe3u_b(ji,jj,jk) = 0.5_wp * ( zvt + fse3t_b(ji+1,jj,jk) * e1t(ji+1,jj) ) / ( e1u(ji,jj) ) 
     1224         ij0 = 232   ;   ij1 = 232 
     1225         DO jk = 1, jpkm1 
     1226            DO jj = mj0(ij0), mj1(ij1) 
     1227               DO ji = mi0(ii0), mi1(ii1) 
     1228                  SELECT CASE ( pout ) 
     1229                  CASE( 'U' ) 
     1230                     pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk)                                        & 
     1231                    &                    * (   e1t(ji  ,jj) * ( pe3_in(ji  ,jj,jk) - e3t_0(ji  ,jj,jk) ) & 
     1232                    &                    +     e1t(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3t_0(ji+1,jj,jk) ) & 
     1233                    &                      ) / e1u(ji,jj)   +   e3u_0(ji,jj,jk) 
     1234                  CASE( 'F' ) 
     1235                     pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk) * umask(ji,jj+1,jk)                    & 
     1236                    &                    * (   e1u(ji  ,jj) * ( pe3_in(ji  ,jj,jk) - e3u_0(ji  ,jj,jk) ) & 
     1237                    &                    +     e1u(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3u_0(ji+1,jj,jk) ) & 
     1238                    &                      ) / e1f(ji,jj)   +   e3f_0(ji,jj,jk) 
     1239                  END SELECT 
    4071240               END DO 
    4081241            END DO 
    … …  
    4101243         ! 
    4111244         ii0 =  15   ;   ii1 =  15        ! Palk Strait (e2u was modified) 
    412          ij0 = 270   ;   ij1 = 270    
    413          DO jk = 1, jpkm1                 ! set the before scale factors at u-points 
    414             DO jj = mj0(ij0), mj1(ij1) 
    415                DO ji = mi0(ii0), mi1(ii1) 
    416                   zvt = fse3t_b(ji,jj,jk) * e1t(ji,jj) 
    417                   pe3u_b(ji,jj,jk) = 0.5_wp * ( zvt + fse3t_b(ji+1,jj,jk) * e1t(ji+1,jj) ) / ( e1u(ji,jj) ) 
     1245         ij0 = 270   ;   ij1 = 270 
     1246         DO jk = 1, jpkm1 
     1247            DO jj = mj0(ij0), mj1(ij1) 
     1248               DO ji = mi0(ii0), mi1(ii1) 
     1249                  SELECT CASE ( pout ) 
     1250                  CASE( 'U' ) 
     1251                     pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk)                                        & 
     1252                    &                    * (   e1t(ji  ,jj) * ( pe3_in(ji  ,jj,jk) - e3t_0(ji  ,jj,jk) ) & 
     1253                    &                    +     e1t(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3t_0(ji+1,jj,jk) ) & 
     1254                    &                      ) / e1u(ji,jj)   +   e3u_0(ji,jj,jk) 
     1255                  CASE( 'F' ) 
     1256                     pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk) * umask(ji,jj+1,jk)                    & 
     1257                    &                    * (   e1u(ji  ,jj) * ( pe3_in(ji  ,jj,jk) - e3u_0(ji  ,jj,jk) ) & 
     1258                    &                    +     e1u(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3u_0(ji+1,jj,jk) ) & 
     1259                    &                      ) / e1f(ji,jj)   +   e3f_0(ji,jj,jk) 
     1260                  END SELECT 
    4181261               END DO 
    4191262            END DO 
    … …  
    4211264         ! 
    4221265         ii0 =  87   ;   ii1 =  87        ! Lombok Strait (e1v was modified) 
    423          ij0 = 232   ;   ij1 = 233    
    424          DO jk = 1, jpkm1                 ! set the before scale factors at v-points 
    425             DO jj = mj0(ij0), mj1(ij1) 
    426                DO ji = mi0(ii0), mi1(ii1) 
    427                   zvt = fse3t_b(ji,jj,jk) * e2t(ji,jj) 
    428                   pe3v_b(ji,jj,jk) = 0.5_wp * ( zvt + fse3t_b(ji,jj+1,jk) * e2t(ji,jj+1) ) / ( e2v(ji,jj) ) 
     1266         ij0 = 232   ;   ij1 = 233 
     1267         DO jk = 1, jpkm1 
     1268            DO jj = mj0(ij0), mj1(ij1) 
     1269               DO ji = mi0(ii0), mi1(ii1) 
     1270                  SELECT CASE ( pout ) 
     1271                  CASE( 'V' ) 
     1272                     pe3_out(ji,jj,jk) = 0.5_wp * vmask(ji,jj,jk)                                        & 
     1273                    &                    * (   e2t(ji,jj  ) * ( pe3_in(ji,jj  ,jk) - e3t_0(ji,jj  ,jk) ) & 
     1274                    &                    +     e2t(ji,jj+1) * ( pe3_in(ji,jj+1,jk) - e3t_0(ji,jj+1,jk) ) & 
     1275                    &                      ) / e2v(ji,jj)   +   e3v_0(ji,jj,jk) 
     1276                  END SELECT 
    4291277               END DO 
    4301278            END DO 
    … …  
    4321280         ! 
    4331281         ii0 = 662   ;   ii1 = 662        ! Bab el Mandeb (e1v was modified) 
    434          ij0 = 276   ;   ij1 = 276    
    435          DO jk = 1, jpkm1                 ! set the before scale factors at v-points 
    436             DO jj = mj0(ij0), mj1(ij1) 
    437                DO ji = mi0(ii0), mi1(ii1) 
    438                   zvt = fse3t_b(ji,jj,jk) * e2t(ji,jj) 
    439                   pe3v_b(ji,jj,jk) = 0.5_wp * ( zvt + fse3t_b(ji,jj+1,jk) * e2t(ji,jj+1) ) / ( e2v(ji,jj) ) 
    440                END DO 
    441             END DO 
    442          END DO 
    443          ! 
     1282         ij0 = 276   ;   ij1 = 276 
     1283         DO jk = 1, jpkm1 
     1284            DO jj = mj0(ij0), mj1(ij1) 
     1285               DO ji = mi0(ii0), mi1(ii1) 
     1286                  SELECT CASE ( pout ) 
     1287                  CASE( 'V' ) 
     1288                     pe3_out(ji,jj,jk) = 0.5_wp * vmask(ji,jj,jk)                                        & 
     1289                    &                    * (   e2t(ji,jj  ) * ( pe3_in(ji,jj  ,jk) - e3t_0(ji,jj  ,jk) ) & 
     1290                    &                    +     e2t(ji,jj+1) * ( pe3_in(ji,jj+1,jk) - e3t_0(ji,jj+1,jk) ) & 
     1291                    &                      ) / e2v(ji,jj)   +   e3v_0(ji,jj,jk) 
     1292                  END SELECT 
     1293               END DO 
     1294            END DO 
     1295         END DO 
    4441296      ENDIF 
    445       ! End of individual corrections to scale factors 
    446  
    447       IF( ln_zps ) THEN          ! minimum of the e3t at partial cell level 
    448          DO jj = 2, jpjm1 
    449             DO ji = fs_2, fs_jpim1 
    450                iku = mbku(ji,jj) 
    451                ikv = mbkv(ji,jj) 
    452                pe3u_b(ji,jj,iku) = MIN( fse3t_b(ji,jj,iku), fse3t_b(ji+1,jj  ,iku) )  
    453                pe3v_b(ji,jj,ikv) = MIN( fse3t_b(ji,jj,ikv), fse3t_b(ji  ,jj+1,ikv) )  
    454             END DO 
    455          END DO 
    456       ENDIF 
    457  
    458       pe3u_b(:,:,:) = pe3u_b(:,:,:) - fse3u_0(:,:,:)      ! anomaly to avoid zero along closed boundary/extra halos 
    459       pe3v_b(:,:,:) = pe3v_b(:,:,:) - fse3v_0(:,:,:) 
    460       CALL lbc_lnk( pe3u_b(:,:,:), 'U', 1. )               ! lateral boundary conditions 
    461       CALL lbc_lnk( pe3v_b(:,:,:), 'V', 1. ) 
    462       pe3u_b(:,:,:) = pe3u_b(:,:,:) + fse3u_0(:,:,:)      ! recover the full scale factor 
    463       pe3v_b(:,:,:) = pe3v_b(:,:,:) + fse3v_0(:,:,:) 
    464       ! 
    465       IF( nn_timing == 1 )  CALL timing_stop('dom_vvl_2') 
    466       ! 
    467    END SUBROUTINE dom_vvl_2 
    468     
    469 #else 
    470    !!---------------------------------------------------------------------- 
    471    !!   Default option :                                      Empty routine 
    472    !!---------------------------------------------------------------------- 
    473 CONTAINS 
    474    SUBROUTINE dom_vvl 
    475    END SUBROUTINE dom_vvl 
    476    SUBROUTINE dom_vvl_2(kdum, pudum, pvdum ) 
    477       USE par_kind 
    478       INTEGER                   , INTENT(in   ) ::   kdum        
    479       REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pudum, pvdum 
    480    END SUBROUTINE dom_vvl_2 
    481 #endif 
     1297   END SUBROUTINE dom_vvl_orca_fix 
    4821298 
    4831299   !!====================================================================== 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DOM/domwri.F90

    r3680 r4292  
    183183         CALL iom_rstput( 0, 0, inum4, 'esigw', esigw ) 
    184184         ! 
    185          CALL iom_rstput( 0, 0, inum4, 'e3t', e3t )             !    ! scale factors 
    186          CALL iom_rstput( 0, 0, inum4, 'e3u', e3u ) 
    187          CALL iom_rstput( 0, 0, inum4, 'e3v', e3v ) 
    188          CALL iom_rstput( 0, 0, inum4, 'e3w', e3w ) 
     185         CALL iom_rstput( 0, 0, inum4, 'e3t_0', e3t_0 )         !    ! scale factors 
     186         CALL iom_rstput( 0, 0, inum4, 'e3u_0', e3u_0 ) 
     187         CALL iom_rstput( 0, 0, inum4, 'e3v_0', e3v_0 ) 
     188         CALL iom_rstput( 0, 0, inum4, 'e3w_0', e3w_0 ) 
    189189         CALL iom_rstput( 0, 0, inum4, 'rx1', rx1 )             !    ! Max. grid stiffness ratio 
    190190         ! 
    191          CALL iom_rstput( 0, 0, inum4, 'gdept' , gdept )    !    ! stretched system 
    192          CALL iom_rstput( 0, 0, inum4, 'gdepw' , gdepw ) 
     191         CALL iom_rstput( 0, 0, inum4, 'gdept_1d' , gdept_1d )  !    ! stretched system 
     192         CALL iom_rstput( 0, 0, inum4, 'gdepw_1d' , gdepw_1d ) 
    193193      ENDIF 
    194194       
    … …  
    196196         ! 
    197197         IF( nmsh <= 6 ) THEN                                   !    ! 3D vertical scale factors 
    198             CALL iom_rstput( 0, 0, inum4, 'e3t', e3t )          
    199             CALL iom_rstput( 0, 0, inum4, 'e3u', e3u ) 
    200             CALL iom_rstput( 0, 0, inum4, 'e3v', e3v ) 
    201             CALL iom_rstput( 0, 0, inum4, 'e3w', e3w ) 
     198            CALL iom_rstput( 0, 0, inum4, 'e3t_0', e3t_0 )          
     199            CALL iom_rstput( 0, 0, inum4, 'e3u_0', e3u_0 ) 
     200            CALL iom_rstput( 0, 0, inum4, 'e3v_0', e3v_0 ) 
     201            CALL iom_rstput( 0, 0, inum4, 'e3w_0', e3w_0 ) 
    202202         ELSE                                                   !    ! 2D masked bottom ocean scale factors 
    203203            DO jj = 1,jpj    
    204204               DO ji = 1,jpi 
    205                   e3tp(ji,jj) = e3t(ji,jj,mbkt(ji,jj)) * tmask(ji,jj,1) 
    206                   e3wp(ji,jj) = e3w(ji,jj,mbkt(ji,jj)) * tmask(ji,jj,1) 
     205                  e3tp(ji,jj) = e3t_0(ji,jj,mbkt(ji,jj)) * tmask(ji,jj,1) 
     206                  e3wp(ji,jj) = e3w_0(ji,jj,mbkt(ji,jj)) * tmask(ji,jj,1) 
    207207               END DO 
    208208            END DO 
    … …  
    212212         ! 
    213213         IF( nmsh <= 3 ) THEN                                   !    ! 3D depth 
    214             CALL iom_rstput( 0, 0, inum4, 'gdept', gdept, ktype = jp_r4 )      
     214            CALL iom_rstput( 0, 0, inum4, 'gdept_0', gdept_0, ktype = jp_r4 )      
    215215            DO jk = 1,jpk    
    216216               DO jj = 1, jpjm1    
    217217                  DO ji = 1, fs_jpim1   ! vector opt. 
    218                      zdepu(ji,jj,jk) = MIN( gdept(ji,jj,jk) , gdept(ji+1,jj  ,jk) ) 
    219                      zdepv(ji,jj,jk) = MIN( gdept(ji,jj,jk) , gdept(ji  ,jj+1,jk) ) 
     218                     zdepu(ji,jj,jk) = MIN( gdept_0(ji,jj,jk) , gdept_0(ji+1,jj  ,jk) ) 
     219                     zdepv(ji,jj,jk) = MIN( gdept_0(ji,jj,jk) , gdept_0(ji  ,jj+1,jk) ) 
    220220                  END DO    
    221221               END DO    
    … …  
    224224            CALL iom_rstput( 0, 0, inum4, 'gdepu', zdepu, ktype = jp_r4 ) 
    225225            CALL iom_rstput( 0, 0, inum4, 'gdepv', zdepv, ktype = jp_r4 ) 
    226             CALL iom_rstput( 0, 0, inum4, 'gdepw', gdepw, ktype = jp_r4 ) 
     226            CALL iom_rstput( 0, 0, inum4, 'gdepw_0', gdepw_0, ktype = jp_r4 ) 
    227227         ELSE                                                   !    ! 2D bottom depth 
    228228            DO jj = 1,jpj    
    229229               DO ji = 1,jpi 
    230                   zprt(ji,jj) = gdept(ji,jj,mbkt(ji,jj)  ) * tmask(ji,jj,1) 
    231                   zprw(ji,jj) = gdepw(ji,jj,mbkt(ji,jj)+1) * tmask(ji,jj,1) 
     230                  zprt(ji,jj) = gdept_0(ji,jj,mbkt(ji,jj)  ) * tmask(ji,jj,1) 
     231                  zprw(ji,jj) = gdepw_0(ji,jj,mbkt(ji,jj)+1) * tmask(ji,jj,1) 
    232232               END DO 
    233233            END DO 
    … …  
    236236         ENDIF 
    237237         ! 
    238          CALL iom_rstput( 0, 0, inum4, 'gdept_0', gdept_0 )     !    ! reference z-coord. 
    239          CALL iom_rstput( 0, 0, inum4, 'gdepw_0', gdepw_0 ) 
    240          CALL iom_rstput( 0, 0, inum4, 'e3t_0'  , e3t_0   ) 
    241          CALL iom_rstput( 0, 0, inum4, 'e3w_0'  , e3w_0   ) 
     238         CALL iom_rstput( 0, 0, inum4, 'gdept_1d', gdept_1d )   !    ! reference z-coord. 
     239         CALL iom_rstput( 0, 0, inum4, 'gdepw_1d', gdepw_1d ) 
     240         CALL iom_rstput( 0, 0, inum4, 'e3t_1d'  , e3t_1d   ) 
     241         CALL iom_rstput( 0, 0, inum4, 'e3w_1d'  , e3w_1d   ) 
    242242      ENDIF 
    243243       
    244244      IF( ln_zco ) THEN 
    245245         !                                                      ! z-coordinate - full steps 
    246          CALL iom_rstput( 0, 0, inum4, 'gdept_0', gdept_0 )     !    ! depth 
    247          CALL iom_rstput( 0, 0, inum4, 'gdepw_0', gdepw_0 ) 
    248          CALL iom_rstput( 0, 0, inum4, 'e3t_0'  , e3t_0   )     !    ! scale factors 
    249          CALL iom_rstput( 0, 0, inum4, 'e3w_0'  , e3w_0   ) 
     246         CALL iom_rstput( 0, 0, inum4, 'gdept_1d', gdept_1d )   !    ! depth 
     247         CALL iom_rstput( 0, 0, inum4, 'gdepw_1d', gdepw_1d ) 
     248         CALL iom_rstput( 0, 0, inum4, 'e3t_1d'  , e3t_1d   )   !    ! scale factors 
     249         CALL iom_rstput( 0, 0, inum4, 'e3w_1d'  , e3w_1d   ) 
    250250      ENDIF 
    251251      !                                     ! ============================ 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DOM/domzgr.F90

    r4245 r4292  
    8888      !!              vertical scale factors. 
    8989      !! 
    90       !! ** Method  : - reference 1D vertical coordinate (gdep._0, e3._0) 
     90      !! ** Method  : - reference 1D vertical coordinate (gdep._1d, e3._1d) 
    9191      !!              - read/set ocean depth and ocean levels (bathy, mbathy) 
    9292      !!              - vertical coordinate (gdep., e3.) depending on the  
    … …  
    153153      IF( nprint == 1 .AND. lwp )   THEN 
    154154         WRITE(numout,*) ' MIN val mbathy ', MINVAL( mbathy(:,:) ), ' MAX ', MAXVAL( mbathy(:,:) ) 
    155          WRITE(numout,*) ' MIN val depth t ', MINVAL( fsdept(:,:,:) ),   & 
    156             &                   ' w ',   MINVAL( fsdepw(:,:,:) ), '3w ', MINVAL( fsde3w(:,:,:) ) 
    157          WRITE(numout,*) ' MIN val e3    t ', MINVAL( fse3t(:,:,:) ), ' f ', MINVAL( fse3f(:,:,:) ),  & 
    158             &                   ' u ',   MINVAL( fse3u(:,:,:) ), ' u ', MINVAL( fse3v(:,:,:) ),  & 
    159             &                   ' uw',   MINVAL( fse3uw(:,:,:)), ' vw', MINVAL( fse3vw(:,:,:)),   & 
    160             &                   ' w ',   MINVAL( fse3w(:,:,:) ) 
    161  
    162          WRITE(numout,*) ' MAX val depth t ', MAXVAL( fsdept(:,:,:) ),   & 
    163             &                   ' w ',   MAXVAL( fsdepw(:,:,:) ), '3w ', MAXVAL( fsde3w(:,:,:) ) 
    164          WRITE(numout,*) ' MAX val e3    t ', MAXVAL( fse3t(:,:,:) ), ' f ', MAXVAL( fse3f(:,:,:) ),  & 
    165             &                   ' u ',   MAXVAL( fse3u(:,:,:) ), ' u ', MAXVAL( fse3v(:,:,:) ),  & 
    166             &                   ' uw',   MAXVAL( fse3uw(:,:,:)), ' vw', MAXVAL( fse3vw(:,:,:)),   & 
    167             &                   ' w ',   MAXVAL( fse3w(:,:,:) ) 
     155         WRITE(numout,*) ' MIN val depth t ', MINVAL( gdept_0(:,:,:) ),   & 
     156            &                   ' w ',   MINVAL( gdepw_0(:,:,:) ), '3w ', MINVAL( gdep3w_0(:,:,:) ) 
     157         WRITE(numout,*) ' MIN val e3    t ', MINVAL( e3t_0(:,:,:) ), ' f ', MINVAL( e3f_0(:,:,:) ),  & 
     158            &                   ' u ',   MINVAL( e3u_0(:,:,:) ), ' u ', MINVAL( e3v_0(:,:,:) ),  & 
     159            &                   ' uw',   MINVAL( e3uw_0(:,:,:)), ' vw', MINVAL( e3vw_0(:,:,:)),   & 
     160            &                   ' w ',   MINVAL( e3w_0(:,:,:) ) 
     161 
     162         WRITE(numout,*) ' MAX val depth t ', MAXVAL( gdept_0(:,:,:) ),   & 
     163            &                   ' w ',   MAXVAL( gdepw_0(:,:,:) ), '3w ', MAXVAL( gdep3w_0(:,:,:) ) 
     164         WRITE(numout,*) ' MAX val e3    t ', MAXVAL( e3t_0(:,:,:) ), ' f ', MAXVAL( e3f_0(:,:,:) ),  & 
     165            &                   ' u ',   MAXVAL( e3u_0(:,:,:) ), ' u ', MAXVAL( e3v_0(:,:,:) ),  & 
     166            &                   ' uw',   MAXVAL( e3uw_0(:,:,:)), ' vw', MAXVAL( e3vw_0(:,:,:)),   & 
     167            &                   ' w ',   MAXVAL( e3w_0(:,:,:) ) 
    168168      ENDIF 
    169169      ! 
    … …  
    176176      !!---------------------------------------------------------------------- 
    177177      !!                   ***  ROUTINE zgr_z  *** 
    178       !!                     
     178      !!                    
    179179      !! ** Purpose :   set the depth of model levels and the resulting  
    180180      !!      vertical scale factors. 
    … …  
    184184      !!      function the derivative of which gives the scale factors. 
    185185      !!        both depth and scale factors only depend on k (1d arrays). 
    186       !!              w-level: gdepw_0  = fsdep(k) 
    187       !!                       e3w_0(k) = dk(fsdep)(k)     = fse3(k) 
    188       !!              t-level: gdept_0  = fsdep(k+0.5) 
    189       !!                       e3t_0(k) = dk(fsdep)(k+0.5) = fse3(k+0.5) 
    190       !! 
    191       !! ** Action  : - gdept_0, gdepw_0 : depth of T- and W-point (m) 
    192       !!              - e3t_0  , e3w_0   : scale factors at T- and W-levels (m) 
     186      !!              w-level: gdepw_1d  = gdep(k) 
     187      !!                       e3w_1d(k) = dk(gdep)(k)     = e3(k) 
     188      !!              t-level: gdept_1d  = gdep(k+0.5) 
     189      !!                       e3t_1d(k) = dk(gdep)(k+0.5) = e3(k+0.5) 
     190      !! 
     191      !! ** Action  : - gdept_1d, gdepw_1d : depth of T- and W-point (m) 
     192      !!              - e3t_1d  , e3w_1d   : scale factors at T- and W-levels (m) 
    193193      !! 
    194194      !! Reference : Marti, Madec & Delecluse, 1992, JGR, 97, No8, 12,763-12,766. 
    … …  
    262262            zw = FLOAT( jk ) 
    263263            zt = FLOAT( jk ) + 0.5_wp 
    264             gdepw_0(jk) = ( zw - 1 ) * za1 
    265             gdept_0(jk) = ( zt - 1 ) * za1 
    266             e3w_0  (jk) =  za1 
    267             e3t_0  (jk) =  za1 
     264            gdepw_1d(jk) = ( zw - 1 ) * za1 
     265            gdept_1d(jk) = ( zt - 1 ) * za1 
     266            e3w_1d  (jk) =  za1 
     267            e3t_1d  (jk) =  za1 
    268268         END DO 
    269269      ELSE                                ! Madec & Imbard 1996 function 
    … …  
    272272               zw = REAL( jk , wp ) 
    273273               zt = REAL( jk , wp ) + 0.5_wp 
    274                gdepw_0(jk) = ( zsur + za0 * zw + za1 * zacr * LOG ( COSH( (zw-zkth) / zacr ) )  ) 
    275                gdept_0(jk) = ( zsur + za0 * zt + za1 * zacr * LOG ( COSH( (zt-zkth) / zacr ) )  ) 
    276                e3w_0  (jk) =          za0      + za1        * TANH(       (zw-zkth) / zacr   ) 
    277                e3t_0  (jk) =          za0      + za1        * TANH(       (zt-zkth) / zacr   ) 
     274               gdepw_1d(jk) = ( zsur + za0 * zw + za1 * zacr * LOG ( COSH( (zw-zkth) / zacr ) )  ) 
     275               gdept_1d(jk) = ( zsur + za0 * zt + za1 * zacr * LOG ( COSH( (zt-zkth) / zacr ) )  ) 
     276               e3w_1d  (jk) =          za0      + za1        * TANH(       (zw-zkth) / zacr   ) 
     277               e3t_1d  (jk) =          za0      + za1        * TANH(       (zt-zkth) / zacr   ) 
    278278            END DO 
    279279         ELSE 
    … …  
    282282               zt = FLOAT( jk ) + 0.5_wp 
    283283               ! Double tanh function 
    284                gdepw_0(jk) = ( zsur + za0 * zw + za1 * zacr * LOG ( COSH( (zw-zkth ) / zacr  ) )    & 
    285                   &                            + za2 * zacr2* LOG ( COSH( (zw-zkth2) / zacr2 ) )  ) 
    286                gdept_0(jk) = ( zsur + za0 * zt + za1 * zacr * LOG ( COSH( (zt-zkth ) / zacr  ) )    & 
    287                   &                            + za2 * zacr2* LOG ( COSH( (zt-zkth2) / zacr2 ) )  ) 
    288                e3w_0  (jk) =          za0      + za1        * TANH(       (zw-zkth ) / zacr  )    & 
    289                   &                            + za2        * TANH(       (zw-zkth2) / zacr2 ) 
    290                e3t_0  (jk) =          za0      + za1        * TANH(       (zt-zkth ) / zacr  )    & 
    291                   &                            + za2        * TANH(       (zt-zkth2) / zacr2 ) 
     284               gdepw_1d(jk) = ( zsur + za0 * zw + za1 * zacr * LOG ( COSH( (zw-zkth ) / zacr  ) )    & 
     285                  &                             + za2 * zacr2* LOG ( COSH( (zw-zkth2) / zacr2 ) )  ) 
     286               gdept_1d(jk) = ( zsur + za0 * zt + za1 * zacr * LOG ( COSH( (zt-zkth ) / zacr  ) )    & 
     287                  &                             + za2 * zacr2* LOG ( COSH( (zt-zkth2) / zacr2 ) )  ) 
     288               e3w_1d  (jk) =          za0      + za1        * TANH(       (zw-zkth ) / zacr  )      & 
     289                  &                             + za2        * TANH(       (zw-zkth2) / zacr2 ) 
     290               e3t_1d  (jk) =          za0      + za1        * TANH(       (zt-zkth ) / zacr  )      & 
     291                  &                             + za2        * TANH(       (zt-zkth2) / zacr2 ) 
    292292            END DO 
    293293         ENDIF 
    294          gdepw_0(1) = 0._wp                    ! force first w-level to be exactly at zero 
     294         gdepw_1d(1) = 0._wp                    ! force first w-level to be exactly at zero 
    295295      ENDIF 
    296296 
    297297!!gm BUG in s-coordinate this does not work! 
    298298      ! deepest/shallowest W level Above/Below ~10m 
    299       zrefdep = 10._wp - 0.1_wp * MINVAL( e3w_0 )                    ! ref. depth with tolerance (10% of minimum layer thickness) 
    300       nlb10 = MINLOC( gdepw_0, mask = gdepw_0 > zrefdep, dim = 1 )  ! shallowest W level Below ~10m 
     299      zrefdep = 10._wp - 0.1_wp * MINVAL( e3w_1d )                   ! ref. depth with tolerance (10% of minimum layer thickness) 
     300      nlb10 = MINLOC( gdepw_1d, mask = gdepw_1d > zrefdep, dim = 1 ) ! shallowest W level Below ~10m 
    301301      nla10 = nlb10 - 1                                              ! deepest    W level Above ~10m 
    302302!!gm end bug 
    … …  
    305305         WRITE(numout,*) 
    306306         WRITE(numout,*) '              Reference z-coordinate depth and scale factors:' 
    307          WRITE(numout, "(9x,' level   gdept    gdepw     e3t      e3w  ')" ) 
    308          WRITE(numout, "(10x, i4, 4f9.2)" ) ( jk, gdept_0(jk), gdepw_0(jk), e3t_0(jk), e3w_0(jk), jk = 1, jpk ) 
     307         WRITE(numout, "(9x,' level  gdept_1d  gdepw_1d  e3t_1d   e3w_1d  ')" ) 
     308         WRITE(numout, "(10x, i4, 4f9.2)" ) ( jk, gdept_1d(jk), gdepw_1d(jk), e3t_1d(jk), e3w_1d(jk), jk = 1, jpk ) 
    309309      ENDIF 
    310310      DO jk = 1, jpk                      ! control positivity 
    311          IF( e3w_0  (jk) <= 0._wp .OR. e3t_0  (jk) <= 0._wp )   CALL ctl_stop( 'dom:zgr_z: e3w or e3t =< 0 '    ) 
    312          IF( gdepw_0(jk) <  0._wp .OR. gdept_0(jk) <  0._wp )   CALL ctl_stop( 'dom:zgr_z: gdepw or gdept < 0 ' ) 
     311         IF( e3w_1d  (jk) <= 0._wp .OR. e3t_1d  (jk) <= 0._wp )   CALL ctl_stop( 'dom:zgr_z: e3w_1d or e3t_1d =< 0 '    ) 
     312         IF( gdepw_1d(jk) <  0._wp .OR. gdept_1d(jk) <  0._wp )   CALL ctl_stop( 'dom:zgr_z: gdepw_1d or gdept_1d < 0 ' ) 
    313313      END DO 
    314314      ! 
    … …  
    382382                  idta(:,:) = jpkm1 
    383383                  DO jk = 1, jpkm1 
    384                      WHERE( gdept_0(jk) < zdta(:,:) .AND. zdta(:,:) <= gdept_0(jk+1) )   idta(:,:) = jk 
     384                     WHERE( gdept_1d(jk) < zdta(:,:) .AND. zdta(:,:) <= gdept_1d(jk+1) )   idta(:,:) = jk 
    385385                  END DO 
    386386               ENDIF 
    … …  
    388388               IF(lwp) WRITE(numout,*) '         Depth = depthw(jpkm1)' 
    389389               idta(:,:) = jpkm1                            ! before last level 
    390                zdta(:,:) = gdepw_0(jpk)                     ! last w-point depth 
    391                h_oce     = gdepw_0(jpk) 
     390               zdta(:,:) = gdepw_1d(jpk)                     ! last w-point depth 
     391               h_oce     = gdepw_1d(jpk) 
    392392            ENDIF 
    393393         ELSE                                         ! bump centered in the basin 
    … …  
    398398            r_bump  = 50000._wp                            ! bump radius (meters)        
    399399            h_bump  =  2700._wp                            ! bump height (meters) 
    400             h_oce   = gdepw_0(jpk)                         ! background ocean depth (meters) 
     400            h_oce   = gdepw_1d(jpk)                        ! background ocean depth (meters) 
    401401            IF(lwp) WRITE(numout,*) '            bump characteristics: ' 
    402402            IF(lwp) WRITE(numout,*) '               bump center (i,j)   = ', ii_bump, ii_bump 
    … …  
    418418               idta(:,:) = jpkm1 
    419419               DO jk = 1, jpkm1 
    420                   WHERE( gdept_0(jk) < zdta(:,:) .AND. zdta(:,:) <= gdept_0(jk+1) )   idta(:,:) = jk 
     420                  WHERE( gdept_1d(jk) < zdta(:,:) .AND. zdta(:,:) <= gdept_1d(jk+1) )   idta(:,:) = jk 
    421421               END DO 
    422422            ENDIF 
    … …  
    460460            CALL iom_close( inum ) 
    461461            mbathy(:,:) = INT( bathy(:,:) ) 
    462             ! 
     462            !                                                ! ===================== 
    463463            IF( cp_cfg == "orca" .AND. jp_cfg == 2 ) THEN    ! ORCA R2 configuration 
    464                ! 
     464               !                                             ! ===================== 
    465465               IF( nn_cla == 0 ) THEN 
    466466                  ii0 = 140   ;   ii1 = 140                  ! Gibraltar Strait open  
    … …  
    531531      IF ( .not. ln_sco ) THEN                                !==  set a minimum depth  ==! 
    532532         IF( rn_hmin < 0._wp ) THEN    ;   ik = - INT( rn_hmin )                                      ! from a nb of level 
    533          ELSE                          ;   ik = MINLOC( gdepw_0, mask = gdepw_0 > rn_hmin, dim = 1 )  ! from a depth 
     533         ELSE                          ;   ik = MINLOC( gdepw_1d, mask = gdepw_1d > rn_hmin, dim = 1 )  ! from a depth 
    534534         ENDIF 
    535          zhmin = gdepw_0(ik+1)                                                         ! minimum depth = ik+1 w-levels  
     535         zhmin = gdepw_1d(ik+1)                                                         ! minimum depth = ik+1 w-levels  
    536536         WHERE( bathy(:,:) <= 0._wp )   ;   bathy(:,:) = 0._wp                         ! min=0     over the lands 
    537537         ELSE WHERE                     ;   bathy(:,:) = MAX(  zhmin , bathy(:,:)  )   ! min=zhmin over the oceans 
    … …  
    798798      ! 
    799799      DO jk = 1, jpk 
    800             gdept(:,:,jk) = gdept_0(jk) 
    801             gdepw(:,:,jk) = gdepw_0(jk) 
    802             gdep3w(:,:,jk) = gdepw_0(jk) 
    803             e3t (:,:,jk) = e3t_0(jk) 
    804             e3u (:,:,jk) = e3t_0(jk) 
    805             e3v (:,:,jk) = e3t_0(jk) 
    806             e3f (:,:,jk) = e3t_0(jk) 
    807             e3w (:,:,jk) = e3w_0(jk) 
    808             e3uw(:,:,jk) = e3w_0(jk) 
    809             e3vw(:,:,jk) = e3w_0(jk) 
     800         gdept_0 (:,:,jk) = gdept_1d(jk) 
     801         gdepw_0 (:,:,jk) = gdepw_1d(jk) 
     802         gdep3w_0(:,:,jk) = gdepw_1d(jk) 
     803         e3t_0   (:,:,jk) = e3t_1d  (jk) 
     804         e3u_0   (:,:,jk) = e3t_1d  (jk) 
     805         e3v_0   (:,:,jk) = e3t_1d  (jk) 
     806         e3f_0   (:,:,jk) = e3t_1d  (jk) 
     807         e3w_0   (:,:,jk) = e3w_1d  (jk) 
     808         e3uw_0  (:,:,jk) = e3w_1d  (jk) 
     809         e3vw_0  (:,:,jk) = e3w_1d  (jk) 
    810810      END DO 
    811811      ! 
    … …  
    832832      !!      with partial steps  on 3d arrays ( i, j, k ). 
    833833      !! 
    834       !!              w-level: gdepw(i,j,k)  = fsdep(k) 
    835       !!                       e3w(i,j,k) = dk(fsdep)(k)     = fse3(i,j,k) 
    836       !!              t-level: gdept(i,j,k)  = fsdep(k+0.5) 
    837       !!                       e3t(i,j,k) = dk(fsdep)(k+0.5) = fse3(i,j,k+0.5) 
     834      !!              w-level: gdepw_0(i,j,k)  = gdep(k) 
     835      !!                       e3w_0(i,j,k) = dk(gdep)(k)     = e3(i,j,k) 
     836      !!              t-level: gdept_0(i,j,k)  = gdep(k+0.5) 
     837      !!                       e3t_0(i,j,k) = dk(gdep)(k+0.5) = e3(i,j,k+0.5) 
    838838      !! 
    839839      !!        With the help of the bathymetric file ( bathymetry_depth_ORCA_R2.nc), 
    … …  
    843843      !!              - bathy = 0 => mbathy = 0 
    844844      !!              - 1 < mbathy < jpkm1     
    845       !!              - bathy > gdepw(jpk) => mbathy = jpkm1   
     845      !!              - bathy > gdepw_0(jpk) => mbathy = jpkm1   
    846846      !! 
    847847      !!        Then, for each case, we find the new depth at t- and w- levels 
    … …  
    855855      !!      schemes. 
    856856      !! 
    857       !!         c a u t i o n : gdept_0, gdepw_0 and e3._0 are positives 
    858       !!         - - - - - - -   gdept, gdepw and e3. are positives 
     857      !!         c a u t i o n : gdept_1d, gdepw_1d and e3._1d are positives 
     858      !!         - - - - - - -   gdept_0, gdepw_0 and e3. are positives 
    859859      !!       
    860860      !!  Reference :   Pacanowsky & Gnanadesikan 1997, Mon. Wea. Rev., 126, 3248-3270. 
    … …  
    892892      ! bathymetry in level (from bathy_meter) 
    893893      ! =================== 
    894       zmax = gdepw_0(jpk) + e3t_0(jpk)          ! maximum depth (i.e. the last ocean level thickness <= 2*e3t_0(jpkm1) ) 
     894      zmax = gdepw_1d(jpk) + e3t_1d(jpk)        ! maximum depth (i.e. the last ocean level thickness <= 2*e3t_1d(jpkm1) ) 
    895895      bathy(:,:) = MIN( zmax ,  bathy(:,:) )    ! bounded value of bathy (min already set at the end of zgr_bat) 
    896896      WHERE( bathy(:,:) == 0._wp )   ;   mbathy(:,:) = 0       ! land  : set mbathy to 0 
    … …  
    900900      ! Compute mbathy for ocean points (i.e. the number of ocean levels) 
    901901      ! find the number of ocean levels such that the last level thickness 
    902       ! is larger than the minimum of e3zps_min and e3zps_rat * e3t_0 (where 
    903       ! e3t_0 is the reference level thickness 
     902      ! is larger than the minimum of e3zps_min and e3zps_rat * e3t_1d (where 
     903      ! e3t_1d is the reference level thickness 
    904904      DO jk = jpkm1, 1, -1 
    905          zdepth = gdepw_0(jk) + MIN( e3zps_min, e3t_0(jk)*e3zps_rat ) 
     905         zdepth = gdepw_1d(jk) + MIN( e3zps_min, e3t_1d(jk)*e3zps_rat ) 
    906906         WHERE( 0._wp < bathy(:,:) .AND. bathy(:,:) <= zdepth )   mbathy(:,:) = jk-1 
    907907      END DO 
    … …  
    909909      ! Scale factors and depth at T- and W-points 
    910910      DO jk = 1, jpk                        ! intitialization to the reference z-coordinate 
    911          gdept(:,:,jk) = gdept_0(jk) 
    912          gdepw(:,:,jk) = gdepw_0(jk) 
    913          e3t  (:,:,jk) = e3t_0  (jk) 
    914          e3w  (:,:,jk) = e3w_0  (jk) 
     911         gdept_0(:,:,jk) = gdept_1d(jk) 
     912         gdepw_0(:,:,jk) = gdepw_1d(jk) 
     913         e3t_0  (:,:,jk) = e3t_1d  (jk) 
     914         e3w_0  (:,:,jk) = e3w_1d  (jk) 
    915915      END DO 
    916916      !  
    … …  
    922922               IF( ik == jpkm1 ) THEN 
    923923                  zdepwp = bathy(ji,jj) 
    924                   ze3tp  = bathy(ji,jj) - gdepw_0(ik) 
    925                   ze3wp = 0.5_wp * e3w_0(ik) * ( 1._wp + ( ze3tp/e3t_0(ik) ) ) 
    926                   e3t(ji,jj,ik  ) = ze3tp 
    927                   e3t(ji,jj,ik+1) = ze3tp 
    928                   e3w(ji,jj,ik  ) = ze3wp 
    929                   e3w(ji,jj,ik+1) = ze3tp 
    930                   gdepw(ji,jj,ik+1) = zdepwp 
    931                   gdept(ji,jj,ik  ) = gdept_0(ik-1) + ze3wp 
    932                   gdept(ji,jj,ik+1) = gdept(ji,jj,ik) + ze3tp 
     924                  ze3tp  = bathy(ji,jj) - gdepw_1d(ik) 
     925                  ze3wp = 0.5_wp * e3w_1d(ik) * ( 1._wp + ( ze3tp/e3t_1d(ik) ) ) 
     926                  e3t_0(ji,jj,ik  ) = ze3tp 
     927                  e3t_0(ji,jj,ik+1) = ze3tp 
     928                  e3w_0(ji,jj,ik  ) = ze3wp 
     929                  e3w_0(ji,jj,ik+1) = ze3tp 
     930                  gdepw_0(ji,jj,ik+1) = zdepwp 
     931                  gdept_0(ji,jj,ik  ) = gdept_1d(ik-1) + ze3wp 
     932                  gdept_0(ji,jj,ik+1) = gdept_0(ji,jj,ik) + ze3tp 
    933933                  ! 
    934934               ELSE                         ! standard case 
    935                   IF( bathy(ji,jj) <= gdepw_0(ik+1) ) THEN   ;   gdepw(ji,jj,ik+1) = bathy(ji,jj) 
    936                   ELSE                                       ;   gdepw(ji,jj,ik+1) = gdepw_0(ik+1) 
     935                  IF( bathy(ji,jj) <= gdepw_1d(ik+1) ) THEN  ;   gdepw_0(ji,jj,ik+1) = bathy(ji,jj) 
     936                  ELSE                                       ;   gdepw_0(ji,jj,ik+1) = gdepw_1d(ik+1) 
    937937                  ENDIF 
    938 !gm Bug?  check the gdepw_0 
     938!gm Bug?  check the gdepw_1d 
    939939                  !       ... on ik 
    940                   gdept(ji,jj,ik) = gdepw_0(ik) + ( gdepw  (ji,jj,ik+1) - gdepw_0(ik) )   & 
    941                      &                          * ((gdept_0(      ik  ) - gdepw_0(ik) )   & 
    942                      &                          / ( gdepw_0(      ik+1) - gdepw_0(ik) )) 
    943                   e3t  (ji,jj,ik) = e3t_0  (ik) * ( gdepw  (ji,jj,ik+1) - gdepw_0(ik) )   &  
    944                      &                          / ( gdepw_0(      ik+1) - gdepw_0(ik) )  
    945                   e3w  (ji,jj,ik) = 0.5_wp * ( gdepw(ji,jj,ik+1) + gdepw_0(ik+1) - 2._wp * gdepw_0(ik) )   & 
    946                      &                     * ( e3w_0(ik) / ( gdepw_0(ik+1) - gdepw_0(ik) ) ) 
     940                  gdept_0(ji,jj,ik) = gdepw_1d(ik) + ( gdepw_0   (ji,jj,ik+1) - gdepw_1d(ik) )   & 
     941                     &                           * ((gdept_1d(      ik  ) - gdepw_1d(ik) )   & 
     942                     &                           / ( gdepw_1d(      ik+1) - gdepw_1d(ik) )) 
     943                  e3t_0(ji,jj,ik) = e3t_1d (ik) * ( gdepw_0 (ji,jj,ik+1) - gdepw_1d(ik) )   &  
     944                     &                          / ( gdepw_1d(      ik+1) - gdepw_1d(ik) )  
     945                  e3w_0(ji,jj,ik) = 0.5_wp * ( gdepw_0(ji,jj,ik+1) + gdepw_1d(ik+1) - 2._wp * gdepw_1d(ik) )   & 
     946                     &                     * ( e3w_1d(ik) / ( gdepw_1d(ik+1) - gdepw_1d(ik) ) ) 
    947947                  !       ... on ik+1 
    948                   e3w  (ji,jj,ik+1) = e3t  (ji,jj,ik) 
    949                   e3t  (ji,jj,ik+1) = e3t  (ji,jj,ik) 
    950                   gdept(ji,jj,ik+1) = gdept(ji,jj,ik) + e3t(ji,jj,ik) 
     948                  e3w_0  (ji,jj,ik+1) = e3t_0  (ji,jj,ik) 
     949                  e3t_0  (ji,jj,ik+1) = e3t_0  (ji,jj,ik) 
     950                  gdept_0(ji,jj,ik+1) = gdept_0(ji,jj,ik) + e3t_0(ji,jj,ik) 
    951951               ENDIF 
    952952            ENDIF 
    … …  
    959959            ik = mbathy(ji,jj) 
    960960            IF( ik > 0 ) THEN               ! ocean point only 
    961                e3tp (ji,jj) = e3t(ji,jj,ik  ) 
    962                e3wp (ji,jj) = e3w(ji,jj,ik  ) 
     961               e3tp (ji,jj) = e3t_0(ji,jj,ik) 
     962               e3wp (ji,jj) = e3w_0(ji,jj,ik) 
    963963               ! test 
    964                zdiff= gdepw(ji,jj,ik+1) - gdept(ji,jj,ik  ) 
     964               zdiff= gdepw_0(ji,jj,ik+1) - gdept_0(ji,jj,ik  ) 
    965965               IF( zdiff <= 0._wp .AND. lwp ) THEN  
    966966                  it = it + 1 
    967967                  WRITE(numout,*) ' it      = ', it, ' ik      = ', ik, ' (i,j) = ', ji, jj 
    968968                  WRITE(numout,*) ' bathy = ', bathy(ji,jj) 
    969                   WRITE(numout,*) ' gdept = ', gdept(ji,jj,ik), ' gdepw = ', gdepw(ji,jj,ik+1), ' zdiff = ', zdiff 
    970                   WRITE(numout,*) ' e3tp  = ', e3t  (ji,jj,ik), ' e3wp  = ', e3w  (ji,jj,ik  ) 
     969                  WRITE(numout,*) ' gdept_0 = ', gdept_0(ji,jj,ik), ' gdepw_0 = ', gdepw_0(ji,jj,ik+1), ' zdiff = ', zdiff 
     970                  WRITE(numout,*) ' e3tp    = ', e3t_0  (ji,jj,ik), ' e3wp    = ', e3w_0  (ji,jj,ik  ) 
    971971               ENDIF 
    972972            ENDIF 
    … …  
    976976      ! Scale factors and depth at U-, V-, UW and VW-points 
    977977      DO jk = 1, jpk                        ! initialisation to z-scale factors 
    978          e3u (:,:,jk) = e3t_0(jk) 
    979          e3v (:,:,jk) = e3t_0(jk) 
    980          e3uw(:,:,jk) = e3w_0(jk) 
    981          e3vw(:,:,jk) = e3w_0(jk) 
     978         e3u_0 (:,:,jk) = e3t_1d(jk) 
     979         e3v_0 (:,:,jk) = e3t_1d(jk) 
     980         e3uw_0(:,:,jk) = e3w_1d(jk) 
     981         e3vw_0(:,:,jk) = e3w_1d(jk) 
    982982      END DO 
    983983      DO jk = 1,jpk                         ! Computed as the minimum of neighbooring scale factors 
    984984         DO jj = 1, jpjm1 
    985985            DO ji = 1, fs_jpim1   ! vector opt. 
    986                e3u (ji,jj,jk) = MIN( e3t(ji,jj,jk), e3t(ji+1,jj,jk) ) 
    987                e3v (ji,jj,jk) = MIN( e3t(ji,jj,jk), e3t(ji,jj+1,jk) ) 
    988                e3uw(ji,jj,jk) = MIN( e3w(ji,jj,jk), e3w(ji+1,jj,jk) ) 
    989                e3vw(ji,jj,jk) = MIN( e3w(ji,jj,jk), e3w(ji,jj+1,jk) ) 
    990             END DO 
    991          END DO 
    992       END DO 
    993       CALL lbc_lnk( e3u , 'U', 1._wp )   ;   CALL lbc_lnk( e3uw, 'U', 1._wp )   ! lateral boundary conditions 
    994       CALL lbc_lnk( e3v , 'V', 1._wp )   ;   CALL lbc_lnk( e3vw, 'V', 1._wp ) 
     986               e3u_0 (ji,jj,jk) = MIN( e3t_0(ji,jj,jk), e3t_0(ji+1,jj,jk) ) 
     987               e3v_0 (ji,jj,jk) = MIN( e3t_0(ji,jj,jk), e3t_0(ji,jj+1,jk) ) 
     988               e3uw_0(ji,jj,jk) = MIN( e3w_0(ji,jj,jk), e3w_0(ji+1,jj,jk) ) 
     989               e3vw_0(ji,jj,jk) = MIN( e3w_0(ji,jj,jk), e3w_0(ji,jj+1,jk) ) 
     990            END DO 
     991         END DO 
     992      END DO 
     993      CALL lbc_lnk( e3u_0 , 'U', 1._wp )   ;   CALL lbc_lnk( e3uw_0, 'U', 1._wp )   ! lateral boundary conditions 
     994      CALL lbc_lnk( e3v_0 , 'V', 1._wp )   ;   CALL lbc_lnk( e3vw_0, 'V', 1._wp ) 
    995995      ! 
    996996      DO jk = 1, jpk                        ! set to z-scale factor if zero (i.e. along closed boundaries) 
    997          WHERE( e3u (:,:,jk) == 0._wp )   e3u (:,:,jk) = e3t_0(jk) 
    998          WHERE( e3v (:,:,jk) == 0._wp )   e3v (:,:,jk) = e3t_0(jk) 
    999          WHERE( e3uw(:,:,jk) == 0._wp )   e3uw(:,:,jk) = e3w_0(jk) 
    1000          WHERE( e3vw(:,:,jk) == 0._wp )   e3vw(:,:,jk) = e3w_0(jk) 
     997         WHERE( e3u_0 (:,:,jk) == 0._wp )   e3u_0 (:,:,jk) = e3t_1d(jk) 
     998         WHERE( e3v_0 (:,:,jk) == 0._wp )   e3v_0 (:,:,jk) = e3t_1d(jk) 
     999         WHERE( e3uw_0(:,:,jk) == 0._wp )   e3uw_0(:,:,jk) = e3w_1d(jk) 
     1000         WHERE( e3vw_0(:,:,jk) == 0._wp )   e3vw_0(:,:,jk) = e3w_1d(jk) 
    10011001      END DO 
    10021002       
    10031003      ! Scale factor at F-point 
    10041004      DO jk = 1, jpk                        ! initialisation to z-scale factors 
    1005          e3f(:,:,jk) = e3t_0(jk) 
     1005         e3f_0(:,:,jk) = e3t_1d(jk) 
    10061006      END DO 
    10071007      DO jk = 1, jpk                        ! Computed as the minimum of neighbooring V-scale factors 
    10081008         DO jj = 1, jpjm1 
    10091009            DO ji = 1, fs_jpim1   ! vector opt. 
    1010                e3f(ji,jj,jk) = MIN( e3v(ji,jj,jk), e3v(ji+1,jj,jk) ) 
    1011             END DO 
    1012          END DO 
    1013       END DO 
    1014       CALL lbc_lnk( e3f, 'F', 1._wp )       ! Lateral boundary conditions 
     1010               e3f_0(ji,jj,jk) = MIN( e3v_0(ji,jj,jk), e3v_0(ji+1,jj,jk) ) 
     1011            END DO 
     1012         END DO 
     1013      END DO 
     1014      CALL lbc_lnk( e3f_0, 'F', 1._wp )       ! Lateral boundary conditions 
    10151015      ! 
    10161016      DO jk = 1, jpk                        ! set to z-scale factor if zero (i.e. along closed boundaries) 
    1017          WHERE( e3f(:,:,jk) == 0._wp )   e3f(:,:,jk) = e3t_0(jk) 
     1017         WHERE( e3f_0(:,:,jk) == 0._wp )   e3f_0(:,:,jk) = e3t_1d(jk) 
    10181018      END DO 
    10191019!!gm  bug ? :  must be a do loop with mj0,mj1 
    10201020      !  
    1021       e3t(:,mj0(1),:) = e3t(:,mj0(2),:)     ! we duplicate factor scales for jj = 1 and jj = 2 
    1022       e3w(:,mj0(1),:) = e3w(:,mj0(2),:)  
    1023       e3u(:,mj0(1),:) = e3u(:,mj0(2),:)  
    1024       e3v(:,mj0(1),:) = e3v(:,mj0(2),:)  
    1025       e3f(:,mj0(1),:) = e3f(:,mj0(2),:)  
     1021      e3t_0(:,mj0(1),:) = e3t_0(:,mj0(2),:)     ! we duplicate factor scales for jj = 1 and jj = 2 
     1022      e3w_0(:,mj0(1),:) = e3w_0(:,mj0(2),:)  
     1023      e3u_0(:,mj0(1),:) = e3u_0(:,mj0(2),:)  
     1024      e3v_0(:,mj0(1),:) = e3v_0(:,mj0(2),:)  
     1025      e3f_0(:,mj0(1),:) = e3f_0(:,mj0(2),:)  
    10261026 
    10271027      ! Control of the sign 
    1028       IF( MINVAL( e3t  (:,:,:) ) <= 0._wp )   CALL ctl_stop( '    zgr_zps :   e r r o r   e3t  <= 0' ) 
    1029       IF( MINVAL( e3w  (:,:,:) ) <= 0._wp )   CALL ctl_stop( '    zgr_zps :   e r r o r   e3w  <= 0' ) 
    1030       IF( MINVAL( gdept(:,:,:) ) <  0._wp )   CALL ctl_stop( '    zgr_zps :   e r r o r   gdepw <  0' ) 
    1031       IF( MINVAL( gdepw(:,:,:) ) <  0._wp )   CALL ctl_stop( '    zgr_zps :   e r r o r   gdepw <  0' ) 
     1028      IF( MINVAL( e3t_0  (:,:,:) ) <= 0._wp )   CALL ctl_stop( '    zgr_zps :   e r r o r   e3t_0 <= 0' ) 
     1029      IF( MINVAL( e3w_0  (:,:,:) ) <= 0._wp )   CALL ctl_stop( '    zgr_zps :   e r r o r   e3w_0 <= 0' ) 
     1030      IF( MINVAL( gdept_0(:,:,:) ) <  0._wp )   CALL ctl_stop( '    zgr_zps :   e r r o r   gdept_0 <  0' ) 
     1031      IF( MINVAL( gdepw_0(:,:,:) ) <  0._wp )   CALL ctl_stop( '    zgr_zps :   e r r o r   gdepw_0 <  0' ) 
    10321032      
    1033       ! Compute gdep3w (vertical sum of e3w) 
    1034       gdep3w(:,:,1) = 0.5_wp * e3w(:,:,1) 
     1033      ! Compute gdep3w_0 (vertical sum of e3w) 
     1034      gdep3w_0(:,:,1) = 0.5_wp * e3w_0(:,:,1) 
    10351035      DO jk = 2, jpk 
    1036          gdep3w(:,:,jk) = gdep3w(:,:,jk-1) + e3w(:,:,jk)  
     1036         gdep3w_0(:,:,jk) = gdep3w_0(:,:,jk-1) + e3w_0(:,:,jk)  
    10371037      END DO 
    10381038         
    … …  
    10431043            DO ji = 1, jpi 
    10441044               ik = MAX( mbathy(ji,jj), 1 ) 
    1045                zprt(ji,jj,1) = e3t   (ji,jj,ik) 
    1046                zprt(ji,jj,2) = e3w   (ji,jj,ik) 
    1047                zprt(ji,jj,3) = e3u   (ji,jj,ik) 
    1048                zprt(ji,jj,4) = e3v   (ji,jj,ik) 
    1049                zprt(ji,jj,5) = e3f   (ji,jj,ik) 
    1050                zprt(ji,jj,6) = gdep3w(ji,jj,ik) 
     1045               zprt(ji,jj,1) = e3t_0   (ji,jj,ik) 
     1046               zprt(ji,jj,2) = e3w_0   (ji,jj,ik) 
     1047               zprt(ji,jj,3) = e3u_0   (ji,jj,ik) 
     1048               zprt(ji,jj,4) = e3v_0   (ji,jj,ik) 
     1049               zprt(ji,jj,5) = e3f_0   (ji,jj,ik) 
     1050               zprt(ji,jj,6) = gdep3w_0(ji,jj,ik) 
    10511051            END DO 
    10521052         END DO 
    … …  
    13871387      ENDIF  
    13881388 
    1389       CALL lbc_lnk( e3t , 'T', 1._wp ) 
    1390       CALL lbc_lnk( e3u , 'U', 1._wp ) 
    1391       CALL lbc_lnk( e3v , 'V', 1._wp ) 
    1392       CALL lbc_lnk( e3f , 'F', 1._wp ) 
    1393       CALL lbc_lnk( e3w , 'W', 1._wp ) 
    1394       CALL lbc_lnk( e3uw, 'U', 1._wp ) 
    1395       CALL lbc_lnk( e3vw, 'V', 1._wp ) 
    1396  
    1397       fsdepw(:,:,:) = gdepw (:,:,:) 
    1398       fsde3w(:,:,:) = gdep3w(:,:,:) 
    1399       ! 
    1400       where (e3t   (:,:,:).eq.0.0)  e3t(:,:,:) = 1._wp 
    1401       where (e3u   (:,:,:).eq.0.0)  e3u(:,:,:) = 1._wp 
    1402       where (e3v   (:,:,:).eq.0.0)  e3v(:,:,:) = 1._wp 
    1403       where (e3f   (:,:,:).eq.0.0)  e3f(:,:,:) = 1._wp 
    1404       where (e3w   (:,:,:).eq.0.0)  e3w(:,:,:) = 1._wp 
    1405       where (e3uw  (:,:,:).eq.0.0)  e3uw(:,:,:) = 1._wp 
    1406       where (e3vw  (:,:,:).eq.0.0)  e3vw(:,:,:) = 1._wp 
     1389      CALL lbc_lnk( e3t_0 , 'T', 1._wp ) 
     1390      CALL lbc_lnk( e3u_0 , 'U', 1._wp ) 
     1391      CALL lbc_lnk( e3v_0 , 'V', 1._wp ) 
     1392      CALL lbc_lnk( e3f_0 , 'F', 1._wp ) 
     1393      CALL lbc_lnk( e3w_0 , 'W', 1._wp ) 
     1394      CALL lbc_lnk( e3uw_0, 'U', 1._wp ) 
     1395      CALL lbc_lnk( e3vw_0, 'V', 1._wp ) 
     1396 
     1397      fsdepw(:,:,:) = gdepw_0 (:,:,:) 
     1398      fsde3w(:,:,:) = gdep3w_0(:,:,:) 
     1399      ! 
     1400      where (e3t_0   (:,:,:).eq.0.0)  e3t_0(:,:,:) = 1.0 
     1401      where (e3u_0   (:,:,:).eq.0.0)  e3u_0(:,:,:) = 1.0 
     1402      where (e3v_0   (:,:,:).eq.0.0)  e3v_0(:,:,:) = 1.0 
     1403      where (e3f_0   (:,:,:).eq.0.0)  e3f_0(:,:,:) = 1.0 
     1404      where (e3w_0   (:,:,:).eq.0.0)  e3w_0(:,:,:) = 1.0 
     1405      where (e3uw_0  (:,:,:).eq.0.0)  e3uw_0(:,:,:) = 1.0 
     1406      where (e3vw_0  (:,:,:).eq.0.0)  e3vw_0(:,:,:) = 1.0 
    14071407 
    14081408#if defined key_agrif 
    … …  
    14111411         !   
    14121412         IF((nbondi == -1).OR.(nbondi == 2)) THEN 
    1413             e3u(1,:,:) = e3u(2,:,:) 
     1413            e3u_0(1,:,:) = e3u_0(2,:,:) 
    14141414         ENDIF 
    14151415         ! 
    14161416         IF((nbondi ==  1).OR.(nbondi == 2)) THEN 
    1417             e3u(nlci-1,:,:) = e3u(nlci-2,:,:) 
     1417            e3u_0(nlci-1,:,:) = e3u_0(nlci-2,:,:) 
    14181418         ENDIF 
    14191419         ! 
    14201420         IF((nbondj == -1).OR.(nbondj == 2)) THEN 
    1421             e3v(:,1,:) = e3v(:,2,:) 
     1421            e3v_0(:,1,:) = e3v_0(:,2,:) 
    14221422         ENDIF 
    14231423         ! 
    14241424         IF((nbondj ==  1).OR.(nbondj == 2)) THEN 
    1425             e3v(:,nlcj-1,:) = e3v(:,nlcj-2,:) 
     1425            e3v_0(:,nlcj-1,:) = e3v_0(:,nlcj-2,:) 
    14261426         ENDIF 
    14271427         ! 
    … …  
    14291429#endif 
    14301430 
    1431       fsdept(:,:,:) = gdept (:,:,:) 
    1432       fsdepw(:,:,:) = gdepw (:,:,:) 
    1433       fsde3w(:,:,:) = gdep3w(:,:,:) 
    1434       fse3t (:,:,:) = e3t   (:,:,:) 
    1435       fse3u (:,:,:) = e3u   (:,:,:) 
    1436       fse3v (:,:,:) = e3v   (:,:,:) 
    1437       fse3f (:,:,:) = e3f   (:,:,:) 
    1438       fse3w (:,:,:) = e3w   (:,:,:) 
    1439       fse3uw(:,:,:) = e3uw  (:,:,:) 
    1440       fse3vw(:,:,:) = e3vw  (:,:,:) 
     1431      fsdept(:,:,:) = gdept_0 (:,:,:) 
     1432      fsdepw(:,:,:) = gdepw_0 (:,:,:) 
     1433      fsde3w(:,:,:) = gdep3w_0(:,:,:) 
     1434      fse3t (:,:,:) = e3t_0   (:,:,:) 
     1435      fse3u (:,:,:) = e3u_0   (:,:,:) 
     1436      fse3v (:,:,:) = e3v_0   (:,:,:) 
     1437      fse3f (:,:,:) = e3f_0   (:,:,:) 
     1438      fse3w (:,:,:) = e3w_0   (:,:,:) 
     1439      fse3uw(:,:,:) = e3uw_0  (:,:,:) 
     1440      fse3vw(:,:,:) = e3vw_0  (:,:,:) 
    14411441!! 
    14421442      ! HYBRID :  
    … …  
    14531453 
    14541454      IF( nprint == 1  .AND. lwp )   THEN         ! min max values over the local domain 
    1455          WRITE(numout,*) ' MIN val mbathy  ', MINVAL( mbathy(:,:)   ), ' MAX ', MAXVAL( mbathy(:,:) ) 
    1456          WRITE(numout,*) ' MIN val depth t ', MINVAL( fsdept(:,:,:) ),   & 
    1457             &                          ' w ', MINVAL( fsdepw(:,:,:) ), '3w '  , MINVAL( fsde3w(:,:,:) ) 
    1458          WRITE(numout,*) ' MIN val e3    t ', MINVAL( fse3t (:,:,:) ), ' f '  , MINVAL( fse3f (:,:,:) ),   & 
    1459             &                          ' u ', MINVAL( fse3u (:,:,:) ), ' u '  , MINVAL( fse3v (:,:,:) ),   & 
    1460             &                          ' uw', MINVAL( fse3uw(:,:,:) ), ' vw'  , MINVAL( fse3vw(:,:,:) ),   & 
    1461             &                          ' w ', MINVAL( fse3w (:,:,:) ) 
    1462  
    1463          WRITE(numout,*) ' MAX val depth t ', MAXVAL( fsdept(:,:,:) ),   & 
    1464             &                          ' w ', MAXVAL( fsdepw(:,:,:) ), '3w '  , MAXVAL( fsde3w(:,:,:) ) 
    1465          WRITE(numout,*) ' MAX val e3    t ', MAXVAL( fse3t (:,:,:) ), ' f '  , MAXVAL( fse3f (:,:,:) ),   & 
    1466             &                          ' u ', MAXVAL( fse3u (:,:,:) ), ' u '  , MAXVAL( fse3v (:,:,:) ),   & 
    1467             &                          ' uw', MAXVAL( fse3uw(:,:,:) ), ' vw'  , MAXVAL( fse3vw(:,:,:) ),   & 
    1468             &                          ' w ', MAXVAL( fse3w (:,:,:) ) 
     1455         WRITE(numout,*) ' MIN val mbathy  ', MINVAL( mbathy(:,:)    ), ' MAX ', MAXVAL( mbathy(:,:) ) 
     1456         WRITE(numout,*) ' MIN val depth t ', MINVAL( gdept_0(:,:,:) ),   & 
     1457            &                          ' w ', MINVAL( gdepw_0(:,:,:) ), '3w '  , MINVAL( gdep3w_0(:,:,:) ) 
     1458         WRITE(numout,*) ' MIN val e3    t ', MINVAL( e3t_0  (:,:,:) ), ' f '  , MINVAL( e3f_0  (:,:,:) ),   & 
     1459            &                          ' u ', MINVAL( e3u_0  (:,:,:) ), ' u '  , MINVAL( e3v_0  (:,:,:) ),   & 
     1460            &                          ' uw', MINVAL( e3uw_0 (:,:,:) ), ' vw'  , MINVAL( e3vw_0  (:,:,:) ),   & 
     1461            &                          ' w ', MINVAL( e3w_0 (:,:,:) ) 
     1462 
     1463         WRITE(numout,*) ' MAX val depth t ', MAXVAL( gdept_0(:,:,:) ),   & 
     1464            &                          ' w ', MAXVAL( gdepw_0(:,:,:) ), '3w '  , MAXVAL( gdep3w_0(:,:,:) ) 
     1465         WRITE(numout,*) ' MAX val e3    t ', MAXVAL( e3t_0  (:,:,:) ), ' f '  , MAXVAL( e3f_0  (:,:,:) ),   & 
     1466            &                          ' u ', MAXVAL( e3u_0  (:,:,:) ), ' u '  , MAXVAL( e3v_0  (:,:,:) ),   & 
     1467            &                          ' uw', MAXVAL( e3uw_0 (:,:,:) ), ' vw'  , MAXVAL( e3vw_0  (:,:,:) ),   & 
     1468            &                          ' w ', MAXVAL( e3w_0 (:,:,:) ) 
    14691469      ENDIF 
    14701470      !  END DO 
    … …  
    14731473         WRITE(numout,*) ' domzgr: vertical coordinates : point (1,1,k) bathy = ', bathy(1,1), hbatt(1,1) 
    14741474         WRITE(numout,*) ' ~~~~~~  --------------------' 
    1475          WRITE(numout,"(9x,' level   gdept    gdepw    gde3w     e3t      e3w  ')") 
    1476          WRITE(numout,"(10x,i4,4f9.2)") ( jk, fsdept(1,1,jk), fsdepw(1,1,jk),     & 
    1477             &                                 fse3t (1,1,jk), fse3w (1,1,jk), jk=1,jpk ) 
    1478          iip1 = MIN(20, jpiglo-1)  ! for config with i smaller than 20 points 
    1479          ijp1 = MIN(20, jpjglo-1)  ! for config with j smaller than 20 points 
    1480          DO jj = mj0(ijp1), mj1(ijp1) 
    1481             DO ji = mi0(iip1), mi1(iip1) 
     1475         WRITE(numout,"(9x,' level  gdept_0   gdepw_0   e3t_0    e3w_0')") 
     1476         WRITE(numout,"(10x,i4,4f9.2)") ( jk, gdept_0(1,1,jk), gdepw_0(1,1,jk),     & 
     1477            &                                 e3t_0 (1,1,jk) , e3w_0 (1,1,jk) , jk=1,jpk ) 
     1478         DO jj = mj0(20), mj1(20) 
     1479            DO ji = mi0(20), mi1(20) 
    14821480               WRITE(numout,*) 
    1483                WRITE(numout,*) ' domzgr: vertical coordinates : point (',iip1,',',ijp1,',k)   bathy = ',  & 
    1484                   &                                              bathy(ji,jj), hbatt(ji,jj) 
     1481               WRITE(numout,*) ' domzgr: vertical coordinates : point (20,20,k)   bathy = ', bathy(ji,jj), hbatt(ji,jj) 
    14851482               WRITE(numout,*) ' ~~~~~~  --------------------' 
    1486                WRITE(numout,"(9x,' level   gdept    gdepw    gde3w     e3t      e3w  ')") 
    1487                WRITE(numout,"(10x,i4,4f9.2)") ( jk, fsdept(ji,jj,jk), fsdepw(ji,jj,jk),     & 
    1488                   &                                 fse3t (ji,jj,jk), fse3w (ji,jj,jk), jk=1,jpk ) 
    1489             END DO 
    1490          END DO 
    1491          iip1 = MIN(  74, jpiglo-1) 
    1492          ijp1 = MIN( 100, jpjglo-1) 
    1493          DO jj = mj0(ijp1), mj1(ijp1) 
    1494             DO ji = mi0(iip1), mi1(iip1) 
     1483               WRITE(numout,"(9x,' level  gdept_0   gdepw_0   e3t_0    e3w_0')") 
     1484               WRITE(numout,"(10x,i4,4f9.2)") ( jk, gdept_0(ji,jj,jk), gdepw_0(ji,jj,jk),     & 
     1485                  &                                 e3t_0 (ji,jj,jk) , e3w_0 (ji,jj,jk) , jk=1,jpk ) 
     1486            END DO 
     1487         END DO 
     1488         DO jj = mj0(74), mj1(74) 
     1489            DO ji = mi0(100), mi1(100) 
    14951490               WRITE(numout,*) 
    1496                WRITE(numout,*) ' domzgr: vertical coordinates : point (',iip1,',',ijp1,',k)   bathy = ',  & 
    1497                   &                                              bathy(ji,jj), hbatt(ji,jj) 
     1491               WRITE(numout,*) ' domzgr: vertical coordinates : point (100,74,k)   bathy = ', bathy(ji,jj), hbatt(ji,jj) 
    14981492               WRITE(numout,*) ' ~~~~~~  --------------------' 
    1499                WRITE(numout,"(9x,' level   gdept    gdepw    gde3w     e3t      e3w  ')") 
    1500                WRITE(numout,"(10x,i4,4f9.2)") ( jk, fsdept(ji,jj,jk), fsdepw(ji,jj,jk),     & 
    1501                   &                                 fse3t (ji,jj,jk), fse3w (ji,jj,jk), jk=1,jpk ) 
     1493               WRITE(numout,"(9x,' level  gdept_0   gdepw_0   e3t_0    e3w_0')") 
     1494               WRITE(numout,"(10x,i4,4f9.2)") ( jk, gdept_0(ji,jj,jk), gdepw_0(ji,jj,jk),     & 
     1495                  &                                 e3t_0 (ji,jj,jk) , e3w_0 (ji,jj,jk) , jk=1,jpk ) 
    15021496            END DO 
    15031497         END DO 
    … …  
    16171611               zcoeft = ( REAL(jk,wp) - 0.5_wp ) / REAL(jpkm1,wp) 
    16181612               zcoefw = ( REAL(jk,wp) - 1.0_wp ) / REAL(jpkm1,wp) 
    1619                gdept (ji,jj,jk) = ( scosrf(ji,jj) + (hbatt(ji,jj)-rn_hc)*z_gsigt3(ji,jj,jk)+rn_hc*zcoeft ) 
    1620                gdepw (ji,jj,jk) = ( scosrf(ji,jj) + (hbatt(ji,jj)-rn_hc)*z_gsigw3(ji,jj,jk)+rn_hc*zcoefw ) 
    1621                gdep3w(ji,jj,jk) = ( scosrf(ji,jj) + (hbatt(ji,jj)-rn_hc)*z_gsi3w3(ji,jj,jk)+rn_hc*zcoeft ) 
     1613               gdept_0 (ji,jj,jk) = ( scosrf(ji,jj) + (hbatt(ji,jj)-rn_hc)*z_gsigt3(ji,jj,jk)+rn_hc*zcoeft ) 
     1614               gdepw_0 (ji,jj,jk) = ( scosrf(ji,jj) + (hbatt(ji,jj)-rn_hc)*z_gsigw3(ji,jj,jk)+rn_hc*zcoefw ) 
     1615               gdep3w_0(ji,jj,jk) = ( scosrf(ji,jj) + (hbatt(ji,jj)-rn_hc)*z_gsi3w3(ji,jj,jk)+rn_hc*zcoeft ) 
    16221616            END DO 
    16231617           ! 
    … …  
    16401634                  &              / ( hbatt(ji,jj)+hbatt(ji,jj+1) ) 
    16411635               ! 
    1642                e3t(ji,jj,jk) = ( (hbatt(ji,jj)-rn_hc)*z_esigt3 (ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) 
    1643                e3u(ji,jj,jk) = ( (hbatu(ji,jj)-rn_hc)*z_esigtu3(ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) 
    1644                e3v(ji,jj,jk) = ( (hbatv(ji,jj)-rn_hc)*z_esigtv3(ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) 
    1645                e3f(ji,jj,jk) = ( (hbatf(ji,jj)-rn_hc)*z_esigtf3(ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) 
     1636               e3t_0(ji,jj,jk) = ( (hbatt(ji,jj)-rn_hc)*z_esigt3 (ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) 
     1637               e3u_0(ji,jj,jk) = ( (hbatu(ji,jj)-rn_hc)*z_esigtu3(ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) 
     1638               e3v_0(ji,jj,jk) = ( (hbatv(ji,jj)-rn_hc)*z_esigtv3(ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) 
     1639               e3f_0(ji,jj,jk) = ( (hbatf(ji,jj)-rn_hc)*z_esigtf3(ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) 
    16461640               ! 
    1647                e3w (ji,jj,jk) = ( (hbatt(ji,jj)-rn_hc)*z_esigw3 (ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) 
    1648                e3uw(ji,jj,jk) = ( (hbatu(ji,jj)-rn_hc)*z_esigwu3(ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) 
    1649                e3vw(ji,jj,jk) = ( (hbatv(ji,jj)-rn_hc)*z_esigwv3(ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) 
     1641               e3w_0 (ji,jj,jk) = ( (hbatt(ji,jj)-rn_hc)*z_esigw3 (ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) 
     1642               e3uw_0(ji,jj,jk) = ( (hbatu(ji,jj)-rn_hc)*z_esigwu3(ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) 
     1643               e3vw_0(ji,jj,jk) = ( (hbatv(ji,jj)-rn_hc)*z_esigwv3(ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) 
    16501644            END DO 
    16511645        END DO 
    … …  
    17451739 
    17461740          DO jk = 1, jpk 
    1747              gdept (ji,jj,jk) = (scosrf(ji,jj)+hbatt(ji,jj))*z_gsigt3(ji,jj,jk) 
    1748              gdepw (ji,jj,jk) = (scosrf(ji,jj)+hbatt(ji,jj))*z_gsigw3(ji,jj,jk) 
    1749              gdep3w(ji,jj,jk) = (scosrf(ji,jj)+hbatt(ji,jj))*z_gsi3w3(ji,jj,jk) 
     1741             gdept_0 (ji,jj,jk) = (scosrf(ji,jj)+hbatt(ji,jj))*z_gsigt3(ji,jj,jk) 
     1742             gdepw_0 (ji,jj,jk) = (scosrf(ji,jj)+hbatt(ji,jj))*z_gsigw3(ji,jj,jk) 
     1743             gdep3w_0(ji,jj,jk) = (scosrf(ji,jj)+hbatt(ji,jj))*z_gsi3w3(ji,jj,jk) 
    17501744          END DO 
    17511745 
    … …  
    17691763                                    ( hbatt(ji,jj)+hbatt(ji,jj+1) ) 
    17701764 
    1771              e3t(ji,jj,jk)=(scosrf(ji,jj)+hbatt(ji,jj))*z_esigt3(ji,jj,jk) 
    1772              e3u(ji,jj,jk)=(scosrf(ji,jj)+hbatu(ji,jj))*z_esigtu3(ji,jj,jk) 
    1773              e3v(ji,jj,jk)=(scosrf(ji,jj)+hbatv(ji,jj))*z_esigtv3(ji,jj,jk) 
    1774              e3f(ji,jj,jk)=(scosrf(ji,jj)+hbatf(ji,jj))*z_esigtf3(ji,jj,jk) 
     1765             e3t_0(ji,jj,jk)=(scosrf(ji,jj)+hbatt(ji,jj))*z_esigt3(ji,jj,jk) 
     1766             e3u_0(ji,jj,jk)=(scosrf(ji,jj)+hbatu(ji,jj))*z_esigtu3(ji,jj,jk) 
     1767             e3v_0(ji,jj,jk)=(scosrf(ji,jj)+hbatv(ji,jj))*z_esigtv3(ji,jj,jk) 
     1768             e3f_0(ji,jj,jk)=(scosrf(ji,jj)+hbatf(ji,jj))*z_esigtf3(ji,jj,jk) 
    17751769             ! 
    1776              e3w(ji,jj,jk)=hbatt(ji,jj)*z_esigw3(ji,jj,jk) 
    1777              e3uw(ji,jj,jk)=hbatu(ji,jj)*z_esigwu3(ji,jj,jk) 
    1778              e3vw(ji,jj,jk)=hbatv(ji,jj)*z_esigwv3(ji,jj,jk) 
     1770             e3w_0(ji,jj,jk)=hbatt(ji,jj)*z_esigw3(ji,jj,jk) 
     1771             e3uw_0(ji,jj,jk)=hbatu(ji,jj)*z_esigwu3(ji,jj,jk) 
     1772             e3vw_0(ji,jj,jk)=hbatv(ji,jj)*z_esigwv3(ji,jj,jk) 
    17791773          END DO 
    17801774 
    17811775        ENDDO 
    17821776      ENDDO 
     1777      ! 
     1778      CALL lbc_lnk(e3t_0 ,'T',1.) ; CALL lbc_lnk(e3u_0 ,'T',1.) 
     1779      CALL lbc_lnk(e3v_0 ,'T',1.) ; CALL lbc_lnk(e3f_0 ,'T',1.) 
     1780      CALL lbc_lnk(e3w_0 ,'T',1.) 
     1781      CALL lbc_lnk(e3uw_0,'T',1.) ; CALL lbc_lnk(e3vw_0,'T',1.) 
    17831782      ! 
    17841783      !                                               ! ============= 
    … …  
    18381837         zcoeft = ( REAL(jk,wp) - 0.5_wp ) / REAL(jpkm1,wp) 
    18391838         zcoefw = ( REAL(jk,wp) - 1.0_wp ) / REAL(jpkm1,wp) 
    1840          gdept (:,:,jk) = ( scosrf(:,:) + (hbatt(:,:)-hift(:,:))*z_gsigt(jk) + hift(:,:)*zcoeft ) 
    1841          gdepw (:,:,jk) = ( scosrf(:,:) + (hbatt(:,:)-hift(:,:))*z_gsigw(jk) + hift(:,:)*zcoefw ) 
    1842          gdep3w(:,:,jk) = ( scosrf(:,:) + (hbatt(:,:)-hift(:,:))*z_gsi3w(jk) + hift(:,:)*zcoeft ) 
     1839         gdept_0 (:,:,jk) = ( scosrf(:,:) + (hbatt(:,:)-hift(:,:))*z_gsigt(jk) + hift(:,:)*zcoeft ) 
     1840         gdepw_0 (:,:,jk) = ( scosrf(:,:) + (hbatt(:,:)-hift(:,:))*z_gsigw(jk) + hift(:,:)*zcoefw ) 
     1841         gdep3w_0(:,:,jk) = ( scosrf(:,:) + (hbatt(:,:)-hift(:,:))*z_gsi3w(jk) + hift(:,:)*zcoeft ) 
    18431842      END DO 
    18441843!!gm: e3uw, e3vw can be suppressed  (modif in dynzdf, dynzdf_iso, zdfbfr) (save 2 3D arrays) 
    … …  
    18461845         DO ji = 1, jpi 
    18471846            DO jk = 1, jpk 
    1848               e3t(ji,jj,jk) = ( (hbatt(ji,jj)-hift(ji,jj))*z_esigt(jk) + hift(ji,jj)/REAL(jpkm1,wp) ) 
    1849               e3u(ji,jj,jk) = ( (hbatu(ji,jj)-hifu(ji,jj))*z_esigt(jk) + hifu(ji,jj)/REAL(jpkm1,wp) ) 
    1850               e3v(ji,jj,jk) = ( (hbatv(ji,jj)-hifv(ji,jj))*z_esigt(jk) + hifv(ji,jj)/REAL(jpkm1,wp) ) 
    1851               e3f(ji,jj,jk) = ( (hbatf(ji,jj)-hiff(ji,jj))*z_esigt(jk) + hiff(ji,jj)/REAL(jpkm1,wp) ) 
     1847              e3t_0(ji,jj,jk) = ( (hbatt(ji,jj)-hift(ji,jj))*z_esigt(jk) + hift(ji,jj)/REAL(jpkm1,wp) ) 
     1848              e3u_0(ji,jj,jk) = ( (hbatu(ji,jj)-hifu(ji,jj))*z_esigt(jk) + hifu(ji,jj)/REAL(jpkm1,wp) ) 
     1849              e3v_0(ji,jj,jk) = ( (hbatv(ji,jj)-hifv(ji,jj))*z_esigt(jk) + hifv(ji,jj)/REAL(jpkm1,wp) ) 
     1850              e3f_0(ji,jj,jk) = ( (hbatf(ji,jj)-hiff(ji,jj))*z_esigt(jk) + hiff(ji,jj)/REAL(jpkm1,wp) ) 
    18521851              ! 
    1853               e3w (ji,jj,jk) = ( (hbatt(ji,jj)-hift(ji,jj))*z_esigw(jk) + hift(ji,jj)/REAL(jpkm1,wp) ) 
    1854               e3uw(ji,jj,jk) = ( (hbatu(ji,jj)-hifu(ji,jj))*z_esigw(jk) + hifu(ji,jj)/REAL(jpkm1,wp) ) 
    1855               e3vw(ji,jj,jk) = ( (hbatv(ji,jj)-hifv(ji,jj))*z_esigw(jk) + hifv(ji,jj)/REAL(jpkm1,wp) ) 
     1852              e3w_0 (ji,jj,jk) = ( (hbatt(ji,jj)-hift(ji,jj))*z_esigw(jk) + hift(ji,jj)/REAL(jpkm1,wp) ) 
     1853              e3uw_0(ji,jj,jk) = ( (hbatu(ji,jj)-hifu(ji,jj))*z_esigw(jk) + hifu(ji,jj)/REAL(jpkm1,wp) ) 
     1854              e3vw_0(ji,jj,jk) = ( (hbatv(ji,jj)-hifv(ji,jj))*z_esigw(jk) + hifv(ji,jj)/REAL(jpkm1,wp) ) 
    18561855            END DO 
    18571856         END DO 
    … …  
    18781877      !!---------------------------------------------------------------------- 
    18791878      ! 
    1880       pf =   (   TANH( rn_theta * ( -(pk-0.5_wp) / REAL(jpkm1,wp) + rn_thetb )  )   & 
     1879      pf =   (   TANH( rn_theta * ( -(pk-0.5_wp) / REAL(jpkm1) + rn_thetb )  )   & 
    18811880         &     - TANH( rn_thetb * rn_theta                                )  )   & 
    18821881         & * (   COSH( rn_theta                           )                      & 
    … …  
    19041903      ! 
    19051904      IF ( rn_theta == 0 ) then      ! uniform sigma 
    1906          pf1 = - ( pk1 - 0.5_wp ) / REAL( jpkm1,wp ) 
     1905         pf1 = - ( pk1 - 0.5_wp ) / REAL( jpkm1 ) 
    19071906      ELSE                        ! stretched sigma 
    1908          pf1 =   ( 1._wp - pbb ) * ( SINH( rn_theta*(-(pk1-0.5_wp)/REAL(jpkm1,wp)) ) ) / SINH( rn_theta )              & 
    1909             &  + pbb * (  (TANH( rn_theta*( (-(pk1-0.5_wp)/REAL(jpkm1,wp)) + 0.5_wp) ) - TANH( 0.5_wp * rn_theta )  )  & 
     1907         pf1 =   ( 1._wp - pbb ) * ( SINH( rn_theta*(-(pk1-0.5_wp)/REAL(jpkm1)) ) ) / SINH( rn_theta )              & 
     1908            &  + pbb * (  (TANH( rn_theta*( (-(pk1-0.5_wp)/REAL(jpkm1)) + 0.5_wp) ) - TANH( 0.5_wp * rn_theta )  )  & 
    19101909            &        / ( 2._wp * TANH( 0.5_wp * rn_theta ) )  ) 
    19111910      ENDIF 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DOM/domzgr_substitute.h90

    r2528 r4292  
    88   !!            3.1  !  2009-02  (G. Madec, M. Leclair)  pure z* coordinate 
    99   !!---------------------------------------------------------------------- 
    10 ! reference for s- or zps-coordinate (3D no time dependency) 
    11 #   define  fsdept_0(i,j,k)  gdept(i,j,k) 
    12 #   define  fsdepw_0(i,j,k)  gdepw(i,j,k) 
    13 #   define  fsde3w_0(i,j,k)  gdep3w(i,j,k) 
    14 #   define  fse3t_0(i,j,k)   e3t(i,j,k) 
    15 #   define  fse3u_0(i,j,k)   e3u(i,j,k) 
    16 #   define  fse3v_0(i,j,k)   e3v(i,j,k) 
    17 #   define  fse3f_0(i,j,k)   e3f(i,j,k) 
    18 #   define  fse3w_0(i,j,k)   e3w(i,j,k) 
    19 #   define  fse3uw_0(i,j,k)  e3uw(i,j,k) 
    20 #   define  fse3vw_0(i,j,k)  e3vw(i,j,k) 
     10 
    2111#if defined key_vvl 
    22 ! s* or z*-coordinate (3D + time dependency) + use of additional now arrays (..._1) 
    23 #   define  fsdept(i,j,k)  gdept_1(i,j,k) 
    24 #   define  fsdepw(i,j,k)  gdepw_1(i,j,k) 
    25 #   define  fsde3w(i,j,k)  gdep3w_1(i,j,k) 
    26 #   define  fse3t(i,j,k)   e3t_1(i,j,k) 
    27 #   define  fse3u(i,j,k)   e3u_1(i,j,k) 
    28 #   define  fse3v(i,j,k)   e3v_1(i,j,k) 
    29 #   define  fse3f(i,j,k)   e3f_1(i,j,k) 
    30 #   define  fse3w(i,j,k)   e3w_1(i,j,k) 
    31 #   define  fse3uw(i,j,k)  e3uw_1(i,j,k) 
    32 #   define  fse3vw(i,j,k)  e3vw_1(i,j,k) 
     12! s* or z*-coordinate (3D + time dependency) + use of additional now arrays (..._n) 
    3313 
    3414#   define  fse3t_b(i,j,k)   e3t_b(i,j,k) 
    3515#   define  fse3u_b(i,j,k)   e3u_b(i,j,k) 
    3616#   define  fse3v_b(i,j,k)   e3v_b(i,j,k) 
    37 #   define  fse3uw_b(i,j,k)  (fse3uw_0(i,j,k)*(1.+sshu_b(i,j)*muu(i,j,k))) 
    38 #   define  fse3vw_b(i,j,k)  (fse3vw_0(i,j,k)*(1.+sshv_b(i,j)*muv(i,j,k))) 
     17#   define  fse3uw_b(i,j,k)  e3uw_b(i,j,k) 
     18#   define  fse3vw_b(i,j,k)  e3vw_b(i,j,k) 
    3919 
    40 #   define  fsdept_n(i,j,k)  (fsdept_0(i,j,k)*(1.+sshn(i,j)*mut(i,j,k))) 
    41 #   define  fsdepw_n(i,j,k)  (fsdepw_0(i,j,k)*(1.+sshn(i,j)*mut(i,j,k))) 
    42 #   define  fsde3w_n(i,j,k)  (fsde3w_0(i,j,k)*(1.+sshn(i,j)*mut(i,j,k))-sshn(i,j)) 
    43 #   define  fse3t_n(i,j,k)   (fse3t_0(i,j,k)*(1.+sshn(i,j)*mut(i,j,k))) 
    44 #   define  fse3u_n(i,j,k)   (fse3u_0(i,j,k)*(1.+sshu_n(i,j)*muu(i,j,k))) 
    45 #   define  fse3v_n(i,j,k)   (fse3v_0(i,j,k)*(1.+sshv_n(i,j)*muv(i,j,k))) 
    46 #   define  fse3f_n(i,j,k)   (fse3f_0(i,j,k)*(1.+sshf_n(i,j)*muf(i,j,k))) 
    47 #   define  fse3w_n(i,j,k)   (fse3w_0(i,j,k)*(1.+sshn(i,j)*mut(i,j,k))) 
    48 #   define  fse3uw_n(i,j,k)  (fse3uw_0(i,j,k)*(1.+sshu_n(i,j)*muu(i,j,k))) 
    49 #   define  fse3vw_n(i,j,k)  (fse3vw_0(i,j,k)*(1.+sshv_n(i,j)*muv(i,j,k))) 
     20#   define  fsdept_n(i,j,k)  gdept_n(i,j,k) 
     21#   define  fsdepw_n(i,j,k)  gdepw_n(i,j,k) 
     22#   define  fsde3w_n(i,j,k)  gdep3w_n(i,j,k) 
     23#   define  fse3t_n(i,j,k)   e3t_n(i,j,k) 
     24#   define  fse3u_n(i,j,k)   e3u_n(i,j,k) 
     25#   define  fse3v_n(i,j,k)   e3v_n(i,j,k) 
     26#   define  fse3f_n(i,j,k)   e3f_n(i,j,k) 
     27#   define  fse3w_n(i,j,k)   e3w_n(i,j,k) 
     28#   define  fse3uw_n(i,j,k)  e3uw_n(i,j,k) 
     29#   define  fse3vw_n(i,j,k)  e3vw_n(i,j,k) 
    5030 
    51 #   define  fse3t_m(i,j,k)   (fse3t_0(i,j,k)*(1.+ssh_m(i,j)*mut(i,j,k))) 
     31#   define  fse3t_a(i,j,k)   e3t_a(i,j,k) 
     32#   define  fse3u_a(i,j,k)   e3u_a(i,j,k) 
     33#   define  fse3v_a(i,j,k)   e3v_a(i,j,k) 
    5234 
    53 #   define  fse3t_a(i,j,k)   (fse3t_0(i,j,k)*(1.+ssha(i,j)*mut(i,j,k))) 
    54 #   define  fse3u_a(i,j,k)   (fse3u_0(i,j,k)*(1.+sshu_a(i,j)*muu(i,j,k))) 
    55 #   define  fse3v_a(i,j,k)   (fse3v_0(i,j,k)*(1.+sshv_a(i,j)*muv(i,j,k))) 
     35#   define  fse3t_m(i,j)     e3t_m(i,j) 
     36 
     37! This part should be removed one day ... 
     38! ... In that case all occurence of the above statement functions 
     39!     have to be replaced in the code by xxx_n 
     40#   define  fsdept(i,j,k)    gdept_n(i,j,k) 
     41#   define  fsdepw(i,j,k)    gdepw_n(i,j,k) 
     42#   define  fsde3w(i,j,k)    gdep3w_n(i,j,k) 
     43#   define  fse3t(i,j,k)     e3t_n(i,j,k)  
     44#   define  fse3u(i,j,k)     e3u_n(i,j,k)  
     45#   define  fse3v(i,j,k)     e3v_n(i,j,k)  
     46#   define  fse3f(i,j,k)     e3f_n(i,j,k)  
     47#   define  fse3w(i,j,k)     e3w_n(i,j,k)  
     48#   define  fse3uw(i,j,k)    e3uw_n(i,j,k) 
     49#   define  fse3vw(i,j,k)    e3vw_n(i,j,k) 
    5650 
    5751#else 
    5852! z- or s-coordinate (1D or 3D + no time dependency) use reference in all cases 
    59 #   define  fsdept(i,j,k)  fsdept_0(i,j,k) 
    60 #   define  fsdepw(i,j,k)  fsdepw_0(i,j,k) 
    61 #   define  fsde3w(i,j,k)  fsde3w_0(i,j,k) 
    62 #   define  fse3t(i,j,k)   fse3t_0(i,j,k) 
    63 #   define  fse3u(i,j,k)   fse3u_0(i,j,k) 
    64 #   define  fse3v(i,j,k)   fse3v_0(i,j,k) 
    65 #   define  fse3f(i,j,k)   fse3f_0(i,j,k) 
    66 #   define  fse3w(i,j,k)   fse3w_0(i,j,k) 
    67 #   define  fse3uw(i,j,k)  fse3uw_0(i,j,k) 
    68 #   define  fse3vw(i,j,k)  fse3vw_0(i,j,k) 
    6953 
    70 #   define  fse3t_b(i,j,k)   fse3t_0(i,j,k) 
    71 #   define  fse3u_b(i,j,k)   fse3u_0(i,j,k) 
    72 #   define  fse3v_b(i,j,k)   fse3v_0(i,j,k) 
    73 #   define  fse3uw_b(i,j,k)  fse3uw_0(i,j,k) 
    74 #   define  fse3vw_b(i,j,k)  fse3vw_0(i,j,k) 
     54#   define  fse3t_b(i,j,k)   e3t_0(i,j,k) 
     55#   define  fse3u_b(i,j,k)   e3u_0(i,j,k) 
     56#   define  fse3v_b(i,j,k)   e3v_0(i,j,k) 
     57#   define  fse3uw_b(i,j,k)  e3uw_0(i,j,k) 
     58#   define  fse3vw_b(i,j,k)  e3vw_0(i,j,k) 
    7559 
    76 #   define  fsdept_n(i,j,k)  fsdept_0(i,j,k) 
    77 #   define  fsdepw_n(i,j,k)  fsdepw_0(i,j,k) 
    78 #   define  fsde3w_n(i,j,k)  fsde3w_0(i,j,k) 
    79 #   define  fse3t_n(i,j,k)   fse3t_0(i,j,k) 
    80 #   define  fse3u_n(i,j,k)   fse3u_0(i,j,k) 
    81 #   define  fse3v_n(i,j,k)   fse3v_0(i,j,k) 
    82 #   define  fse3f_n(i,j,k)   fse3f_0(i,j,k) 
    83 #   define  fse3w_n(i,j,k)   fse3w_0(i,j,k) 
    84 #   define  fse3uw_n(i,j,k)  fse3uw_0(i,j,k) 
    85 #   define  fse3vw_n(i,j,k)  fse3vw_0(i,j,k) 
     60#   define  fsdept_n(i,j,k)  gdept_0(i,j,k) 
     61#   define  fsdepw_n(i,j,k)  gdepw_0(i,j,k) 
     62#   define  fsde3w_n(i,j,k)  gdep3w_0(i,j,k) 
     63#   define  fse3t_n(i,j,k)   e3t_0(i,j,k) 
     64#   define  fse3u_n(i,j,k)   e3u_0(i,j,k) 
     65#   define  fse3v_n(i,j,k)   e3v_0(i,j,k) 
     66#   define  fse3f_n(i,j,k)   e3f_0(i,j,k) 
     67#   define  fse3w_n(i,j,k)   e3w_0(i,j,k) 
     68#   define  fse3uw_n(i,j,k)  e3uw_0(i,j,k) 
     69#   define  fse3vw_n(i,j,k)  e3vw_0(i,j,k) 
    8670 
    87 #   define  fse3t_m(i,j,k)   fse3t_0(i,j,k) 
     71#   define  fse3t_a(i,j,k)   e3t_0(i,j,k) 
     72#   define  fse3u_a(i,j,k)   e3u_0(i,j,k) 
     73#   define  fse3v_a(i,j,k)   e3v_0(i,j,k) 
    8874 
    89 #   define  fse3t_a(i,j,k)   fse3t_0(i,j,k) 
    90 #   define  fse3u_a(i,j,k)   fse3u_0(i,j,k) 
    91 #   define  fse3v_a(i,j,k)   fse3v_0(i,j,k) 
     75#   define  fse3t_m(i,j)     e3t_0(i,j,1) 
     76 
     77! This part should be removed one day ... 
     78! ... In that case all occurence of the above statement functions 
     79!     have to be replaced in the code by xxx_n 
     80#   define  fsdept(i,j,k)    gdept_0(i,j,k) 
     81#   define  fsdepw(i,j,k)    gdepw_0(i,j,k) 
     82#   define  fsde3w(i,j,k)    gdep3w_0(i,j,k) 
     83#   define  fse3t(i,j,k)     e3t_0(i,j,k) 
     84#   define  fse3u(i,j,k)     e3u_0(i,j,k) 
     85#   define  fse3v(i,j,k)     e3v_0(i,j,k) 
     86#   define  fse3f(i,j,k)     e3f_0(i,j,k) 
     87#   define  fse3w(i,j,k)     e3w_0(i,j,k) 
     88#   define  fse3uw(i,j,k)    e3uw_0(i,j,k) 
     89#   define  fse3vw(i,j,k)    e3vw_0(i,j,k) 
     90 
    9291#endif 
    9392   !!---------------------------------------------------------------------- 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DOM/dtatsd.F90

    r4245 r4292  
    221221            DO ji = 1, jpi 
    222222               DO jk = 1, jpk                        ! determines the intepolated T-S profiles at each (i,j) points 
    223                   zl = fsdept_0(ji,jj,jk) 
    224                   IF(     zl < gdept_0(1  ) ) THEN          ! above the first level of data 
     223                  zl = gdept_0(ji,jj,jk) 
     224                  IF(     zl < gdept_1d(1  ) ) THEN          ! above the first level of data 
    225225                     ztp(jk) =  ptsd(ji,jj,1    ,jp_tem) 
    226226                     zsp(jk) =  ptsd(ji,jj,1    ,jp_sal) 
    227                   ELSEIF( zl > gdept_0(jpk) ) THEN          ! below the last level of data 
     227                  ELSEIF( zl > gdept_1d(jpk) ) THEN          ! below the last level of data 
    228228                     ztp(jk) =  ptsd(ji,jj,jpkm1,jp_tem) 
    229229                     zsp(jk) =  ptsd(ji,jj,jpkm1,jp_sal) 
    230230                  ELSE                                      ! inbetween : vertical interpolation between jkk & jkk+1 
    231231                     DO jkk = 1, jpkm1                                  ! when  gdept(jkk) < zl < gdept(jkk+1) 
    232                         IF( (zl-gdept_0(jkk)) * (zl-gdept_0(jkk+1)) <= 0._wp ) THEN 
    233                            zi = ( zl - gdept_0(jkk) ) / (gdept_0(jkk+1)-gdept_0(jkk)) 
     232                        IF( (zl-gdept_1d(jkk)) * (zl-gdept_1d(jkk+1)) <= 0._wp ) THEN 
     233                           zi = ( zl - gdept_1d(jkk) ) / (gdept_1d(jkk+1)-gdept_1d(jkk)) 
    234234                           ztp(jk) = ptsd(ji,jj,jkk,jp_tem) + ( ptsd(ji,jj,jkk+1,jp_tem) - ptsd(ji,jj,jkk,jp_tem) ) * zi  
    235235                           zsp(jk) = ptsd(ji,jj,jkk,jp_sal) + ( ptsd(ji,jj,jkk+1,jp_sal) - ptsd(ji,jj,jkk,jp_sal) ) * zi 
    … …  
    259259                  ik = mbkt(ji,jj)  
    260260                  IF( ik > 1 ) THEN 
    261                      zl = ( gdept_0(ik) - fsdept_0(ji,jj,ik) ) / ( gdept_0(ik) - gdept_0(ik-1) ) 
     261                     zl = ( gdept_1d(ik) - gdept_0(ji,jj,ik) ) / ( gdept_1d(ik) - gdept_1d(ik-1) ) 
    262262                     ptsd(ji,jj,ik,jp_tem) = (1.-zl) * ptsd(ji,jj,ik,jp_tem) + zl * ptsd(ji,jj,ik-1,jp_tem) 
    263263                     ptsd(ji,jj,ik,jp_sal) = (1.-zl) * ptsd(ji,jj,ik,jp_sal) + zl * ptsd(ji,jj,ik-1,jp_sal) 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DOM/istate.F90

    r4245 r4292  
    9494         neuler = 1                              ! Set time-step indicator at nit000 (leap-frog) 
    9595         CALL rst_read                           ! Read the restart file 
    96          !                                       ! define e3u_b, e3v_b from e3t_b read in restart file 
    97          CALL dom_vvl_2( nit000, fse3u_b(:,:,:), fse3v_b(:,:,:) ) 
    9896         CALL day_init                           ! model calendar (using both namelist and restart infos) 
    9997      ELSE 
    … …  
    144142            ENDDO 
    145143         ENDIF 
    146          !                                       ! define e3u_b, e3v_b from e3t_b initialized in domzgr 
    147          CALL dom_vvl_2( nit000, fse3u_b(:,:,:), fse3v_b(:,:,:) ) 
    148144         !  
    149145      ENDIF 
    … …  
    230226            IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 
    231227            ! 
    232             zh1 = gdept_0(  1  ) 
    233             zh2 = gdept_0(jpkm1) 
     228            zh1 = gdept_1d(  1  ) 
     229            zh2 = gdept_1d(jpkm1) 
    234230            ! 
    235231            zslope = ( zt1 - zt2 ) / ( zh1 - zh2 ) 
    … …  
    411407         WRITE(numout,*) 
    412408         WRITE(numout,*) '              Initial temperature and salinity profiles:' 
    413          WRITE(numout, "(9x,' level   gdept_0   temperature   salinity   ')" ) 
    414          WRITE(numout, "(10x, i4, 3f10.2)" ) ( jk, gdept_0(jk), tsn(2,2,jk,jp_tem), tsn(2,2,jk,jp_sal), jk = 1, jpk ) 
     409         WRITE(numout, "(9x,' level   gdept_1d   temperature   salinity   ')" ) 
     410         WRITE(numout, "(10x, i4, 3f10.2)" ) ( jk, gdept_1d(jk), tsn(2,2,jk,jp_tem), tsn(2,2,jk,jp_sal), jk = 1, jpk ) 
    415411      ENDIF 
    416412 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DYN/dynhpg.F90

    r4147 r4292  
    767767      DO jj = 2, jpjm1 
    768768        DO ji = 2, jpim1 
    769           zu(ji,jj,1) = - ( fse3u(ji,jj,1) - sshu_n(ji,jj) * znad) 
    770           zv(ji,jj,1) = - ( fse3v(ji,jj,1) - sshv_n(ji,jj) * znad) 
     769          zu(ji,jj,1) = - ( fse3u(ji,jj,1) - sshn(ji,jj) * znad)    ! probable bug: changed from sshu_n for ztilde compilation 
     770          zv(ji,jj,1) = - ( fse3v(ji,jj,1) - sshn(ji,jj) * znad)    ! probable bug: changed from sshv_n for ztilde compilation 
    771771        END DO 
    772772      END DO 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DYN/dynnxt.F90

    r3764 r4292  
    1717   !!            3.3  !  2010-09  (D. Storkey, E.O'Dea) Bug fix for BDY module 
    1818   !!            3.3  !  2011-03  (P. Oddo) Bug fix for time-splitting+(BDY-OBC) and not VVL 
     19   !!            3.5  !  2013-07  (J. Chanut) Compliant with time splitting changes 
    1920   !!------------------------------------------------------------------------- 
    2021   
    … …  
    4243   USE wrk_nemo        ! Memory Allocation 
    4344   USE prtctl          ! Print control 
     45   USE dynspg_ts       ! Barotropic velocities 
     46 
    4447#if defined key_agrif 
    4548   USE agrif_opa_interp 
    … …  
    103106      REAL(wp) ::   zue3a, zue3n, zue3b, zuf, zec   ! local scalars 
    104107      REAL(wp) ::   zve3a, zve3n, zve3b, zvf        !   -      - 
     108      REAL(wp), POINTER, DIMENSION(:,:)   ::  zua, zva 
    105109      REAL(wp), POINTER, DIMENSION(:,:,:) ::  ze3u_f, ze3v_f  
    106110      !!---------------------------------------------------------------------- 
    … …  
    109113      ! 
    110114      CALL wrk_alloc( jpi,jpj,jpk, ze3u_f, ze3v_f ) 
     115      IF ( lk_dynspg_ts ) CALL wrk_alloc( jpi,jpj, zua, zva ) 
    111116      ! 
    112117      IF( kt == nit000 ) THEN 
    … …  
    127132      ! 
    128133#else 
     134 
     135# if defined key_dynspg_exp 
    129136      ! Next velocity :   Leap-frog time stepping 
    130137      ! ------------- 
    … …  
    147154         END DO 
    148155      ENDIF 
    149  
     156# endif 
     157 
     158# if defined key_dynspg_ts 
     159      ! Ensure below that barotropic velocities match time splitting estimate 
     160      ! Compute actual transport and replace it with ts estimate at "after" time step 
     161      zua(:,:) = 0._wp 
     162      zva(:,:) = 0._wp 
     163      IF (lk_vvl) THEN 
     164         DO jk = 1, jpkm1 
     165            zua(:,:) = zua(:,:) + fse3u_a(:,:,jk) * ua(:,:,jk) * umask(:,:,jk) 
     166            zva(:,:) = zva(:,:) + fse3v_a(:,:,jk) * va(:,:,jk) * vmask(:,:,jk)     
     167         END DO 
     168         DO jk = 1, jpkm1 
     169            ua(:,:,jk) = ( ua(:,:,jk) - zua(:,:) * hur_e(:,:) + ua_b(:,:) ) * umask(:,:,jk) 
     170            va(:,:,jk) = ( va(:,:,jk) - zva(:,:) * hvr_e(:,:) + va_b(:,:) ) * vmask(:,:,jk) 
     171         END DO 
     172      ELSE 
     173         DO jk = 1, jpkm1 
     174            zua(:,:) = zua(:,:) + fse3u(:,:,jk) * ua(:,:,jk) * umask(:,:,jk) 
     175            zva(:,:) = zva(:,:) + fse3v(:,:,jk) * va(:,:,jk) * vmask(:,:,jk)     
     176         END DO 
     177         DO jk = 1, jpkm1 
     178            ua(:,:,jk) = ( ua(:,:,jk) - zua(:,:) * hur(:,:) + ua_b(:,:) ) *umask(:,:,jk) 
     179            va(:,:,jk) = ( va(:,:,jk) - zva(:,:) * hvr(:,:) + va_b(:,:) ) *vmask(:,:,jk) 
     180         END DO 
     181      ENDIF 
     182 
     183      IF (lk_dynspg_ts.AND.(.NOT.ln_bt_fw)) THEN 
     184         ! Remove advective velocity from "now velocities"  
     185         ! prior to asselin filtering      
     186         ! In the forward case, this is done below after asselin filtering     
     187         DO jk = 1, jpkm1 
     188            un(:,:,jk) = ( un(:,:,jk) - un_adv(:,:) + un_b(:,:) )*umask(:,:,jk) 
     189            vn(:,:,jk) = ( vn(:,:,jk) - vn_adv(:,:) + vn_b(:,:) )*vmask(:,:,jk) 
     190         END DO   
     191      ENDIF 
     192# endif 
    150193 
    151194      ! Update after velocity on domain lateral boundaries 
    … …  
    194237            vn(:,:,jk) = va(:,:,jk) 
    195238         END DO 
     239         IF (lk_vvl) THEN 
     240            DO jk = 1, jpkm1 
     241               fse3t_b(:,:,jk) = fse3t_n(:,:,jk) 
     242               fse3u_b(:,:,jk) = fse3u_n(:,:,jk) 
     243               fse3v_b(:,:,jk) = fse3v_n(:,:,jk) 
     244            ENDDO 
     245         ENDIF 
    196246      ELSE                                             !* Leap-Frog : Asselin filter and swap 
    197247         !                                ! =============! 
    … …  
    201251               DO jj = 1, jpj 
    202252                  DO ji = 1, jpi     
    203                      zuf = un(ji,jj,jk) + atfp * ( ub(ji,jj,jk) - 2.e0 * un(ji,jj,jk) + ua(ji,jj,jk) ) 
    204                      zvf = vn(ji,jj,jk) + atfp * ( vb(ji,jj,jk) - 2.e0 * vn(ji,jj,jk) + va(ji,jj,jk) ) 
     253                     zuf = un(ji,jj,jk) + atfp * ( ub(ji,jj,jk) - 2.e0_wp * un(ji,jj,jk) + ua(ji,jj,jk) ) 
     254                     zvf = vn(ji,jj,jk) + atfp * ( vb(ji,jj,jk) - 2.e0_wp * vn(ji,jj,jk) + va(ji,jj,jk) ) 
    205255                     ! 
    206256                     ub(ji,jj,jk) = zuf                      ! ub <-- filtered velocity 
    … …  
    214264         ELSE                             ! Variable volume ! 
    215265            !                             ! ================! 
     266            ! Before scale factor at t-points 
     267            ! (used as a now filtered scale factor until the swap) 
     268            ! ---------------------------------------------------- 
     269            IF (lk_dynspg_ts.AND.ln_bt_fw) THEN 
     270               ! Remove asselin filtering on thicknesses if forward time splitting 
     271                  fse3t_b(:,:,:) = fse3t_n(:,:,:) 
     272            ELSE 
     273               fse3t_b(:,:,:) = fse3t_n(:,:,:) + atfp * ( fse3t_b(:,:,:) - 2._wp * fse3t_n(:,:,:) + fse3t_a(:,:,:) ) 
     274               ! Add volume filter correction: compatibility with tracer advection scheme 
     275               ! => time filter + conservation correction (only at the first level) 
     276               fse3t_b(:,:,1) = fse3t_b(:,:,1) - atfp * rdt * r1_rau0 * ( emp_b(:,:) - emp(:,:) ) * tmask(:,:,1) 
    216277            ! 
    217             DO jk = 1, jpkm1                 ! Before scale factor at t-points 
    218                fse3t_b(:,:,jk) = fse3t_n(:,:,jk)                                   & 
    219                   &              + atfp * (  fse3t_b(:,:,jk) + fse3t_a(:,:,jk)     & 
    220                   &                         - 2._wp * fse3t_n(:,:,jk)            ) 
    221             END DO 
    222             zec = atfp * rdt / rau0          ! Add filter correction only at the 1st level of t-point scale factors 
    223             fse3t_b(:,:,1) = fse3t_b(:,:,1) - zec * ( emp_b(:,:) - emp(:,:) ) * tmask(:,:,1) 
     278            ENDIF 
    224279            ! 
    225             IF( ln_dynadv_vec ) THEN         ! vector invariant form (no thickness weighted calulation) 
    226                ! 
    227                !                                      ! before scale factors at u- & v-pts (computed from fse3t_b) 
    228                CALL dom_vvl_2( kt, fse3u_b(:,:,:), fse3v_b(:,:,:) ) 
    229                ! 
    230                DO jk = 1, jpkm1                       ! Leap-Frog - Asselin filter and swap: applied on velocity 
    231                   DO jj = 1, jpj                      !                                                 -------- 
     280            IF( ln_dynadv_vec ) THEN 
     281               ! Before scale factor at (u/v)-points 
     282               ! ----------------------------------- 
     283               CALL dom_vvl_interpol( fse3t_b(:,:,:), fse3u_b(:,:,:), 'U' ) 
     284               CALL dom_vvl_interpol( fse3t_b(:,:,:), fse3v_b(:,:,:), 'V' ) 
     285               ! Leap-Frog - Asselin filter and swap: applied on velocity 
     286               ! ----------------------------------- 
     287               DO jk = 1, jpkm1 
     288                  DO jj = 1, jpj 
    232289                     DO ji = 1, jpi 
    233                         zuf = un(ji,jj,jk) + atfp * ( ub(ji,jj,jk) - 2.e0 * un(ji,jj,jk) + ua(ji,jj,jk) ) 
    234                         zvf = vn(ji,jj,jk) + atfp * ( vb(ji,jj,jk) - 2.e0 * vn(ji,jj,jk) + va(ji,jj,jk) ) 
     290                        zuf = un(ji,jj,jk) + atfp * ( ub(ji,jj,jk) - 2._wp * un(ji,jj,jk) + ua(ji,jj,jk) ) 
     291                        zvf = vn(ji,jj,jk) + atfp * ( vb(ji,jj,jk) - 2._wp * vn(ji,jj,jk) + va(ji,jj,jk) ) 
    235292                        ! 
    236293                        ub(ji,jj,jk) = zuf                      ! ub <-- filtered velocity 
    … …  
    242299               END DO 
    243300               ! 
    244             ELSE                             ! flux form (thickness weighted calulation) 
    245                ! 
    246                CALL dom_vvl_2( kt, ze3u_f, ze3v_f )   ! before scale factors at u- & v-pts (computed from fse3t_b) 
    247                ! 
    248                DO jk = 1, jpkm1                       ! Leap-Frog - Asselin filter and swap:  
    249                   DO jj = 1, jpj                      !                   applied on thickness weighted velocity 
     301            ELSE 
     302               ! Temporary filtered scale factor at (u/v)-points (will become before scale factor) 
     303               !------------------------------------------------ 
     304               CALL dom_vvl_interpol( fse3t_b(:,:,:), ze3u_f, 'U' ) 
     305               CALL dom_vvl_interpol( fse3t_b(:,:,:), ze3v_f, 'V' ) 
     306               ! Leap-Frog - Asselin filter and swap: applied on thickness weighted velocity 
     307               ! -----------------------------------             =========================== 
     308               DO jk = 1, jpkm1 
     309                  DO jj = 1, jpj 
    250310                     DO ji = 1, jpi                   !                              --------------------------- 
    251311                        zue3a = ua(ji,jj,jk) * fse3u_a(ji,jj,jk) 
    … …  
    272332         ENDIF 
    273333         ! 
    274       ENDIF 
     334         IF (lk_dynspg_ts.AND.ln_bt_fw) THEN 
     335         ! Remove asselin filtering of barotropic velocities if forward time splitting 
     336         ! note that we replace barotropic velocities by advective velocities        
     337            zua(:,:) = 0._wp 
     338            zva(:,:) = 0._wp 
     339            IF (lk_vvl) THEN 
     340               DO jk = 1, jpkm1 
     341                  zua(:,:) = zua(:,:) + fse3u_b(:,:,jk) * ub(:,:,jk) * umask(:,:,jk) 
     342                  zva(:,:) = zva(:,:) + fse3v_b(:,:,jk) * vb(:,:,jk) * vmask(:,:,jk)     
     343               END DO 
     344            ELSE 
     345               DO jk = 1, jpkm1 
     346                  zua(:,:) = zua(:,:) + fse3u(:,:,jk) * ub(:,:,jk) * umask(:,:,jk) 
     347                  zva(:,:) = zva(:,:) + fse3v(:,:,jk) * vb(:,:,jk) * vmask(:,:,jk)     
     348               END DO 
     349            ENDIF 
     350            DO jk = 1, jpkm1 
     351               ub(:,:,jk) = ub(:,:,jk) - (zua(:,:) * hur(:,:) - un_b(:,:)) * umask(:,:,jk) 
     352               vb(:,:,jk) = vb(:,:,jk) - (zva(:,:) * hvr(:,:) - vn_b(:,:)) * vmask(:,:,jk) 
     353            END DO 
     354         ENDIF 
     355         ! 
     356      ENDIF ! neuler =/0 
    275357 
    276358      IF(ln_ctl)   CALL prt_ctl( tab3d_1=un, clinfo1=' nxt  - Un: ', mask1=umask,   & 
    … …  
    278360      !  
    279361      CALL wrk_dealloc( jpi,jpj,jpk, ze3u_f, ze3v_f ) 
     362      IF ( lk_dynspg_ts ) CALL wrk_dealloc( jpi,jpj, zua, zva ) 
    280363      ! 
    281364      IF( nn_timing == 1 )  CALL timing_stop('dyn_nxt') 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg.F90

    r4245 r4292  
    2323   USE dynspg_flt     ! surface pressure gradient     (dyn_spg_flt routine) 
    2424   USE dynadv         ! dynamics: vector invariant versus flux form 
     25   USE dynhpg, ONLY: ln_dynhpg_imp 
     26   USE sbctide 
     27   USE updtide 
    2528   USE trdmod         ! ocean dynamics trends 
    2629   USE trdmod_oce     ! ocean variables trends 
    … …  
    101104      ENDIF 
    102105 
    103       IF( ln_apr_dyn ) THEN                   !==  Atmospheric pressure gradient  ==! 
    104          zg_2 = grav * 0.5 
    105          DO jj = 2, jpjm1                          ! gradient of Patm using inverse barometer ssh 
     106      IF(      ln_apr_dyn                                                &   ! atmos. pressure 
     107         .OR.  ( .NOT.lk_dynspg_ts .AND. (ln_tide_pot .AND. lk_tide) )   &   ! tide potential (no time slitting) 
     108         .OR.  nn_ice_embd == 2  ) THEN                                      ! embedded sea-ice 
     109         ! 
     110         DO jj = 2, jpjm1 
    106111            DO ji = fs_2, fs_jpim1   ! vector opt. 
    107                spgu(ji,jj) =  zg_2 * (  ssh_ib (ji+1,jj) - ssh_ib (ji,jj)    & 
    108                   &                   + ssh_ibb(ji+1,jj) - ssh_ibb(ji,jj)  ) /e1u(ji,jj) 
    109                spgv(ji,jj) =  zg_2 * (  ssh_ib (ji,jj+1) - ssh_ib (ji,jj)    & 
    110                   &                   + ssh_ibb(ji,jj+1) - ssh_ibb(ji,jj)  ) /e2v(ji,jj) 
    111             END DO 
    112          END DO 
    113          DO jk = 1, jpkm1                          ! Add the apg to the general trend 
     112               spgu(ji,jj) = 0._wp 
     113               spgv(ji,jj) = 0._wp 
     114            END DO 
     115         END DO          
     116         ! 
     117         IF( ln_apr_dyn .AND. (.NOT. lk_dynspg_ts) ) THEN                    !==  Atmospheric pressure gradient (added later in time-split case) ==! 
     118            zg_2 = grav * 0.5 
     119            DO jj = 2, jpjm1                          ! gradient of Patm using inverse barometer ssh 
     120               DO ji = fs_2, fs_jpim1   ! vector opt. 
     121                  spgu(ji,jj) = spgu(ji,jj) + zg_2 * (  ssh_ib (ji+1,jj) - ssh_ib (ji,jj)    & 
     122                     &                      + ssh_ibb(ji+1,jj) - ssh_ibb(ji,jj)  ) /e1u(ji,jj) 
     123                  spgv(ji,jj) = spgv(ji,jj) + zg_2 * (  ssh_ib (ji,jj+1) - ssh_ib (ji,jj)    & 
     124                     &                      + ssh_ibb(ji,jj+1) - ssh_ibb(ji,jj)  ) /e2v(ji,jj) 
     125               END DO 
     126            END DO 
     127         ENDIF 
     128         ! 
     129         !                                    !==  tide potential forcing term  ==! 
     130         IF( .NOT.lk_dynspg_ts .AND. ( ln_tide_pot .AND. lk_tide )  ) THEN   ! N.B. added directly at sub-time-step in ts-case 
     131            ! 
     132            CALL upd_tide( kt )                      ! update tide potential 
     133            ! 
     134            DO jj = 2, jpjm1                         ! add tide potential forcing 
     135               DO ji = fs_2, fs_jpim1   ! vector opt. 
     136                  spgv(ji,jj) = spgu(ji,jj) + grav * ( pot_astro(ji+1,jj) - pot_astro(ji,jj) ) / e1u(ji,jj) 
     137                  spgv(ji,jj) = spgv(ji,jj) + grav * ( pot_astro(ji,jj+1) - pot_astro(ji,jj) ) / e2v(ji,jj) 
     138               END DO  
     139            END DO 
     140         ENDIF 
     141         ! 
     142         IF( nn_ice_embd == 2 ) THEN          !== embedded sea ice: Pressure gradient due to snow-ice mass ==! 
     143            CALL wrk_alloc( jpi, jpj, zpice ) 
     144            !                                             
     145            zintp = REAL( MOD( kt-1, nn_fsbc ) ) / REAL( nn_fsbc ) 
     146            zgrau0r     = - grav * r1_rau0 
     147            zpice(:,:) = (  zintp * snwice_mass(:,:) + ( 1.- zintp ) * snwice_mass_b(:,:)  ) * zgrau0r 
     148            DO jj = 2, jpjm1 
     149               DO ji = fs_2, fs_jpim1   ! vector opt. 
     150                  spgu(ji,jj) = spgu(ji,jj) + ( zpice(ji+1,jj) - zpice(ji,jj) ) / e1u(ji,jj) 
     151                  spgv(ji,jj) = spgv(ji,jj) + ( zpice(ji,jj+1) - zpice(ji,jj) ) / e2v(ji,jj) 
     152               END DO 
     153            END DO 
     154            ! 
     155            CALL wrk_dealloc( jpi, jpj, zpice )          
     156         ENDIF 
     157         ! 
     158         DO jk = 1, jpkm1                     !== Add all terms to the general trend 
    114159            DO jj = 2, jpjm1 
    115160               DO ji = fs_2, fs_jpim1   ! vector opt. 
    … …  
    118163               END DO 
    119164            END DO 
    120          END DO 
    121       ENDIF 
    122  
    123       IF( nn_ice_embd == 2 ) THEN             !== embedded sea ice: Pressure gradient due to snow-ice mass ==! 
    124          CALL wrk_alloc( jpi, jpj, zpice ) 
    125          !                                             
    126          zintp = REAL( MOD( kt-1, nn_fsbc ) ) / REAL( nn_fsbc ) 
    127          zgrau0r     = - grav * r1_rau0 
    128          zpice(:,:) = (  zintp * snwice_mass(:,:) + ( 1.- zintp ) * snwice_mass_b(:,:)  ) * zgrau0r 
    129          DO jj = 2, jpjm1 
    130             DO ji = fs_2, fs_jpim1   ! vector opt. 
    131                spgu(ji,jj) = ( zpice(ji+1,jj) - zpice(ji,jj) ) / e1u(ji,jj) 
    132                spgv(ji,jj) = ( zpice(ji,jj+1) - zpice(ji,jj) ) / e2v(ji,jj) 
    133             END DO 
    134          END DO 
    135          DO jk = 1, jpkm1                             ! Add the surface pressure trend to the general trend 
    136             DO jj = 2, jpjm1 
    137                DO ji = fs_2, fs_jpim1   ! vector opt. 
    138                   ua(ji,jj,jk) = ua(ji,jj,jk) + spgu(ji,jj) 
    139                   va(ji,jj,jk) = va(ji,jj,jk) + spgv(ji,jj) 
    140                END DO 
    141             END DO 
    142          END DO 
    143          ! 
    144          CALL wrk_dealloc( jpi, jpj, zpice ) 
    145       ENDIF 
    146  
     165         END DO          
     166      ENDIF 
    147167 
    148168      SELECT CASE ( nspg )                       ! compute surf. pressure gradient trend and add it to the general trend 
    … …  
    209229      ENDIF 
    210230 
     231      IF( lk_dynspg_ts ) CALL dyn_spg_ts_init( nit000 ) 
     232      ! (do it now, to set nn_baro, used to allocate some arrays later on) 
    211233      !                        ! allocate dyn_spg arrays 
    212234      IF( lk_dynspg_ts ) THEN 
    … …  
    248270      ENDIF 
    249271 
    250       !                        ! Control of momentum formulation 
    251       IF( lk_dynspg_ts .AND. lk_vvl ) THEN 
    252          IF( .NOT.ln_dynadv_vec )   CALL ctl_stop( 'Flux form not implemented for this free surface formulation' ) 
     272      !               ! Control of hydrostatic pressure choice 
     273      IF( lk_dynspg_ts .AND. ln_dynhpg_imp ) THEN 
     274         CALL ctl_stop( 'Semi-implicit hpg not compatible with time splitting' ) 
    253275      ENDIF 
    254276      ! 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_exp.F90

    r3680 r4292  
    9191               spgv(ji,jj) = - grav * ( sshn(ji,jj+1) - sshn(ji,jj) ) / e2v(ji,jj) 
    9292            END DO  
    93          END DO  
     93         END DO 
     94         ! 
    9495         DO jk = 1, jpkm1                    ! Add it to the general trend 
    9596            DO jj = 2, jpjm1 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_oce.F90

    r3294 r4292  
    3939   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET ::   hur_e , hvr_e    ! inverse of hu_e and hv_e 
    4040   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET ::   sshn_b           ! before field without time-filter 
     41   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ua_b, va_b     ! after  averaged velocities 
     42   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   un_b, vn_b     ! now    averaged velocities 
     43   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ub_b, vb_b     ! before averaged velocities 
     44   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   un_adv, vn_adv ! Advection vel. at "now" barocl. step 
     45   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ub2_b,  vb2_b  ! Advection vel. at "now-0.5" barocl. step 
    4146 
    4247   !!---------------------------------------------------------------------- 
    … …  
    5358      ALLOCATE( sshn_e(jpi,jpj) , ua_e(jpi,jpj) , hu_e(jpi,jpj) , hur_e(jpi,jpj) ,      & 
    5459         &      ssha_e(jpi,jpj) , va_e(jpi,jpj) , hv_e(jpi,jpj) , hvr_e(jpi,jpj) ,      & 
     60         &      ub_b(jpi,jpj)   , vb_b(jpi,jpj) , un_b(jpi,jpj) , vn_b(jpi,jpj)  ,      & 
     61         &      ua_b(jpi,jpj)   , va_b(jpi,jpj)                                  ,      &  
     62         &      ub2_b(jpi,jpj)  , vb2_b(jpi,jpj)                                 ,      & 
     63         &      un_adv(jpi,jpj) , vn_adv(jpi,jpj)                                ,      & 
    5564         &      sshn_b(jpi,jpj)                                                  , STAT = dynspg_oce_alloc ) 
    5665         ! 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_ts.F90

    r3680 r4292  
    99   !!             3.3  ! 2010-09  (D. Storkey, E. O'Dea) update for BDY for Shelf configurations 
    1010   !!             3.3  ! 2011-03  (R. Benshila, R. Hordoir, P. Oddo) update calculation of ub_b 
     11   !!             3.5  ! 2013-07  (J. Chanut) Switch to Forward-backward time stepping 
     12   !!             3.6  ! 2013-11  (A. Coward) Update for z-tilde compatibility 
    1113   !!--------------------------------------------------------------------- 
    1214#if defined key_dynspg_ts   ||   defined key_esopa 
    … …  
    1618   !!   dyn_spg_ts  : compute surface pressure gradient trend using a time- 
    1719   !!                 splitting scheme and add to the general trend  
    18    !!   ts_rst      : read/write the time-splitting restart fields in the ocean restart file 
    1920   !!---------------------------------------------------------------------- 
    2021   USE oce             ! ocean dynamics and tracers 
    … …  
    2425   USE phycst          ! physical constants 
    2526   USE domvvl          ! variable volume 
    26    USE zdfbfr          ! bottom friction 
    2727   USE dynvor          ! vorticity term 
    28    USE obc_oce         ! Lateral open boundary condition 
    29    USE obc_par         ! open boundary condition parameters 
    30    USE obcdta          ! open boundary condition data      
    31    USE obcfla          ! Flather open boundary condition   
    3228   USE bdy_par         ! for lk_bdy 
    3329   USE bdy_oce         ! Lateral open boundary condition 
    34    USE bdydta          ! open boundary condition data      
     30   USE bdytides        ! open boundary condition data      
    3531   USE bdydyn2d        ! open boundary conditions on barotropic variables 
    36    USE sbctide 
    37    USE updtide 
     32   USE sbctide         ! tides 
     33   USE updtide         ! tide potential 
    3834   USE lib_mpp         ! distributed memory computing library 
    3935   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    … …  
    4137   USE in_out_manager  ! I/O manager 
    4238   USE iom             ! IOM library 
     39   USE restart         ! only for lrst_oce 
    4340   USE zdf_oce         ! Vertical diffusion 
    4441   USE wrk_nemo        ! Memory Allocation 
    45    USE timing          ! Timing 
     42   USE timing          ! Timing     
     43   USE sbcapr          ! surface boundary condition: atmospheric pressure 
     44   USE dynadv, ONLY: ln_dynadv_vec 
     45#if defined key_agrif 
     46   USE agrif_opa_interp ! agrif 
     47#endif 
    4648 
    4749 
    … …  
    4951   PRIVATE 
    5052 
    51    PUBLIC dyn_spg_ts        ! routine called by step.F90 
    52    PUBLIC ts_rst            ! routine called by istate.F90 
    53    PUBLIC dyn_spg_ts_alloc  ! routine called by dynspg.F90 
    54  
    55  
     53   PUBLIC dyn_spg_ts        ! routine called in dynspg.F90  
     54   PUBLIC dyn_spg_ts_alloc  !    "      "     "    " 
     55   PUBLIC dyn_spg_ts_init   !    "      "     "    " 
     56 
     57   ! Potential namelist parameters below to be read in dyn_spg_ts_init 
     58   LOGICAL,  PUBLIC,  PARAMETER :: ln_bt_fw=.TRUE.        !: Forward integration of barotropic sub-stepping 
     59   LOGICAL,  PRIVATE, PARAMETER :: ln_bt_av=.TRUE.        !: Time averaging of barotropic variables 
     60   LOGICAL,  PRIVATE, PARAMETER :: ln_bt_nn_auto=.FALSE.  !: Set number of iterations automatically 
     61   INTEGER,  PRIVATE, PARAMETER :: nn_bt_flt=1            !: Filter choice 
     62   REAL(wp), PRIVATE, PARAMETER :: rn_bt_cmax=0.8_wp      !: Max. courant number (used if ln_bt_nn_auto=T) 
     63   ! End namelist parameters 
     64 
     65   INTEGER, SAVE :: icycle  ! Number of barotropic sub-steps for each internal step nn_baro <= 2.5 nn_baro 
     66   REAL(wp),SAVE :: rdtbt   ! Barotropic time step 
     67 
     68   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: & 
     69                    wgtbtp1, &              ! Primary weights used for time filtering of barotropic variables 
     70                    wgtbtp2                 ! Secondary weights used for time filtering of barotropic variables 
     71 
     72   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::  zwz          ! ff/h at F points 
    5673   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::  ftnw, ftne   ! triad of coriolis parameter 
    5774   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::  ftsw, ftse   ! (only used with een vorticity scheme) 
    5875 
    59    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   un_b, vn_b   ! now    averaged velocity 
    60    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ub_b, vb_b   ! before averaged velocity 
     76   ! Arrays below are saved to allow testing of the "no time averaging" option 
     77   ! If this option is not retained, these could be replaced by temporary arrays 
     78   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::  sshbb_e, sshb_e, & ! Instantaneous barotropic arrays 
     79                                                   ubb_e, ub_e,     & 
     80                                                   vbb_e, vb_e 
    6181 
    6282   !! * Substitutions 
    … …  
    6484#  include "vectopt_loop_substitute.h90" 
    6585   !!---------------------------------------------------------------------- 
    66    !! NEMO/OPA 4.0 , NEMO Consortium (2011) 
    67    !! $Id$ 
     86   !! NEMO/OPA 3.5 , NEMO Consortium (2013) 
     87   !! $Id: dynspg_ts.F90 
    6888   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    6989   !!---------------------------------------------------------------------- 
    … …  
    7494      !!                  ***  routine dyn_spg_ts_alloc  *** 
    7595      !!---------------------------------------------------------------------- 
    76       ALLOCATE( ftnw  (jpi,jpj) , ftne(jpi,jpj) , un_b(jpi,jpj) , vn_b(jpi,jpj) ,     & 
    77          &      ftsw  (jpi,jpj) , ftse(jpi,jpj) , ub_b(jpi,jpj) , vb_b(jpi,jpj) , STAT= dyn_spg_ts_alloc ) 
    78          ! 
     96      INTEGER :: ierr(3) 
     97      !!---------------------------------------------------------------------- 
     98      ierr(:) = 0 
     99 
     100      ALLOCATE( sshb_e(jpi,jpj), sshbb_e(jpi,jpj), & 
     101         &      ub_e(jpi,jpj)  , vb_e(jpi,jpj)   , & 
     102         &      ubb_e(jpi,jpj) , vbb_e(jpi,jpj)  , STAT= ierr(1) ) 
     103 
     104      ALLOCATE( wgtbtp1(3*nn_baro), wgtbtp2(3*nn_baro), zwz(jpi,jpj), STAT= ierr(2) ) 
     105 
     106      IF( ln_dynvor_een ) ALLOCATE( ftnw(jpi,jpj) , ftne(jpi,jpj) , &  
     107                             &      ftsw(jpi,jpj) , ftse(jpi,jpj) , STAT=ierr(3) ) 
     108 
     109      dyn_spg_ts_alloc = MAXVAL(ierr(:)) 
     110 
    79111      IF( lk_mpp                )   CALL mpp_sum( dyn_spg_ts_alloc ) 
    80112      IF( dyn_spg_ts_alloc /= 0 )   CALL ctl_warn('dynspg_oce_alloc: failed to allocate arrays') 
    … …  
    82114   END FUNCTION dyn_spg_ts_alloc 
    83115 
    84  
    85116   SUBROUTINE dyn_spg_ts( kt ) 
    86117      !!---------------------------------------------------------------------- 
    87       !!                  ***  routine dyn_spg_ts  *** 
    88118      !! 
    89       !! ** Purpose :   Compute the now trend due to the surface pressure 
    90       !!      gradient in case of free surface formulation with time-splitting. 
    91       !!      Add it to the general trend of momentum equation. 
     119      !! ** Purpose :    
     120      !!      -Compute the now trend due to the explicit time stepping 
     121      !!      of the quasi-linear barotropic system. Barotropic variables are 
     122      !!      advanced from internal time steps "n" to "n+1" (if ln_bt_cen=F) 
     123      !!      or from "n-1" to "n+1" time steps (if ln_bt_cen=T) with a 
     124      !!      generalized forward-backward (see ref. below) time stepping. 
     125      !!      -Update the free surface at step "n+1" (ssha, zsshu_a, zsshv_a). 
     126      !!      -Compute barotropic advective velocities at step "n" to be used  
     127      !!      to advect tracers latter on. These are compliant with discrete 
     128      !!      continuity equation taken at the baroclinic time steps, thus  
     129      !!      ensuring tracers conservation. 
    92130      !! 
    93       !! ** Method  :   Free surface formulation with time-splitting 
    94       !!      -1- Save the vertically integrated trend. This general trend is 
    95       !!          held constant over the barotropic integration. 
    96       !!          The Coriolis force is removed from the general trend as the 
    97       !!          surface gradient and the Coriolis force are updated within 
    98       !!          the barotropic integration. 
    99       !!      -2- Barotropic loop : updates of sea surface height (ssha_e) and  
    100       !!          barotropic velocity (ua_e and va_e) through barotropic  
    101       !!          momentum and continuity integration. Barotropic former  
    102       !!          variables are time averaging over the full barotropic cycle 
    103       !!          (= 2 * baroclinic time step) and saved in uX_b  
    104       !!          and vX_b (X specifying after, now or before). 
    105       !!      -3- The new general trend becomes : 
    106       !!          ua = ua - sum_k(ua)/H + ( un_b - ub_b ) 
     131      !! ** Method  :   
    107132      !! 
    108       !! ** Action : - Update (ua,va) with the surf. pressure gradient trend 
     133      !! ** Action : - Update barotropic velocities: ua_b, va_b 
     134      !!             - Update trend (ua,va) with barotropic component 
     135      !!             - Update ssha, zsshu_a, zsshv_a 
     136      !!             - Update barotropic advective velocity at kt=now 
    109137      !! 
    110       !! References : Griffies et al., (2003): A technical guide to MOM4. NOAA/GFDL 
     138      !! References : Shchepetkin, A.F. and J.C. McWilliams, 2005:  
     139      !!              The regional oceanic modeling system (ROMS):  
     140      !!              a split-explicit, free-surface, 
     141      !!              topography-following-coordinate oceanic model.  
     142      !!              Ocean Modelling, 9, 347-404.  
    111143      !!--------------------------------------------------------------------- 
    112144      ! 
    113145      INTEGER, INTENT(in)  ::   kt   ! ocean time-step index 
    114146      ! 
    115       INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    116       INTEGER  ::   icycle           ! local scalar 
    117       INTEGER  ::   ikbu, ikbv       ! local scalar 
    118       REAL(wp) ::   zraur, zcoef, z2dt_e, z1_2dt_b, z2dt_bf   ! local scalars 
    119       REAL(wp) ::   z1_8, zx1, zy1                            !   -      - 
    120       REAL(wp) ::   z1_4, zx2, zy2                            !   -      - 
    121       REAL(wp) ::   zu_spg, zu_cor, zu_sld, zu_asp            !   -      - 
    122       REAL(wp) ::   zv_spg, zv_cor, zv_sld, zv_asp            !   -      - 
    123       REAL(wp) ::   ua_btm, va_btm                            !   -      - 
    124       ! 
    125       REAL(wp), POINTER, DIMENSION(:,:) :: zsshun_e, zsshvn_e, zsshb_e, zssh_sum, zhdiv  
    126       REAL(wp), POINTER, DIMENSION(:,:) :: zua, zva, zun, zvn, zun_e, zvn_e, zub_e, zvb_e  
    127       REAL(wp), POINTER, DIMENSION(:,:) :: zcu, zcv, zwx, zwy, zbfru, zbfrv, zu_sum, zv_sum 
     147      LOGICAL  ::   ll_fw_start        ! if true, forward integration  
     148      LOGICAL  ::   ll_init         ! if true, special startup of 2d equations 
     149      INTEGER  ::   ji, jj, jk, jn        ! dummy loop indices 
     150      INTEGER  ::   ikbu, ikbv, noffset      ! local integers 
     151      REAL(wp) ::   zraur, z1_2dt_b, z2dt_bf    ! local scalars 
     152      REAL(wp) ::   zx1, zy1, zx2, zy2          !   -      - 
     153      REAL(wp) ::   z1_12, z1_8, z1_4, z1_2  !   -      - 
     154      REAL(wp) ::   zu_spg, zv_spg     !   -      - 
     155      REAL(wp) ::   zhura, zhvra          !   -      - 
     156      REAL(wp) ::   za0, za1, za2, za3    !   -      - 
     157      ! 
     158      REAL(wp), POINTER, DIMENSION(:,:) :: zun_e, zvn_e, zsshp2_e 
     159      REAL(wp), POINTER, DIMENSION(:,:) :: zu_trd, zv_trd, zu_frc, zv_frc, zssh_frc 
     160      REAL(wp), POINTER, DIMENSION(:,:) :: zu_sum, zv_sum, zwx, zwy, zhdiv 
     161      REAL(wp), POINTER, DIMENSION(:,:) :: zhup2_e, zhvp2_e, zhust_e, zhvst_e 
     162      REAL(wp), POINTER, DIMENSION(:,:) :: zhur_b, zhvr_b 
     163      REAL(wp), POINTER, DIMENSION(:,:) :: zsshu_a, zsshv_a 
     164      REAL(wp), POINTER, DIMENSION(:,:) :: zht, zhf 
    128165      !!---------------------------------------------------------------------- 
    129166      ! 
    130167      IF( nn_timing == 1 )  CALL timing_start('dyn_spg_ts') 
    131168      ! 
    132       CALL wrk_alloc( jpi, jpj, zsshun_e, zsshvn_e, zsshb_e, zssh_sum, zhdiv     ) 
    133       CALL wrk_alloc( jpi, jpj, zua, zva, zun, zvn, zun_e, zvn_e, zub_e, zvb_e   ) 
    134       CALL wrk_alloc( jpi, jpj, zcu, zcv, zwx, zwy, zbfru, zbfrv, zu_sum, zv_sum ) 
    135       ! 
    136       IF( kt == nit000 ) THEN             !* initialisation 
     169      !                                         !* Allocate temporay arrays 
     170      CALL wrk_alloc( jpi, jpj, zsshp2_e, zhdiv ) 
     171      CALL wrk_alloc( jpi, jpj, zu_trd, zv_trd, zun_e, zvn_e  ) 
     172      CALL wrk_alloc( jpi, jpj, zwx, zwy, zu_sum, zv_sum, zssh_frc, zu_frc, zv_frc) 
     173      CALL wrk_alloc( jpi, jpj, zhup2_e, zhvp2_e, zhust_e, zhvst_e) 
     174      CALL wrk_alloc( jpi, jpj, zhur_b, zhvr_b                                     ) 
     175      CALL wrk_alloc( jpi, jpj, zsshu_a, zsshv_a                                   ) 
     176      CALL wrk_alloc( jpi, jpj, zht, zhf ) 
     177      ! 
     178      !                                         !* Local constant initialization 
     179      z1_12 = 1._wp / 12._wp  
     180      z1_8  = 0.125_wp                                    
     181      z1_4  = 0.25_wp 
     182      z1_2  = 0.5_wp      
     183      zraur = 1._wp / rau0 
     184      ! 
     185      IF( kt == nit000 .AND. neuler == 0 ) THEN    ! reciprocal of baroclinic time step  
     186        z2dt_bf = rdt 
     187      ELSE 
     188        z2dt_bf = 2.0_wp * rdt 
     189      ENDIF 
     190      z1_2dt_b = 1.0_wp / z2dt_bf  
     191      ! 
     192      ll_init = ln_bt_av                           ! if no time averaging, then no specific restart  
     193      ll_fw_start = .FALSE. 
     194      ! 
     195                                                       ! time offset in steps for bdy data update 
     196      IF (.NOT.ln_bt_fw) THEN ; noffset=-2*nn_baro ; ELSE ;  noffset = 0 ; ENDIF 
     197      ! 
     198      IF( kt == nit000 ) THEN                !* initialisation 
    137199         ! 
    138200         IF(lwp) WRITE(numout,*) 
    … …  
    141203         IF(lwp) WRITE(numout,*) ' Number of sub cycle in 1 time-step (2 rdt) : icycle = ',  2*nn_baro 
    142204         ! 
    143          CALL ts_rst( nit000, 'READ' )   ! read or initialize the following fields: un_b, vn_b   
    144          ! 
    145          ua_e  (:,:) = un_b (:,:) 
    146          va_e  (:,:) = vn_b (:,:) 
    147          hu_e  (:,:) = hu   (:,:) 
    148          hv_e  (:,:) = hv   (:,:) 
    149          hur_e (:,:) = hur  (:,:) 
    150          hvr_e (:,:) = hvr  (:,:) 
    151          IF( ln_dynvor_een ) THEN 
    152             ftne(1,:) = 0._wp   ;   ftnw(1,:) = 0._wp   ;   ftse(1,:) = 0._wp   ;   ftsw(1,:) = 0._wp 
     205         IF (neuler==0) ll_init=.TRUE. 
     206         ! 
     207         IF (ln_bt_fw.OR.(neuler==0)) THEN 
     208           ll_fw_start=.TRUE. 
     209           noffset = 0 
     210         ELSE 
     211           ll_fw_start=.FALSE. 
     212         ENDIF 
     213         ! 
     214         ! Set averaging weights and cycle length: 
     215         CALL ts_wgt(ln_bt_av, ll_fw_start, icycle, wgtbtp1, wgtbtp2) 
     216         ! 
     217         IF ((neuler/=0).AND.(ln_bt_fw)) CALL ts_rst( nit000, 'READ' )  
     218         ! 
     219      ENDIF 
     220      ! 
     221      ! Set arrays to remove/compute coriolis trend. 
     222      ! Do it once at kt=nit000 if volume is fixed, else at each long time step. 
     223      ! Note that these arrays are also used during barotropic loop. These are however frozen 
     224      ! although they should be updated in variable volume case. Not a big approximation. 
     225      ! To remove this approximation, copy lines below inside barotropic loop 
     226      ! and update depths at T-F points (ht and hf resp.) at each barotropic time step 
     227      ! 
     228      IF ( kt == nit000 .OR. lk_vvl ) THEN 
     229         IF ( ln_dynvor_een ) THEN 
     230            ! JC: Simplification needed below: define ht_0 even when volume is fixed 
     231            IF (lk_vvl) THEN 
     232               zht(:,:) = (ht_0(:,:) + sshn(:,:)) * tmask(:,:,1)  
     233            ELSE 
     234               zht(:,:) = 0. 
     235               DO jk = 1, jpkm1 
     236                  zht(:,:) = zht(:,:) + fse3t_n(:,:,jk) * tmask(:,:,jk) 
     237               END DO 
     238            ENDIF 
     239 
     240            DO jj = 1, jpjm1 
     241               DO ji = 1, jpim1 
     242                  zwz(ji,jj) =   ( zht(ji  ,jj+1) + zht(ji+1,jj+1) +                     & 
     243                        &          zht(ji  ,jj  ) + zht(ji+1,jj  )   )                   & 
     244                        &      / ( MAX( 1.0_wp, tmask(ji  ,jj+1, 1) + tmask(ji+1,jj+1, 1) +    & 
     245                        &                       tmask(ji  ,jj  , 1) + tmask(ji+1,jj  , 1) ) ) 
     246                  IF( zwz(ji,jj) /= 0._wp )   zwz(ji,jj) = 1._wp / zwz(ji,jj) 
     247               END DO 
     248            END DO 
     249            CALL lbc_lnk( zwz, 'F', 1._wp ) 
     250            zwz(:,:) = ff(:,:) * zwz(:,:) 
     251 
     252            ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp 
    153253            DO jj = 2, jpj 
    154254               DO ji = fs_2, jpi   ! vector opt. 
    155                   ftne(ji,jj) = ( ff(ji-1,jj  ) + ff(ji  ,jj  ) + ff(ji  ,jj-1) ) / 3._wp 
    156                   ftnw(ji,jj) = ( ff(ji-1,jj-1) + ff(ji-1,jj  ) + ff(ji  ,jj  ) ) / 3._wp 
    157                   ftse(ji,jj) = ( ff(ji  ,jj  ) + ff(ji  ,jj-1) + ff(ji-1,jj-1) ) / 3._wp 
    158                   ftsw(ji,jj) = ( ff(ji  ,jj-1) + ff(ji-1,jj-1) + ff(ji-1,jj  ) ) / 3._wp 
    159                END DO 
    160             END DO 
    161          ENDIF 
    162          ! 
    163       ENDIF 
    164  
    165       !                                                     !* Local constant initialization 
    166       z1_2dt_b = 1._wp / ( 2.0_wp * rdt )                   ! reciprocal of baroclinic time step 
    167       IF( neuler == 0 .AND. kt == nit000 )   z1_2dt_b = 1.0_wp / rdt    ! reciprocal of baroclinic  
    168                                                                         ! time step (euler timestep) 
    169       z1_8     = 0.125_wp                                   ! coefficient for vorticity estimates 
    170       z1_4     = 0.25_wp         
    171       zraur    = 1._wp / rau0                               ! 1 / volumic mass 
    172       ! 
    173       zhdiv(:,:) = 0._wp                                    ! barotropic divergence 
    174       zu_sld = 0._wp   ;   zu_asp = 0._wp                   ! tides trends (lk_tide=F) 
    175       zv_sld = 0._wp   ;   zv_asp = 0._wp 
    176  
    177       IF( kt == nit000 .AND. neuler == 0) THEN              ! for implicit bottom friction 
    178         z2dt_bf = rdt 
    179       ELSE 
    180         z2dt_bf = 2.0_wp * rdt 
    181       ENDIF 
    182  
     255                  ftne(ji,jj) = zwz(ji-1,jj  ) + zwz(ji  ,jj  ) + zwz(ji  ,jj-1) 
     256                  ftnw(ji,jj) = zwz(ji-1,jj-1) + zwz(ji-1,jj  ) + zwz(ji  ,jj  ) 
     257                  ftse(ji,jj) = zwz(ji  ,jj  ) + zwz(ji  ,jj-1) + zwz(ji-1,jj-1) 
     258                  ftsw(ji,jj) = zwz(ji  ,jj-1) + zwz(ji-1,jj-1) + zwz(ji-1,jj  ) 
     259               END DO 
     260            END DO 
     261         ELSE 
     262            zwz(:,:) = 0._wp 
     263            zht(:,:) = 0. 
     264            IF ( .not. ln_sco ) THEN 
     265!              IF( rn_hmin < 0._wp ) THEN    ;   jk = - INT( rn_hmin )                                      ! from a nb of level 
     266!              ELSE                          ;   jk = MINLOC( gdepw_0, mask = gdepw_0 > rn_hmin, dim = 1 )  ! from a depth 
     267!              ENDIF 
     268!              zht(:,:) = gdepw_0(:,:,jk+1) 
     269            ELSE 
     270               zht(:,:) = hbatf(:,:) 
     271            END IF 
     272 
     273            DO jj = 1, jpjm1 
     274               zht(:,jj) = zht(:,jj)*(1._wp- umask(:,jj,1) * umask(:,jj+1,1)) 
     275            END DO 
     276 
     277            DO jk = 1, jpkm1 
     278               DO jj = 1, jpjm1 
     279                  zht(:,jj) = zht(:,jj) + fse3f_n(:,jj,jk) * umask(:,jj,jk) * umask(:,jj+1,jk) 
     280               END DO 
     281            END DO 
     282            CALL lbc_lnk( zht, 'F', 1._wp ) 
     283            ! JC: TBC. hf should be greater than 0  
     284            DO jj = 1, jpj 
     285               DO ji = 1, jpi 
     286                  IF( zht(ji,jj) /= 0._wp )   zwz(ji,jj) = 1._wp / zht(ji,jj) ! zht is actually hf here but it saves an array 
     287               END DO 
     288            END DO 
     289            zwz(:,:) = ff(:,:) * zwz(:,:) 
     290         ENDIF 
     291      ENDIF 
     292      ! 
     293      ! If forward start at previous time step, and centered integration,  
     294      ! then update averaging weights: 
     295      IF ((.NOT.ln_bt_fw).AND.((neuler==0).AND.(kt==nit000+1))) THEN 
     296         ll_fw_start=.FALSE. 
     297         CALL ts_wgt(ln_bt_av, ll_fw_start, icycle, wgtbtp1, wgtbtp2) 
     298      ENDIF 
     299 
     300      ! before inverse water column height at u- and v- points 
     301      IF( lk_vvl ) THEN 
     302         zhur_b(:,:) = 0. 
     303         zhvr_b(:,:) = 0. 
     304         DO jk = 1, jpk 
     305            zhur_b(:,:) = zhur_b(:,:) + fse3u_b(:,:,jk) * umask(:,:,jk) 
     306            zhvr_b(:,:) = zhvr_b(:,:) + fse3v_b(:,:,jk) * vmask(:,:,jk) 
     307         END DO 
     308         zhur_b(:,:) = umask(:,:,1) / ( zhur_b(:,:) + 1. - umask(:,:,1) ) 
     309         zhvr_b(:,:) = vmask(:,:,1) / ( zhvr_b(:,:) + 1. - vmask(:,:,1) ) 
     310      ELSE 
     311         zhur_b(:,:) = hur(:,:) 
     312         zhvr_b(:,:) = hvr(:,:) 
     313      ENDIF 
     314                           
    183315      ! ----------------------------------------------------------------------------- 
    184316      !  Phase 1 : Coupling between general trend and barotropic estimates (1st step) 
    185317      ! ----------------------------------------------------------------------------- 
    186318      !       
     319      ! Some vertical sums (at now and before time steps) below could be suppressed  
     320      ! if one swap barotropic arrays somewhere 
     321      ! 
    187322      !                                   !* e3*d/dt(Ua), e3*Ub, e3*Vn (Vertically integrated) 
    188       !                                   ! -------------------------- 
    189       zua(:,:) = 0._wp   ;   zun(:,:) = 0._wp   ;   ub_b(:,:) = 0._wp 
    190       zva(:,:) = 0._wp   ;   zvn(:,:) = 0._wp   ;   vb_b(:,:) = 0._wp 
     323      !                                   ! -------------------------------------------------- 
     324      zu_frc(:,:) = 0._wp   ;   ub_b(:,:) = 0._wp  ;  un_b(:,:) = 0._wp 
     325      zv_frc(:,:) = 0._wp   ;   vb_b(:,:) = 0._wp  ;  vn_b(:,:) = 0._wp 
    191326      ! 
    192327      DO jk = 1, jpkm1 
    … …  
    198333            DO ji = 1, jpi 
    199334#endif 
    200                !                                                                              ! now trend 
    201                zua(ji,jj) = zua(ji,jj) + fse3u  (ji,jj,jk) * ua(ji,jj,jk) * umask(ji,jj,jk) 
    202                zva(ji,jj) = zva(ji,jj) + fse3v  (ji,jj,jk) * va(ji,jj,jk) * vmask(ji,jj,jk) 
    203                !                                                                              ! now velocity  
    204                zun(ji,jj) = zun(ji,jj) + fse3u  (ji,jj,jk) * un(ji,jj,jk) 
    205                zvn(ji,jj) = zvn(ji,jj) + fse3v  (ji,jj,jk) * vn(ji,jj,jk)                
    206                ! 
    207 #if defined key_vvl 
    208                ub_b(ji,jj) = ub_b(ji,jj) + fse3u_b(ji,jj,jk)* ub(ji,jj,jk)   *umask(ji,jj,jk)  
    209                vb_b(ji,jj) = vb_b(ji,jj) + fse3v_b(ji,jj,jk)* vb(ji,jj,jk)   *vmask(ji,jj,jk) 
    210 #else 
    211                ub_b(ji,jj) = ub_b(ji,jj) + fse3u_0(ji,jj,jk) * ub(ji,jj,jk)  * umask(ji,jj,jk) 
    212                vb_b(ji,jj) = vb_b(ji,jj) + fse3v_0(ji,jj,jk) * vb(ji,jj,jk)  * vmask(ji,jj,jk) 
    213 #endif 
     335               !        ! now trend:                                                                    
     336               zu_frc(ji,jj) = zu_frc(ji,jj) + fse3u(ji,jj,jk) * ua(ji,jj,jk) * umask(ji,jj,jk) 
     337               zv_frc(ji,jj) = zv_frc(ji,jj) + fse3v(ji,jj,jk) * va(ji,jj,jk) * vmask(ji,jj,jk)          
     338               !        ! now bt transp:                    
     339               un_b(ji,jj) = un_b(ji,jj) + fse3u(ji,jj,jk) * un(ji,jj,jk) * umask(ji,jj,jk)         
     340               vn_b(ji,jj) = vn_b(ji,jj) + fse3v(ji,jj,jk) * vn(ji,jj,jk) * vmask(ji,jj,jk) 
     341               !  ! before bt transp: 
     342               ub_b(ji,jj) = ub_b(ji,jj) + fse3u_b(ji,jj,jk) * ub(ji,jj,jk)  * umask(ji,jj,jk) 
     343               vb_b(ji,jj) = vb_b(ji,jj) + fse3v_b(ji,jj,jk) * vb(ji,jj,jk)  * vmask(ji,jj,jk) 
    214344            END DO 
    215345         END DO 
    216346      END DO 
    217  
     347      ! 
     348      zu_frc(:,:) = zu_frc(:,:) * hur(:,:) 
     349      zv_frc(:,:) = zv_frc(:,:) * hvr(:,:) 
     350      ! 
     351      IF( lk_vvl ) THEN 
     352          ub_b(:,:) = ub_b(:,:) * zhur_b(:,:) 
     353          vb_b(:,:) = vb_b(:,:) * zhvr_b(:,:) 
     354      ELSE 
     355          ub_b(:,:) = ub_b(:,:) * hur(:,:) 
     356          vb_b(:,:) = vb_b(:,:) * hvr(:,:) 
     357      ENDIF 
     358      ! 
    218359      !                                   !* baroclinic momentum trend (remove the vertical mean trend) 
    219       DO jk = 1, jpkm1                    ! -------------------------- 
     360      DO jk = 1, jpkm1                    ! ----------------------------------------------------------- 
    220361         DO jj = 2, jpjm1 
    221362            DO ji = fs_2, fs_jpim1   ! vector opt. 
    222                ua(ji,jj,jk) = ua(ji,jj,jk) - zua(ji,jj) * hur(ji,jj) 
    223                va(ji,jj,jk) = va(ji,jj,jk) - zva(ji,jj) * hvr(ji,jj) 
     363               ua(ji,jj,jk) = ua(ji,jj,jk) - zu_frc(ji,jj) * umask(ji,jj,jk) 
     364               va(ji,jj,jk) = va(ji,jj,jk) - zv_frc(ji,jj) * vmask(ji,jj,jk) 
    224365            END DO 
    225366         END DO 
    226367      END DO 
    227  
    228       !                                   !* barotropic Coriolis trends * H (vorticity scheme dependent) 
    229       !                                   ! ---------------------------==== 
    230       zwx(:,:) = zun(:,:) * e2u(:,:)                   ! now transport  
    231       zwy(:,:) = zvn(:,:) * e1v(:,:) 
     368      !                                   !* barotropic Coriolis trends (vorticity scheme dependent) 
     369      !                                   ! -------------------------------------------------------- 
     370      zwx(:,:) = un_b(:,:) * e2u(:,:)           ! now transport  
     371      zwy(:,:) = vn_b(:,:) * e1v(:,:) 
    232372      ! 
    233373      IF( ln_dynvor_ene .OR. ln_dynvor_mix ) THEN      ! energy conserving or mixed scheme 
    … …  
    239379               zx2 = ( zwx(ji  ,jj) + zwx(ji  ,jj+1) ) / e2v(ji,jj) 
    240380               ! energy conserving formulation for planetary vorticity term 
    241                zcu(ji,jj) = z1_4 * ( ff(ji  ,jj-1) * zy1 + ff(ji,jj) * zy2 ) 
    242                zcv(ji,jj) =-z1_4 * ( ff(ji-1,jj  ) * zx1 + ff(ji,jj) * zx2 ) 
    243             END DO 
    244          END DO 
    245          ! 
    246       ELSEIF ( ln_dynvor_ens ) THEN                    ! enstrophy conserving scheme 
     381               zu_trd(ji,jj) = z1_4 * ( zwz(ji  ,jj-1) * zy1 + zwz(ji,jj) * zy2 ) 
     382               zv_trd(ji,jj) =-z1_4 * ( zwz(ji-1,jj  ) * zx1 + zwz(ji,jj) * zx2 ) 
     383            END DO 
     384         END DO 
     385         ! 
     386      ELSEIF ( ln_dynvor_ens ) THEN             ! enstrophy conserving scheme 
    247387         DO jj = 2, jpjm1 
    248388            DO ji = fs_2, fs_jpim1   ! vector opt. 
    249                zy1 =   z1_8 * ( zwy(ji  ,jj-1) + zwy(ji+1,jj-1) + zwy(ji,jj) + zwy(ji+1,jj  ) ) / e1u(ji,jj) 
    250                zx1 = - z1_8 * ( zwx(ji-1,jj  ) + zwx(ji-1,jj+1) + zwx(ji,jj) + zwx(ji  ,jj+1) ) / e2v(ji,jj) 
    251                zcu(ji,jj)  = zy1 * ( ff(ji  ,jj-1) + ff(ji,jj) ) 
    252                zcv(ji,jj)  = zx1 * ( ff(ji-1,jj  ) + ff(ji,jj) ) 
    253             END DO 
    254          END DO 
    255          ! 
    256       ELSEIF ( ln_dynvor_een ) THEN                    ! enstrophy and energy conserving scheme 
     389               zy1 =   z1_8 * ( zwy(ji  ,jj-1) + zwy(ji+1,jj-1) & 
     390                 &            + zwy(ji  ,jj  ) + zwy(ji+1,jj  ) ) / e1u(ji,jj) 
     391               zx1 = - z1_8 * ( zwx(ji-1,jj  ) + zwx(ji-1,jj+1) & 
     392                 &            + zwx(ji  ,jj  ) + zwx(ji  ,jj+1) ) / e2v(ji,jj) 
     393               zu_trd(ji,jj)  = zy1 * ( zwz(ji  ,jj-1) + zwz(ji,jj) ) 
     394               zv_trd(ji,jj)  = zx1 * ( zwz(ji-1,jj  ) + zwz(ji,jj) ) 
     395            END DO 
     396         END DO 
     397         ! 
     398      ELSEIF ( ln_dynvor_een ) THEN             ! enstrophy and energy conserving scheme 
    257399         DO jj = 2, jpjm1 
    258400            DO ji = fs_2, fs_jpim1   ! vector opt. 
    259                zcu(ji,jj) = + z1_4 / e1u(ji,jj) * (  ftne(ji,jj  ) * zwy(ji  ,jj  ) + ftnw(ji+1,jj) * zwy(ji+1,jj  )   & 
    260                   &                                + ftse(ji,jj  ) * zwy(ji  ,jj-1) + ftsw(ji+1,jj) * zwy(ji+1,jj-1) ) 
    261                zcv(ji,jj) = - z1_4 / e2v(ji,jj) * (  ftsw(ji,jj+1) * zwx(ji-1,jj+1) + ftse(ji,jj+1) * zwx(ji  ,jj+1)   & 
    262                   &                                + ftnw(ji,jj  ) * zwx(ji-1,jj  ) + ftne(ji,jj  ) * zwx(ji  ,jj  ) ) 
    263             END DO 
    264          END DO 
    265          ! 
    266       ENDIF 
    267  
     401               zu_trd(ji,jj) = + z1_12 / e1u(ji,jj) * (  ftne(ji,jj  ) * zwy(ji  ,jj  ) & 
     402                &                                      + ftnw(ji+1,jj) * zwy(ji+1,jj  ) & 
     403                &                                      + ftse(ji,jj  ) * zwy(ji  ,jj-1) & 
     404                &                                      + ftsw(ji+1,jj) * zwy(ji+1,jj-1) ) 
     405               zv_trd(ji,jj) = - z1_12 / e2v(ji,jj) * (  ftsw(ji,jj+1) * zwx(ji-1,jj+1) & 
     406                &                                      + ftse(ji,jj+1) * zwx(ji  ,jj+1) & 
     407                &                                      + ftnw(ji,jj  ) * zwx(ji-1,jj  ) & 
     408                &                                      + ftne(ji,jj  ) * zwx(ji  ,jj  ) ) 
     409            END DO 
     410         END DO 
     411         ! 
     412      ENDIF  
     413      ! 
     414      un_b (:,:) = un_b(:,:) * hur(:,:)         ! Revert now transport to barotropic velocities 
     415      vn_b (:,:) = vn_b(:,:) * hvr(:,:)   
    268416      !                                   !* Right-Hand-Side of the barotropic momentum equation 
    269417      !                                   ! ---------------------------------------------------- 
    270       IF( lk_vvl ) THEN                         ! Variable volume : remove both Coriolis and Surface pressure gradient 
     418      IF( lk_vvl ) THEN                         ! Variable volume : remove surface pressure gradient 
    271419         DO jj = 2, jpjm1  
    272420            DO ji = fs_2, fs_jpim1   ! vector opt. 
    273                zcu(ji,jj) = zcu(ji,jj) - grav * (  ( rhd(ji+1,jj  ,1) + 1 ) * sshn(ji+1,jj  )    & 
    274                   &                              - ( rhd(ji  ,jj  ,1) + 1 ) * sshn(ji  ,jj  )  ) * hu(ji,jj) / e1u(ji,jj) 
    275                zcv(ji,jj) = zcv(ji,jj) - grav * (  ( rhd(ji  ,jj+1,1) + 1 ) * sshn(ji  ,jj+1)    & 
    276                   &                              - ( rhd(ji  ,jj  ,1) + 1 ) * sshn(ji  ,jj  )  ) * hv(ji,jj) / e2v(ji,jj) 
    277             END DO 
    278          END DO 
    279       ENDIF 
    280  
    281       DO jj = 2, jpjm1                             ! Remove coriolis term (and possibly spg) from barotropic trend 
     421               zu_trd(ji,jj) = zu_trd(ji,jj) - grav * (  sshn(ji+1,jj  ) - sshn(ji  ,jj  )  ) / e1u(ji,jj) 
     422               zv_trd(ji,jj) = zv_trd(ji,jj) - grav * (  sshn(ji  ,jj+1) - sshn(ji  ,jj  )  ) / e2v(ji,jj) 
     423            END DO 
     424         END DO 
     425      ENDIF 
     426 
     427      DO jj = 2, jpjm1                          ! Remove coriolis term (and possibly spg) from barotropic trend 
    282428         DO ji = fs_2, fs_jpim1 
    283              zua(ji,jj) = zua(ji,jj) - zcu(ji,jj) 
    284              zva(ji,jj) = zva(ji,jj) - zcv(ji,jj) 
     429             zu_frc(ji,jj) = zu_frc(ji,jj) - zu_trd(ji,jj) * umask(ji,jj,1) 
     430             zv_frc(ji,jj) = zv_frc(ji,jj) - zv_trd(ji,jj) * vmask(ji,jj,1) 
    285431          END DO 
    286       END DO 
    287  
    288                      
    289       !                                             ! Remove barotropic contribution of bottom friction  
    290       !                                             ! from the barotropic transport trend 
    291       zcoef = -1._wp * z1_2dt_b 
    292  
    293       IF(ln_bfrimp) THEN 
    294       !                                   ! Remove the bottom stress trend from 3-D sea surface level gradient 
    295       !                                   ! and Coriolis forcing in case of 3D semi-implicit bottom friction  
    296         DO jj = 2, jpjm1          
    297            DO ji = fs_2, fs_jpim1 
    298               ikbu = mbku(ji,jj) 
    299               ikbv = mbkv(ji,jj) 
    300               ua_btm = zcu(ji,jj) * z2dt_bf * hur(ji,jj) * umask (ji,jj,ikbu) 
    301               va_btm = zcv(ji,jj) * z2dt_bf * hvr(ji,jj) * vmask (ji,jj,ikbv) 
    302  
    303               zua(ji,jj) = zua(ji,jj) - bfrua(ji,jj) * ua_btm 
    304               zva(ji,jj) = zva(ji,jj) - bfrva(ji,jj) * va_btm 
    305            END DO 
    306         END DO 
    307  
    308       ELSE 
    309  
    310 # if defined key_vectopt_loop 
    311         DO jj = 1, 1 
    312            DO ji = 1, jpij-jpi   ! vector opt. (forced unrolling) 
    313 # else 
    314         DO jj = 2, jpjm1 
    315            DO ji = 2, jpim1 
    316 # endif 
    317             ! Apply stability criteria for bottom friction 
    318             !RBbug for vvl and external mode we may need to use varying fse3 
    319             !!gm  Rq: the bottom e3 present the smallest variation, the use of e3u_0 is not a big approx. 
    320               zbfru(ji,jj) = MAX(  bfrua(ji,jj) , fse3u(ji,jj,mbku(ji,jj)) * zcoef  ) 
    321               zbfrv(ji,jj) = MAX(  bfrva(ji,jj) , fse3v(ji,jj,mbkv(ji,jj)) * zcoef  ) 
    322            END DO 
    323         END DO 
    324  
    325         IF( lk_vvl ) THEN 
    326            DO jj = 2, jpjm1 
    327               DO ji = fs_2, fs_jpim1   ! vector opt. 
    328                  zua(ji,jj) = zua(ji,jj) - zbfru(ji,jj) * ub_b(ji,jj)   & 
    329                     &       / ( hu_0(ji,jj) + sshu_b(ji,jj) + 1._wp - umask(ji,jj,1) ) 
    330                  zva(ji,jj) = zva(ji,jj) - zbfrv(ji,jj) * vb_b(ji,jj)   & 
    331                     &       / ( hv_0(ji,jj) + sshv_b(ji,jj) + 1._wp - vmask(ji,jj,1) ) 
    332               END DO 
    333            END DO 
    334         ELSE 
    335            DO jj = 2, jpjm1 
    336               DO ji = fs_2, fs_jpim1   ! vector opt. 
    337                  zua(ji,jj) = zua(ji,jj) - zbfru(ji,jj) * ub_b(ji,jj) * hur(ji,jj) 
    338                  zva(ji,jj) = zva(ji,jj) - zbfrv(ji,jj) * vb_b(ji,jj) * hvr(ji,jj) 
    339               END DO 
    340            END DO 
    341         ENDIF 
    342       END IF    ! end (ln_bfrimp) 
    343  
    344                      
    345       !                                   !* d/dt(Ua), Ub, Vn (Vertical mean velocity) 
    346       !                                   ! --------------------------  
    347       zua(:,:) = zua(:,:) * hur(:,:) 
    348       zva(:,:) = zva(:,:) * hvr(:,:) 
    349       ! 
    350       IF( lk_vvl ) THEN 
    351          ub_b(:,:) = ub_b(:,:) * umask(:,:,1) / ( hu_0(:,:) + sshu_b(:,:) + 1._wp - umask(:,:,1) ) 
    352          vb_b(:,:) = vb_b(:,:) * vmask(:,:,1) / ( hv_0(:,:) + sshv_b(:,:) + 1._wp - vmask(:,:,1) ) 
    353       ELSE 
    354          ub_b(:,:) = ub_b(:,:) * hur(:,:) 
    355          vb_b(:,:) = vb_b(:,:) * hvr(:,:) 
    356       ENDIF 
    357  
     432      END DO  
     433      ! 
     434      !                 ! Add bottom stress contribution from baroclinic velocities:       
     435      IF (ln_bt_fw) THEN 
     436         DO jj = 2, jpjm1                           
     437            DO ji = fs_2, fs_jpim1   ! vector opt. 
     438               ikbu = mbku(ji,jj)        
     439               ikbv = mbkv(ji,jj)     
     440               zwx(ji,jj) = un(ji,jj,ikbu) - un_b(ji,jj) ! NOW bottom baroclinic velocities 
     441               zwy(ji,jj) = vn(ji,jj,ikbv) - vn_b(ji,jj) 
     442            END DO 
     443         END DO 
     444      ELSE 
     445         DO jj = 2, jpjm1 
     446            DO ji = fs_2, fs_jpim1   ! vector opt. 
     447               ikbu = mbku(ji,jj)        
     448               ikbv = mbkv(ji,jj)     
     449               zwx(ji,jj) = ub(ji,jj,ikbu) - ub_b(ji,jj) ! BEFORE bottom baroclinic velocities 
     450               zwy(ji,jj) = vb(ji,jj,ikbv) - vb_b(ji,jj) 
     451            END DO 
     452         END DO 
     453      ENDIF 
     454      ! 
     455      ! Note that the "unclipped" bottom friction parameter is used even with explicit drag 
     456      zu_frc(:,:) = zu_frc(:,:) + hur(:,:) * bfrua(:,:) * zwx(:,:) 
     457      zv_frc(:,:) = zv_frc(:,:) + hvr(:,:) * bfrva(:,:) * zwy(:,:) 
     458      !        
     459      IF (ln_bt_fw) THEN                        ! Add wind forcing 
     460         zu_frc(:,:) =  zu_frc(:,:) + zraur * utau(:,:) * hur(:,:) 
     461         zv_frc(:,:) =  zv_frc(:,:) + zraur * vtau(:,:) * hvr(:,:) 
     462      ELSE 
     463         zu_frc(:,:) =  zu_frc(:,:) + zraur * z1_2 * ( utau_b(:,:) + utau(:,:) ) * hur(:,:) 
     464         zv_frc(:,:) =  zv_frc(:,:) + zraur * z1_2 * ( vtau_b(:,:) + vtau(:,:) ) * hvr(:,:) 
     465      ENDIF   
     466      ! 
     467      IF ( ln_apr_dyn ) THEN                    ! Add atm pressure forcing 
     468         IF (ln_bt_fw) THEN 
     469            DO jj = 2, jpjm1               
     470               DO ji = fs_2, fs_jpim1   ! vector opt. 
     471                  zu_spg =  grav * (  ssh_ib (ji+1,jj  ) - ssh_ib (ji,jj) ) /e1u(ji,jj) 
     472                  zv_spg =  grav * (  ssh_ib (ji  ,jj+1) - ssh_ib (ji,jj) ) /e2v(ji,jj) 
     473                  zu_frc(ji,jj) = zu_frc(ji,jj) + zu_spg 
     474                  zv_frc(ji,jj) = zv_frc(ji,jj) + zv_spg 
     475               END DO 
     476            END DO 
     477         ELSE 
     478            DO jj = 2, jpjm1               
     479               DO ji = fs_2, fs_jpim1   ! vector opt. 
     480                  zu_spg =  grav * z1_2 * (  ssh_ib (ji+1,jj  ) - ssh_ib (ji,jj)    & 
     481                      &                    + ssh_ibb(ji+1,jj  ) - ssh_ibb(ji,jj)  ) /e1u(ji,jj) 
     482                  zv_spg =  grav * z1_2 * (  ssh_ib (ji  ,jj+1) - ssh_ib (ji,jj)    & 
     483                      &                    + ssh_ibb(ji  ,jj+1) - ssh_ibb(ji,jj)  ) /e2v(ji,jj) 
     484                  zu_frc(ji,jj) = zu_frc(ji,jj) + zu_spg 
     485                  zv_frc(ji,jj) = zv_frc(ji,jj) + zv_spg 
     486               END DO 
     487            END DO 
     488         ENDIF  
     489      ENDIF 
     490      !                                   !* Right-Hand-Side of the barotropic ssh equation 
     491      !                                   ! ----------------------------------------------- 
     492      !                                         ! Surface net water flux and rivers 
     493      IF (ln_bt_fw) THEN 
     494         zssh_frc(:,:) = zraur * ( emp(:,:) - rnf(:,:) ) 
     495      ELSE 
     496         zssh_frc(:,:) = zraur * z1_2 * (emp(:,:) + emp_b(:,:) - rnf(:,:) - rnf_b(:,:)) 
     497      ENDIF 
     498#if defined key_asminc 
     499      !                                         ! Include the IAU weighted SSH increment 
     500      IF( lk_asminc .AND. ln_sshinc .AND. ln_asmiau ) THEN 
     501         zssh_frc(:,:) = zssh_frc(:,:) + ssh_iau(:,:) 
     502      ENDIF 
     503#endif 
     504      ! 
    358505      ! ----------------------------------------------------------------------- 
    359       !  Phase 2 : Integration of the barotropic equations with time splitting 
     506      !  Phase 2 : Integration of the barotropic equations  
    360507      ! ----------------------------------------------------------------------- 
    361508      ! 
    362509      !                                             ! ==================== ! 
    363510      !                                             !    Initialisations   ! 
     511      !                                             ! ==================== !   
     512      ! Initialize barotropic variables:     
     513      IF (ln_bt_fw) THEN                  ! FORWARD integration:  start from NOW fields                              
     514         sshn_e (:,:) = sshn (:,:)             
     515         zun_e  (:,:) = un_b (:,:)             
     516         zvn_e  (:,:) = vn_b (:,:) 
     517      ELSE                                ! CENTERED integration: start from BEFORE fields 
     518         sshn_e (:,:) = sshb (:,:) 
     519         zun_e  (:,:) = ub_b (:,:)          
     520         zvn_e  (:,:) = vb_b (:,:) 
     521      ENDIF 
     522      ! 
     523      ! Initialize depths: 
     524      IF ( lk_vvl.AND.(.NOT.ln_bt_fw) ) THEN 
     525         hu_e  (:,:) = umask(:,:,1) / ( zhur_b(:,:) + 1._wp - umask(:,:,1) ) 
     526         hv_e  (:,:) = vmask(:,:,1) / ( zhvr_b(:,:) + 1._wp - vmask(:,:,1) ) 
     527         hur_e (:,:) = zhur_b(:,:) 
     528         hvr_e (:,:) = zhvr_b(:,:) 
     529      ELSE 
     530         hu_e  (:,:) = hu   (:,:)        
     531         hv_e  (:,:) = hv   (:,:)  
     532         hur_e (:,:) = hur  (:,:)     
     533         hvr_e (:,:) = hvr  (:,:) 
     534      ENDIF 
     535      ! 
     536      IF (.NOT.lk_vvl) THEN ! Depths at jn+0.5: 
     537         zhup2_e (:,:) = hu(:,:) 
     538         zhvp2_e (:,:) = hv(:,:) 
     539      ENDIF 
     540      ! 
     541      ! Initialize sums: 
     542      ua_b  (:,:) = 0._wp       ! After barotropic velocities (or transport if flux form)           
     543      va_b  (:,:) = 0._wp 
     544      ssha  (:,:) = 0._wp       ! Sum for after averaged sea level 
     545      zu_sum(:,:) = 0._wp       ! Sum for now transport issued from ts loop 
     546      zv_sum(:,:) = 0._wp 
    364547      !                                             ! ==================== ! 
    365       icycle = 2  * nn_baro            ! Number of barotropic sub time-step 
    366        
    367       !                                ! Start from NOW field 
    368       hu_e   (:,:) = hu   (:,:)            ! ocean depth at u- and v-points 
    369       hv_e   (:,:) = hv   (:,:)  
    370       hur_e  (:,:) = hur  (:,:)            ! ocean depth inverted at u- and v-points 
    371       hvr_e  (:,:) = hvr  (:,:) 
    372 !RBbug     zsshb_e(:,:) = sshn (:,:)   
    373       zsshb_e(:,:) = sshn_b(:,:)           ! sea surface height (before and now) 
    374       sshn_e (:,:) = sshn (:,:) 
    375        
    376       zun_e  (:,:) = un_b (:,:)            ! barotropic velocity (external) 
    377       zvn_e  (:,:) = vn_b (:,:) 
    378       zub_e  (:,:) = un_b (:,:) 
    379       zvb_e  (:,:) = vn_b (:,:) 
    380  
    381       zu_sum  (:,:) = un_b (:,:)           ! summation 
    382       zv_sum  (:,:) = vn_b (:,:) 
    383       zssh_sum(:,:) = sshn (:,:) 
    384  
    385 #if defined key_obc 
    386       ! set ssh corrections to 0 
    387       ! ssh corrections are applied to normal velocities (Flather's algorithm) and averaged over the barotropic loop 
    388       IF( lp_obc_east  )   sshfoe_b(:,:) = 0._wp 
    389       IF( lp_obc_west  )   sshfow_b(:,:) = 0._wp 
    390       IF( lp_obc_south )   sshfos_b(:,:) = 0._wp 
    391       IF( lp_obc_north )   sshfon_b(:,:) = 0._wp 
    392 #endif 
    393  
    394       !                                             ! ==================== ! 
    395       DO jn = 1, icycle                             !  sub-time-step loop  ! (from NOW to AFTER+1) 
     548      DO jn = 1, icycle                             !  sub-time-step loop  ! 
    396549         !                                          ! ==================== ! 
    397          z2dt_e = 2. * ( rdt / nn_baro ) 
    398          IF( jn == 1 )   z2dt_e = rdt / nn_baro 
    399  
    400550         !                                                !* Update the forcing (BDY and tides) 
    401551         !                                                !  ------------------ 
    402          IF( lk_obc )   CALL obc_dta_bt ( kt, jn   ) 
    403          IF( lk_bdy )   CALL bdy_dta ( kt, jit=jn, time_offset=+1 ) 
    404          IF ( ln_tide_pot .AND. lk_tide) CALL upd_tide( kt, jn ) 
    405  
    406          !                                                !* after ssh_e 
     552         ! Update only tidal forcing at open boundaries 
     553#if defined key_tide 
     554         IF ( lk_bdy .AND. lk_tide )      CALL bdy_dta_tides( kt, kit=jn, time_offset=(noffset+1) ) 
     555         IF ( ln_tide_pot .AND. lk_tide ) CALL upd_tide( kt, kit=jn, koffset=noffset ) 
     556#endif 
     557         ! 
     558         ! Set extrapolation coefficients for predictor step: 
     559         IF ((jn<3).AND.ll_init) THEN      ! Forward            
     560           za1 = 1._wp                                           
     561           za2 = 0._wp                         
     562           za3 = 0._wp                         
     563         ELSE                              ! AB3-AM4 Coefficients: bet=0.281105  
     564           za1 =  1.781105_wp              ! za1 =   3/2 +   bet 
     565           za2 = -1.06221_wp               ! za2 = -(1/2 + 2*bet) 
     566           za3 =  0.281105_wp              ! za3 = bet 
     567         ENDIF 
     568 
     569         ! Extrapolate barotropic velocities at step jit+0.5: 
     570         ua_e(:,:) = za1 * zun_e(:,:) + za2 * ub_e(:,:) + za3 * ubb_e(:,:) 
     571         va_e(:,:) = za1 * zvn_e(:,:) + za2 * vb_e(:,:) + za3 * vbb_e(:,:) 
     572 
     573         IF( lk_vvl ) THEN                                !* Update ocean depth (variable volume case only) 
     574            !                                             !  ------------------ 
     575            ! Extrapolate Sea Level at step jit+0.5: 
     576            zsshp2_e(:,:) = za1 * sshn_e(:,:)  + za2 * sshb_e(:,:) + za3 * sshbb_e(:,:) 
     577            ! 
     578            DO jj = 2, jpjm1                                    ! Sea Surface Height at u- & v-points 
     579               DO ji = 2, fs_jpim1   ! Vector opt. 
     580                  zwx(ji,jj) = z1_2 * umask(ji,jj,1) / ( e1u(ji,jj) * e2u(ji,jj) )       & 
     581                     &              * ( e1t(ji  ,jj) * e2t(ji  ,jj) * zsshp2_e(ji  ,jj)  & 
     582                     &              +   e1t(ji+1,jj) * e2t(ji+1,jj) * zsshp2_e(ji+1,jj) ) 
     583                  zwy(ji,jj) = z1_2 * vmask(ji,jj,1) / ( e1v(ji,jj) * e2v(ji,jj) )       & 
     584                     &              * ( e1t(ji,jj  ) * e2t(ji,jj  ) * zsshp2_e(ji,jj  )  & 
     585                     &              +   e1t(ji,jj+1) * e2t(ji,jj+1) * zsshp2_e(ji,jj+1) ) 
     586               END DO 
     587            END DO 
     588            CALL lbc_lnk( zwx, 'U', 1._wp )    ;   CALL lbc_lnk( zwy, 'V', 1._wp ) 
     589            ! 
     590            zhup2_e (:,:) = hu_0(:,:) + zwx(:,:)               ! Ocean depth at U- and V-points 
     591            zhvp2_e (:,:) = hv_0(:,:) + zwy(:,:) 
     592         ENDIF 
     593         !                                                !* after ssh 
    407594         !                                                !  ----------- 
    408          DO jj = 2, jpjm1                                 ! Horizontal divergence of barotropic transports 
     595         ! One should enforce volume conservation at open boundaries here 
     596         ! considering fluxes below: 
     597         ! 
     598         zwx(:,:) = e2u(:,:) * ua_e(:,:) * zhup2_e(:,:)         ! fluxes at jn+0.5 
     599         zwy(:,:) = e1v(:,:) * va_e(:,:) * zhvp2_e(:,:) 
     600         DO jj = 2, jpjm1                                  
    409601            DO ji = fs_2, fs_jpim1   ! vector opt. 
    410                zhdiv(ji,jj) = (   e2u(ji  ,jj) * zun_e(ji  ,jj) * hu_e(ji  ,jj)     & 
    411                   &             - e2u(ji-1,jj) * zun_e(ji-1,jj) * hu_e(ji-1,jj)     & 
    412                   &             + e1v(ji,jj  ) * zvn_e(ji,jj  ) * hv_e(ji,jj  )     & 
    413                   &             - e1v(ji,jj-1) * zvn_e(ji,jj-1) * hv_e(ji,jj-1)   ) / ( e1t(ji,jj) * e2t(ji,jj) ) 
    414             END DO 
    415          END DO 
    416          ! 
    417 #if defined key_obc 
    418          !                                                     ! OBC : zhdiv must be zero behind the open boundary 
    419 !!  mpp remark: The zeroing of hdiv can probably be extended to 1->jpi/jpj for the correct row/column 
    420          IF( lp_obc_east  )   zhdiv(nie0p1:nie1p1,nje0  :nje1  ) = 0._wp      ! east 
    421          IF( lp_obc_west  )   zhdiv(niw0  :niw1  ,njw0  :njw1  ) = 0._wp      ! west 
    422          IF( lp_obc_north )   zhdiv(nin0  :nin1  ,njn0p1:njn1p1) = 0._wp      ! north 
    423          IF( lp_obc_south )   zhdiv(nis0  :nis1  ,njs0  :njs1  ) = 0._wp      ! south 
     602               zhdiv(ji,jj) = (   zwx(ji,jj) - zwx(ji-1,jj)   & 
     603                  &             + zwy(ji,jj) - zwy(ji,jj-1)   & 
     604                  &           ) / ( e1t(ji,jj) * e2t(ji,jj) ) 
     605            END DO 
     606         END DO 
     607         ! 
     608         ! Sum over sub-time-steps to compute advective velocities 
     609         za2 = wgtbtp2(jn) 
     610         zu_sum  (:,:) = zu_sum  (:,:) + za2 * ua_e  (:,:) * zhup2_e  (:,:) 
     611         zv_sum  (:,:) = zv_sum  (:,:) + za2 * va_e  (:,:) * zhvp2_e  (:,:) 
     612         ! 
     613         ! Set next sea level: 
     614         ssha_e(:,:) = (  sshn_e(:,:) - rdtbt * ( zssh_frc(:,:) + zhdiv(:,:) )  ) * tmask(:,:,1) 
     615         CALL lbc_lnk( ssha_e, 'T',  1._wp ) 
     616 
     617#if defined key_bdy 
     618         ! Duplicate sea level across open boundaries (this is only cosmetic if lk_vvl=.false.) 
     619         IF (lk_bdy) CALL bdy_ssh( ssha_e ) 
    424620#endif 
    425 #if defined key_bdy 
    426          zhdiv(:,:) = zhdiv(:,:) * bdytmask(:,:)               ! BDY mask 
     621#if defined key_agrif 
     622         IF( .NOT.Agrif_Root() ) CALL agrif_ssh_ts( jn ) 
    427623#endif 
    428          ! 
    429          DO jj = 2, jpjm1                                      ! leap-frog on ssh_e 
    430             DO ji = fs_2, fs_jpim1   ! vector opt. 
    431                ssha_e(ji,jj) = ( zsshb_e(ji,jj) - z2dt_e * ( zraur * ( emp(ji,jj)-rnf(ji,jj) ) + zhdiv(ji,jj) ) ) * tmask(ji,jj,1)  
    432             END DO 
    433          END DO 
    434  
    435          !                                                !* after barotropic velocities (vorticity scheme dependent) 
    436          !                                                !  ---------------------------   
    437          zwx(:,:) = e2u(:,:) * zun_e(:,:) * hu_e(:,:)     ! now_e transport 
    438          zwy(:,:) = e1v(:,:) * zvn_e(:,:) * hv_e(:,:) 
     624         !   
     625         ! Sea Surface Height at u-,v-points (vvl case only) 
     626         IF ( lk_vvl ) THEN                                 
     627            DO jj = 2, jpjm1 
     628               DO ji = 2, jpim1      ! NO Vector Opt. 
     629                  zsshu_a(ji,jj) = z1_2  * umask(ji,jj,1) / ( e1u(ji  ,jj) * e2u(ji  ,jj) )                 & 
     630                     &                                   * ( e1t(ji  ,jj) * e2t(ji  ,jj) * ssha_e(ji  ,jj) & 
     631                     &                                     + e1t(ji+1,jj) * e2t(ji+1,jj) * ssha_e(ji+1,jj) ) 
     632                  zsshv_a(ji,jj) = z1_2  * vmask(ji,jj,1) / ( e1v(ji,jj  ) * e2v(ji,jj  ) )                 & 
     633                     &                                   * ( e1t(ji,jj  ) * e2t(ji,jj  ) * ssha_e(ji,jj  ) & 
     634                     &                                     + e1t(ji,jj+1) * e2t(ji,jj+1) * ssha_e(ji,jj+1) ) 
     635               END DO 
     636            END DO 
     637            CALL lbc_lnk( zsshu_a, 'U', 1._wp )   ;   CALL lbc_lnk( zsshv_a, 'V', 1._wp ) 
     638         ENDIF    
     639         !                                  
     640         ! Half-step back interpolation of SSH for surface pressure computation: 
     641         !---------------------------------------------------------------------- 
     642         IF ((jn==1).AND.ll_init) THEN 
     643           za0=1._wp                        ! Forward-backward 
     644           za1=0._wp                            
     645           za2=0._wp 
     646           za3=0._wp 
     647         ELSEIF ((jn==2).AND.ll_init) THEN  ! AB2-AM3 Coefficients; bet=0 ; gam=-1/6 ; eps=1/12 
     648           za0= 1.0833333333333_wp          ! za0 = 1-gam-eps 
     649           za1=-0.1666666666666_wp          ! za1 = gam 
     650           za2= 0.0833333333333_wp          ! za2 = eps 
     651           za3= 0._wp               
     652         ELSE                               ! AB3-AM4 Coefficients; bet=0.281105 ; eps=0.013 ; gam=0.0880  
     653           za0=0.614_wp                     ! za0 = 1/2 +   gam + 2*eps     
     654           za1=0.285_wp                     ! za1 = 1/2 - 2*gam - 3*eps  
     655           za2=0.088_wp                     ! za2 = gam 
     656           za3=0.013_wp                     ! za3 = eps 
     657         ENDIF 
     658 
     659         zsshp2_e(:,:) = za0 *  ssha_e(:,:) + za1 *  sshn_e (:,:) & 
     660          &            + za2 *  sshb_e(:,:) + za3 *  sshbb_e(:,:) 
     661 
     662         ! 
     663         ! Compute associated depths at U and V points: 
     664         IF ( lk_vvl.AND.(.NOT.ln_dynadv_vec) ) THEN       
     665            !                                         
     666            DO jj = 2, jpjm1                             
     667               DO ji = 2, jpim1 
     668                  zx1 = z1_2 * umask(ji,jj,1) / ( e1u(ji,jj) * e2u(ji,jj) )       & 
     669                    &        * ( e1t(ji  ,jj) * e2t(ji  ,jj) * zsshp2_e(ji  ,jj)  & 
     670                    &        +   e1t(ji+1,jj) * e2t(ji+1,jj) * zsshp2_e(ji+1,jj) )                  
     671                  zy1 = z1_2 * vmask(ji,jj,1) / ( e1v(ji,jj) * e2v(ji,jj) )       & 
     672                     &       * ( e1t(ji,jj  ) * e2t(ji,jj  ) * zsshp2_e(ji,jj  )  & 
     673                     &       +   e1t(ji,jj+1) * e2t(ji,jj+1) * zsshp2_e(ji,jj+1) ) 
     674                  zhust_e(ji,jj) = hu_0(ji,jj) + zx1  
     675                  zhvst_e(ji,jj) = hv_0(ji,jj) + zy1 
     676               END DO 
     677            END DO 
     678         ENDIF 
     679         ! 
     680         ! Add Coriolis trend: 
     681         ! zwz array below or triads normally depend on sea level with key_vvl and should be updated 
     682         ! at each time step. We however keep them constant here for optimization. 
     683         ! Recall that zwx and zwy arrays hold fluxes at this stage: 
     684         ! zwx(:,:) = e2u(:,:) * ua_e(:,:) * zhup2_e(:,:)   ! fluxes at jn+0.5 
     685         ! zwy(:,:) = e1v(:,:) * va_e(:,:) * zhvp2_e(:,:) 
    439686         ! 
    440687         IF( ln_dynvor_ene .OR. ln_dynvor_mix ) THEN      !==  energy conserving or mixed scheme  ==! 
    441688            DO jj = 2, jpjm1 
    442689               DO ji = fs_2, fs_jpim1   ! vector opt. 
    443                   ! surface pressure gradient 
    444                   IF( lk_vvl) THEN 
    445                      zu_spg = -grav * (  ( rhd(ji+1,jj ,1) + 1 ) * sshn_e(ji+1,jj  )    & 
    446                         &              - ( rhd(ji  ,jj ,1) + 1 ) * sshn_e(ji  ,jj  )  ) / e1u(ji,jj) 
    447                      zv_spg = -grav * (  ( rhd(ji ,jj+1,1) + 1 ) * sshn_e(ji  ,jj+1)    & 
    448                         &              - ( rhd(ji ,jj  ,1) + 1 ) * sshn_e(ji  ,jj  )  ) / e2v(ji,jj) 
    449                   ELSE 
    450                      zu_spg = -grav * ( sshn_e(ji+1,jj) - sshn_e(ji,jj) ) / e1u(ji,jj) 
    451                      zv_spg = -grav * ( sshn_e(ji,jj+1) - sshn_e(ji,jj) ) / e2v(ji,jj) 
    452                   ENDIF 
    453                   ! add tidal astronomical forcing 
    454                   IF ( ln_tide_pot .AND. lk_tide ) THEN  
    455                   zu_spg = zu_spg + grav * ( pot_astro(ji+1,jj) - pot_astro(ji,jj) ) / e1u(ji,jj) 
    456                   zv_spg = zv_spg + grav * ( pot_astro(ji,jj+1) - pot_astro(ji,jj) ) / e2v(ji,jj) 
    457                   ENDIF 
    458                   ! energy conserving formulation for planetary vorticity term 
    459690                  zy1 = ( zwy(ji  ,jj-1) + zwy(ji+1,jj-1) ) / e1u(ji,jj) 
    460691                  zy2 = ( zwy(ji  ,jj  ) + zwy(ji+1,jj  ) ) / e1u(ji,jj) 
    461692                  zx1 = ( zwx(ji-1,jj  ) + zwx(ji-1,jj+1) ) / e2v(ji,jj) 
    462693                  zx2 = ( zwx(ji  ,jj  ) + zwx(ji  ,jj+1) ) / e2v(ji,jj) 
    463                   zu_cor = z1_4 * ( ff(ji  ,jj-1) * zy1 + ff(ji,jj) * zy2 ) * hur_e(ji,jj) 
    464                   zv_cor =-z1_4 * ( ff(ji-1,jj  ) * zx1 + ff(ji,jj) * zx2 ) * hvr_e(ji,jj) 
    465                   ! after velocities with implicit bottom friction 
    466  
    467                   IF( ln_bfrimp ) THEN      ! implicit bottom friction 
    468                      !   A new method to implement the implicit bottom friction.  
    469                      !   H. Liu 
    470                      !   Sept 2011 
    471                      ua_e(ji,jj) = umask(ji,jj,1) * ( zub_e(ji,jj) +                                            & 
    472                       &                               z2dt_e * ( zu_cor + zu_spg + zu_sld + zu_asp )            & 
    473                       &                               / ( 1._wp      - z2dt_e * bfrua(ji,jj) * hur_e(ji,jj) ) ) 
    474                      ua_e(ji,jj) = ( ua_e(ji,jj) + z2dt_e *   zua(ji,jj)  ) * umask(ji,jj,1)    
    475                      ! 
    476                      va_e(ji,jj) = vmask(ji,jj,1) * ( zvb_e(ji,jj) +                                            & 
    477                       &                               z2dt_e * ( zv_cor + zv_spg + zv_sld + zv_asp )            & 
    478                       &                               / ( 1._wp      - z2dt_e * bfrva(ji,jj) * hvr_e(ji,jj) ) ) 
    479                      va_e(ji,jj) = ( va_e(ji,jj) + z2dt_e *   zva(ji,jj)  ) * vmask(ji,jj,1)    
    480                      ! 
    481                   ELSE 
    482                      ua_e(ji,jj) = ( zub_e(ji,jj) + z2dt_e * ( zu_cor + zu_spg + zu_sld + zu_asp + zua(ji,jj))) * umask(ji,jj,1)   & 
    483                       &           / ( 1._wp         - z2dt_e * bfrua(ji,jj) * hur_e(ji,jj) ) 
    484                      va_e(ji,jj) = ( zvb_e(ji,jj) + z2dt_e * ( zv_cor + zv_spg + zv_sld + zv_asp + zva(ji,jj))) * vmask(ji,jj,1)   & 
    485                       &           / ( 1._wp         - z2dt_e * bfrva(ji,jj) * hvr_e(ji,jj) ) 
    486                   ENDIF 
     694                  zu_trd(ji,jj) = z1_4 * ( zwz(ji  ,jj-1) * zy1 + zwz(ji,jj) * zy2 ) 
     695                  zv_trd(ji,jj) =-z1_4 * ( zwz(ji-1,jj  ) * zx1 + zwz(ji,jj) * zx2 ) 
    487696               END DO 
    488697            END DO 
    … …  
    491700            DO jj = 2, jpjm1 
    492701               DO ji = fs_2, fs_jpim1   ! vector opt. 
    493                    ! surface pressure gradient 
    494                   IF( lk_vvl) THEN 
    495                      zu_spg = -grav * (  ( rhd(ji+1,jj ,1) + 1 ) * sshn_e(ji+1,jj  )    & 
    496                         &              - ( rhd(ji  ,jj ,1) + 1 ) * sshn_e(ji  ,jj  )  ) / e1u(ji,jj) 
    497                      zv_spg = -grav * (  ( rhd(ji ,jj+1,1) + 1 ) * sshn_e(ji  ,jj+1)    & 
    498                         &              - ( rhd(ji ,jj  ,1) + 1 ) * sshn_e(ji  ,jj  )  ) / e2v(ji,jj) 
    499                   ELSE 
    500                      zu_spg = -grav * ( sshn_e(ji+1,jj) - sshn_e(ji,jj) ) / e1u(ji,jj) 
    501                      zv_spg = -grav * ( sshn_e(ji,jj+1) - sshn_e(ji,jj) ) / e2v(ji,jj) 
    502                   ENDIF 
    503                   ! add tidal astronomical forcing 
    504                   IF ( ln_tide_pot .AND. lk_tide ) THEN 
    505                   zu_spg = zu_spg + grav * ( pot_astro(ji+1,jj) - pot_astro(ji,jj) ) / e1u(ji,jj) 
    506                   zv_spg = zv_spg + grav * ( pot_astro(ji,jj+1) - pot_astro(ji,jj) ) / e2v(ji,jj) 
    507                   ENDIF 
    508                   ! enstrophy conserving formulation for planetary vorticity term 
    509                   zy1 =   z1_8 * ( zwy(ji  ,jj-1) + zwy(ji+1,jj-1) + zwy(ji,jj) + zwy(ji+1,jj  ) ) / e1u(ji,jj) 
    510                   zx1 = - z1_8 * ( zwx(ji-1,jj  ) + zwx(ji-1,jj+1) + zwx(ji,jj) + zwx(ji  ,jj+1) ) / e2v(ji,jj) 
    511                   zu_cor  = zy1 * ( ff(ji  ,jj-1) + ff(ji,jj) ) * hur_e(ji,jj) 
    512                   zv_cor  = zx1 * ( ff(ji-1,jj  ) + ff(ji,jj) ) * hvr_e(ji,jj) 
    513                   ! after velocities with implicit bottom friction 
    514                   IF( ln_bfrimp ) THEN 
    515                      !   A new method to implement the implicit bottom friction.  
    516                      !   H. Liu 
    517                      !   Sept 2011 
    518                      ua_e(ji,jj) = umask(ji,jj,1) * ( zub_e(ji,jj) +                                            & 
    519                       &                               z2dt_e * ( zu_cor + zu_spg + zu_sld + zu_asp )            & 
    520                       &                               / ( 1._wp      - z2dt_e * bfrua(ji,jj) * hur_e(ji,jj) ) ) 
    521                      ua_e(ji,jj) = ( ua_e(ji,jj) + z2dt_e *   zua(ji,jj)  ) * umask(ji,jj,1)    
    522                      ! 
    523                      va_e(ji,jj) = vmask(ji,jj,1) * ( zvb_e(ji,jj) +                                            & 
    524                       &                               z2dt_e * ( zv_cor + zv_spg + zv_sld + zv_asp )            & 
    525                       &                               / ( 1._wp      - z2dt_e * bfrva(ji,jj) * hvr_e(ji,jj) ) ) 
    526                      va_e(ji,jj) = ( va_e(ji,jj) + z2dt_e *   zva(ji,jj)  ) * vmask(ji,jj,1)    
    527                      ! 
    528                   ELSE 
    529                      ua_e(ji,jj) = ( zub_e(ji,jj) + z2dt_e * ( zu_cor + zu_spg + zu_sld + zu_asp + zua(ji,jj))) * umask(ji,jj,1)   & 
    530                      &            / ( 1._wp        - z2dt_e * bfrua(ji,jj) * hur_e(ji,jj) ) 
    531                      va_e(ji,jj) = ( zvb_e(ji,jj) + z2dt_e * ( zv_cor + zv_spg + zv_sld + zv_asp + zva(ji,jj))) * vmask(ji,jj,1)   & 
    532                      &            / ( 1._wp        - z2dt_e * bfrva(ji,jj) * hvr_e(ji,jj) ) 
    533                   ENDIF 
     702                  zy1 =   z1_8 * ( zwy(ji  ,jj-1) + zwy(ji+1,jj-1) & 
     703                   &             + zwy(ji  ,jj  ) + zwy(ji+1,jj  ) ) / e1u(ji,jj) 
     704                  zx1 = - z1_8 * ( zwx(ji-1,jj  ) + zwx(ji-1,jj+1) & 
     705                   &             + zwx(ji  ,jj  ) + zwx(ji  ,jj+1) ) / e2v(ji,jj) 
     706                  zu_trd(ji,jj)  = zy1 * ( zwz(ji  ,jj-1) + zwz(ji,jj) ) 
     707                  zv_trd(ji,jj)  = zx1 * ( zwz(ji-1,jj  ) + zwz(ji,jj) ) 
    534708               END DO 
    535709            END DO 
    … …  
    538712            DO jj = 2, jpjm1 
    539713               DO ji = fs_2, fs_jpim1   ! vector opt. 
    540                   ! surface pressure gradient 
    541                   IF( lk_vvl) THEN 
    542                      zu_spg = -grav * (  ( rhd(ji+1,jj  ,1) + 1 ) * sshn_e(ji+1,jj  )    & 
    543                         &              - ( rhd(ji  ,jj  ,1) + 1 ) * sshn_e(ji  ,jj  )  ) / e1u(ji,jj) 
    544                      zv_spg = -grav * (  ( rhd(ji  ,jj+1,1) + 1 ) * sshn_e(ji  ,jj+1)    & 
    545                         &              - ( rhd(ji  ,jj  ,1) + 1 ) * sshn_e(ji  ,jj  )  ) / e2v(ji,jj) 
    546                   ELSE 
    547                      zu_spg = -grav * ( sshn_e(ji+1,jj) - sshn_e(ji,jj) ) / e1u(ji,jj) 
    548                      zv_spg = -grav * ( sshn_e(ji,jj+1) - sshn_e(ji,jj) ) / e2v(ji,jj) 
    549                   ENDIF 
    550                   ! add tidal astronomical forcing 
    551                   IF ( ln_tide_pot .AND. lk_tide ) THEN 
    552                   zu_spg = zu_spg + grav * ( pot_astro(ji+1,jj) - pot_astro(ji,jj) ) / e1u(ji,jj) 
    553                   zv_spg = zv_spg + grav * ( pot_astro(ji,jj+1) - pot_astro(ji,jj) ) / e2v(ji,jj) 
    554                   ENDIF 
    555                   ! energy/enstrophy conserving formulation for planetary vorticity term 
    556                   zu_cor = + z1_4 / e1u(ji,jj) * (  ftne(ji,jj  ) * zwy(ji  ,jj  ) + ftnw(ji+1,jj) * zwy(ji+1,jj  )   & 
    557                      &                           + ftse(ji,jj  ) * zwy(ji  ,jj-1) + ftsw(ji+1,jj) * zwy(ji+1,jj-1) ) * hur_e(ji,jj) 
    558                   zv_cor = - z1_4 / e2v(ji,jj) * (  ftsw(ji,jj+1) * zwx(ji-1,jj+1) + ftse(ji,jj+1) * zwx(ji  ,jj+1)   & 
    559                      &                           + ftnw(ji,jj  ) * zwx(ji-1,jj  ) + ftne(ji,jj  ) * zwx(ji  ,jj  ) ) * hvr_e(ji,jj) 
    560                   ! after velocities with implicit bottom friction 
    561                   IF( ln_bfrimp ) THEN 
    562                      !   A new method to implement the implicit bottom friction.  
    563                      !   H. Liu 
    564                      !   Sept 2011 
    565                      ua_e(ji,jj) = umask(ji,jj,1) * ( zub_e(ji,jj) +                                            & 
    566                       &                               z2dt_e * ( zu_cor + zu_spg + zu_sld + zu_asp )            & 
    567                       &                               / ( 1._wp      - z2dt_e * bfrua(ji,jj) * hur_e(ji,jj) ) ) 
    568                      ua_e(ji,jj) = ( ua_e(ji,jj) + z2dt_e *   zua(ji,jj)  ) * umask(ji,jj,1)    
    569                      ! 
    570                      va_e(ji,jj) = vmask(ji,jj,1) * ( zvb_e(ji,jj) +                                            & 
    571                       &                               z2dt_e * ( zv_cor + zv_spg + zv_sld + zv_asp )            & 
    572                       &                               / ( 1._wp      - z2dt_e * bfrva(ji,jj) * hvr_e(ji,jj) ) ) 
    573                      va_e(ji,jj) = ( va_e(ji,jj) + z2dt_e *   zva(ji,jj)  ) * vmask(ji,jj,1)    
    574                      ! 
    575                   ELSE 
    576                      ua_e(ji,jj) = ( zub_e(ji,jj) + z2dt_e * ( zu_cor + zu_spg + zu_sld + zu_asp + zua(ji,jj))) * umask(ji,jj,1)   & 
    577                      &            / ( 1._wp        - z2dt_e * bfrua(ji,jj) * hur_e(ji,jj) ) 
    578                      va_e(ji,jj) = ( zvb_e(ji,jj) + z2dt_e * ( zv_cor + zv_spg + zv_sld + zv_asp + zva(ji,jj))) * vmask(ji,jj,1)   & 
    579                      &            / ( 1._wp        - z2dt_e * bfrva(ji,jj) * hvr_e(ji,jj) ) 
    580                   ENDIF 
     714                  zu_trd(ji,jj) = + z1_12 / e1u(ji,jj) * (  ftne(ji,jj  ) * zwy(ji  ,jj  ) & 
     715                     &                                    + ftnw(ji+1,jj) * zwy(ji+1,jj  ) & 
     716                     &                                    + ftse(ji,jj  ) * zwy(ji  ,jj-1) &  
     717                     &                                    + ftsw(ji+1,jj) * zwy(ji+1,jj-1) ) 
     718                  zv_trd(ji,jj) = - z1_12 / e2v(ji,jj) * (  ftsw(ji,jj+1) * zwx(ji-1,jj+1) &  
     719                     &                                    + ftse(ji,jj+1) * zwx(ji  ,jj+1) & 
     720                     &                                    + ftnw(ji,jj  ) * zwx(ji-1,jj  ) &  
     721                     &                                    + ftne(ji,jj  ) * zwx(ji  ,jj  ) ) 
    581722               END DO 
    582723            END DO 
    583724            !  
    584725         ENDIF 
    585          !                                                     !* domain lateral boundary 
    586          !                                                     !  ----------------------- 
    587  
    588                                                                ! OBC open boundaries 
    589          IF( lk_obc               )   CALL obc_fla_ts ( ua_e, va_e, sshn_e, ssha_e ) 
    590  
    591                                                                ! BDY open boundaries 
    592 #if defined key_bdy 
    593          pssh => sshn_e 
    594          phur => hur_e 
    595          phvr => hvr_e 
    596          pu2d => ua_e 
    597          pv2d => va_e 
    598  
    599          IF( lk_bdy )   CALL bdy_dyn2d( kt )  
    600 #endif 
    601  
    602          ! 
    603          CALL lbc_lnk( ua_e  , 'U', -1. )                      ! local domain boundaries  
    604          CALL lbc_lnk( va_e  , 'V', -1. ) 
    605          CALL lbc_lnk( ssha_e, 'T',  1. ) 
    606  
    607          zu_sum  (:,:) = zu_sum  (:,:) + ua_e  (:,:)           ! Sum over sub-time-steps 
    608          zv_sum  (:,:) = zv_sum  (:,:) + va_e  (:,:)  
    609          zssh_sum(:,:) = zssh_sum(:,:) + ssha_e(:,:)  
    610  
    611          !                                                !* Time filter and swap 
    612          !                                                !  -------------------- 
    613          IF( jn == 1 ) THEN                                     ! Swap only (1st Euler time step) 
    614             zsshb_e(:,:) = sshn_e(:,:) 
    615             zub_e  (:,:) = zun_e (:,:) 
    616             zvb_e  (:,:) = zvn_e (:,:) 
    617             sshn_e (:,:) = ssha_e(:,:) 
    618             zun_e  (:,:) = ua_e  (:,:) 
    619             zvn_e  (:,:) = va_e  (:,:) 
    620          ELSE                                                   ! Swap + Filter 
    621             zsshb_e(:,:) = atfp * ( zsshb_e(:,:) + ssha_e(:,:) ) + atfp1 * sshn_e(:,:) 
    622             zub_e  (:,:) = atfp * ( zub_e  (:,:) + ua_e  (:,:) ) + atfp1 * zun_e (:,:) 
    623             zvb_e  (:,:) = atfp * ( zvb_e  (:,:) + va_e  (:,:) ) + atfp1 * zvn_e (:,:) 
    624             sshn_e (:,:) = ssha_e(:,:) 
    625             zun_e  (:,:) = ua_e  (:,:) 
    626             zvn_e  (:,:) = va_e  (:,:) 
    627          ENDIF 
    628  
    629          IF( lk_vvl ) THEN                                !* Update ocean depth (variable volume case only) 
    630             !                                             !  ------------------ 
    631             DO jj = 1, jpjm1                                    ! Sea Surface Height at u- & v-points 
    632                DO ji = 1, fs_jpim1   ! Vector opt. 
    633                   zsshun_e(ji,jj) = 0.5_wp * umask(ji,jj,1) / ( e1u(ji,jj) * e2u(ji,jj) )       & 
    634                      &                     * ( e1t(ji  ,jj) * e2t(ji  ,jj) * sshn_e(ji  ,jj)    & 
    635                      &                     +   e1t(ji+1,jj) * e2t(ji+1,jj) * sshn_e(ji+1,jj) ) 
    636                   zsshvn_e(ji,jj) = 0.5_wp * vmask(ji,jj,1) / ( e1v(ji,jj) * e2v(ji,jj) )       & 
    637                      &                     * ( e1t(ji,jj  ) * e2t(ji,jj  ) * sshn_e(ji,jj  )    & 
    638                      &                     +   e1t(ji,jj+1) * e2t(ji,jj+1) * sshn_e(ji,jj+1) ) 
    639                END DO 
    640             END DO 
    641             CALL lbc_lnk( zsshun_e, 'U', 1. )                   ! lateral boundaries conditions 
    642             CALL lbc_lnk( zsshvn_e, 'V', 1. )  
    643             ! 
    644             hu_e (:,:) = hu_0(:,:) + zsshun_e(:,:)              ! Ocean depth at U- and V-points 
    645             hv_e (:,:) = hv_0(:,:) + zsshvn_e(:,:) 
     726         ! 
     727         ! Add tidal astronomical forcing if defined 
     728         IF ( lk_tide.AND.ln_tide_pot ) THEN 
     729            DO jj = 2, jpjm1 
     730               DO ji = fs_2, fs_jpim1   ! vector opt. 
     731                  zu_spg = grav * ( pot_astro(ji+1,jj) - pot_astro(ji,jj) ) / e1u(ji,jj) 
     732                  zv_spg = grav * ( pot_astro(ji,jj+1) - pot_astro(ji,jj) ) / e2v(ji,jj) 
     733                  zu_trd(ji,jj) = zu_trd(ji,jj) + zu_spg 
     734                  zv_trd(ji,jj) = zv_trd(ji,jj) + zv_spg 
     735               END DO 
     736            END DO 
     737         ENDIF 
     738         ! 
     739         ! Add bottom stresses: 
     740         zu_trd(:,:) = zu_trd(:,:) + bfrua(:,:) * zun_e(:,:) * hur_e(:,:) 
     741         zv_trd(:,:) = zv_trd(:,:) + bfrva(:,:) * zvn_e(:,:) * hvr_e(:,:) 
     742         ! 
     743         ! Surface pressure trend: 
     744         DO jj = 2, jpjm1 
     745            DO ji = fs_2, fs_jpim1   ! vector opt. 
     746               ! Add surface pressure gradient 
     747               zu_spg = - grav * ( zsshp2_e(ji+1,jj) - zsshp2_e(ji,jj) ) / e1u(ji,jj) 
     748               zv_spg = - grav * ( zsshp2_e(ji,jj+1) - zsshp2_e(ji,jj) ) / e2v(ji,jj) 
     749               zwx(ji,jj) = zu_spg 
     750               zwy(ji,jj) = zv_spg 
     751            END DO 
     752         END DO 
     753         ! 
     754         ! Set next velocities: 
     755         IF( ln_dynadv_vec .OR. (.NOT. lk_vvl) ) THEN    ! Vector form 
     756            DO jj = 2, jpjm1 
     757               DO ji = fs_2, fs_jpim1   ! vector opt. 
     758                  ua_e(ji,jj) = (                                zun_e(ji,jj)   &  
     759                            &     + rdtbt * (                      zwx(ji,jj)   & 
     760                            &                                 + zu_trd(ji,jj)   & 
     761                            &                                 + zu_frc(ji,jj) ) &  
     762                            &   ) * umask(ji,jj,1) 
     763 
     764                  va_e(ji,jj) = (                                zvn_e(ji,jj)   & 
     765                            &     + rdtbt * (                      zwy(ji,jj)   & 
     766                            &                                 + zv_trd(ji,jj)   & 
     767                            &                                 + zv_frc(ji,jj) ) & 
     768                            &   ) * vmask(ji,jj,1) 
     769               END DO 
     770            END DO 
     771 
     772         ELSE                 ! Flux form 
     773            DO jj = 2, jpjm1 
     774               DO ji = fs_2, fs_jpim1   ! vector opt. 
     775 
     776                  zhura = umask(ji,jj,1)/(hu_0(ji,jj) + zsshu_a(ji,jj) + 1._wp - umask(ji,jj,1)) 
     777                  zhvra = vmask(ji,jj,1)/(hv_0(ji,jj) + zsshv_a(ji,jj) + 1._wp - vmask(ji,jj,1)) 
     778 
     779                  ua_e(ji,jj) = (                hu_e(ji,jj)  *  zun_e(ji,jj)   &  
     780                            &     + rdtbt * ( zhust_e(ji,jj)  *    zwx(ji,jj)   &  
     781                            &               + zhup2_e(ji,jj)  * zu_trd(ji,jj)   & 
     782                            &               +      hu(ji,jj)  * zu_frc(ji,jj) ) & 
     783                            &   ) * zhura 
     784 
     785                  va_e(ji,jj) = (                hv_e(ji,jj)  *  zvn_e(ji,jj)   & 
     786                            &     + rdtbt * ( zhvst_e(ji,jj)  *    zwy(ji,jj)   & 
     787                            &               + zhvp2_e(ji,jj)  * zv_trd(ji,jj)   & 
     788                            &               +      hv(ji,jj)  * zv_frc(ji,jj) ) & 
     789                            &   ) * zhvra 
     790               END DO 
     791            END DO 
     792         ENDIF 
     793         ! 
     794         IF( lk_vvl ) THEN                             !* Update ocean depth (variable volume case only) 
     795            !                                          !  ----------------------------------------------         
     796            hu_e (:,:) = hu_0(:,:) + zsshu_a(:,:) 
     797            hv_e (:,:) = hv_0(:,:) + zsshv_a(:,:) 
    646798            hur_e(:,:) = umask(:,:,1) / ( hu_e(:,:) + 1._wp - umask(:,:,1) ) 
    647799            hvr_e(:,:) = vmask(:,:,1) / ( hv_e(:,:) + 1._wp - vmask(:,:,1) ) 
    648800            ! 
    649801         ENDIF 
     802         !                                                 !* domain lateral boundary 
     803         !                                                 !  ----------------------- 
     804         ! 
     805         CALL lbc_lnk( ua_e  , 'U', -1._wp )               ! local domain boundaries  
     806         CALL lbc_lnk( va_e  , 'V', -1._wp ) 
     807 
     808#if defined key_bdy   
     809 
     810         pssh => ssha_e 
     811         phur => hur_e 
     812         phvr => hvr_e 
     813         pua2d => ua_e 
     814         pva2d => va_e 
     815         pub2d => zun_e 
     816         pvb2d => zvn_e 
     817                                       
     818         IF( lk_bdy )   CALL bdy_dyn2d( kt )               ! open boundaries 
     819#endif 
     820#if defined key_agrif 
     821         IF( .NOT.Agrif_Root() ) CALL agrif_dyn_ts( kt, jn ) ! Agrif 
     822#endif 
     823         !                                             !* Swap 
     824         !                                             !  ---- 
     825         ubb_e  (:,:) = ub_e  (:,:) 
     826         ub_e   (:,:) = zun_e (:,:) 
     827         zun_e  (:,:) = ua_e  (:,:) 
     828         ! 
     829         vbb_e  (:,:) = vb_e  (:,:) 
     830         vb_e   (:,:) = zvn_e (:,:) 
     831         zvn_e  (:,:) = va_e  (:,:) 
     832         ! 
     833         sshbb_e(:,:) = sshb_e(:,:) 
     834         sshb_e (:,:) = sshn_e(:,:) 
     835         sshn_e (:,:) = ssha_e(:,:) 
     836 
     837         !                                             !* Sum over whole bt loop 
     838         !                                             !  ---------------------- 
     839         za1 = wgtbtp1(jn)                                     
     840         IF (( ln_dynadv_vec ).OR. (.NOT. lk_vvl)) THEN    ! Sum velocities 
     841            ua_b  (:,:) = ua_b  (:,:) + za1 * ua_e  (:,:)  
     842            va_b  (:,:) = va_b  (:,:) + za1 * va_e  (:,:)  
     843         ELSE                                ! Sum transports 
     844            ua_b  (:,:) = ua_b  (:,:) + za1 * ua_e  (:,:) * hu_e (:,:) 
     845            va_b  (:,:) = va_b  (:,:) + za1 * va_e  (:,:) * hv_e (:,:) 
     846         ENDIF 
     847         !                                   ! Sum sea level 
     848         ssha(:,:) = ssha(:,:) + za1 * ssha_e(:,:) 
    650849         !                                                 ! ==================== ! 
    651850      END DO                                               !        end loop      ! 
    652851      !                                                    ! ==================== ! 
    653  
    654 #if defined key_obc 
    655       IF( lp_obc_east  )   sshfoe_b(:,:) = zcoef * sshfoe_b(:,:)     !!gm totally useless ????? 
    656       IF( lp_obc_west  )   sshfow_b(:,:) = zcoef * sshfow_b(:,:) 
    657       IF( lp_obc_north )   sshfon_b(:,:) = zcoef * sshfon_b(:,:) 
    658       IF( lp_obc_south )   sshfos_b(:,:) = zcoef * sshfos_b(:,:) 
    659 #endif 
    660  
    661852      ! ----------------------------------------------------------------------------- 
    662853      ! Phase 3. update the general trend with the barotropic trend 
    663854      ! ----------------------------------------------------------------------------- 
    664855      ! 
    665       !                                   !* Time average ==> after barotropic u, v, ssh 
    666       zcoef =  1._wp / ( 2 * nn_baro  + 1 )  
    667       zu_sum(:,:) = zcoef * zu_sum  (:,:)  
    668       zv_sum(:,:) = zcoef * zv_sum  (:,:)  
    669       !  
    670       !                                   !* update the general momentum trend 
    671       DO jk=1,jpkm1 
    672          ua(:,:,jk) = ua(:,:,jk) + ( zu_sum(:,:) - ub_b(:,:) ) * z1_2dt_b 
    673          va(:,:,jk) = va(:,:,jk) + ( zv_sum(:,:) - vb_b(:,:) ) * z1_2dt_b 
     856      ! At this stage ssha holds a time averaged value 
     857      !                                                ! Sea Surface Height at u-,v- and f-points 
     858      IF( lk_vvl ) THEN                                ! (required only in key_vvl case) 
     859         DO jj = 1, jpjm1 
     860            DO ji = 1, jpim1      ! NO Vector Opt. 
     861               zsshu_a(ji,jj) = z1_2 * umask(ji,jj,1) / ( e1u(ji  ,jj) * e2u(ji  ,jj) )                   & 
     862                  &                                  * ( e1t(ji  ,jj) * e2t(ji  ,jj) * ssha(ji  ,jj)     & 
     863                  &                                    + e1t(ji+1,jj) * e2t(ji+1,jj) * ssha(ji+1,jj) ) 
     864               zsshv_a(ji,jj) = z1_2 * vmask(ji,jj,1) / ( e1v(ji,jj  ) * e2v(ji,jj  ) )                   & 
     865                  &                                  * ( e1t(ji,jj  ) * e2t(ji,jj  ) * ssha(ji,jj  )     & 
     866                  &                                    + e1t(ji,jj+1) * e2t(ji,jj+1) * ssha(ji,jj+1) ) 
     867            END DO 
     868         END DO 
     869         CALL lbc_lnk( zsshu_a, 'U', 1._wp )   ;   CALL lbc_lnk( zsshv_a, 'V', 1._wp ) ! Boundary conditions 
     870      ENDIF 
     871      ! 
     872      ! Set advection velocity correction: 
     873      IF (((kt==nit000).AND.(neuler==0)).OR.(.NOT.ln_bt_fw)) THEN      
     874         un_adv(:,:) = zu_sum(:,:)*hur(:,:) 
     875         vn_adv(:,:) = zv_sum(:,:)*hvr(:,:) 
     876      ELSE 
     877         un_adv(:,:) = z1_2 * ( ub2_b(:,:) + zu_sum(:,:)) * hur(:,:) 
     878         vn_adv(:,:) = z1_2 * ( vb2_b(:,:) + zv_sum(:,:)) * hvr(:,:) 
     879      END IF 
     880 
     881      IF (ln_bt_fw) THEN ! Save integrated transport for next computation 
     882         ub2_b(:,:) = zu_sum(:,:) 
     883         vb2_b(:,:) = zv_sum(:,:) 
     884      ENDIF 
     885      ! 
     886      ! Update barotropic trend: 
     887      IF (( ln_dynadv_vec ).OR. (.NOT. lk_vvl)) THEN 
     888         DO jk=1,jpkm1 
     889            ua(:,:,jk) = ua(:,:,jk) + ( ua_b(:,:) - ub_b(:,:) ) * z1_2dt_b 
     890            va(:,:,jk) = va(:,:,jk) + ( va_b(:,:) - vb_b(:,:) ) * z1_2dt_b 
     891         END DO 
     892      ELSE 
     893         hu_e  (:,:) = umask(:,:,1) / ( zhur_b(:,:) + 1._wp - umask(:,:,1) ) 
     894         hv_e  (:,:) = vmask(:,:,1) / ( zhvr_b(:,:) + 1._wp - vmask(:,:,1) ) 
     895         DO jk=1,jpkm1 
     896            ua(:,:,jk) = ua(:,:,jk) + hur(:,:) * ( ua_b(:,:) - ub_b(:,:) * hu_e(:,:) ) * z1_2dt_b 
     897            va(:,:,jk) = va(:,:,jk) + hvr(:,:) * ( va_b(:,:) - vb_b(:,:) * hv_e(:,:) ) * z1_2dt_b 
     898         END DO 
     899         ! Save barotropic velocities not transport: 
     900         ua_b  (:,:) =  ua_b(:,:) / ( hu_0(:,:) + zsshu_a(:,:) + 1._wp - umask(:,:,1) ) 
     901         va_b  (:,:) =  va_b(:,:) / ( hv_0(:,:) + zsshv_a(:,:) + 1._wp - vmask(:,:,1) ) 
     902      ENDIF 
     903      ! 
     904      DO jk = 1, jpkm1 
     905         ! Correct velocities: 
     906         un(:,:,jk) = ( un(:,:,jk) + un_adv(:,:) - un_b(:,:) )*umask(:,:,jk) 
     907         vn(:,:,jk) = ( vn(:,:,jk) + vn_adv(:,:) - vn_b(:,:) )*vmask(:,:,jk) 
     908         ! 
    674909      END DO 
    675       un_b  (:,:) =  zu_sum(:,:)  
    676       vn_b  (:,:) =  zv_sum(:,:)  
    677       sshn_b(:,:) = zcoef * zssh_sum(:,:)  
    678910      ! 
    679911      !                                   !* write time-spliting arrays in the restart 
    680       IF( lrst_oce )   CALL ts_rst( kt, 'WRITE' ) 
    681       ! 
    682       CALL wrk_dealloc( jpi, jpj, zsshun_e, zsshvn_e, zsshb_e, zssh_sum, zhdiv     ) 
    683       CALL wrk_dealloc( jpi, jpj, zua, zva, zun, zvn, zun_e, zvn_e, zub_e, zvb_e   ) 
    684       CALL wrk_dealloc( jpi, jpj, zcu, zcv, zwx, zwy, zbfru, zbfrv, zu_sum, zv_sum ) 
     912      IF(lrst_oce .AND.ln_bt_fw)   CALL ts_rst( kt, 'WRITE' ) 
     913      ! 
     914      CALL wrk_dealloc( jpi, jpj, zsshp2_e, zhdiv ) 
     915      CALL wrk_dealloc( jpi, jpj, zu_trd, zv_trd, zun_e, zvn_e ) 
     916      CALL wrk_dealloc( jpi, jpj, zwx, zwy, zu_sum, zv_sum, zssh_frc, zu_frc, zv_frc ) 
     917      CALL wrk_dealloc( jpi, jpj, zhup2_e, zhvp2_e, zhust_e, zhvst_e ) 
     918      CALL wrk_dealloc( jpi, jpj, zhur_b, zhvr_b                                     ) 
     919      CALL wrk_dealloc( jpi, jpj, zsshu_a, zsshv_a                                   ) 
     920      CALL wrk_dealloc( jpi, jpj, zht, zhf ) 
    685921      ! 
    686922      IF( nn_timing == 1 )  CALL timing_stop('dyn_spg_ts') 
    … …  
    688924   END SUBROUTINE dyn_spg_ts 
    689925 
     926   SUBROUTINE ts_wgt( ll_av, ll_fw, jpit, zwgt1, zwgt2) 
     927      !!--------------------------------------------------------------------- 
     928      !!                   ***  ROUTINE ts_wgt  *** 
     929      !! 
     930      !! ** Purpose : Set time-splitting weights for temporal averaging (or not) 
     931      !!---------------------------------------------------------------------- 
     932      LOGICAL, INTENT(in) ::   ll_av      ! temporal averaging=.true. 
     933      LOGICAL, INTENT(in) ::   ll_fw      ! forward time splitting =.true. 
     934      INTEGER, INTENT(inout) :: jpit      ! cycle length     
     935      REAL(wp), DIMENSION(3*nn_baro), INTENT(inout) ::   zwgt1, & ! Primary weights 
     936                                                         zwgt2    ! Secondary weights 
     937       
     938      INTEGER ::  jic, jn, ji                      ! temporary integers 
     939      REAL(wp) :: za1, za2 
     940      !!---------------------------------------------------------------------- 
     941 
     942      zwgt1(:) = 0._wp 
     943      zwgt2(:) = 0._wp 
     944 
     945      ! Set time index when averaged value is requested 
     946      IF (ll_fw) THEN  
     947         jic = nn_baro 
     948      ELSE 
     949         jic = 2 * nn_baro 
     950      ENDIF 
     951 
     952      ! Set primary weights: 
     953      IF (ll_av) THEN 
     954           ! Define simple boxcar window for primary weights  
     955           ! (width = nn_baro, centered around jic)      
     956         SELECT CASE ( nn_bt_flt ) 
     957              CASE( 0 )  ! No averaging 
     958                 zwgt1(jic) = 1._wp 
     959                 jpit = jic 
     960 
     961              CASE( 1 )  ! Boxcar, width = nn_baro 
     962                 DO jn = 1, 3*nn_baro 
     963                    za1 = ABS(float(jn-jic))/float(nn_baro)  
     964                    IF (za1 < 0.5_wp) THEN 
     965                      zwgt1(jn) = 1._wp 
     966                      jpit = jn 
     967                    ENDIF 
     968                 ENDDO 
     969 
     970              CASE( 2 )  ! Boxcar, width = 2 * nn_baro 
     971                 DO jn = 1, 3*nn_baro 
     972                    za1 = ABS(float(jn-jic))/float(nn_baro)  
     973                    IF (za1 < 1._wp) THEN 
     974                      zwgt1(jn) = 1._wp 
     975                      jpit = jn 
     976                    ENDIF 
     977                 ENDDO 
     978              CASE DEFAULT   ;   CALL ctl_stop( 'unrecognised value for nn_bt_flt' ) 
     979         END SELECT 
     980 
     981      ELSE ! No time averaging 
     982         zwgt1(jic) = 1._wp 
     983         jpit = jic 
     984      ENDIF 
     985     
     986      ! Set secondary weights 
     987      DO jn = 1, jpit 
     988        DO ji = jn, jpit 
     989             zwgt2(jn) = zwgt2(jn) + zwgt1(ji) 
     990        END DO 
     991      END DO 
     992 
     993      ! Normalize weigths: 
     994      za1 = 1._wp / SUM(zwgt1(1:jpit)) 
     995      za2 = 1._wp / SUM(zwgt2(1:jpit)) 
     996      DO jn = 1, jpit 
     997        zwgt1(jn) = zwgt1(jn) * za1 
     998        zwgt2(jn) = zwgt2(jn) * za2 
     999      END DO 
     1000      ! 
     1001   END SUBROUTINE ts_wgt 
    6901002 
    6911003   SUBROUTINE ts_rst( kt, cdrw ) 
    … …  
    6981010      CHARACTER(len=*), INTENT(in) ::   cdrw       ! "READ"/"WRITE" flag 
    6991011      ! 
    700       INTEGER ::  ji, jk        ! dummy loop indices 
    7011012      !!---------------------------------------------------------------------- 
    7021013      ! 
    7031014      IF( TRIM(cdrw) == 'READ' ) THEN 
    704          IF( iom_varid( numror, 'un_b', ldstop = .FALSE. ) > 0 ) THEN 
    705             CALL iom_get( numror, jpdom_autoglo, 'un_b'  , un_b  (:,:) )   ! external velocity issued 
    706             CALL iom_get( numror, jpdom_autoglo, 'vn_b'  , vn_b  (:,:) )   ! from barotropic loop 
     1015         CALL iom_get( numror, jpdom_autoglo, 'ub2_b'  , ub2_b  (:,:) )    
     1016         CALL iom_get( numror, jpdom_autoglo, 'vb2_b'  , vb2_b  (:,:) )  
     1017         IF( .NOT.ln_bt_av .AND. iom_varid( numror, 'sshbb_e', ldstop = .FALSE. ) > 0) THEN 
     1018            CALL iom_get( numror, jpdom_autoglo, 'sshbb_e'  , sshbb_e(:,:) )    
     1019            CALL iom_get( numror, jpdom_autoglo, 'ubb_e'    ,   ubb_e(:,:) )    
     1020            CALL iom_get( numror, jpdom_autoglo, 'vbb_e'    ,   vbb_e(:,:) ) 
     1021            CALL iom_get( numror, jpdom_autoglo, 'sshb_e'   ,  sshb_e(:,:) )  
     1022            CALL iom_get( numror, jpdom_autoglo, 'ub_e'     ,    ub_e(:,:) )    
     1023            CALL iom_get( numror, jpdom_autoglo, 'vb_e'     ,    vb_e(:,:) ) 
    7071024         ELSE 
    708             un_b (:,:) = 0._wp 
    709             vn_b (:,:) = 0._wp 
    710             ! vertical sum 
    711             IF( lk_vopt_loop ) THEN          ! vector opt., forced unroll 
    712                DO jk = 1, jpkm1 
    713                   DO ji = 1, jpij 
    714                      un_b(ji,1) = un_b(ji,1) + fse3u(ji,1,jk) * un(ji,1,jk) 
    715                      vn_b(ji,1) = vn_b(ji,1) + fse3v(ji,1,jk) * vn(ji,1,jk) 
    716                   END DO 
    717                END DO 
    718             ELSE                             ! No  vector opt. 
    719                DO jk = 1, jpkm1 
    720                   un_b(:,:) = un_b(:,:) + fse3u(:,:,jk) * un(:,:,jk) 
    721                   vn_b(:,:) = vn_b(:,:) + fse3v(:,:,jk) * vn(:,:,jk) 
    722                END DO 
    723             ENDIF 
    724             un_b (:,:) = un_b(:,:) * hur(:,:) 
    725             vn_b (:,:) = vn_b(:,:) * hvr(:,:) 
    726          ENDIF 
    727  
    728          ! Vertically integrated velocity (before) 
    729          IF (neuler/=0) THEN 
    730             ub_b (:,:) = 0._wp 
    731             vb_b (:,:) = 0._wp 
    732  
    733             ! vertical sum 
    734             IF( lk_vopt_loop ) THEN          ! vector opt., forced unroll 
    735                DO jk = 1, jpkm1 
    736                   DO ji = 1, jpij 
    737                      ub_b(ji,1) = ub_b(ji,1) + fse3u_b(ji,1,jk) * ub(ji,1,jk) 
    738                      vb_b(ji,1) = vb_b(ji,1) + fse3v_b(ji,1,jk) * vb(ji,1,jk) 
    739                   END DO 
    740                END DO 
    741             ELSE                             ! No  vector opt. 
    742                DO jk = 1, jpkm1 
    743                   ub_b(:,:) = ub_b(:,:) + fse3u_b(:,:,jk) * ub(:,:,jk) 
    744                   vb_b(:,:) = vb_b(:,:) + fse3v_b(:,:,jk) * vb(:,:,jk) 
    745                END DO 
    746             ENDIF 
    747  
    748             IF( lk_vvl ) THEN 
    749                ub_b (:,:) = ub_b(:,:) * umask(:,:,1) / ( hu_0(:,:) + sshu_b(:,:) + 1._wp - umask(:,:,1) ) 
    750                vb_b (:,:) = vb_b(:,:) * vmask(:,:,1) / ( hv_0(:,:) + sshv_b(:,:) + 1._wp - vmask(:,:,1) ) 
    751             ELSE 
    752                ub_b(:,:) = ub_b(:,:) * hur(:,:) 
    753                vb_b(:,:) = vb_b(:,:) * hvr(:,:) 
    754             ENDIF 
    755          ELSE                                 ! neuler==0 
    756             ub_b (:,:) = un_b (:,:) 
    757             vb_b (:,:) = vn_b (:,:) 
    758          ENDIF 
    759  
    760          IF( iom_varid( numror, 'sshn_b', ldstop = .FALSE. ) > 0 ) THEN 
    761             CALL iom_get( numror, jpdom_autoglo, 'sshn_b' , sshn_b (:,:) )   ! filtered ssh 
    762          ELSE 
    763             sshn_b(:,:) = sshb(:,:)   ! if not in restart set previous time mean to current baroclinic before value    
    764          ENDIF  
     1025            sshbb_e = sshn_b                                                ! ACC GUESS WORK 
     1026            ubb_e   = ub_b 
     1027            vbb_e   = vb_b 
     1028            sshb_e  = sshn_b 
     1029            ub_e    = ub_b 
     1030            vb_e    = vb_b 
     1031         ENDIF 
     1032      ! 
    7651033      ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN 
    766          CALL iom_rstput( kt, nitrst, numrow, 'un_b'   , un_b  (:,:) )   ! external velocity and ssh 
    767          CALL iom_rstput( kt, nitrst, numrow, 'vn_b'   , vn_b  (:,:) )   ! issued from barotropic loop 
    768          CALL iom_rstput( kt, nitrst, numrow, 'sshn_b' , sshn_b(:,:) )   !  
     1034         CALL iom_rstput( kt, nitrst, numrow, 'ub2_b'   , ub2_b  (:,:) ) 
     1035         CALL iom_rstput( kt, nitrst, numrow, 'vb2_b'   , vb2_b  (:,:) ) 
     1036         ! 
     1037         IF (.NOT.ln_bt_av) THEN 
     1038            CALL iom_rstput( kt, nitrst, numrow, 'sshbb_e'  , sshbb_e(:,:) )  
     1039            CALL iom_rstput( kt, nitrst, numrow, 'ubb_e'    ,   ubb_e(:,:) ) 
     1040            CALL iom_rstput( kt, nitrst, numrow, 'vbb_e'    ,   vbb_e(:,:) ) 
     1041            CALL iom_rstput( kt, nitrst, numrow, 'sshb_e'   ,  sshb_e(:,:) ) 
     1042            CALL iom_rstput( kt, nitrst, numrow, 'ub_e'     ,    ub_e(:,:) ) 
     1043            CALL iom_rstput( kt, nitrst, numrow, 'vb_e'     ,    vb_e(:,:) ) 
     1044         ENDIF 
    7691045      ENDIF 
    7701046      ! 
    7711047   END SUBROUTINE ts_rst 
    7721048 
     1049   SUBROUTINE dyn_spg_ts_init( kt ) 
     1050      !!--------------------------------------------------------------------- 
     1051      !!                   ***  ROUTINE dyn_spg_ts_init  *** 
     1052      !! 
     1053      !! ** Purpose : Set time splitting options 
     1054      !!---------------------------------------------------------------------- 
     1055      INTEGER         , INTENT(in) ::   kt         ! ocean time-step 
     1056      ! 
     1057      INTEGER  :: ji ,jj, jk 
     1058      REAL(wp) :: zxr2, zyr2, zcmax 
     1059      REAL(wp), POINTER, DIMENSION(:,:) :: zcu, zht 
     1060      !! 
     1061!      NAMELIST/namsplit/ ln_bt_fw, ln_bt_av, ln_bt_nn_auto, & 
     1062!      &                  nn_baro, rn_bt_cmax, nn_bt_flt 
     1063      !!---------------------------------------------------------------------- 
     1064!      REWIND( numnam )              !* Namelist namsplit: split-explicit free surface 
     1065!      READ  ( numnam, namsplit ) 
     1066      !         ! Max courant number for ext. grav. waves 
     1067      ! 
     1068      CALL wrk_alloc( jpi, jpj, zcu, zht ) 
     1069      ! 
     1070      ! JC: Simplification needed below: define ht_0 even when volume is fixed 
     1071      IF (lk_vvl) THEN  
     1072         zht(:,:) = ht_0(:,:) * tmask(:,:,1) 
     1073      ELSE 
     1074         zht(:,:) = 0. 
     1075         DO jk = 1, jpkm1 
     1076            zht(:,:) = zht(:,:) + fse3t_n(:,:,jk) * tmask(:,:,jk) 
     1077         END DO 
     1078      ENDIF 
     1079 
     1080      DO jj = 1, jpj 
     1081         DO ji =1, jpi 
     1082            zxr2 = 1./(e1t(ji,jj)*e1t(ji,jj)) 
     1083            zyr2 = 1./(e2t(ji,jj)*e2t(ji,jj)) 
     1084            zcu(ji,jj) = sqrt(grav*zht(ji,jj)*(zxr2 + zyr2) ) 
     1085         END DO 
     1086      END DO 
     1087 
     1088      zcmax = MAXVAL(zcu(:,:)) 
     1089      IF( lk_mpp )   CALL mpp_max( zcmax ) 
     1090 
     1091      ! Estimate number of iterations to satisfy a max courant number=0.8  
     1092      IF (ln_bt_nn_auto) nn_baro = CEILING( rdt / rn_bt_cmax * zcmax) 
     1093       
     1094      rdtbt = rdt / FLOAT(nn_baro) 
     1095      zcmax = zcmax * rdtbt 
     1096                     ! Print results 
     1097      IF(lwp) WRITE(numout,*) 
     1098      IF(lwp) WRITE(numout,*) 'dyn_spg_ts : split-explicit free surface' 
     1099      IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 
     1100      IF( ln_bt_nn_auto ) THEN 
     1101         IF(lwp) WRITE(numout,*) ' ln_ts_nn_auto=.true. Automatically set nn_baro ' 
     1102         IF(lwp) WRITE(numout,*) ' Max. courant number allowed: ', rn_bt_cmax 
     1103      ELSE 
     1104         IF(lwp) WRITE(numout,*) ' ln_ts_nn_auto=.false.: Use nn_baro in namelist ' 
     1105      ENDIF 
     1106      IF(lwp) WRITE(numout,*) ' nn_baro = ', nn_baro 
     1107      IF(lwp) WRITE(numout,*) ' Barotropic time step [s] is :', rdtbt 
     1108      IF(lwp) WRITE(numout,*) ' Maximum Courant number is   :', zcmax 
     1109 
     1110      IF(ln_bt_av) THEN 
     1111         IF(lwp) WRITE(numout,*) ' ln_bt_av=.true.  => Time averaging over nn_baro time steps is on ' 
     1112      ELSE 
     1113         IF(lwp) WRITE(numout,*) ' ln_bt_av=.false. => No time averaging of barotropic variables ' 
     1114      ENDIF 
     1115      ! 
     1116      ! 
     1117      IF(ln_bt_fw) THEN 
     1118         IF(lwp) WRITE(numout,*) ' ln_bt_fw=.true.  => Forward integration of barotropic variables ' 
     1119      ELSE 
     1120         IF(lwp) WRITE(numout,*) ' ln_bt_fw =.false.=> Centered integration of barotropic variables ' 
     1121      ENDIF 
     1122      ! 
     1123      IF(lwp) WRITE(numout,*) ' Time filter choice, nn_bt_flt: ', nn_bt_flt 
     1124      SELECT CASE ( nn_bt_flt ) 
     1125           CASE( 0 )  ;   IF(lwp) WRITE(numout,*) '      Dirac' 
     1126           CASE( 1 )  ;   IF(lwp) WRITE(numout,*) '      Boxcar: width = nn_baro' 
     1127           CASE( 2 )  ;   IF(lwp) WRITE(numout,*) '      Boxcar: width = 2*nn_baro'  
     1128           CASE DEFAULT   ;   CALL ctl_stop( 'unrecognised value for nn_bt_flt: should 0,1,2' ) 
     1129      END SELECT 
     1130      ! 
     1131      IF ((.NOT.ln_bt_av).AND.(.NOT.ln_bt_fw)) THEN 
     1132         CALL ctl_stop( 'dynspg_ts ERROR: No time averaging => only forward integration is possible' ) 
     1133      ENDIF 
     1134      IF ( zcmax>0.9_wp ) THEN 
     1135         CALL ctl_stop( 'dynspg_ts ERROR: Maximum Courant number is greater than 0.9: Inc. nn_baro !' )           
     1136      ENDIF 
     1137      ! 
     1138      CALL wrk_dealloc( jpi, jpj, zcu, zht ) 
     1139      ! 
     1140   END SUBROUTINE dyn_spg_ts_init 
     1141 
    7731142#else 
    774    !!---------------------------------------------------------------------- 
    775    !!   Default case :   Empty module   No standart free surface cst volume 
    776    !!---------------------------------------------------------------------- 
     1143   !!--------------------------------------------------------------------------- 
     1144   !!   Default case :   Empty module   No standard free surface constant volume 
     1145   !!--------------------------------------------------------------------------- 
     1146 
     1147   USE par_kind 
     1148   LOGICAL, PUBLIC, PARAMETER :: ln_bt_fw=.FALSE. ! Forward integration of barotropic sub-stepping 
    7771149CONTAINS 
    7781150   INTEGER FUNCTION dyn_spg_ts_alloc()    ! Dummy function 
    … …  
    7871159      CHARACTER(len=*), INTENT(in) ::   cdrw       ! "READ"/"WRITE" flag 
    7881160      WRITE(*,*) 'ts_rst    : You should not have seen this print! error?', kt, cdrw 
    789    END SUBROUTINE ts_rst     
     1161   END SUBROUTINE ts_rst   
     1162   SUBROUTINE dyn_spg_ts_init( kt )       ! Empty routine 
     1163      INTEGER         , INTENT(in) ::   kt         ! ocean time-step 
     1164      WRITE(*,*) 'dyn_spg_ts_init   : You should not have seen this print! error?', kt 
     1165   END SUBROUTINE dyn_spg_ts_init 
    7901166#endif 
    7911167    

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DYN/dynvor.F90

    r4147 r4292  
    572572      INTEGER  ::   ierr                                          ! local integer 
    573573      REAL(wp) ::   zfac12, zua, zva                              ! local scalars 
     574      REAL(wp) ::   zmsk, ze3                                     ! local scalars 
    574575      !                                                           !  3D workspace  
    575576      REAL(wp), POINTER    , DIMENSION(:,:  )         :: zwx, zwy, zwz 
    … …  
    577578#if defined key_vvl 
    578579      REAL(wp), POINTER    , DIMENSION(:,:,:)         :: ze3f     !  3D workspace (lk_vvl=T) 
    579 #endif 
    580 #if ! defined key_vvl 
     580#else 
    581581      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), SAVE   :: ze3f     ! lk_vvl=F, ze3f=1/e3f saved one for all 
    582582#endif 
    … …  
    604604      ENDIF 
    605605 
    606       IF( kt == nit000 .OR. lk_vvl ) THEN      ! reciprocal of e3 at F-point (masked averaging of e3t) 
     606      IF( kt == nit000 .OR. lk_vvl ) THEN      ! reciprocal of e3 at F-point (masked averaging of e3t over ocean points) 
    607607         DO jk = 1, jpk 
    608608            DO jj = 1, jpjm1 
    609609               DO ji = 1, jpim1 
    610                   ze3f(ji,jj,jk) = ( fse3t(ji,jj+1,jk)*tmask(ji,jj+1,jk) + fse3t(ji+1,jj+1,jk)*tmask(ji+1,jj+1,jk)   & 
    611                      &             + fse3t(ji,jj  ,jk)*tmask(ji,jj  ,jk) + fse3t(ji+1,jj  ,jk)*tmask(ji+1,jj  ,jk) ) * 0.25 
    612                   IF( ze3f(ji,jj,jk) /= 0._wp )   ze3f(ji,jj,jk) = 1._wp / ze3f(ji,jj,jk) 
     610                  ze3  = ( fse3t(ji,jj+1,jk)*tmask(ji,jj+1,jk) + fse3t(ji+1,jj+1,jk)*tmask(ji+1,jj+1,jk)   & 
     611                     &   + fse3t(ji,jj  ,jk)*tmask(ji,jj  ,jk) + fse3t(ji+1,jj  ,jk)*tmask(ji+1,jj  ,jk) ) 
     612                  zmsk = (                   tmask(ji,jj+1,jk) +                     tmask(ji+1,jj+1,jk)   & 
     613                     &                     + tmask(ji,jj  ,jk) +                     tmask(ji+1,jj  ,jk) ) 
     614                  IF( ze3 /= 0._wp )   ze3f(ji,jj,jk) = zmsk / ze3 
    613615               END DO 
    614616            END DO 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DYN/dynzdf_imp.F90

    r3625 r4292  
    1616   USE oce             ! ocean dynamics and tracers 
    1717   USE dom_oce         ! ocean space and time domain 
     18   USE domvvl          ! variable volume 
    1819   USE sbc_oce         ! surface boundary condition: ocean 
    1920   USE zdf_oce         ! ocean vertical physics 
    … …  
    2425   USE wrk_nemo        ! Memory Allocation 
    2526   USE timing          ! Timing 
     27   USE dynadv          ! dynamics: vector invariant versus flux form 
     28   USE dynspg_oce, ONLY: lk_dynspg_ts, ua_b, va_b 
     29   USE dynspg_ts 
    2630 
    2731   IMPLICIT NONE 
    … …  
    2933 
    3034   PUBLIC   dyn_zdf_imp   ! called by step.F90 
     35 
     36   REAL(wp) ::  r_vvl     ! variable volume indicator, =1 if lk_vvl=T, =0 otherwise  
    3137 
    3238   !! * Substitutions 
    … …  
    6470      INTEGER  ::   ikbu, ikbv   ! local integers 
    6571      REAL(wp) ::   z1_p2dt, zcoef, zzwi, zzws, zrhs   ! local scalars 
     72      REAL(wp) ::   ze3ua, ze3va 
    6673      !!---------------------------------------------------------------------- 
    6774 
    6875      REAL(wp), POINTER, DIMENSION(:,:,:) ::  zwi, zwd, zws 
    69       REAL(wp), POINTER, DIMENSION(:,:)   ::  zavmu, zavmv 
    7076      !!---------------------------------------------------------------------- 
    7177      ! 
    … …  
    7379      ! 
    7480      CALL wrk_alloc( jpi,jpj,jpk, zwi, zwd, zws )  
    75       CALL wrk_alloc( jpi,jpj, zavmu, zavmv )  
    7681      ! 
    7782      IF( kt == nit000 ) THEN 
    … …  
    7984         IF(lwp) WRITE(numout,*) 'dyn_zdf_imp : vertical momentum diffusion implicit operator' 
    8085         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ ' 
     86         ! 
     87         IF( lk_vvl ) THEN   ;    r_vvl = 1._wp       ! Variable volume indicator 
     88         ELSE                ;    r_vvl = 0._wp        
     89         ENDIF 
    8190      ENDIF 
    8291 
    … …  
    94103      IF( ln_bfrimp ) THEN 
    95104# if defined key_vectopt_loop 
    96       DO jj = 1, 1 
    97          DO ji = jpi+2, jpij-jpi-1   ! vector opt. (forced unrolling) 
     105         DO jj = 1, 1 
     106            DO ji = jpi+2, jpij-jpi-1   ! vector opt. (forced unrolling) 
    98107# else 
    99       DO jj = 2, jpjm1 
    100          DO ji = 2, jpim1 
     108         DO jj = 2, jpjm1 
     109            DO ji = 2, jpim1 
    101110# endif 
    102             ikbu = mbku(ji,jj)         ! ocean bottom level at u- and v-points  
    103             ikbv = mbkv(ji,jj)         ! (deepest ocean u- and v-points) 
    104             zavmu(ji,jj) = avmu(ji,jj,ikbu+1) 
    105             zavmv(ji,jj) = avmv(ji,jj,ikbv+1) 
    106             avmu(ji,jj,ikbu+1) = -bfrua(ji,jj) * fse3uw(ji,jj,ikbu+1)  
    107             avmv(ji,jj,ikbv+1) = -bfrva(ji,jj) * fse3vw(ji,jj,ikbv+1) 
    108          END DO 
    109       END DO 
    110       ENDIF 
     111               ikbu = mbku(ji,jj)       ! ocean bottom level at u- and v-points  
     112               ikbv = mbkv(ji,jj)       ! (deepest ocean u- and v-points) 
     113               avmu(ji,jj,ikbu+1) = -bfrua(ji,jj) * fse3uw(ji,jj,ikbu+1) 
     114               avmv(ji,jj,ikbv+1) = -bfrva(ji,jj) * fse3vw(ji,jj,ikbv+1) 
     115            END DO 
     116         END DO 
     117      ENDIF 
     118 
     119#if defined key_dynspg_ts 
     120      IF( ln_dynadv_vec .OR. .NOT. lk_vvl ) THEN      ! applied on velocity 
     121         DO jk = 1, jpkm1 
     122            ua(:,:,jk) = ( ub(:,:,jk) + p2dt * ua(:,:,jk) ) * umask(:,:,jk) 
     123            va(:,:,jk) = ( vb(:,:,jk) + p2dt * va(:,:,jk) ) * vmask(:,:,jk) 
     124         END DO 
     125      ELSE                                            ! applied on thickness weighted velocity 
     126         DO jk = 1, jpkm1 
     127            ua(:,:,jk) = (          ub(:,:,jk) * fse3u_b(:,:,jk)      & 
     128               &           + p2dt * ua(:,:,jk) * fse3u_n(:,:,jk)  )   & 
     129               &                               / fse3u_a(:,:,jk) * umask(:,:,jk) 
     130            va(:,:,jk) = (          vb(:,:,jk) * fse3v_b(:,:,jk)      & 
     131               &           + p2dt * va(:,:,jk) * fse3v_n(:,:,jk)  )   & 
     132               &                               / fse3v_a(:,:,jk) * vmask(:,:,jk) 
     133         END DO 
     134      ENDIF 
     135 
     136      IF ( ln_bfrimp .AND.lk_dynspg_ts ) THEN 
     137         ! remove barotropic velocities: 
     138         DO jk = 1, jpkm1 
     139            ua(:,:,jk) = (ua(:,:,jk) - ua_b(:,:)) * umask(:,:,jk) 
     140            va(:,:,jk) = (va(:,:,jk) - va_b(:,:)) * vmask(:,:,jk) 
     141         ENDDO 
     142         ! Add bottom stress due to barotropic component only: 
     143         DO jj = 2, jpjm1         
     144            DO ji = fs_2, fs_jpim1   ! vector opt. 
     145               ikbu = mbku(ji,jj)         ! ocean bottom level at u- and v-points  
     146               ikbv = mbkv(ji,jj)         ! (deepest ocean u- and v-points) 
     147               ze3ua =  ( 1._wp - r_vvl ) * fse3u_n(ji,jj,ikbu) + r_vvl   * fse3u_a(ji,jj,ikbu) 
     148               ze3va =  ( 1._wp - r_vvl ) * fse3v_n(ji,jj,ikbv) + r_vvl   * fse3v_a(ji,jj,ikbv) 
     149               ua(ji,jj,ikbu) = ua(ji,jj,ikbu) + p2dt * bfrua(ji,jj) * ua_b(ji,jj) / ze3ua 
     150               va(ji,jj,ikbv) = va(ji,jj,ikbv) + p2dt * bfrva(ji,jj) * va_b(ji,jj) / ze3va 
     151            END DO 
     152         END DO 
     153      ENDIF 
     154#endif 
    111155 
    112156      ! 2. Vertical diffusion on u 
    … …  
    119163         DO jj = 2, jpjm1  
    120164            DO ji = fs_2, fs_jpim1   ! vector opt. 
    121                zcoef = - p2dt / fse3u(ji,jj,jk) 
     165               ze3ua =  ( 1._wp - r_vvl ) * fse3u_n(ji,jj,jk) + r_vvl   * fse3u_a(ji,jj,jk)   ! after scale factor at T-point 
     166               zcoef = - p2dt / ze3ua       
    122167               zzwi          = zcoef * avmu (ji,jj,jk  ) / fse3uw(ji,jj,jk  ) 
    123168               zwi(ji,jj,jk) = zzwi  * umask(ji,jj,jk) 
    … …  
    128173         END DO 
    129174      END DO 
    130       DO jj = 2, jpjm1        ! Surface boudary conditions 
     175      DO jj = 2, jpjm1        ! Surface boundary conditions 
    131176         DO ji = fs_2, fs_jpim1   ! vector opt. 
    132177            zwi(ji,jj,1) = 0._wp 
    … …  
    160205      DO jj = 2, jpjm1        !==  second recurrence:    SOLk = RHSk - Lk / Dk-1  Lk-1  == 
    161206         DO ji = fs_2, fs_jpim1   ! vector opt. 
    162             ua(ji,jj,1) = ub(ji,jj,1) + p2dt * (  ua(ji,jj,1) + 0.5_wp * ( utau_b(ji,jj) + utau(ji,jj) )   & 
    163                &                                                       * r1_rau0 / fse3u(ji,jj,1)       ) 
     207            ze3ua =  ( 1._wp - r_vvl ) * fse3u_n(ji,jj,1) + r_vvl   * fse3u_a(ji,jj,1)  
     208#if defined key_dynspg_ts 
     209            ua(ji,jj,1) = ua(ji,jj,1) + p2dt * 0.5_wp * ( utau_b(ji,jj) + utau(ji,jj) )   & 
     210               &                                      / ( ze3ua * rau0 )  
     211#else 
     212            ua(ji,jj,1) = ub(ji,jj,1) + p2dt *(ua(ji,jj,1) +  0.5_wp * ( utau_b(ji,jj) + utau(ji,jj) )   & 
     213               &                                                     / ( fse3u(ji,jj,1) * rau0     ) )  
     214#endif 
    164215         END DO 
    165216      END DO 
    … …  
    167218         DO jj = 2, jpjm1    
    168219            DO ji = fs_2, fs_jpim1   ! vector opt. 
    169                zrhs = ub(ji,jj,jk) + p2dt * ua(ji,jj,jk)   ! zrhs=right hand side 
     220#if defined key_dynspg_ts 
     221               zrhs = ua(ji,jj,jk)   ! zrhs=right hand side 
     222#else 
     223               zrhs = ub(ji,jj,jk) + p2dt * ua(ji,jj,jk) 
     224#endif 
    170225               ua(ji,jj,jk) = zrhs - zwi(ji,jj,jk) / zwd(ji,jj,jk-1) * ua(ji,jj,jk-1) 
    171226            END DO 
    … …  
    186241      END DO 
    187242 
     243#if ! defined key_dynspg_ts 
    188244      ! Normalization to obtain the general momentum trend ua 
    189245      DO jk = 1, jpkm1 
    … …  
    194250         END DO 
    195251      END DO 
    196  
     252#endif 
    197253 
    198254      ! 3. Vertical diffusion on v 
    … …  
    205261         DO jj = 2, jpjm1    
    206262            DO ji = fs_2, fs_jpim1   ! vector opt. 
    207                zcoef = -p2dt / fse3v(ji,jj,jk) 
     263               ze3va =  ( 1._wp - r_vvl ) * fse3v_n(ji,jj,jk)  + r_vvl * fse3v_a(ji,jj,jk)   ! after scale factor at T-point 
     264               zcoef = - p2dt / ze3va 
    208265               zzwi          = zcoef * avmv (ji,jj,jk  ) / fse3vw(ji,jj,jk  ) 
    209266               zwi(ji,jj,jk) =  zzwi * vmask(ji,jj,jk) 
    … …  
    214271         END DO 
    215272      END DO 
    216       DO jj = 2, jpjm1        ! Surface boudary conditions 
     273      DO jj = 2, jpjm1        ! Surface boundary conditions 
    217274         DO ji = fs_2, fs_jpim1   ! vector opt. 
    218275            zwi(ji,jj,1) = 0._wp 
    … …  
    246303      DO jj = 2, jpjm1        !==  second recurrence:    SOLk = RHSk - Lk / Dk-1  Lk-1  == 
    247304         DO ji = fs_2, fs_jpim1   ! vector opt. 
    248             va(ji,jj,1) = vb(ji,jj,1) + p2dt * (  va(ji,jj,1) + 0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) )   & 
    249                &                                                       * r1_rau0 / fse3v(ji,jj,1)       ) 
     305            ze3va =  ( 1._wp - r_vvl ) * fse3v_n(ji,jj,1) + r_vvl   * fse3v_a(ji,jj,1)  
     306#if defined key_dynspg_ts             
     307            va(ji,jj,1) = va(ji,jj,1) + p2dt * 0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) )   & 
     308               &                                      / ( ze3va * rau0 )  
     309#else 
     310            va(ji,jj,1) = vb(ji,jj,1) + p2dt *(va(ji,jj,1) +  0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) )   & 
     311               &                                                       / ( fse3v(ji,jj,1) * rau0     )  ) 
     312#endif 
    250313         END DO 
    251314      END DO 
    … …  
    253316         DO jj = 2, jpjm1 
    254317            DO ji = fs_2, fs_jpim1   ! vector opt. 
    255                zrhs = vb(ji,jj,jk) + p2dt * va(ji,jj,jk)   ! zrhs=right hand side 
     318#if defined key_dynspg_ts 
     319               zrhs = va(ji,jj,jk)   ! zrhs=right hand side 
     320#else 
     321               zrhs = vb(ji,jj,jk) + p2dt * va(ji,jj,jk) 
     322#endif 
    256323               va(ji,jj,jk) = zrhs - zwi(ji,jj,jk) / zwd(ji,jj,jk-1) * va(ji,jj,jk-1) 
    257324            END DO 
    … …  
    259326      END DO 
    260327      ! 
    261       DO jj = 2, jpjm1        !==  thrid recurrence : SOLk = ( Lk - Uk * SOLk+1 ) / Dk  == 
     328      DO jj = 2, jpjm1        !==  third recurrence : SOLk = ( Lk - Uk * SOLk+1 ) / Dk  == 
    262329         DO ji = fs_2, fs_jpim1   ! vector opt. 
    263330            va(ji,jj,jpkm1) = va(ji,jj,jpkm1) / zwd(ji,jj,jpkm1) 
    … …  
    273340 
    274341      ! Normalization to obtain the general momentum trend va 
     342#if ! defined key_dynspg_ts 
    275343      DO jk = 1, jpkm1 
    276344         DO jj = 2, jpjm1    
    … …  
    280348         END DO 
    281349      END DO 
    282  
     350#endif 
     351 
     352      ! J. Chanut: Lines below are useless ? 
    283353      !! restore bottom layer avmu(v)  
    284354      IF( ln_bfrimp ) THEN 
    … …  
    292362            ikbu = mbku(ji,jj)         ! ocean bottom level at u- and v-points  
    293363            ikbv = mbkv(ji,jj)         ! (deepest ocean u- and v-points) 
    294             avmu(ji,jj,ikbu+1) = zavmu(ji,jj) 
    295             avmv(ji,jj,ikbv+1) = zavmv(ji,jj) 
     364            avmu(ji,jj,ikbu+1) = 0.e0 
     365            avmv(ji,jj,ikbv+1) = 0.e0 
    296366         END DO 
    297367      END DO 
    … …  
    299369      ! 
    300370      CALL wrk_dealloc( jpi,jpj,jpk, zwi, zwd, zws)  
    301       CALL wrk_dealloc( jpi,jpj, zavmu, zavmv)  
    302371      ! 
    303372      IF( nn_timing == 1 )  CALL timing_stop('dyn_zdf_imp') 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DYN/sshwzv.F90

    r3764 r4292  
    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 
    10    !!---------------------------------------------------------------------- 
    11  
    12    !!---------------------------------------------------------------------- 
    13    !!   ssh_wzv        : after ssh & now vertical velocity 
    14    !!   ssh_nxt        : filter ans swap the ssh arrays 
     10   !!            3.3  !  2011-10  (M. Leclair) split former ssh_wzv routine and remove all vvl related work 
     11   !!---------------------------------------------------------------------- 
     12 
     13   !!---------------------------------------------------------------------- 
     14   !!   ssh_nxt        : after ssh 
     15   !!   ssh_swp        : filter ans swap the ssh arrays 
     16   !!   wzv            : compute now vertical velocity 
    1517   !!---------------------------------------------------------------------- 
    1618   USE oce             ! ocean dynamics and tracers variables 
    … …  
    2022   USE divcur          ! hor. divergence and curl      (div & cur routines) 
    2123   USE iom             ! I/O library 
     24   USE restart         ! only for lrst_oce 
    2225   USE in_out_manager  ! I/O manager 
    2326   USE prtctl          ! Print control 
    … …  
    2831   USE obc_oce 
    2932   USE bdy_oce 
     33   USE bdy_par          
     34   USE bdydyn2d        ! bdy_ssh routine 
    3035   USE diaar5, ONLY:   lk_diaar5 
    3136   USE iom 
    32    USE sbcrnf, ONLY: h_rnf, nk_rnf   ! River runoff  
     37   USE sbcrnf, ONLY: h_rnf, nk_rnf, sbc_rnf_div   ! River runoff  
     38   USE dynspg_ts,   ONLY: ln_bt_fw 
     39   USE dynspg_oce, ONLY: lk_dynspg_ts 
    3340#if defined key_agrif 
    3441   USE agrif_opa_update 
    … …  
    4451   PRIVATE 
    4552 
    46    PUBLIC   ssh_wzv    ! called by step.F90 
    4753   PUBLIC   ssh_nxt    ! called by step.F90 
     54   PUBLIC   wzv        ! called by step.F90 
     55   PUBLIC   ssh_swp    ! called by step.F90 
    4856 
    4957   !! * Substitutions 
    … …  
    5765CONTAINS 
    5866 
    59    SUBROUTINE ssh_wzv( kt )  
    60       !!---------------------------------------------------------------------- 
    61       !!                ***  ROUTINE ssh_wzv  *** 
     67   SUBROUTINE ssh_nxt( kt ) 
     68      !!---------------------------------------------------------------------- 
     69      !!                ***  ROUTINE ssh_nxt  *** 
    6270      !!                    
    63       !! ** Purpose :   compute the after ssh (ssha), the now vertical velocity 
    64       !!              and update the now vertical coordinate (lk_vvl=T). 
    65       !! 
    66       !! ** Method  : - Using the incompressibility hypothesis, the vertical  
    67       !!      velocity is computed by integrating the horizontal divergence   
    68       !!      from the bottom to the surface minus the scale factor evolution. 
    69       !!        The boundary conditions are w=0 at the bottom (no flux) and. 
     71      !! ** Purpose :   compute the after ssh (ssha) 
     72      !! 
     73      !! ** Method  : - Using the incompressibility hypothesis, the ssh increment 
     74      !!      is computed by integrating the horizontal divergence and multiply by 
     75      !!      by the time step. 
    7076      !! 
    7177      !! ** action  :   ssha    : after sea surface height 
    72       !!                wn      : now vertical velocity 
    73       !!                sshu_a, sshv_a, sshf_a  : after sea surface height (lk_vvl=T) 
    74       !!                hu, hv, hur, hvr        : ocean depth and its inverse at u-,v-points 
    7578      !! 
    7679      !! Reference  : Leclair, M., and G. Madec, 2009, Ocean Modelling. 
    7780      !!---------------------------------------------------------------------- 
    78       INTEGER, INTENT(in) ::   kt   ! time step 
    79       ! 
    80       INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    81       REAL(wp) ::   zcoefu, zcoefv, zcoeff, z2dt, z1_2dt, z1_rau0   ! local scalars 
    82       REAL(wp), POINTER, DIMENSION(:,:  ) ::  z2d, zhdiv 
    83       REAL(wp), POINTER, DIMENSION(:,:,:) ::  z3d 
    84       !!---------------------------------------------------------------------- 
    85       ! 
    86       IF( nn_timing == 1 )  CALL timing_start('ssh_wzv') 
    87       ! 
    88       CALL wrk_alloc( jpi, jpj, z2d, zhdiv )  
     81      ! 
     82      REAL(wp), POINTER, DIMENSION(:,:  ) ::  zhdiv 
     83      INTEGER, INTENT(in) ::   kt                      ! time step 
     84      !  
     85      INTEGER             ::   jk                      ! dummy loop indice 
     86      REAL(wp)            ::   z2dt, z1_rau0           ! local scalars 
     87      !!---------------------------------------------------------------------- 
     88      ! 
     89      IF( nn_timing == 1 )  CALL timing_start('ssh_nxt') 
     90      ! 
     91      CALL wrk_alloc( jpi, jpj, zhdiv )  
    8992      ! 
    9093      IF( kt == nit000 ) THEN 
    9194         ! 
    9295         IF(lwp) WRITE(numout,*) 
    93          IF(lwp) WRITE(numout,*) 'ssh_wzv : after sea surface height and now vertical velocity ' 
     96         IF(lwp) WRITE(numout,*) 'ssh_nxt : after sea surface height' 
    9497         IF(lwp) WRITE(numout,*) '~~~~~~~ ' 
    9598         ! 
    96          wn(:,:,jpk) = 0._wp                  ! bottom boundary condition: w=0 (set once for all) 
    97          ! 
    98          IF( lk_vvl ) THEN                    ! before and now Sea SSH at u-, v-, f-points (vvl case only) 
    99             DO jj = 1, jpjm1 
    100                DO ji = 1, jpim1                    ! caution: use of Vector Opt. not possible 
    101                   zcoefu = 0.5  * umask(ji,jj,1) / ( e1u(ji,jj) * e2u(ji,jj) ) 
    102                   zcoefv = 0.5  * vmask(ji,jj,1) / ( e1v(ji,jj) * e2v(ji,jj) ) 
    103                   zcoeff = 0.25 * umask(ji,jj,1) * umask(ji,jj+1,1) 
    104                   sshu_b(ji,jj) = zcoefu * ( e1t(ji  ,jj) * e2t(ji  ,jj) * sshb(ji  ,jj)     & 
    105                      &                     + e1t(ji+1,jj) * e2t(ji+1,jj) * sshb(ji+1,jj) ) 
    106                   sshv_b(ji,jj) = zcoefv * ( e1t(ji,jj  ) * e2t(ji,jj  ) * sshb(ji,jj  )     & 
    107                      &                     + e1t(ji,jj+1) * e2t(ji,jj+1) * sshb(ji,jj+1) ) 
    108                   sshu_n(ji,jj) = zcoefu * ( e1t(ji  ,jj) * e2t(ji  ,jj) * sshn(ji  ,jj)     & 
    109                      &                     + e1t(ji+1,jj) * e2t(ji+1,jj) * sshn(ji+1,jj) ) 
    110                   sshv_n(ji,jj) = zcoefv * ( e1t(ji,jj  ) * e2t(ji,jj  ) * sshn(ji,jj  )     & 
    111                      &                     + e1t(ji,jj+1) * e2t(ji,jj+1) * sshn(ji,jj+1) ) 
    112                END DO 
    113             END DO 
    114             CALL lbc_lnk( sshu_b, 'U', 1. )   ;   CALL lbc_lnk( sshu_n, 'U', 1. ) 
    115             CALL lbc_lnk( sshv_b, 'V', 1. )   ;   CALL lbc_lnk( sshv_n, 'V', 1. ) 
    116             DO jj = 1, jpjm1 
    117                DO ji = 1, jpim1      ! NO Vector Opt. 
    118                   sshf_n(ji,jj) = 0.5  * umask(ji,jj,1) * umask(ji,jj+1,1)                   & 
    119                        &               / ( e1f(ji,jj  ) * e2f(ji,jj  ) )                     & 
    120                        &               * ( e1u(ji,jj  ) * e2u(ji,jj  ) * sshu_n(ji,jj  )     & 
    121                        &                 + e1u(ji,jj+1) * e2u(ji,jj+1) * sshu_n(ji,jj+1) ) 
    122                END DO 
    123             END DO 
    124             CALL lbc_lnk( sshf_n, 'F', 1. ) 
    125          ENDIF 
    126          ! 
    127       ENDIF 
    128  
    129       !                                           !------------------------------------------! 
    130       IF( lk_vvl ) THEN                           !  Regridding: Update Now Vertical coord.  !   (only in vvl case) 
    131          !                                        !------------------------------------------! 
    132          DO jk = 1, jpkm1 
    133             fsdept(:,:,jk) = fsdept_n(:,:,jk)         ! now local depths stored in fsdep. arrays 
    134             fsdepw(:,:,jk) = fsdepw_n(:,:,jk) 
    135             fsde3w(:,:,jk) = fsde3w_n(:,:,jk) 
    136             ! 
    137             fse3t (:,:,jk) = fse3t_n (:,:,jk)         ! vertical scale factors stored in fse3. arrays 
    138             fse3u (:,:,jk) = fse3u_n (:,:,jk) 
    139             fse3v (:,:,jk) = fse3v_n (:,:,jk) 
    140             fse3f (:,:,jk) = fse3f_n (:,:,jk) 
    141             fse3w (:,:,jk) = fse3w_n (:,:,jk) 
    142             fse3uw(:,:,jk) = fse3uw_n(:,:,jk) 
    143             fse3vw(:,:,jk) = fse3vw_n(:,:,jk) 
    144          END DO 
    145          ! 
    146          hu(:,:) = hu_0(:,:) + sshu_n(:,:)            ! now ocean depth (at u- and v-points) 
    147          hv(:,:) = hv_0(:,:) + sshv_n(:,:) 
    148          !                                            ! now masked inverse of the ocean depth (at u- and v-points) 
    149          hur(:,:) = umask(:,:,1) / ( hu(:,:) + 1._wp - umask(:,:,1) ) 
    150          hvr(:,:) = vmask(:,:,1) / ( hv(:,:) + 1._wp - vmask(:,:,1) ) 
    151          !  
    15299      ENDIF 
    153100      ! 
    … …  
    162109      zhdiv(:,:) = 0._wp 
    163110      DO jk = 1, jpkm1                                 ! Horizontal divergence of barotropic transports 
    164         zhdiv(:,:) = zhdiv(:,:) + fse3t(:,:,jk) * hdivn(:,:,jk) 
     111        zhdiv(:,:) = zhdiv(:,:) + fse3t_n(:,:,jk) * hdivn(:,:,jk) 
    165112      END DO 
    166113      !                                                ! Sea surface elevation time stepping 
    167114      ! In forward Euler time stepping case, the same formulation as in the leap-frog case can be used 
    168115      ! because emp_b field is initialized with the vlaues of emp field. Hence, 0.5 * ( emp + emp_b ) = emp 
    169       z1_rau0 = 0.5 / rau0 
     116      z1_rau0 = 0.5_wp * r1_rau0 
    170117      ssha(:,:) = (  sshb(:,:) - z2dt * ( z1_rau0 * ( emp_b(:,:) + emp(:,:) ) + zhdiv(:,:) )  ) * tmask(:,:,1) 
    171118 
    … …  
    180127#endif 
    181128#if defined key_bdy 
    182       ssha(:,:) = ssha(:,:) * bdytmask(:,:) 
    183       CALL lbc_lnk( ssha, 'T', 1. )                    ! absolutly compulsory !! (jmm) 
    184 #endif 
     129      ! bg jchanut tschanges 
     130      ! These lines are not necessary with time splitting since 
     131      ! boundary condition on sea level is set during ts loop 
     132      IF (lk_bdy) THEN 
     133         CALL lbc_lnk( ssha, 'T', 1. ) ! Not sure that's necessary 
     134         CALL bdy_ssh( ssha ) ! Duplicate sea level across open boundaries 
     135      ENDIF 
     136#endif 
     137      ! end jchanut tschanges 
    185138#if defined key_asminc 
    186139      !                                                ! Include the IAU weighted SSH increment 
    … …  
    190143      ENDIF 
    191144#endif 
    192       !                                                ! Sea Surface Height at u-,v- and f-points (vvl case only) 
    193       IF( lk_vvl ) THEN                                ! (required only in key_vvl case) 
    194          DO jj = 1, jpjm1 
    195             DO ji = 1, jpim1      ! NO Vector Opt. 
    196                sshu_a(ji,jj) = 0.5  * umask(ji,jj,1) / ( e1u(ji  ,jj) * e2u(ji  ,jj) )                   & 
    197                   &                                  * ( e1t(ji  ,jj) * e2t(ji  ,jj) * ssha(ji  ,jj)     & 
    198                   &                                    + e1t(ji+1,jj) * e2t(ji+1,jj) * ssha(ji+1,jj) ) 
    199                sshv_a(ji,jj) = 0.5  * vmask(ji,jj,1) / ( e1v(ji,jj  ) * e2v(ji,jj  ) )                   & 
    200                   &                                  * ( e1t(ji,jj  ) * e2t(ji,jj  ) * ssha(ji,jj  )     & 
    201                   &                                    + e1t(ji,jj+1) * e2t(ji,jj+1) * ssha(ji,jj+1) ) 
     145 
     146      !                                           !------------------------------! 
     147      !                                           !           outputs            ! 
     148      !                                           !------------------------------! 
     149      CALL iom_put( "ssh" , sshn                  )   ! sea surface height 
     150      CALL iom_put( "ssh2", sshn(:,:) * sshn(:,:) )   ! square of sea surface height 
     151      ! 
     152      IF(ln_ctl)   CALL prt_ctl( tab2d_1=ssha, clinfo1=' ssha  - : ', mask1=tmask, ovlap=1 ) 
     153      ! 
     154      CALL wrk_dealloc( jpi, jpj, zhdiv )  
     155      ! 
     156      IF( nn_timing == 1 )  CALL timing_stop('ssh_nxt') 
     157      ! 
     158   END SUBROUTINE ssh_nxt 
     159 
     160    
     161   SUBROUTINE wzv( kt ) 
     162      !!---------------------------------------------------------------------- 
     163      !!                ***  ROUTINE wzv  *** 
     164      !!                    
     165      !! ** Purpose :   compute the now vertical velocity 
     166      !! 
     167      !! ** Method  : - Using the incompressibility hypothesis, the vertical  
     168      !!      velocity is computed by integrating the horizontal divergence   
     169      !!      from the bottom to the surface minus the scale factor evolution. 
     170      !!        The boundary conditions are w=0 at the bottom (no flux) and. 
     171      !! 
     172      !! ** action  :   wn      : now vertical velocity 
     173      !! 
     174      !! Reference  : Leclair, M., and G. Madec, 2009, Ocean Modelling. 
     175      !!---------------------------------------------------------------------- 
     176      ! 
     177      INTEGER, INTENT(in) ::   kt           ! time step 
     178      REAL(wp), POINTER, DIMENSION(:,:  ) ::  z2d 
     179      REAL(wp), POINTER, DIMENSION(:,:,:) ::  z3d, zhdiv 
     180      ! 
     181      INTEGER             ::   ji, jj, jk   ! dummy loop indices 
     182      REAL(wp)            ::   z1_2dt       ! local scalars 
     183      !!---------------------------------------------------------------------- 
     184       
     185      IF( nn_timing == 1 )  CALL timing_start('wzv') 
     186      ! 
     187      IF( kt == nit000 ) THEN 
     188         ! 
     189         IF(lwp) WRITE(numout,*) 
     190         IF(lwp) WRITE(numout,*) 'wzv : now vertical velocity ' 
     191         IF(lwp) WRITE(numout,*) '~~~~~ ' 
     192         ! 
     193         wn(:,:,jpk) = 0._wp                  ! bottom boundary condition: w=0 (set once for all) 
     194         ! 
     195      ENDIF 
     196      !                                           !------------------------------! 
     197      !                                           !     Now Vertical Velocity    ! 
     198      !                                           !------------------------------! 
     199      z1_2dt = 1. / ( 2. * rdt )                         ! set time step size (Euler/Leapfrog) 
     200      IF( neuler == 0 .AND. kt == nit000 )   z1_2dt = 1. / rdt 
     201      ! 
     202      IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN      ! z_tilde and layer cases 
     203         CALL wrk_alloc( jpi, jpj, jpk, zhdiv )  
     204         ! 
     205         DO jk = 1, jpkm1 
     206            ! horizontal divergence of thickness diffusion transport ( velocity multiplied by e3t) 
     207            ! - ML - note: computation allready done in dom_vvl_sf_nxt. Could be optimized (not critical and clearer this way) 
     208            DO jj = 2, jpjm1 
     209               DO ji = fs_2, fs_jpim1   ! vector opt. 
     210                  zhdiv(ji,jj,jk) = r1_e12t(ji,jj) * ( un_td(ji,jj,jk) - un_td(ji-1,jj,jk) + vn_td(ji,jj,jk) - vn_td(ji,jj-1,jk) ) 
     211               END DO 
    202212            END DO 
    203213         END DO 
    204          CALL lbc_lnk( sshu_a, 'U', 1. )   ;   CALL lbc_lnk( sshv_a, 'V', 1. )      ! Boundaries conditions 
    205       ENDIF 
    206  
    207       !                                           !------------------------------! 
    208       !                                           !     Now Vertical Velocity    ! 
    209       !                                           !------------------------------! 
    210       z1_2dt = 1.e0 / z2dt 
    211       DO jk = jpkm1, 1, -1                             ! integrate from the bottom the hor. divergence 
    212          ! - ML - need 3 lines here because replacement of fse3t by its expression yields too long lines otherwise 
    213          wn(:,:,jk) = wn(:,:,jk+1) -   fse3t_n(:,:,jk) * hdivn(:,:,jk)        & 
    214             &                      - ( fse3t_a(:,:,jk) - fse3t_b(:,:,jk) )    & 
    215             &                         * tmask(:,:,jk) * z1_2dt 
     214         CALL lbc_lnk(zhdiv, 'T', 1.)  ! - ML - Perhaps not necessary: not used for horizontal "connexions" 
     215         !                             ! Is it problematic to have a wrong vertical velocity in boundary cells? 
     216         !                             ! Same question holds for hdivn. Perhaps just for security 
     217         DO jk = jpkm1, 1, -1                       ! integrate from the bottom the hor. divergence 
     218            ! computation of w 
     219            wn(:,:,jk) = wn(:,:,jk+1) - (   fse3t_n(:,:,jk) * hdivn(:,:,jk) + zhdiv(:,:,jk)                    & 
     220               &                          + z1_2dt * ( fse3t_a(:,:,jk) - fse3t_b(:,:,jk) ) ) * tmask(:,:,jk) 
     221         END DO 
     222         !          IF( ln_vvl_layer ) wn(:,:,:) = 0.e0 
     223         CALL wrk_dealloc( jpi, jpj, jpk, zhdiv )  
     224      ELSE   ! z_star and linear free surface cases 
     225         DO jk = jpkm1, 1, -1                       ! integrate from the bottom the hor. divergence 
     226            ! computation of w 
     227            wn(:,:,jk) = wn(:,:,jk+1) - (   fse3t_n(:,:,jk) * hdivn(:,:,jk)                                   & 
     228               &                          + z1_2dt * ( fse3t_a(:,:,jk) - fse3t_b(:,:,jk) ) ) * tmask(:,:,jk) 
     229         END DO 
     230      ENDIF 
     231 
    216232#if defined key_bdy 
    217233         wn(:,:,jk) = wn(:,:,jk) * bdytmask(:,:) 
    218234#endif 
    219       END DO 
    220  
     235      ! 
    221236      !                                           !------------------------------! 
    222237      !                                           !           outputs            ! 
    223238      !                                           !------------------------------! 
    224       CALL iom_put( "woce", wn                    )   ! vertical velocity 
    225       CALL iom_put( "ssh" , sshn                  )   ! sea surface height 
    226       CALL iom_put( "ssh2", sshn(:,:) * sshn(:,:) )   ! square of sea surface height 
     239      CALL iom_put( "woce", wn )   ! vertical velocity 
    227240      IF( lk_diaar5 ) THEN                            ! vertical mass transport & its square value 
     241         CALL wrk_alloc( jpi, jpj, z2d )  
     242         CALL wrk_alloc( jpi, jpj, jpk, z3d )  
    228243         ! Caution: in the VVL case, it only correponds to the baroclinic mass transport. 
    229          CALL wrk_alloc( jpi,jpj,jpk, z3d ) 
    230          z2d(:,:) = rau0 * e1t(:,:) * e2t(:,:) 
     244         z2d(:,:) = rau0 * e12t(:,:) 
    231245         DO jk = 1, jpk 
    232246            z3d(:,:,jk) = wn(:,:,jk) * z2d(:,:) 
    … …  
    234248         CALL iom_put( "w_masstr" , z3d                     )   
    235249         CALL iom_put( "w_masstr2", z3d(:,:,:) * z3d(:,:,:) ) 
    236          CALL wrk_dealloc( jpi,jpj,jpk, z3d ) 
    237       ENDIF 
    238       ! 
    239       IF(ln_ctl)   CALL prt_ctl( tab2d_1=ssha, clinfo1=' ssha  - : ', mask1=tmask, ovlap=1 ) 
    240       ! 
    241       CALL wrk_dealloc( jpi, jpj, z2d, zhdiv )  
    242       ! 
    243       IF( nn_timing == 1 )  CALL timing_stop('ssh_wzv') 
    244       ! 
    245    END SUBROUTINE ssh_wzv 
    246  
    247  
    248    SUBROUTINE ssh_nxt( kt ) 
     250         CALL wrk_dealloc( jpi, jpj, z2d  )  
     251         CALL wrk_dealloc( jpi, jpj, jpk, z3d )  
     252      ENDIF 
     253      ! 
     254      IF( nn_timing == 1 )  CALL timing_stop('wzv') 
     255 
     256 
     257   END SUBROUTINE wzv 
     258 
     259   SUBROUTINE ssh_swp( kt ) 
    249260      !!---------------------------------------------------------------------- 
    250261      !!                    ***  ROUTINE ssh_nxt  *** 
    … …  
    252263      !! ** Purpose :   achieve the sea surface  height time stepping by  
    253264      !!              applying Asselin time filter and swapping the arrays 
    254       !!              ssha  already computed in ssh_wzv   
     265      !!              ssha  already computed in ssh_nxt   
    255266      !! 
    256267      !! ** Method  : - apply Asselin time fiter to now ssh (excluding the forcing 
    … …  
    266277      !!---------------------------------------------------------------------- 
    267278      INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
    268       !! 
    269       INTEGER  ::   ji, jj   ! dummy loop indices 
    270       REAL(wp) ::   zec      ! temporary scalar 
    271       !!---------------------------------------------------------------------- 
    272       ! 
    273       IF( nn_timing == 1 )  CALL timing_start('ssh_nxt') 
     279      !!---------------------------------------------------------------------- 
     280      ! 
     281      IF( nn_timing == 1 )  CALL timing_start('ssh_swp') 
    274282      ! 
    275283      IF( kt == nit000 ) THEN 
    276284         IF(lwp) WRITE(numout,*) 
    277          IF(lwp) WRITE(numout,*) 'ssh_nxt : next sea surface height (Asselin time filter + swap)' 
     285         IF(lwp) WRITE(numout,*) 'ssh_swp : Asselin time filter and swap of sea surface height' 
    278286         IF(lwp) WRITE(numout,*) '~~~~~~~ ' 
    279287      ENDIF 
    280288 
    281       !                       !--------------------------! 
    282       IF( lk_vvl ) THEN       !  Variable volume levels  !     (ssh at t-, u-, v, f-points) 
    283          !                    !--------------------------! 
    284          ! 
    285          IF( neuler == 0 .AND. kt == nit000 ) THEN    !** Euler time-stepping at first time-step : no filter 
    286             sshn  (:,:) = ssha  (:,:)                       ! now <-- after  (before already = now) 
    287             sshu_n(:,:) = sshu_a(:,:) 
    288             sshv_n(:,:) = sshv_a(:,:) 
    289             DO jj = 1, jpjm1                                ! ssh now at f-point 
    290                DO ji = 1, jpim1      ! NO Vector Opt. 
    291                   sshf_n(ji,jj) = 0.5  * umask(ji,jj,1) * umask(ji,jj+1,1)                 & 
    292                      &               / ( e1f(ji,jj  ) * e2f(ji,jj  ) )                     & 
    293                      &               * ( e1u(ji,jj  ) * e2u(ji,jj  ) * sshu_n(ji,jj  )     & 
    294                      &                 + e1u(ji,jj+1) * e2u(ji,jj+1) * sshu_n(ji,jj+1) ) 
    295                END DO 
    296             END DO 
    297             CALL lbc_lnk( sshf_n, 'F', 1. )                 ! Boundaries conditions 
    298             ! 
    299          ELSE                                         !** Leap-Frog time-stepping: Asselin filter + swap 
    300             zec = atfp * rdt / rau0 
    301             DO jj = 1, jpj 
    302                DO ji = 1, jpi                               ! before <-- now filtered 
    303                   sshb  (ji,jj) = sshn  (ji,jj) + atfp * ( sshb(ji,jj) - 2 * sshn(ji,jj) + ssha(ji,jj) )   & 
    304                      &                          - zec  * ( emp_b(ji,jj) - emp(ji,jj) ) * tmask(ji,jj,1) 
    305                   sshn  (ji,jj) = ssha  (ji,jj)             ! now <-- after 
    306                   sshu_n(ji,jj) = sshu_a(ji,jj) 
    307                   sshv_n(ji,jj) = sshv_a(ji,jj) 
    308                END DO 
    309             END DO 
    310             DO jj = 1, jpjm1                                ! ssh now at f-point 
    311                DO ji = 1, jpim1      ! NO Vector Opt. 
    312                   sshf_n(ji,jj) = 0.5  * umask(ji,jj,1) * umask(ji,jj+1,1)                 & 
    313                      &               / ( e1f(ji,jj  ) * e2f(ji,jj  ) )                     & 
    314                      &               * ( e1u(ji,jj  ) * e2u(ji,jj  ) * sshu_n(ji,jj  )     & 
    315                      &                 + e1u(ji,jj+1) * e2u(ji,jj+1) * sshu_n(ji,jj+1) ) 
    316                END DO 
    317             END DO 
    318             CALL lbc_lnk( sshf_n, 'F', 1. )                 ! Boundaries conditions 
    319             ! 
    320             DO jj = 1, jpjm1                                ! ssh before at u- & v-points 
    321                DO ji = 1, jpim1      ! NO Vector Opt. 
    322                   sshu_b(ji,jj) = 0.5  * umask(ji,jj,1) / ( e1u(ji  ,jj) * e2u(ji  ,jj) )                   & 
    323                      &                                  * ( e1t(ji  ,jj) * e2t(ji  ,jj) * sshb(ji  ,jj)     & 
    324                      &                                    + e1t(ji+1,jj) * e2t(ji+1,jj) * sshb(ji+1,jj) ) 
    325                   sshv_b(ji,jj) = 0.5  * vmask(ji,jj,1) / ( e1v(ji,jj  ) * e2v(ji,jj  ) )                   & 
    326                      &                                  * ( e1t(ji,jj  ) * e2t(ji,jj  ) * sshb(ji,jj  )     & 
    327                      &                                    + e1t(ji,jj+1) * e2t(ji,jj+1) * sshb(ji,jj+1) ) 
    328                END DO 
    329             END DO 
    330             CALL lbc_lnk( sshu_b, 'U', 1. ) 
    331             CALL lbc_lnk( sshv_b, 'V', 1. )            !  Boundaries conditions 
    332             ! 
    333          ENDIF 
    334          !                    !--------------------------! 
    335       ELSE                    !        fixed levels      !     (ssh at t-point only) 
    336          !                    !--------------------------! 
    337          ! 
    338          IF( neuler == 0 .AND. kt == nit000 ) THEN    !** Euler time-stepping at first time-step : no filter 
    339             sshn(:,:) = ssha(:,:)                           ! now <-- after  (before already = now) 
    340             ! 
    341          ELSE                                               ! Leap-Frog time-stepping: Asselin filter + swap 
    342             DO jj = 1, jpj 
    343                DO ji = 1, jpi                               ! before <-- now filtered 
    344                   sshb(ji,jj) = sshn(ji,jj) + atfp * ( sshb(ji,jj) - 2 * sshn(ji,jj) + ssha(ji,jj) ) 
    345                   sshn(ji,jj) = ssha(ji,jj)                 ! now <-- after 
    346                END DO 
    347             END DO 
    348          ENDIF 
    349          ! 
     289# if defined key_dynspg_ts 
     290      IF( ( neuler == 0 .AND. kt == nit000 ) .OR. ln_bt_fw ) THEN    !** Euler time-stepping: no filter 
     291# else 
     292      IF ( neuler == 0 .AND. kt == nit000 ) THEN   !** Euler time-stepping at first time-step : no filter 
     293#endif 
     294         sshb(:,:) = sshn(:,:)                           ! before <-- now 
     295         sshn(:,:) = ssha(:,:)                           ! now    <-- after  (before already = now) 
     296      ELSE                                         !** Leap-Frog time-stepping: Asselin filter + swap 
     297         sshb(:,:) = sshn(:,:) + atfp * ( sshb(:,:) - 2 * sshn(:,:) + ssha(:,:) )     ! before <-- now filtered 
     298         IF( lk_vvl ) sshb(:,:) = sshb(:,:) - atfp * rdt / rau0 * ( emp_b(:,:) - emp(:,:) ) * tmask(:,:,1) 
     299         sshn(:,:) = ssha(:,:)                           ! now <-- after 
    350300      ENDIF 
    351301      ! 
    … …  
    357307      IF(ln_ctl)   CALL prt_ctl( tab2d_1=sshb, clinfo1=' sshb  - : ', mask1=tmask, ovlap=1 ) 
    358308      ! 
    359       IF( nn_timing == 1 )  CALL timing_stop('ssh_nxt') 
    360       ! 
    361    END SUBROUTINE ssh_nxt 
     309      IF( nn_timing == 1 )  CALL timing_stop('ssh_swp') 
     310      ! 
     311   END SUBROUTINE ssh_swp 
    362312 
    363313   !!====================================================================== 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/IOM/iom.F90

    r4245 r4292  
    136136 
    137137      ! vertical grid definition 
    138       CALL iom_set_axis_attr( "deptht", gdept_0 ) 
    139       CALL iom_set_axis_attr( "depthu", gdept_0 ) 
    140       CALL iom_set_axis_attr( "depthv", gdept_0 ) 
    141       CALL iom_set_axis_attr( "depthw", gdepw_0 ) 
     138      CALL iom_set_axis_attr( "deptht", gdept_1d ) 
     139      CALL iom_set_axis_attr( "depthu", gdept_1d ) 
     140      CALL iom_set_axis_attr( "depthv", gdept_1d ) 
     141      CALL iom_set_axis_attr( "depthw", gdepw_1d ) 
    142142# if defined key_floats 
    143143      CALL iom_set_axis_attr( "nfloat", (/ (REAL(ji,wp), ji=1,nfloat) /) ) 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/IOM/iom_ioipsl.F90

    r4245 r4292  
    408408               CALL flioputv( ioipslid, 'nav_lon'     , glamt(ix1:ix2, iy1:iy2) ) 
    409409               CALL flioputv( ioipslid, 'nav_lat'     , gphit(ix1:ix2, iy1:iy2) ) 
    410                CALL flioputv( ioipslid, 'nav_lev'     , gdept_0 ) 
     410               CALL flioputv( ioipslid, 'nav_lev'     , gdept_1d ) 
    411411               ! +++ WRONG VALUE: to be improved but not really useful... 
    412412               CALL flioputv( ioipslid, 'time_counter', kt ) 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/IOM/iom_nf90.F90

    r4245 r4292  
    532532               CALL iom_nf90_check(NF90_PUT_VAR( if90id, idmy, gphit(ix1:ix2, iy1:iy2) ), clinfo) 
    533533               CALL iom_nf90_check(NF90_INQ_VARID( if90id, 'nav_lev'     , idmy ), clinfo) 
    534                CALL iom_nf90_check(NF90_PUT_VAR( if90id, idmy, gdept_0                 ), clinfo) 
     534               CALL iom_nf90_check(NF90_PUT_VAR( if90id, idmy, gdept_1d                ), clinfo) 
    535535               ! +++ WRONG VALUE: to be improved but not really useful... 
    536536               CALL iom_nf90_check(NF90_INQ_VARID( if90id, 'time_counter', idmy ), clinfo) 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/IOM/restart.F90

    r4206 r4292  
    2323   USE eosbn2          ! equation of state            (eos bn2 routine) 
    2424   USE trdmld_oce      ! ocean active mixed layer tracers trends variables 
    25    USE domvvl          ! variable volume 
    2625   USE divcur          ! hor. divergence and curl      (div & cur routines) 
    2726   USE sbc_ice, ONLY : lk_lim3 
    … …  
    3029   PRIVATE 
    3130 
    32    PUBLIC   rst_opn    ! routine called by step module 
    33    PUBLIC   rst_write  ! routine called by step module 
    34    PUBLIC   rst_read   ! routine called by opa  module 
     31   PUBLIC   rst_opn         ! routine called by step module 
     32   PUBLIC   rst_write       ! routine called by step module 
     33   PUBLIC   rst_read        ! routine called by istate module 
     34   PUBLIC   rst_read_open   ! routine called in rst_read and (possibly) in dom_vvl_init 
    3535 
    3636   !! * Substitutions 
    … …  
    120120                     CALL iom_rstput( kt, nitrst, numrow, 'hdivb'  , hdivb     ) 
    121121                     CALL iom_rstput( kt, nitrst, numrow, 'sshb'   , sshb      ) 
    122       IF( lk_vvl )   CALL iom_rstput( kt, nitrst, numrow, 'fse3t_b', fse3t_b(:,:,:) ) 
    123122                     ! 
    124123                     CALL iom_rstput( kt, nitrst, numrow, 'un'     , un        )     ! now fields 
    … …  
    144143   END SUBROUTINE rst_write 
    145144 
     145   SUBROUTINE rst_read_open 
     146      !!----------------------------------------------------------------------  
     147      !!                   ***  ROUTINE rst_read_open  *** 
     148      !!  
     149      !! ** Purpose :   Open read files for restart (format fixed by jprstlib ) 
     150      !!  
     151      !! ** Method  :   Use a non-zero, positive value of numror to assess whether or not 
     152      !!                the file has already been opened 
     153      !!---------------------------------------------------------------------- 
     154      INTEGER  ::   jlibalt = jprstlib 
     155      LOGICAL  ::   llok 
     156      !!---------------------------------------------------------------------- 
     157 
     158      IF( numror .LE. 0 ) THEN 
     159         IF(lwp) THEN                                             ! Contol prints 
     160            WRITE(numout,*) 
     161            SELECT CASE ( jprstlib ) 
     162            CASE ( jpnf90    )   ;   WRITE(numout,*) 'rst_read : read oce NetCDF restart file' 
     163            CASE ( jprstdimg )   ;   WRITE(numout,*) 'rst_read : read oce binary restart file' 
     164            END SELECT 
     165            IF ( snc4set%luse )      WRITE(numout,*) 'rst_read : configured with NetCDF4 support' 
     166            WRITE(numout,*) '~~~~~~~~' 
     167         ENDIF 
     168 
     169         IF ( jprstlib == jprstdimg ) THEN 
     170           ! eventually read netcdf file (monobloc)  for restarting on different number of processors 
     171           ! if {cn_ocerst_in}.nc exists, then set jlibalt to jpnf90 
     172           INQUIRE( FILE = TRIM(cn_ocerst_in)//'.nc', EXIST = llok ) 
     173           IF ( llok ) THEN ; jlibalt = jpnf90  ; ELSE ; jlibalt = jprstlib ; ENDIF 
     174         ENDIF 
     175         CALL iom_open( cn_ocerst_in, numror, kiolib = jlibalt ) 
     176      ENDIF 
     177   END SUBROUTINE rst_read_open 
    146178 
    147179   SUBROUTINE rst_read 
    … …  
    154186      !!---------------------------------------------------------------------- 
    155187      REAL(wp) ::   zrdt, zrdttra1 
    156       INTEGER  ::   jk, jlibalt = jprstlib 
     188      INTEGER  ::   jk 
    157189      LOGICAL  ::   llok 
    158190      !!---------------------------------------------------------------------- 
    159191 
    160       IF(lwp) THEN                                             ! Contol prints 
    161          WRITE(numout,*) 
    162          SELECT CASE ( jprstlib ) 
    163          CASE ( jpnf90    )   ;   WRITE(numout,*) 'rst_read : read oce NetCDF restart file ',TRIM(cn_ocerst_in)//'.nc' 
    164          CASE ( jprstdimg )   ;   WRITE(numout,*) 'rst_read : read oce binary restart file' 
    165          END SELECT 
    166          IF ( snc4set%luse )      WRITE(numout,*) 'rst_read : configured with NetCDF4 support' 
    167          WRITE(numout,*) '~~~~~~~~' 
    168       ENDIF 
    169  
    170       IF ( jprstlib == jprstdimg ) THEN 
    171         ! eventually read netcdf file (monobloc)  for restarting on different number of processors 
    172         ! if {cn_ocerst_in}.nc exists, then set jlibalt to jpnf90 
    173         INQUIRE( FILE = TRIM(cn_ocerst_in)//'.nc', EXIST = llok ) 
    174         IF ( llok ) THEN ; jlibalt = jpnf90  ; ELSE ; jlibalt = jprstlib ; ENDIF 
    175       ENDIF 
    176       CALL iom_open( cn_ocerst_in, numror, kiolib = jlibalt ) 
     192      CALL rst_read_open           ! open restart for reading (if not already opened) 
    177193 
    178194      ! Check dynamics and tracer time-step consistency and force Euler restart if changed 
    … …  
    194210         CALL iom_get( numror, jpdom_autoglo, 'hdivb'  , hdivb   ) 
    195211         CALL iom_get( numror, jpdom_autoglo, 'sshb'   , sshb    ) 
    196          IF( lk_vvl )   CALL iom_get( numror, jpdom_autoglo, 'fse3t_b', fse3t_b(:,:,:) ) 
    197212      ELSE 
    198213         neuler = 0 
    … …  
    230245         hdivb(:,:,:)   = hdivn(:,:,:) 
    231246         sshb (:,:)     = sshn (:,:) 
    232          IF( lk_vvl ) THEN 
    233             DO jk = 1, jpk 
    234                fse3t_b(:,:,jk) = fse3t_n(:,:,jk) 
    235             END DO 
    236          ENDIF 
    237247      ENDIF 
    238248      ! 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/LDF/ldfdyn.F90

    r4147 r4292  
    191191      !!---------------------------------------------------------------------- 
    192192 
    193       zm00 = TANH( ( pdam - gdept_0(1    ) ) / pwam ) 
    194       zm01 = TANH( ( pdam - gdept_0(jpkm1) ) / pwam ) 
     193      zm00 = TANH( ( pdam - gdept_1d(1    ) ) / pwam ) 
     194      zm01 = TANH( ( pdam - gdept_1d(jpkm1) ) / pwam ) 
    195195      zmhs = zm00 / zm01 
    196196      zmhb = ( 1.e0 - pbot ) / ( 1.e0 - zmhs ) / zm01 
    … …  
    232232      !!---------------------------------------------------------------------- 
    233233 
    234       zm00 = TANH( ( pdam - gdept_0(1    ) ) / pwam ) 
    235       zm01 = TANH( ( pdam - gdept_0(jpkm1) ) / pwam ) 
     234      zm00 = TANH( ( pdam - gdept_1d(1    ) ) / pwam ) 
     235      zm01 = TANH( ( pdam - gdept_1d(jpkm1) ) / pwam ) 
    236236      zmhs = zm00 / zm01 
    237237      zmhb = ( 1.e0 - pbot ) / ( 1.e0 - zmhs ) / zm01 
    … …  
    274274      !!---------------------------------------------------------------------- 
    275275 
    276       zm00 = TANH( ( pdam - gdept_0(1    ) ) / pwam )    
    277       zm01 = TANH( ( pdam - gdept_0(jpkm1) ) / pwam ) 
     276      zm00 = TANH( ( pdam - gdept_1d(1    ) ) / pwam )    
     277      zm01 = TANH( ( pdam - gdept_1d(jpkm1) ) / pwam ) 
    278278      zmhs = zm00 / zm01 
    279279      zmhb = ( 1.e0 - pbot ) / ( 1.e0 - zmhs ) / zm01 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/LDF/ldfdyn_c3d.h90

    r3294 r4292  
    386386 
    387387      DO jk=1, jpk 
    388          zcoef(jk) = 1.0_wp + NINT(9.0_wp*(gdept_0(jk)-800.0_wp)/(3000.0_wp-800.0_wp)) 
     388         zcoef(jk) = 1.0_wp + NINT(9.0_wp*(gdept_1d(jk)-800.0_wp)/(3000.0_wp-800.0_wp)) 
    389389         zcoef(jk) = MIN(10.0_wp, MAX(1.0_wp, zcoef(jk))) 
    390390         IF(lwp) WRITE(numout,'(4x,i3,6x,f7.3)') jk,zcoef(jk) 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/OBS/diaobs.F90

    r4245 r4292  
    976976      USE dom_oce, ONLY : &             ! Ocean space and time domain variables 
    977977         & rdt,           &                        
    978          & gdept_0,       &              
     978         & gdept_1d,       &              
    979979         & tmask, umask, vmask                             
    980980      USE phycst, ONLY : &              ! Physical constants 
    … …  
    10381038                  &              kstp, jpi, jpj, jpk, nit000, idaystp,   & 
    10391039                  &              tsn(:,:,:,jp_tem), tsn(:,:,:,jp_sal),   & 
    1040                   &              gdept_0, tmask, n1dint, n2dint,         & 
     1040                  &              gdept_1d, tmask, n1dint, n2dint,        & 
    10411041                  &              kdailyavtypes = endailyavtypes ) 
    10421042            ELSE 
    … …  
    10441044                  &              kstp, jpi, jpj, jpk, nit000, idaystp,   & 
    10451045                  &              tsn(:,:,:,jp_tem), tsn(:,:,:,jp_sal),   & 
    1046                   &              gdept_0, tmask, n1dint, n2dint               ) 
     1046                  &              gdept_1d, tmask, n1dint, n2dint              ) 
    10471047            ENDIF 
    10481048         END DO 
    … …  
    10881088           ! zonal component of velocity 
    10891089           CALL obs_vel_opt( veldatqc(jveloset), kstp, jpi, jpj, jpk, & 
    1090               &              nit000, idaystp, un, vn, gdept_0, umask, vmask, & 
     1090              &              nit000, idaystp, un, vn, gdept_1d, umask, vmask, & 
    10911091                             n1dint, n2dint, ld_velav(jveloset) ) 
    10921092         END DO 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/OBS/obs_prep.F90

    r2715 r4292  
    7575         & glamt,   & 
    7676         & gphit,   & 
    77          & gdept_0, & 
     77         & gdept_1d,& 
    7878         & tmask,   & 
    7979         & nproc 
    … …  
    193193         &                 profdata%var(1)%vdep,                        & 
    194194         &                 glamt,                 gphit,                & 
    195          &                 gdept_0,               tmask,                & 
     195         &                 gdept_1d,              tmask,                & 
    196196         &                 profdata%nqc,          profdata%var(1)%nvqc, & 
    197197         &                 iosdtobs,              ilantobs,             & 
    … …  
    213213         &                 profdata%var(2)%vdep,                        & 
    214214         &                 glamt,                 gphit,                & 
    215          &                 gdept_0,               tmask,                & 
     215         &                 gdept_1d,              tmask,                & 
    216216         &                 profdata%nqc,          profdata%var(2)%nvqc, & 
    217217         &                 iosdsobs,              ilansobs,             & 
    … …  
    916916         & glamt, glamu, glamv,    & 
    917917         & gphit, gphiu, gphiv,    & 
    918          & gdept_0, & 
     918         & gdept_1d,            & 
    919919         & tmask, umask, vmask,  & 
    920920         & nproc 
    … …  
    10321032         &                 profdata%var(1)%vdep,                        & 
    10331033         &                 glamu,                 gphiu,                & 
    1034          &                 gdept_0,               umask,                & 
     1034         &                 gdept_1d,              umask,                & 
    10351035         &                 profdata%nqc,          profdata%var(1)%nvqc, & 
    10361036         &                 iosduobs,              ilanuobs,             & 
    … …  
    10521052         &                 profdata%var(2)%vdep,                        & 
    10531053         &                 glamv,                 gphiv,                & 
    1054          &                 gdept_0,               vmask,                & 
     1054         &                 gdept_1d,              vmask,                & 
    10551055         &                 profdata%nqc,          profdata%var(2)%nvqc, & 
    10561056         &                 iosdvobs,              ilanvobs,             & 
    … …  
    17091709      !! * Modules used 
    17101710      USE dom_oce, ONLY : &       ! Geographical information 
    1711          & gdepw_0                         
     1711         & gdepw_1d                         
    17121712 
    17131713      !! * Arguments 
    … …  
    18261826               &  .OR. ( pobsphi(jobs) >   90.         )       & 
    18271827               &  .OR. ( pobsdep(jobsp) < 0.0          )       & 
    1828                &  .OR. ( pobsdep(jobsp) > gdepw_0(kpk) ) ) THEN 
     1828               &  .OR. ( pobsdep(jobsp) > gdepw_1d(kpk)) ) THEN 
    18291829               kobsqc(jobsp) = kobsqc(jobsp) + 11 
    18301830               kosdobs = kosdobs + 1 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/OBS/obs_read_prof.F90

    r2715 r4292  
    793793      !----------------------------------------------------------------------- 
    794794      IF ( ldt3d ) THEN 
    795          CALL obs_level_search( jpk, gdept_0, & 
     795         CALL obs_level_search( jpk, gdept_1d, & 
    796796            & profdata%nvprot(1), profdata%var(1)%vdep, & 
    797797            & profdata%var(1)%mvk ) 
    798798      ENDIF 
    799799      IF ( lds3d ) THEN 
    800          CALL obs_level_search( jpk, gdept_0, & 
     800         CALL obs_level_search( jpk, gdept_1d, & 
    801801            & profdata%nvprot(2), profdata%var(2)%vdep, & 
    802802            & profdata%var(2)%mvk ) 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/OBS/obs_read_vel.F90

    r2715 r4292  
    614614      ! Model level search 
    615615      !----------------------------------------------------------------------- 
    616       CALL obs_level_search( jpk, gdept_0, & 
     616      CALL obs_level_search( jpk, gdept_1d,          & 
    617617         & profdata%nvprot(1), profdata%var(1)%vdep, & 
    618618         & profdata%var(1)%mvk ) 
    619       CALL obs_level_search( jpk, gdept_0, & 
     619      CALL obs_level_search( jpk, gdept_1d,          & 
    620620         & profdata%nvprot(2), profdata%var(2)%vdep, & 
    621621         & profdata%var(2)%mvk ) 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/SBC/sbc_oce.F90

    r4230 r4292  
    100100   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sss_m     !: mean (nn_fsbc time-step) surface sea salinity            [psu] 
    101101   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ssh_m     !: mean (nn_fsbc time-step) sea surface height                [m] 
     102   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   e3t_m     !: mean (nn_fsbc time-step) sea surface height                [m] 
    102103 
    103104   !! * Substitutions 
    … …  
    114115      !!                  ***  FUNCTION sbc_oce_alloc  *** 
    115116      !!--------------------------------------------------------------------- 
    116       INTEGER :: ierr(4) 
     117      INTEGER :: ierr(5) 
    117118      !!--------------------------------------------------------------------- 
    118119      ierr(:) = 0 
    … …  
    135136         &      ssu_m  (jpi,jpj) , sst_m(jpi,jpj) ,                       & 
    136137         &      ssv_m  (jpi,jpj) , sss_m  (jpi,jpj), ssh_m(jpi,jpj) , STAT=ierr(4) ) 
     138         ! 
     139#if defined key_vvl 
     140      ALLOCATE( e3t_m(jpi,jpj) , STAT=ierr(5) ) 
     141#endif 
    137142         ! 
    138143      sbc_oce_alloc = MAXVAL( ierr ) 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_cice.F90

    r4230 r4292  
    412412! Freezing/melting potential 
    413413! Calculated over NEMO leapfrog timestep (hence 2*dt) 
    414       nfrzmlt(:,:)=rau0*rcp*fse3t_m(:,:,1)*(Tocnfrz-sst_m(:,:))/(2.0*dt) 
     414      nfrzmlt(:,:)=rau0*rcp*fse3t_m(:,:)*(Tocnfrz-sst_m(:,:))/(2.0*dt) 
    415415 
    416416      ztmp(:,:) = nfrzmlt(:,:) 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/SBC/sbcrnf.F90

    r4147 r4292  
    388388         IF( rn_hrnf > 0._wp ) THEN 
    389389            nkrnf = 2 
    390             DO WHILE( nkrnf /= jpkm1 .AND. gdepw_0(nkrnf+1) < rn_hrnf )   ;   nkrnf = nkrnf + 1   ;   END DO 
     390            DO WHILE( nkrnf /= jpkm1 .AND. gdepw_1d(nkrnf+1) < rn_hrnf )   ;   nkrnf = nkrnf + 1   ;   END DO 
    391391            IF( ln_sco )   CALL ctl_warn( 'sbc_rnf: number of levels over which Kz is increased is computed for zco...' ) 
    392392         ENDIF 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/SBC/sbcssm.F90

    r3680 r4292  
    2626   PUBLIC   sbc_ssm         ! routine called by step.F90 
    2727   PUBLIC   sbc_ssm_init    ! routine called by sbcmod.F90 
    28     
     28 
    2929   LOGICAL, SAVE  ::   l_ssm_mean = .FALSE.       ! keep track of whether means have been read 
    3030                                                  ! from restart file 
    31  
     31    
    3232   !! * Substitutions 
    3333#  include "domzgr_substitute.h90" 
    … …  
    6767         ELSE                    ;   ssh_m(:,:) = sshn(:,:) 
    6868         ENDIF 
    69  
     69         ! 
     70         IF( lk_vvl )   fse3t_m(:,:) = fse3t_n(:,:,1) 
    7071         ! 
    7172      ELSE 
    … …  
    8485            ELSE                    ;   ssh_m(:,:) = zcoef *   sshn(:,:) 
    8586            ENDIF 
     87            IF( lk_vvl )   fse3t_m(:,:) = zcoef * fse3t_n(:,:,1) 
    8688            !                                             ! ---------------------------------------- ! 
    8789         ELSEIF( MOD( kt - 2 , nn_fsbc ) == 0 ) THEN      !   Initialisation: New mean computation   ! 
    … …  
    9294            sss_m(:,:) = 0.e0 
    9395            ssh_m(:,:) = 0.e0 
     96            IF( lk_vvl )   fse3t_m(:,:) = 0.e0 
    9497         ENDIF 
    9598         !                                                ! ---------------------------------------- ! 
    … …  
    104107         ELSE                    ;   ssh_m(:,:) = ssh_m(:,:) + sshn(:,:) 
    105108         ENDIF 
     109         IF( lk_vvl )   fse3t_m(:,:) = fse3t_m(:,:) + fse3t_n(:,:,1) 
    106110 
    107111         !                                                ! ---------------------------------------- ! 
    … …  
    114118            ssv_m(:,:) = ssv_m(:,:) * zcoef           ! 
    115119            ssh_m(:,:) = ssh_m(:,:) * zcoef           ! mean SSH             [m] 
     120            IF( lk_vvl )   fse3t_m(:,:) = fse3t_m(:,:) * zcoef   ! mean vertical scale factor [m] 
    116121            ! 
    117122         ENDIF 
    … …  
    130135            CALL iom_rstput( kt, nitrst, numrow, 'sss_m'  , sss_m  ) 
    131136            CALL iom_rstput( kt, nitrst, numrow, 'ssh_m'  , ssh_m  ) 
     137            IF( lk_vvl ) THEN 
     138               CALL iom_rstput( kt, nitrst, numrow, 'fse3t_m'  , fse3t_m(:,:)  ) 
     139            END IF 
    132140            ! 
    133141         ENDIF 
    … …  
    168176            CALL iom_get( numror, jpdom_autoglo, 'sss_m'  , sss_m  )   !   "         "    salinity    (T-point) 
    169177            CALL iom_get( numror, jpdom_autoglo, 'ssh_m'  , ssh_m  )   !   "         "    height      (T-point) 
     178            IF( lk_vvl ) CALL iom_get( numror, jpdom_autoglo, 'fse3t_m', fse3t_m(:,:) ) 
    170179            ! 
    171180            IF( zf_sbc /= REAL( nn_fsbc, wp ) ) THEN      ! nn_fsbc has changed between 2 runs 
    … …  
    178187               sss_m(:,:) = zcoef * sss_m(:,:) 
    179188               ssh_m(:,:) = zcoef * ssh_m(:,:) 
     189               IF( lk_vvl ) fse3t_m(:,:) = zcoef * fse3t_m(:,:) 
    180190            ELSE 
    181191               IF(lwp) WRITE(numout,*) '~~~~~~~   mean fields read in the ocean restart file' 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/SBC/sbctide.F90

    r3651 r4292  
    11MODULE sbctide 
    2   !!================================================================================= 
    3   !!                       ***  MODULE  sbctide  *** 
    4   !! Initialization of tidal forcing 
    5   !! History :  9.0  !  07  (O. Le Galloudec)  Original code 
    6   !!================================================================================= 
    7   !! * Modules used 
    8   USE oce             ! ocean dynamics and tracers variables 
    9   USE dom_oce         ! ocean space and time domain 
    10   USE in_out_manager  ! I/O units 
    11   USE ioipsl          ! NetCDF IPSL library 
    12   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    13   USE phycst 
    14   USE daymod 
    15   USE dynspg_oce 
    16   USE tideini 
    17   USE iom 
     2   !!====================================================================== 
     3   !!                       ***  MODULE  sbctide  *** 
     4   !! Initialization of tidal forcing 
     5   !!====================================================================== 
     6   !! History :  9.0  !  2007  (O. Le Galloudec)  Original code 
     7   !!---------------------------------------------------------------------- 
     8   USE oce             ! ocean dynamics and tracers variables 
     9   USE dom_oce         ! ocean space and time domain 
     10   USE phycst 
     11   USE daymod 
     12   USE dynspg_oce 
     13   USE tideini 
     14   ! 
     15   USE iom 
     16   USE in_out_manager  ! I/O units 
     17   USE ioipsl          ! NetCDF IPSL library 
     18   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    1819 
    19   IMPLICIT NONE 
    20   PUBLIC 
     20   IMPLICIT NONE 
     21   PUBLIC 
    2122 
    22   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: pot_astro 
     23   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) ::   pot_astro   ! 
    2324 
    2425#if defined key_tide 
     26   !!---------------------------------------------------------------------- 
     27   !!   'key_tide' :                                        tidal potential 
     28   !!---------------------------------------------------------------------- 
     29   !!   sbc_tide            :  
     30   !!   tide_init_potential : 
     31   !!---------------------------------------------------------------------- 
    2532 
    26   LOGICAL, PUBLIC, PARAMETER ::   lk_tide  = .TRUE. 
    27   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: amp_pot,phi_pot 
    28   !!--------------------------------------------------------------------------------- 
    29   !!   OPA 9.0 , LODYC-IPSL  (2003) 
    30   !!--------------------------------------------------------------------------------- 
     33   LOGICAL, PUBLIC, PARAMETER ::   lk_tide  = .TRUE. 
     34   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   amp_pot, phi_pot 
    3135 
     36   !!---------------------------------------------------------------------- 
     37   !! NEMO/OPA 3.5 , NEMO Consortium (2013) 
     38   !! $Id: $ 
     39   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
     40   !!---------------------------------------------------------------------- 
    3241CONTAINS 
    3342 
    34   SUBROUTINE sbc_tide ( kt ) 
    35     !!---------------------------------------------------------------------- 
    36     !!                 ***  ROUTINE sbc_tide  *** 
    37     !!----------------------------------------------------------------------       
    38     !! * Arguments 
    39     INTEGER, INTENT( in ) ::   kt     ! ocean time-step 
    40     !!---------------------------------------------------------------------- 
     43   SUBROUTINE sbc_tide( kt ) 
     44      !!---------------------------------------------------------------------- 
     45      !!                 ***  ROUTINE sbc_tide  *** 
     46      !!----------------------------------------------------------------------       
     47      INTEGER, INTENT( in ) ::   kt     ! ocean time-step 
     48      INTEGER               ::   jk     ! dummy loop index 
     49      !!---------------------------------------------------------------------- 
    4150 
    42     IF ( kt == nit000 .AND. .NOT. lk_dynspg_ts )  CALL ctl_stop( 'STOP', 'sbc_tide : tidal potential use only with time splitting' ) 
    43  
    44     IF ( nsec_day == NINT(0.5 * rdttra(1)) ) THEN 
     51      IF( nsec_day == NINT(0.5_wp * rdttra(1)) ) THEN      ! start a new day 
     52         ! 
     53         IF( kt == nit000 ) THEN 
     54            ALLOCATE( amp_pot(jpi,jpj,nb_harmo),                      & 
     55               &      phi_pot(jpi,jpj,nb_harmo), pot_astro(jpi,jpj)   ) 
     56         ENDIF 
     57         ! 
     58         amp_pot(:,:,:) = 0._wp 
     59         phi_pot(:,:,:) = 0._wp 
     60         pot_astro(:,:) = 0._wp 
     61         ! 
     62         CALL tide_harmo( omega_tide, v0tide, utide, ftide, ntide, nb_harmo ) 
     63         ! 
     64         kt_tide = kt 
     65         ! 
     66         IF(lwp) THEN 
     67            WRITE(numout,*) 
     68            WRITE(numout,*) 'sbc_tide : Update of the components and (re)Init. the potential at kt=', kt 
     69            WRITE(numout,*) '~~~~~~~~ ' 
     70            DO jk = 1, nb_harmo 
     71               WRITE(numout,*) Wave(ntide(jk))%cname_tide, utide(jk), ftide(jk), v0tide(jk), omega_tide(jk) 
     72            END DO 
     73         ENDIF 
     74         ! 
     75         IF( ln_tide_pot )   CALL tide_init_potential 
     76         ! 
     77      ENDIF 
    4578      ! 
    46       kt_tide = kt 
    47  
    48       IF(lwp) THEN 
    49          WRITE(numout,*) 
    50          WRITE(numout,*) 'sbc_tide : (re)Initialization of the tidal potential at kt=',kt 
    51          WRITE(numout,*) '~~~~~~~ ' 
    52       ENDIF 
    53  
    54       IF(lwp) THEN 
    55          IF ( kt == nit000 ) WRITE(numout,*) 'Apply astronomical potential : ln_tide_pot =', ln_tide_pot 
    56          CALL flush(numout) 
    57       ENDIF 
    58  
    59       IF ( kt == nit000 ) ALLOCATE(amp_pot(jpi,jpj,nb_harmo)) 
    60       IF ( kt == nit000 ) ALLOCATE(phi_pot(jpi,jpj,nb_harmo)) 
    61       IF ( kt == nit000 ) ALLOCATE(pot_astro(jpi,jpj)) 
    62  
    63       amp_pot(:,:,:) = 0.e0 
    64       phi_pot(:,:,:) = 0.e0 
    65       pot_astro(:,:) = 0.e0 
    66  
    67       IF ( ln_tide_pot ) CALL tide_init_potential 
    68       ! 
    69     ENDIF 
    70  
    71   END SUBROUTINE sbc_tide 
    72  
    73   SUBROUTINE tide_init_potential 
    74     !!---------------------------------------------------------------------- 
    75     !!                 ***  ROUTINE tide_init_potential  *** 
    76     !!---------------------------------------------------------------------- 
    77     !! * Local declarations 
    78     INTEGER  :: ji,jj,jk 
    79     REAL(wp) :: zcons,ztmp1,ztmp2,zlat,zlon 
     79   END SUBROUTINE sbc_tide 
    8080 
    8181 
    82     DO jk=1,nb_harmo 
    83        zcons=0.7*Wave(ntide(jk))%equitide*ftide(jk) 
    84        do ji=1,jpi 
    85           do jj=1,jpj 
    86              ztmp1 = amp_pot(ji,jj,jk)*COS(phi_pot(ji,jj,jk)) 
    87              ztmp2 = -amp_pot(ji,jj,jk)*SIN(phi_pot(ji,jj,jk)) 
    88              zlat = gphit(ji,jj)*rad !! latitude en radian 
    89              zlon = glamt(ji,jj)*rad !! longitude en radian 
    90              ! le potentiel est composé des effets des astres: 
    91              IF (Wave(ntide(jk))%nutide .EQ.1) THEN 
    92                 ztmp1= ztmp1 + zcons*(SIN(2.*zlat))*COS(v0tide(jk)+utide(jk)+Wave(ntide(jk))%nutide*zlon) 
    93                 ztmp2= ztmp2 - zcons*(SIN(2.*zlat))*SIN(v0tide(jk)+utide(jk)+Wave(ntide(jk))%nutide*zlon) 
    94              ENDIF 
    95              IF (Wave(ntide(jk))%nutide.EQ.2) THEN 
    96                 ztmp1= ztmp1 + zcons*(COS(zlat)**2)*COS(v0tide(jk)+utide(jk)+Wave(ntide(jk))%nutide*zlon) 
    97                 ztmp2= ztmp2 - zcons*(COS(zlat)**2)*SIN(v0tide(jk)+utide(jk)+Wave(ntide(jk))%nutide*zlon) 
    98              ENDIF 
    99              amp_pot(ji,jj,jk)=SQRT(ztmp1**2+ztmp2**2) 
    100              phi_pot(ji,jj,jk)=ATAN2(-ztmp2/MAX(1.E-10,SQRT(ztmp1**2+ztmp2**2)),ztmp1/MAX(1.E-10,SQRT(ztmp1**2+ztmp2**2))) 
    101           enddo 
    102        enddo 
    103     END DO 
     82   SUBROUTINE tide_init_potential 
     83      !!---------------------------------------------------------------------- 
     84      !!                 ***  ROUTINE tide_init_potential  *** 
     85      !!---------------------------------------------------------------------- 
     86      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
     87      REAL(wp) ::   zcons, ztmp1, ztmp2, zlat, zlon, ztmp, zamp, zcs   ! local scalar 
     88      !!---------------------------------------------------------------------- 
    10489 
    105   END SUBROUTINE tide_init_potential 
     90      DO jk = 1, nb_harmo 
     91         zcons = 0.7_wp * Wave(ntide(jk))%equitide * ftide(jk) 
     92         DO ji = 1, jpi 
     93            DO jj = 1, jpj 
     94               ztmp1 =  amp_pot(ji,jj,jk) * COS( phi_pot(ji,jj,jk) ) 
     95               ztmp2 = -amp_pot(ji,jj,jk) * SIN( phi_pot(ji,jj,jk) ) 
     96               zlat = gphit(ji,jj)*rad !! latitude en radian 
     97               zlon = glamt(ji,jj)*rad !! longitude en radian 
     98               ztmp = v0tide(jk) + utide(jk) + Wave(ntide(jk))%nutide * zlon 
     99               ! le potentiel est composé des effets des astres: 
     100               IF    ( Wave(ntide(jk))%nutide == 1 )  THEN  ;  zcs = zcons * SIN( 2._wp*zlat ) 
     101               ELSEIF( Wave(ntide(jk))%nutide == 2 )  THEN  ;  zcs = zcons * COS( zlat )**2 
     102               ELSE                                         ;  zcs = 0._wp 
     103               ENDIF 
     104               ztmp1 = ztmp1 + zcs * COS( ztmp ) 
     105               ztmp2 = ztmp2 - zcs * SIN( ztmp ) 
     106               zamp = SQRT( ztmp1*ztmp1 + ztmp2*ztmp2 ) 
     107               amp_pot(ji,jj,jk) = zamp 
     108               phi_pot(ji,jj,jk) = ATAN2( -ztmp2 / MAX( 1.e-10_wp , zamp ) ,   & 
     109                  &                        ztmp1 / MAX( 1.e-10_wp,  zamp )   ) 
     110            END DO 
     111         END DO 
     112      END DO 
     113      ! 
     114   END SUBROUTINE tide_init_potential 
    106115 
    107116#else 
    … …  
    116125  END SUBROUTINE sbc_tide 
    117126#endif 
     127 
    118128  !!====================================================================== 
    119  
    120129END MODULE sbctide 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/SBC/sbcwave.F90

    r4230 r4292  
    151151             DO jj = 1, jpj-1 
    152152                DO ji = 1, jpi-1 
    153                    usd3d(ji,jj,jk) = usd2d(ji,jj)*exp(2.0*uwavenum(ji,jj)*(-MIN( gdept(ji,jj,jk) , gdept(ji+1,jj  ,jk)))) 
    154                    vsd3d(ji,jj,jk) = vsd2d(ji,jj)*exp(2.0*vwavenum(ji,jj)*(-MIN( gdept(ji,jj,jk) , gdept(ji  ,jj+1,jk)))) 
     153                   usd3d(ji,jj,jk) = usd2d(ji,jj)*exp(2.0*uwavenum(ji,jj)*(-MIN( gdept_0(ji,jj,jk) , gdept_0(ji+1,jj  ,jk)))) 
     154                   vsd3d(ji,jj,jk) = vsd2d(ji,jj)*exp(2.0*vwavenum(ji,jj)*(-MIN( gdept_0(ji,jj,jk) , gdept_0(ji  ,jj+1,jk)))) 
    155155                END DO 
    156156             END DO 
    157              usd3d(jpi,:,jk) = usd2d(jpi,:)*exp( 2.0*uwavenum(jpi,:)*(-gdept(jpi,:,jk)) ) 
    158              vsd3d(:,jpj,jk) = vsd2d(:,jpj)*exp( 2.0*vwavenum(:,jpj)*(-gdept(:,jpj,jk)) ) 
     157             usd3d(jpi,:,jk) = usd2d(jpi,:)*exp( 2.0*uwavenum(jpi,:)*(-gdept_0(jpi,:,jk)) ) 
     158             vsd3d(:,jpj,jk) = vsd2d(:,jpj)*exp( 2.0*vwavenum(:,jpj)*(-gdept_0(:,jpj,jk)) ) 
    159159          END DO 
    160160 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/SBC/tide.h90

    r3294 r4292  
    1 !! History :  9.0  !  07  (O. Le Galloudec)  Original code 
     1   !!---------------------------------------------------------------------- 
     2   !! History :  3.2  !  2007  (O. Le Galloudec)  Original code 
     3   !!---------------------------------------------------------------------- 
    24 
    3 ! Wave(1)= tide(name_tide,equitide,nutide,nt,ns,nh,np,np1,shift,nksi,nnu0,nnu1,nnu2,R,formula) 
    4   
    5    
    6   Wave(1)= tide('M2'     ,0.242297,2     ,2 ,-2,2 ,0 ,0  ,0    ,2   ,-2   ,0  ,0   ,0,78) 
    7   Wave(2)= tide('N2'     ,0.046313,2     ,2 ,-3,2 ,1 ,0  ,0    ,2   ,-2   ,0  ,0   ,0,78) 
    8   Wave(3)= tide('2N2'    ,0.006184,2     ,2 ,-4,2 ,2 ,0  ,0    ,2   ,-2   ,0  ,0   ,0,78) 
    9   Wave(4)= tide('S2'     ,0.113572,2     ,2 , 0,0 ,0 ,0  ,0    ,0   , 0   ,0  ,0   ,0,0) 
    10   Wave(5)= tide('K2'     ,0.030875,2     ,2 , 0,2 ,0 ,0  ,0    ,0   , 0   ,0  ,-2  ,0,235) 
    11  
    12   Wave(6)= tide('K1'     ,0.142408,1     ,1 , 0,1 ,0 ,0  ,-90  ,0   , 0   ,-1 ,0   ,0,227) 
    13   Wave(7)= tide('O1'     ,0.101266,1     ,1 ,-2,1 ,0 ,0  ,+90  ,2   ,-1   , 0 ,0   ,0,75) 
    14   Wave(8)= tide('Q1'     ,0.019387,1     ,1 ,-3,1 ,1 ,0  ,+90  ,2   ,-1   , 0 ,0   ,0,75) 
    15   Wave(9)= tide('P1'     ,0.047129,1     ,1 , 0,-1,0 ,0  ,+90  ,0   , 0   , 0 ,0   ,0,0)   
    16  
    17   Wave(10)= tide('M4'    ,0.000000,4     ,4 ,-4, 4,0 ,0  ,0    ,4   , -4  , 0 ,0   ,0,1) 
    18  
    19   Wave(11) = tide('Mf'   ,0.042017,0     ,0 , 2, 0,0 ,0  ,0    ,-2  , 0   , 0 ,0   ,0,74) 
    20   Wave(12) = tide('Mm'   ,0.022191,0     ,0 , 1,0 ,-1,0  ,0    ,0   , 0   , 0 ,0   ,0,73) 
    21   Wave(13) = tide('Msqm' ,0.000667,0     ,0 , 4,-2, 0,0  ,0    ,-2  , 0   , 0 ,0   ,0,74) 
    22   Wave(14) = tide('Mtm'  ,0.008049,0     ,0 , 3, 0,-1,0  ,0    ,-2  , 0   , 0 ,0   ,0,74) 
    23  
    24   Wave(15) = tide('S1'   ,0.000000,1     ,1,  0, 0, 0,0  ,0    , 0  , 0   , 0 ,0   ,0,0)    
    25   Wave(16) = tide('MU2'  ,0.005841,2     ,2, -4, 4, 0,0  ,0    ,2   ,-2   , 0, 0   ,0,78) 
    26   Wave(17) = tide('NU2'  ,0.009094,2     ,2, -3, 4,-1,0  ,0    ,2   ,-2   , 0, 0   ,0,78)  
    27   Wave(18) = tide('L2'   ,0.006694,2     ,2, -1, 2,-1,0  ,+180 ,2   ,-2   , 0, 0   ,0,215) 
    28   Wave(19) = tide('T2'   ,0.006614,2     ,2,  0,-1, 0,1  ,0    ,0   , 0   , 0, 0   ,0,0) 
     5   !             !! name_tide , equitide , nutide , nt , ns , nh , np , np1 , shift , nksi , nnu0 , nnu1 , nnu2 , R , formula !! 
     6   !             !!           !          !        !    !    !    !    !     !       !      !      !      !      !   !         !! 
     7   Wave( 1) = tide(  'M2'     , 0.242297 ,    2   ,  2 , -2 ,  2 ,  0 ,  0  ,    0  ,  2   , -2   ,  0   ,  0   , 0 ,    78   ) 
     8   Wave( 2) = tide(  'N2'     , 0.046313 ,    2   ,  2 , -3 ,  2 ,  1 ,  0  ,    0  ,  2   , -2   ,  0   ,  0   , 0 ,    78   ) 
     9   Wave( 3) = tide( '2N2'     , 0.006184 ,    2   ,  2 , -4 ,  2 ,  2 ,  0  ,    0  ,  2   , -2   ,  0   ,  0   , 0 ,    78   ) 
     10   Wave( 4) = tide(  'S2'     , 0.113572 ,    2   ,  2 ,  0 ,  0 ,  0 ,  0  ,    0  ,  0   ,  0   ,  0   ,  0   , 0 ,     0   ) 
     11   Wave( 5) = tide(  'K2'     , 0.030875 ,    2   ,  2 ,  0 ,  2 ,  0 ,  0  ,    0  ,  0   ,  0   ,  0   , -2   , 0 ,   235   ) 
     12   !              !           !          !        !    !    !    !    !     !       !      !      !      !      !   !         ! 
     13   Wave( 6) = tide(  'K1'     , 0.142408 ,    1   ,  1 ,  0 ,  1 ,  0 ,  0  ,  -90  ,  0   ,  0   , -1   ,  0   , 0 ,   227   ) 
     14   Wave( 7) = tide(  'O1'     , 0.101266 ,    1   ,  1 , -2 ,  1 ,  0 ,  0  ,  +90  ,  2   , -1   ,  0   ,  0   , 0 ,    75   ) 
     15   Wave( 8) = tide(  'Q1'     , 0.019387 ,    1   ,  1 , -3 ,  1 ,  1 ,  0  ,  +90  ,  2   , -1   ,  0   ,  0   , 0 ,    75   ) 
     16   Wave( 9) = tide(  'P1'     , 0.047129 ,    1   ,  1 ,  0 , -1 ,  0 ,  0  ,  +90  ,  0   ,  0   ,  0   ,  0   , 0 ,    0    ) 
     17   !              !           !          !        !    !    !    !    !     !       !      !      !      !      !   !         ! 
     18   Wave(10) = tide(  'M4'     , 0.000000 ,    4   ,  4 , -4 ,  4 ,  0 ,  0  ,    0  ,  4   , -4   ,  0   ,  0   , 0 ,    1    ) 
     19   !              !           !          !        !    !    !    !    !     !       !      !      !      !      !   !         ! 
     20   Wave(11) = tide(  'Mf'     , 0.042017 ,    0   ,  0 ,  2 ,  0 ,  0 ,  0  ,    0  , -2   ,  0   ,  0   ,  0   , 0 ,   74    ) 
     21   Wave(12) = tide(  'Mm'     , 0.022191 ,    0   ,  0 ,  1 ,  0 , -1 ,  0  ,    0  ,  0   ,  0   ,  0   ,  0   , 0 ,   73    ) 
     22   Wave(13) = tide(  'Msqm'   , 0.000667 ,    0   ,  0 ,  4 , -2 ,  0 ,  0  ,    0  , -2   ,  0   ,  0   ,  0   , 0 ,   74    ) 
     23   Wave(14) = tide(  'Mtm'    , 0.008049 ,    0   ,  0 ,  3 ,  0 , -1 ,  0  ,    0  , -2   ,  0   ,  0   ,  0   , 0 ,   74    ) 
     24   !              !           !          !        !    !    !    !    !     !       !      !      !      !      !   !         ! 
     25   Wave(15) = tide(  'S1'     , 0.000000 ,    1   ,  1 ,  0 ,  0 ,  0 ,  0  ,    0  ,  0   ,  0   ,  0   ,  0   , 0 ,    0    )    
     26   Wave(16) = tide(  'MU2'    , 0.005841 ,    2   ,  2 , -4 ,  4 ,  0 ,  0  ,    0  ,  2   , -2   ,  0   ,  0   , 0 ,   78    ) 
     27   Wave(17) = tide(  'NU2'    , 0.009094 ,    2   ,  2 , -3 ,  4 , -1 ,  0  ,    0  ,  2   , -2   ,  0   ,  0   , 0 ,   78    )  
     28   Wave(18) = tide(  'L2'     , 0.006694 ,    2   ,  2 , -1 ,  2 , -1 ,  0  , +180  ,  2   , -2   ,  0   ,  0   , 0 ,  215    ) 
     29   Wave(19) = tide(  'T2'     , 0.006614 ,    2   ,  2 ,  0 , -1 ,  0 ,  1  ,    0  ,  0   ,  0   ,  0   ,  0   , 0 ,    0    ) 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/SBC/tide_mod.F90

    r3670 r4292  
    11MODULE tide_mod 
    2   !!================================================================================= 
    3   !!                       ***  MODULE  tide_mod  *** 
    4   !! Compute nodal modulations corrections and pulsations 
    5   !!================================================================================= 
    6   !!--------------------------------------------------------------------------------- 
    7   !!   OPA 9.0 , LODYC-IPSL  (2003) 
    8   !!--------------------------------------------------------------------------------- 
    9   USE dom_oce         ! ocean space and time domain 
    10   USE phycst 
    11   USE daymod 
    12  
    13   IMPLICIT NONE 
    14   PRIVATE 
    15  
    16   REAL(wp) :: sh_T, sh_s, sh_h, sh_p, sh_p1, & 
    17        sh_xi, sh_nu, sh_nuprim, sh_nusec, sh_R, & 
    18        sh_I, sh_x1ra, sh_N 
    19  
    20   INTEGER,PUBLIC, PARAMETER ::   & 
    21        jpmax_harmo = 19             ! maximum number of harmonic 
    22  
    23   TYPE, PUBLIC ::    tide 
    24      CHARACTER(LEN=4)  :: cname_tide 
    25      REAL(wp) :: equitide 
    26      INTEGER  :: nutide 
    27      INTEGER  ::  nt,ns,nh,np,np1,shift 
    28      INTEGER  ::  nksi,nnu0,nnu1,nnu2,R 
    29      INTEGER  :: nformula 
    30   END TYPE tide 
    31  
    32   TYPE(tide), PUBLIC, DIMENSION(jpmax_harmo) :: Wave 
    33  
    34   !! * Accessibility 
    35   PUBLIC tide_harmo 
    36   PUBLIC nodal_factort 
    37   PUBLIC tide_init_Wave 
    38  
     2   !!====================================================================== 
     3   !!                       ***  MODULE  tide_mod  *** 
     4   !! Compute nodal modulations corrections and pulsations 
     5   !!====================================================================== 
     6   !! History :  1.0  !  2007  (O. Le Galloudec)  Original code 
     7   !!---------------------------------------------------------------------- 
     8   USE dom_oce        ! ocean space and time domain 
     9   USE phycst         ! physical constant 
     10   USE daymod         ! calendar 
     11 
     12   IMPLICIT NONE 
     13   PRIVATE 
     14 
     15   PUBLIC   tide_harmo       ! called by tideini and diaharm modules 
     16   PUBLIC   tide_init_Wave   ! called by tideini and diaharm modules 
     17 
     18   INTEGER, PUBLIC, PARAMETER ::   jpmax_harmo = 19   !: maximum number of harmonic 
     19 
     20   TYPE, PUBLIC ::    tide 
     21      CHARACTER(LEN=4) ::   cname_tide 
     22      REAL(wp)         ::   equitide 
     23      INTEGER          ::   nutide 
     24      INTEGER          ::   nt, ns, nh, np, np1, shift 
     25      INTEGER          ::   nksi, nnu0, nnu1, nnu2, R 
     26      INTEGER          ::   nformula 
     27   END TYPE tide 
     28 
     29   TYPE(tide), PUBLIC, DIMENSION(jpmax_harmo) ::   Wave   !: 
     30 
     31   REAL(wp) ::   sh_T, sh_s, sh_h, sh_p, sh_p1             ! astronomic angles 
     32   REAL(wp) ::   sh_xi, sh_nu, sh_nuprim, sh_nusec, sh_R   ! 
     33   REAL(wp) ::   sh_I, sh_x1ra, sh_N                       ! 
     34 
     35   !!---------------------------------------------------------------------- 
     36   !! NEMO/OPA 3.3 , LOCEAN-IPSL (2010)  
     37   !! $Id:$  
     38   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 
     39   !!---------------------------------------------------------------------- 
    3940CONTAINS 
    4041 
    41   SUBROUTINE tide_init_Wave 
    42  
    43 #  include "tide.h90" 
    44  
    45   END SUBROUTINE tide_init_Wave 
    46  
    47   SUBROUTINE tide_harmo( pomega, pvt, put , pcor, ktide ,kc) 
    48  
    49     INTEGER, DIMENSION(kc), INTENT( in ) ::   & 
    50          ktide      ! Indice of tidal constituents 
    51  
    52     INTEGER, INTENT( in ) :: & 
    53          kc         ! Total number of tidal constituents 
    54  
    55     REAL (wp), DIMENSION(kc), INTENT( out ) ::   & 
    56          pomega      ! pulsation in radians/s 
    57  
    58     REAL (wp), DIMENSION(kc), INTENT( out ) ::   & 
    59          pvt, &      ! 
    60          put, &      ! 
    61          pcor         ! 
    62  
    63     CALL astronomic_angle 
    64     CALL tide_pulse(pomega, ktide ,kc) 
    65     CALL tide_vuf( pvt, put, pcor, ktide ,kc) 
    66  
    67   END SUBROUTINE tide_harmo 
    68  
    69   SUBROUTINE astronomic_angle 
    70  
    71     !!---------------------------------------------------------------------- 
    72     !! 
    73     !!  tj is time elapsed since 1st January 1900, 0 hour, counted in julian 
    74     !!  century (e.g. time in days divide by 36525) 
    75     !!---------------------------------------------------------------------- 
    76  
    77     REAL(wp) ::  cosI,p,q,t2,t4,sin2I,s2,tgI2,P1,sh_tgn2,at1,at2 
    78     REAL(wp) :: zqy,zsy,zday,zdj,zhfrac 
    79  
    80     zqy=AINT((nyear-1901.)/4.) 
    81     zsy=nyear-1900. 
    82  
    83     zdj=dayjul(nyear,nmonth,nday) 
    84     zday=zdj+zqy-1. 
    85  
    86     zhfrac=nsec_day/3600. 
    87  
    88     !---------------------------------------------------------------------- 
    89     !  Sh_n Longitude of ascending lunar node 
    90     !---------------------------------------------------------------------- 
    91  
    92     sh_N=(259.1560564-19.328185764*zsy-.0529539336*zday-.0022064139*zhfrac)*rad 
    93     !---------------------------------------------------------------------- 
    94     ! T mean solar angle (Greenwhich time) 
    95     !---------------------------------------------------------------------- 
    96     sh_T=(180.+zhfrac*(360./24.))*rad 
    97     !---------------------------------------------------------------------- 
    98     ! h mean solar Longitude 
    99     !---------------------------------------------------------------------- 
    100  
    101     sh_h=(280.1895014-.238724988*zsy+.9856473288*zday+.0410686387*zhfrac)*rad 
    102     !---------------------------------------------------------------------- 
    103     ! s mean lunar Longitude 
    104     !---------------------------------------------------------------------- 
    105  
    106     sh_s=(277.0256206+129.38482032*zsy+13.176396768*zday+.549016532*zhfrac)*rad 
    107     !---------------------------------------------------------------------- 
    108     ! p1 Longitude of solar perigee 
    109     !---------------------------------------------------------------------- 
    110  
    111     sh_p1=(281.2208569+.01717836*zsy+.000047064*zday+.000001961*zhfrac)*rad 
    112     !---------------------------------------------------------------------- 
    113     ! p Longitude of lunar perigee 
    114     !---------------------------------------------------------------------- 
    115  
    116     sh_p=(334.3837214+40.66246584*zsy+.111404016*zday+.004641834*zhfrac)*rad 
    117  
    118     sh_N =mod(sh_N ,2*rpi) 
    119     sh_s =mod(sh_s ,2*rpi) 
    120     sh_h =mod(sh_h, 2*rpi) 
    121     sh_p =mod(sh_p, 2*rpi) 
    122     sh_p1=mod(sh_p1,2*rpi) 
    123  
    124     cosI=0.913694997 -0.035692561 *cos(sh_N) 
    125  
    126     sh_I=acos(cosI) 
    127  
    128     sin2I=sin(sh_I) 
    129     sh_tgn2=tan(sh_N/2.0) 
    130  
    131     at1=atan(1.01883*sh_tgn2) 
    132     at2=atan(0.64412*sh_tgn2) 
    133  
    134     sh_xi=-at1-at2+sh_N 
    135  
    136     if (sh_N > rpi) sh_xi=sh_xi-2.0*rpi 
    137  
    138     sh_nu=at1-at2 
    139  
    140     !---------------------------------------------------------------------- 
    141     ! For constituents l2 k1 k2 
    142     !---------------------------------------------------------------------- 
    143  
    144     tgI2=tan(sh_I/2.0) 
    145     P1=sh_p-sh_xi 
    146  
    147     t2=tgI2*tgI2 
    148     t4=t2*t2 
    149     sh_x1ra=sqrt(1.0-12.0*t2*cos(2.0*P1)+36.0*t4) 
    150  
    151     p=sin(2.0*P1) 
    152     q=1.0/(6.0*t2)-cos(2.0*P1) 
    153     sh_R=atan(p/q) 
    154  
    155     p=sin(2.0*sh_I)*sin(sh_nu) 
    156     q=sin(2.0*sh_I)*cos(sh_nu)+0.3347 
    157     sh_nuprim=atan(p/q) 
    158  
    159     s2=sin(sh_I)*sin(sh_I) 
    160     p=s2*sin(2.0*sh_nu) 
    161     q=s2*cos(2.0*sh_nu)+0.0727 
    162     sh_nusec=0.5*atan(p/q) 
    163  
    164   END SUBROUTINE astronomic_angle 
    165  
    166   SUBROUTINE tide_pulse( pomega, ktide ,kc) 
    167     !!---------------------------------------------------------------------- 
    168     !!                     ***  ROUTINE tide_pulse  *** 
    169     !!                       
    170     !! ** Purpose : Compute tidal frequencies 
    171     !! 
    172     !!---------------------------------------------------------------------- 
    173     !! * Arguments 
    174     INTEGER, DIMENSION(kc), INTENT( in ) ::   & 
    175          ktide      ! Indice of tidal constituents 
    176  
    177     INTEGER, INTENT( in ) :: & 
    178          kc         ! Total number of tidal constituents 
    179  
    180     REAL (wp), DIMENSION(kc), INTENT( out ) ::   & 
    181          pomega      ! pulsation in radians/s 
    182  
    183     !! * Local declarations 
    184     INTEGER :: jh 
    185     REAL(wp) :: zscale  =  36525*24.0 
    186     REAL(wp) :: zomega_T=  13149000.0 
    187     REAL(wp) :: zomega_s=    481267.892 
    188     REAL(wp) :: zomega_h=     36000.76892 
    189     REAL(wp) :: zomega_p=      4069.0322056 
    190     REAL(wp) :: zomega_n=      1934.1423972 
    191     REAL(wp) :: zomega_p1=        1.719175 
    192     !!---------------------------------------------------------------------- 
    193  
    194     DO jh=1,kc 
    195        pomega(jh) = zomega_T * Wave(ktide(jh))%nT & 
    196             + zomega_s * Wave(ktide(jh))%ns & 
    197             + zomega_h * Wave(ktide(jh))%nh & 
    198             + zomega_p * Wave(ktide(jh))%np & 
    199             + zomega_p1* Wave(ktide(jh))%np1 
    200        pomega(jh) = (pomega(jh)/zscale)*rad/3600. 
    201     END DO 
    202  
    203   END SUBROUTINE tide_pulse 
    204  
    205   SUBROUTINE tide_vuf( pvt, put, pcor, ktide ,kc) 
    206     !!---------------------------------------------------------------------- 
    207     !!                     ***  ROUTINE tide_vuf  *** 
    208     !!                       
    209     !! ** Purpose : Compute nodal modulation corrections 
    210     !! 
    211     !! ** Outputs : 
    212     !!          vt: Pase of tidal potential relative to Greenwich (radians) 
    213     !!          ut: Phase correction u due to nodal motion (radians) 
    214     !!          ft: Nodal correction factor 
    215     !! 
    216     !! ** Inputs : 
    217     !!          tname: array of constituents names (dimension<=nc)  
    218     !!             nc: number of constituents 
    219     !!    
    220     !!---------------------------------------------------------------------- 
    221     !! * Arguments 
    222     INTEGER, DIMENSION(kc), INTENT( in ) ::   & 
    223          ktide      ! Indice of tidal constituents 
    224     INTEGER, INTENT( in ) :: & 
    225          kc         ! Total number of tidal constituents 
    226     REAL (wp), DIMENSION(kc), INTENT( out ) ::   & 
    227          pvt, &      ! 
    228          put, &      ! 
    229          pcor         ! 
    230     !! * Local declarations 
    231     INTEGER :: jh 
    232     !!---------------------------------------------------------------------- 
    233  
    234     DO jh =1,kc 
    235        !  Phase of the tidal potential relative to the Greenwhich  
    236        !  meridian (e.g. the position of the fictuous celestial body). Units are 
    237        !  radian: 
    238        pvt(jh) = sh_T *Wave(ktide(jh))%nT        & 
    239             +sh_s *Wave(ktide(jh))%ns        & 
    240             +sh_h *Wave(ktide(jh))%nh        & 
    241             +sh_p *Wave(ktide(jh))%np        & 
    242             +sh_p1*Wave(ktide(jh))%np1       & 
    243             +Wave(ktide(jh))%shift*rad 
     42   SUBROUTINE tide_init_Wave 
     43#     include "tide.h90" 
     44   END SUBROUTINE tide_init_Wave 
     45 
     46 
     47   SUBROUTINE tide_harmo( pomega, pvt, put , pcor, ktide ,kc) 
     48      !!---------------------------------------------------------------------- 
     49      !!---------------------------------------------------------------------- 
     50      INTEGER , DIMENSION(kc), INTENT(in ) ::   ktide            ! Indice of tidal constituents 
     51      INTEGER                , INTENT(in ) ::   kc               ! Total number of tidal constituents 
     52      REAL(wp), DIMENSION(kc), INTENT(out) ::   pomega           ! pulsation in radians/s 
     53      REAL(wp), DIMENSION(kc), INTENT(out) ::   pvt, put, pcor   ! 
     54      !!---------------------------------------------------------------------- 
     55      ! 
     56      CALL astronomic_angle 
     57      CALL tide_pulse( pomega, ktide ,kc ) 
     58      CALL tide_vuf  ( pvt, put, pcor, ktide ,kc ) 
     59      ! 
     60   END SUBROUTINE tide_harmo 
     61 
     62 
     63   SUBROUTINE astronomic_angle 
     64      !!---------------------------------------------------------------------- 
     65      !!  tj is time elapsed since 1st January 1900, 0 hour, counted in julian 
     66      !!  century (e.g. time in days divide by 36525) 
     67      !!---------------------------------------------------------------------- 
     68      REAL(wp) ::   cosI, p, q, t2, t4, sin2I, s2, tgI2, P1, sh_tgn2, at1, at2 
     69      REAL(wp) ::   zqy , zsy, zday, zdj, zhfrac 
     70      !!---------------------------------------------------------------------- 
     71      ! 
     72      zqy = AINT( (nyear-1901.)/4. ) 
     73      zsy = nyear - 1900. 
     74      ! 
     75      zdj  = dayjul( nyear, nmonth, nday ) 
     76      zday = zdj + zqy - 1. 
     77      ! 
     78      zhfrac = nsec_day / 3600. 
     79      ! 
     80      !---------------------------------------------------------------------- 
     81      !  Sh_n Longitude of ascending lunar node 
     82      !---------------------------------------------------------------------- 
     83      sh_N=(259.1560564-19.328185764*zsy-.0529539336*zday-.0022064139*zhfrac)*rad 
     84      !---------------------------------------------------------------------- 
     85      ! T mean solar angle (Greenwhich time) 
     86      !---------------------------------------------------------------------- 
     87      sh_T=(180.+zhfrac*(360./24.))*rad 
     88      !---------------------------------------------------------------------- 
     89      ! h mean solar Longitude 
     90      !---------------------------------------------------------------------- 
     91      sh_h=(280.1895014-.238724988*zsy+.9856473288*zday+.0410686387*zhfrac)*rad 
     92      !---------------------------------------------------------------------- 
     93      ! s mean lunar Longitude 
     94      !---------------------------------------------------------------------- 
     95      sh_s=(277.0256206+129.38482032*zsy+13.176396768*zday+.549016532*zhfrac)*rad 
     96      !---------------------------------------------------------------------- 
     97      ! p1 Longitude of solar perigee 
     98      !---------------------------------------------------------------------- 
     99      sh_p1=(281.2208569+.01717836*zsy+.000047064*zday+.000001961*zhfrac)*rad 
     100      !---------------------------------------------------------------------- 
     101      ! p Longitude of lunar perigee 
     102      !---------------------------------------------------------------------- 
     103      sh_p=(334.3837214+40.66246584*zsy+.111404016*zday+.004641834*zhfrac)*rad 
     104 
     105      sh_N = MOD( sh_N ,2*rpi ) 
     106      sh_s = MOD( sh_s ,2*rpi ) 
     107      sh_h = MOD( sh_h, 2*rpi ) 
     108      sh_p = MOD( sh_p, 2*rpi ) 
     109      sh_p1= MOD( sh_p1,2*rpi ) 
     110 
     111      cosI = 0.913694997 -0.035692561 *cos(sh_N) 
     112 
     113      sh_I = ACOS( cosI ) 
     114 
     115      sin2I   = sin(sh_I) 
     116      sh_tgn2 = tan(sh_N/2.0) 
     117 
     118      at1=atan(1.01883*sh_tgn2) 
     119      at2=atan(0.64412*sh_tgn2) 
     120 
     121      sh_xi=-at1-at2+sh_N 
     122 
     123      IF( sh_N > rpi )   sh_xi=sh_xi-2.0*rpi 
     124 
     125      sh_nu = at1 - at2 
     126 
     127      !---------------------------------------------------------------------- 
     128      ! For constituents l2 k1 k2 
     129      !---------------------------------------------------------------------- 
     130 
     131      tgI2 = tan(sh_I/2.0) 
     132      P1   = sh_p-sh_xi 
     133 
     134      t2 = tgI2*tgI2 
     135      t4 = t2*t2 
     136      sh_x1ra = sqrt( 1.0-12.0*t2*cos(2.0*P1)+36.0*t4 ) 
     137 
     138      p = sin(2.0*P1) 
     139      q = 1.0/(6.0*t2)-cos(2.0*P1) 
     140      sh_R = atan(p/q) 
     141 
     142      p = sin(2.0*sh_I)*sin(sh_nu) 
     143      q = sin(2.0*sh_I)*cos(sh_nu)+0.3347 
     144      sh_nuprim = atan(p/q) 
     145 
     146      s2 = sin(sh_I)*sin(sh_I) 
     147      p  = s2*sin(2.0*sh_nu) 
     148      q  = s2*cos(2.0*sh_nu)+0.0727 
     149      sh_nusec = 0.5*atan(p/q) 
     150      ! 
     151   END SUBROUTINE astronomic_angle 
     152 
     153 
     154   SUBROUTINE tide_pulse( pomega, ktide ,kc ) 
     155      !!---------------------------------------------------------------------- 
     156      !!                     ***  ROUTINE tide_pulse  *** 
     157      !!                       
     158      !! ** Purpose : Compute tidal frequencies 
     159      !!---------------------------------------------------------------------- 
     160      INTEGER                , INTENT(in ) ::   kc       ! Total number of tidal constituents 
     161      INTEGER , DIMENSION(kc), INTENT(in ) ::   ktide    ! Indice of tidal constituents 
     162      REAL(wp), DIMENSION(kc), INTENT(out) ::   pomega   ! pulsation in radians/s 
     163      ! 
     164      INTEGER  ::   jh 
     165      REAL(wp) ::   zscale 
     166      REAL(wp) ::   zomega_T =  13149000.0_wp 
     167      REAL(wp) ::   zomega_s =    481267.892_wp 
     168      REAL(wp) ::   zomega_h =     36000.76892_wp 
     169      REAL(wp) ::   zomega_p =      4069.0322056_wp 
     170      REAL(wp) ::   zomega_n =      1934.1423972_wp 
     171      REAL(wp) ::   zomega_p1=         1.719175_wp 
     172      !!---------------------------------------------------------------------- 
     173      ! 
     174      zscale =  rad / ( 36525._wp * 86400._wp )  
     175      ! 
     176      DO jh = 1, kc 
     177         pomega(jh) = (  zomega_T * Wave( ktide(jh) )%nT   & 
     178            &          + zomega_s * Wave( ktide(jh) )%ns   & 
     179            &          + zomega_h * Wave( ktide(jh) )%nh   & 
     180            &          + zomega_p * Wave( ktide(jh) )%np   & 
     181            &          + zomega_p1* Wave( ktide(jh) )%np1  ) * zscale 
     182      END DO 
     183      ! 
     184   END SUBROUTINE tide_pulse 
     185 
     186 
     187   SUBROUTINE tide_vuf( pvt, put, pcor, ktide ,kc ) 
     188      !!---------------------------------------------------------------------- 
     189      !!                     ***  ROUTINE tide_vuf  *** 
     190      !!                       
     191      !! ** Purpose : Compute nodal modulation corrections 
     192      !! 
     193      !! ** Outputs : vt: Phase of tidal potential relative to Greenwich (radians) 
     194      !!              ut: Phase correction u due to nodal motion (radians) 
     195      !!              ft: Nodal correction factor 
     196      !!---------------------------------------------------------------------- 
     197      INTEGER                , INTENT(in ) ::   kc               ! Total number of tidal constituents 
     198      INTEGER , DIMENSION(kc), INTENT(in ) ::   ktide            ! Indice of tidal constituents 
     199      REAL(wp), DIMENSION(kc), INTENT(out) ::   pvt, put, pcor   ! 
     200      ! 
     201      INTEGER ::   jh   ! dummy loop index 
     202      !!---------------------------------------------------------------------- 
     203      ! 
     204      DO jh = 1, kc 
     205         !  Phase of the tidal potential relative to the Greenwhich  
     206         !  meridian (e.g. the position of the fictuous celestial body). Units are radian: 
     207         pvt(jh) = sh_T * Wave( ktide(jh) )%nT    & 
     208            &    + sh_s * Wave( ktide(jh) )%ns    & 
     209            &    + sh_h * Wave( ktide(jh) )%nh    & 
     210            &    + sh_p * Wave( ktide(jh) )%np    & 
     211            &    + sh_p1* Wave( ktide(jh) )%np1   & 
     212            &    +        Wave( ktide(jh) )%shift * rad 
     213         ! 
     214         !  Phase correction u due to nodal motion. Units are radian: 
     215         put(jh) = sh_xi     * Wave( ktide(jh) )%nksi   & 
     216            &    + sh_nu     * Wave( ktide(jh) )%nnu0   & 
     217            &    + sh_nuprim * Wave( ktide(jh) )%nnu1   & 
     218            &    + sh_nusec  * Wave( ktide(jh) )%nnu2   & 
     219            &    + sh_R      * Wave( ktide(jh) )%R 
     220 
     221         !  Nodal correction factor: 
     222         pcor(jh) = nodal_factort( Wave( ktide(jh) )%nformula ) 
     223      END DO 
     224      ! 
     225   END SUBROUTINE tide_vuf 
     226 
     227 
     228   RECURSIVE FUNCTION nodal_factort( kformula ) RESULT( zf ) 
     229      !!---------------------------------------------------------------------- 
     230      !!---------------------------------------------------------------------- 
     231      INTEGER, INTENT(in) :: kformula 
     232      ! 
     233      REAL(wp) :: zf 
     234      REAL(wp) :: zs, zf1, zf2 
     235      !!---------------------------------------------------------------------- 
     236      ! 
     237      SELECT CASE( kformula ) 
     238      ! 
     239      CASE( 0 )                  !==  formule 0, solar waves 
     240         zf = 1.0 
     241         ! 
     242      CASE( 1 )                  !==  formule 1, compound waves (78 x 78) 
     243         zf=nodal_factort(78) 
     244         zf = zf * zf 
     245         ! 
     246      CASE ( 2 )                 !==  formule 2, compound waves (78 x 0)  ===  (78)  
     247       zf1= nodal_factort(78) 
     248       zf = nodal_factort( 0) 
     249       zf = zf1 * zf 
    244250       ! 
    245        !  Phase correction u due to nodal motion. Units are radian: 
    246        put(jh) = sh_xi    *Wave(ktide(jh))%nksi  & 
    247             +sh_nu    *Wave(ktide(jh))%nnu0  & 
    248             +sh_nuprim*Wave(ktide(jh))%nnu1  & 
    249             +sh_nusec *Wave(ktide(jh))%nnu2  & 
    250             +sh_R     *Wave(ktide(jh))%R 
    251  
    252        !  Nodal correction factor: 
    253        pcor(jh) = nodal_factort(Wave(ktide(jh))%nformula) 
    254     END DO 
    255  
    256   END SUBROUTINE tide_vuf 
    257  
    258   recursive function nodal_factort(kformula) result (zf) 
    259     !!---------------------------------------------------------------------- 
    260     INTEGER, INTENT(IN) :: kformula 
    261     REAL(wp) :: zf 
    262     REAL(wp) :: zs,zf1,zf2 
    263  
    264     SELECT CASE (kformula) 
    265  
    266        !!  formule 0, solar waves 
    267  
    268     case ( 0 ) 
    269        zf=1.0 
    270  
    271        !! formule 1, compound waves (78 x 78) 
    272  
    273     case ( 1 ) 
    274        zf=nodal_factort(78) 
    275        zf=zf*zf 
    276  
    277        !! formule 2, compound waves (78 x 0)  ===  (78)  
    278  
    279     case ( 2 ) 
    280        zf1=nodal_factort(78) 
    281        zf=nodal_factort(0) 
    282        zf=zf1*zf 
    283  
    284        !! formule 4,  compound waves (78 x 235)  
    285  
    286     case ( 4 ) 
    287        zf1=nodal_factort(78) 
    288        zf=nodal_factort(235) 
    289        zf=zf1*zf 
    290  
    291        !! formule 5,  compound waves (78 *78 x 235) 
    292  
    293     case ( 5 ) 
    294        zf1=nodal_factort(78) 
    295        zf=nodal_factort(235) 
    296        zf=zf*zf1*zf1 
    297  
    298        !! formule 6,  compound waves (78 *78 x 0) 
    299  
    300     case ( 6 ) 
    301        zf1=nodal_factort(78) 
    302        zf=nodal_factort(0) 
    303        zf=zf*zf1*zf1  
    304  
    305        !! formule 7, compound waves (75 x 75) 
    306  
    307     case ( 7 ) 
    308        zf=nodal_factort(75) 
    309        zf=zf*zf 
    310  
    311        !! formule 8,  compound waves (78 x 0 x 235) 
    312  
    313     case ( 8 ) 
    314        zf=nodal_factort(78) 
    315        zf1=nodal_factort(0) 
    316        zf2=nodal_factort(235) 
    317        zf=zf*zf1*zf2 
    318  
    319        !! formule 9,  compound waves (78 x 0 x 227) 
    320  
    321     case ( 9 ) 
    322        zf=nodal_factort(78) 
    323        zf1=nodal_factort(0) 
    324        zf2=nodal_factort(227) 
    325        zf=zf*zf1*zf2 
    326  
    327        !! formule 10,  compound waves (78 x 227) 
    328  
    329     case ( 10 ) 
    330        zf=nodal_factort(78) 
    331        zf1=nodal_factort(227) 
    332        zf=zf*zf1 
    333  
    334        !! formule 11,  compound waves (75 x 0) 
    335  
    336     case ( 11 ) 
    337        zf=nodal_factort(75) 
    338        zf=nodal_factort(0) 
    339        zf=zf*zf1 
    340  
    341        !! formule 12,  compound waves (78 x 78 x 78 x 0)  
    342  
    343     case ( 12 ) 
    344        zf1=nodal_factort(78) 
    345        zf=nodal_factort(0) 
    346        zf=zf*zf1*zf1*zf1 
    347  
    348        !! formule 13, compound waves (78 x 75) 
    349  
    350     case ( 13 ) 
    351        zf1=nodal_factort(78) 
    352        zf=nodal_factort(75) 
    353        zf=zf*zf1 
    354  
    355        !! formule 14, compound waves (235 x 0)  ===  (235) 
    356  
    357     case ( 14 ) 
    358        zf=nodal_factort(235) 
    359        zf1=nodal_factort(0) 
    360        zf=zf*zf1 
    361  
    362        !! formule 15, compound waves (235 x 75)  
    363  
    364     case ( 15 ) 
    365        zf=nodal_factort(235) 
    366        zf1=nodal_factort(75) 
    367        zf=zf*zf1 
    368  
    369        !! formule 16, compound waves (78 x 0 x 0)  ===  (78) 
    370  
    371     case ( 16 ) 
    372        zf=nodal_factort(78) 
    373        zf1=nodal_factort(0) 
    374        zf=zf*zf1*zf1 
    375  
    376        !! formule 17,  compound waves (227 x 0)  
    377  
    378     case ( 17 ) 
    379        zf1=nodal_factort(227) 
    380        zf=nodal_factort(0) 
    381        zf=zf*zf1 
    382  
    383        !! formule 18,  compound waves (78 x 78 x 78 ) 
    384  
    385     case ( 18 )  
    386        zf1=nodal_factort(78) 
    387        zf=zf1*zf1*zf1 
    388  
    389        !! formule 19, compound waves (78 x 0 x 0 x 0)  ===  (78) 
    390  
    391     case ( 19 ) 
    392        zf=nodal_factort(78) 
    393        zf1=nodal_factort(0) 
    394        zf=zf*zf1*zf1 
    395  
    396        !! formule 73 
    397  
    398     case ( 73 ) 
    399        zs=sin(sh_I) 
    400        zf=(2./3.-zs*zs)/0.5021 
    401  
    402        !! formule 74 
    403  
    404     case ( 74 ) 
    405        zs=sin(sh_I) 
    406        zf=zs*zs/0.1578 
    407  
    408        !! formule 75 
    409  
    410     case ( 75 ) 
    411        zs=cos (sh_I/2) 
    412        zf=sin (sh_I)*zs*zs/0.3800 
    413  
    414        !! formule 76 
    415  
    416     case ( 76 ) 
    417        zf=sin (2*sh_I)/0.7214 
    418  
    419        !! formule 77 
    420  
    421     case ( 77 ) 
    422        zs=sin (sh_I/2) 
    423        zf=sin (sh_I)*zs*zs/0.0164 
    424  
    425        !! formule 78 
    426  
    427     case ( 78 ) 
    428        zs=cos (sh_I/2) 
    429        zf=zs*zs*zs*zs/0.9154 
    430  
    431        !! formule 79 
    432  
    433     case ( 79 ) 
    434        zs=sin(sh_I) 
    435        zf=zs*zs/0.1565 
    436  
    437        !! formule 144 
    438  
    439     case ( 144 ) 
    440        zs=sin (sh_I/2) 
    441        zf=(1-10*zs*zs+15*zs*zs*zs*zs)*cos(sh_I/2)/0.5873 
    442  
    443        !! formule 149 
    444  
    445     case ( 149 ) 
    446        zs=cos (sh_I/2) 
    447        zf=zs*zs*zs*zs*zs*zs/0.8758 
    448  
    449        !! formule 215 
    450  
    451     case ( 215 ) 
    452        zs=cos (sh_I/2) 
    453        zf=zs*zs*zs*zs/0.9154*sh_x1ra 
    454  
    455        !! formule 227  
    456  
    457     case ( 227 ) 
    458        zs=sin (2*sh_I) 
    459        zf=sqrt (0.8965*zs*zs+0.6001*zs*cos (sh_nu)+0.1006) 
    460  
    461        !! formule 235  
    462  
    463     case ( 235 ) 
    464        zs=sin (sh_I) 
    465        zf=sqrt (19.0444*zs*zs*zs*zs+2.7702*zs*zs*cos (2*sh_nu)+.0981) 
    466  
    467     END SELECT 
    468  
    469   end function nodal_factort 
    470  
    471   function dayjul(kyr,kmonth,kday) 
    472     ! 
    473     !*** THIS ROUTINE COMPUTES THE JULIAN DAY (AS A REAL VARIABLE) 
    474     ! 
    475     INTEGER,INTENT(IN) :: kyr,kmonth,kday 
    476     INTEGER,DIMENSION(12) ::  idayt,idays 
    477     INTEGER :: inc,ji 
    478     REAL(wp) :: dayjul,zyq 
    479  
    480     DATA idayt/0.,31.,59.,90.,120.,151.,181.,212.,243.,273.,304.,334./ 
    481     idays(1)=0. 
    482     idays(2)=31. 
    483     inc=0. 
    484     zyq=MOD((kyr-1900.),4.) 
    485     IF(zyq .eq. 0.) inc=1. 
    486     DO ji=3,12 
    487        idays(ji)=idayt(ji)+inc 
    488     END DO 
    489     dayjul=idays(kmonth)+kday 
    490  
    491   END FUNCTION dayjul 
    492  
     251      CASE ( 4 )                 !==  formule 4,  compound waves (78 x 235)  
     252         zf1 = nodal_factort( 78) 
     253         zf  = nodal_factort(235) 
     254         zf  = zf1 * zf 
     255         ! 
     256      CASE ( 5 )                 !==  formule 5,  compound waves (78 *78 x 235) 
     257         zf1 = nodal_factort( 78) 
     258         zf  = nodal_factort(235) 
     259         zf  = zf * zf1 * zf1 
     260         ! 
     261      CASE ( 6 )                 !==  formule 6,  compound waves (78 *78 x 0) 
     262         zf1 = nodal_factort(78) 
     263         zf  = nodal_factort( 0) 
     264         zf  = zf * zf1 * zf1  
     265         ! 
     266      CASE( 7 )                  !==  formule 7, compound waves (75 x 75) 
     267         zf = nodal_factort(75) 
     268         zf = zf * zf 
     269         ! 
     270      CASE( 8 )                  !==  formule 8,  compound waves (78 x 0 x 235) 
     271         zf  = nodal_factort( 78) 
     272         zf1 = nodal_factort(  0) 
     273         zf2 = nodal_factort(235) 
     274         zf  = zf * zf1 * zf2 
     275         ! 
     276      CASE( 9 )                  !==  formule 9,  compound waves (78 x 0 x 227) 
     277         zf  = nodal_factort( 78) 
     278         zf1 = nodal_factort(  0) 
     279         zf2 = nodal_factort(227) 
     280         zf  = zf * zf1 * zf2 
     281         ! 
     282      CASE( 10 )                 !==  formule 10,  compound waves (78 x 227) 
     283         zf  = nodal_factort( 78) 
     284         zf1 = nodal_factort(227) 
     285         zf  = zf * zf1 
     286         ! 
     287      CASE( 11 )                 !==  formule 11,  compound waves (75 x 0) 
     288!!gm bug???? zf 2 fois ! 
     289         zf = nodal_factort(75) 
     290         zf = nodal_factort( 0) 
     291         zf = zf * zf1 
     292         ! 
     293      CASE( 12 )                 !==  formule 12,  compound waves (78 x 78 x 78 x 0)  
     294         zf1 = nodal_factort(78) 
     295         zf  = nodal_factort( 0) 
     296         zf  = zf * zf1 * zf1 * zf1 
     297         ! 
     298      CASE( 13 )                 !==  formule 13, compound waves (78 x 75) 
     299         zf1 = nodal_factort(78) 
     300         zf  = nodal_factort(75) 
     301         zf  = zf * zf1 
     302         ! 
     303      CASE( 14 )                 !==  formule 14, compound waves (235 x 0)  ===  (235) 
     304         zf  = nodal_factort(235) 
     305         zf1 = nodal_factort(  0) 
     306         zf  = zf * zf1 
     307         ! 
     308      CASE( 15 )                 !==  formule 15, compound waves (235 x 75)  
     309         zf  = nodal_factort(235) 
     310         zf1 = nodal_factort( 75) 
     311         zf  = zf * zf1 
     312         ! 
     313      CASE( 16 )                 !==  formule 16, compound waves (78 x 0 x 0)  ===  (78) 
     314         zf  = nodal_factort(78) 
     315         zf1 = nodal_factort( 0) 
     316         zf  = zf * zf1 * zf1 
     317         ! 
     318      CASE( 17 )                 !==  formule 17,  compound waves (227 x 0)  
     319         zf1 = nodal_factort(227) 
     320         zf  = nodal_factort(  0) 
     321         zf  = zf * zf1 
     322         ! 
     323      CASE( 18 )                 !==  formule 18,  compound waves (78 x 78 x 78 ) 
     324         zf1 = nodal_factort(78) 
     325         zf  = zf1 * zf1 * zf1 
     326         ! 
     327      CASE( 19 )                 !==  formule 19, compound waves (78 x 0 x 0 x 0)  ===  (78) 
     328!!gm bug2 ==>>>   here identical to formule 16,  a third multiplication by zf1 is missing 
     329         zf  = nodal_factort(78) 
     330         zf1 = nodal_factort( 0) 
     331         zf = zf * zf1 * zf1 
     332         ! 
     333      CASE( 73 )                 !==  formule 73 
     334         zs = sin(sh_I) 
     335         zf = (2./3.-zs*zs)/0.5021 
     336         ! 
     337      CASE( 74 )                 !==  formule 74 
     338         zs = sin(sh_I) 
     339         zf = zs * zs / 0.1578 
     340         ! 
     341      CASE( 75 )                 !==  formule 75 
     342         zs = cos(sh_I/2) 
     343         zf = sin(sh_I) * zs * zs / 0.3800 
     344         ! 
     345      CASE( 76 )                 !==  formule 76 
     346         zf = sin(2*sh_I) / 0.7214 
     347         ! 
     348      CASE( 77 )                 !==  formule 77 
     349         zs = sin(sh_I/2) 
     350         zf = sin(sh_I) * zs * zs / 0.0164 
     351         ! 
     352      CASE( 78 )                 !==  formule 78 
     353         zs = cos(sh_I/2) 
     354         zf = zs * zs * zs * zs / 0.9154 
     355         ! 
     356      CASE( 79 )                 !==  formule 79 
     357         zs = sin(sh_I) 
     358         zf = zs * zs / 0.1565 
     359         ! 
     360      CASE( 144 )                !==  formule 144 
     361         zs = sin(sh_I/2) 
     362         zf = ( 1-10*zs*zs+15*zs*zs*zs*zs ) * cos(sh_I/2) / 0.5873 
     363         ! 
     364      CASE( 149 )                !==  formule 149 
     365         zs = cos(sh_I/2) 
     366         zf = zs*zs*zs*zs*zs*zs / 0.8758 
     367         ! 
     368      CASE( 215 )                !==  formule 215 
     369         zs = cos(sh_I/2) 
     370         zf = zs*zs*zs*zs / 0.9154 * sh_x1ra 
     371         ! 
     372      CASE( 227 )                !==  formule 227  
     373         zs = sin(2*sh_I) 
     374         zf = sqrt( 0.8965*zs*zs+0.6001*zs*cos (sh_nu)+0.1006 ) 
     375         ! 
     376      CASE ( 235 )               !==  formule 235  
     377         zs = sin(sh_I) 
     378         zf = sqrt( 19.0444*zs*zs*zs*zs + 2.7702*zs*zs*cos(2*sh_nu) + .0981 ) 
     379         ! 
     380      END SELECT 
     381      ! 
     382   END FUNCTION nodal_factort 
     383 
     384 
     385   FUNCTION dayjul( kyr, kmonth, kday ) 
     386      !!---------------------------------------------------------------------- 
     387      !!  *** THIS ROUTINE COMPUTES THE JULIAN DAY (AS A REAL VARIABLE) 
     388      !!---------------------------------------------------------------------- 
     389      INTEGER,INTENT(in) ::   kyr, kmonth, kday 
     390      ! 
     391      INTEGER,DIMENSION(12) ::  idayt, idays 
     392      INTEGER  ::   inc, ji 
     393      REAL(wp) ::   dayjul, zyq 
     394      ! 
     395      DATA idayt/0.,31.,59.,90.,120.,151.,181.,212.,243.,273.,304.,334./ 
     396      !!---------------------------------------------------------------------- 
     397      ! 
     398      idays(1) = 0. 
     399      idays(2) = 31. 
     400      inc = 0. 
     401      zyq = MOD( kyr-1900. , 4. ) 
     402      IF( zyq == 0.)   inc = 1. 
     403      DO ji = 3, 12 
     404         idays(ji)=idayt(ji)+inc 
     405      END DO 
     406      dayjul = idays(kmonth) + kday 
     407      ! 
     408   END FUNCTION dayjul 
     409 
     410   !!====================================================================== 
    493411END MODULE tide_mod 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/SBC/tideini.F90

    r4147 r4292  
    11MODULE tideini 
    2   !!================================================================================= 
    3   !!                       ***  MODULE  tideini  *** 
    4   !! Initialization of tidal forcing 
    5   !! History :  9.0  !  07  (O. Le Galloudec)  Original code 
    6   !!================================================================================= 
    7   !! * Modules used 
    8   USE oce             ! ocean dynamics and tracers variables 
    9   USE dom_oce         ! ocean space and time domain 
    10   USE in_out_manager  ! I/O units 
    11   USE ioipsl          ! NetCDF IPSL library 
    12   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    13   USE phycst 
    14   USE daymod 
    15   USE dynspg_oce 
    16   USE tide_mod 
    17   USE iom 
     2   !!====================================================================== 
     3   !!                       ***  MODULE  tideini  *** 
     4   !! Initialization of tidal forcing 
     5   !!====================================================================== 
     6   !! History :  1.0  !  2007  (O. Le Galloudec)  Original code 
     7   !!---------------------------------------------------------------------- 
     8   USE oce             ! ocean dynamics and tracers variables 
     9   USE dom_oce         ! ocean space and time domain 
     10   USE phycst 
     11   USE daymod 
     12   USE dynspg_oce 
     13   USE tide_mod 
     14   ! 
     15   USE iom 
     16   USE in_out_manager  ! I/O units 
     17   USE ioipsl          ! NetCDF IPSL library 
     18   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    1819 
    19   IMPLICIT NONE 
    20   PUBLIC 
     20   IMPLICIT NONE 
     21   PUBLIC 
    2122 
    22   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:) ::  & 
    23        omega_tide,  & 
    24        v0tide,      & 
    25        utide,       & 
    26        ftide 
     23   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:) ::   omega_tide   !: 
     24   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:) ::   v0tide       !: 
     25   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:) ::   utide        !: 
     26   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:) ::   ftide        !: 
    2727 
    28   LOGICAL, PUBLIC :: ln_tide_pot , ln_tide_ramp  
    29   REAL(wp), PUBLIC :: rdttideramp  
    30   INTEGER, PUBLIC :: nb_harmo 
    31   INTEGER, PUBLIC, ALLOCATABLE, DIMENSION(:) :: ntide 
    32   INTEGER, PUBLIC :: kt_tide 
     28   LOGICAL , PUBLIC ::   ln_tide_pot     !: 
     29   LOGICAL , PUBLIC ::   ln_tide_ramp    !: 
     30   INTEGER , PUBLIC ::   nb_harmo                 !: 
     31   INTEGER , PUBLIC ::   kt_tide                  !: 
     32   REAL(wp), PUBLIC ::   rdttideramp              !: 
     33    
     34   INTEGER , PUBLIC, ALLOCATABLE, DIMENSION(:) ::   ntide   !: 
    3335 
    34   !!--------------------------------------------------------------------------------- 
    35   !!   OPA 9.0 , LODYC-IPSL  (2003) 
    36   !!--------------------------------------------------------------------------------- 
    37  
     36   !!---------------------------------------------------------------------- 
     37   !! NEMO/OPA 3.5 , NEMO Consortium (2013) 
     38   !! $Id: $ 
     39   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
     40   !!---------------------------------------------------------------------- 
    3841CONTAINS 
    3942    
    … …  
    7275       ! 
    7376       nb_harmo=0 
    74        DO jk=1,jpmax_harmo 
    75           DO ji=1,jpmax_harmo 
    76              IF(TRIM(clname(jk)) .eq. Wave(ji)%cname_tide) THEN 
    77                 nb_harmo=nb_harmo+1 
    78              ENDIF 
     77       DO jk = 1, jpmax_harmo 
     78          DO ji = 1,jpmax_harmo 
     79             IF( TRIM(clname(jk)) == Wave(ji)%cname_tide )   nb_harmo = nb_harmo + 1 
    7980          END DO 
    80        ENDDO 
     81       END DO 
    8182       ! 
    8283       IF(lwp) THEN 
    83           WRITE(numout,*) '        Namelist nam_tide' 
    84           WRITE(numout,*) '        nb_harmo    = ', nb_harmo 
    85           WRITE(numout,*) '        ln_tide_ramp = ', ln_tide_ramp  
    86           WRITE(numout,*) '        rdttideramp = ', rdttideramp 
    87           IF (ln_tide_ramp.AND.((nitend-nit000+1)*rdt/rday < rdttideramp)) & 
    88           & CALL ctl_stop('rdttideramp must be lower than run duration') 
    89           IF (ln_tide_ramp.AND.(rdttideramp<0.)) & 
    90           & CALL ctl_stop('rdttideramp must be positive') 
    91           CALL flush(numout) 
     84          WRITE(numout,*) '   Namelist nam_tide' 
     85          WRITE(numout,*) '      Apply astronomical potential : ln_tide_pot  =', ln_tide_pot 
     86          WRITE(numout,*) '                                     nb_harmo     = ', nb_harmo 
     87          WRITE(numout,*) '                                     ln_tide_ramp = ', ln_tide_ramp  
     88          WRITE(numout,*) '                                     rdttideramp  = ', rdttideramp 
    9289       ENDIF 
     90       IF( ln_tide_ramp.AND.((nitend-nit000+1)*rdt/rday < rdttideramp) )   & 
     91          &   CALL ctl_stop('rdttideramp must be lower than run duration') 
     92       IF( ln_tide_ramp.AND.(rdttideramp<0.) ) & 
     93          &   CALL ctl_stop('rdttideramp must be positive') 
    9394       ! 
    94        ALLOCATE(ntide(nb_harmo)) 
    95        DO jk=1,nb_harmo 
    96           DO ji=1,jpmax_harmo 
    97              IF (TRIM(clname(jk)) .eq. Wave(ji)%cname_tide) THEN 
     95       IF( .NOT. lk_dynspg_ts )   CALL ctl_warn( 'sbc_tide : use of time splitting is recommended' ) 
     96       ! 
     97       ALLOCATE( ntide(nb_harmo) ) 
     98       DO jk = 1, nb_harmo 
     99          DO ji = 1, jpmax_harmo 
     100             IF( TRIM(clname(jk)) .eq. Wave(ji)%cname_tide ) THEN 
    98101                ntide(jk) = ji 
    99102                EXIT 
    … …  
    102105       END DO 
    103106       ! 
    104        ALLOCATE(omega_tide(nb_harmo)) 
    105        ALLOCATE(v0tide    (nb_harmo)) 
    106        ALLOCATE(utide     (nb_harmo)) 
    107        ALLOCATE(ftide     (nb_harmo)) 
     107       ALLOCATE( omega_tide(nb_harmo), v0tide    (nb_harmo),   & 
     108          &      utide     (nb_harmo), ftide     (nb_harmo)  ) 
    108109       kt_tide = kt 
    109110       ! 
    110     ENDIF 
    111  
    112     IF ( nsec_day == NINT(0.5 * rdttra(1)) ) THEN 
    113        ! 
    114        IF(lwp) THEN 
    115           WRITE(numout,*) 
    116           WRITE(numout,*) 'tide_ini : Update of the tidal components at kt=',kt 
    117           WRITE(numout,*) '~~~~~~~~ ' 
    118        ENDIF 
    119        CALL tide_harmo(omega_tide, v0tide, utide, ftide, ntide, nb_harmo) 
    120        DO jk =1,nb_harmo 
    121          IF(lwp) WRITE(numout,*) Wave(ntide(jk))%cname_tide,utide(jk),ftide(jk),v0tide(jk),omega_tide(jk) 
    122          call flush(numout) 
    123        END DO 
    124        ! 
    125        kt_tide = kt 
    126        ! 
    127     ENDIF 
    128  
    129   END SUBROUTINE tide_init 
    130     
     111      ENDIF 
     112      ! 
     113   END SUBROUTINE tide_init 
     114      
     115   !!====================================================================== 
    131116END MODULE tideini 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/SBC/updtide.F90

    r3651 r4292  
    11MODULE updtide 
    2   !!================================================================================= 
    3   !!                       ***  MODULE  updtide  *** 
    4   !! Initialization of tidal forcing 
    5   !! History :  9.0  !  07  (O. Le Galloudec)  Original code 
    6   !!================================================================================= 
     2   !!====================================================================== 
     3   !!                       ***  MODULE  updtide  *** 
     4   !! Initialization of tidal forcing 
     5   !!====================================================================== 
     6   !! History :  9.0  !  07  (O. Le Galloudec)  Original code 
     7   !!---------------------------------------------------------------------- 
    78#if defined key_tide 
    8   !! * Modules used 
    9   USE oce             ! ocean dynamics and tracers variables 
    10   USE dom_oce         ! ocean space and time domain 
    11   USE in_out_manager  ! I/O units 
    12   USE phycst 
    13   USE sbctide 
    14   USE dynspg_oce 
    15   USE tideini, ONLY: ln_tide_ramp, rdttideramp 
     9   !!---------------------------------------------------------------------- 
     10   !!   'key_tide' :                                        tidal potential 
     11   !!---------------------------------------------------------------------- 
     12   !!   upd_tide       : update tidal potential 
     13   !!---------------------------------------------------------------------- 
     14   USE oce             ! ocean dynamics and tracers variables 
     15   USE dom_oce         ! ocean space and time domain 
     16   USE in_out_manager  ! I/O units 
     17   USE phycst          ! physical constant 
     18   USE sbctide         ! tide potential variable 
     19   USE tideini, ONLY: ln_tide_ramp, rdttideramp 
    1620 
    17   IMPLICIT NONE 
    18   PUBLIC 
     21   IMPLICIT NONE 
     22   PUBLIC 
    1923 
    20   !! * Routine accessibility 
    21   PUBLIC upd_tide 
    22   !!--------------------------------------------------------------------------------- 
    23   !!   OPA 9.0 , LODYC-IPSL  (2003) 
    24   !!--------------------------------------------------------------------------------- 
    25  
     24   PUBLIC   upd_tide   ! called in dynspg_... modules 
     25   
     26   !!---------------------------------------------------------------------- 
     27   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
     28   !! $Id: sbcfwb.F90 3625 2012-11-21 13:19:18Z acc $ 
     29   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
     30   !!---------------------------------------------------------------------- 
    2631CONTAINS 
    2732 
    28   SUBROUTINE upd_tide (kt,kit) 
    29     !!---------------------------------------------------------------------- 
    30     !!                 ***  ROUTINE upd_tide  *** 
    31     !!----------------------------------------------------------------------       
    32     !! * Local declarations 
     33   SUBROUTINE upd_tide( kt, kit, kbaro, koffset ) 
     34      !!---------------------------------------------------------------------- 
     35      !!                 ***  ROUTINE upd_tide  *** 
     36      !! 
     37      !! ** Purpose :   provide at each time step the astronomical potential 
     38      !! 
     39      !! ** Method  :   computed from pulsation and amplitude of all tide components 
     40      !! 
     41      !! ** Action  :   pot_astro   actronomical potential 
     42      !!----------------------------------------------------------------------       
     43      INTEGER, INTENT(in)           ::   kt      ! ocean time-step index 
     44      INTEGER, INTENT(in), OPTIONAL ::   kit     ! external mode sub-time-step index (lk_dynspg_ts=T only) 
     45      INTEGER, INTENT(in), OPTIONAL ::   kbaro   ! number of sub-time-step           (lk_dynspg_ts=T only) 
     46      INTEGER, INTENT(in), OPTIONAL ::   koffset ! time offset in number  
     47                                                 ! of sub-time-steps                 (lk_dynspg_ts=T only) 
     48      ! 
     49      INTEGER  ::   joffset      ! local integer 
     50      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
     51      REAL(wp) ::   zt, zramp    ! local scalar 
     52      REAL(wp), DIMENSION(nb_harmo) ::   zwt  
     53      !!----------------------------------------------------------------------       
     54      ! 
     55      !                               ! tide pulsation at model time step (or sub-time-step) 
     56      zt = ( kt - kt_tide ) * rdt 
     57      ! 
     58      joffset = 0 
     59      IF( PRESENT( koffset ) )   joffset = koffset 
     60      ! 
     61      IF( PRESENT( kit ) .AND. PRESENT( kbaro ) )   THEN 
     62         zt = zt + ( kit + 0.5_wp * ( joffset - 1 ) ) * rdt / REAL( kbaro, wp ) 
     63      ELSE 
     64         zt = zt + joffset * rdt 
     65      ENDIF 
     66      ! 
     67      zwt(:) = omega_tide(:) * zt 
    3368 
    34     INTEGER, INTENT( in ) ::   kt,kit      ! ocean time-step index 
    35     INTEGER  :: ji,jj,jk 
    36     REAL (wp) :: zramp 
    37     REAL (wp), DIMENSION(nb_harmo) :: zwt  
    38     !............................................................................... 
    39  
    40     pot_astro(:,:)=0.e0 
    41     zramp = 1.e0 
    42  
    43     IF (lk_dynspg_ts) THEN 
    44        zwt(:) = omega_tide(:)* ((kt-kt_tide)*rdt + kit*(rdt/REAL(nn_baro,wp))) 
    45        IF (ln_tide_ramp) THEN 
    46           zramp = MIN(MAX( ((kt-nit000)*rdt + kit*(rdt/REAL(nn_baro,wp)))/(rdttideramp*rday),0.),1.) 
    47        ENDIF 
    48     ELSE 
    49        zwt(:) = omega_tide(:)*(kt-kt_tide)*rdt 
    50        IF (ln_tide_ramp) THEN 
    51           zramp = MIN(MAX( ((kt-nit000)*rdt)/(rdttideramp*rday),0.),1.)  
    52        ENDIF   
    53     ENDIF 
    54  
    55     do jk=1,nb_harmo 
    56        do ji=1,jpi 
    57           do jj=1,jpj 
    58              pot_astro(ji,jj)=pot_astro(ji,jj) + zramp*(amp_pot(ji,jj,jk)*COS(zwt(jk)+phi_pot(ji,jj,jk)))       
    59           enddo 
    60        enddo 
    61     enddo 
    62  
    63   END SUBROUTINE upd_tide 
     69      pot_astro(:,:) = 0._wp          ! update tidal potential (sum of all harmonics) 
     70      DO jk = 1, nb_harmo    
     71         pot_astro(:,:) = pot_astro(:,:) + amp_pot(:,:,jk) * COS( zwt(jk) + phi_pot(:,:,jk) )       
     72      END DO 
     73      ! 
     74      IF( ln_tide_ramp ) THEN         ! linear increase if asked 
     75         zt = ( kt - nit000 ) * rdt 
     76         IF( PRESENT( kit ) .AND. PRESENT( kbaro ) )   zt = zt + kit * rdt / REAL( kbaro, wp ) 
     77         zramp = MIN(  MAX( zt / (rdttideramp*rday) , 0._wp ) , 1._wp  ) 
     78         pot_astro(:,:) = zramp * pot_astro(:,:) 
     79      ENDIF 
     80      ! 
     81   END SUBROUTINE upd_tide 
    6482 
    6583#else 
    … …  
    6886  !!---------------------------------------------------------------------- 
    6987CONTAINS 
    70   SUBROUTINE upd_tide( kt,kit )          ! Empty routine 
    71     INTEGER,INTENT (IN) :: kt, kit 
     88  SUBROUTINE upd_tide( kt, kit, kbaro, koffset )          ! Empty routine 
     89    INTEGER, INTENT(in)           ::   kt      !  integer  arg, dummy routine 
     90    INTEGER, INTENT(in), OPTIONAL ::   kit     !  optional arg, dummy routine 
     91    INTEGER, INTENT(in), OPTIONAL ::   kbaro   !  optional arg, dummy routine 
     92    INTEGER, INTENT(in), OPTIONAL ::   koffset !  optional arg, dummy routine 
    7293    WRITE(*,*) 'upd_tide: You should not have seen this print! error?', kt 
    7394  END SUBROUTINE upd_tide 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/TRA/eosbn2.F90

    r4162 r4292  
    7474CONTAINS 
    7575 
    76    SUBROUTINE eos_insitu( pts, prd ) 
     76   SUBROUTINE eos_insitu( pts, prd, pdep ) 
    7777      !!---------------------------------------------------------------------- 
    7878      !!                   ***  ROUTINE eos_insitu  *** 
    … …  
    114114      !                                                      ! 2 : salinity               [psu] 
    115115      REAL(wp), DIMENSION(:,:,:)  , INTENT(  out) ::   prd   ! in situ density            [-] 
     116      REAL(wp), DIMENSION(:,:,:)  , INTENT(in   ) ::   pdep  ! depth                      [m] 
    116117      !! 
    117118      INTEGER  ::   ji, jj, jk           ! dummy loop indices 
    … …  
    140141                  zt = pts   (ji,jj,jk,jp_tem) 
    141142                  zs = pts   (ji,jj,jk,jp_sal) 
    142                   zh = fsdept(ji,jj,jk)        ! depth 
     143                  zh = pdep(ji,jj,jk)        ! depth 
    143144                  zsr= zws   (ji,jj,jk)        ! square root salinity 
    144145                  ! 
    … …  
    198199 
    199200 
    200    SUBROUTINE eos_insitu_pot( pts, prd, prhop ) 
     201   SUBROUTINE eos_insitu_pot( pts, prd, prhop, pdep ) 
    201202      !!---------------------------------------------------------------------- 
    202203      !!                  ***  ROUTINE eos_insitu_pot  *** 
    … …  
    249250      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(  out) ::   prd    ! in situ density            [-] 
    250251      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(  out) ::   prhop  ! potential density (surface referenced) 
     252      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pdep   ! depth                      [m] 
    251253      ! 
    252254      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    … …  
    271273                  zt = pts   (ji,jj,jk,jp_tem) 
    272274                  zs = pts   (ji,jj,jk,jp_sal) 
    273                   zh = fsdept(ji,jj,jk)        ! depth 
     275                  zh = pdep(ji,jj,jk)        ! depth 
    274276                  zsr= zws   (ji,jj,jk)        ! square root salinity 
    275277                  ! 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/TRA/traadv.F90

    r4245 r4292  
    1515   USE oce             ! ocean dynamics and active tracers 
    1616   USE dom_oce         ! ocean space and time domain 
     17   USE domvvl          ! variable vertical scale factors 
    1718   USE traadv_cen2     ! 2nd order centered scheme (tra_adv_cen2   routine) 
    1819   USE traadv_tvd      ! TVD      scheme           (tra_adv_tvd    routine) 
    … …  
    9495         zwn(:,:,jk) = e1t(:,:) * e2t(:,:)      * wn(:,:,jk) 
    9596      END DO 
     97      ! 
     98      IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN 
     99         zun(:,:,:) = zun(:,:,:) + un_td(:,:,:) 
     100         zvn(:,:,:) = zvn(:,:,:) + vn_td(:,:,:) 
     101      ENDIF 
     102      ! 
    96103      zun(:,:,jpk) = 0._wp                                                     ! no transport trough the bottom 
    97104      zvn(:,:,jpk) = 0._wp                                                     ! no transport trough the bottom 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/TRA/trabbl.F90

    r4147 r4292  
    6666   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)         ::   ahu_bbl_0, ahv_bbl_0   ! diffusive bbl flux coefficients at u and v-points 
    6767   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC ::   e3u_bbl_0, e3v_bbl_0   ! thichness of the bbl (e3) at u and v-points (PUBLIC for TAM) 
    68    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC ::   r1_e1e2t               ! inverse of the cell surface at t-point      [1/m2] (PUBLIC for TAM) 
    6968 
    7069   !! * Substitutions 
    … …  
    8584         &      vtr_bbl  (jpi,jpj) , ahv_bbl  (jpi,jpj) , mbkv_d  (jpi,jpj) , mgrhv(jpi,jpj) ,     & 
    8685         &      ahu_bbl_0(jpi,jpj) , ahv_bbl_0(jpi,jpj) ,                                          & 
    87          &      e3u_bbl_0(jpi,jpj) , e3v_bbl_0(jpi,jpj) , r1_e1e2t(jpi,jpj)                  , STAT= tra_bbl_alloc ) 
     86         &      e3u_bbl_0(jpi,jpj) , e3v_bbl_0(jpi,jpj) , STAT= tra_bbl_alloc                ) 
    8887         ! 
    8988      IF( lk_mpp            )   CALL mpp_sum ( tra_bbl_alloc ) 
    … …  
    217216#  endif 
    218217               ik = mbkt(ji,jj)                            ! bottom T-level index 
    219                zbtr = r1_e1e2t(ji,jj)  / fse3t(ji,jj,ik) 
     218               zbtr = r1_e12t(ji,jj)  / fse3t(ji,jj,ik) 
    220219               pta(ji,jj,ik,jn) = pta(ji,jj,ik,jn)                                                         & 
    221220                  &               + (   ahu_bbl(ji  ,jj  ) * ( zptb(ji+1,jj  ) - zptb(ji  ,jj  ) )   & 
    … …  
    279278                  ! 
    280279                  !                                               ! up  -slope T-point (shelf bottom point) 
    281                   zbtr = r1_e1e2t(iis,jj) / fse3t(iis,jj,ikus) 
     280                  zbtr = r1_e12t(iis,jj) / fse3t(iis,jj,ikus) 
    282281                  ztra = zu_bbl * ( ptb(iid,jj,ikus,jn) - ptb(iis,jj,ikus,jn) ) * zbtr 
    283282                  pta(iis,jj,ikus,jn) = pta(iis,jj,ikus,jn) + ztra 
    284283                  ! 
    285284                  DO jk = ikus, ikud-1                            ! down-slope upper to down T-point (deep column) 
    286                      zbtr = r1_e1e2t(iid,jj) / fse3t(iid,jj,jk) 
     285                     zbtr = r1_e12t(iid,jj) / fse3t(iid,jj,jk) 
    287286                     ztra = zu_bbl * ( ptb(iid,jj,jk+1,jn) - ptb(iid,jj,jk,jn) ) * zbtr 
    288287                     pta(iid,jj,jk,jn) = pta(iid,jj,jk,jn) + ztra 
    289288                  END DO 
    290289                  ! 
    291                   zbtr = r1_e1e2t(iid,jj) / fse3t(iid,jj,ikud) 
     290                  zbtr = r1_e12t(iid,jj) / fse3t(iid,jj,ikud) 
    292291                  ztra = zu_bbl * ( ptb(iis,jj,ikus,jn) - ptb(iid,jj,ikud,jn) ) * zbtr 
    293292                  pta(iid,jj,ikud,jn) = pta(iid,jj,ikud,jn) + ztra 
    … …  
    301300                  ! 
    302301                  ! up  -slope T-point (shelf bottom point) 
    303                   zbtr = r1_e1e2t(ji,ijs) / fse3t(ji,ijs,ikvs) 
     302                  zbtr = r1_e12t(ji,ijs) / fse3t(ji,ijs,ikvs) 
    304303                  ztra = zv_bbl * ( ptb(ji,ijd,ikvs,jn) - ptb(ji,ijs,ikvs,jn) ) * zbtr 
    305304                  pta(ji,ijs,ikvs,jn) = pta(ji,ijs,ikvs,jn) + ztra 
    306305                  ! 
    307306                  DO jk = ikvs, ikvd-1                            ! down-slope upper to down T-point (deep column) 
    308                      zbtr = r1_e1e2t(ji,ijd) / fse3t(ji,ijd,jk) 
     307                     zbtr = r1_e12t(ji,ijd) / fse3t(ji,ijd,jk) 
    309308                     ztra = zv_bbl * ( ptb(ji,ijd,jk+1,jn) - ptb(ji,ijd,jk,jn) ) * zbtr 
    310309                     pta(ji,ijd,jk,jn) = pta(ji,ijd,jk,jn)  + ztra 
    311310                  END DO 
    312311                  !                                               ! down-slope T-point (deep bottom point) 
    313                   zbtr = r1_e1e2t(ji,ijd) / fse3t(ji,ijd,ikvd) 
     312                  zbtr = r1_e12t(ji,ijd) / fse3t(ji,ijd,ikvd) 
    314313                  ztra = zv_bbl * ( ptb(ji,ijs,ikvs,jn) - ptb(ji,ijd,ikvd,jn) ) * zbtr 
    315314                  pta(ji,ijd,ikvd,jn) = pta(ji,ijd,ikvd,jn) + ztra 
    … …  
    423422            ztb (ji,jj) = tsb(ji,jj,ik,jp_tem) * tmask(ji,jj,1)      ! bottom before T and S 
    424423            zsb (ji,jj) = tsb(ji,jj,ik,jp_sal) * tmask(ji,jj,1) 
    425             zdep(ji,jj) = fsdept_0(ji,jj,ik)        ! bottom T-level reference depth 
     424            zdep(ji,jj) = gdept_0(ji,jj,ik)         ! bottom T-level reference depth 
    426425            ! 
    427426            zub(ji,jj) = un(ji,jj,mbku(ji,jj))      ! bottom velocity 
    … …  
    601600      IF( nn_eos /= 0 )   CALL ctl_stop ( ' bbl parameterisation requires eos = 0. We stop.' ) 
    602601 
    603  
    604       !                             !* inverse of surface of T-cells 
    605       r1_e1e2t(:,:) = 1._wp / ( e1t(:,:) * e2t(:,:) ) 
    606  
    607602      !                             !* vertical index of  "deep" bottom u- and v-points 
    608603      DO jj = 1, jpjm1                    ! (the "shelf" bottom k-indices are mbku and mbkv) 
    … …  
    612607         END DO 
    613608      END DO 
    614       ! converte into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk 
     609      ! convert into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk 
    615610      zmbk(:,:) = REAL( mbku_d(:,:), wp )   ;   CALL lbc_lnk(zmbk,'U',1.)   ;   mbku_d(:,:) = MAX( INT( zmbk(:,:) ), 1 ) 
    616611      zmbk(:,:) = REAL( mbkv_d(:,:), wp )   ;   CALL lbc_lnk(zmbk,'V',1.)   ;   mbkv_d(:,:) = MAX( INT( zmbk(:,:) ), 1 ) 
    617612 
    618                                         !* sign of grad(H) at u- and v-points 
     613                                     !* sign of grad(H) at u- and v-points 
    619614      mgrhu(jpi,:) = 0.    ;    mgrhu(:,jpj) = 0.   ;    mgrhv(jpi,:) = 0.    ;    mgrhv(:,jpj) = 0. 
    620615      DO jj = 1, jpjm1 
    621616         DO ji = 1, jpim1 
    622             mgrhu(ji,jj) = INT(  SIGN( 1.e0, fsdept_0(ji+1,jj,mbkt(ji+1,jj)) - fsdept_0(ji,jj,mbkt(ji,jj)) )  ) 
    623             mgrhv(ji,jj) = INT(  SIGN( 1.e0, fsdept_0(ji,jj+1,mbkt(ji,jj+1)) - fsdept_0(ji,jj,mbkt(ji,jj)) )  ) 
     617            mgrhu(ji,jj) = INT(  SIGN( 1.e0, gdept_0(ji+1,jj,mbkt(ji+1,jj)) - gdept_0(ji,jj,mbkt(ji,jj)) )  ) 
     618            mgrhv(ji,jj) = INT(  SIGN( 1.e0, gdept_0(ji,jj+1,mbkt(ji,jj+1)) - gdept_0(ji,jj,mbkt(ji,jj)) )  ) 
    624619         END DO 
    625620      END DO 
    626621 
    627622      DO jj = 1, jpjm1              !* bbl thickness at u- (v-) point 
    628          DO ji = 1, jpim1                 ! minimum of top & bottom e3u_0 (e3v_0) 
    629             e3u_bbl_0(ji,jj) = MIN( fse3u_0(ji,jj,mbkt(ji+1,jj  )), fse3u_0(ji,jj,mbkt(ji,jj)) ) 
    630             e3v_bbl_0(ji,jj) = MIN( fse3v_0(ji,jj,mbkt(ji  ,jj+1)), fse3v_0(ji,jj,mbkt(ji,jj)) ) 
     623         DO ji = 1, jpim1           ! minimum of top & bottom e3u_0 (e3v_0) 
     624            e3u_bbl_0(ji,jj) = MIN( e3u_0(ji,jj,mbkt(ji+1,jj  )), e3u_0(ji,jj,mbkt(ji,jj)) ) 
     625            e3v_bbl_0(ji,jj) = MIN( e3v_0(ji,jj,mbkt(ji  ,jj+1)), e3v_0(ji,jj,mbkt(ji,jj)) ) 
    631626         END DO 
    632627      END DO 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/TRA/tradmp.F90

    r4247 r4292  
    795795      clname = 'dist.coast' 
    796796      itime  = 0 
    797       CALL ymds2ju( 0     , 1      , 1     , 0._wp , zdate0 ) 
    798       CALL restini( 'NONE', jpi    , jpj   , glamt, gphit ,   & 
    799          &          jpk   , gdept_0, clname, itime, zdate0,   & 
     797      CALL ymds2ju( 0     , 1       , 1     , 0._wp , zdate0 ) 
     798      CALL restini( 'NONE', jpi     , jpj   , glamt, gphit ,   & 
     799         &          jpk   , gdept_1d, clname, itime, zdate0,   & 
    800800         &          rdt   , icot                         ) 
    801801      CALL restput( icot, 'Tcoast', jpi, jpj, jpk, 0, pdct ) 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_bilap.F90

    r3294 r4292  
    110110            DO jj = 1, jpjm1 
    111111               DO ji = 1, fs_jpim1   ! vector opt. 
    112                   zeeu(ji,jj) = e2u(ji,jj) * fse3u(ji,jj,jk) / e1u(ji,jj) * umask(ji,jj,jk) 
    113                   zeev(ji,jj) = e1v(ji,jj) * fse3v(ji,jj,jk) / e2v(ji,jj) * vmask(ji,jj,jk) 
     112                  zeeu(ji,jj) = re2u_e1u(ji,jj) * fse3u_n(ji,jj,jk) * umask(ji,jj,jk) 
     113                  zeev(ji,jj) = re1v_e2v(ji,jj) * fse3v_n(ji,jj,jk) * vmask(ji,jj,jk) 
    114114               END DO 
    115115            END DO 
    … …  
    133133            DO jj = 2, jpjm1                 ! Second derivative (divergence) time the eddy diffusivity coefficient 
    134134               DO ji = fs_2, fs_jpim1   ! vector opt. 
    135                   zbtr = 1.0 / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
     135                  zbtr = 1.0 / ( e12t(ji,jj) * fse3t_n(ji,jj,jk) ) 
    136136                  zlt(ji,jj) = fsahtt(ji,jj,jk) * zbtr * (   ztu(ji,jj,jk) - ztu(ji-1,jj,jk)   & 
    137137                     &                                     + ztv(ji,jj,jk) - ztv(ji,jj-1,jk)   ) 
    … …  
    151151               DO ji = fs_2, fs_jpim1   ! vector opt. 
    152152                  ! horizontal diffusive trends 
    153                   zbtr = 1.0 / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
     153                  zbtr = 1.0 / ( e12t(ji,jj) * fse3t_n(ji,jj,jk) ) 
    154154                  ztra = zbtr * (  ztu(ji,jj,jk) - ztu(ji-1,jj,jk) + ztv(ji,jj,jk) - ztv(ji,jj-1,jk)  ) 
    155155                  ! add it to the general tracer trends 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_bilapg.F90

    r3805 r4292  
    210210            DO jj = 1, jpjm1 
    211211               DO ji = 1, jpim1 
    212                   zabe1 = e2u(ji,jj) * fse3u(ji,jj,jk) / e1u(ji,jj) 
    213                   zabe2 = e1v(ji,jj) * fse3v(ji,jj,jk) / e2v(ji,jj) 
     212                  zabe1 = re2u_e1u(ji,jj) * fse3u_n(ji,jj,jk) 
     213                  zabe2 = re1v_e2v(ji,jj) * fse3v_n(ji,jj,jk) 
    214214                   
    215215                  zmku = 1./MAX( tmask(ji+1,jj,jk  )+tmask(ji,jj,jk+1)   & 
    … …  
    279279            DO jk = 2, jpkm1 
    280280               DO ji = 2, jpim1 
    281                   zcof0 = e1t(ji,jj) * e2t(ji,jj) / fse3w(ji,jj,jk)   & 
     281                  zcof0 = e12t(ji,jj) / fse3w_n(ji,jj,jk)   & 
    282282                     &     * (  wslpi(ji,jj,jk) * wslpi(ji,jj,jk)        & 
    283283                     &        + wslpj(ji,jj,jk) * wslpj(ji,jj,jk)  ) 
    … …  
    310310                  DO ji = 2, jpim1 
    311311                     ! eddy coef. divided by the volume element 
    312                      zbtr = 1.0 / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
     312                     zbtr = 1.0 / ( e12t(ji,jj) * fse3t_n(ji,jj,jk) ) 
    313313                     ! vertical divergence 
    314314                     ztav = fsahtt(ji,jj,jk) * ( zftw(ji,jk) - zftw(ji,jk+1) ) 
    … …  
    322322                  DO ji = 2, jpim1 
    323323                     ! inverse of the volume element 
    324                      zbtr = 1.0 / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
     324                     zbtr = 1.0 / ( e12t(ji,jj) * fse3t_n(ji,jj,jk) ) 
    325325                     ! vertical divergence 
    326326                     ztav = zftw(ji,jk) - zftw(ji,jk+1) 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_iso.F90

    r3805 r4292  
    176176            DO jj = 1 , jpjm1 
    177177               DO ji = 1, fs_jpim1   ! vector opt. 
    178                   zabe1 = ( fsahtu(ji,jj,jk) + pahtb0 ) * e2u(ji,jj) * fse3u(ji,jj,jk) / e1u(ji,jj) 
    179                   zabe2 = ( fsahtv(ji,jj,jk) + pahtb0 ) * e1v(ji,jj) * fse3v(ji,jj,jk) / e2v(ji,jj) 
     178                  zabe1 = ( fsahtu(ji,jj,jk) + pahtb0 ) * re2u_e1u(ji,jj) * fse3u_n(ji,jj,jk) 
     179                  zabe2 = ( fsahtv(ji,jj,jk) + pahtb0 ) * re1v_e2v(ji,jj) * fse3v_n(ji,jj,jk) 
    180180                  ! 
    181181                  zmsku = 1. / MAX(  tmask(ji+1,jj,jk  ) + tmask(ji,jj,jk+1)   & 
    … …  
    201201            DO jj = 2 , jpjm1 
    202202               DO ji = fs_2, fs_jpim1   ! vector opt. 
    203                   zbtr = 1.0 / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
     203                  zbtr = 1.0 / ( e12t(ji,jj) * fse3t_n(ji,jj,jk) ) 
    204204                  ztra = zbtr * ( zftu(ji,jj,jk) - zftu(ji-1,jj,jk) + zftv(ji,jj,jk) - zftv(ji,jj-1,jk)  ) 
    205205                  pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra 
    … …  
    288288            DO jj = 2, jpjm1 
    289289               DO ji = fs_2, fs_jpim1   ! vector opt. 
    290                   zbtr = 1.0 / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
     290                  zbtr = 1.0 / ( e12t(ji,jj) * fse3t_n(ji,jj,jk) ) 
    291291                  ztra = (  ztfw(ji,jj,jk) - ztfw(ji,jj,jk+1)  ) * zbtr 
    292292                  pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_lap.F90

    r3294 r4292  
    3131 
    3232   PUBLIC   tra_ldf_lap   ! routine called by step.F90 
    33  
    34    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) ::   e1ur, e2vr   ! scale factor coefficients 
    3533 
    3634   !! * Substitutions 
    … …  
    8583         IF(lwp) WRITE(numout,*) 'tra_ldf_lap : iso-level laplacian diffusion on ', cdtype 
    8684         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ ' 
    87          ! 
    88          IF( .NOT. ALLOCATED( e1ur ) ) THEN 
    89             ! This routine may be called for both active and passive tracers.  
    90             ! Allocate and set saved arrays on first call only. 
    91             ALLOCATE( e1ur(jpi,jpj), e2vr(jpi,jpj), STAT=ierr ) 
    92             IF( lk_mpp    )   CALL mpp_sum( ierr ) 
    93             IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'tra_ldf_lap : unable to allocate arrays' ) 
    94             ! 
    95             e1ur(:,:) = e2u(:,:) / e1u(:,:) 
    96             e2vr(:,:) = e1v(:,:) / e2v(:,:) 
    97          ENDIF 
    9885      ENDIF 
    9986 
    … …  
    10794            DO jj = 1, jpjm1 
    10895               DO ji = 1, fs_jpim1   ! vector opt. 
    109                   zabe1 = fsahtu(ji,jj,jk) * umask(ji,jj,jk) * e1ur(ji,jj) * fse3u(ji,jj,jk) 
    110                   zabe2 = fsahtv(ji,jj,jk) * vmask(ji,jj,jk) * e2vr(ji,jj) * fse3v(ji,jj,jk) 
     96                  zabe1 = fsahtu(ji,jj,jk) * umask(ji,jj,jk) * re2u_e1u(ji,jj) * fse3u_n(ji,jj,jk) 
     97                  zabe2 = fsahtv(ji,jj,jk) * vmask(ji,jj,jk) * re1v_e2v(ji,jj) * fse3v_n(ji,jj,jk) 
    11198                  ztu(ji,jj,jk) = zabe1 * ( ptb(ji+1,jj  ,jk,jn) - ptb(ji,jj,jk,jn) ) 
    11299                  ztv(ji,jj,jk) = zabe2 * ( ptb(ji  ,jj+1,jk,jn) - ptb(ji,jj,jk,jn) ) 
    … …  
    120107                     ikv = mbkv(ji,jj) 
    121108                     IF( iku == jk ) THEN 
    122                         zabe1 = fsahtu(ji,jj,iku) * umask(ji,jj,iku) * e1ur(ji,jj) * fse3u(ji,jj,iku) 
     109                        zabe1 = fsahtu(ji,jj,iku) * umask(ji,jj,iku) * re2u_e1u(ji,jj) * fse3u_n(ji,jj,iku) 
    123110                        ztu(ji,jj,jk) = zabe1 * pgu(ji,jj,jn) 
    124111                     ENDIF 
    125112                     IF( ikv == jk ) THEN 
    126                         zabe2 = fsahtv(ji,jj,ikv) * vmask(ji,jj,ikv) * e2vr(ji,jj) * fse3v(ji,jj,ikv) 
     113                        zabe2 = fsahtv(ji,jj,ikv) * vmask(ji,jj,ikv) * re1v_e2v(ji,jj) * fse3v_n(ji,jj,ikv) 
    127114                        ztv(ji,jj,jk) = zabe2 * pgv(ji,jj,jn) 
    128115                     ENDIF 
    … …  
    136123            DO jj = 2, jpjm1 
    137124               DO ji = fs_2, fs_jpim1   ! vector opt. 
    138                   zbtr = 1._wp / ( e1t(ji,jj) *e2t(ji,jj) * fse3t(ji,jj,jk) ) 
     125                  zbtr = 1._wp / ( e12t(ji,jj) * fse3t_n(ji,jj,jk) ) 
    139126                  ! horizontal diffusive trends added to the general tracer trends 
    140127                  pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + zbtr * (  ztu(ji,jj,jk) - ztu(ji-1,jj,jk)   & 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/TRA/traqsr.F90

    r4207 r4292  
    466466            ENDIF 
    467467 
    468             IF(lwp) WRITE(numout,*) '        level of light extinction = ', nksr, ' ref depth = ', gdepw_0(nksr+1), ' m' 
     468            IF(lwp) WRITE(numout,*) '        level of light extinction = ', nksr, ' ref depth = ', gdepw_1d(nksr+1), ' m' 
    469469            ! 
    470470            IF( nn_chldta == 1 ) THEN           !* Chl data : set sf_chl structure 
    … …  
    507507!CDIR NOVERRCHK    
    508508                        DO ji = 1, jpi 
    509                            zc0 = ze0(ji,jj,jk-1) * EXP( - fse3t_0(ji,jj,jk-1) * xsi0r     ) 
    510                            zc1 = ze1(ji,jj,jk-1) * EXP( - fse3t_0(ji,jj,jk-1) * zekb(ji,jj) ) 
    511                            zc2 = ze2(ji,jj,jk-1) * EXP( - fse3t_0(ji,jj,jk-1) * zekg(ji,jj) ) 
    512                            zc3 = ze3(ji,jj,jk-1) * EXP( - fse3t_0(ji,jj,jk-1) * zekr(ji,jj) ) 
     509                           zc0 = ze0(ji,jj,jk-1) * EXP( - e3t_0(ji,jj,jk-1) * xsi0r     ) 
     510                           zc1 = ze1(ji,jj,jk-1) * EXP( - e3t_0(ji,jj,jk-1) * zekb(ji,jj) ) 
     511                           zc2 = ze2(ji,jj,jk-1) * EXP( - e3t_0(ji,jj,jk-1) * zekg(ji,jj) ) 
     512                           zc3 = ze3(ji,jj,jk-1) * EXP( - e3t_0(ji,jj,jk-1) * zekr(ji,jj) ) 
    513513                           ze0(ji,jj,jk) = zc0 
    514514                           ze1(ji,jj,jk) = zc1 
    … …  
    536536            IF(lwp) THEN 
    537537               WRITE(numout,*) 
    538             IF(lwp) WRITE(numout,*) '        level of light extinction = ', nksr, ' ref depth = ', gdepw_0(nksr+1), ' m' 
     538            IF(lwp) WRITE(numout,*) '        level of light extinction = ', nksr, ' ref depth = ', gdepw_1d(nksr+1), ' m' 
    539539            ENDIF 
    540540            ! 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfini.F90

    r4147 r4292  
    154154      ELSE                                  ! Background profile of avt (fit a theoretical/observational profile (Krauss 1990) 
    155155         avmb(:) = rn_avm0 
    156          avtb(:) = rn_avt0 + ( 3.e-4_wp - 2._wp * rn_avt0 ) * 1.e-4_wp * gdepw_0(:)   ! m2/s 
     156         avtb(:) = rn_avt0 + ( 3.e-4_wp - 2._wp * rn_avt0 ) * 1.e-4_wp * gdepw_1d(:)   ! m2/s 
    157157         IF(ln_sco .AND. lwp)   CALL ctl_warn( 'avtb profile not valid in sco' ) 
    158158      ENDIF 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90

    r4289 r4292  
    385385                            CALL  istate_init   ! ocean initial state (Dynamics and tracers) 
    386386 
    387       IF( lk_tide       )   CALL tide_init( nit000 )    ! Initialisation of the tidal harmonics 
    388  
    389       IF( lk_bdy        )   CALL     bdy_init       ! Open boundaries initialisation 
    390       IF( lk_bdy        )   CALL     bdy_dta_init   ! Open boundaries initialisation of external data arrays 
    391       IF( lk_bdy        )   CALL     bdytide_init   ! Open boundaries initialisation of tidal harmonic forcing 
     387      IF( lk_tide       )   CALL    tide_init( nit000 )    ! Initialisation of the tidal harmonics 
     388 
     389      IF( lk_bdy        )   CALL      bdy_init  ! Open boundaries initialisation 
     390      IF( lk_bdy        )   CALL  bdy_dta_init  ! Open boundaries initialisation of external data arrays 
     391      IF( lk_bdy .AND. lk_tide )   & 
     392         &                  CALL  bdytide_init  ! Open boundaries initialisation of tidal harmonic forcing 
    392393 
    393394                            CALL dyn_nept_init  ! simplified form of Neptune effect 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/oce.F90

    r4205 r4292  
    2222   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   ub   ,  un    , ua     !: i-horizontal velocity        [m/s] 
    2323   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   vb   ,  vn    , va     !: j-horizontal velocity        [m/s] 
     24   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   ua_sv,  va_sv          !: Saved trends (time spliting) [m/s2] 
    2425   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::           wn             !: vertical velocity            [m/s] 
    2526   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   rotb ,  rotn           !: relative vorticity           [s-1] 
    … …  
    3637   !! ------------                                      !  fields  ! fields ! trends ! 
    3738   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET ::   sshb   , sshn   , ssha   !: sea surface height at t-point [m] 
    38    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)         ::   sshu_b , sshu_n , sshu_a !: sea surface height at u-point [m] 
    39    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)         ::   sshv_b , sshv_n , sshv_a !: sea surface height at u-point [m] 
    40    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)         ::            sshf_n          !: sea surface height at f-point [m] 
    4139   ! 
    4240   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   spgu, spgv               !: horizontal surface pressure gradient 
    … …  
    7674      ALLOCATE( ub   (jpi,jpj,jpk)      , un   (jpi,jpj,jpk)      , ua(jpi,jpj,jpk)       ,     & 
    7775         &      vb   (jpi,jpj,jpk)      , vn   (jpi,jpj,jpk)      , va(jpi,jpj,jpk)       ,     &       
     76         &      ua_sv(jpi,jpj,jpk)      , va_sv(jpi,jpj,jpk)      ,                             &       
    7877         &      wn   (jpi,jpj,jpk)      ,                                                       & 
    7978         &      rotb (jpi,jpj,jpk)      , rotn (jpi,jpj,jpk)      ,                             &    
    … …  
    8281         &      rn2b (jpi,jpj,jpk)      , rn2  (jpi,jpj,jpk)                              , STAT=ierr(1) ) 
    8382         ! 
    84       ALLOCATE( rhd (jpi,jpj,jpk) ,                                         & 
    85          &      rhop(jpi,jpj,jpk) ,                                         & 
    86          &      rke (jpi,jpj,jpk) ,                                         & 
    87          &      sshb  (jpi,jpj)   , sshn  (jpi,jpj) , ssha  (jpi,jpj) ,     & 
    88          &      sshu_b(jpi,jpj)   , sshu_n(jpi,jpj) , sshu_a(jpi,jpj) ,     & 
    89          &      sshv_b(jpi,jpj)   , sshv_n(jpi,jpj) , sshv_a(jpi,jpj) ,     & 
    90          &                          sshf_n(jpi,jpj) ,                       & 
    91          &      spgu  (jpi,jpj)   , spgv(jpi,jpj)   ,                       & 
    92          &      gtsu(jpi,jpj,jpts), gtsv(jpi,jpj,jpts),                     & 
    93          &      gru(jpi,jpj)      , grv(jpi,jpj)                      , STAT=ierr(2) ) 
     83      ALLOCATE(rhd (jpi,jpj,jpk) ,                                         & 
     84         &     rhop(jpi,jpj,jpk) ,                                         & 
     85         &     sshb  (jpi,jpj)   , sshn  (jpi,jpj) , ssha  (jpi,jpj) ,     & 
     86         &     spgu  (jpi,jpj)   , spgv(jpi,jpj)   ,                       & 
     87         &     gtsu(jpi,jpj,jpts), gtsv(jpi,jpj,jpts),                     & 
     88         &     gru(jpi,jpj)      , grv(jpi,jpj)                      , STAT=ierr(2) ) 
    9489         ! 
    9590      ALLOCATE( snwice_mass(jpi,jpj) , snwice_mass_b(jpi,jpj), snwice_fmass(jpi,jpj) , STAT=ierr(3) ) 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/step.F90

    r4230 r4292  
    9595      ! Update data, open boundaries, surface boundary condition (including sea-ice) 
    9696      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
     97      IF( lk_tide    )   CALL sbc_tide( kstp ) 
     98      IF( lk_obc     )   CALL obc_dta ( kstp )        ! update dynamic and tracer data at open boundaries 
     99      IF( lk_obc     )   CALL obc_rad ( kstp )        ! compute phase velocities at open boundaries 
     100      IF( lk_bdy     )   CALL bdy_dta ( kstp, time_offset=+1 )   ! update dynamic & tracer data at open boundaries 
     101 
    97102                         CALL sbc    ( kstp )         ! Sea Boundary Condition (including sea-ice) 
    98  
    99       IF( lk_tide.AND.(kstp /= nit000 ))   CALL tide_init ( kstp ) 
    100       IF( lk_tide    )   CALL sbc_tide( kstp ) 
    101       IF( lk_obc     )   CALL obc_dta( kstp )         ! update dynamic and tracer data at open boundaries 
    102       IF( lk_obc     )   CALL obc_rad( kstp )         ! compute phase velocities at open boundaries 
    103       IF( lk_bdy     )   CALL bdy_dta( kstp, time_offset=+1 ) ! update dynamic and tracer data at open boundaries 
    104  
    105       !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    106       !  Ocean dynamics : ssh, wn, hdiv, rot                                 ! 
    107       !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    108                          CALL ssh_wzv( kstp )         ! after ssh & vertical velocity 
     103                                                      ! clem: moved here for bdy ice purpose 
     104      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
     105      !  Ocean dynamics : hdiv, rot, ssh, e3, wn 
     106      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
     107                         CALL zdf_bfr( kstp )         ! bottom friction (if quadratic) 
     108                         CALL ssh_nxt       ( kstp )  ! after ssh (includes call to div_cur) 
     109      IF( lk_dynspg_ts ) THEN 
     110                                  CALL wzv           ( kstp )  ! now cross-level velocity  
     111          ! In case the time splitting case, update almost all momentum trends here: 
     112          ! Note that the computation of vertical velocity above, hence "after" sea level 
     113          ! is necessary to compute momentum advection for the rhs of barotropic loop: 
     114                                  CALL eos    ( tsn, rhd, rhop )                 ! now in situ density for hpg computation 
     115          IF( ln_zps      )       CALL zps_hde( kstp, jpts, tsn, gtsu, gtsv,  &  ! zps: now hor. derivative 
     116                &                                          rhd, gru , grv  )     ! of t, s, rd at the last ocean level 
     117 
     118                                  ua(:,:,:) = 0.e0             ! set dynamics trends to zero 
     119                                  va(:,:,:) = 0.e0 
     120          IF(  ln_asmiau .AND. & 
     121             & ln_dyninc       )  CALL dyn_asm_inc  ( kstp )   ! apply dynamics assimilation increment 
     122          IF( ln_neptsimp )       CALL dyn_nept_cor ( kstp )   ! subtract Neptune velocities (simplified) 
     123          IF( lk_bdy           )  CALL bdy_dyn3d_dmp( kstp )   ! bdy damping trends 
     124                                  CALL dyn_adv      ( kstp )   ! advection (vector or flux form) 
     125                                  CALL dyn_vor      ( kstp )   ! vorticity term including Coriolis 
     126                                  CALL dyn_ldf      ( kstp )   ! lateral mixing 
     127          IF( ln_neptsimp )       CALL dyn_nept_cor ( kstp )   ! add Neptune velocities (simplified) 
     128#if defined key_agrif 
     129          IF(.NOT. Agrif_Root())  CALL Agrif_Sponge_dyn        ! momentum sponge 
     130#endif 
     131                                  CALL dyn_hpg( kstp )         ! horizontal gradient of Hydrostatic pressure 
     132                                  CALL dyn_spg( kstp, indic )  ! surface pressure gradient 
     133 
     134                                  hdivb(:,:,:) = hdivn(:,:,:)  ! Store now divergence and rot temporarly, revert to these below  
     135                                  rotb(:,:,:)  = rotn(:,:,:)      
     136                                  ua_sv(:,:,:) = ua(:,:,:)     ! Save trends (barotropic trend has been fully updated) 
     137                                  va_sv(:,:,:) = va(:,:,:) 
     138 
     139                                  CALL div_cur( kstp )         ! Horizontal divergence & Relative vorticity (2nd call in time-split case) 
     140      ENDIF 
     141      IF( lk_vvl     )   CALL dom_vvl_sf_nxt( kstp )  ! after vertical scale factors 
     142                         CALL wzv           ( kstp )  ! now cross-level velocity (original) 
    109143 
    110144      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    … …  
    115149      ! 
    116150      !  VERTICAL PHYSICS 
    117                          CALL zdf_bfr( kstp )         ! bottom friction 
    118  
    119151      !                                               ! Vertical eddy viscosity and diffusivity coefficients 
    120152      IF( lk_zdfric  )   CALL zdf_ric( kstp )            ! Richardson number dependent Kz 
    … …  
    122154      IF( lk_zdfgls  )   CALL zdf_gls( kstp )            ! GLS closure scheme for Kz 
    123155      IF( lk_zdfkpp  )   CALL zdf_kpp( kstp )            ! KPP closure scheme for Kz 
    124       IF( lk_zdfcst  )   THEN                            ! Constant Kz (reset avt, avm[uv] to the background value) 
     156      IF( lk_zdfcst  ) THEN                              ! Constant Kz (reset avt, avm[uv] to the background value) 
    125157         avt (:,:,:) = rn_avt0 * tmask(:,:,:) 
    126158         avmu(:,:,:) = rn_avm0 * umask(:,:,:) 
    … …  
    146178      ! 
    147179      IF( lk_ldfslp ) THEN                            ! slope of lateral mixing 
    148                          CALL eos( tsb, rhd )                ! before in situ density 
     180                         CALL eos( tsb, rhd, gdept_0(:,:,:) )             ! before in situ density 
    149181         IF( ln_zps )    CALL zps_hde( kstp, jpts, tsb, gtsu, gtsv,  &    ! Partial steps: before horizontal gradient 
    150182            &                                      rhd, gru , grv  )      ! of t, s, rd at the last ocean level 
    … …  
    193225                             tsa(:,:,:,:) = 0.e0            ! set tracer trends to zero 
    194226 
    195 !write(numout,*) "MAV kt",kstp 
    196 !write(numout,'(a5,3(1x,f21.18))') "INIn:",tsn(24,11,1,jp_tem),tsn(24,11,1,jp_sal),sshn(24,11) 
    197 !write(numout,'(a5,3(1x,f21.18))') "INIa:",tsa(24,11,1,jp_tem),tsa(24,11,1,jp_sal),ssha(24,11) 
    198227      IF(  ln_asmiau .AND. & 
    199228         & ln_trainc     )   CALL tra_asm_inc( kstp )       ! apply tracer assimilation increment 
    … …  
    205234      IF( lk_bdy         )   CALL bdy_tra_dmp( kstp )       ! bdy damping trends 
    206235                             CALL tra_adv    ( kstp )       ! horizontal & vertical advection 
    207 !write(numout,'(a5,3(1x,f21.18))') "ADVn:",tsn(24,11,1,jp_tem),tsn(24,11,1,jp_sal),sshn(24,11) 
    208 !write(numout,'(a5,3(1x,f21.18))') "ADVa:",tsa(24,11,1,jp_tem),tsa(24,11,1,jp_sal),ssha(24,11) 
    209236      IF( lk_zdfkpp      )   CALL tra_kpp    ( kstp )       ! KPP non-local tracer fluxes 
    210237                             CALL tra_ldf    ( kstp )       ! lateral mixing 
    211 !write(numout,'(a5,3(1x,f21.18))') "LDFn:",tsn(24,11,1,jp_tem),tsn(24,11,1,jp_sal),sshn(24,11) 
    212 !write(numout,'(a5,3(1x,f21.18))') "LDFa:",tsa(24,11,1,jp_tem),tsa(24,11,1,jp_sal),ssha(24,11) 
    213238#if defined key_agrif 
    214239      IF(.NOT. Agrif_Root()) CALL Agrif_Sponge_tra          ! tracers sponge 
    215240#endif 
    216241                             CALL tra_zdf    ( kstp )       ! vertical mixing and after tracer fields 
    217 !do jk=1,jpk 
    218 !write(numout,'(a5,3(1x,f21.18))') "ZDFn:",tsn(5,10,jk,jp_tem),tsn(5,10,jk,jp_sal),tmask(5,10,jk) 
    219 !write(numout,'(a5,3(1x,f21.18))') "ZDFa:",tsa(5,10,jk,jp_tem),tsa(5,10,jk,jp_sal),ssha(5,10) 
    220 !end do 
    221242 
    222243      IF( ln_dynhpg_imp  ) THEN                             ! semi-implicit hpg (time stepping then eos) 
    223244         IF( ln_zdfnpc   )   CALL tra_npc( kstp )                ! update after fields by non-penetrative convection 
    224245                             CALL tra_nxt( kstp )                ! tracer fields at next time step 
    225                              CALL eos    ( tsa, rhd, rhop )      ! Time-filtered in situ density for hpg computation 
     246                             CALL eos    ( tsa, rhd, rhop, fsdept_n(:,:,:) )  ! Time-filtered in situ density for hpg computation 
    226247         IF( ln_zps      )   CALL zps_hde( kstp, jpts, tsa, gtsu, gtsv,  &    ! zps: time filtered hor. derivative 
    227248            &                                          rhd, gru , grv  )      ! of t, s, rd at the last ocean level 
    228249 
    229250      ELSE                                                  ! centered hpg  (eos then time stepping) 
    230                              CALL eos    ( tsn, rhd, rhop )      ! now in situ density for hpg computation 
    231          IF( ln_zps      )   CALL zps_hde( kstp, jpts, tsn, gtsu, gtsv,  &    ! zps: now hor. derivative 
     251         IF ( .NOT. lk_dynspg_ts ) THEN                     ! eos already called in time-split case 
     252                                CALL eos    ( tsn, rhd, rhop, fsdept_n(:,:,:) )  ! now in situ density for hpg computation 
     253            IF( ln_zps      )   CALL zps_hde( kstp, jpts, tsn, gtsu, gtsv,  &    ! zps: now hor. derivative 
    232254            &                                          rhd, gru , grv  )      ! of t, s, rd at the last ocean level 
    233 !write(numout,'(a5,3(1x,f21.18))') "ZPSn:",tsn(24,11,1,jp_tem),tsn(24,11,1,jp_sal),sshn(24,11) 
    234 !write(numout,'(a5,3(1x,f21.18))') "ZPSa:",tsa(24,11,1,jp_tem),tsa(24,11,1,jp_sal),ssha(24,11) 
     255         ENDIF 
    235256         IF( ln_zdfnpc   )   CALL tra_npc( kstp )                ! update after fields by non-penetrative convection 
    236257                             CALL tra_nxt( kstp )                ! tracer fields at next time step 
    237 !write(numout,'(a5,3(1x,f21.18))') "NXTn:",tsn(24,11,1,jp_tem),tsn(24,11,1,jp_sal),sshn(25,11) 
    238 !write(numout,'(a5,3(1x,f21.18))') "NXTa:",tsa(24,11,1,jp_tem),tsa(24,11,1,jp_sal),ssha(24,11) 
    239258      ENDIF 
    240259 
    … …  
    242261      ! Dynamics                                    (tsa used as workspace) 
    243262      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
     263      IF( lk_dynspg_ts   )  THEN 
     264                                                             ! revert to previously computed momentum tendencies 
     265                                                             ! (not using ua, va as temporary arrays during tracers' update could avoid that) 
     266                               ua(:,:,:) = ua_sv(:,:,:) 
     267                               va(:,:,:) = va_sv(:,:,:) 
     268                                                             ! Revert now divergence and rotational to previously computed ones  
     269                                                             !(needed because of the time swap in div_cur, at the beginning of each time step) 
     270                               hdivn(:,:,:) = hdivb(:,:,:) 
     271                               rotn(:,:,:)  = rotb(:,:,:)  
     272 
     273                               CALL dyn_bfr( kstp )         ! bottom friction 
     274                               CALL dyn_zdf( kstp )         ! vertical diffusion 
     275      ELSE 
    244276                               ua(:,:,:) = 0.e0             ! set dynamics trends to zero 
    245277                               va(:,:,:) = 0.e0 
    246278 
    247       IF(  ln_asmiau .AND. & 
    248          & ln_dyninc       )   CALL dyn_asm_inc( kstp )     ! apply dynamics assimilation increment 
    249       IF( ln_bkgwri )          CALL asm_bkg_wri( kstp )     ! output background fields 
    250       IF( ln_neptsimp )        CALL dyn_nept_cor( kstp )    ! subtract Neptune velocities (simplified) 
    251       IF( lk_bdy           )   CALL bdy_dyn3d_dmp(kstp )    ! bdy damping trends 
     279        IF(  ln_asmiau .AND. & 
     280           & ln_dyninc      )  CALL dyn_asm_inc( kstp )     ! apply dynamics assimilation increment 
     281        IF( ln_bkgwri )        CALL asm_bkg_wri( kstp )     ! output background fields 
     282        IF( ln_neptsimp )      CALL dyn_nept_cor( kstp )    ! subtract Neptune velocities (simplified) 
     283        IF( lk_bdy          )  CALL bdy_dyn3d_dmp(kstp )    ! bdy damping trends 
    252284                               CALL dyn_adv( kstp )         ! advection (vector or flux form) 
    253285                               CALL dyn_vor( kstp )         ! vorticity term including Coriolis 
    254286                               CALL dyn_ldf( kstp )         ! lateral mixing 
    255       IF( ln_neptsimp )        CALL dyn_nept_cor( kstp )    ! add Neptune velocities (simplified) 
    256 #if defined key_agrif 
    257       IF(.NOT. Agrif_Root())  CALL Agrif_Sponge_dyn        ! momemtum sponge 
     287        IF( ln_neptsimp )      CALL dyn_nept_cor( kstp )    ! add Neptune velocities (simplified) 
     288#if defined key_agrif 
     289        IF(.NOT. Agrif_Root()) CALL Agrif_Sponge_dyn        ! momemtum sponge 
    258290#endif 
    259291                               CALL dyn_hpg( kstp )         ! horizontal gradient of Hydrostatic pressure 
    … …  
    261293                               CALL dyn_zdf( kstp )         ! vertical diffusion 
    262294                               CALL dyn_spg( kstp, indic )  ! surface pressure gradient 
     295      ENDIF 
    263296                               CALL dyn_nxt( kstp )         ! lateral velocity at next time step 
    264297 
    265                                CALL ssh_nxt( kstp )         ! sea surface height at next time step 
     298                               CALL ssh_swp( kstp )         ! swap of sea surface height 
     299      IF( lk_vvl           )   CALL dom_vvl_sf_swp( kstp )  ! swap of vertical scale factors 
    266300 
    267301      IF( ln_diahsb        )   CALL dia_hsb( kstp )         ! - ML - global conservation diagnostics 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/step_oce.F90

    r4152 r4292  
    1111   USE ldftra_oce       ! ocean tracer   - trends 
    1212   USE ldfdyn_oce       ! ocean dynamics - trends 
     13   USE divcur           ! hor. divergence and curl      (div & cur routines) 
    1314   USE in_out_manager   ! I/O manager 
    1415   USE iom              ! 
    … …  
    6465   USE bdydyn3d         ! bdy cond. for baroclinic vel.  (bdy_dyn3d routine) 
    6566 
    66    USE sshwzv           ! vertical velocity and ssh        (ssh_wzv routine) 
     67   USE sshwzv           ! vertical velocity and ssh        (ssh_nxt routine) 
     68   !                                                       (ssh_swp routine) 
     69   !                                                       (wzv     routine) 
     70   USE domvvl           ! variable vertical scale factors  (dom_vvl_sf_nxt routine) 
     71   !                                                       (dom_vvl_sf_swp routine) 
    6772 
    6873   USE ldfslp           ! iso-neutral slopes               (ldf_slp routine) 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/SAS_SRC/diawri.F90

    r4148 r4292  
    220220            &          nit000-1, zjulian, zdt, nh_T, nid_T, domain_id=nidom, snc4chunks=snc4set ) 
    221221         CALL histvert( nid_T, "deptht", "Vertical T levels",      &  ! Vertical grid: gdept 
    222             &           "m", ipk, gdept_0, nz_T, "down" ) 
     222            &           "m", ipk, gdept_1d, nz_T, "down" ) 
    223223         !                                                            ! Index of ocean points 
    224224         CALL wheneq( jpi*jpj    , tmask, 1, 1., ndex_hT, ndim_hT )      ! surface 
    … …  
    232232            &          nit000-1, zjulian, zdt, nh_U, nid_U, domain_id=nidom, snc4chunks=snc4set ) 
    233233         CALL histvert( nid_U, "depthu", "Vertical U levels",      &  ! Vertical grid: gdept 
    234             &           "m", ipk, gdept_0, nz_U, "down" ) 
     234            &           "m", ipk, gdept_1d, nz_U, "down" ) 
    235235         !                                                            ! Index of ocean points 
    236236         CALL wheneq( jpi*jpj    , umask, 1, 1., ndex_hU, ndim_hU )      ! surface 
    … …  
    244244            &          nit000-1, zjulian, zdt, nh_V, nid_V, domain_id=nidom, snc4chunks=snc4set ) 
    245245         CALL histvert( nid_V, "depthv", "Vertical V levels",      &  ! Vertical grid : gdept 
    246             &          "m", ipk, gdept_0, nz_V, "down" ) 
     246            &          "m", ipk, gdept_1d, nz_V, "down" ) 
    247247         !                                                            ! Index of ocean points 
    248248         CALL wheneq( jpi*jpj    , vmask, 1, 1., ndex_hV, ndim_hV )      ! surface 
    … …  
    394394          1, jpi, 1, jpj, nit000-1, zjulian, zdt, nh_i, id_i, domain_id=nidom, snc4chunks=snc4set ) ! Horizontal grid : glamt and gphit 
    395395      CALL histvert( id_i, "deptht", "Vertical T levels",   &    ! Vertical grid : gdept 
    396           "m", jpk, gdept_0, nz_i, "down") 
     396          "m", jpk, gdept_1d, nz_i, "down") 
    397397 
    398398      ! Declare all the output fields as NetCDF variables 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/TOP_SRC/C14b/trcwri_c14b.F90

    r3680 r4292  
    3636      DO jn = jp_c14b0, jp_c14b1 
    3737         cltra = TRIM( ctrcnm(jn) )                  ! short title for tracer 
    38          CALL iom_put( cltra, trn(:,:,:,jn) ) 
     38         IF( lk_vvl ) THEN 
     39            CALL iom_put( cltra, trn(:,:,:,jn) * fse3t_n(:,:,:) ) 
     40         ELSE 
     41            CALL iom_put( cltra, trn(:,:,:,jn) ) 
     42         ENDIF 
    3943      END DO 
    4044      ! 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/TOP_SRC/CFC/trcwri_cfc.F90

    r3680 r4292  
    3636      DO jn = jp_cfc0, jp_cfc1 
    3737         cltra = TRIM( ctrcnm(jn) )                  ! short title for tracer 
    38          CALL iom_put( cltra, trn(:,:,:,jn) ) 
     38         IF( lk_vvl ) THEN 
     39            CALL iom_put( cltra, trn(:,:,:,jn) * fse3t_n(:,:,:) ) 
     40         ELSE 
     41            CALL iom_put( cltra, trn(:,:,:,jn) ) 
     42         ENDIF 
    3943      END DO 
    4044      ! 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/TOP_SRC/MY_TRC/trcwri_my_trc.F90

    r3680 r4292  
    3636      DO jn = jp_myt0, jp_myt1 
    3737         cltra = TRIM( ctrcnm(jn) )                  ! short title for tracer 
    38          CALL iom_put( cltra, trn(:,:,:,jn) ) 
     38         IF( lk_vvl ) THEN 
     39            CALL iom_put( cltra, trn(:,:,:,jn) * fse3t_n(:,:,:) ) 
     40         ELSE 
     41            CALL iom_put( cltra, trn(:,:,:,jn) ) 
     42         ENDIF 
    3943      END DO 
    4044      ! 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zopt.F90

    r4147 r4292  
    371371      nksrp = trc_oce_ext_lev( r_si2, 0.33e2 )     ! max level of light extinction (Blue Chl=0.01) 
    372372      ! 
    373       IF(lwp) WRITE(numout,*) '        level of light extinction = ', nksrp, ' ref depth = ', gdepw_0(nksrp+1), ' m' 
     373      IF(lwp) WRITE(numout,*) '        level of light extinction = ', nksrp, ' ref depth = ', gdepw_1d(nksrp+1), ' m' 
    374374      ! 
    375375                         etot (:,:,:) = 0._wp 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/TOP_SRC/PISCES/SED/sed.F90

    r3443 r4292  
    1919   USE dom_oce , ONLY :   glamt     =>   glamt          !: longitude of t-point (degre) 
    2020   USE dom_oce , ONLY :   gphit     =>   gphit          !: latitude  of t-point (degre) 
    21    USE dom_oce , ONLY :   e3t_0     =>   e3t_0          !: reference depth of t-points (m) 
     21   USE dom_oce , ONLY :   e3t_1d    =>   e3t_1d         !: reference depth of t-points (m) 
    2222   USE dom_oce , ONLY :   mbkt      =>   mbkt           !: vertical index of the bottom last T- ocean level 
    2323   USE dom_oce , ONLY :   tmask     =>   tmask          !: land/ocean mask at t-points 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/TOP_SRC/PISCES/SED/sedini.F90

    r3443 r4292  
    142142         DO ji = 1, jpi 
    143143            ikt = mbkt(ji,jj)  
    144             IF( tmask(ji,jj,ikt) == 1 ) epkbot(ji,jj) = e3t_0(ikt) 
     144            IF( tmask(ji,jj,ikt) == 1 ) epkbot(ji,jj) = e3t_1d(ikt) 
    145145         ENDDO 
    146146      ENDDO 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/TOP_SRC/PISCES/trcwri_pisces.F90

    r3680 r4292  
    2121   PUBLIC trc_wri_pisces  
    2222 
     23#  include "top_substitute.h90" 
    2324CONTAINS 
    2425 
    … …  
    3940      DO jn = jp_pcs0, jp_pcs1 
    4041         cltra = TRIM( ctrcnm(jn) )                  ! short title for tracer 
     42         IF( lk_vvl ) THEN 
     43            CALL iom_put( cltra, trn(:,:,:,jn) * fse3t_n(:,:,:) ) 
     44         ELSE 
     45            CALL iom_put( cltra, trn(:,:,:,jn) ) 
     46         ENDIF 
    4147         CALL iom_put( cltra, trn(:,:,:,jn) * zrfact ) 
    4248      END DO 
    … …  
    4753         IF( jn == jppo4  )                 zrfact = po4r * 1.0e+6 
    4854         cltra = TRIM( ctrcnm(jn) )                  ! short title for tracer 
    49          CALL iom_put( cltra, trn(:,:,:,jn) * zrfact ) 
     55         IF( lk_vvl ) THEN 
     56            CALL iom_put( cltra, trn(:,:,:,jn) * fse3t_n(:,:,:) * zrfact ) 
     57         ELSE 
     58            CALL iom_put( cltra, trn(:,:,:,jn) * zrfact ) 
     59         ENDIF 
    5060      END DO 
    5161#endif 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/TOP_SRC/oce_trc.F90

    r4148 r4292  
    7070   USE oce , ONLY :   sshb    =>    sshb    !: sea surface height at t-point [m]    
    7171   USE oce , ONLY :   ssha    =>    ssha    !: sea surface height at t-point [m]    
    72    USE oce , ONLY :   sshu_n  =>    sshu_n  !: sea surface height at u-point [m]    
    73    USE oce , ONLY :   sshu_b  =>    sshu_b  !: sea surface height at u-point [m]    
    74    USE oce , ONLY :   sshu_a  =>    sshu_a  !: sea surface height at u-point [m]    
    75    USE oce , ONLY :   sshv_n  =>    sshv_n  !: sea surface height at v-point [m]    
    76    USE oce , ONLY :   sshv_b  =>    sshv_b  !: sea surface height at v-point [m]    
    77    USE oce , ONLY :   sshv_a  =>    sshv_a  !: sea surface height at v-point [m]    
    78    USE oce , ONLY :   sshf_n  =>    sshf_n  !: sea surface height at v-point [m]    
    7972   USE oce , ONLY :   l_traldf_rot => l_traldf_rot  !: rotated laplacian operator for lateral diffusion 
    8073#if defined key_offline 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/TOP_SRC/trcdia.F90

    r3294 r4292  
    187187 
    188188         ! Vertical grid for tracer : gdept 
    189          CALL histvert( nit5, 'deptht', 'Vertical T levels', 'm', ipk, gdept_0, ndepit5) 
     189         CALL histvert( nit5, 'deptht', 'Vertical T levels', 'm', ipk, gdept_1d, ndepit5) 
    190190 
    191191         ! Index of ocean points in 3D and 2D (surface) 
    … …  
    308308         ! Vertical grid for 2d and 3d arrays 
    309309 
    310          CALL histvert( nitd, 'deptht', 'Vertical T levels','m', ipk, gdept_0, ndepitd) 
     310         CALL histvert( nitd, 'deptht', 'Vertical T levels','m', ipk, gdept_1d, ndepitd) 
    311311 
    312312         ! Declare all the output fields as NETCDF variables 
    … …  
    439439            &    iiter, zjulian, zdt, nhoritb, nitb , domain_id=nidom, snc4chunks=snc4set ) 
    440440         ! Vertical grid for biological trends 
    441          CALL histvert(nitb, 'deptht', 'Vertical T levels', 'm', ipk, gdept_0, ndepitb) 
     441         CALL histvert(nitb, 'deptht', 'Vertical T levels', 'm', ipk, gdept_1d, ndepitb) 
    442442 
    443443         ! Declare all the output fields as NETCDF variables 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/TOP_SRC/trcdta.F90

    r4230 r4292  
    188188                  DO ji = 1, jpi 
    189189                     DO jk = 1, jpk                        ! determines the intepolated T-S profiles at each (i,j) points 
    190                         zl = fsdept_0(ji,jj,jk) 
    191                         IF(     zl < gdept_0(1  ) ) THEN          ! above the first level of data 
     190                        zl = fsdept_n(ji,jj,jk) 
     191                        IF(     zl < gdept_1d(1  ) ) THEN         ! above the first level of data 
    192192                           ztp(jk) =  sf_dta(1)%fnow(ji,jj,1) 
    193                         ELSEIF( zl > gdept_0(jpk) ) THEN          ! below the last level of data 
     193                        ELSEIF( zl > gdept_1d(jpk) ) THEN         ! below the last level of data 
    194194                           ztp(jk) =  sf_dta(1)%fnow(ji,jj,jpkm1) 
    195195                        ELSE                                      ! inbetween : vertical interpolation between jkk & jkk+1 
    196196                           DO jkk = 1, jpkm1                                  ! when  gdept(jkk) < zl < gdept(jkk+1) 
    197                               IF( (zl-gdept_0(jkk)) * (zl-gdept_0(jkk+1)) <= 0._wp ) THEN 
    198                                  zi = ( zl - gdept_0(jkk) ) / (gdept_0(jkk+1)-gdept_0(jkk)) 
     197                              IF( (zl-gdept_1d(jkk)) * (zl-gdept_1d(jkk+1)) <= 0._wp ) THEN 
     198                                 zi = ( zl - gdept_1d(jkk) ) / (gdept_1d(jkk+1)-gdept_1d(jkk)) 
    199199                                 ztp(jk) = sf_dta(1)%fnow(ji,jj,jkk) + ( sf_dta(1)%fnow(ji,jj,jkk+1) - & 
    200200                                           sf_dta(1)%fnow(ji,jj,jkk) ) * zi  
    … …  
    219219                        ik = mbkt(ji,jj)  
    220220                        IF( ik > 1 ) THEN 
    221                            zl = ( gdept_0(ik) - fsdept_0(ji,jj,ik) ) / ( gdept_0(ik) - gdept_0(ik-1) ) 
     221                           zl = ( gdept_1d(ik) - fsdept_n(ji,jj,ik) ) / ( gdept_1d(ik) - gdept_1d(ik-1) ) 
    222222                           sf_dta(1)%fnow(ji,jj,ik) = (1.-zl) * sf_dta(1)%fnow(ji,jj,ik) + zl * sf_dta(1)%fnow(ji,jj,ik-1) 
    223223                        ENDIF 

  • branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/TOP_SRC/trcsub.F90

    r4148 r4292  
    7979           ! 
    8080           sshb_hold  (:,:) = sshn  (:,:) 
    81            sshu_b_hold(:,:) = sshu_n(:,:) 
    82            sshv_b_hold(:,:) = sshv_n(:,:) 
     81!!Z~       sshu_b_hold(:,:) = sshu_n(:,:) 
     82!!Z~       sshv_b_hold(:,:) = sshv_n(:,:) 
    8383           emp_b_hold (:,:) = emp_b (:,:) 
    8484           ! 
    … …  
    117117          ! 
    118118          sshn_tm  (:,:)         = sshn_tm  (:,:)         + sshn  (:,:)  
    119           sshu_n_tm(:,:)         = sshu_n_tm(:,:)         + sshu_n(:,:)  
    120           sshv_n_tm(:,:)         = sshv_n_tm(:,:)         + sshv_n(:,:)  
     119!!Z~      sshu_n_tm(:,:)         = sshu_n_tm(:,:)         + sshu_n(:,:)  
     120!!Z~      sshv_n_tm(:,:)         = sshv_n_tm(:,:)         + sshv_n(:,:)  
    121121          rnf_tm   (:,:)         = rnf_tm   (:,:)         + rnf   (:,:)  
    122122          h_rnf_tm (:,:)         = h_rnf_tm (:,:)         + h_rnf (:,:)  
    … …  
    197197# endif 
    198198         sshn_temp  (:,:)        = sshn  (:,:) 
    199          sshu_n_temp(:,:)        = sshu_n(:,:) 
    200          sshv_n_temp(:,:)        = sshv_n(:,:) 
    201          sshf_n_temp(:,:)        = sshf_n(:,:) 
     199!!Z~     sshu_n_temp(:,:)        = sshu_n(:,:) 
     200!!Z~     sshv_n_temp(:,:)        = sshv_n(:,:) 
     201!!Z~     sshf_n_temp(:,:)        = sshf_n(:,:) 
    202202         sshb_temp  (:,:)        = sshb  (:,:) 
    203          sshu_b_temp(:,:)        = sshu_b(:,:) 
    204          sshv_b_temp(:,:)        = sshv_b(:,:) 
     203!!Z~     sshu_b_temp(:,:)        = sshu_b(:,:) 
     204!!Z~     sshv_b_temp(:,:)        = sshv_b(:,:) 
    205205         ssha_temp  (:,:)        = ssha  (:,:) 
    206          sshu_a_temp(:,:)        = sshu_a(:,:) 
    207          sshv_a_temp(:,:)        = sshv_a(:,:) 
     206!!Z~     sshu_a_temp(:,:)        = sshu_a(:,:) 
     207!!Z~     sshv_a_temp(:,:)        = sshv_a(:,:) 
    208208         rnf_temp   (:,:)        = rnf   (:,:) 
    209209         h_rnf_temp (:,:)        = h_rnf (:,:) 
    … …  
    309309# endif 
    310310         sshn_tm  (:,:)          = sshn_tm    (:,:)       + sshn  (:,:)  
    311          sshu_n_tm(:,:)          = sshu_n_tm  (:,:)       + sshu_n(:,:)  
    312          sshv_n_tm(:,:)          = sshv_n_tm  (:,:)       + sshv_n(:,:)  
     311!!Z~     sshu_n_tm(:,:)          = sshu_n_tm  (:,:)       + sshu_n(:,:)  
     312!!Z~     sshv_n_tm(:,:)          = sshv_n_tm  (:,:)       + sshv_n(:,:)  
    313313         rnf_tm   (:,:)          = rnf_tm     (:,:)       + rnf   (:,:)  
    314314         h_rnf_tm (:,:)          = h_rnf_tm   (:,:)       + h_rnf (:,:)  
    … …  
    321321         ! 
    322322         sshn     (:,:)          = sshn_tm    (:,:) * r1_ndttrcp1  
    323          sshu_n   (:,:)          = sshu_n_tm  (:,:) * r1_ndttrcp1   
    324          sshv_n   (:,:)          = sshv_n_tm  (:,:) * r1_ndttrcp1   
     323!!Z~     sshu_n   (:,:)          = sshu_n_tm  (:,:) * r1_ndttrcp1   
     324!!Z~     sshv_n   (:,:)          = sshv_n_tm  (:,:) * r1_ndttrcp1   
    325325         sshb     (:,:)          = sshb_hold  (:,:) 
    326          sshu_b   (:,:)          = sshu_b_hold(:,:) 
    327          sshv_b   (:,:)          = sshv_b_hold(:,:) 
     326!!Z~     sshu_b   (:,:)          = sshu_b_hold(:,:) 
     327!!Z~     sshv_b   (:,:)          = sshv_b_hold(:,:) 
    328328         rnf      (:,:)          = rnf_tm     (:,:) * r1_ndttrcp1  
    329329         h_rnf    (:,:)          = h_rnf_tm   (:,:) * r1_ndttrcp1  
    … …  
    486486#endif 
    487487         CALL lbc_lnk( sshn  (:,:)         , 'T', 1. )  
    488          CALL lbc_lnk( sshu_n(:,:)         , 'U', 1. )  
    489          CALL lbc_lnk( sshv_n(:,:)         , 'V', 1. )  
    490          CALL lbc_lnk( sshf_n(:,:)         , 'F', 1. )  
     488!!Z~     CALL lbc_lnk( sshu_n(:,:)         , 'U', 1. )  
     489!!Z~     CALL lbc_lnk( sshv_n(:,:)         , 'V', 1. )  
     490!!Z~     CALL lbc_lnk( sshf_n(:,:)         , 'F', 1. )  
    491491         CALL lbc_lnk( sshb  (:,:)         , 'T', 1. )  
    492          CALL lbc_lnk( sshu_b(:,:)         , 'U', 1. )  
    493          CALL lbc_lnk( sshv_b(:,:)         , 'V', 1. )  
     492!!Z~     CALL lbc_lnk( sshu_b(:,:)         , 'U', 1. )  
     493!!Z~     CALL lbc_lnk( sshv_b(:,:)         , 'V', 1. )  
    494494         CALL lbc_lnk( ssha  (:,:)         , 'T', 1. )  
    495          CALL lbc_lnk( sshu_a(:,:)         , 'U', 1. )  
    496          CALL lbc_lnk( sshv_a(:,:)         , 'V', 1. )  
     495!!Z~     CALL lbc_lnk( sshu_a(:,:)         , 'U', 1. )  
     496!!Z~     CALL lbc_lnk( sshv_a(:,:)         , 'V', 1. )  
    497497         CALL lbc_lnk( rnf   (:,:)         , 'T', 1. )  
    498498         CALL lbc_lnk( h_rnf (:,:)         , 'T', 1. )  
    … …  
    592592#endif 
    593593      sshn_tm  (:,:) = sshn  (:,:)  
    594       sshu_n_tm(:,:) = sshu_n(:,:)  
    595       sshv_n_tm(:,:) = sshv_n(:,:)  
     594!!Z~  sshu_n_tm(:,:) = sshu_n(:,:)  
     595!!Z~  sshv_n_tm(:,:) = sshv_n(:,:)  
    596596      rnf_tm   (:,:) = rnf   (:,:)  
    597597      h_rnf_tm (:,:) = h_rnf (:,:)  
    … …  
    695695      sshb  (:,:)     =  sshb_temp  (:,:) 
    696696      ssha  (:,:)     =  ssha_temp  (:,:) 
    697       sshu_n(:,:)     =  sshu_n_temp(:,:) 
    698       sshu_b(:,:)     =  sshu_b_temp(:,:) 
    699       sshu_a(:,:)     =  sshu_a_temp(:,:) 
    700       sshv_n(:,:)     =  sshv_n_temp(:,:) 
    701       sshv_b(:,:)     =  sshv_b_temp(:,:) 
    702       sshv_a(:,:)     =  sshv_a_temp(:,:) 
    703       sshf_n(:,:)     =  sshf_n_temp(:,:) 
     697!!Z~  sshu_n(:,:)     =  sshu_n_temp(:,:) 
     698!!Z~  sshu_b(:,:)     =  sshu_b_temp(:,:) 
     699!!Z~  sshu_a(:,:)     =  sshu_a_temp(:,:) 
     700!!Z~  sshv_n(:,:)     =  sshv_n_temp(:,:) 
     701!!Z~  sshv_b(:,:)     =  sshv_b_temp(:,:) 
     702!!Z~  sshv_a(:,:)     =  sshv_a_temp(:,:) 
     703!!Z~  sshf_n(:,:)     =  sshf_n_temp(:,:) 
    704704      rnf   (:,:)     =  rnf_temp   (:,:) 
    705705      h_rnf (:,:)     =  h_rnf_temp (:,:) 
    … …  
    816816      ! 
    817817      sshb_hold  (:,:) = sshn  (:,:) 
    818       sshu_b_hold(:,:) = sshu_n(:,:) 
    819       sshv_b_hold(:,:) = sshv_n(:,:) 
     818!!Z~  sshu_b_hold(:,:) = sshu_n(:,:) 
     819!!Z~  sshv_b_hold(:,:) = sshv_n(:,:) 
    820820      emp_b_hold (:,:) = emp   (:,:) 
    821821      sshn_tm    (:,:) = sshn  (:,:)  
    822       sshu_n_tm  (:,:) = sshu_n(:,:)  
    823       sshv_n_tm  (:,:) = sshv_n(:,:)  
     822!!Z~  sshu_n_tm  (:,:) = sshu_n(:,:)  
     823!!Z~  sshv_n_tm  (:,:) = sshv_n(:,:)  
    824824      rnf_tm     (:,:) = rnf   (:,:)  
    825825      h_rnf_tm   (:,:) = h_rnf (:,:)  
    … …  
    951951         END DO 
    952952         ! 
    953          hu(:,:) = hu_0(:,:) + sshu_n(:,:)            ! now ocean depth (at u- and v-points) 
    954          hv(:,:) = hv_0(:,:) + sshv_n(:,:) 
     953!!Z~     hu(:,:) = hu_0(:,:) + sshu_n(:,:)            ! now ocean depth (at u- and v-points) 
     954!!Z~     hv(:,:) = hv_0(:,:) + sshv_n(:,:) 
    955955         !                                            ! now masked inverse of the ocean depth (at u- and v-points) 
    956956         hur(:,:) = umask(:,:,1) / ( hu(:,:) + 1._wp - umask(:,:,1) ) 
    … …  
    992992 
    993993      !                                                ! Sea Surface Height at u-,v- and f-points (vvl case only) 
    994       IF( lk_vvl ) THEN                                ! (required only in key_vvl case) 
    995          DO jj = 1, jpjm1 
    996             DO ji = 1, jpim1      ! NO Vector Opt. 
    997                sshu_a(ji,jj) = 0.5  * umask(ji,jj,1) / ( e1u(ji  ,jj) * e2u(ji  ,jj) )                   & 
    998                   &                                  * ( e1t(ji  ,jj) * e2t(ji  ,jj) * ssha(ji  ,jj)     & 
    999                   &                                    + e1t(ji+1,jj) * e2t(ji+1,jj) * ssha(ji+1,jj) ) 
    1000                sshv_a(ji,jj) = 0.5  * vmask(ji,jj,1) / ( e1v(ji,jj  ) * e2v(ji,jj  ) )                   & 
    1001                   &                                  * ( e1t(ji,jj  ) * e2t(ji,jj  ) * ssha(ji,jj  )     & 
    1002                   &                                    + e1t(ji,jj+1) * e2t(ji,jj+1) * ssha(ji,jj+1) ) 
    1003             END DO 
    1004          END DO 
    1005          CALL lbc_lnk( sshu_a, 'U', 1. )   ;   CALL lbc_lnk( sshv_a, 'V', 1. )      ! Boundaries conditions 
    1006       ENDIF 
     994!!Z~  IF( lk_vvl ) THEN                                ! (required only in key_vvl case) 
     995!!Z~     DO jj = 1, jpjm1 
     996!!Z~        DO ji = 1, jpim1      ! NO Vector Opt. 
     997!!Z~           sshu_a(ji,jj) = 0.5  * umask(ji,jj,1) / ( e1u(ji  ,jj) * e2u(ji  ,jj) )                   & 
     998!!Z~              &                                  * ( e1t(ji  ,jj) * e2t(ji  ,jj) * ssha(ji  ,jj)     & 
     999!!Z~              &                                    + e1t(ji+1,jj) * e2t(ji+1,jj) * ssha(ji+1,jj) ) 
     1000!!Z~           sshv_a(ji,jj) = 0.5  * vmask(ji,jj,1) / ( e1v(ji,jj  ) * e2v(ji,jj  ) )                   & 
     1001!!Z~              &                                  * ( e1t(ji,jj  ) * e2t(ji,jj  ) * ssha(ji,jj  )     & 
     1002!!Z~              &                                    + e1t(ji,jj+1) * e2t(ji,jj+1) * ssha(ji,jj+1) ) 
     1003!!Z~        END DO 
     1004!!Z~     END DO 
     1005!!Z~     CALL lbc_lnk( sshu_a, 'U', 1. )   ;   CALL lbc_lnk( sshv_a, 'V', 1. )      ! Boundaries conditions 
     1006!!Z~  ENDIF 
    10071007       
    10081008 
Note: See TracChangeset for help on using the changeset viewer.