crsdom.F90

MODULE crsdom
   !!===================================================================
   !!                  ***  crs.F90 ***
   !!  Purpose: Interface for calculating quantities from a  
   !!           higher-resolution grid for the coarse grid.
   !!
   !!  Method:  Given the user-defined reduction factor, 
   !!           the averaging bins are set: 
   !!           - nn_binref = 0, starting from the north 
   !!           to the south in the model interior domain, 
   !!           in this way the north fold and redundant halo cells  
   !!           could be handled in a consistent manner and 
   !!           the irregularities of bin size can be handled
   !!           more naturally by the presence of land
   !!           in the southern boundary.  Thus the southernmost bin 
   !!           could be of an irregular bin size.
   !!           Information on the parent grid is retained, specifically,
   !!           each coarse grid cell's volume and ocean surface 
   !!           at the faces, relative to the parent grid.
   !!           - nn_binref = 1 (not yet available), starting
   !!           at a centralized bin at the equator, being only
   !!           truly centered for odd-numbered j-direction reduction 
   !!           factors.
   !!  References:  Aumont, O., J.C. Orr, D. Jamous, P. Monfray
   !!               O. Marti and G. Madec, 1998. A degradation 
   !!               approach to accelerate simulations to steady-state 
   !!               in a 3-D tracer transport model of the global ocean.
   !!               Climate Dynamics, 14:101-116.
   !!  History: 
   !!       Original.   May 2012.  (J. Simeon, C. Calone, G. Madec, C. Ethe)
   !!===================================================================
   USE dom_oce        ! ocean space and time domain
   USE crs            ! domain for coarse grid
   !
   USE in_out_manager 
   USE par_kind
   USE crslbclnk
   USE lib_mpp

   IMPLICIT NONE

   PRIVATE 

   PUBLIC crs_dom_ope
   PUBLIC crs_dom_e3, crs_dom_sfc, crs_dom_msk, crs_dom_hgr, crs_dom_coordinates
   PUBLIC crs_dom_facvol, crs_dom_def, crs_dom_bat

   INTERFACE crs_dom_ope
      MODULE PROCEDURE crs_dom_ope_3d, crs_dom_ope_2d
   END INTERFACE

   REAL(wp) :: r_inf = 1e+36

   !!----------------------------------------------------------------------
   !! NEMO/OCE 4.0 , NEMO Consortium (2018)
   !! $Id: crsdom.F90 14433 2021-02-11 08:06:49Z smasson $
   !! Software governed by the CeCILL license (see ./LICENSE)
   !!----------------------------------------------------------------------
CONTAINS

   SUBROUTINE crs_dom_msk
      
      INTEGER  ::  ji, jj, jk                   ! dummy loop indices
      INTEGER  ::  ijie,ijis,ijje,ijjs,ij,je_2
      REAL(wp) ::  zmask
      
      ! Initialize

      tmask_crs(:,:,:) = 0.0
      vmask_crs(:,:,:) = 0.0
      umask_crs(:,:,:) = 0.0
      fmask_crs(:,:,:) = 0.0
  
            
      IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
         IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
            je_2 = mje_crs(2)   ;  ij = je_2
         ENDIF
      ELSE
         je_2 = mje_crs(2)      ;  ij = mjs_crs(2) 
      ENDIF
      DO jk = 1, jpkm1
         DO ji = 2, Nie0_crs  
            ijis = mis_crs(ji)  ;  ijie = mie_crs(ji)    
            !          
            zmask = 0.0
            zmask = SUM( tmask(ijis:ijie,ij:je_2,jk) ) 
            IF ( zmask > 0.0 ) tmask_crs(ji,2,jk) = 1.0_wp
               
            zmask = 0.0
            zmask = SUM( vmask(ijis:ijie,je_2     ,jk) )  
            IF ( zmask > 0.0 ) vmask_crs(ji,2,jk) = 1.0_wp
               
            zmask = 0.0
            zmask = SUM(umask(ijie,ij:je_2,jk))   
            IF ( zmask > 0.0 ) umask_crs(ji,2,jk) = 1.0_wp
               
            fmask_crs(ji,je_2,jk) = fmask(ijie,2,jk)
         ENDDO
      ENDDO
      !
      DO jk = 1, jpkm1
         DO ji = 2, Nie0_crs  
            ijis = mis_crs(ji)     ;   ijie = mie_crs(ji)       
            DO jj = 3, Nje0_crs
               ijjs = mjs_crs(jj)  ;   ijje = mje_crs(jj)
                          
               zmask = 0.0
               zmask = SUM( tmask(ijis:ijie,ijjs:ijje,jk) ) 
               IF ( zmask > 0.0 ) tmask_crs(ji,jj,jk) = 1.0_wp
               
               zmask = 0.0
               zmask = SUM( vmask(ijis:ijie,ijje     ,jk) )  
               IF ( zmask > 0.0 ) vmask_crs(ji,jj,jk) = 1.0_wp
               
               zmask = 0.0
               zmask = SUM( umask(ijie     ,ijjs:ijje,jk) )  
               IF ( zmask > 0.0 ) umask_crs(ji,jj,jk) = 1.0_wp
               
               fmask_crs(ji,jj,jk) = fmask(ijie,ijje,jk)  
            ENDDO
         ENDDO
      ENDDO

      !
      CALL crs_lbc_lnk( tmask_crs, 'T', 1.0_wp )
      CALL crs_lbc_lnk( vmask_crs, 'V', 1.0_wp )
      CALL crs_lbc_lnk( umask_crs, 'U', 1.0_wp )
      CALL crs_lbc_lnk( fmask_crs, 'F', 1.0_wp )
      !
   END SUBROUTINE crs_dom_msk


   SUBROUTINE crs_dom_coordinates( p_gphi, p_glam, cd_type, p_gphi_crs, p_glam_crs )
      !!----------------------------------------------------------------
      !!               *** SUBROUTINE crs_coordinates ***
      !! ** Purpose :  Determine the coordinates for the coarse grid
      !! 
      !! ** Method  :  From the parent grid subset, search for the central
      !!               point.  For an odd-numbered reduction factor,
      !!               the coordinate will be that of the central T-cell.
      !!               For an even-numbered reduction factor, of a non-square
      !!               coarse grid box, the coordinate will be that of 
      !!               the east or north face or more likely.  For a square
      !!               coarse grid box, the coordinate will be that of
      !!               the central f-corner.
      !!
      !! ** Input   :  p_gphi = parent grid gphi[t|u|v|f]
      !!               p_glam = parent grid glam[t|u|v|f]
      !!               cd_type  = grid type (T,U,V,F)
      !! ** Output  :  p_gphi_crs = coarse grid gphi[t|u|v|f]
      !!               p_glam_crs = coarse grid glam[t|u|v|f]
      !!              
      !! History. 1 Jun.
      !!----------------------------------------------------------------
      !! Arguments
      REAL(wp), DIMENSION(jpi,jpj)        , INTENT(in)  :: p_gphi  ! Parent grid latitude
      REAL(wp), DIMENSION(jpi,jpj)        , INTENT(in)  :: p_glam  ! Parent grid longitude
      CHARACTER(len=1),                     INTENT(in)  :: cd_type   ! grid type (T,U,V,F) 
      REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_gphi_crs  ! Coarse grid latitude
      REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_glam_crs  ! Coarse grid longitude

      !! Local variables
      INTEGER :: ji, jj, jk                   ! dummy loop indices
      INTEGER :: ijis, ijjs

  
      SELECT CASE ( cd_type )
         CASE ( 'T' )
            DO jj =  Njs0_crs, Nje0_crs
               ijjs = mjs_crs(jj) + mybinctr
               DO ji = 2, Nie0_crs
                  ijis = mis_crs(ji) + mxbinctr 
                  p_gphi_crs(ji,jj) = p_gphi(ijis,ijjs)
                  p_glam_crs(ji,jj) = p_glam(ijis,ijjs)
               ENDDO
            ENDDO
         CASE ( 'U' )
            DO jj =  Njs0_crs, Nje0_crs
               ijjs = mjs_crs(jj) + mybinctr                  
               DO ji = 2, Nie0_crs
                  ijis = mis_crs(ji)
                  p_gphi_crs(ji,jj) = p_gphi(ijis,ijjs)
                  p_glam_crs(ji,jj) = p_glam(ijis,ijjs)
               ENDDO
            ENDDO
         CASE ( 'V' )
            DO jj =  Njs0_crs, Nje0_crs
               ijjs = mjs_crs(jj)
               DO ji = 2, Nie0_crs
                  ijis = mis_crs(ji) + mxbinctr 
                  p_gphi_crs(ji,jj) = p_gphi(ijis,ijjs)
                  p_glam_crs(ji,jj) = p_glam(ijis,ijjs)
               ENDDO
            ENDDO
         CASE ( 'F' )
            DO jj =  Njs0_crs, Nje0_crs
               ijjs = mjs_crs(jj)
               DO ji = 2, Nie0_crs
                  ijis = mis_crs(ji)