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 12624 for NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/DOM/domqe.F90 – NEMO

Ignore:
Timestamp:
2020-03-29T12:55:27+02:00 (4 years ago)
Author:
techene
Message:

all: add e3 substitute and limit precompiled files lines to about 130 character, change key_LF into key_QCO, change module name (dynatfQCO, traatfQCO, stepLF)

File:
1 edited

Legend:

Unmodified
Added
Removed
  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/DOM/domqe.F90

    r12584 r12624  
    4444   PUBLIC  dom_qe_sf_nxt     ! called by steplf.F90 
    4545   PUBLIC  dom_qe_sf_update  ! called by steplf.F90 
    46    PUBLIC  dom_qe_interpol   ! called by dynnxt.F90 
     46   PUBLIC  dom_h_nxt         ! called by steplf.F90 
    4747   PUBLIC  dom_qe_r3c        ! called by steplf.F90 
    4848 
     
    292292 
    293293 
     294   SUBROUTINE dom_h_nxt( kt, Kbb, Kmm, Kaa, kcall ) 
     295      !!---------------------------------------------------------------------- 
     296      !!                ***  ROUTINE dom_qe_sf_nxt  *** 
     297      !! 
     298      !! ** Purpose :  - compute the after water heigh used in tra_zdf, dynnxt, 
     299      !!                 tranxt and dynspg routines 
     300      !! 
     301      !! ** Method  :  - z_star case:  Proportionnaly to the water column thickness. 
     302      !! 
     303      !! ** Action  :  - h(u/v) update wrt ssh/h(u/v)_0 
     304      !! 
     305      !!---------------------------------------------------------------------- 
     306      INTEGER, INTENT( in )           ::   kt             ! time step 
     307      INTEGER, INTENT( in )           ::   Kbb, Kmm, Kaa  ! time step 
     308      INTEGER, INTENT( in ), OPTIONAL ::   kcall          ! optional argument indicating call sequence 
     309      ! 
     310      !!---------------------------------------------------------------------- 
     311      ! 
     312      IF( ln_linssh )   RETURN      ! No calculation in linear free surface 
     313      ! 
     314      IF( ln_timing )   CALL timing_start('dom_h_nxt') 
     315      ! 
     316      IF( kt == nit000 ) THEN 
     317         IF(lwp) WRITE(numout,*) 
     318         IF(lwp) WRITE(numout,*) 'dom_h_nxt : compute after scale factors' 
     319         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~' 
     320      ENDIF 
     321      ! 
     322      ! *********************************** ! 
     323      ! After depths at u- v points         ! 
     324      ! *********************************** ! 
     325      hu(:,:,Kaa) = hu_0(:,:) * ( 1._wp + r3u(:,:,Kaa) ) 
     326      hv(:,:,Kaa) = hv_0(:,:) * ( 1._wp + r3v(:,:,Kaa) ) 
     327      !                                        ! Inverse of the local depth 
     328      r1_hu(:,:,Kaa) = ssumask(:,:) / ( hu(:,:,Kaa) + 1._wp - ssumask(:,:) ) 
     329      r1_hv(:,:,Kaa) = ssvmask(:,:) / ( hv(:,:,Kaa) + 1._wp - ssvmask(:,:) ) 
     330      ! 
     331      IF( ln_timing )   CALL timing_stop('dom_h_nxt') 
     332      ! 
     333   END SUBROUTINE dom_h_nxt 
     334 
     335 
    294336   SUBROUTINE dom_qe_sf_update( kt, Kbb, Kmm, Kaa ) 
    295337      !!---------------------------------------------------------------------- 
     
    398440      ! 
    399441   END SUBROUTINE dom_qe_sf_update 
    400  
    401  
    402    SUBROUTINE dom_qe_interpol( pe3_in, pe3_out, pout ) 
    403       !!--------------------------------------------------------------------- 
    404       !!                  ***  ROUTINE dom_qe_interpol  *** 
    405       !! 
    406       !! ** Purpose :   interpolate scale factors from one grid point to another 
    407       !! 
    408       !! ** Method  :   e3_out = e3_0 + interpolation(e3_in - e3_0) 
    409       !!                - horizontal interpolation: grid cell surface averaging 
    410       !!                - vertical interpolation: simple averaging 
    411       !!---------------------------------------------------------------------- 
    412       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in   ) ::  pe3_in    ! input e3 to be interpolated 
    413       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::  pe3_out   ! output interpolated e3 
    414       CHARACTER(LEN=*)                , INTENT(in   ) ::  pout      ! grid point of out scale factors 
    415       !                                                             !   =  'U', 'V', 'W, 'F', 'UW' or 'VW' 
    416       ! 
    417       INTEGER ::   ji, jj, jk                                       ! dummy loop indices 
    418       REAL(wp) ::  zlnwd                                            ! =1./0. when ln_wd_il = T/F 
    419       !!---------------------------------------------------------------------- 
    420       ! 
    421       IF(ln_wd_il) THEN 
    422         zlnwd = 1.0_wp 
    423       ELSE 
    424         zlnwd = 0.0_wp 
    425       END IF 
    426       ! 
    427       SELECT CASE ( pout )    !==  type of interpolation  ==! 
    428          ! 
    429       CASE( 'U' )                   !* from T- to U-point : hor. surface weighted mean 
    430          DO_3D_10_10( 1, jpk ) 
    431             pe3_out(ji,jj,jk) = 0.5_wp * (  umask(ji,jj,jk) * (1.0_wp - zlnwd) + zlnwd ) * r1_e1e2u(ji,jj)   & 
    432                &                       * (   e1e2t(ji  ,jj) * ( pe3_in(ji  ,jj,jk) - e3t_0(ji  ,jj,jk) )     & 
    433                &                           + e1e2t(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3t_0(ji+1,jj,jk) ) ) 
    434          END_3D 
    435          CALL lbc_lnk( 'domqe', pe3_out(:,:,:), 'U', 1._wp ) 
    436          pe3_out(:,:,:) = pe3_out(:,:,:) + e3u_0(:,:,:) 
    437          ! 
    438       CASE( 'V' )                   !* from T- to V-point : hor. surface weighted mean 
    439          DO_3D_10_10( 1, jpk ) 
    440             pe3_out(ji,jj,jk) = 0.5_wp * ( vmask(ji,jj,jk)  * (1.0_wp - zlnwd) + zlnwd ) * r1_e1e2v(ji,jj)   & 
    441                &                       * (   e1e2t(ji,jj  ) * ( pe3_in(ji,jj  ,jk) - e3t_0(ji,jj  ,jk) )     & 
    442                &                           + e1e2t(ji,jj+1) * ( pe3_in(ji,jj+1,jk) - e3t_0(ji,jj+1,jk) ) ) 
    443          END_3D 
    444          CALL lbc_lnk( 'domqe', pe3_out(:,:,:), 'V', 1._wp ) 
    445          pe3_out(:,:,:) = pe3_out(:,:,:) + e3v_0(:,:,:) 
    446          ! 
    447       CASE( 'F' )                   !* from U-point to F-point : hor. surface weighted mean 
    448          DO_3D_10_10( 1, jpk ) 
    449             pe3_out(ji,jj,jk) = 0.5_wp * (  umask(ji,jj,jk) * umask(ji,jj+1,jk) * (1.0_wp - zlnwd) + zlnwd ) & 
    450                &                       *    r1_e1e2f(ji,jj)                                                  & 
    451                &                       * (   e1e2u(ji,jj  ) * ( pe3_in(ji,jj  ,jk) - e3u_0(ji,jj  ,jk) )     & 
    452                &                           + e1e2u(ji,jj+1) * ( pe3_in(ji,jj+1,jk) - e3u_0(ji,jj+1,jk) ) ) 
    453          END_3D 
    454          CALL lbc_lnk( 'domqe', pe3_out(:,:,:), 'F', 1._wp ) 
    455          pe3_out(:,:,:) = pe3_out(:,:,:) + e3f_0(:,:,:) 
    456          ! 
    457       CASE( 'W' )                   !* from T- to W-point : vertical simple mean 
    458          ! 
    459          !zlnwd = 1.0_wp 
    460          pe3_out(:,:,1) = e3w_0(:,:,1) + pe3_in(:,:,1) - e3t_0(:,:,1) 
    461          ! - ML - The use of mask in this formulea enables the special treatment of the last w-point without indirect adressing 
    462 !!gm BUG? use here wmask in case of ISF ?  to be checked 
    463          DO jk = 2, jpk 
    464             pe3_out(:,:,jk) = e3w_0(:,:,jk) + ( 1.0_wp - 0.5_wp * ( tmask(:,:,jk) * (1.0_wp - zlnwd) + zlnwd ) )   & 
    465                &                            * ( pe3_in(:,:,jk-1) - e3t_0(:,:,jk-1) )                               & 
    466                &                            +            0.5_wp * ( tmask(:,:,jk) * (1.0_wp - zlnwd) + zlnwd )     & 
    467                &                            * ( pe3_in(:,:,jk  ) - e3t_0(:,:,jk  ) ) 
    468          END DO 
    469          ! 
    470       CASE( 'UW' )                  !* from U- to UW-point : vertical simple mean 
    471          ! 
    472          !zlnwd = 1.0_wp 
    473          pe3_out(:,:,1) = e3uw_0(:,:,1) + pe3_in(:,:,1) - e3u_0(:,:,1) 
    474          ! - ML - The use of mask in this formaula enables the special treatment of the last w- point without indirect adressing 
    475 !!gm BUG? use here wumask in case of ISF ?  to be checked 
    476          DO jk = 2, jpk 
    477             pe3_out(:,:,jk) = e3uw_0(:,:,jk) + ( 1.0_wp - 0.5_wp * ( umask(:,:,jk) * (1.0_wp - zlnwd) + zlnwd ) )  & 
    478                &                             * ( pe3_in(:,:,jk-1) - e3u_0(:,:,jk-1) )                              & 
    479                &                             +            0.5_wp * ( umask(:,:,jk) * (1.0_wp - zlnwd) + zlnwd )    & 
    480                &                             * ( pe3_in(:,:,jk  ) - e3u_0(:,:,jk  ) ) 
    481          END DO 
    482          ! 
    483       CASE( 'VW' )                  !* from V- to VW-point : vertical simple mean 
    484          ! 
    485          !zlnwd = 1.0_wp 
    486          pe3_out(:,:,1) = e3vw_0(:,:,1) + pe3_in(:,:,1) - e3v_0(:,:,1) 
    487          ! - ML - The use of mask in this formaula enables the special treatment of the last w- point without indirect adressing 
    488 !!gm BUG? use here wvmask in case of ISF ?  to be checked 
    489          DO jk = 2, jpk 
    490             pe3_out(:,:,jk) = e3vw_0(:,:,jk) + ( 1.0_wp - 0.5_wp * ( vmask(:,:,jk) * (1.0_wp - zlnwd) + zlnwd ) )  & 
    491                &                             * ( pe3_in(:,:,jk-1) - e3v_0(:,:,jk-1) )                              & 
    492                &                             +            0.5_wp * ( vmask(:,:,jk) * (1.0_wp - zlnwd) + zlnwd )    & 
    493                &                             * ( pe3_in(:,:,jk  ) - e3v_0(:,:,jk  ) ) 
    494          END DO 
    495       END SELECT 
    496       ! 
    497    END SUBROUTINE dom_qe_interpol 
    498442 
    499443 
Note: See TracChangeset for help on using the changeset viewer.