!---------------------------------------------------------------------- ! NEMO system team, System and Interface for oceanic RElocable Nesting !---------------------------------------------------------------------- ! ! MODULE: dom ! ! DESCRIPTION: !> @brief !> This module manage domain computation. ! !> @details !> !> !> !> !> !> @author !> J.Paul ! REVISION HISTORY: !> @date Nov, 2013 - Initial Version !> @todo !> - check use of id_pivot !> !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) !---------------------------------------------------------------------- MODULE dom USE kind ! F90 kind parameter USE global ! global parameter USE fct ! basic useful function USE logger ! log file manager USE dim ! dimension manager USE var ! variable manager USE file ! file manager IMPLICIT NONE PRIVATE ! NOTE_avoid_public_variables_if_possible ! type and variable PUBLIC :: TDOM !< domain structure ! function and subroutine PUBLIc :: dom_clean !< clean domain structure PUBLIC :: dom_init !< initialise domain structure PUBLIC :: dom_print !< print information about domain PUBLIC :: dom_get_ew_overlap !< get east west overlap PUBLIC :: dom_add_extra !< add useful extra point to coarse grid for interpolation PUBLIC :: dom_clean_extra !< reset domain without extra point PUBLIC :: dom_del_extra !< remove extra point from fine grid after interpolation PRIVATE :: dom__define !< define extract domain indices !< define extract domain indices for input domain with PRIVATE :: dom__define_cyclic_north_fold !< - cyclic east-west boundary and north fold boundary condition. PRIVATE :: dom__define_north_fold !< - north fold boundary condition. PRIVATE :: dom__define_symmetric !< - symmetric boundary condition across the equator. PRIVATE :: dom__define_cyclic !< - cyclic east-west boundary. PRIVATE :: dom__define_closed !< - cyclic east-west boundary. PRIVATE :: dom__check_EW_index !< check East-West indices !< compute size of an extract domain PRIVATE :: dom__size_no_pole !< - without north fold condition PRIVATE :: dom__size_no_pole_overlap !< - without north fold condition, and which overlap east-west boundary PRIVATE :: dom__size_no_pole_no_overlap !< - without north fold condition, and which do not overlap east-west boundary PRIVATE :: dom__size_pole !< - with north fold condition PRIVATE :: dom__size_pole_overlap !< - with north fold condition, and which overlap east-west boundary PRIVATE :: dom__size_pole_no_overlap !< - with north fold condition, and which do not overlap east-west boundary !> @struct TYPE TDOM TYPE(TDIM), DIMENSION(ip_maxdim) :: t_dim0 !< global domain dimension TYPE(TDIM), DIMENSION(ip_maxdim) :: t_dim !< sub domain dimension INTEGER(i4) :: i_perio0 !< NEMO periodicity index INTEGER(i4) :: i_ew0 !< East-West overlap INTEGER(i4) :: i_perio !< NEMO periodicity index INTEGER(i4) :: i_pivot !< NEMO pivot point index F(0),T(1) INTEGER(i4) :: i_imin = 1 !< i-direction sub-domain lower left point indice INTEGER(i4) :: i_imax = 1 !< i-direction sub-domain upper right point indice INTEGER(i4) :: i_jmin = 1 !< j-direction sub-domain lower left point indice INTEGER(i4) :: i_jmax = 1 !< j-direction sub-domain upper right point indice INTEGER(i4) :: i_kmin = 1 !< k-direction sub-domain lower level indice INTEGER(i4) :: i_kmax = 1 !< k-direction sub-domain upper level indice INTEGER(i4) :: i_lmin = 1 !< l-direction sub-domain lower time indice INTEGER(i4) :: i_lmax = 1 !< l-direction sub-domain upper time indice INTEGER(i4) :: i_ighost = 0 !< i-direction ghost cell factor INTEGER(i4) :: i_jghost = 0 !< j-direction ghost cell factor INTEGER(i4), DIMENSION(2) :: i_iextra = 0 !< i-direction extra point INTEGER(i4), DIMENSION(2) :: i_jextra = 0 !< j-direction extra point END TYPE TDOM INTEGER(i4), PARAMETER :: im_minext = 2 !< default minumum number of extraband INTERFACE dom_init MODULE PROCEDURE dom_init_file ! MODULE PROCEDURE dom_init_mpp END INTERFACE dom_init CONTAINS !------------------------------------------------------------------- !> @brief This subroutine print some information about domain strucutre. ! !> @author J.Paul !> - Nov, 2013- Initial Version ! !> @param[inout] td_dom : dom structure !------------------------------------------------------------------- !> @code SUBROUTINE dom_print(td_dom) IMPLICIT NONE ! Argument TYPE(TDOM), INTENT(IN) :: td_dom ! local argument CHARACTER(LEN=lc) :: cl_pivot !---------------------------------------------------------------- SELECT CASE(td_dom%i_pivot) CASE(0) cl_pivot='F-point' CASE(1) cl_pivot='T-point' CASE DEFAULT cl_pivot='unknown' END SELECT WRITE(*,'((a,4(i0,1x)),(/a,i2,a,a),(/a,4(i0,1x)),(/a,i2/),10(/a,i0))') & & " global domain size ",td_dom%t_dim0(:)%i_len, & & " domain periodicity ",td_dom%i_perio0,", pivot: ",TRIM(cl_pivot), & & " sub-domain size : ",td_dom%t_dim(:)%i_len, & & " sub domain periodicity ",td_dom%i_perio, & & " i-direction sub-domain lower left point indice ",td_dom%i_imin, & & " i-direction sub-domain upper right point indice ",td_dom%i_imax, & & " j-direction sub-domain lower left point indice ",td_dom%i_jmin, & & " j-direction sub-domain upper right point indice ",td_dom%i_jmax, & ! & " k-direction sub-domain lower level indice ",td_dom%i_kmin, & ! & " k-direction sub-domain upper level indice ",td_dom%i_kmax, & ! & " l-direction sub-domain lower time indice ",td_dom%i_lmin, & ! & " l-direction sub-domain upper time indice ",td_dom%i_lmax, & & " i-direction ghost cell factor ",td_dom%i_ighost, & & " j-direction ghost cell factor ",td_dom%i_jghost END SUBROUTINE dom_print !> @endcode !------------------------------------------------------------------- !> @brief !> This function intialise domain structure, given open file structure, !> and grid periodicity. ! !> @author J.Paul !> - June, 2013- Initial Version ! !> @param[in] td_file : file structure !> @param[in] id_perio : grid periodicity !> @param[in] id_imin : i-direction sub-domain lower left point indice !> @param[in] id_imax : i-direction sub-domain upper right point indice !> @param[in] id_jmin : j-direction sub-domain lower left point indice !> @param[in] id_jmax : j-direction sub-domain upper right point indice !> @param[in] id_kmin : k-direction sub-domain lower level indice !> @param[in] id_kmax : k-direction sub-domain upper level indice !> @param[in] id_lmin : l-direction sub-domain lower time indice !> @param[in] id_lmax : l-direction sub-domain upper time indice !> @return domain structure !> !> @todo !> - initialiser domain !> - add info new perio.. dans sortie !------------------------------------------------------------------- !> @code TYPE(TDOM) FUNCTION dom_init_file( td_file, & & id_imin, id_imax, id_jmin, id_jmax ) ! & id_kmin, id_kmax, id_lmin, id_lmax ) IMPLICIT NONE ! Argument TYPE(TFILE), INTENT(IN) :: td_file INTEGER(i4), INTENT(IN), OPTIONAL :: id_imin INTEGER(i4), INTENT(IN), OPTIONAL :: id_imax INTEGER(i4), INTENT(IN), OPTIONAL :: id_jmin INTEGER(i4), INTENT(IN), OPTIONAL :: id_jmax ! INTEGER(i4), INTENT(IN), OPTIONAL :: id_kmin ! INTEGER(i4), INTENT(IN), OPTIONAL :: id_kmax ! INTEGER(i4), INTENT(IN), OPTIONAL :: id_lmin ! INTEGER(i4), INTENT(IN), OPTIONAL :: id_lmax !local variable !---------------------------------------------------------------- ! clean domain structure CALL dom_clean(dom_init_file) IF( td_file%i_id == 0 )THEN CALL logger_error( & & " DOM INIT: no id associated to file "//TRIM(td_file%c_name)) ELSE ! global domain define by file ! use global dimension define by file dom_init_file%t_dim0(:) = td_file%t_dim(:) IF( td_file%i_perio < 0 .OR. td_file%i_perio > 6 )THEN CALL logger_error("DOM INIT: invalid grid periodicity. "//& & "you should use dom_get_perio to compute it") ELSE dom_init_file%i_perio0=td_file%i_perio ENDIF ! global domain pivot point SELECT CASE(dom_init_file%i_perio0) CASE(3,4) dom_init_file%i_pivot = 0 CASE(5,6) dom_init_file%i_pivot = 1 CASE DEFAULT dom_init_file%i_pivot = 0 END SELECT ! look for EW overlap dom_init_file%i_ew0=td_file%i_ew ! initialise domain as global dom_init_file%i_imin = 1 dom_init_file%i_imax = dom_init_file%t_dim0(1)%i_len dom_init_file%i_jmin = 1 dom_init_file%i_jmax = dom_init_file%t_dim0(2)%i_len ! dom_init_file%i_kmin = 1 ! dom_init_file%i_kmax = dom_init_file%t_dim(3)%i_len ! ! dom_init_file%i_lmin = 1 ! dom_init_file%i_lmax = dom_init_file%t_dim(4)%i_len ! extract domain dimension dom_init_file%t_dim(:) = td_file%t_dim(:) ! define extract domain indices CALL dom__define( dom_init_file, & & id_imin, id_imax, id_jmin, id_jmax ) ! & id_kmin, id_kmax, id_lmin, id_lmax ) ENDIF END FUNCTION dom_init_file !> @endcode ! !------------------------------------------------------------------- ! !> @brief ! !> This function intialise domain structure, given mpp structure, ! !> and variable name. domain indices could be specify. ! ! ! !> @details ! !> ! ! ! !> @author J.Paul ! !> - Nov, 2013- Initial Version ! ! ! !> @param[in] td_mpp : mpp structure ! !> @param[in] cd_varname : variable name ! !> @return domain structure ! !> ! !> @todo ! !> - initialiser domain ! !------------------------------------------------------------------- ! !> @code ! TYPE(TDOM) FUNCTION dom_init_mpp( td_mpp, cd_varname ) ! IMPLICIT NONE ! ! Argument ! TYPE(TMPP), INTENT(IN) :: td_mpp ! CHARACTER(LEN=*), INTENT(IN) :: cd_varname ! !---------------------------------------------------------------- ! ! clean domain structure ! CALL dom_clean(dom_init_mpp) ! IF( ASSOCIATED(td_mpp%t_proc) )THEN ! CALL logger_error( " INIT: mpp strcuture "//TRIM(td_mpp%c_name)//& ! & " not define" ) ! ELSE ! ! global domain define by mpp ! ! use global dimension define by mpp ! dom_init_mpp%t_dim(:) = td_mpp%t_dim(:) ! ! get global domain periodicity ?? ! dom_init_mpp%i_perio = dom_get_perio(td_mpp, cd_varname) ! ! global domain pivot point ! SELECT CASE(dom_init%i_perio) ! CASE(3,4) ! dom_init%i_pivot = 0 ! CASE(5,6) ! dom_init%i_pivot = 1 ! CASE DEFAULT ! dom_init%i_pivot = 0 ! END SELECT ! ! initialise domain as global ! dom_init_mpp%i_imin = 1 ! dom_init_mpp%i_imax = dom_init_mpp%t_dim(1)%i_len ! dom_init_mpp%i_jmin = 1 ! dom_init_mpp%i_jmax = dom_init_mpp%t_dim(2)%i_len ! dom_init_mpp%i_kmin = 1 ! dom_init_mpp%i_kmax = dom_init_mpp%t_dim(3)%i_len ! dom_init_mpp%i_lmin = 1 ! dom_init_mpp%i_lmax = dom_init_mpp%t_dim(4)%i_len ! ENDIF ! END FUNCTION dom_init_mpp ! !> @endcode !------------------------------------------------------------------- !> @brief !> This subroutine define extract domain indices, and compute the size !> of the domain. !> !> @author J.Paul !> - Nov, 2013- Subroutine written ! !> @param[inout] td_dom : domain structure !> @param[in] id_imin : i-direction sub-domain lower left point indice !> @param[in] id_imax : i-direction sub-domain upper right point indice !> @param[in] id_jmin : j-direction sub-domain lower left point indice !> @param[in] id_jmax : j-direction sub-domain upper right point indice !> @param[in] id_kmin : k-direction sub-domain lower level indice !> @param[in] id_kmax : k-direction sub-domain upper level indice !> @param[in] id_lmin : l-direction sub-domain lower time indice !> @param[in] id_lmax : l-direction sub-domain upper time indice !------------------------------------------------------------------- !> @code SUBROUTINE dom__define(td_dom, & & id_imin, id_imax, id_jmin, id_jmax ) ! & id_kmin, id_kmax, id_lmin, id_lmax ) IMPLICIT NONE ! Argument TYPE(TDOM), INTENT(INOUT) :: td_dom INTEGER(i4), INTENT(IN), OPTIONAL :: id_imin INTEGER(i4), INTENT(IN), OPTIONAL :: id_imax INTEGER(i4), INTENT(IN), OPTIONAL :: id_jmin INTEGER(i4), INTENT(IN), OPTIONAL :: id_jmax ! INTEGER(i4), INTENT(IN), OPTIONAL :: id_kmin ! INTEGER(i4), INTENT(IN), OPTIONAL :: id_kmax ! INTEGER(i4), INTENT(IN), OPTIONAL :: id_lmin ! INTEGER(i4), INTENT(IN), OPTIONAL :: id_lmax !---------------------------------------------------------------- IF( PRESENT(id_imin) ) td_dom%i_imin = id_imin IF( PRESENT(id_imax) ) td_dom%i_imax = id_imax IF( PRESENT(id_jmin) ) td_dom%i_jmin = id_jmin IF( PRESENT(id_jmax) ) td_dom%i_jmax = id_jmax ! IF( PRESENT(id_kmin) ) td_dom%i_kmin = id_kmin ! IF( PRESENT(id_kmax) ) td_dom%i_kmax = id_kmax ! ! IF( PRESENT(id_lmin) ) td_dom%i_lmin = id_lmin ! IF( PRESENT(id_lmax) ) td_dom%i_lmax = id_lmax ! check indices IF(( td_dom%i_imin < 0 .OR. td_dom%i_imin > td_dom%t_dim0(1)%i_len ).OR. & & ( td_dom%i_imax < 0 .OR. td_dom%i_imax > td_dom%t_dim0(1)%i_len ).OR. & & ( td_dom%i_jmin < 0 .OR. td_dom%i_jmin > td_dom%t_dim0(2)%i_len ).OR. & & ( td_dom%i_jmax < 0 .OR. td_dom%i_jmax > td_dom%t_dim0(2)%i_len ))THEN ! & ( td_dom%i_kmin < 0 .OR. td_dom%i_kmin > td_dom%t_dim0(3)%i_len ).OR. & ! & ( td_dom%i_kmax < 0 .OR. td_dom%i_kmax > td_dom%t_dim0(3)%i_len ).OR. & ! & ( td_dom%i_lmin < 0 .OR. td_dom%i_lmin > td_dom%t_dim0(4)%i_len ).OR. & ! & ( td_dom%i_lmax < 0 .OR. td_dom%i_lmax > td_dom%t_dim0(4)%i_len ))THEN CALL logger_error( "DOM INIT DEFINE: invalid grid definition."// & & " check min and max indices") CALL logger_debug("0 < imin ("//TRIM(fct_str(id_imin))//") < "//& & TRIM(fct_str(td_dom%t_dim0(1)%i_len))) CALL logger_debug("0 < imax ("//TRIM(fct_str(id_imax))//") < "//& & TRIM(fct_str(td_dom%t_dim0(1)%i_len))) CALL logger_debug("0 < jmin ("//TRIM(fct_str(id_jmin))//") < "//& & TRIM(fct_str(td_dom%t_dim0(2)%i_len))) CALL logger_debug("0 < jmax ("//TRIM(fct_str(id_jmax))//") < "//& & TRIM(fct_str(td_dom%t_dim0(2)%i_len))) ! CALL logger_debug("0 < kmin ("//TRIM(fct_str(id_kmin))//") < "//& ! & TRIM(fct_str(td_dom%t_dim0(3)%i_len))) ! CALL logger_debug("0 < kmax ("//TRIM(fct_str(id_kmax))//") < "//& ! & TRIM(fct_str(td_dom%t_dim0(3)%i_len))) ! CALL logger_debug("0 < lmin ("//TRIM(fct_str(id_lmin))//") < "//& ! & TRIM(fct_str(td_dom%t_dim0(4)%i_len))) ! CALL logger_debug("0 < lmax ("//TRIM(fct_str(id_lmax))//") < "//& ! & TRIM(fct_str(td_dom%t_dim0(4)%i_len))) ELSE ! td_dom%t_dim(3)%i_len=td_dom%i_kmax-td_dom%i_kmin+1 ! td_dom%t_dim(4)%i_len=td_dom%i_lmax-td_dom%i_lmin+1 SELECT CASE(td_dom%i_perio0) CASE(0) ! closed boundary CALL logger_trace("DEFINE: closed boundary") CALL dom__define_closed( td_dom ) CASE(1) ! cyclic east-west boundary CALL logger_trace("DEFINE: cyclic east-west boundary") CALL dom__define_cyclic( td_dom ) CASE(2) ! symmetric boundary condition across the equator CALL logger_trace("DEFINE: symmetric boundary condition "//& & " across the equator") CALL dom__define_symmetric( td_dom ) CASE(3) ! North fold boundary (with a F-point pivot) CALL logger_trace("DEFINE: North fold boundary "//& & "(with a F-point pivot)") CALL dom__define_north_fold( td_dom ) CASE(5) ! North fold boundary (with a T-point pivot) CALL logger_trace("DEFINE: North fold boundary "//& & "(with a T-point pivot)") CALL dom__define_north_fold( td_dom ) CASE(4) ! North fold boundary (with a F-point pivot) ! and cyclic east-west boundary CALL logger_trace("DEFINE: North fold boundary "//& & "(with a F-point pivot) and cyclic "//& & "east-west boundary") CALL dom__define_cyclic_north_fold( td_dom ) CASE(6) ! North fold boundary (with a T-point pivot) ! and cyclic east-west boundary CALL logger_trace("DEFINE: North fold boundary "//& & "(with a T-point pivot) and cyclic "//& & "east-west boundary") CALL dom__define_cyclic_north_fold( td_dom ) CASE DEFAULT CALL logger_error("DEFINE: invalid grid periodicity index") END SELECT ENDIF END SUBROUTINE dom__define !> @endcode !------------------------------------------------------------------- !> @brief !> This subroutine define domain indices from global domain with !> cyclic east-west boundary and north fold boundary condition. !> !> @author J.Paul !> - Nov, 2013- Subroutine written ! !> @param[inout] td_dom : domain strcuture !------------------------------------------------------------------- !> @code SUBROUTINE dom__define_cyclic_north_fold( td_dom ) IMPLICIT NONE ! Argument TYPE(TDOM), INTENT(INOUT) :: td_dom !---------------------------------------------------------------- CALL dom__check_EW_index( td_dom ) IF( td_dom%i_imin == td_dom%i_imax .AND. & & td_dom%i_jmin == td_dom%i_jmax )THEN CALL logger_trace("DEFINE CYCLIC NORTH FOLD: "//& & "domain to extract is global" ) ! coarse domain is global domain CALL dom__size_global( td_dom ) ELSEIF( td_dom%i_imin == td_dom%i_imax .AND. & & td_dom%i_jmin >= td_dom%i_jmax )THEN CALL logger_trace("DEFINE CYCLIC NORTH FOLD: "//& & "domain to extract is semi-global" ) CALL dom__size_semi_global( td_dom ) ELSEIF( td_dom%i_imin == td_dom%i_imax .AND. & & td_dom%i_jmin < td_dom%i_jmax )THEN CALL logger_trace("DEFINE CYCLIC NORTH FOLD: "//& & "domain to extract is band of latidue" ) CALL dom__size_no_pole( td_dom ) ELSEIF( td_dom%i_imin /= td_dom%i_imax .AND. & & td_dom%i_jmin == td_dom%i_jmax )THEN CALL logger_trace("DEFINE CYCLIC NORTH FOLD: "//& & "domain to extract has north boundary" ) CALL dom__size_pole( td_dom ) ELSEIF( td_dom%i_imin /= td_dom%i_imax .AND. & & td_dom%i_jmin /= td_dom%i_jmax )THEN IF( td_dom%i_jmax < td_dom%t_dim0(2)%i_len-1 .AND. & & td_dom%i_jmax > td_dom%i_jmin )THEN CALL logger_trace("DEFINE CYCLIC NORTH FOLD: "//& & "domain to extract has no north boundary" ) ! no North Pole CALL dom__size_no_pole( td_dom ) ELSE CALL logger_trace("DEFINE CYCLIC NORTH FOLD: "//& & "domain to extract has north boundary" ) CALL dom__size_pole( td_dom ) ENDIF ELSE CALL logger_error("DEFINE CYCLIC NORTH FOLD: "//& & "should have been an impossible case" ) ENDIF END SUBROUTINE dom__define_cyclic_north_fold !> @endcode !------------------------------------------------------------------- !> @brief !> This subroutine define extract domain indices from global domain !> with north fold boundary condition. !> !> @author J.Paul !> - Nov, 2013- Subroutine written ! !> @param[inout] td_dom : domain strcuture !------------------------------------------------------------------- !> @code SUBROUTINE dom__define_north_fold( td_dom ) IMPLICIT NONE ! Argument TYPE(TDOM), INTENT(INOUT) :: td_dom !---------------------------------------------------------------- IF( td_dom%i_jmax < td_dom%t_dim0(2)%i_len-1 .AND. & & td_dom%i_jmax > td_dom%i_jmin )THEN CALL logger_trace("DEFINE NORTH FOLD: "//& & "domain to extract has no north boundary" ) ! no North Pole CALL dom__size_no_pole_no_overlap( td_dom ) ELSE CALL logger_trace("DEFINE NORTH FOLD: "//& & "domain to extract has north boundary" ) CALL dom__size_pole_no_overlap( td_dom ) ENDIF END SUBROUTINE dom__define_north_fold !> @endcode !------------------------------------------------------------------- !> @brief !> This subroutine define extract domain indices from global domain !> with symmetric boundary condition across the equator. !> !> @author J.Paul !> - Nov, 2013- Subroutine written ! !> @param[inout] td_dom : domain strcuture !------------------------------------------------------------------- !> @code SUBROUTINE dom__define_symmetric( td_dom ) IMPLICIT NONE ! Argument TYPE(TDOM), INTENT(INOUT) :: td_dom !---------------------------------------------------------------- CALL dom__size_no_pole_no_overlap( td_dom ) END SUBROUTINE dom__define_symmetric !> @endcode !------------------------------------------------------------------- !> @brief !> This subroutine define extract domain indices from global domain !> with cyclic east-west boundary. !> !> @author J.Paul !> - Nov, 2013- Subroutine written ! !> @param[inout] td_dom : domain strcuture !------------------------------------------------------------------- !> @code SUBROUTINE dom__define_cyclic( td_dom ) IMPLICIT NONE ! Argument TYPE(TDOM), INTENT(INOUT) :: td_dom !---------------------------------------------------------------- CALL dom__check_EW_index( td_dom ) IF( td_dom%i_imin >= td_dom%i_imax )THEN CALL logger_trace("DEFINE CYCLIC: "//& & "domain to extract overlap east-west boundary") CALL dom__size_no_pole_overlap( td_dom ) ELSE ! id_imin < id_imax CALL logger_trace("DEFINE CYCLIC: "//& & "domain to extract do not overlap east-west boundary") CALL dom__size_no_pole_no_overlap( td_dom ) ENDIF END SUBROUTINE dom__define_cyclic !> @endcode !------------------------------------------------------------------- !> @brief !> This subroutine define extract domain indices from global domain !> with closed boundaries. !> !> @author J.Paul !> - Nov, 2013- Subroutine written ! !> @param[inout] td_dom : domain strcuture !------------------------------------------------------------------- !> @code SUBROUTINE dom__define_closed( td_dom ) IMPLICIT NONE ! Argument TYPE(TDOM), INTENT(INOUT) :: td_dom !---------------------------------------------------------------- CALL dom__size_no_pole_no_overlap( td_dom ) END SUBROUTINE dom__define_closed !> @endcode !------------------------------------------------------------------- !> @brief !> This subroutine check East-West indices, use inside a cyclic domain, !> and redefine it in some particular cases. !> !> @author J.Paul !> - Nov, 2013- Subroutine written ! !> @param[inout] td_dom : domain strcuture !------------------------------------------------------------------- !> @code SUBROUTINE dom__check_EW_index( td_dom ) IMPLICIT NONE ! Argument TYPE(TDOM), INTENT(INOUT) :: td_dom !---------------------------------------------------------------- IF( td_dom%i_imin /= td_dom%i_imax )THEN IF((ABS(td_dom%i_imax-td_dom%i_imin) >= td_dom%t_dim0(1)%i_len-1).OR.& (ABS(td_dom%i_imax-td_dom%i_imin) <= td_dom%i_ew0 ) )THEN td_dom%i_imin = td_dom%i_imax ENDIF ENDIF END SUBROUTINE dom__check_EW_index !> @endcode !------------------------------------------------------------------- !> @brief !> This subroutine compute size of global domain !> !> @author J.Paul !> - Nov, 2013- Subroutine written ! !> @param[inout] td_dom : domain strcuture !------------------------------------------------------------------- !> @code SUBROUTINE dom__size_global( td_dom ) IMPLICIT NONE ! Argument TYPE(TDOM), INTENT(INOUT) :: td_dom !---------------------------------------------------------------- td_dom%i_imin = 1 td_dom%i_imax = td_dom%t_dim0(1)%i_len td_dom%i_jmin = 1 td_dom%i_jmax = td_dom%t_dim0(2)%i_len ! domain size td_dom%t_dim(1)%i_len = td_dom%t_dim0(1)%i_len td_dom%t_dim(2)%i_len = td_dom%t_dim0(2)%i_len ! no ghost cell to add td_dom%i_ighost=0 td_dom%i_jghost=0 ! peiordicity IF( td_dom%i_pivot == 0 )THEN ! 0-F td_dom%i_perio=4 td_dom%i_pivot=0 ELSE ! 1-T td_dom%i_perio=6 td_dom%i_pivot=1 ENDIF END SUBROUTINE dom__size_global !> @endcode !------------------------------------------------------------------- !> @brief !> This subroutine compute size of a semi global domain !> !> @author J.Paul !> - Nov, 2013- Subroutine written ! !> @param[inout] td_dom : domain strcuture !> @note never tested !------------------------------------------------------------------- !> @code SUBROUTINE dom__size_semi_global( td_dom ) IMPLICIT NONE ! Argument TYPE(TDOM), INTENT(INOUT) :: td_dom ! local variable INTEGER(i4) :: il_imid ! cananadian bipole index (middle of global domain) !---------------------------------------------------------------- il_imid = td_dom%t_dim0(1)%i_len/2 + td_dom%i_pivot td_dom%i_imin = 2 td_dom%i_imax = il_imid !td_dom%t_dim0(1)%i_len IF( td_dom%i_jmax >= td_dom%t_dim0(2)%i_len-1 )THEN td_dom%i_jmax=MIN( td_dom%i_jmin, & & td_dom%t_dim0(2)%i_len-td_dom%i_jmax ) ELSE td_dom%i_jmin=td_dom%i_jmax ENDIF ! domain size td_dom%t_dim(1)%i_len = (td_dom%i_imax ) - & & (td_dom%i_imin ) + 1 td_dom%t_dim(2)%i_len = ( td_dom%t_dim0(2)%i_len - & & ( td_dom%i_jmin ) + 1 ) + & & ( td_dom%t_dim0(2)%i_len - & & ( td_dom%i_jmax ) + 1 ) - 2 ! remove north fold condition ? ! ghost cell to add td_dom%i_ighost=1 td_dom%i_jghost=1 ! periodicity IF( td_dom%i_pivot == 0 )THEN !0-F td_dom%i_perio=3 td_dom%i_pivot=0 ELSE !1-T td_dom%i_perio=5 td_dom%i_pivot=1 ENDIF END SUBROUTINE dom__size_semi_global !> @endcode !------------------------------------------------------------------- !> @brief !> This subroutine compute size of an extract domain without north fold !> condition !> !> @author J.Paul !> - Nov, 2013- Subroutine written ! !> @param[inout] td_dom : domain strcuture !------------------------------------------------------------------- !> @code SUBROUTINE dom__size_no_pole( td_dom ) IMPLICIT NONE ! Argument TYPE(TDOM), INTENT(INOUT) :: td_dom !---------------------------------------------------------------- IF( td_dom%i_jmin >= td_dom%i_jmax )THEN CALL logger_fatal("DOM INIT: invalid domain. "//& & "can not get north pole from this coarse grid. "//& & "check namelist and coarse grid periodicity." ) ENDIF IF( td_dom%i_imin >= td_dom%i_imax )THEN CALL logger_trace("DEFINE NO POLE: "// & & "domain to extract overlap east-west boundary") CALL dom__size_no_pole_overlap( td_dom ) ELSE ! id_imin < id_imax CALL logger_trace("DEFINE NO POLE: "// & & "domain to extract do not overlap east-west boundary") CALL dom__size_no_pole_no_overlap( td_dom ) ENDIF END SUBROUTINE dom__size_no_pole !> @endcode !------------------------------------------------------------------- !> @brief !> This subroutine compute size of an extract domain with north fold !> condition !> !> @author J.Paul !> - April, 2013- Subroutine written ! !> @param[inout] td_dom : domain strcuture !------------------------------------------------------------------- !> @code SUBROUTINE dom__size_pole( td_dom ) IMPLICIT NONE ! Argument TYPE(TDOM), INTENT(INOUT) :: td_dom !---------------------------------------------------------------- IF( td_dom%i_imin > td_dom%i_imax )THEN CALL logger_trace("DEFINE POLE: "//& & "domain to extract overlap east-west boundary") CALL dom__size_pole_overlap( td_dom ) ELSEIF( td_dom%i_imin < td_dom%i_imax )THEN CALL logger_trace("DEFINE POLE: "//& & "domain to extract do not overlap east-west boundary") CALL dom__size_pole_no_overlap( td_dom ) ENDIF END SUBROUTINE dom__size_pole !> @endcode !------------------------------------------------------------------- !> @brief !> This subroutine compute size of an extract domain without north fold !> condition, and which overlap east-west boundary !> !> @author J.Paul !> - Nov, 2013- Subroutine written ! !> @param[inout] td_dom : domain strcuture !------------------------------------------------------------------- !> @code SUBROUTINE dom__size_no_pole_overlap( td_dom ) IMPLICIT NONE ! Argument TYPE(TDOM), INTENT(INOUT) :: td_dom !---------------------------------------------------------------- IF( td_dom%i_jmin >= td_dom%i_jmax )THEN CALL logger_fatal("DOM INIT: invalid domain. "//& & "can not get north pole from this coarse grid. "//& & "check namelist and coarse grid periodicity." ) ENDIF IF( td_dom%i_imin == td_dom%i_imax )THEN ! domain to extract with east west cyclic boundary CALL logger_trace("DEFINE NO POLE OVERLAP: "//& & "domain to extract has cyclic east-west boundary") td_dom%i_imin = 1 td_dom%i_imax = td_dom%t_dim0(1)%i_len td_dom%t_dim(1)%i_len = td_dom%t_dim0(1)%i_len ! no ghost cell td_dom%i_ighost=0 ! periodicity td_dom%i_perio=1 ELSE ! id_imin > id_imax ! extract domain overlap east-west boundary td_dom%t_dim(1)%i_len = td_dom%t_dim0(1)%i_len - & & (td_dom%i_imin ) + 1 + & & (td_dom%i_imax ) - 2 ! remove cyclic boundary ! add ghost cell td_dom%i_ighost=1 ! periodicity td_dom%i_perio=0 ENDIF td_dom%t_dim(2)%i_len = (td_dom%i_jmax ) - & & (td_dom%i_jmin ) + 1 ! add ghost cell td_dom%i_jghost=1 END SUBROUTINE dom__size_no_pole_overlap !> @endcode !------------------------------------------------------------------- !> @brief !> This subroutine compute size of an extract domain without north fold !> condition, and which do not overlap east-west boundary !> !> @author J.Paul !> - Nov, 2013- Subroutine written ! !> @param[inout] td_dom : domain strcuture !------------------------------------------------------------------- !> @code SUBROUTINE dom__size_no_pole_no_overlap( td_dom ) IMPLICIT NONE ! Argument TYPE(TDOM), INTENT(INOUT) :: td_dom !---------------------------------------------------------------- IF( td_dom%i_jmin >= td_dom%i_jmax )THEN CALL logger_fatal("DOM INIT: invalid domain. "//& & "can not get north pole from this coarse grid. "//& & "check namelist and coarse grid periodicity." ) ENDIF IF( td_dom%i_imin >= td_dom%i_imax )THEN CALL logger_fatal("DOM INIT: invalid domain. "//& & "can not overlap East-West boundary with this coarse grid. "//& & "check namelist and coarse grid periodicity." ) ENDIF td_dom%t_dim(1)%i_len = ( td_dom%i_imax ) - & & ( td_dom%i_imin ) + 1 td_dom%t_dim(2)%i_len = ( td_dom%i_jmax ) - & & ( td_dom%i_jmin ) + 1 ! add ghost cell td_dom%i_ighost=1 td_dom%i_jghost=1 ! periodicity td_dom%i_perio=0 END SUBROUTINE dom__size_no_pole_no_overlap !> @endcode !------------------------------------------------------------------- !> @brief !> This subroutine compute size of an extract domain with north fold !> condition, and which overlap east-west boundary !> !> @author J.Paul !> - Nov, 2013- Subroutine written ! !> @param[inout] td_dom : domain strcuture !> @note never tested !------------------------------------------------------------------- !> @code SUBROUTINE dom__size_pole_overlap( td_dom ) IMPLICIT NONE ! Argument TYPE(TDOM), INTENT(INOUT) :: td_dom ! local variable INTEGER(i4) :: il_idom1 ! extract domain size, east part INTEGER(i4) :: il_idom2 ! extract domain size, west part INTEGER(i4) :: il_imid ! cananadian bipole index (middle of global domain) !---------------------------------------------------------------- CALL logger_trace("DEFINE POLE OVERLAP: "//& & "asian bipole inside domain to extract") il_imid = td_dom%t_dim0(1)%i_len/2 + td_dom%i_pivot il_idom1 = td_dom%t_dim0(1)%i_len - td_dom%i_imin + 1 il_idom2 = td_dom%i_imax IF( il_idom1 > il_imid .OR. il_idom2 > il_imid )THEN CALL logger_trace("DEFINE POLE OVERLAP: "//& & "canadian bipole inside domain to extract") td_dom%i_imin = td_dom%i_imax IF( td_dom%i_jmin == td_dom%i_jmax )THEN CALL dom__size_global( td_dom ) ELSE CALL dom__size_semi_global( td_dom ) ENDIF ! periodicity td_dom%i_perio=0 ELSEIF( il_idom1 > il_idom2 )THEN ! east part bigger than west part CALL logger_trace("DEFINE POLE OVERLAP: east part bigger than west part ") ! to respect symmetry around asian bipole td_dom%i_imax = il_idom1 ! north pole IF( td_dom%i_jmax >= td_dom%t_dim0(2)%i_len-1 )THEN td_dom%i_jmax=MIN( td_dom%i_jmin, & & td_dom%t_dim0(2)%i_len-td_dom%i_jmax ) ELSE td_dom%i_jmax=MIN( td_dom%i_jmin, td_dom%i_jmax ) ENDIF td_dom%i_jmin=td_dom%i_jmax ! compute size td_dom%t_dim(1)%i_len = il_idom1 !! no ghost cell ?? td_dom%t_dim(2)%i_len = ( td_dom%t_dim0(2)%i_len - & & ( td_dom%i_jmin ) + 1 ) + & & ( td_dom%t_dim0(2)%i_len - & & ( td_dom%i_jmax ) + 1 ) - 2 ! remove north fold condition ? ! add ghost cell td_dom%i_ighost=1 td_dom%i_jghost=1 ! periodicity td_dom%i_perio=0 ELSE ! il_idom2 >= il_idom1 ! west part bigger than east part CALL logger_trace("DEFINE POLE OVERLAP: west part bigger than east part ") ! to respect symmetry around asian bipole td_dom%i_imin = td_dom%t_dim0(1)%i_len - il_idom2 + 1 ! north pole IF( td_dom%i_jmax >= td_dom%t_dim0(2)%i_len-1 )THEN td_dom%i_jmax=MIN( td_dom%i_jmin, & & td_dom%t_dim0(2)%i_len-td_dom%i_jmax ) ELSE td_dom%i_jmax=MIN( td_dom%i_jmin, td_dom%i_jmax ) ENDIF td_dom%i_jmin=td_dom%i_jmax ! compute size td_dom%t_dim(1)%i_len = il_idom2 td_dom%t_dim(2)%i_len = ( td_dom%t_dim0(2)%i_len - & & ( td_dom%i_jmin ) + 1 ) + & & ( td_dom%t_dim0(2)%i_len - & & ( td_dom%i_jmax ) + 1 ) - 2 ! add ghost cell td_dom%i_ighost=1 td_dom%i_jghost=1 ! periodicity td_dom%i_perio=0 ENDIF END SUBROUTINE dom__size_pole_overlap !> @endcode !------------------------------------------------------------------- !> @brief !> This subroutine compute size of an extract domain with north fold !> condition, and which do not overlap east-west boundary !> !> @author J.Paul !> - Nov, 2013- Subroutine written ! !> @param[inout] td_dom : domain strcuture !> @note never tested !------------------------------------------------------------------- !> @code SUBROUTINE dom__size_pole_no_overlap( td_dom ) IMPLICIT NONE ! Argument TYPE(TDOM), INTENT(INOUT) :: td_dom ! local variable INTEGER(i4) :: il_idom1 ! extract domain size, east part INTEGER(i4) :: il_idom2 ! extract domain size, west part INTEGER(i4) :: il_mid ! canadian biple index ? !---------------------------------------------------------------- IF( td_dom%i_imin >= td_dom%i_imax )THEN CALL logger_fatal("DOM INIT: invalid domain. "//& & "can not overlap East-West boundary with this coarse grid. "//& & "check namelist and coarse grid periodicity." ) ENDIF CALL logger_trace("DEFINE POLE NO OVERLAP: "//& & "no asian bipole inside domain to extract") ! north pole IF( td_dom%i_jmax >= td_dom%t_dim0(2)%i_len-1 )THEN td_dom%i_jmax=MIN( td_dom%i_jmin, & & td_dom%t_dim0(2)%i_len-td_dom%i_jmax ) ELSE td_dom%i_jmax=MIN( td_dom%i_jmin, td_dom%i_jmax ) ENDIF td_dom%i_jmin=td_dom%i_jmax ! il_mid = td_dom%t_dim0(1)%i_len/2 + td_dom%i_pivot IF( (td_dom%i_imin < il_mid .AND. td_dom%i_imax < il_mid) .OR. & & (td_dom%i_imin > il_mid .AND. td_dom%i_imax > il_mid) )THEN CALL logger_trace("DEFINE POLE NO OVERLAP: "//& & "no canadian bipole inside domain to extract") td_dom%t_dim(1)%i_len = ( td_dom%i_imax ) - & & ( td_dom%i_imin ) + 1 td_dom%t_dim(2)%i_len = ( td_dom%t_dim0(2)%i_len - & & ( td_dom%i_jmin ) + 1 ) + & & ( td_dom%t_dim0(2)%i_len - & & ( td_dom%i_jmax ) + 1 ) - 2 ! remove north fold condition ? ! add ghost cell td_dom%i_ighost=1 td_dom%i_jghost=1 ! periodicity td_dom%i_perio=0 ELSE ! id_imin < il_mid .AND. id_imax > il_mid CALL logger_trace("DEFINE POLE NO OVERLAP: "//& & "canadian bipole inside domain to extract") il_idom1 = td_dom%i_imax - (il_mid - 1) il_idom2 = il_mid - td_dom%i_imin IF( il_idom1 > il_idom2 )THEN ! east part bigger than west part CALL logger_trace("DEFINE POLE NO OVERLAP: east part bigger than west part ") ! to respect symmetry around canadian bipole td_dom%i_imin = il_mid - il_idom1 td_dom%t_dim(1)%i_len = il_idom1 + 1 td_dom%t_dim(2)%i_len = ( td_dom%t_dim0(2)%i_len - & & ( td_dom%i_jmin ) + 1 ) + & & ( td_dom%t_dim0(2)%i_len - & & ( td_dom%i_jmax ) + 1 ) & & - 2 - 2 * td_dom%i_pivot ! remove north fold condition ? ! add ghost cell td_dom%i_ighost=1 td_dom%i_jghost=1 ! periodicity td_dom%i_perio=0 ELSE ! il_idom2 >= il_idom1 ! west part bigger than east part CALL logger_trace("DEFINE POLE NO OVERLAP: west part bigger than east part ") ! to respect symmetry around canadian bipole td_dom%i_imax = il_mid + il_idom2 td_dom%t_dim(1)%i_len = il_idom2 + 1 td_dom%t_dim(2)%i_len = ( td_dom%t_dim0(2)%i_len - & & ( td_dom%i_jmin ) + 1 ) + & & ( td_dom%t_dim0(2)%i_len - & & ( td_dom%i_jmax ) + 1 ) & & - 2 - 2 * td_dom%i_pivot ! remove north fold condition ? ! add ghost cell td_dom%i_ighost=1 td_dom%i_jghost=1 ! periodicity td_dom%i_perio=0 ENDIF ENDIF END SUBROUTINE dom__size_pole_no_overlap !> @endcode !------------------------------------------------------------------- !> @brief This function get east west overlap. ! !> @details !> If no east -west wrap return -1, !> else return the size of the ovarlap band ! !> @author J.Paul !> - 2013- Initial Version ! !> @param[in] !------------------------------------------------------------------- !> @code FUNCTION dom_get_ew_overlap(td_lon) IMPLICIT NONE ! Argument TYPE(TVAR), INTENT(IN) :: td_lon ! function INTEGER(i4) :: dom_get_ew_overlap ! local variable REAL(dp), DIMENSION(:,:,:,:), ALLOCATABLE :: dl_value REAL(dp), DIMENSION(:) , ALLOCATABLE :: dl_lone REAL(dp), DIMENSION(:) , ALLOCATABLE :: dl_lonw REAL(dp) :: dl_delta REAL(dp) :: dl_lonmax REAL(dp) :: dl_lonmin INTEGER(i4) :: il_east INTEGER(i4) :: il_west INTEGER(i4) :: il_jmin INTEGER(i4) :: il_jmax INTEGER(i4), PARAMETER :: ip_max_overlap = 5 ! loop indices INTEGER(i4) :: ji !---------------------------------------------------------------- ! init dom_get_ew_overlap=-1 il_west=1 il_east=td_lon%t_dim(1)%i_len ALLOCATE( dl_value(td_lon%t_dim(1)%i_len, & & td_lon%t_dim(2)%i_len, & & td_lon%t_dim(3)%i_len, & & td_lon%t_dim(4)%i_len) ) dl_value(:,:,:,:)=td_lon%d_value(:,:,:,:) WHERE( dl_value(:,:,:,:) > 180._dp .AND. & & dl_value(:,:,:,:) /= td_lon%d_fill ) dl_value(:,:,:,:)=360.-dl_value(:,:,:,:) END WHERE ! we do not use jmax as dimension length due to north fold boundary il_jmin=1+ig_ghost il_jmax=(td_lon%t_dim(2)%i_len-ig_ghost)/2 ALLOCATE( dl_lone(il_jmax-il_jmin+1) ) ALLOCATE( dl_lonw(il_jmax-il_jmin+1) ) dl_lone(:)=dl_value(il_east,il_jmin:il_jmax,1,1) dl_lonw(:)=dl_value(il_west,il_jmin:il_jmax,1,1) IF( .NOT.( ALL(dl_lone(:)==td_lon%d_fill) .AND. & & ALL(dl_lonw(:)==td_lon%d_fill) ) )THEN dl_lonmax=MAXVAL(dl_value(:,il_jmin:il_jmax,:,:)) dl_lonmin=MINVAL(dl_value(:,il_jmin:il_jmax,:,:)) dl_delta=(dl_lonmax-dl_lonmin)/td_lon%t_dim(1)%i_len IF( ALL(ABS(dl_lone(:)) - ABS(dl_lonw(:)) == dl_delta) )THEN dom_get_ew_overlap=0 ELSE IF( ALL( ABS(dl_lone(:)) - ABS(dl_lonw(:)) < & & ip_max_overlap*dl_delta ) )THEN DO ji=0,ip_max_overlap IF( il_east-ji == il_west )THEN ! case of small domain EXIT ELSE dl_lone(:)=dl_value(il_east-ji,il_jmin:il_jmax,1,1) IF( ALL( dl_lonw(:) == dl_lone(:) ) )THEN dom_get_ew_overlap=ji+1 EXIT ENDIF ENDIF ENDDO ENDIF ENDIF DEALLOCATE( dl_value ) END FUNCTION dom_get_ew_overlap !> @endcode !------------------------------------------------------------------- !> @brief !> This subroutine add extra point to domain ! !> @author J.Paul !> @date Nov, 2013 ! !> @param[inout] td_dom : domain strcuture !> @param [in] id_iext : i-direction size of extra bands (default=im_minext) !> @param [in] id_jext : j-direction size of extra bands (default=im_minext) !------------------------------------------------------------------- !> @code SUBROUTINE dom_add_extra( td_dom, id_iext, id_jext ) IMPLICIT NONE ! Argument TYPE(TDOM) , INTENT(INOUT) :: td_dom INTEGER(i4), INTENT(IN ), OPTIONAL :: id_iext INTEGER(i4), INTENT(IN ), OPTIONAL :: id_jext ! local variable INTEGER(i4) :: il_iext INTEGER(i4) :: il_jext ! loop indices !---------------------------------------------------------------- ! init !WARNING: two extrabands are required for cubic interpolation il_iext=im_minext IF( PRESENT(id_iext) ) il_iext=id_iext il_jext=im_minext IF( PRESENT(id_jext) ) il_jext=id_jext td_dom%i_iextra(:)=0 td_dom%i_jextra(:)=0 IF( td_dom%i_imin == 1 .AND. & & td_dom%i_imax == td_dom%t_dim0(1)%i_len .AND. & & td_dom%i_jmin == 1 .AND. & & td_dom%i_jmax == td_dom%t_dim0(2)%i_len )THEN ! global ! nothing to be done ELSE IF( td_dom%i_imin == 1 .AND. & & td_dom%i_imax == td_dom%t_dim0(1)%i_len )THEN ! EW cyclic ! nothing to be done ELSE IF( td_dom%i_imin /= 1 )THEN td_dom%i_iextra(1)=il_iext ELSE IF( td_dom%i_ew0 > 0 )THEN td_dom%i_iextra(1)=il_iext ENDIF ENDIF IF( td_dom%i_imax /= td_dom%t_dim(1)%i_len )THEN td_dom%i_iextra(2)=1 ELSE IF( td_dom%i_ew0 > 0 )THEN td_dom%i_iextra(2)=il_jext ENDIF ENDIF ENDIF IF( td_dom%i_jmin == td_dom%i_jmax )THEN td_dom%i_jextra(1)=il_iext td_dom%i_jextra(2)=il_jext ELSE IF( td_dom%i_jmin /= 1)THEN td_dom%i_jextra(1)=il_iext ENDIF IF( td_dom%i_jmax /= td_dom%t_dim(2)%i_len )THEN td_dom%i_jextra(2)=il_jext ENDIF ENDIF ENDIF ! change domain td_dom%i_imin = td_dom%i_imin - td_dom%i_iextra(1) td_dom%i_jmin = td_dom%i_jmin - td_dom%i_jextra(1) td_dom%i_imax = td_dom%i_imax + td_dom%i_iextra(2) td_dom%i_jmax = td_dom%i_jmax + td_dom%i_jextra(2) td_dom%t_dim(1)%i_len = td_dom%t_dim(1)%i_len + & & td_dom%i_iextra(1) + & & td_dom%i_iextra(2) td_dom%t_dim(2)%i_len = td_dom%t_dim(2)%i_len + & & td_dom%i_jextra(1) + & & td_dom%i_jextra(2) END SUBROUTINE dom_add_extra !> @endcode !------------------------------------------------------------------- !> @brief !> This subroutine clean domain structure. it remove extra point added. ! !> @author J.Paul !> @date Nov, 2013 ! !> @param[inout] td_dom : domain strcuture !------------------------------------------------------------------- !> @code SUBROUTINE dom_clean_extra( td_dom ) IMPLICIT NONE ! Argument TYPE(TDOM) , INTENT(INOUT) :: td_dom ! local variable ! loop indices !---------------------------------------------------------------- ! change domain td_dom%i_imin = td_dom%i_imin + td_dom%i_iextra(1) td_dom%i_jmin = td_dom%i_jmin + td_dom%i_jextra(1) td_dom%i_imax = td_dom%i_imax - td_dom%i_iextra(2) td_dom%i_jmax = td_dom%i_jmax - td_dom%i_jextra(2) td_dom%t_dim(1)%i_len = td_dom%t_dim(1)%i_len - & & td_dom%i_iextra(1) - & & td_dom%i_iextra(2) td_dom%t_dim(2)%i_len = td_dom%t_dim(2)%i_len - & & td_dom%i_jextra(1) - & & td_dom%i_jextra(2) td_dom%i_iextra(:)=0 td_dom%i_jextra(:)=0 END SUBROUTINE dom_clean_extra !> @endcode !------------------------------------------------------------------- !> @brief !> This subroutine ! !> @author J.Paul !> @date Nov, 2013 ! !> @param[inout] td_var : variable strcuture !> @param[inout] td_dom : domain strcuture !> @param[inout] id_rhoi : i-direction refinement factor !> @param[inout] id_rhoj : j-direction refinement factor !------------------------------------------------------------------- !> @code SUBROUTINE dom_del_extra( td_var, td_dom, id_rho ) IMPLICIT NONE ! Argument TYPE(TVAR) , INTENT(INOUT) :: td_var TYPE(TDOM) , INTENT(IN ) :: td_dom INTEGER(i4), DIMENSION(:), INTENT(IN ) :: id_rho ! local variable INTEGER(i4) :: il_iextra INTEGER(i4) :: il_jextra INTEGER(i4) :: il_imin INTEGER(i4) :: il_imax INTEGER(i4) :: il_jmin INTEGER(i4) :: il_jmax REAL(dp), DIMENSION(:,:,:,:), ALLOCATABLE :: dl_value ! loop indices !---------------------------------------------------------------- IF( .NOT. ASSOCIATED(td_var%d_value) )THEN CALL logger_error("DOM DEL EXTRA: no value associated to "//& & "variable "//TRIM(td_var%c_name) ) ELSE ! get vairbale right domain IF( ALL(td_var%t_dim(1:2)%l_use) )THEN il_iextra=SUM(td_dom%i_iextra(:))*id_rho(jp_I) il_jextra=SUM(td_dom%i_jextra(:))*id_rho(jp_J) ALLOCATE(dl_value(td_var%t_dim(1)%i_len, & & td_var%t_dim(2)%i_len, & & td_var%t_dim(3)%i_len, & & td_var%t_dim(4)%i_len) ) dl_value(:,:,:,:)=td_var%d_value(:,:,:,:) il_imin=1 + td_dom%i_iextra(1)*id_rho(jp_I) il_imax=td_var%t_dim(1)%i_len - td_dom%i_iextra(2)*id_rho(jp_I) il_jmin=1 + td_dom%i_jextra(1)*id_rho(jp_J) il_jmax=td_var%t_dim(2)%i_len - td_dom%i_jextra(2)*id_rho(jp_J) td_var%t_dim(1)%i_len=td_var%t_dim(1)%i_len-il_iextra td_var%t_dim(2)%i_len=td_var%t_dim(2)%i_len-il_jextra DEALLOCATE(td_var%d_value) ALLOCATE(td_var%d_value(td_var%t_dim(1)%i_len, & & td_var%t_dim(2)%i_len, & & td_var%t_dim(3)%i_len, & & td_var%t_dim(4)%i_len) ) td_var%d_value(:,:,:,:)=dl_value(il_imin:il_imax, & & il_jmin:il_jmax, & & :, :) DEALLOCATE(dl_value) ENDIF ENDIF END SUBROUTINE dom_del_extra !> @endcode !------------------------------------------------------------------- !> @brief !> This subroutine clean mpp strcuture. ! !> @author J.Paul !> @date Nov, 2013 ! !> @param[inout] td_dom : domain strcuture !------------------------------------------------------------------- !> @code SUBROUTINE dom_clean( td_dom ) IMPLICIT NONE ! Argument TYPE(TDOM), INTENT(INOUT) :: td_dom ! local variable TYPE(TDOM) :: tl_dom ! empty file structure ! loop indices INTEGER(i4) :: ji !---------------------------------------------------------------- CALL logger_info( " CLEAN: reset domain " ) ! del dimension DO ji=ip_maxdim,1,-1 CALL dim_clean( td_dom%t_dim0(ji) ) ENDDO ! replace by empty structure td_dom=tl_dom END SUBROUTINE dom_clean END MODULE dom