4468 lines
154 KiB
Fortran
Executable File
4468 lines
154 KiB
Fortran
Executable File
!----------------------------------------------------------------------
|
|
! NEMO system team, System and Interface for oceanic RElocable Nesting
|
|
!----------------------------------------------------------------------
|
|
!
|
|
! DESCRIPTION:
|
|
!> @brief
|
|
!> This module manage massively parallel processing.
|
|
!>
|
|
!> @details
|
|
!> define type TMPP:<br/>
|
|
!> @code
|
|
!> TYPE(TMPP) :: tl_mpp
|
|
!> @endcode
|
|
!>
|
|
!> to initialise a mpp structure:<br/>
|
|
!> @code
|
|
!> tl_mpp=mpp_init( cd_file, id_mask,
|
|
!> [id_niproc,] [id_njproc,] [id_nproc,]
|
|
!> [id_preci,] [id_precj,]
|
|
!> [cd_type,] [id_ew])
|
|
!> @endcode
|
|
!> or
|
|
!> @code
|
|
!> tl_mpp=mpp_init( cd_file, td_var,
|
|
!> [id_niproc,] [id_njproc,] [id_nproc,]
|
|
!> [id_preci,] [id_precj,]
|
|
!> [cd_type] )
|
|
!> @endcode
|
|
!> or
|
|
!> @code
|
|
!> tl_mpp=mpp_init( td_file [,id_ew] )
|
|
!> @endcode
|
|
!> - cd_file is the filename of the global domain file, in which
|
|
!> MPP will be done (example: Bathymetry)
|
|
!> - td_file is the file structure of one processor file composing an MPP
|
|
!> - id_mask is the 2D mask of global domain [optional]
|
|
!> - td_var is a variable structure (on T-point) from global domain file.
|
|
!> mask of the domain will be computed using FillValue [optional]
|
|
!> - id_niproc is the number of processor following I-direction to be used
|
|
!> [optional]
|
|
!> - id_njproc is the number of processor following J-direction to be used
|
|
!> [optional]
|
|
!> - id_nproc is the total number of processor to be used [optional]
|
|
!> - id_preci is the size of the overlap region following I-direction [optional]
|
|
!> - id_precj is the size of the overlap region following J-direction [optional]
|
|
!> - cd_type is the type of files composing MPP [optional]
|
|
!> - id_ew is east-west overlap [optional]<br/>
|
|
!>
|
|
!> to get mpp name:<br/>
|
|
!> - tl_mpp\%c_name
|
|
!>
|
|
!> to get the total number of processor:<br/>
|
|
!> - tl_mpp\%i_nproc
|
|
!>
|
|
!> to get the number of processor following I-direction:<br/>
|
|
!> - tl_mpp\%i_niproc
|
|
!>
|
|
!> to get the number of processor following J-direction:<br/>
|
|
!> - tl_mpp\%i_njproc
|
|
!>
|
|
!> to get the length of the overlap region following I-direction:<br/>
|
|
!> - tl_mpp\%i_preci
|
|
!>
|
|
!> to get the length of the overlap region following J-direction:<br/>
|
|
!> - tl_mpp\%i_precj
|
|
!>
|
|
!> to get the type of files composing mpp structure:<br/>
|
|
!> - tl_mpp\%c_type
|
|
!>
|
|
!> to get the type of the global domain:<br/>
|
|
!> - tl_mpp\%c_dom
|
|
!>
|
|
!> MPP dimensions (global domain)<br/>
|
|
!> to get the number of dimensions to be used in mpp strcuture:<br/>
|
|
!> - tl_mpp\%i_ndim
|
|
!>
|
|
!> to get the array of dimension structure (4 elts) associated to the
|
|
!> mpp structure:<br/>
|
|
!> - tl_mpp\%t_dim(:)
|
|
!>
|
|
!> MPP processor (files composing domain)<br/>
|
|
!> - tl_mpp\%t_proc(:)
|
|
!>
|
|
!> to clean a mpp structure:<br/>
|
|
!> @code
|
|
!> CALL mpp_clean(tl_mpp)
|
|
!> @endcode
|
|
!>
|
|
!> to print information about mpp:<br/>
|
|
!> @code
|
|
!> CALL mpp_print(tl_mpp)
|
|
!> @endcode
|
|
!>
|
|
!> to add variable to mpp:<br/>
|
|
!> @code
|
|
!> CALL mpp_add_var(td_mpp, td_var)
|
|
!> @endcode
|
|
!> - td_var is a variable structure
|
|
!>
|
|
!> to add dimension to mpp:<br/>
|
|
!> @code
|
|
!> CALL mpp_add_dim(td_mpp, td_dim)
|
|
!> @endcode
|
|
!> - td_dim is a dimension structure
|
|
!>
|
|
!> to add attribute to mpp:<br/>
|
|
!> @code
|
|
!> CALL mpp_add_att(td_mpp, td_att)
|
|
!> @endcode
|
|
!> - td_att is a attribute structure
|
|
!>
|
|
!> to delete variable from mpp:<br/>
|
|
!> @code
|
|
!> CALL mpp_del_var(td_mpp, td_var)
|
|
!> @endcode
|
|
!> or
|
|
!> @code
|
|
!> CALL mpp_del_var(td_mpp, cd_name)
|
|
!> @endcode
|
|
!> - td_var is a variable structure
|
|
!> - cd_name is variable name or standard name
|
|
!>
|
|
!> to delete dimension from mpp:<br/>
|
|
!> @code
|
|
!> CALL mpp_del_dim(td_mpp, td_dim)
|
|
!> @endcode
|
|
!> - td_dim is a dimension structure
|
|
!>
|
|
!> to delete attribute from mpp:<br/>
|
|
!> @code
|
|
!> CALL mpp_del_att(td_mpp, td_att)
|
|
!> @endcode
|
|
!> or
|
|
!> @code
|
|
!> CALL mpp_del_att(td_mpp, cd_name)
|
|
!> @endcode
|
|
!> - td_att is a attribute structure
|
|
!> - cd_name is attribute name
|
|
!>
|
|
!> to overwrite variable to mpp:<br/>
|
|
!> @code
|
|
!> CALL mpp_move_var(td_mpp, td_var)
|
|
!> @endcode
|
|
!> - td_var is a variable structure
|
|
!>
|
|
!> to overwrite dimension to mpp:<br/>
|
|
!> @code
|
|
!> CALL mpp_move_dim(td_mpp, td_dim)
|
|
!> @endcode
|
|
!> - td_dim is a dimension structure
|
|
!>
|
|
!> to overwrite attribute to mpp:<br/>
|
|
!> @code
|
|
!> CALL mpp_move_att(td_mpp, td_att)
|
|
!> @endcode
|
|
!> - td_att is a attribute structure
|
|
!>
|
|
!> to determine domain decomposition type:<br/>
|
|
!> @code
|
|
!> CALL mpp_get_dom(td_mpp)
|
|
!> @endcode
|
|
!>
|
|
!> to get processors to be used:<br/>
|
|
!> @code
|
|
!> CALL mpp_get_use( td_mpp, id_imin, id_imax, &
|
|
!> & id_jmin, id_jmax )
|
|
!> @endcode
|
|
!> - id_imin
|
|
!> - id_imax
|
|
!> - id_jmin
|
|
!> - id_jmax
|
|
!>
|
|
!> to get sub domains which form global domain contour:<br/>
|
|
!> @code
|
|
!> CALL mpp_get_contour( td_mpp )
|
|
!> @endcode
|
|
!>
|
|
!> to get global domain indices of one processor:<br/>
|
|
!> @code
|
|
!> il_ind(1:4)=mpp_get_proc_index( td_mpp, id_procid )
|
|
!> @endcode
|
|
!> - il_ind(1:4) are global domain indices (i1,i2,j1,j2)
|
|
!> - id_procid is the processor id
|
|
!>
|
|
!> to get the processor domain size:<br/>
|
|
!> @code
|
|
!> il_size(1:2)=mpp_get_proc_size( td_mpp, id_procid )
|
|
!> @endcode
|
|
!> - il_size(1:2) are the size of domain following I and J
|
|
!> - id_procid is the processor id
|
|
!>
|
|
!> @author
|
|
!> J.Paul
|
|
!>
|
|
!> @date November, 2013 - Initial Version
|
|
!> @date November, 2014
|
|
!> - Fix memory leaks bug
|
|
!> @date October, 2015
|
|
!> - improve way to compute domain layout
|
|
!> @date January, 2016
|
|
!> - allow to print layout file (use lm_layout, hard coded)
|
|
!> - add mpp__compute_halo and mpp__read_halo
|
|
!>
|
|
!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
|
|
!>
|
|
!> @todo
|
|
!> - ECRIRE ET TESTER add_proc_array pour optimiser codes (voir old/MO_mpp.f90)
|
|
!----------------------------------------------------------------------
|
|
MODULE mpp
|
|
|
|
USE global ! global parameter
|
|
USE kind ! F90 kind parameter
|
|
USE logger ! log file manager
|
|
USE fct ! basic useful function
|
|
USE dim ! dimension manager
|
|
USE att ! attribute manager
|
|
USE var ! variable manager
|
|
USE file ! file manager
|
|
USE iom ! I/O manager
|
|
|
|
IMPLICIT NONE
|
|
! NOTE_avoid_public_variables_if_possible
|
|
|
|
! type and variable
|
|
PUBLIC :: TMPP !< mpp structure
|
|
PRIVATE :: TLAY !< domain layout structure
|
|
|
|
! function and subroutine
|
|
PUBLIC :: mpp_copy !< copy mpp structure
|
|
PUBLIC :: mpp_init !< initialise mpp structure
|
|
PUBLIC :: mpp_clean !< clean mpp strcuture
|
|
PUBLIC :: mpp_print !< print information about mpp structure
|
|
PUBLIC :: mpp_add_var !< split/add one variable strucutre in mpp structure
|
|
PUBLIC :: mpp_add_dim !< add one dimension to mpp structure
|
|
PUBLIC :: mpp_add_att !< add one attribute strucutre in mpp structure
|
|
PUBLIC :: mpp_del_var !< delete one variable strucutre in mpp structure
|
|
PUBLIC :: mpp_del_dim !< delete one dimension strucutre in mpp structure
|
|
PUBLIC :: mpp_del_att !< delete one attribute strucutre in mpp structure
|
|
PUBLIC :: mpp_move_var !< overwrite variable structure in mpp structure
|
|
PUBLIC :: mpp_move_dim !< overwrite one dimension strucutre in mpp structure
|
|
PUBLIC :: mpp_move_att !< overwrite one attribute strucutre in mpp structure
|
|
PUBLIC :: mpp_recombine_var !< recombine variable from mpp structure
|
|
PUBLIC :: mpp_get_index !< return index of mpp
|
|
|
|
PUBLIC :: mpp_get_dom !< determine domain decomposition type (full, overlap, noverlap)
|
|
PUBLIC :: mpp_get_use !< get sub domains to be used (which cover "zoom domain")
|
|
PUBLIC :: mpp_get_contour !< get sub domains which form global domain contour
|
|
PUBLIC :: mpp_get_proc_index !< get processor domain indices
|
|
PUBLIC :: mpp_get_proc_size !< get processor domain size
|
|
|
|
PRIVATE :: mpp__add_proc ! add proc strucutre in mpp structure
|
|
PRIVATE :: mpp__add_proc_unit ! add one proc strucutre in mpp structure
|
|
PRIVATE :: mpp__add_proc_arr ! add array of proc strucutre in mpp structure
|
|
PRIVATE :: mpp__del_proc ! delete one proc strucutre in mpp structure
|
|
PRIVATE :: mpp__del_proc_id ! delete one proc strucutre in mpp structure, given procesor id
|
|
PRIVATE :: mpp__del_proc_str ! delete one proc strucutre in mpp structure, given procesor file structure
|
|
PRIVATE :: mpp__move_proc ! overwrite proc strucutre in mpp structure
|
|
PRIVATE :: mpp__create_layout ! create mpp structure using domain layout
|
|
PRIVATE :: mpp__optimiz ! compute optimum domain decomposition
|
|
PRIVATE :: mpp__check_dim ! check mpp structure dimension with proc or variable dimension
|
|
PRIVATE :: mpp__check_proc_dim ! check if processor and mpp structure use same dimension
|
|
PRIVATE :: mpp__check_var_dim ! check if variable and mpp structure use same dimension
|
|
PRIVATE :: mpp__del_var_name ! delete variable in mpp structure, given variable name
|
|
PRIVATE :: mpp__del_var_mpp ! delete all variable in mpp structure
|
|
PRIVATE :: mpp__del_var_str ! delete variable in mpp structure, given variable structure
|
|
PRIVATE :: mpp__del_att_name ! delete variable in mpp structure, given variable name
|
|
PRIVATE :: mpp__del_att_str ! delete variable in mpp structure, given variable structure
|
|
PRIVATE :: mpp__split_var ! extract variable part that will be written in processor
|
|
PRIVATE :: mpp__copy_unit ! copy mpp structure
|
|
PRIVATE :: mpp__copy_arr ! copy array of mpp structure
|
|
PRIVATE :: mpp__get_use_unit ! get sub domains to be used (which cover "zoom domain")
|
|
PRIVATE :: mpp__init_mask ! initialise mpp structure, given mask array
|
|
PRIVATE :: mpp__init_var ! initialise mpp structure, given variable strcuture
|
|
PRIVATE :: mpp__init_file ! initialise a mpp structure, given file structure
|
|
PRIVATE :: mpp__init_file_cdf ! initialise a mpp structure with cdf file
|
|
PRIVATE :: mpp__init_file_rstdimg ! initialise a mpp structure with rstdimg file
|
|
PRIVATE :: mpp__clean_unit ! clean mpp strcuture
|
|
PRIVATE :: mpp__clean_arr ! clean array of mpp strcuture
|
|
PRIVATE :: mpp__compute_halo ! compute subdomain indices defined with halo
|
|
PRIVATE :: mpp__read_halo ! read subdomain indices defined with halo
|
|
|
|
PRIVATE :: layout__init ! initialise domain layout structure
|
|
PRIVATE :: layout__copy ! clean domain layout structure
|
|
PRIVATE :: layout__clean ! copy domain layout structure
|
|
|
|
TYPE TMPP !< mpp structure
|
|
! general
|
|
CHARACTER(LEN=lc) :: c_name = '' !< base name
|
|
INTEGER(i4) :: i_id = 0 !< mpp id
|
|
|
|
INTEGER(i4) :: i_niproc = 0 !< number of processors following i
|
|
INTEGER(i4) :: i_njproc = 0 !< number of processors following j
|
|
INTEGER(i4) :: i_nproc = 0 !< total number of proccessors used
|
|
INTEGER(i4) :: i_preci = 1 !< i-direction overlap region length
|
|
INTEGER(i4) :: i_precj = 1 !< j-direction overlap region length
|
|
INTEGER(i4) :: i_ew = -1 !< east-west overlap
|
|
INTEGER(i4) :: i_perio = -1 !< NEMO periodicity index
|
|
INTEGER(i4) :: i_pivot = -1 !< NEMO pivot point index F(0),T(1)
|
|
|
|
CHARACTER(LEN=lc) :: c_type = '' !< type of the files (cdf, cdf4, dimg)
|
|
CHARACTER(LEN=lc) :: c_dom = '' !< type of domain (full, noextra, nooverlap)
|
|
|
|
INTEGER(i4) :: i_ndim = 0 !< number of dimensions used in mpp
|
|
TYPE(TDIM), DIMENSION(ip_maxdim) :: t_dim !< global domain dimension
|
|
|
|
TYPE(TFILE), DIMENSION(:), POINTER :: t_proc => NULL() !< files/processors composing mpp
|
|
|
|
LOGICAL :: l_usempp = .TRUE. !< use mpp decomposition for writing netcdf
|
|
END TYPE
|
|
|
|
TYPE TLAY !< domain layout structure
|
|
INTEGER(i4) :: i_niproc = 0 !< number of processors following i
|
|
INTEGER(i4) :: i_njproc = 0 !< number of processors following j
|
|
INTEGER(i4) :: i_nland = 0 !< number of land processors
|
|
INTEGER(i4) :: i_nsea = 0 !< number of sea processors
|
|
INTEGER(i4) :: i_mean = 0 !< mean sea point per proc
|
|
INTEGER(i4) :: i_min = 0 !< min sea point per proc
|
|
INTEGER(i4) :: i_max = 0 !< max sea point per proc
|
|
INTEGER(i4), DIMENSION(:,:), POINTER :: i_msk => NULL() !< sea/land processor mask
|
|
INTEGER(i4), DIMENSION(:,:), POINTER :: i_impp => NULL() !< i-indexes for mpp-subdomain left bottom
|
|
INTEGER(i4), DIMENSION(:,:), POINTER :: i_jmpp => NULL() !< j-indexes for mpp-subdomain left bottom
|
|
INTEGER(i4), DIMENSION(:,:), POINTER :: i_lci => NULL() !< i-dimensions of subdomain
|
|
INTEGER(i4), DIMENSION(:,:), POINTER :: i_lcj => NULL() !< j-dimensions of subdomain
|
|
END TYPE
|
|
|
|
! module variable
|
|
INTEGER(i4) :: im_psize = 2000 !< processor dimension length for huge file
|
|
|
|
INTEGER(i4) :: im_iumout = 44
|
|
LOGICAL :: lm_layout =.FALSE.
|
|
|
|
INTERFACE mpp_get_use
|
|
MODULE PROCEDURE mpp__get_use_unit
|
|
END INTERFACE mpp_get_use
|
|
|
|
INTERFACE mpp__add_proc
|
|
MODULE PROCEDURE mpp__add_proc_unit
|
|
MODULE PROCEDURE mpp__add_proc_arr
|
|
END INTERFACE mpp__add_proc
|
|
|
|
INTERFACE mpp_clean
|
|
MODULE PROCEDURE mpp__clean_unit
|
|
MODULE PROCEDURE mpp__clean_arr
|
|
END INTERFACE mpp_clean
|
|
|
|
INTERFACE mpp__check_dim
|
|
MODULE PROCEDURE mpp__check_proc_dim !< check if processor and mpp structure use same dimension
|
|
MODULE PROCEDURE mpp__check_var_dim !< check if variable and mpp structure use same dimension
|
|
END INTERFACE mpp__check_dim
|
|
|
|
INTERFACE mpp__del_proc
|
|
MODULE PROCEDURE mpp__del_proc_id
|
|
MODULE PROCEDURE mpp__del_proc_str
|
|
END INTERFACE mpp__del_proc
|
|
|
|
INTERFACE mpp_del_var
|
|
MODULE PROCEDURE mpp__del_var_name
|
|
MODULE PROCEDURE mpp__del_var_str
|
|
MODULE PROCEDURE mpp__del_var_mpp
|
|
END INTERFACE mpp_del_var
|
|
|
|
INTERFACE mpp_del_att
|
|
MODULE PROCEDURE mpp__del_att_name
|
|
MODULE PROCEDURE mpp__del_att_str
|
|
END INTERFACE mpp_del_att
|
|
|
|
INTERFACE mpp_init
|
|
MODULE PROCEDURE mpp__init_mask
|
|
MODULE PROCEDURE mpp__init_var
|
|
MODULE PROCEDURE mpp__init_file
|
|
END INTERFACE mpp_init
|
|
|
|
INTERFACE mpp_copy
|
|
MODULE PROCEDURE mpp__copy_unit ! copy mpp structure
|
|
MODULE PROCEDURE mpp__copy_arr ! copy array of mpp structure
|
|
END INTERFACE
|
|
|
|
CONTAINS
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
FUNCTION mpp__copy_unit(td_mpp) &
|
|
& RESULT(tf_mpp)
|
|
!-------------------------------------------------------------------
|
|
!> @brief
|
|
!> This subroutine copy mpp structure in another one
|
|
!> @details
|
|
!> mpp file are copied in a temporary array,
|
|
!> so input and output mpp structure do not point on the same
|
|
!> "memory cell", and so on are independant.
|
|
!>
|
|
!> @warning do not use on the output of a function who create or read an
|
|
!> structure (ex: tl_file=file_copy(file_init()) is forbidden).
|
|
!> This will create memory leaks.
|
|
!> @warning to avoid infinite loop, do not use any function inside
|
|
!> this subroutine
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date November, 2013 - Initial Version
|
|
!> @date November, 2014
|
|
!> - use function instead of overload assignment operator
|
|
!> (to avoid memory leak)
|
|
!> @date January, 2019
|
|
!> - clean file structure
|
|
!>
|
|
!> @param[in] td_mpp mpp structure
|
|
!> @return copy of input mpp structure
|
|
!-------------------------------------------------------------------
|
|
|
|
IMPLICIT NONE
|
|
|
|
! Argument
|
|
TYPE(TMPP), INTENT(IN) :: td_mpp
|
|
|
|
! function
|
|
TYPE(TMPP) :: tf_mpp
|
|
|
|
! local variable
|
|
TYPE(TFILE) :: tl_file
|
|
|
|
! loop indices
|
|
INTEGER(i4) :: ji
|
|
!----------------------------------------------------------------
|
|
|
|
CALL logger_trace("MPP COPY: "//TRIM(td_mpp%c_name)//" in "//&
|
|
& TRIM(tf_mpp%c_name))
|
|
|
|
! copy mpp variable
|
|
tf_mpp%c_name = TRIM(td_mpp%c_name)
|
|
tf_mpp%i_id = td_mpp%i_id
|
|
tf_mpp%i_niproc = td_mpp%i_niproc
|
|
tf_mpp%i_njproc = td_mpp%i_njproc
|
|
tf_mpp%i_nproc = td_mpp%i_nproc
|
|
tf_mpp%i_preci = td_mpp%i_preci
|
|
tf_mpp%i_precj = td_mpp%i_precj
|
|
tf_mpp%c_type = TRIM(td_mpp%c_type)
|
|
tf_mpp%c_dom = TRIM(td_mpp%c_dom)
|
|
tf_mpp%i_ndim = td_mpp%i_ndim
|
|
tf_mpp%i_ew = td_mpp%i_ew
|
|
tf_mpp%i_perio = td_mpp%i_perio
|
|
tf_mpp%i_pivot = td_mpp%i_pivot
|
|
tf_mpp%l_usempp = td_mpp%l_usempp
|
|
|
|
! copy dimension
|
|
tf_mpp%t_dim(:) = dim_copy(td_mpp%t_dim(:))
|
|
|
|
! copy file structure
|
|
IF( ASSOCIATED(tf_mpp%t_proc) )THEN
|
|
CALL file_clean(tf_mpp%t_proc(:))
|
|
DEALLOCATE(tf_mpp%t_proc)
|
|
ENDIF
|
|
IF( ASSOCIATED(td_mpp%t_proc) .AND. tf_mpp%i_nproc > 0 )THEN
|
|
ALLOCATE( tf_mpp%t_proc(tf_mpp%i_nproc) )
|
|
DO ji=1,tf_mpp%i_nproc
|
|
tl_file = file_copy(td_mpp%t_proc(ji))
|
|
tf_mpp%t_proc(ji) = file_copy(tl_file)
|
|
ENDDO
|
|
! clean
|
|
CALL file_clean(tl_file)
|
|
ENDIF
|
|
|
|
END FUNCTION mpp__copy_unit
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
FUNCTION mpp__copy_arr(td_mpp) &
|
|
& RESULT(tf_mpp)
|
|
!-------------------------------------------------------------------
|
|
!> @brief
|
|
!> This subroutine copy an array of mpp structure in another one
|
|
!> @details
|
|
!> mpp file are copied in a temporary array,
|
|
!> so input and output mpp structure do not point on the same
|
|
!> "memory cell", and so on are independant.
|
|
!>
|
|
!> @warning do not use on the output of a function who create or read an
|
|
!> structure (ex: tl_file=file_copy(file_init()) is forbidden).
|
|
!> This will create memory leaks.
|
|
!> @warning to avoid infinite loop, do not use any function inside
|
|
!> this subroutine
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date November, 2013 - Initial Version
|
|
!> @date November, 2014
|
|
!> - use function instead of overload assignment operator
|
|
!> (to avoid memory leak)
|
|
!>
|
|
!> @param[in] td_mpp mpp structure
|
|
!> @return copy of input array of mpp structure
|
|
!-------------------------------------------------------------------
|
|
|
|
IMPLICIT NONE
|
|
|
|
! Argument
|
|
TYPE(TMPP), DIMENSION(:), INTENT(IN) :: td_mpp
|
|
|
|
! function
|
|
TYPE(TMPP), DIMENSION(SIZE(td_mpp(:))) :: tf_mpp
|
|
|
|
! local variable
|
|
! loop indices
|
|
INTEGER(i4) :: ji
|
|
!----------------------------------------------------------------
|
|
|
|
DO ji=1,SIZE(td_mpp(:))
|
|
tf_mpp(ji)=mpp_copy(td_mpp(ji))
|
|
ENDDO
|
|
|
|
END FUNCTION mpp__copy_arr
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
SUBROUTINE mpp_print(td_mpp)
|
|
!-------------------------------------------------------------------
|
|
!> @brief This subroutine print some information about mpp strucutre.
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date November, 2013 - Initial Version
|
|
!>
|
|
!> @param[in] td_mpp mpp structure
|
|
!-------------------------------------------------------------------
|
|
|
|
IMPLICIT NONE
|
|
|
|
! Argument
|
|
TYPE(TMPP), INTENT(IN) :: td_mpp
|
|
|
|
! local variable
|
|
INTEGER(i4), PARAMETER :: ip_freq = 4
|
|
INTEGER(i4), PARAMETER :: ip_min = 5
|
|
|
|
INTEGER(i4) :: il_min
|
|
INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_proc
|
|
INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_lci
|
|
INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_lcj
|
|
|
|
! loop indices
|
|
INTEGER(i4) :: ji
|
|
INTEGER(i4) :: jj
|
|
INTEGER(i4) :: jk
|
|
INTEGER(i4) :: jl
|
|
INTEGER(i4) :: jm
|
|
!----------------------------------------------------------------
|
|
|
|
WRITE(*,'((a,a),2(/3x,a,a),9(/3x,a,i0))')&
|
|
& "MPP : ",TRIM(td_mpp%c_name), &
|
|
& " type : ",TRIM(td_mpp%c_type), &
|
|
& " dom : ",TRIM(td_mpp%c_dom), &
|
|
& " nproc : ",td_mpp%i_nproc, &
|
|
& " niproc : ",td_mpp%i_niproc, &
|
|
& " njproc : ",td_mpp%i_njproc, &
|
|
& " preci : ",td_mpp%i_preci, &
|
|
& " precj : ",td_mpp%i_precj, &
|
|
& " ndim : ",td_mpp%i_ndim, &
|
|
& " overlap: ",td_mpp%i_ew, &
|
|
& " perio : ",td_mpp%i_perio, &
|
|
& " pivot : ",td_mpp%i_pivot
|
|
|
|
! print dimension
|
|
IF( td_mpp%i_ndim /= 0 )THEN
|
|
WRITE(*,'(/a)') " MPP dimension"
|
|
DO ji=1,ip_maxdim
|
|
IF( td_mpp%t_dim(ji)%l_use )THEN
|
|
CALL dim_print(td_mpp%t_dim(ji))
|
|
ENDIF
|
|
ENDDO
|
|
ENDIF
|
|
|
|
! print file
|
|
IF( td_mpp%i_nproc /= 0 .AND. ASSOCIATED(td_mpp%t_proc) )THEN
|
|
IF( ALL( td_mpp%t_proc(:)%i_iind==0 ) .OR. &
|
|
& ALL( td_mpp%t_proc(:)%i_jind==0 ) )THEN
|
|
|
|
il_min=MIN(td_mpp%i_nproc,ip_min)
|
|
DO ji=1,il_min
|
|
CALL file_print(td_mpp%t_proc(ji))
|
|
WRITE(*,'((a),(/3x,a,i0),2(/3x,a,a),4(/3x,a,i0,a,i0)/)')&
|
|
& " Domain decomposition : ", &
|
|
& " id : ",td_mpp%t_proc(ji)%i_pid, &
|
|
& " used : ",TRIM(fct_str(td_mpp%t_proc(ji)%l_use)), &
|
|
& " contour : ",TRIM(fct_str(td_mpp%t_proc(ji)%l_ctr)), &
|
|
& " left-bottom : ",td_mpp%t_proc(ji)%i_impp,', ',&
|
|
& td_mpp%t_proc(ji)%i_jmpp, &
|
|
& " dimension : ",td_mpp%t_proc(ji)%i_lci,' x ',&
|
|
& td_mpp%t_proc(ji)%i_lcj, &
|
|
& " first indoor indices : ",td_mpp%t_proc(ji)%i_ldi,', ',&
|
|
& td_mpp%t_proc(ji)%i_ldj, &
|
|
& " last indoor indices : ",td_mpp%t_proc(ji)%i_lei,', ',&
|
|
& td_mpp%t_proc(ji)%i_lej
|
|
|
|
ENDDO
|
|
IF( td_mpp%i_nproc > ip_min )THEN
|
|
WRITE(*,'(a)') "...etc"
|
|
ENDIF
|
|
|
|
IF( td_mpp%t_proc(1)%i_nvar > 0 )THEN
|
|
WRITE(*,'(/a)') " Variable(s) used : "
|
|
DO ji=1,td_mpp%t_proc(1)%i_nvar
|
|
WRITE(*,'(3x,a)') TRIM(td_mpp%t_proc(1)%t_var(ji)%c_name)
|
|
ENDDO
|
|
ENDIF
|
|
|
|
ELSE
|
|
|
|
il_min=MIN(td_mpp%i_nproc,ip_min)
|
|
DO ji=1,il_min
|
|
CALL file_print(td_mpp%t_proc(ji))
|
|
WRITE(*,'((a, a),(/3x,a,i0),(/3x,a,a),4(/3x,a,i0,a,i0)/)')&
|
|
& " Domain decomposition : ",TRIM(td_mpp%t_proc(ji)%c_name),&
|
|
& " id : ",td_mpp%t_proc(ji)%i_pid, &
|
|
& " used : ",TRIM(fct_str(td_mpp%t_proc(ji)%l_use)),&
|
|
& " left-bottom : ",td_mpp%t_proc(ji)%i_impp,', ',&
|
|
& td_mpp%t_proc(ji)%i_jmpp, &
|
|
& " dimension : ",td_mpp%t_proc(ji)%i_lci,' x ',&
|
|
& td_mpp%t_proc(ji)%i_lcj, &
|
|
& " first indoor indices : ",td_mpp%t_proc(ji)%i_ldi,',',&
|
|
& td_mpp%t_proc(ji)%i_ldj, &
|
|
& " last indoor indices : ",td_mpp%t_proc(ji)%i_lei,', ',&
|
|
& td_mpp%t_proc(ji)%i_lej
|
|
|
|
ENDDO
|
|
IF( td_mpp%i_nproc > ip_min )THEN
|
|
WRITE(*,'(a)') "...etc"
|
|
ENDIF
|
|
|
|
IF( td_mpp%t_proc(1)%i_nvar > 0 )THEN
|
|
WRITE(*,'(/a)') " Variable(s) used : "
|
|
DO ji=1,td_mpp%t_proc(1)%i_nvar
|
|
WRITE(*,'(3x,a)') TRIM(td_mpp%t_proc(1)%t_var(ji)%c_name)
|
|
ENDDO
|
|
ENDIF
|
|
|
|
IF( td_mpp%l_usempp )THEN
|
|
ALLOCATE( il_proc(td_mpp%i_niproc,td_mpp%i_njproc) )
|
|
ALLOCATE( il_lci(td_mpp%i_niproc,td_mpp%i_njproc) )
|
|
ALLOCATE( il_lcj(td_mpp%i_niproc,td_mpp%i_njproc) )
|
|
il_proc(:,:)=-1
|
|
il_lci(:,:) =-1
|
|
il_lcj(:,:) =-1
|
|
|
|
DO jk=1,td_mpp%i_nproc
|
|
ji=td_mpp%t_proc(jk)%i_iind
|
|
jj=td_mpp%t_proc(jk)%i_jind
|
|
il_proc(ji,jj)=jk-1
|
|
il_lci(ji,jj)=td_mpp%t_proc(jk)%i_lci
|
|
il_lcj(ji,jj)=td_mpp%t_proc(jk)%i_lcj
|
|
ENDDO
|
|
|
|
jl = 1
|
|
DO jk = 1,(td_mpp%i_niproc-1)/ip_freq+1
|
|
jm = MIN(td_mpp%i_niproc, jl+ip_freq-1)
|
|
WRITE(*,*)
|
|
WRITE(*,9401) (ji, ji = jl,jm)
|
|
WRITE(*,9400) ('***', ji = jl,jm-1)
|
|
DO jj = 1, td_mpp%i_njproc
|
|
WRITE(*,9403) (' ', ji = jl,jm-1)
|
|
WRITE(*,9402) jj, ( il_lci(ji,jj), il_lcj(ji,jj), ji = jl,jm)
|
|
WRITE(*,9404) (il_proc(ji,jj), ji= jl,jm)
|
|
WRITE(*,9403) (' ', ji = jl,jm-1)
|
|
WRITE(*,9400) ('***', ji = jl,jm-1)
|
|
ENDDO
|
|
jl = jl+ip_freq
|
|
ENDDO
|
|
|
|
DEALLOCATE( il_proc )
|
|
DEALLOCATE( il_lci )
|
|
DEALLOCATE( il_lcj )
|
|
ENDIF
|
|
|
|
ENDIF
|
|
ELSE
|
|
WRITE(*,'(/a)') " Domain decomposition : none"
|
|
ENDIF
|
|
|
|
9400 FORMAT(' ***',20('*************',a3))
|
|
9403 FORMAT(' * ',20(' * ',a3))
|
|
9401 FORMAT(' ',20(' ',i3,' '))
|
|
9402 FORMAT(' ',i3,' * ',20(i3,' x',i3,' * '))
|
|
9404 FORMAT(' * ',20(' ',i3,' * '))
|
|
|
|
END SUBROUTINE mpp_print
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
FUNCTION mpp__init_mask(cd_file, id_mask, &
|
|
& id_niproc, id_njproc, id_nproc, &
|
|
& id_preci, id_precj, &
|
|
& cd_type, id_ew, id_perio, id_pivot, &
|
|
& td_dim, ld_usempp) &
|
|
& RESULT(tf_mpp)
|
|
!-------------------------------------------------------------------
|
|
!> @brief
|
|
!> This function initialise mpp structure, given file name,
|
|
!> and optionaly mask and number of processor following I and J
|
|
!> @detail
|
|
!> - If no total number of processor is defined (id_nproc), optimize
|
|
!> the domain decomposition (look for the domain decomposition with
|
|
!> the most land processor to remove)
|
|
!> - length of the overlap region (id_preci, id_precj) could be specify
|
|
!> in I and J direction (default value is 1)
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date November, 2013 - Initial version
|
|
!> @date September, 2015
|
|
!> - allow to define dimension with array of dimension structure
|
|
!> @date January, 2016
|
|
!> - use RESULT to rename output
|
|
!> - mismatch with "halo" indices
|
|
!> @date July, 2020
|
|
!> - call dim_reorder for each proc file
|
|
!>
|
|
!> @param[in] cd_file file name of one file composing mpp domain
|
|
!> @param[in] id_mask domain mask
|
|
!> @param[in] id_niproc number of processors following i
|
|
!> @param[in] id_njproc number of processors following j
|
|
!> @param[in] id_nproc total number of processors
|
|
!> @param[in] id_preci i-direction overlap region
|
|
!> @param[in] id_precj j-direction overlap region
|
|
!> @param[in] cd_type type of the files (cdf, cdf4, dimg)
|
|
!> @param[in] id_ew east-west overlap
|
|
!> @param[in] id_perio NEMO periodicity index
|
|
!> @param[in] id_pivot NEMO pivot point index F(0),T(1)
|
|
!> @param[in] td_dim array of dimension structure
|
|
!> @return mpp structure
|
|
!-------------------------------------------------------------------
|
|
|
|
IMPLICIT NONE
|
|
|
|
! Argument
|
|
CHARACTER(LEN=*), INTENT(IN) :: cd_file
|
|
INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_mask
|
|
INTEGER(i4), INTENT(IN), OPTIONAL :: id_niproc
|
|
INTEGER(i4), INTENT(IN), OPTIONAL :: id_njproc
|
|
INTEGER(i4), INTENT(IN), OPTIONAL :: id_nproc
|
|
INTEGER(i4), INTENT(IN), OPTIONAL :: id_preci
|
|
INTEGER(i4), INTENT(IN), OPTIONAL :: id_precj
|
|
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_type
|
|
INTEGER(i4), INTENT(IN), OPTIONAL :: id_ew
|
|
INTEGER(i4), INTENT(IN), OPTIONAL :: id_perio
|
|
INTEGER(i4), INTENT(IN), OPTIONAL :: id_pivot
|
|
TYPE(TDIM) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: td_dim
|
|
LOGICAL , INTENT(IN), OPTIONAL :: ld_usempp
|
|
|
|
! function
|
|
TYPE(TMPP) :: tf_mpp
|
|
|
|
! local variable
|
|
CHARACTER(LEN=lc) :: cl_type
|
|
|
|
INTEGER(i4) , DIMENSION(2) :: il_shape
|
|
INTEGER(i4) :: il_niproc
|
|
INTEGER(i4) :: il_njproc
|
|
|
|
TYPE(TDIM) :: tl_dim
|
|
|
|
TYPE(TATT) :: tl_att
|
|
|
|
TYPE(TLAY) :: tl_lay
|
|
|
|
! loop indices
|
|
INTEGER(i4) :: ji
|
|
!----------------------------------------------------------------
|
|
|
|
! clean mpp
|
|
CALL mpp_clean(tf_mpp)
|
|
|
|
! check type
|
|
cl_type=''
|
|
IF( PRESENT(cd_type) ) cl_type=TRIM(ADJUSTL(cd_type))
|
|
|
|
IF( TRIM(cl_type) /= '' )THEN
|
|
SELECT CASE(TRIM(cd_type))
|
|
CASE('cdf')
|
|
tf_mpp%c_type='cdf'
|
|
CASE('dimg')
|
|
tf_mpp%c_type='dimg'
|
|
CASE DEFAULT
|
|
CALL logger_warn("MPP INIT: type "//TRIM(cd_type)//&
|
|
& " unknown. type dimg will be used for mpp "//&
|
|
& TRIM(tf_mpp%c_name) )
|
|
tf_mpp%c_type='dimg'
|
|
END SELECT
|
|
ELSE
|
|
tf_mpp%c_type=TRIM(file_get_type(cd_file))
|
|
ENDIF
|
|
|
|
! get mpp name
|
|
tf_mpp%c_name=TRIM(file_rename(cd_file))
|
|
|
|
! get global domain dimension
|
|
il_shape(:)=SHAPE(id_mask)
|
|
|
|
IF( PRESENT(td_dim) )THEN
|
|
DO ji=1,ip_maxdim
|
|
IF( td_dim(ji)%l_use )THEN
|
|
CALL mpp_add_dim(tf_mpp, td_dim(ji))
|
|
ENDIF
|
|
ENDDO
|
|
ELSE
|
|
tl_dim=dim_init('X',il_shape(1))
|
|
CALL mpp_add_dim(tf_mpp, tl_dim)
|
|
|
|
tl_dim=dim_init('Y',il_shape(2))
|
|
CALL mpp_add_dim(tf_mpp, tl_dim)
|
|
|
|
! clean
|
|
CALL dim_clean(tl_dim)
|
|
ENDIF
|
|
|
|
IF( ( PRESENT(id_niproc) .AND. (.NOT. PRESENT(id_njproc))) .OR. &
|
|
((.NOT. PRESENT(id_niproc)) .AND. PRESENT(id_njproc) ) )THEN
|
|
CALL logger_warn( "MPP INIT: number of processors following I and J "//&
|
|
& "should be both specified")
|
|
ELSE
|
|
! get number of processors following I and J
|
|
IF( PRESENT(id_niproc) ) tf_mpp%i_niproc=id_niproc
|
|
IF( PRESENT(id_njproc) ) tf_mpp%i_njproc=id_njproc
|
|
ENDIF
|
|
|
|
! get maximum number of processors to be used
|
|
IF( PRESENT(id_nproc) ) tf_mpp%i_nproc = id_nproc
|
|
|
|
! get overlap region length
|
|
IF( PRESENT(id_preci) ) tf_mpp%i_preci= id_preci
|
|
IF( PRESENT(id_precj) ) tf_mpp%i_precj= id_precj
|
|
|
|
! east-west overlap
|
|
IF( PRESENT(id_ew) ) tf_mpp%i_ew= id_ew
|
|
! NEMO periodicity
|
|
IF( PRESENT(id_perio) ) tf_mpp%i_perio= id_perio
|
|
IF( PRESENT(id_pivot) ) tf_mpp%i_pivot= id_pivot
|
|
!
|
|
IF( PRESENT(ld_usempp) ) tf_mpp%l_usempp = ld_usempp
|
|
|
|
IF( tf_mpp%i_nproc /= 0 .AND. &
|
|
& tf_mpp%i_niproc /= 0 .AND. &
|
|
& tf_mpp%i_njproc /= 0 .AND. &
|
|
& tf_mpp%i_nproc > tf_mpp%i_niproc * tf_mpp%i_njproc )THEN
|
|
|
|
CALL logger_error("MPP INIT: invalid domain decomposition ")
|
|
CALL logger_debug("MPP INIT: "// &
|
|
& TRIM(fct_str(tf_mpp%i_nproc))//" > "//&
|
|
& TRIM(fct_str(tf_mpp%i_niproc))//" x "//&
|
|
& TRIM(fct_str(tf_mpp%i_njproc)) )
|
|
|
|
ELSE
|
|
IF( lm_layout )THEN
|
|
OPEN(im_iumout,FILE='processor.layout')
|
|
WRITE(im_iumout,*)
|
|
WRITE(im_iumout,*) ' optimisation de la partition'
|
|
WRITE(im_iumout,*) ' ----------------------------'
|
|
WRITE(im_iumout,*)
|
|
ENDIF
|
|
|
|
IF( tf_mpp%i_niproc /= 0 .AND. tf_mpp%i_njproc /= 0 .AND. &
|
|
&(tf_mpp%i_niproc > 1 .OR. tf_mpp%i_njproc > 1) )THEN
|
|
|
|
! compute domain layout
|
|
tl_lay=layout__init(tf_mpp, id_mask, &
|
|
& tf_mpp%i_niproc, tf_mpp%i_njproc)
|
|
! create mpp domain layout
|
|
CALL mpp__create_layout( tf_mpp, tl_lay )
|
|
|
|
! clean
|
|
CALL layout__clean( tl_lay )
|
|
|
|
ELSEIF( tf_mpp%i_nproc > 1 )THEN
|
|
|
|
! optimiz
|
|
CALL mpp__optimiz( tf_mpp, id_mask, tf_mpp%i_nproc )
|
|
|
|
ELSE
|
|
|
|
CALL logger_warn("MPP INIT: number of processor to be used "//&
|
|
& "not specify. force output on one file.")
|
|
! number of proc to get proc size close to im_psize
|
|
il_niproc=INT(il_shape(jp_I)/im_psize)+1
|
|
il_njproc=INT(il_shape(jp_J)/im_psize)+1
|
|
|
|
tf_mpp%l_usempp=.FALSE.
|
|
tl_lay=layout__init( tf_mpp, id_mask, &
|
|
& il_niproc, il_njproc )
|
|
|
|
! create mpp domain layout
|
|
CALL mpp__create_layout( tf_mpp, tl_lay )
|
|
|
|
! clean
|
|
CALL layout__clean( tl_lay )
|
|
|
|
ENDIF
|
|
|
|
CALL logger_info("MPP INIT: domain decoposition : "//&
|
|
& 'niproc('//TRIM(fct_str(tf_mpp%i_niproc))//') * '//&
|
|
& 'njproc('//TRIM(fct_str(tf_mpp%i_njproc))//') = '//&
|
|
& 'nproc('//TRIM(fct_str(tf_mpp%i_nproc))//')' )
|
|
|
|
! get domain type
|
|
CALL mpp_get_dom( tf_mpp )
|
|
|
|
DO ji=1,tf_mpp%i_nproc
|
|
|
|
! get processor size
|
|
il_shape(:)=mpp_get_proc_size( tf_mpp, ji )
|
|
|
|
tl_dim=dim_init('X',il_shape(1))
|
|
CALL file_move_dim(tf_mpp%t_proc(ji), tl_dim)
|
|
|
|
tl_dim=dim_init('Y',il_shape(2))
|
|
CALL file_move_dim(tf_mpp%t_proc(ji), tl_dim)
|
|
|
|
IF( PRESENT(td_dim) )THEN
|
|
IF( td_dim(jp_K)%l_use )THEN
|
|
CALL file_move_dim(tf_mpp%t_proc(ji), td_dim(jp_K))
|
|
ENDIF
|
|
IF( td_dim(jp_L)%l_use )THEN
|
|
CALL file_move_dim(tf_mpp%t_proc(ji), td_dim(jp_L))
|
|
ENDIF
|
|
ENDIF
|
|
! add type
|
|
tf_mpp%t_proc(ji)%c_type=TRIM(tf_mpp%c_type)
|
|
|
|
! reorder dimension
|
|
CALL dim_reorder(tf_mpp%t_proc(ji)%t_dim(:))
|
|
|
|
! clean
|
|
CALL dim_clean(tl_dim)
|
|
|
|
ENDDO
|
|
|
|
! add global attribute
|
|
tl_att=att_init("DOMAIN_number_total",tf_mpp%i_nproc)
|
|
CALL mpp_add_att(tf_mpp, tl_att)
|
|
|
|
tl_att=att_init("DOMAIN_LOCAL",TRIM(tf_mpp%c_dom))
|
|
CALL mpp_add_att(tf_mpp, tl_att)
|
|
|
|
tl_att=att_init("DOMAIN_I_number_total",tf_mpp%i_niproc)
|
|
CALL mpp_add_att(tf_mpp, tl_att)
|
|
|
|
tl_att=att_init("DOMAIN_J_number_total",tf_mpp%i_njproc)
|
|
CALL mpp_add_att(tf_mpp, tl_att)
|
|
|
|
tl_att=att_init("DOMAIN_size_global",tf_mpp%t_dim(1:2)%i_len)
|
|
CALL mpp_add_att(tf_mpp, tl_att)
|
|
|
|
CALL mpp__compute_halo(tf_mpp)
|
|
ENDIF
|
|
|
|
END FUNCTION mpp__init_mask
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
FUNCTION mpp__init_var(cd_file, td_var, &
|
|
& id_niproc, id_njproc, id_nproc,&
|
|
& id_preci, id_precj, cd_type, &
|
|
& id_perio, id_pivot, ld_usempp) &
|
|
& RESULT(tf_mpp)
|
|
!-------------------------------------------------------------------
|
|
!> @brief
|
|
!> This function initialise mpp structure, given variable strcuture
|
|
!> and optionaly number of processor following I and J
|
|
!> @detail
|
|
!> - If no total number of processor is defined (id_nproc), optimize
|
|
!> the domain decomposition (look for the domain decomposition with
|
|
!> the most land processor to remove)
|
|
!> - length of the overlap region (id_preci, id_precj) could be specify
|
|
!> in I and J direction (default value is 1)
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date November, 2013 - Initial version
|
|
!> @date July, 2020
|
|
!> - add variable dimension argument to set up mpp structure
|
|
!>
|
|
!> @param[in] cd_file file name of one file composing mpp domain
|
|
!> @param[in] td_var variable structure
|
|
!> @param[in] id_niproc number of processors following i
|
|
!> @param[in] id_njproc number of processors following j
|
|
!> @param[in] id_nproc total number of processors
|
|
!> @param[in] id_preci i-direction overlap region
|
|
!> @param[in] id_precj j-direction overlap region
|
|
!> @param[in] cd_type type of the files (cdf, cdf4, dimg)
|
|
!> @param[in] id_perio NEMO periodicity index
|
|
!> @param[in] id_pivot NEMO pivot point index F(0),T(1)
|
|
!> @return mpp structure
|
|
!-------------------------------------------------------------------
|
|
|
|
IMPLICIT NONE
|
|
|
|
! Argument
|
|
CHARACTER(LEN=*), INTENT(IN) :: cd_file
|
|
TYPE(TVAR), INTENT(IN) :: td_var
|
|
INTEGER(i4), INTENT(IN), OPTIONAL :: id_niproc
|
|
INTEGER(i4), INTENT(IN), OPTIONAL :: id_njproc
|
|
INTEGER(i4), INTENT(IN), OPTIONAL :: id_nproc
|
|
INTEGER(i4), INTENT(IN), OPTIONAL :: id_preci
|
|
INTEGER(i4), INTENT(IN), OPTIONAL :: id_precj
|
|
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_type
|
|
INTEGER(i4), INTENT(IN), OPTIONAL :: id_perio
|
|
INTEGER(i4), INTENT(IN), OPTIONAL :: id_pivot
|
|
LOGICAL, INTENT(IN), OPTIONAL :: ld_usempp
|
|
|
|
! function
|
|
TYPE(TMPP) :: tf_mpp
|
|
|
|
! local variable
|
|
INTEGER(i4), DIMENSION(:,:,:), ALLOCATABLE :: il_mask
|
|
!----------------------------------------------------------------
|
|
|
|
IF( ASSOCIATED(td_var%d_value) )THEN
|
|
ALLOCATE( il_mask(td_var%t_dim(1)%i_len, &
|
|
& td_var%t_dim(2)%i_len, &
|
|
& td_var%t_dim(3)%i_len) )
|
|
il_mask(:,:,:)=var_get_mask(td_var)
|
|
|
|
CALL logger_info("MPP INIT: mask compute from variable "//&
|
|
& TRIM(td_var%c_name))
|
|
tf_mpp = mpp_init( cd_file, il_mask(:,:,1), &
|
|
& id_niproc, id_njproc, id_nproc,&
|
|
& id_preci, id_precj, cd_type, &
|
|
& id_ew=td_var%i_ew, &
|
|
& id_perio=id_perio, id_pivot=id_pivot,&
|
|
& td_dim=td_var%t_dim(:), &
|
|
& ld_usempp=ld_usempp)
|
|
|
|
DEALLOCATE(il_mask)
|
|
ELSE
|
|
CALL logger_error("MPP INIT: variable value not define.")
|
|
ENDIF
|
|
|
|
END FUNCTION mpp__init_var
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
FUNCTION mpp__init_file(td_file, id_ew, id_perio, id_pivot) &
|
|
& RESULT(tf_mpp)
|
|
!-------------------------------------------------------------------
|
|
!> @brief This function initalise a mpp structure given file structure.
|
|
!> @details
|
|
!> It reads restart dimg files, or some netcdf files.
|
|
!>
|
|
!> @warning
|
|
!> netcdf file must contains some attributes:
|
|
!> - DOMAIN_number_total
|
|
!> - DOMAIN_size_global
|
|
!> - DOMAIN_number
|
|
!> - DOMAIN_position_first
|
|
!> - DOMAIN_position_last
|
|
!> - DOMAIN_halo_size_start
|
|
!> - DOMAIN_halo_size_end
|
|
!> or the file is assume to be no mpp file.
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date November, 2013 - Initial Version
|
|
!> @date January, 2016
|
|
!> - mismatch with "halo" indices, use mpp__compute_halo
|
|
!> @date Marsh, 2017
|
|
!> - netcdf proc indices from zero to N-1
|
|
!> - copy file periodicity to mpp structure
|
|
!> @date August, 2017
|
|
!> - force to use domain decomposition to enhance read of monoproc file
|
|
!>
|
|
!> @param[in] td_file file strcuture
|
|
!> @param[in] id_ew east-west overlap
|
|
!> @param[in] id_perio NEMO periodicity index
|
|
!> @param[in] id_pivot NEMO pivot point index F(0),T(1)
|
|
!> @return mpp structure
|
|
!-------------------------------------------------------------------
|
|
|
|
IMPLICIT NONE
|
|
|
|
! Argument
|
|
TYPE(TFILE), INTENT(IN) :: td_file
|
|
INTEGER(i4), INTENT(IN), OPTIONAL :: id_ew
|
|
INTEGER(i4), INTENT(IN), OPTIONAL :: id_perio
|
|
INTEGER(i4), INTENT(IN), OPTIONAL :: id_pivot
|
|
|
|
! function
|
|
TYPE(TMPP) :: tf_mpp
|
|
|
|
! local variable
|
|
INTEGER(i4) :: il_nproc
|
|
INTEGER(i4) :: il_attid
|
|
INTEGER(i4), DIMENSION(2) :: il_shape
|
|
|
|
INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_mask
|
|
INTEGER(i4), DIMENSION(ip_maxdim) :: il_dim
|
|
INTEGER(i4) :: il_niproc
|
|
INTEGER(i4) :: il_njproc
|
|
|
|
TYPE(TDIM) :: tl_dim
|
|
|
|
TYPE(TATT) :: tl_att
|
|
|
|
TYPE(TFILE) :: tl_file
|
|
|
|
TYPE(TMPP) :: tl_mpp
|
|
|
|
! loop indices
|
|
INTEGER(i4) :: ji
|
|
!----------------------------------------------------------------
|
|
|
|
! clean mpp
|
|
CALL mpp_clean(tf_mpp)
|
|
|
|
! check file type
|
|
SELECT CASE( TRIM(td_file%c_type) )
|
|
CASE('cdf')
|
|
! need to read all file to get domain decomposition
|
|
tl_file=file_copy(td_file)
|
|
|
|
! open file
|
|
CALL iom_open(tl_file)
|
|
|
|
! read first file domain decomposition
|
|
tl_mpp=mpp__init_file_cdf(tl_file)
|
|
|
|
! get number of processor/file to be read
|
|
il_nproc = 1
|
|
il_attid = 0
|
|
|
|
IF( ASSOCIATED(tl_file%t_att) )THEN
|
|
il_attid=att_get_id( tl_file%t_att, "DOMAIN_number_total" )
|
|
ENDIF
|
|
IF( il_attid /= 0 )THEN
|
|
il_nproc = INT(tl_file%t_att(il_attid)%d_value(1))
|
|
ENDIF
|
|
|
|
! close file
|
|
CALL iom_close(tl_file)
|
|
|
|
IF( il_nproc /= 1 )THEN
|
|
|
|
DO ji=1,il_nproc
|
|
|
|
! clean mpp strcuture
|
|
CALL mpp_clean(tl_mpp)
|
|
|
|
! get filename (from 0 to n-1)
|
|
tl_file=file_rename(td_file,ji-1)
|
|
|
|
! open file
|
|
CALL iom_open(tl_file)
|
|
|
|
! read domain decomposition
|
|
tl_mpp = mpp__init_file_cdf(tl_file)
|
|
IF( ji == 1 )THEN
|
|
tf_mpp=mpp_copy(tl_mpp)
|
|
ELSE
|
|
IF( ANY( tf_mpp%t_dim(1:2)%i_len /= &
|
|
tl_mpp%t_dim(1:2)%i_len) )THEN
|
|
|
|
CALL logger_error("MPP INIT READ: dimension from file "//&
|
|
& TRIM(tl_file%c_name)//" and mpp strcuture "//&
|
|
& TRIM(tf_mpp%c_name)//"differ ")
|
|
|
|
ELSE
|
|
|
|
! add processor to mpp strcuture
|
|
CALL mpp__add_proc(tf_mpp, tl_mpp%t_proc(1))
|
|
|
|
ENDIF
|
|
ENDIF
|
|
|
|
! close file
|
|
CALL iom_close(tl_file)
|
|
|
|
ENDDO
|
|
IF( tf_mpp%i_nproc /= il_nproc )THEN
|
|
CALL logger_error("MPP INIT READ: some processors can't be added &
|
|
& to mpp structure")
|
|
ENDIF
|
|
|
|
ELSE
|
|
|
|
! force to use domain decomposition to enhance read of input
|
|
|
|
! create pseudo mask
|
|
il_dim(:)=tl_mpp%t_dim(:)%i_len
|
|
ALLOCATE(il_mask(il_dim(jp_I),il_dim(jp_J)))
|
|
il_mask(:,:)=1
|
|
|
|
! number of proc to get proc size close to im_psize
|
|
il_niproc=INT(il_dim(jp_I)/im_psize)+1
|
|
il_njproc=INT(il_dim(jp_J)/im_psize)+1
|
|
|
|
! compute domain layout
|
|
! output will be written on one file
|
|
tf_mpp=mpp_init(tl_mpp%c_name, il_mask, il_niproc, il_njproc,&
|
|
& id_perio=tl_file%i_perio, &
|
|
& ld_usempp=.FALSE. )
|
|
|
|
! add var
|
|
DO ji=1,tl_mpp%t_proc(1)%i_nvar
|
|
CALL mpp_add_var(tf_mpp, tl_mpp%t_proc(1)%t_var(ji))
|
|
ENDDO
|
|
|
|
ENDIF
|
|
|
|
! mpp type
|
|
tf_mpp%c_type=TRIM(td_file%c_type)
|
|
|
|
! mpp domain type
|
|
CALL mpp_get_dom(tf_mpp)
|
|
|
|
! create some attributes for domain decomposition (use with dimg file)
|
|
tl_att=att_init( "DOMAIN_number_total", tf_mpp%i_nproc )
|
|
CALL mpp_move_att(tf_mpp, tl_att)
|
|
|
|
CALL mpp__compute_halo(tf_mpp)
|
|
|
|
! clean
|
|
CALL mpp_clean(tl_mpp)
|
|
CALL att_clean(tl_att)
|
|
|
|
CASE('dimg')
|
|
! domain decomposition could be read in one file
|
|
|
|
tl_file=file_copy(td_file)
|
|
! open file
|
|
CALL logger_debug("MPP INIT READ: open file "//TRIM(tl_file%c_name))
|
|
CALL iom_open(tl_file)
|
|
|
|
CALL logger_debug("MPP INIT READ: read mpp structure ")
|
|
! read mpp structure
|
|
tf_mpp=mpp__init_file_rstdimg(tl_file)
|
|
|
|
! mpp type
|
|
tf_mpp%c_type=TRIM(td_file%c_type)
|
|
|
|
! mpp domain type
|
|
CALL logger_debug("MPP INIT READ: mpp_get_dom ")
|
|
CALL mpp_get_dom(tf_mpp)
|
|
|
|
! get processor size
|
|
CALL logger_debug("MPP INIT READ: get processor size ")
|
|
DO ji=1,tf_mpp%i_nproc
|
|
|
|
il_shape(:)=mpp_get_proc_size( tf_mpp, ji )
|
|
|
|
tl_dim=dim_init('X',il_shape(1))
|
|
CALL file_add_dim(tf_mpp%t_proc(ji), tl_dim)
|
|
|
|
tl_dim=dim_init('Y',il_shape(2))
|
|
CALL file_add_dim(tf_mpp%t_proc(ji), tl_dim)
|
|
|
|
! clean
|
|
CALL dim_clean(tl_dim)
|
|
|
|
ENDDO
|
|
|
|
! close file
|
|
CALL iom_close(tl_file)
|
|
|
|
CASE DEFAULT
|
|
CALL logger_error("MPP INIT READ: invalid type for file "//&
|
|
& TRIM(tl_file%c_name))
|
|
END SELECT
|
|
|
|
! east west overlap
|
|
IF( PRESENT(id_ew) ) tf_mpp%i_ew=id_ew
|
|
! NEMO periodicity
|
|
IF( PRESENT(id_perio) )THEN
|
|
tf_mpp%i_perio= id_perio
|
|
SELECT CASE(id_perio)
|
|
CASE(3,4)
|
|
tf_mpp%i_pivot=1
|
|
CASE(5,6)
|
|
tf_mpp%i_pivot=0
|
|
CASE DEFAULT
|
|
tf_mpp%i_pivot=1
|
|
END SELECT
|
|
ENDIF
|
|
|
|
IF( PRESENT(id_pivot) ) tf_mpp%i_pivot= id_pivot
|
|
|
|
! clean
|
|
CALL file_clean(tl_file)
|
|
|
|
END FUNCTION mpp__init_file
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
FUNCTION mpp__init_file_cdf(td_file) &
|
|
& RESULT(tf_mpp)
|
|
!-------------------------------------------------------------------
|
|
!> @brief This function initalise a mpp structure,
|
|
!> reading some netcdf files.
|
|
!>
|
|
!> @details
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date November, 2013 - Initial Version
|
|
!> @date July, 2015
|
|
!> - add only use dimension in MPP structure
|
|
!> @date January, 2016
|
|
!> - mismatch with "halo" indices, use mpp__read_halo
|
|
!>
|
|
!> @param[in] td_file file strcuture
|
|
!> @return mpp structure
|
|
!-------------------------------------------------------------------
|
|
|
|
IMPLICIT NONE
|
|
|
|
! Argument
|
|
TYPE(TFILE), INTENT(IN) :: td_file
|
|
|
|
! function
|
|
TYPE(TMPP) :: tf_mpp
|
|
|
|
! local variable
|
|
INTEGER(i4) :: il_attid ! attribute id
|
|
|
|
LOGICAL :: ll_exist
|
|
LOGICAL :: ll_open
|
|
|
|
TYPE(TATT) :: tl_att
|
|
|
|
TYPE(TDIM) :: tl_dim
|
|
|
|
TYPE(TFILE) :: tl_proc
|
|
!----------------------------------------------------------------
|
|
|
|
CALL logger_trace("MPP INIT READ: netcdf file "//TRIM(td_file%c_name))
|
|
|
|
INQUIRE( FILE=TRIM(td_file%c_name), EXIST=ll_exist, OPENED=ll_open )
|
|
! ll_open do not work for netcdf file, return always FALSE
|
|
IF( ll_exist )THEN
|
|
|
|
IF( td_file%i_id == 0 )THEN
|
|
CALL logger_info(" id "//TRIM(fct_str(td_file%i_id)))
|
|
CALL logger_error("MPP INIT READ: netcdf file "//&
|
|
& TRIM(td_file%c_name)//" not opened")
|
|
ELSE
|
|
|
|
! get mpp name
|
|
tf_mpp%c_name=TRIM( file_rename(td_file%c_name) )
|
|
|
|
! add type
|
|
tf_mpp%c_type="cdf"
|
|
|
|
! global domain size
|
|
il_attid = 0
|
|
IF( ASSOCIATED(td_file%t_att) )THEN
|
|
il_attid=att_get_id( td_file%t_att, "DOMAIN_size_global" )
|
|
ENDIF
|
|
IF( il_attid /= 0 )THEN
|
|
tl_dim=dim_init('X',INT(td_file%t_att(il_attid)%d_value(1)))
|
|
CALL mpp_add_dim(tf_mpp,tl_dim)
|
|
|
|
tl_dim=dim_init('Y',INT(td_file%t_att(il_attid)%d_value(2)))
|
|
CALL mpp_add_dim(tf_mpp,tl_dim)
|
|
ELSE ! assume only one file (not mpp)
|
|
tl_dim=dim_init( td_file%t_dim(1)%c_name, td_file%t_dim(1)%i_len)
|
|
CALL mpp_add_dim(tf_mpp,tl_dim)
|
|
|
|
tl_dim=dim_init( td_file%t_dim(2)%c_name, td_file%t_dim(2)%i_len)
|
|
CALL mpp_add_dim(tf_mpp,tl_dim)
|
|
ENDIF
|
|
|
|
IF( td_file%t_dim(3)%l_use )THEN
|
|
tl_dim=dim_init( td_file%t_dim(3)%c_name, td_file%t_dim(3)%i_len)
|
|
CALL mpp_add_dim(tf_mpp,tl_dim)
|
|
ENDIF
|
|
|
|
IF( td_file%t_dim(4)%l_use )THEN
|
|
tl_dim=dim_init( td_file%t_dim(4)%c_name, td_file%t_dim(4)%i_len)
|
|
CALL mpp_add_dim(tf_mpp,tl_dim)
|
|
ENDIF
|
|
|
|
! initialise file/processor
|
|
tl_proc=file_copy(td_file)
|
|
|
|
! processor id
|
|
il_attid = 0
|
|
IF( ASSOCIATED(td_file%t_att) )THEN
|
|
il_attid=att_get_id( td_file%t_att, "DOMAIN_number" )
|
|
ENDIF
|
|
IF( il_attid /= 0 )THEN
|
|
tl_proc%i_pid = INT(td_file%t_att(il_attid)%d_value(1))
|
|
ELSE
|
|
tl_proc%i_pid = 1
|
|
ENDIF
|
|
|
|
! processor dimension
|
|
tl_proc%t_dim(:)=dim_copy(td_file%t_dim(:))
|
|
|
|
CALL mpp__read_halo(tl_proc, tf_mpp%t_dim(:) )
|
|
|
|
! add attributes
|
|
tl_att=att_init( "DOMAIN_size_global", tf_mpp%t_dim(:)%i_len)
|
|
CALL file_move_att(tl_proc, tl_att)
|
|
|
|
tl_att=att_init( "DOMAIN_number", tl_proc%i_pid )
|
|
CALL file_move_att(tl_proc, tl_att)
|
|
|
|
! add processor to mpp structure
|
|
CALL mpp__add_proc(tf_mpp, tl_proc)
|
|
|
|
! clean
|
|
CALL file_clean(tl_proc)
|
|
CALL dim_clean(tl_dim)
|
|
CALL att_clean(tl_att)
|
|
ENDIF
|
|
|
|
ELSE
|
|
|
|
CALL logger_error("MPP INIT READ: netcdf file "//TRIM(td_file%c_name)//&
|
|
& " do not exist")
|
|
|
|
ENDIF
|
|
|
|
END FUNCTION mpp__init_file_cdf
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
FUNCTION mpp__init_file_rstdimg(td_file) &
|
|
& RESULT(tf_mpp)
|
|
!-------------------------------------------------------------------
|
|
!> @brief This function initalise a mpp structure,
|
|
!> reading one dimg restart file.
|
|
!>
|
|
!> @details
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date November, 2013 - Initial Version
|
|
!> @date January, 2016
|
|
!> - mismatch with "halo" indices, use mpp__compute_halo
|
|
!> @date January,2019
|
|
!> - clean file structure
|
|
!>
|
|
!> @param[in] td_file file strcuture
|
|
!> @return mpp structure
|
|
!-------------------------------------------------------------------
|
|
|
|
IMPLICIT NONE
|
|
|
|
! Argument
|
|
TYPE(TFILE), INTENT(IN) :: td_file
|
|
|
|
! function
|
|
TYPE(TMPP) :: tf_mpp
|
|
|
|
! local variable
|
|
INTEGER(i4) :: il_status
|
|
INTEGER(i4) :: il_recl ! record length
|
|
INTEGER(i4) :: il_nx, il_ny, il_nz ! x,y,z dimension
|
|
INTEGER(i4) :: il_n0d, il_n1d, il_n2d, il_n3d ! number of 0/1/2/3D variables
|
|
INTEGER(i4) :: il_iglo, il_jglo ! domain global size
|
|
INTEGER(i4) :: il_rhd ! record of the header infos
|
|
INTEGER(i4) :: il_pni, il_pnj, il_pnij ! domain decomposition
|
|
INTEGER(i4) :: il_area ! domain index
|
|
|
|
INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_lci
|
|
INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ldi
|
|
INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_lei
|
|
INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_impp
|
|
INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_lcj
|
|
INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ldj
|
|
INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_lej
|
|
INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_jmpp
|
|
|
|
LOGICAL :: ll_exist
|
|
LOGICAL :: ll_open
|
|
|
|
CHARACTER(LEN=lc) :: cl_file
|
|
|
|
TYPE(TDIM) :: tl_dim ! dimension structure
|
|
TYPE(TATT) :: tl_att
|
|
TYPE(TFILE) :: tl_proc
|
|
|
|
! loop indices
|
|
INTEGER(i4) :: ji
|
|
!----------------------------------------------------------------
|
|
|
|
INQUIRE( FILE=TRIM(td_file%c_name), EXIST=ll_exist, OPENED=ll_open)
|
|
IF( ll_exist )THEN
|
|
|
|
IF( .NOT. ll_open )THEN
|
|
CALL logger_error("MPP INIT READ: dimg file "//TRIM(td_file%c_name)//&
|
|
& " not opened")
|
|
ELSE
|
|
|
|
! read first record
|
|
READ( td_file%i_id, IOSTAT=il_status, REC=1 )&
|
|
& il_recl, &
|
|
& il_nx, il_ny, il_nz, &
|
|
& il_n0d, il_n1d, il_n2d, il_n3d, &
|
|
& il_rhd, &
|
|
& il_pni, il_pnj, il_pnij, &
|
|
& il_area
|
|
CALL fct_err(il_status)
|
|
IF( il_status /= 0 )THEN
|
|
CALL logger_error("MPP INIT READ: read first line header of "//&
|
|
& TRIM(td_file%c_name))
|
|
ENDIF
|
|
|
|
! get mpp name
|
|
tf_mpp%c_name=TRIM( file_rename(td_file%c_name) )
|
|
|
|
! add type
|
|
tf_mpp%c_type="dimg"
|
|
|
|
! number of processors to be read
|
|
tf_mpp%i_nproc = il_pnij
|
|
tf_mpp%i_niproc = il_pni
|
|
tf_mpp%i_njproc = il_pnj
|
|
|
|
IF( ASSOCIATED(tf_mpp%t_proc) )THEN
|
|
CALL file_clean(tf_mpp%t_proc(:))
|
|
DEALLOCATE(tf_mpp%t_proc)
|
|
ENDIF
|
|
ALLOCATE( tf_mpp%t_proc(il_pnij) , stat=il_status )
|
|
|
|
ALLOCATE(il_lci (il_pnij))
|
|
ALLOCATE(il_lcj (il_pnij))
|
|
ALLOCATE(il_ldi (il_pnij))
|
|
ALLOCATE(il_ldj (il_pnij))
|
|
ALLOCATE(il_lei (il_pnij))
|
|
ALLOCATE(il_lej (il_pnij))
|
|
ALLOCATE(il_impp(il_pnij))
|
|
ALLOCATE(il_jmpp(il_pnij))
|
|
|
|
tl_proc=file_copy(td_file)
|
|
! remove dimension from file
|
|
CALL dim_clean(tl_proc%t_dim(:))
|
|
! initialise file/processors
|
|
DO ji=1,tf_mpp%i_nproc
|
|
tf_mpp%t_proc(ji)=file_copy(tl_proc)
|
|
ENDDO
|
|
|
|
IF( il_status /= 0 )THEN
|
|
CALL logger_error("MPP INIT READ: not enough space to read domain &
|
|
& decomposition in file "//TRIM(td_file%c_name))
|
|
ENDIF
|
|
|
|
! read first record
|
|
READ( td_file%i_id, IOSTAT=il_status, REC=1 )&
|
|
& il_recl, &
|
|
& il_nx, il_ny, il_nz, &
|
|
& il_n0d, il_n1d, il_n2d, il_n3d, &
|
|
& il_rhd, &
|
|
& il_pni, il_pnj, il_pnij, &
|
|
& il_area, &
|
|
& il_iglo, il_jglo, &
|
|
& il_lci(1:il_pnij), &
|
|
& il_lcj(1:il_pnij), &
|
|
& il_ldi(1:il_pnij), &
|
|
& il_ldj(1:il_pnij), &
|
|
& il_lei(1:il_pnij), &
|
|
& il_lej(1:il_pnij), &
|
|
& il_impp(1:il_pnij), &
|
|
& il_jmpp(1:il_pnij)
|
|
CALL fct_err(il_status)
|
|
IF( il_status /= 0 )THEN
|
|
CALL logger_error("MPP INIT READ: read first line of "//&
|
|
& TRIM(td_file%c_name))
|
|
ENDIF
|
|
|
|
tf_mpp%t_proc(1:il_pnij)%i_lci = il_lci (1:il_pnij)
|
|
tf_mpp%t_proc(1:il_pnij)%i_lcj = il_lcj (1:il_pnij)
|
|
tf_mpp%t_proc(1:il_pnij)%i_ldi = il_ldi (1:il_pnij)
|
|
tf_mpp%t_proc(1:il_pnij)%i_ldj = il_ldj (1:il_pnij)
|
|
tf_mpp%t_proc(1:il_pnij)%i_lei = il_lei (1:il_pnij)
|
|
tf_mpp%t_proc(1:il_pnij)%i_lej = il_lej (1:il_pnij)
|
|
tf_mpp%t_proc(1:il_pnij)%i_impp= il_impp(1:il_pnij)
|
|
tf_mpp%t_proc(1:il_pnij)%i_jmpp= il_jmpp(1:il_pnij)
|
|
|
|
DEALLOCATE(il_lci)
|
|
DEALLOCATE(il_lcj)
|
|
DEALLOCATE(il_ldi)
|
|
DEALLOCATE(il_ldj)
|
|
DEALLOCATE(il_lei)
|
|
DEALLOCATE(il_lej)
|
|
DEALLOCATE(il_impp)
|
|
DEALLOCATE(il_jmpp)
|
|
|
|
! global domain size
|
|
tl_dim=dim_init('X',il_iglo)
|
|
CALL mpp_add_dim(tf_mpp,tl_dim)
|
|
tl_dim=dim_init('Y',il_jglo)
|
|
CALL mpp_add_dim(tf_mpp,tl_dim)
|
|
|
|
tl_dim=dim_init('Z',il_nz)
|
|
CALL mpp_add_dim(tf_mpp,tl_dim)
|
|
|
|
DO ji=1,tf_mpp%i_nproc
|
|
|
|
! get file name
|
|
cl_file = file_rename(td_file%c_name,ji)
|
|
tf_mpp%t_proc(ji)%c_name = TRIM(cl_file)
|
|
! update processor id
|
|
tf_mpp%t_proc(ji)%i_pid=ji
|
|
|
|
! add attributes
|
|
tl_att=att_init( "DOMAIN_number", ji )
|
|
CALL file_move_att(tf_mpp%t_proc(ji), tl_att)
|
|
|
|
ENDDO
|
|
|
|
! add type
|
|
tf_mpp%t_proc(:)%c_type="dimg"
|
|
|
|
! add attributes
|
|
tl_att=att_init("DOMAIN_size_global", tf_mpp%t_dim(:)%i_len)
|
|
CALL mpp_move_att(tf_mpp, tl_att)
|
|
|
|
tl_att=att_init("DOMAIN_number_total", tf_mpp%i_nproc)
|
|
CALL mpp_move_att(tf_mpp, tl_att)
|
|
|
|
tl_att=att_init("DOMAIN_I_number_total", tf_mpp%i_niproc)
|
|
CALL mpp_move_att(tf_mpp, tl_att)
|
|
|
|
tl_att=att_init("DOMAIN_J_number_total", tf_mpp%i_njproc)
|
|
CALL mpp_move_att(tf_mpp, tl_att)
|
|
|
|
CALL mpp_get_dom( tf_mpp )
|
|
|
|
CALL mpp__compute_halo( tf_mpp )
|
|
|
|
! clean
|
|
CALL dim_clean(tl_dim)
|
|
CALL att_clean(tl_att)
|
|
CALL file_clean(tl_proc)
|
|
ENDIF
|
|
|
|
ELSE
|
|
|
|
CALL logger_error("MPP INIT READ: dimg file "//TRIM(td_file%c_name)//&
|
|
& " do not exist")
|
|
|
|
ENDIF
|
|
|
|
END FUNCTION mpp__init_file_rstdimg
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
FUNCTION mpp__check_proc_dim(td_mpp, td_proc) &
|
|
& RESULT(lf_check)
|
|
!-------------------------------------------------------------------
|
|
!> @brief This function check if variable and mpp structure use same
|
|
!> dimension.
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date November, 2013 - Initial Version
|
|
!>
|
|
!> @param[in] td_mpp mpp structure
|
|
!> @param[in] td_proc processor structure
|
|
!> @return dimension of processor and mpp structure agree (or not)
|
|
!-------------------------------------------------------------------
|
|
|
|
IMPLICIT NONE
|
|
|
|
! Argument
|
|
TYPE(TMPP), INTENT(IN) :: td_mpp
|
|
TYPE(TFILE), INTENT(IN) :: td_proc
|
|
|
|
!function
|
|
LOGICAL :: lf_check
|
|
|
|
! local variable
|
|
INTEGER(i4) :: il_isize !< i-direction maximum sub domain size
|
|
INTEGER(i4) :: il_jsize !< j-direction maximum sub domain size
|
|
!----------------------------------------------------------------
|
|
|
|
lf_check=.TRUE.
|
|
! check used dimension
|
|
IF( td_mpp%i_niproc /= 0 .AND. td_mpp%i_njproc /= 0 )THEN
|
|
! check with maximum size of sub domain
|
|
il_isize = ( td_mpp%t_dim(1)%i_len - 2*td_mpp%i_preci + &
|
|
& (td_mpp%i_niproc-1) ) / td_mpp%i_niproc + 2*td_mpp%i_preci
|
|
il_jsize = ( td_mpp%t_dim(2)%i_len - 2*td_mpp%i_precj + &
|
|
& (td_mpp%i_njproc-1) ) / td_mpp%i_njproc + 2*td_mpp%i_precj
|
|
|
|
IF( il_isize < td_proc%i_lci .OR. &
|
|
&il_jsize < td_proc%i_lcj )THEN
|
|
|
|
lf_check=.FALSE.
|
|
|
|
CALL logger_error( "MPP CHECK DIM: processor and mpp dimension differ" )
|
|
|
|
ENDIF
|
|
|
|
ELSE
|
|
! check with global domain size
|
|
IF( td_mpp%t_dim(1)%i_len < td_proc%i_lci .OR. &
|
|
&td_mpp%t_dim(2)%i_len < td_proc%i_lcj )THEN
|
|
|
|
lf_check=.FALSE.
|
|
|
|
CALL logger_error( "MPP CHECK DIM: processor and mpp dimension differ" )
|
|
|
|
ENDIF
|
|
ENDIF
|
|
|
|
END FUNCTION mpp__check_proc_dim
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
SUBROUTINE mpp_add_var(td_mpp, td_var)
|
|
!-------------------------------------------------------------------
|
|
!> @brief
|
|
!> This subroutine add variable in all files of mpp structure.
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date November, 2013 - Initial version
|
|
!> @date January, 2019
|
|
!> - do not split variable on domain decomposition, if only one procesor
|
|
!>
|
|
!> @param[inout] td_mpp mpp strcuture
|
|
!> @param[in] td_var variable strcuture
|
|
!-------------------------------------------------------------------
|
|
|
|
IMPLICIT NONE
|
|
|
|
! Argument
|
|
TYPE(TMPP), INTENT(INOUT) :: td_mpp
|
|
TYPE(TVAR), INTENT(INOUT) :: td_var
|
|
|
|
! local variable
|
|
INTEGER(i4) :: il_varid
|
|
TYPE(TVAR) :: tl_var
|
|
|
|
! loop indices
|
|
INTEGER(i4) :: ji
|
|
!----------------------------------------------------------------
|
|
|
|
! check if mpp exist
|
|
IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
|
|
|
|
CALL logger_error( "MPP ADD VAR: processor decomposition not "//&
|
|
& "define for mpp "//TRIM(td_mpp%c_name))
|
|
|
|
ELSE
|
|
! check if variable exist
|
|
IF( TRIM(td_var%c_name) == '' .AND. &
|
|
& TRIM(td_var%c_stdname) == '' )THEN
|
|
CALL logger_error("MPP ADD VAR: variable not define ")
|
|
ELSE
|
|
! check if variable already in mpp structure
|
|
il_varid=0
|
|
IF( ASSOCIATED(td_mpp%t_proc(1)%t_var) )THEN
|
|
il_varid=var_get_index( td_mpp%t_proc(1)%t_var(:), &
|
|
& td_var%c_name, td_var%c_stdname )
|
|
ENDIF
|
|
|
|
IF( il_varid /= 0 )THEN
|
|
|
|
DO ji=1,td_mpp%t_proc(1)%i_nvar
|
|
CALL logger_debug( " MPP ADD VAR: in mpp structure : &
|
|
& variable "//TRIM(td_mpp%t_proc(1)%t_var(ji)%c_name)//&
|
|
& ", standard name "//&
|
|
& TRIM(td_mpp%t_proc(1)%t_var(ji)%c_stdname) )
|
|
ENDDO
|
|
CALL logger_error( " MPP ADD VAR: variable "//TRIM(td_var%c_name)//&
|
|
& ", standard name "//TRIM(td_var%c_stdname)//&
|
|
& ", already in mpp "//TRIM(td_mpp%c_name) )
|
|
|
|
ELSE
|
|
|
|
CALL logger_info( &
|
|
& " MPP ADD VAR: add variable "//TRIM(td_var%c_name)//&
|
|
& ", standard name "//TRIM(td_var%c_stdname)//&
|
|
& ", in mpp "//TRIM(td_mpp%c_name) )
|
|
! check used dimension
|
|
IF( mpp__check_dim(td_mpp, td_var) )THEN
|
|
|
|
! check variable dimension expected
|
|
CALL var_check_dim(td_var)
|
|
|
|
! update dimension if need be
|
|
DO ji=1,ip_maxdim
|
|
IF( td_var%t_dim(ji)%l_use .AND. &
|
|
& .NOT. td_mpp%t_dim(ji)%l_use )THEN
|
|
CALL mpp_add_dim(td_mpp,td_var%t_dim(ji))
|
|
ENDIF
|
|
ENDDO
|
|
|
|
! add variable in each processor
|
|
IF( td_mpp%i_nproc == 1 )THEN
|
|
CALL file_add_var(td_mpp%t_proc(1), td_var)
|
|
ELSE
|
|
DO ji=1,td_mpp%i_nproc
|
|
! split variable on domain decomposition
|
|
tl_var=mpp__split_var(td_mpp, td_var, ji)
|
|
|
|
CALL file_add_var(td_mpp%t_proc(ji), tl_var)
|
|
|
|
! clean
|
|
CALL var_clean(tl_var)
|
|
ENDDO
|
|
ENDIF
|
|
|
|
ENDIF
|
|
ENDIF
|
|
ENDIF
|
|
ENDIF
|
|
|
|
END SUBROUTINE mpp_add_var
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
FUNCTION mpp__split_var(td_mpp, td_var, id_procid) &
|
|
& RESULT(tf_var)
|
|
!-------------------------------------------------------------------
|
|
!> @brief This function extract, from variable structure, part that will
|
|
!> be written in processor id_procid.<br/>
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date November, 2013 - Initial Version
|
|
!>
|
|
!> @param[in] td_mpp mpp structure
|
|
!> @param[in] td_var variable structure
|
|
!> @param[in] id_procid processor id
|
|
!> @return variable structure
|
|
!-------------------------------------------------------------------
|
|
|
|
IMPLICIT NONE
|
|
|
|
! Argument
|
|
TYPE(TMPP), INTENT(IN) :: td_mpp
|
|
TYPE(TVAR), INTENT(IN) :: td_var
|
|
INTEGER(i4), INTENT(IN) :: id_procid
|
|
|
|
! function
|
|
TYPE(TVAR) :: tf_var
|
|
|
|
! local variable
|
|
TYPE(TDIM) :: tl_dim
|
|
|
|
INTEGER(i4), DIMENSION(4) :: il_ind
|
|
INTEGER(i4), DIMENSION(2) :: il_size
|
|
INTEGER(i4) :: il_i1
|
|
INTEGER(i4) :: il_i2
|
|
INTEGER(i4) :: il_j1
|
|
INTEGER(i4) :: il_j2
|
|
!----------------------------------------------------------------
|
|
|
|
! copy mpp
|
|
tf_var=var_copy(td_var, ld_value=.FALSE.)
|
|
|
|
! get processor indices
|
|
il_ind(:)=mpp_get_proc_index( td_mpp, id_procid )
|
|
il_i1 = il_ind(1)
|
|
il_i2 = il_ind(2)
|
|
il_j1 = il_ind(3)
|
|
il_j2 = il_ind(4)
|
|
|
|
IF( .NOT. td_var%t_dim(1)%l_use )THEN
|
|
il_i1=1
|
|
il_i2=1
|
|
ENDIF
|
|
|
|
IF( .NOT. td_var%t_dim(2)%l_use )THEN
|
|
il_j1=1
|
|
il_j2=1
|
|
ENDIF
|
|
|
|
IF( ASSOCIATED(td_var%d_value) )THEN
|
|
! remove value over global domain from pointer
|
|
!CALL var_del_value( tf_var )
|
|
|
|
! get processor dimension
|
|
il_size(:)=mpp_get_proc_size( td_mpp, id_procid )
|
|
|
|
! define new dimension in variable structure
|
|
IF( td_var%t_dim(1)%l_use )THEN
|
|
tl_dim=dim_init( TRIM(td_var%t_dim(1)%c_name), il_size(1) )
|
|
CALL var_move_dim( tf_var, tl_dim )
|
|
ENDIF
|
|
IF( td_var%t_dim(2)%l_use )THEN
|
|
tl_dim=dim_init( TRIM(td_var%t_dim(2)%c_name), il_size(2) )
|
|
CALL var_move_dim( tf_var, tl_dim )
|
|
ENDIF
|
|
|
|
! add variable value on processor
|
|
CALL var_add_value( tf_var, &
|
|
& td_var%d_value(il_i1:il_i2, il_j1:il_j2, :, :) )
|
|
|
|
ELSE
|
|
|
|
tf_var%t_dim(jp_I)%i_len=il_i2-il_i1+1
|
|
tf_var%t_dim(jp_J)%i_len=il_j2-il_j1+1
|
|
|
|
ENDIF
|
|
|
|
END FUNCTION mpp__split_var
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
SUBROUTINE mpp__del_var_mpp(td_mpp)
|
|
!-------------------------------------------------------------------
|
|
!> @brief
|
|
!> This subroutine delete all variable in mpp strcuture.
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date October, 2014 - Initial version
|
|
!>
|
|
!> @param[inout] td_mpp mpp strcuture
|
|
!-------------------------------------------------------------------
|
|
|
|
IMPLICIT NONE
|
|
|
|
! Argument
|
|
TYPE(TMPP), INTENT(INOUT) :: td_mpp
|
|
|
|
! local variable
|
|
! loop indices
|
|
INTEGER(i4) :: ji
|
|
!----------------------------------------------------------------
|
|
|
|
CALL logger_info( &
|
|
& "MPP CLEAN VAR: reset all variable "//&
|
|
& "in mpp strcuture "//TRIM(td_mpp%c_name) )
|
|
|
|
IF( ASSOCIATED(td_mpp%t_proc) )THEN
|
|
DO ji=td_mpp%t_proc(1)%i_nvar,1,-1
|
|
CALL mpp_del_var(td_mpp, td_mpp%t_proc(1)%t_var(ji))
|
|
ENDDO
|
|
ENDIF
|
|
|
|
END SUBROUTINE mpp__del_var_mpp
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
SUBROUTINE mpp__del_var_str(td_mpp, td_var)
|
|
!-------------------------------------------------------------------
|
|
!> @brief
|
|
!> This subroutine delete variable in mpp structure, given variable
|
|
!> structure.
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date November, 2013 - Initial version
|
|
!>
|
|
!> @param[inout] td_mpp mpp strcuture
|
|
!> @param[in] td_var variable strcuture
|
|
!-------------------------------------------------------------------
|
|
|
|
IMPLICIT NONE
|
|
|
|
! Argument
|
|
TYPE(TMPP), INTENT(INOUT) :: td_mpp
|
|
TYPE(TVAR), INTENT(IN) :: td_var
|
|
|
|
! local variable
|
|
INTEGER(i4) :: il_varid
|
|
CHARACTER(LEN=lc) :: cl_name
|
|
|
|
! loop indices
|
|
INTEGER(i4) :: ji
|
|
!----------------------------------------------------------------
|
|
|
|
! check if mpp exist
|
|
IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
|
|
|
|
CALL logger_error( "MPP DEL VAR: domain decomposition not define "//&
|
|
& " in mpp strcuture "//TRIM(td_mpp%c_name))
|
|
|
|
ELSE
|
|
|
|
! check if variable already in mpp structure
|
|
il_varid = 0
|
|
IF( ASSOCIATED(td_mpp%t_proc(1)%t_var) )THEN
|
|
il_varid=var_get_index( td_mpp%t_proc(1)%t_var(:), &
|
|
& td_var%c_name, td_var%c_stdname )
|
|
ENDIF
|
|
IF( il_varid == 0 )THEN
|
|
CALL logger_error( &
|
|
& "MPP DEL VAR: no variable "//TRIM(td_var%c_name)//&
|
|
& ", in mpp structure "//TRIM(td_mpp%c_name) )
|
|
|
|
DO ji=1,td_mpp%t_proc(1)%i_nvar
|
|
CALL logger_debug( "MPP DEL VAR: in mpp structure : &
|
|
& variable : "//TRIM(td_mpp%t_proc(1)%t_var(ji)%c_name)//&
|
|
& ", standard name "//&
|
|
& TRIM(td_mpp%t_proc(1)%t_var(ji)%c_stdname) )
|
|
ENDDO
|
|
|
|
ELSE
|
|
|
|
cl_name=TRIM(td_var%c_name)
|
|
DO ji=1,td_mpp%i_nproc
|
|
CALL file_del_var(td_mpp%t_proc(ji), TRIM(cl_name))
|
|
ENDDO
|
|
|
|
ENDIF
|
|
ENDIF
|
|
|
|
END SUBROUTINE mpp__del_var_str
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
SUBROUTINE mpp__del_var_name(td_mpp, cd_name)
|
|
!-------------------------------------------------------------------
|
|
!> @brief
|
|
!> This subroutine delete variable in mpp structure, given variable name.
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date November, 2013 - Initial version
|
|
!> @date February, 2015
|
|
!> - define local variable structure to avoid mistake with pointer
|
|
!> @date January, 2019
|
|
!> - clean variable strcuture
|
|
!>
|
|
!> @param[inout] td_mpp mpp strcuture
|
|
!> @param[in] cd_name variable name
|
|
!-------------------------------------------------------------------
|
|
|
|
IMPLICIT NONE
|
|
|
|
! Argument
|
|
TYPE(TMPP) , INTENT(INOUT) :: td_mpp
|
|
CHARACTER(LEN=*), INTENT(IN ) :: cd_name
|
|
|
|
! local variable
|
|
INTEGER(i4) :: il_varid
|
|
TYPE(TVAR) :: tl_var
|
|
!----------------------------------------------------------------
|
|
|
|
! check if mpp exist
|
|
IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
|
|
|
|
CALL logger_error( "MPP DEL VAR: domain decomposition not define "//&
|
|
& " in mpp strcuture "//TRIM(td_mpp%c_name))
|
|
|
|
ELSE
|
|
|
|
IF( td_mpp%t_proc(1)%i_nvar == 0 )THEN
|
|
CALL logger_debug( "MPP DEL VAR NAME: no variable associated to mpp &
|
|
& structure "//TRIM(td_mpp%c_name) )
|
|
ELSE
|
|
|
|
! get the variable id, in file variable structure
|
|
il_varid=0
|
|
IF( ASSOCIATED(td_mpp%t_proc(1)%t_var) )THEN
|
|
il_varid=var_get_index( td_mpp%t_proc(1)%t_var(:), &
|
|
& cd_name )
|
|
ENDIF
|
|
|
|
IF( il_varid == 0 )THEN
|
|
|
|
CALL logger_warn( &
|
|
& "MPP DEL VAR : there is no variable with name "//&
|
|
& "or standard name "//TRIM(ADJUSTL(cd_name))//&
|
|
& " in mpp structure "//TRIM(td_mpp%c_name))
|
|
|
|
ELSE
|
|
|
|
tl_var=var_copy(td_mpp%t_proc(1)%t_var(il_varid))
|
|
CALL mpp_del_var(td_mpp, tl_var)
|
|
! clean
|
|
CALL var_clean(tl_var)
|
|
ENDIF
|
|
ENDIF
|
|
ENDIF
|
|
|
|
END SUBROUTINE mpp__del_var_name
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
SUBROUTINE mpp_move_var(td_mpp, td_var)
|
|
!-------------------------------------------------------------------
|
|
!> @brief
|
|
!> This subroutine overwrite variable in mpp structure.
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date November, 2013 - Initial version
|
|
!>
|
|
!> @param[inout] td_mpp mpp strcuture
|
|
!> @param[in] td_var variable structure
|
|
!-------------------------------------------------------------------
|
|
|
|
IMPLICIT NONE
|
|
|
|
! Argument
|
|
TYPE(TMPP), INTENT(INOUT) :: td_mpp
|
|
TYPE(TVAR), INTENT(IN) :: td_var
|
|
|
|
!local variable
|
|
TYPE(TVAR) :: tl_var
|
|
!----------------------------------------------------------------
|
|
|
|
! copy variablie
|
|
tl_var=var_copy(td_var)
|
|
|
|
! remove processor
|
|
CALL mpp_del_var(td_mpp, tl_var)
|
|
|
|
! add processor
|
|
CALL mpp_add_var(td_mpp, tl_var)
|
|
|
|
! clean
|
|
CALL var_clean(tl_var)
|
|
|
|
END SUBROUTINE mpp_move_var
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
SUBROUTINE mpp__add_proc_unit(td_mpp, td_proc)
|
|
!-------------------------------------------------------------------
|
|
!> @brief
|
|
!> This subroutine add processor to mpp structure.
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date November, 2013 - Initial version
|
|
!> @date January, 2019
|
|
!> - deallocate file structure whatever happens
|
|
!> @date July, 2020
|
|
!> - look for array index of proc id, only if proc id contains in array
|
|
!>
|
|
!> @param[inout] td_mpp mpp strcuture
|
|
!> @param[in] td_proc processor strcuture
|
|
!-------------------------------------------------------------------
|
|
|
|
IMPLICIT NONE
|
|
|
|
! Argument
|
|
TYPE(TMPP) , INTENT(INOUT) :: td_mpp
|
|
TYPE(TFILE), INTENT(IN) :: td_proc
|
|
|
|
! local variable
|
|
INTEGER(i4) :: il_status
|
|
INTEGER(i4) :: il_procid
|
|
INTEGER(i4) , DIMENSION(1) :: il_ind
|
|
|
|
TYPE(TFILE) , DIMENSION(:), ALLOCATABLE :: tl_proc
|
|
|
|
LOGICAL , DIMENSION(:), ALLOCATABLE :: ll_mask
|
|
|
|
CHARACTER(LEN=lc) :: cl_name
|
|
!----------------------------------------------------------------
|
|
|
|
! check file name
|
|
cl_name=TRIM( file_rename(td_proc%c_name) )
|
|
IF( TRIM(cl_name) /= TRIM(td_mpp%c_name) )THEN
|
|
CALL logger_warn("MPP ADD PROC: processor name do not match mpp name")
|
|
ENDIF
|
|
|
|
il_procid=0
|
|
IF( ASSOCIATED(td_mpp%t_proc) )THEN
|
|
! check if processor already in mpp structure
|
|
ALLOCATE(ll_mask(SIZE(td_mpp%t_proc(:))))
|
|
ll_mask(:)=(td_mpp%t_proc(:)%i_pid==td_proc%i_pid)
|
|
IF( ANY(ll_mask(:)) )THEN
|
|
il_ind(:)=MINLOC( td_mpp%t_proc(:)%i_pid, mask=ll_mask(:) )
|
|
il_procid=il_ind(1)
|
|
ENDIF
|
|
DEALLOCATE(ll_mask)
|
|
ENDIF
|
|
|
|
IF( il_procid /= 0 )THEN
|
|
|
|
CALL logger_error( &
|
|
& "MPP ADD PROC: processor "//TRIM(fct_str(td_proc%i_pid))//&
|
|
& ", already in mpp structure " )
|
|
|
|
ELSE
|
|
|
|
CALL logger_trace("MPP ADD PROC: add processor "//&
|
|
& TRIM(fct_str(td_mpp%i_nproc+1))//" in mpp structure")
|
|
|
|
IF( td_mpp%i_nproc > 0 )THEN
|
|
!
|
|
il_ind(:)=MAXLOC( td_mpp%t_proc(:)%i_pid, &
|
|
mask=(td_mpp%t_proc(:)%i_pid < td_proc%i_pid) )
|
|
il_procid=il_ind(1)
|
|
|
|
! already other processor in mpp structure
|
|
ALLOCATE( tl_proc(td_mpp%i_nproc), stat=il_status )
|
|
IF(il_status /= 0 )THEN
|
|
|
|
CALL logger_error( "MPP ADD PROC: not enough space to put processor &
|
|
& in mpp structure")
|
|
|
|
ELSE
|
|
! save temporary mpp structure
|
|
tl_proc(:)=file_copy(td_mpp%t_proc(:))
|
|
|
|
CALL file_clean( td_mpp%t_proc(:) )
|
|
DEALLOCATE(td_mpp%t_proc)
|
|
ALLOCATE( td_mpp%t_proc(td_mpp%i_nproc+1), stat=il_status)
|
|
IF(il_status /= 0 )THEN
|
|
|
|
CALL logger_error( "MPP ADD PROC: not enough space to put "//&
|
|
& "processor in mpp structure ")
|
|
|
|
ENDIF
|
|
|
|
! copy processor in mpp before
|
|
! processor with lower id than new processor
|
|
td_mpp%t_proc( 1:il_procid ) = file_copy(tl_proc( 1:il_procid ))
|
|
|
|
! processor with greater id than new processor
|
|
td_mpp%t_proc( il_procid+1 : td_mpp%i_nproc+1 ) = &
|
|
& file_copy(tl_proc( il_procid : td_mpp%i_nproc ))
|
|
|
|
! clean
|
|
CALL file_clean(tl_proc(:))
|
|
ENDIF
|
|
DEALLOCATE(tl_proc)
|
|
|
|
ELSE
|
|
|
|
! no processor in mpp structure
|
|
IF( ASSOCIATED(td_mpp%t_proc) )THEN
|
|
CALL file_clean(td_mpp%t_proc(:))
|
|
DEALLOCATE(td_mpp%t_proc)
|
|
ENDIF
|
|
ALLOCATE( td_mpp%t_proc(td_mpp%i_nproc+1), stat=il_status )
|
|
IF(il_status /= 0 )THEN
|
|
|
|
CALL logger_error( "MPP ADD PROC: not enough space to put "//&
|
|
& "processor in mpp structure " )
|
|
|
|
ENDIF
|
|
ENDIF
|
|
|
|
! check dimension
|
|
IF( ANY(td_mpp%t_dim(1:2)%i_len < td_proc%t_dim(1:2)%i_len) )THEN
|
|
CALL logger_error( "MPP ADD PROC: mpp structure and new processor "//&
|
|
& " dimension differ. ")
|
|
CALL logger_debug("MPP ADD PROC: mpp dimension ("//&
|
|
& TRIM(fct_str(td_mpp%t_dim(1)%i_len))//","//&
|
|
& TRIM(fct_str(td_mpp%t_dim(2)%i_len))//")" )
|
|
CALL logger_debug("MPP ADD PROC: processor dimension ("//&
|
|
& TRIM(fct_str(td_proc%t_dim(1)%i_len))//","//&
|
|
& TRIM(fct_str(td_proc%t_dim(2)%i_len))//")" )
|
|
ELSE
|
|
td_mpp%i_nproc=td_mpp%i_nproc+1
|
|
|
|
! add new processor
|
|
td_mpp%t_proc(td_mpp%i_nproc)=file_copy(td_proc)
|
|
ENDIF
|
|
|
|
ENDIF
|
|
|
|
END SUBROUTINE mpp__add_proc_unit
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
SUBROUTINE mpp__add_proc_arr(td_mpp, td_proc)
|
|
!-------------------------------------------------------------------
|
|
!> @brief
|
|
!> This subroutine add array of processor to mpp structure.
|
|
!> @note mpp structure should be empty
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date August, 2017 - Initial version
|
|
!>
|
|
!> @param[inout] td_mpp mpp strcuture
|
|
!> @param[in] td_proc array of processor strcuture
|
|
!-------------------------------------------------------------------
|
|
|
|
IMPLICIT NONE
|
|
|
|
! Argument
|
|
TYPE(TMPP) , INTENT(INOUT) :: td_mpp
|
|
TYPE(TFILE), DIMENSION(:), INTENT(IN ) :: td_proc
|
|
|
|
! local variable
|
|
INTEGER(i4) :: il_status
|
|
INTEGER(i4) :: il_nproc
|
|
|
|
CHARACTER(LEN=lc) :: cl_name
|
|
!----------------------------------------------------------------
|
|
|
|
! check file name
|
|
cl_name=TRIM( file_rename(td_proc(1)%c_name) )
|
|
IF( TRIM(cl_name) /= TRIM(td_mpp%c_name) )THEN
|
|
CALL logger_warn("MPP ADD PROC: processor name do not match mpp name")
|
|
ENDIF
|
|
|
|
IF( ASSOCIATED(td_mpp%t_proc) )THEN
|
|
CALL logger_error( &
|
|
& "MPP ADD PROC: some processor(s) already in mpp structure " )
|
|
|
|
ELSE
|
|
|
|
CALL logger_trace("MPP ADD PROC: add array of processor "//&
|
|
& " in mpp structure")
|
|
|
|
il_nproc=SIZE(td_proc)
|
|
ALLOCATE( td_mpp%t_proc(il_nproc), stat=il_status )
|
|
IF(il_status /= 0 )THEN
|
|
CALL logger_error( "MPP ADD PROC: not enough space to put "//&
|
|
& "processor in mpp structure " )
|
|
ENDIF
|
|
|
|
! check dimension
|
|
IF( ANY(td_mpp%t_dim(1:2)%i_len < td_proc(1)%t_dim(1:2)%i_len) )THEN
|
|
CALL logger_error( "MPP ADD PROC: mpp structure and new processor "//&
|
|
& " dimension differ. ")
|
|
CALL logger_debug("MPP ADD PROC: mpp dimension ("//&
|
|
& TRIM(fct_str(td_mpp%t_dim(1)%i_len))//","//&
|
|
& TRIM(fct_str(td_mpp%t_dim(2)%i_len))//")" )
|
|
CALL logger_debug("MPP ADD PROC: processor dimension ("//&
|
|
& TRIM(fct_str(td_proc(1)%t_dim(1)%i_len))//","//&
|
|
& TRIM(fct_str(td_proc(1)%t_dim(2)%i_len))//")" )
|
|
ELSE
|
|
td_mpp%i_nproc=il_nproc
|
|
|
|
! add new processor
|
|
td_mpp%t_proc(:)=file_copy(td_proc(:))
|
|
ENDIF
|
|
|
|
ENDIF
|
|
|
|
END SUBROUTINE mpp__add_proc_arr
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
SUBROUTINE mpp__del_proc_id(td_mpp, id_procid)
|
|
!-------------------------------------------------------------------
|
|
!> @brief
|
|
!> This subroutine delete processor in mpp structure, given processor id.
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date November, 2013 - Initial version
|
|
!> @date January, 2019
|
|
!> - clean file structure
|
|
!>
|
|
!> @param[inout] td_mpp mpp strcuture
|
|
!> @param[in] id_procid processor id
|
|
!-------------------------------------------------------------------
|
|
|
|
IMPLICIT NONE
|
|
|
|
! Argument
|
|
TYPE(TMPP), INTENT(INOUT) :: td_mpp
|
|
INTEGER(i4), INTENT(IN) :: id_procid
|
|
|
|
! local variable
|
|
INTEGER(i4) :: il_status
|
|
INTEGER(i4) :: il_procid
|
|
INTEGER(i4), DIMENSION(1) :: il_ind
|
|
TYPE(TFILE), DIMENSION(:), ALLOCATABLE :: tl_proc
|
|
|
|
! loop indices
|
|
!----------------------------------------------------------------
|
|
|
|
il_ind(:)=MINLOC(td_mpp%t_proc(:)%i_pid,td_mpp%t_proc(:)%i_pid==id_procid)
|
|
il_procid=il_ind(1)
|
|
IF( il_procid == 0 )THEN
|
|
CALL logger_error("MPP DEL PROC: no processor "//&
|
|
& TRIM(fct_str(id_procid))//&
|
|
& " associated to mpp structure")
|
|
ELSE
|
|
CALL logger_trace("DEL PROC: remove processor "//&
|
|
& TRIM(fct_str(id_procid)))
|
|
|
|
IF( td_mpp%i_nproc > 1 )THEN
|
|
ALLOCATE( tl_proc(td_mpp%i_nproc-1), stat=il_status )
|
|
IF(il_status /= 0 )THEN
|
|
CALL logger_error( "MPP DEL PROC: not enough space to put &
|
|
& processor in temporary mpp structure")
|
|
|
|
ELSE
|
|
|
|
! save temporary processor's mpp structure
|
|
IF( il_procid > 1 )THEN
|
|
tl_proc(1:il_procid-1)=file_copy(td_mpp%t_proc(1:il_procid-1))
|
|
ENDIF
|
|
|
|
IF( il_procid < td_mpp%i_nproc )THEN
|
|
tl_proc(il_procid:)=file_copy(td_mpp%t_proc(il_procid+1:))
|
|
ENDIF
|
|
|
|
! new number of processor in mpp
|
|
td_mpp%i_nproc=td_mpp%i_nproc-1
|
|
|
|
CALL file_clean( td_mpp%t_proc(:) )
|
|
DEALLOCATE(td_mpp%t_proc)
|
|
ALLOCATE( td_mpp%t_proc(td_mpp%i_nproc), stat=il_status )
|
|
IF(il_status /= 0 )THEN
|
|
|
|
CALL logger_error( "MPP DEL PROC: not enough space &
|
|
& to put processors in mpp structure " )
|
|
|
|
ELSE
|
|
|
|
! copy processor in mpp before
|
|
td_mpp%t_proc(:)=file_copy(tl_proc(:))
|
|
|
|
! update processor id
|
|
td_mpp%t_proc( il_procid : td_mpp%i_nproc )%i_pid = &
|
|
& td_mpp%t_proc( il_procid : td_mpp%i_nproc )%i_pid - 1
|
|
|
|
ENDIF
|
|
ENDIF
|
|
! clean
|
|
CALL file_clean( tl_proc(:) )
|
|
DEALLOCATE(tl_proc)
|
|
ELSE
|
|
CALL file_clean( td_mpp%t_proc(:) )
|
|
DEALLOCATE(td_mpp%t_proc)
|
|
|
|
! new number of processor in mpp
|
|
td_mpp%i_nproc=td_mpp%i_nproc-1
|
|
ENDIF
|
|
ENDIF
|
|
|
|
END SUBROUTINE mpp__del_proc_id
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
SUBROUTINE mpp__del_proc_str(td_mpp, td_proc)
|
|
!-------------------------------------------------------------------
|
|
!> @brief
|
|
!> This subroutine delete processor in mpp structure, given processor
|
|
!> structure.
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date November, 2013 - Initial version
|
|
!>
|
|
!> @param[inout] td_mpp : mpp strcuture
|
|
!> @param[in] td_proc : file/processor structure
|
|
!-------------------------------------------------------------------
|
|
|
|
IMPLICIT NONE
|
|
|
|
! Argument
|
|
TYPE(TMPP), INTENT(INOUT) :: td_mpp
|
|
TYPE(TFILE), INTENT(IN) :: td_proc
|
|
!----------------------------------------------------------------
|
|
|
|
IF( td_proc%i_pid >= 0 )THEN
|
|
CALL mpp__del_proc( td_mpp, td_proc%i_pid )
|
|
ELSE
|
|
CALL logger_error("MPP DEL PROC: processor not defined")
|
|
ENDIF
|
|
|
|
END SUBROUTINE mpp__del_proc_str
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
SUBROUTINE mpp__move_proc(td_mpp, td_proc)
|
|
!-------------------------------------------------------------------
|
|
!> @brief
|
|
!> This subroutine overwrite processor in mpp structure.
|
|
!>
|
|
!> @detail
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date Nov, 2013 - Initial version
|
|
!>
|
|
!> @param[inout] td_mpp mpp strcuture
|
|
!> @param[in] id_procid processor id
|
|
!-------------------------------------------------------------------
|
|
|
|
IMPLICIT NONE
|
|
|
|
! Argument
|
|
TYPE(TMPP), INTENT(INOUT) :: td_mpp
|
|
TYPE(TFILE), INTENT(IN) :: td_proc
|
|
!----------------------------------------------------------------
|
|
|
|
! remove processor
|
|
CALL mpp__del_proc(td_mpp, td_proc)
|
|
|
|
! add processor
|
|
CALL mpp__add_proc(td_mpp, td_proc)
|
|
|
|
END SUBROUTINE mpp__move_proc
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
SUBROUTINE mpp_add_dim(td_mpp, td_dim)
|
|
!-------------------------------------------------------------------
|
|
!> @brief This subroutine add a dimension structure in a mpp
|
|
!> structure.
|
|
!> Do not overwrite, if dimension already in mpp structure.
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date November, 2013 - Initial Version
|
|
!> @date July, 2015
|
|
!> - rewrite the same as way var_add_dim
|
|
!>
|
|
!> @param[inout] td_mpp mpp structure
|
|
!> @param[in] td_dim dimension structure
|
|
!-------------------------------------------------------------------
|
|
|
|
IMPLICIT NONE
|
|
|
|
! Argument
|
|
TYPE(TMPP), INTENT(INOUT) :: td_mpp
|
|
TYPE(TDIM), INTENT(IN) :: td_dim
|
|
|
|
! local variable
|
|
INTEGER(i4) :: il_ind
|
|
|
|
! loop indices
|
|
!----------------------------------------------------------------
|
|
|
|
IF( td_mpp%i_ndim <= ip_maxdim )THEN
|
|
|
|
! check if dimension already used in mpp structure
|
|
il_ind=SCAN(TRIM(cp_dimorder),TRIM(td_dim%c_sname))
|
|
IF( il_ind == 0 )THEN
|
|
CALL logger_warn( &
|
|
& " MPP ADD DIM: dimension "//TRIM(td_dim%c_name)//&
|
|
& ", short name "//TRIM(td_dim%c_sname)//&
|
|
& ", will not be added in mpp "//TRIM(td_mpp%c_name) )
|
|
ELSEIF( td_mpp%t_dim(il_ind)%l_use )THEN
|
|
CALL logger_error( &
|
|
& " MPP ADD DIM: dimension "//TRIM(td_dim%c_name)//&
|
|
& ", short name "//TRIM(td_dim%c_sname)//&
|
|
& ", already used in mpp "//TRIM(td_mpp%c_name) )
|
|
ELSE
|
|
|
|
! back to disorder dimension array
|
|
CALL dim_disorder(td_mpp%t_dim(:))
|
|
|
|
! add new dimension
|
|
td_mpp%t_dim(td_mpp%i_ndim+1)=dim_copy(td_dim)
|
|
|
|
! update number of attribute
|
|
td_mpp%i_ndim=COUNT(td_mpp%t_dim(:)%l_use)
|
|
|
|
ENDIF
|
|
! reorder dimension to ('x','y','z','t')
|
|
CALL dim_reorder(td_mpp%t_dim(:))
|
|
|
|
ELSE
|
|
CALL logger_error( &
|
|
& "MPP ADD DIM: too much dimension in mpp "//&
|
|
& TRIM(td_mpp%c_name)//" ("//TRIM(fct_str(td_mpp%i_ndim))//")")
|
|
ENDIF
|
|
|
|
END SUBROUTINE mpp_add_dim
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
SUBROUTINE mpp_del_dim(td_mpp, td_dim)
|
|
!-------------------------------------------------------------------
|
|
!> @brief This subroutine delete a dimension structure in a mpp
|
|
!> structure.<br/>
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date November, 2013 - Initial Version
|
|
!> @date July, 2015
|
|
!> - rewrite the same as way var_del_dim
|
|
!>
|
|
!> @param[inout] td_mpp mpp structure
|
|
!> @param[in] td_dim dimension structure
|
|
!-------------------------------------------------------------------
|
|
|
|
IMPLICIT NONE
|
|
|
|
! Argument
|
|
TYPE(TMPP), INTENT(INOUT) :: td_mpp
|
|
TYPE(TDIM), INTENT(IN) :: td_dim
|
|
|
|
! local variable
|
|
INTEGER(i4) :: il_ind
|
|
TYPE(TDIM) :: tl_dim
|
|
|
|
! loop indices
|
|
!----------------------------------------------------------------
|
|
|
|
IF( td_mpp%i_ndim <= ip_maxdim )THEN
|
|
|
|
CALL logger_trace( &
|
|
& " MPP DEL DIM: delete dimension "//TRIM(td_dim%c_name)//&
|
|
& ", short name "//TRIM(td_dim%c_sname)//&
|
|
& ", in mpp "//TRIM(td_mpp%c_name) )
|
|
|
|
! check if dimension already in variable structure
|
|
il_ind=SCAN(TRIM(cp_dimorder),TRIM(td_dim%c_sname))
|
|
|
|
! replace dimension by empty one
|
|
td_mpp%t_dim(il_ind)=dim_copy(tl_dim)
|
|
|
|
! update number of dimension
|
|
td_mpp%i_ndim=COUNT(td_mpp%t_dim(:)%l_use)
|
|
|
|
! reorder dimension to ('x','y','z','t')
|
|
CALL dim_reorder(td_mpp%t_dim)
|
|
|
|
ELSE
|
|
CALL logger_error( &
|
|
& " MPP DEL DIM: too much dimension in mpp "//&
|
|
& TRIM(td_mpp%c_name)//" ("//TRIM(fct_str(td_mpp%i_ndim))//")")
|
|
ENDIF
|
|
|
|
END SUBROUTINE mpp_del_dim
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
SUBROUTINE mpp_move_dim(td_mpp, td_dim)
|
|
!-------------------------------------------------------------------
|
|
!> @brief This subroutine move a dimension structure
|
|
!> in mpp structure.
|
|
!> @warning dimension order may have changed
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date November, 2013 - Initial Version
|
|
!>
|
|
!> @param[inout] td_mpp mpp structure
|
|
!> @param[in] td_dim dimension structure
|
|
!-------------------------------------------------------------------
|
|
|
|
IMPLICIT NONE
|
|
|
|
! Argument
|
|
TYPE(TMPP), INTENT(INOUT) :: td_mpp
|
|
TYPE(TDIM), INTENT(IN) :: td_dim
|
|
|
|
! local variable
|
|
INTEGER(i4) :: il_ind
|
|
INTEGER(i4) :: il_dimid
|
|
!----------------------------------------------------------------
|
|
|
|
IF( td_mpp%i_ndim <= ip_maxdim )THEN
|
|
|
|
! check if dimension already in mpp structure
|
|
il_ind=dim_get_index(td_mpp%t_dim(:), td_dim%c_name, td_dim%c_sname)
|
|
IF( il_ind /= 0 )THEN
|
|
|
|
il_dimid=td_mpp%t_dim(il_ind)%i_id
|
|
! replace dimension
|
|
td_mpp%t_dim(il_ind)=dim_copy(td_dim)
|
|
td_mpp%t_dim(il_ind)%i_id=il_dimid
|
|
td_mpp%t_dim(il_ind)%l_use=.TRUE.
|
|
|
|
ELSE
|
|
CALL mpp_add_dim(td_mpp, td_dim)
|
|
ENDIF
|
|
|
|
ELSE
|
|
CALL logger_error( &
|
|
& "MPP MOVE DIM: too much dimension in mpp "//&
|
|
& TRIM(td_mpp%c_name)//" ("//TRIM(fct_str(td_mpp%i_ndim))//")")
|
|
ENDIF
|
|
|
|
END SUBROUTINE mpp_move_dim
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
SUBROUTINE mpp_add_att(td_mpp, td_att)
|
|
!-------------------------------------------------------------------
|
|
!> @brief
|
|
!> This subroutine add global attribute to mpp structure.
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date November, 2013 - Initial version
|
|
!>
|
|
!> @param[inout] td_mpp mpp strcuture
|
|
!> @param[in] td_att attribute strcuture
|
|
!-------------------------------------------------------------------
|
|
|
|
IMPLICIT NONE
|
|
|
|
! Argument
|
|
TYPE(TMPP), INTENT(INOUT) :: td_mpp
|
|
TYPE(TATT), INTENT(IN) :: td_att
|
|
|
|
! local variable
|
|
INTEGER(i4) :: il_attid
|
|
|
|
! loop indices
|
|
INTEGER(i4) :: ji
|
|
!----------------------------------------------------------------
|
|
|
|
! check if mpp exist
|
|
IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
|
|
|
|
CALL logger_error( "MPP ADD ATT: domain decomposition not define "//&
|
|
& "for mpp "//TRIM(td_mpp%c_name))
|
|
|
|
ELSE
|
|
! check if variable exist
|
|
IF( TRIM(td_att%c_name) == '' )THEN
|
|
CALL logger_error("MPP ADD ATT: attribute not define ")
|
|
ELSE
|
|
! check if attribute already in mpp structure
|
|
il_attid=0
|
|
IF( ASSOCIATED(td_mpp%t_proc(1)%t_att) )THEN
|
|
il_attid=att_get_index( td_mpp%t_proc(1)%t_att(:), &
|
|
& td_att%c_name )
|
|
ENDIF
|
|
IF( il_attid /= 0 )THEN
|
|
|
|
CALL logger_error( " MPP ADD ATT: attribute "//&
|
|
& TRIM(td_att%c_name)//&
|
|
& ", already in mpp "//TRIM(td_mpp%c_name) )
|
|
|
|
DO ji=1,td_mpp%t_proc(1)%i_natt
|
|
CALL logger_debug( " MPP ADD ATT: in mpp structure : &
|
|
& attribute "//TRIM(td_mpp%t_proc(1)%t_att(ji)%c_name) )
|
|
ENDDO
|
|
|
|
ELSE
|
|
|
|
CALL logger_info( &
|
|
& " MPP ADD ATT: add attribute "//TRIM(td_att%c_name)//&
|
|
& ", in mpp "//TRIM(td_mpp%c_name) )
|
|
|
|
! add attribute in each processor
|
|
DO ji=1,td_mpp%i_nproc
|
|
|
|
CALL file_add_att(td_mpp%t_proc(ji), td_att)
|
|
|
|
ENDDO
|
|
|
|
ENDIF
|
|
ENDIF
|
|
ENDIF
|
|
|
|
END SUBROUTINE mpp_add_att
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
SUBROUTINE mpp__del_att_str(td_mpp, td_att)
|
|
!-------------------------------------------------------------------
|
|
!> @brief
|
|
!> This subroutine delete attribute in mpp structure, given attribute
|
|
!> structure.
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date November, 2013 - Initial version
|
|
!>
|
|
!> @param[inout] td_mpp mpp strcuture
|
|
!> @param[in] td_att attribute strcuture
|
|
!-------------------------------------------------------------------
|
|
|
|
IMPLICIT NONE
|
|
|
|
! Argument
|
|
TYPE(TMPP), INTENT(INOUT) :: td_mpp
|
|
TYPE(TATT), INTENT(IN) :: td_att
|
|
|
|
! local variable
|
|
INTEGER(i4) :: il_attid
|
|
CHARACTER(LEN=lc) :: cl_name
|
|
|
|
! loop indices
|
|
INTEGER(i4) :: ji
|
|
!----------------------------------------------------------------
|
|
|
|
! check if mpp exist
|
|
IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
|
|
|
|
CALL logger_warn( "MPP DEL VAR: domain decomposition not define "//&
|
|
& " in mpp strcuture "//TRIM(td_mpp%c_name))
|
|
|
|
ELSE
|
|
|
|
! check if attribute already in mpp structure
|
|
il_attid=0
|
|
IF( ASSOCIATED(td_mpp%t_proc(1)%t_att) )THEN
|
|
il_attid=att_get_index( td_mpp%t_proc(1)%t_att(:), &
|
|
& td_att%c_name )
|
|
ENDIF
|
|
IF( il_attid == 0 )THEN
|
|
CALL logger_warn( &
|
|
& "MPP DEL VAR: no attribute "//TRIM(td_att%c_name)//&
|
|
& ", in mpp structure "//TRIM(td_mpp%c_name) )
|
|
|
|
IF( ASSOCIATED(td_mpp%t_proc(1)%t_att) )THEN
|
|
DO ji=1,td_mpp%t_proc(1)%i_natt
|
|
CALL logger_debug( "MPP DEL ATT: in mpp structure : &
|
|
& attribute : "//TRIM(td_mpp%t_proc(1)%t_att(ji)%c_name) )
|
|
ENDDO
|
|
ENDIF
|
|
|
|
ELSE
|
|
|
|
cl_name=TRIM(td_att%c_name)
|
|
CALL logger_debug( "MPP DEL ATT: delete in mpp structure : &
|
|
& attribute : "//TRIM(cl_name) )
|
|
DO ji=1,td_mpp%i_nproc
|
|
CALL file_del_att(td_mpp%t_proc(ji), TRIM(cl_name))
|
|
ENDDO
|
|
|
|
ENDIF
|
|
ENDIF
|
|
|
|
END SUBROUTINE mpp__del_att_str
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
SUBROUTINE mpp__del_att_name(td_mpp, cd_name)
|
|
!-------------------------------------------------------------------
|
|
!> @brief
|
|
!> This subroutine delete attribute in mpp structure, given attribute name.
|
|
!>
|
|
!> @detail
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date November, 2013 - Initial version
|
|
!> @date February, 2015
|
|
!> - define local attribute structure to avoid mistake with pointer
|
|
!> @date January, 2019
|
|
!> - clean attributes structure
|
|
!>
|
|
!> @param[inout] td_mpp mpp strcuture
|
|
!> @param[in] cd_name attribute name
|
|
!-------------------------------------------------------------------
|
|
|
|
IMPLICIT NONE
|
|
|
|
! Argument
|
|
TYPE(TMPP) , INTENT(INOUT) :: td_mpp
|
|
CHARACTER(LEN=*) , INTENT(IN ) :: cd_name
|
|
|
|
! local variable
|
|
INTEGER(i4) :: il_attid
|
|
TYPE(TATT) :: tl_att
|
|
!----------------------------------------------------------------
|
|
|
|
! check if mpp exist
|
|
IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
|
|
|
|
CALL logger_warn( "MPP DEL ATT: domain decomposition not define "//&
|
|
& " in mpp strcuture "//TRIM(td_mpp%c_name))
|
|
|
|
ELSE
|
|
|
|
IF( td_mpp%t_proc(1)%i_natt == 0 )THEN
|
|
CALL logger_debug( "MPP DEL ATT NAME: no attribute associated to mpp &
|
|
& structure "//TRIM(td_mpp%c_name) )
|
|
ELSE
|
|
|
|
! get the attribute id, in file variable structure
|
|
il_attid=0
|
|
IF( ASSOCIATED(td_mpp%t_proc(1)%t_att) )THEN
|
|
il_attid=att_get_id( td_mpp%t_proc(1)%t_att(:), &
|
|
& cd_name )
|
|
ENDIF
|
|
|
|
IF( il_attid == 0 )THEN
|
|
|
|
CALL logger_debug( &
|
|
& "MPP DEL ATT : there is no attribute with "//&
|
|
& "name "//TRIM(cd_name)//" in mpp structure "//&
|
|
& TRIM(td_mpp%c_name))
|
|
|
|
ELSE
|
|
|
|
tl_att=att_copy(td_mpp%t_proc(1)%t_att(il_attid))
|
|
CALL mpp_del_att(td_mpp, tl_att)
|
|
! clean
|
|
CALL att_clean(tl_att)
|
|
ENDIF
|
|
ENDIF
|
|
ENDIF
|
|
|
|
END SUBROUTINE mpp__del_att_name
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
SUBROUTINE mpp_move_att(td_mpp, td_att)
|
|
!-------------------------------------------------------------------
|
|
!> @brief
|
|
!> This subroutine overwrite attribute in mpp structure.
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date November, 2013 - Initial version
|
|
!>
|
|
!> @param[inout] td_mpp mpp strcuture
|
|
!> @param[in] td_att attribute structure
|
|
!-------------------------------------------------------------------
|
|
|
|
IMPLICIT NONE
|
|
|
|
! Argument
|
|
TYPE(TMPP), INTENT(INOUT) :: td_mpp
|
|
TYPE(TATT), INTENT(IN) :: td_att
|
|
|
|
!local variable
|
|
TYPE(TATT) :: tl_att
|
|
!----------------------------------------------------------------
|
|
|
|
! copy variable
|
|
tl_att=att_copy(td_att)
|
|
|
|
! remove processor
|
|
CALL mpp_del_att(td_mpp, tl_att)
|
|
|
|
! add processor
|
|
CALL mpp_add_att(td_mpp, tl_att)
|
|
|
|
! clean
|
|
CALL att_clean(tl_att)
|
|
|
|
END SUBROUTINE mpp_move_att
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
FUNCTION layout__init(td_mpp, id_mask, id_niproc, id_njproc) &
|
|
& RESULT(tf_lay)
|
|
!-------------------------------------------------------------------
|
|
!> @brief
|
|
!> This function initialise domain layout
|
|
!>
|
|
!> @detail
|
|
!> Domain layout is first computed, with domain dimension, overlap between subdomain,
|
|
!> and the number of processors following I and J.
|
|
!> Then the number of sea/land processors is compute with mask
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date October, 2015 - Initial version
|
|
!> @date October, 2016
|
|
!> - compare index to tf_lay number of proc instead of td_mpp (bug fix)
|
|
!>
|
|
!> @param[in] td_mpp mpp strcuture
|
|
!> @param[in] id_mask sub domain mask (sea=1, land=0)
|
|
!> @pâram[in] id_niproc number of processors following I
|
|
!> @pâram[in] id_njproc number of processors following J
|
|
!> @return domain layout structure
|
|
!-------------------------------------------------------------------
|
|
|
|
IMPLICIT NONE
|
|
|
|
! Argument
|
|
TYPE(TMPP) , INTENT(IN) :: td_mpp
|
|
INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_mask
|
|
INTEGER(i4) , INTENT(IN) :: id_niproc
|
|
INTEGER(i4) , INTENT(IN) :: id_njproc
|
|
|
|
! function
|
|
TYPE(TLAY) :: tf_lay
|
|
|
|
! local variable
|
|
INTEGER(i4) :: ii1, ii2
|
|
INTEGER(i4) :: ij1, ij2
|
|
|
|
INTEGER(i4) :: il_ldi
|
|
INTEGER(i4) :: il_ldj
|
|
INTEGER(i4) :: il_lei
|
|
INTEGER(i4) :: il_lej
|
|
|
|
INTEGER(i4) :: il_isize !< i-direction maximum sub domain size
|
|
INTEGER(i4) :: il_jsize !< j-direction maximum sub domain size
|
|
INTEGER(i4) :: il_resti !<
|
|
INTEGER(i4) :: il_restj !<
|
|
|
|
! loop indices
|
|
INTEGER(i4) :: ji
|
|
INTEGER(i4) :: jj
|
|
!----------------------------------------------------------------
|
|
|
|
! intialise
|
|
tf_lay%i_niproc=id_niproc
|
|
tf_lay%i_njproc=id_njproc
|
|
|
|
CALL logger_info( "MPP COMPUTE LAYOUT: compute domain layout with "//&
|
|
& TRIM(fct_str(tf_lay%i_niproc))//" x "//&
|
|
& TRIM(fct_str(tf_lay%i_njproc))//" processors")
|
|
|
|
! maximum size of sub domain
|
|
il_isize = ((td_mpp%t_dim(1)%i_len - 2*td_mpp%i_preci + (tf_lay%i_niproc-1))/ &
|
|
& tf_lay%i_niproc) + 2*td_mpp%i_preci
|
|
il_jsize = ((td_mpp%t_dim(2)%i_len - 2*td_mpp%i_precj + (tf_lay%i_njproc-1))/ &
|
|
& tf_lay%i_njproc) + 2*td_mpp%i_precj
|
|
|
|
il_resti = MOD(td_mpp%t_dim(1)%i_len - 2*td_mpp%i_preci, tf_lay%i_niproc)
|
|
il_restj = MOD(td_mpp%t_dim(2)%i_len - 2*td_mpp%i_precj, tf_lay%i_njproc)
|
|
IF( il_resti == 0 ) il_resti = tf_lay%i_niproc
|
|
IF( il_restj == 0 ) il_restj = tf_lay%i_njproc
|
|
|
|
! compute dimension of each sub domain
|
|
ALLOCATE( tf_lay%i_lci(tf_lay%i_niproc,tf_lay%i_njproc) )
|
|
ALLOCATE( tf_lay%i_lcj(tf_lay%i_niproc,tf_lay%i_njproc) )
|
|
|
|
tf_lay%i_lci( 1 : il_resti , : ) = il_isize
|
|
tf_lay%i_lci( il_resti+1 : tf_lay%i_niproc, : ) = il_isize-1
|
|
|
|
tf_lay%i_lcj( : , 1 : il_restj ) = il_jsize
|
|
tf_lay%i_lcj( : , il_restj+1 : tf_lay%i_njproc) = il_jsize-1
|
|
|
|
! compute first index of each sub domain
|
|
ALLOCATE( tf_lay%i_impp(tf_lay%i_niproc,tf_lay%i_njproc) )
|
|
ALLOCATE( tf_lay%i_jmpp(tf_lay%i_niproc,tf_lay%i_njproc) )
|
|
|
|
tf_lay%i_impp(:,:)=1
|
|
tf_lay%i_jmpp(:,:)=1
|
|
|
|
IF( tf_lay%i_niproc > 1 )THEN
|
|
DO jj=1,tf_lay%i_njproc
|
|
DO ji=2,tf_lay%i_niproc
|
|
tf_lay%i_impp(ji,jj) = tf_lay%i_impp(ji-1,jj) + &
|
|
& tf_lay%i_lci (ji-1,jj) - 2*td_mpp%i_preci
|
|
ENDDO
|
|
ENDDO
|
|
ENDIF
|
|
|
|
IF( tf_lay%i_njproc > 1 )THEN
|
|
DO jj=2,tf_lay%i_njproc
|
|
DO ji=1,tf_lay%i_niproc
|
|
tf_lay%i_jmpp(ji,jj) = tf_lay%i_jmpp(ji,jj-1) + &
|
|
& tf_lay%i_lcj (ji,jj-1) - 2*td_mpp%i_precj
|
|
ENDDO
|
|
ENDDO
|
|
ENDIF
|
|
|
|
ALLOCATE( tf_lay%i_msk(tf_lay%i_niproc,tf_lay%i_njproc) )
|
|
tf_lay%i_msk(:,:)=0
|
|
! init number of sea/land proc
|
|
tf_lay%i_nsea=0
|
|
tf_lay%i_nland=tf_lay%i_njproc*tf_lay%i_niproc
|
|
|
|
! check if processor is land or sea
|
|
DO jj = 1,tf_lay%i_njproc
|
|
DO ji = 1,tf_lay%i_niproc
|
|
|
|
! compute first and last indoor indices
|
|
! west boundary
|
|
IF( ji == 1 )THEN
|
|
il_ldi = 1
|
|
ELSE
|
|
il_ldi = 1 + td_mpp%i_preci
|
|
ENDIF
|
|
|
|
! south boundary
|
|
IF( jj == 1 )THEN
|
|
il_ldj = 1
|
|
ELSE
|
|
il_ldj = 1 + td_mpp%i_precj
|
|
ENDIF
|
|
|
|
! east boundary
|
|
IF( ji == tf_lay%i_niproc )THEN
|
|
il_lei = tf_lay%i_lci(ji,jj)
|
|
ELSE
|
|
il_lei = tf_lay%i_lci(ji,jj) - td_mpp%i_preci
|
|
ENDIF
|
|
|
|
! north boundary
|
|
IF( jj == tf_lay%i_njproc )THEN
|
|
il_lej = tf_lay%i_lcj(ji,jj)
|
|
ELSE
|
|
il_lej = tf_lay%i_lcj(ji,jj) - td_mpp%i_precj
|
|
ENDIF
|
|
|
|
ii1=tf_lay%i_impp(ji,jj) + il_ldi - 1
|
|
ii2=tf_lay%i_impp(ji,jj) + il_lei - 1
|
|
|
|
ij1=tf_lay%i_jmpp(ji,jj) + il_ldj - 1
|
|
ij2=tf_lay%i_jmpp(ji,jj) + il_lej - 1
|
|
|
|
tf_lay%i_msk(ji,jj)=SUM( id_mask(ii1:ii2,ij1:ij2) )
|
|
IF( tf_lay%i_msk(ji,jj) > 0 )THEN ! sea
|
|
tf_lay%i_nsea =tf_lay%i_nsea +1
|
|
tf_lay%i_nland=tf_lay%i_nland-1
|
|
ENDIF
|
|
|
|
ENDDO
|
|
ENDDO
|
|
|
|
CALL logger_info( "MPP COMPUTE LAYOUT: sea proc "//TRIM(fct_str(tf_lay%i_nsea)))
|
|
CALL logger_info( "MPP COMPUTE LAYOUT: land proc "//TRIM(fct_str(tf_lay%i_nland)))
|
|
CALL logger_info( "MPP COMPUTE LAYOUT: sum "//TRIM(fct_str( SUM(tf_lay%i_msk(:,:)))))
|
|
|
|
tf_lay%i_mean= SUM(tf_lay%i_msk(:,:)) / tf_lay%i_nsea
|
|
tf_lay%i_min = MINVAL(tf_lay%i_msk(:,:),tf_lay%i_msk(:,:)/=0)
|
|
tf_lay%i_max = MAXVAL(tf_lay%i_msk(:,:))
|
|
|
|
IF( lm_layout )THEN
|
|
! print info
|
|
WRITE(im_iumout,*) ' '
|
|
WRITE(im_iumout,*) " jpni=",tf_lay%i_niproc ," jpnj=",tf_lay%i_njproc
|
|
WRITE(im_iumout,*) " jpi= ",il_isize," jpj= ",il_jsize
|
|
WRITE(im_iumout,*) " iresti=",td_mpp%i_preci," irestj=",td_mpp%i_precj
|
|
|
|
|
|
WRITE(im_iumout,*) ' nombre de processeurs ',tf_lay%i_niproc*tf_lay%i_njproc
|
|
WRITE(im_iumout,*) ' nombre de processeurs mer ',tf_lay%i_nsea
|
|
WRITE(im_iumout,*) ' nombre de processeurs terre ',tf_lay%i_nland
|
|
WRITE(im_iumout,*) ' moyenne de recouvrement ',tf_lay%i_mean
|
|
WRITE(im_iumout,*) ' minimum de recouvrement ',tf_lay%i_min
|
|
WRITE(im_iumout,*) ' maximum de recouvrement ',tf_lay%i_max
|
|
ENDIF
|
|
|
|
END FUNCTION layout__init
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
SUBROUTINE layout__clean(td_lay)
|
|
!-------------------------------------------------------------------
|
|
!> @brief
|
|
!> This subroutine clean domain layout strcuture.
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date October, 2015 - Initial version
|
|
!> @date January, 2019
|
|
!> - nullify array in layout structure
|
|
!>
|
|
!> @param[inout] td_lay domain layout strcuture
|
|
!-------------------------------------------------------------------
|
|
|
|
IMPLICIT NONE
|
|
|
|
! Argument
|
|
TYPE(TLAY), INTENT(INOUT) :: td_lay
|
|
!----------------------------------------------------------------
|
|
|
|
IF( ASSOCIATED(td_lay%i_msk) )THEN
|
|
DEALLOCATE(td_lay%i_msk)
|
|
NULLIFY(td_lay%i_msk)
|
|
ENDIF
|
|
IF( ASSOCIATED(td_lay%i_impp) )THEN
|
|
DEALLOCATE(td_lay%i_impp)
|
|
NULLIFY(td_lay%i_impp)
|
|
ENDIF
|
|
IF( ASSOCIATED(td_lay%i_jmpp) )THEN
|
|
DEALLOCATE(td_lay%i_jmpp)
|
|
NULLIFY(td_lay%i_jmpp)
|
|
ENDIF
|
|
IF( ASSOCIATED(td_lay%i_lci) )THEN
|
|
DEALLOCATE(td_lay%i_lci)
|
|
NULLIFY(td_lay%i_lci)
|
|
ENDIF
|
|
IF( ASSOCIATED(td_lay%i_lcj) )THEN
|
|
DEALLOCATE(td_lay%i_lcj)
|
|
NULLIFY(td_lay%i_lcj)
|
|
ENDIF
|
|
|
|
td_lay%i_niproc=0
|
|
td_lay%i_njproc=0
|
|
td_lay%i_nland =0
|
|
td_lay%i_nsea =0
|
|
|
|
td_lay%i_mean =0
|
|
td_lay%i_min =0
|
|
td_lay%i_max =0
|
|
|
|
END SUBROUTINE layout__clean
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
FUNCTION layout__copy(td_lay) &
|
|
& RESULT(tf_lay)
|
|
!-------------------------------------------------------------------
|
|
!> @brief
|
|
!> This subroutine copy domain layout structure in another one.
|
|
!>
|
|
!> @warning do not use on the output of a function who create or read a
|
|
!> structure (ex: tl_seg=seg__copy(seg__init()) is forbidden).
|
|
!> This will create memory leaks.
|
|
!> @warning to avoid infinite loop, do not use any function inside
|
|
!> this subroutine
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date October, 2015 - Initial Version
|
|
!>
|
|
!> @param[in] td_lay domain layout structure
|
|
!> @return copy of input domain layout structure
|
|
!-------------------------------------------------------------------
|
|
|
|
IMPLICIT NONE
|
|
|
|
! Argument
|
|
TYPE(TLAY), INTENT(IN) :: td_lay
|
|
! function
|
|
TYPE(TLAY) :: tf_lay
|
|
|
|
! local variable
|
|
INTEGER(i4), DIMENSION(2) :: il_shape
|
|
INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_tmp
|
|
! loop indices
|
|
!----------------------------------------------------------------
|
|
|
|
! copy scalar
|
|
tf_lay%i_niproc = td_lay%i_niproc
|
|
tf_lay%i_njproc = td_lay%i_njproc
|
|
tf_lay%i_nland = td_lay%i_nland
|
|
tf_lay%i_nsea = td_lay%i_nsea
|
|
tf_lay%i_mean = td_lay%i_mean
|
|
tf_lay%i_min = td_lay%i_min
|
|
tf_lay%i_max = td_lay%i_max
|
|
|
|
! copy pointers
|
|
IF( ASSOCIATED(tf_lay%i_msk) )THEN
|
|
DEALLOCATE(tf_lay%i_msk)
|
|
ENDIF
|
|
IF( ASSOCIATED(td_lay%i_msk) )THEN
|
|
il_shape(:)=SHAPE(td_lay%i_msk(:,:))
|
|
ALLOCATE( tf_lay%i_msk(il_shape(jp_I),il_shape(jp_J)) )
|
|
tf_lay%i_msk(:,:)=td_lay%i_msk(:,:)
|
|
ENDIF
|
|
|
|
IF( ASSOCIATED(tf_lay%i_msk) ) DEALLOCATE(tf_lay%i_msk)
|
|
IF( ASSOCIATED(td_lay%i_msk) )THEN
|
|
il_shape(:)=SHAPE(td_lay%i_msk(:,:))
|
|
ALLOCATE(il_tmp(il_shape(jp_I),il_shape(jp_J)))
|
|
il_tmp(:,:)=td_lay%i_msk(:,:)
|
|
|
|
ALLOCATE( tf_lay%i_msk(il_shape(jp_I),il_shape(jp_J)) )
|
|
tf_lay%i_msk(:,:)=il_tmp(:,:)
|
|
|
|
DEALLOCATE(il_tmp)
|
|
ENDIF
|
|
|
|
IF( ASSOCIATED(tf_lay%i_impp) ) DEALLOCATE(tf_lay%i_impp)
|
|
IF( ASSOCIATED(td_lay%i_impp) )THEN
|
|
il_shape(:)=SHAPE(td_lay%i_impp(:,:))
|
|
ALLOCATE(il_tmp(il_shape(jp_I),il_shape(jp_J)))
|
|
il_tmp(:,:)=td_lay%i_impp(:,:)
|
|
|
|
ALLOCATE( tf_lay%i_impp(il_shape(jp_I),il_shape(jp_J)) )
|
|
tf_lay%i_impp(:,:)=il_tmp(:,:)
|
|
|
|
DEALLOCATE(il_tmp)
|
|
ENDIF
|
|
|
|
IF( ASSOCIATED(tf_lay%i_jmpp) ) DEALLOCATE(tf_lay%i_jmpp)
|
|
IF( ASSOCIATED(td_lay%i_jmpp) )THEN
|
|
il_shape(:)=SHAPE(td_lay%i_jmpp(:,:))
|
|
ALLOCATE(il_tmp(il_shape(jp_I),il_shape(jp_J)))
|
|
il_tmp(:,:)=td_lay%i_jmpp(:,:)
|
|
|
|
ALLOCATE( tf_lay%i_jmpp(il_shape(jp_I),il_shape(jp_J)) )
|
|
tf_lay%i_jmpp(:,:)=il_tmp(:,:)
|
|
|
|
DEALLOCATE(il_tmp)
|
|
ENDIF
|
|
|
|
IF( ASSOCIATED(tf_lay%i_lci) ) DEALLOCATE(tf_lay%i_lci)
|
|
IF( ASSOCIATED(td_lay%i_lci) )THEN
|
|
il_shape(:)=SHAPE(td_lay%i_lci(:,:))
|
|
ALLOCATE(il_tmp(il_shape(jp_I),il_shape(jp_J)))
|
|
il_tmp(:,:)=td_lay%i_lci(:,:)
|
|
|
|
ALLOCATE( tf_lay%i_lci(il_shape(jp_I),il_shape(jp_J)) )
|
|
tf_lay%i_lci(:,:)=il_tmp(:,:)
|
|
|
|
DEALLOCATE(il_tmp)
|
|
ENDIF
|
|
|
|
IF( ASSOCIATED(tf_lay%i_lcj) ) DEALLOCATE(tf_lay%i_lcj)
|
|
IF( ASSOCIATED(td_lay%i_lcj) )THEN
|
|
il_shape(:)=SHAPE(td_lay%i_lcj(:,:))
|
|
ALLOCATE(il_tmp(il_shape(jp_I),il_shape(jp_J)))
|
|
il_tmp(:,:)=td_lay%i_lcj(:,:)
|
|
|
|
ALLOCATE( tf_lay%i_lcj(il_shape(jp_I),il_shape(jp_J)) )
|
|
tf_lay%i_lcj(:,:)=il_tmp(:,:)
|
|
|
|
DEALLOCATE(il_tmp)
|
|
ENDIF
|
|
|
|
END FUNCTION layout__copy
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
SUBROUTINE mpp__create_layout(td_mpp, td_lay)
|
|
!-------------------------------------------------------------------
|
|
!> @brief
|
|
!> This subroutine create mpp structure using domain layout
|
|
!>
|
|
!> @detail
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date October, 2015 - Initial version
|
|
!> @date August, 2017
|
|
!> - handle use of domain decomposition for monoproc file
|
|
!>
|
|
!> @param[inout] td_mpp mpp strcuture
|
|
!> @param[in] td_lay domain layout structure
|
|
!-------------------------------------------------------------------
|
|
|
|
IMPLICIT NONE
|
|
|
|
! Argument
|
|
TYPE(TMPP), INTENT(INOUT) :: td_mpp
|
|
TYPE(TLAY), INTENT(IN ) :: td_lay
|
|
|
|
! local variable
|
|
CHARACTER(LEN=lc) :: cl_file
|
|
TYPE(TATT) :: tl_att
|
|
|
|
TYPE(TFILE), DIMENSION(:), ALLOCATABLE :: tl_proc
|
|
|
|
! loop indices
|
|
INTEGER(i4) :: ji
|
|
INTEGER(i4) :: jj
|
|
INTEGER(i4) :: jk
|
|
!----------------------------------------------------------------
|
|
|
|
! intialise
|
|
td_mpp%i_nproc=0
|
|
|
|
CALL logger_debug( "MPP CREATE LAYOUT: create domain decomposition with "//&
|
|
& TRIM(fct_str(td_lay%i_niproc))//" x "//&
|
|
& TRIM(fct_str(td_lay%i_njproc))//" = "//&
|
|
& TRIM(fct_str(td_lay%i_nsea))//" processors")
|
|
|
|
IF( lm_layout )THEN
|
|
WRITE(im_iumout,*) ' choix optimum'
|
|
WRITE(im_iumout,*) ' ============='
|
|
WRITE(im_iumout,*)
|
|
! print info
|
|
WRITE(im_iumout,*) ' '
|
|
WRITE(im_iumout,*) " jpni=",td_lay%i_niproc ," jpnj=",td_lay%i_njproc
|
|
WRITE(im_iumout,*) " iresti=",td_mpp%i_preci," irestj=",td_mpp%i_precj
|
|
|
|
|
|
WRITE(im_iumout,*) ' nombre de processeurs ',td_lay%i_niproc*td_lay%i_njproc
|
|
WRITE(im_iumout,*) ' nombre de processeurs mer ',td_lay%i_nsea
|
|
WRITE(im_iumout,*) ' nombre de processeurs terre ',td_lay%i_nland
|
|
WRITE(im_iumout,*) ' moyenne de recouvrement ',td_lay%i_mean
|
|
WRITE(im_iumout,*) ' minimum de recouvrement ',td_lay%i_min
|
|
WRITE(im_iumout,*) ' maximum de recouvrement ',td_lay%i_max
|
|
ENDIF
|
|
|
|
td_mpp%i_niproc=td_lay%i_niproc
|
|
td_mpp%i_njproc=td_lay%i_njproc
|
|
!td_mpp%i_nproc =td_lay%i_nsea
|
|
|
|
IF( td_mpp%i_niproc*td_mpp%i_njproc == td_lay%i_nsea )THEN
|
|
IF( td_lay%i_nsea == 1 )THEN
|
|
td_mpp%c_dom='full'
|
|
ELSE
|
|
td_mpp%c_dom='nooverlap'
|
|
ENDIF
|
|
ELSE
|
|
td_mpp%c_dom='noextra'
|
|
ENDIF
|
|
|
|
ALLOCATE(tl_proc(td_lay%i_nsea))
|
|
jk=1
|
|
DO jj=1,td_lay%i_njproc
|
|
DO ji=1,td_lay%i_niproc
|
|
|
|
IF( td_lay%i_msk(ji,jj) >= 1 )THEN
|
|
|
|
! get processor file name
|
|
IF( td_mpp%l_usempp )THEN
|
|
cl_file=file_rename(td_mpp%c_name,jk)
|
|
ELSE
|
|
cl_file=TRIM(td_mpp%c_name)
|
|
ENDIF
|
|
! initialise file structure
|
|
tl_proc(jk)=file_init(cl_file,td_mpp%c_type)
|
|
|
|
! procesor id
|
|
tl_proc(jk)%i_pid=jk-1
|
|
|
|
tl_att=att_init("DOMAIN_number",tl_proc(jk)%i_pid)
|
|
CALL file_add_att(tl_proc(jk), tl_att)
|
|
|
|
! processor indices
|
|
tl_proc(jk)%i_iind=ji
|
|
tl_proc(jk)%i_jind=jj
|
|
|
|
! fill processor dimension and first indices
|
|
tl_proc(jk)%i_impp = td_lay%i_impp(ji,jj)
|
|
tl_proc(jk)%i_jmpp = td_lay%i_jmpp(ji,jj)
|
|
|
|
tl_proc(jk)%i_lci = td_lay%i_lci(ji,jj)
|
|
tl_proc(jk)%i_lcj = td_lay%i_lcj(ji,jj)
|
|
|
|
! compute first and last indoor indices
|
|
|
|
! west boundary
|
|
IF( ji == 1 )THEN
|
|
tl_proc(jk)%i_ldi = 1
|
|
tl_proc(jk)%l_ctr = .TRUE.
|
|
ELSE
|
|
tl_proc(jk)%i_ldi = 1 + td_mpp%i_preci
|
|
ENDIF
|
|
|
|
! south boundary
|
|
IF( jj == 1 )THEN
|
|
tl_proc(jk)%i_ldj = 1
|
|
tl_proc(jk)%l_ctr = .TRUE.
|
|
ELSE
|
|
tl_proc(jk)%i_ldj = 1 + td_mpp%i_precj
|
|
ENDIF
|
|
|
|
! east boundary
|
|
IF( ji == td_mpp%i_niproc )THEN
|
|
tl_proc(jk)%i_lei = td_lay%i_lci(ji,jj)
|
|
tl_proc(jk)%l_ctr = .TRUE.
|
|
ELSE
|
|
tl_proc(jk)%i_lei = td_lay%i_lci(ji,jj) - td_mpp%i_preci
|
|
ENDIF
|
|
|
|
! north boundary
|
|
IF( jj == td_mpp%i_njproc )THEN
|
|
tl_proc(jk)%i_lej = td_lay%i_lcj(ji,jj)
|
|
tl_proc(jk)%l_ctr = .TRUE.
|
|
ELSE
|
|
tl_proc(jk)%i_lej = td_lay%i_lcj(ji,jj) - td_mpp%i_precj
|
|
ENDIF
|
|
|
|
! clean
|
|
CALL att_clean(tl_att)
|
|
|
|
! update proc number
|
|
jk=jk+1
|
|
|
|
ENDIF
|
|
ENDDO
|
|
ENDDO
|
|
!
|
|
CALL mpp__add_proc(td_mpp, tl_proc(:))
|
|
DEALLOCATE(tl_proc)
|
|
|
|
END SUBROUTINE mpp__create_layout
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
SUBROUTINE mpp__optimiz(td_mpp, id_mask, id_nproc)
|
|
!-------------------------------------------------------------------
|
|
!> @brief
|
|
!> This subroutine optimize the number of sub domain to be used, given mask.
|
|
!> @details
|
|
!> Actually it get the domain decomposition with the most land
|
|
!> processors removed.
|
|
!> If no land processor could be removed, it get the decomposition with the
|
|
!> most sea processors.
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date November, 2013 - Initial version
|
|
!> @date October, 2015
|
|
!> - improve way to compute domain layout
|
|
!> @date February, 2016
|
|
!> - new criteria for domain layout in case no land proc
|
|
!>
|
|
!> @param[inout] td_mpp mpp strcuture
|
|
!> @param[in] id_mask sub domain mask (sea=1, land=0)
|
|
!> @pram[in] id_nproc maximum number of processor to be used
|
|
!-------------------------------------------------------------------
|
|
|
|
IMPLICIT NONE
|
|
|
|
! Argument
|
|
TYPE(TMPP), INTENT(INOUT) :: td_mpp
|
|
INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_mask
|
|
INTEGER(i4) , INTENT(IN) :: id_nproc
|
|
|
|
! local variable
|
|
TYPE(TLAY) :: tl_lay
|
|
TYPE(TLAY) :: tl_sav
|
|
|
|
REAL(dp) :: dl_min
|
|
REAL(dp) :: dl_max
|
|
REAL(dp) :: dl_ratio
|
|
REAL(dp) :: dl_sav
|
|
|
|
! loop indices
|
|
INTEGER(i4) :: ji
|
|
INTEGER(i4) :: jj
|
|
!----------------------------------------------------------------
|
|
|
|
CALL logger_trace("MPP OPTIMIZ: look for best domain decomposition")
|
|
dl_sav=0
|
|
!
|
|
DO ji=1,id_nproc
|
|
DO jj=1,id_nproc
|
|
|
|
! compute domain layout
|
|
tl_lay=layout__init( td_mpp, id_mask, ji,jj )
|
|
IF( tl_lay%i_nsea <= id_nproc )THEN
|
|
|
|
IF( ASSOCIATED(tl_sav%i_lci) )THEN
|
|
IF( tl_sav%i_nland /= 0 )THEN
|
|
! look for layout with most land proc
|
|
IF( tl_lay%i_nland > tl_sav%i_nland .OR. &
|
|
& ( tl_lay%i_nland == tl_sav%i_nland .AND. &
|
|
& tl_lay%i_min > tl_sav%i_min ) )THEN
|
|
! save optimiz layout
|
|
CALL logger_info("MPP OPTIMIZ:save this decomposition "//&
|
|
& TRIM(fct_str(ji))//"x"//TRIM(fct_str(jj))//"="//&
|
|
& TRIM(fct_str(tl_lay%i_nsea)) )
|
|
|
|
tl_sav=layout__copy(tl_lay)
|
|
ENDIF
|
|
ELSE ! tl_sav%i_nland == 0
|
|
! look for layout with most sea proc
|
|
! and "square" cell
|
|
dl_min=MIN(tl_lay%i_lci(1,1),tl_lay%i_lcj(1,1))
|
|
dl_max=MAX(tl_lay%i_lci(1,1),tl_lay%i_lcj(1,1))
|
|
dl_ratio=dl_min/dl_max
|
|
IF( tl_lay%i_nsea > tl_sav%i_nsea .OR. &
|
|
& ( tl_lay%i_nsea == tl_sav%i_nsea .AND. &
|
|
& dl_ratio > dl_sav ) )THEN
|
|
! save optimiz layout
|
|
CALL logger_info("MPP OPTIMIZ:save this decomposition "//&
|
|
& TRIM(fct_str(ji))//"x"//TRIM(fct_str(jj))//"="//&
|
|
& TRIM(fct_str(tl_lay%i_nsea)) )
|
|
|
|
tl_sav=layout__copy(tl_lay)
|
|
dl_sav=dl_ratio
|
|
ENDIF
|
|
ENDIF
|
|
ELSE
|
|
! init tl_sav
|
|
tl_sav=layout__copy(tl_lay)
|
|
|
|
dl_min=MIN(tl_sav%i_lci(1,1),tl_sav%i_lcj(1,1))
|
|
dl_max=MAX(tl_sav%i_lci(1,1),tl_sav%i_lcj(1,1))
|
|
dl_sav=dl_min/dl_max
|
|
ENDIF
|
|
|
|
ENDIF
|
|
|
|
! clean
|
|
CALL layout__clean( tl_lay )
|
|
|
|
ENDDO
|
|
ENDDO
|
|
|
|
! create mpp domain layout
|
|
CALL mpp__create_layout(td_mpp, tl_sav)
|
|
|
|
! clean
|
|
CALL layout__clean( tl_sav )
|
|
|
|
END SUBROUTINE mpp__optimiz
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
SUBROUTINE mpp__clean_unit(td_mpp)
|
|
!-------------------------------------------------------------------
|
|
!> @brief
|
|
!> This subroutine clean mpp strcuture.
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date November, 2013 - Initial version
|
|
!> @date January, 2019
|
|
!> - nullify file structure inside mpp structure
|
|
!>
|
|
!> @param[inout] td_mpp mpp strcuture
|
|
!-------------------------------------------------------------------
|
|
|
|
IMPLICIT NONE
|
|
|
|
! Argument
|
|
TYPE(TMPP), INTENT(INOUT) :: td_mpp
|
|
|
|
! local variable
|
|
TYPE(TMPP) :: tl_mpp ! empty mpp structure
|
|
|
|
! loop indices
|
|
!----------------------------------------------------------------
|
|
|
|
CALL logger_info( &
|
|
& "MPP CLEAN: reset mpp "//TRIM(td_mpp%c_name) )
|
|
|
|
! del dimension
|
|
IF( td_mpp%i_ndim /= 0 )THEN
|
|
CALL dim_clean( td_mpp%t_dim(:) )
|
|
ENDIF
|
|
|
|
IF( ASSOCIATED(td_mpp%t_proc) )THEN
|
|
! clean array of file processor
|
|
CALL file_clean( td_mpp%t_proc(:) )
|
|
DEALLOCATE(td_mpp%t_proc)
|
|
NULLIFY(td_mpp%t_proc)
|
|
ENDIF
|
|
|
|
! replace by empty structure
|
|
td_mpp=mpp_copy(tl_mpp)
|
|
|
|
END SUBROUTINE mpp__clean_unit
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
!-------------------------------------------------------------------
|
|
!> @brief
|
|
!> This subroutine clean mpp strcuture.
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date November, 2013 - Initial version
|
|
!>
|
|
!> @param[inout] td_mpp mpp strcuture
|
|
!-------------------------------------------------------------------
|
|
SUBROUTINE mpp__clean_arr(td_mpp)
|
|
|
|
IMPLICIT NONE
|
|
! Argument
|
|
TYPE(TMPP), DIMENSION(:), INTENT(INOUT) :: td_mpp
|
|
|
|
! local variable
|
|
! loop indices
|
|
INTEGER(i4) :: ji
|
|
!----------------------------------------------------------------
|
|
|
|
DO ji=SIZE(td_mpp(:)),1,-1
|
|
CALL mpp_clean(td_mpp(ji))
|
|
ENDDO
|
|
|
|
END SUBROUTINE mpp__clean_arr
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
SUBROUTINE mpp__get_use_unit(td_mpp, id_imin, id_imax, id_jmin, id_jmax)
|
|
!-------------------------------------------------------------------
|
|
!> @brief
|
|
!> This subroutine get sub domains which cover "zoom domain".
|
|
!> proc use in "zoom domain"
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date November, 2013 - Initial version
|
|
!>
|
|
!> @param[inout] td_mpp mpp strcuture
|
|
!> @param[in] id_imin i-direction lower indice
|
|
!> @param[in] id_imax i-direction upper indice
|
|
!> @param[in] id_jmin j-direction lower indice
|
|
!> @param[in] id_jmax j-direction upper indice
|
|
!-------------------------------------------------------------------
|
|
|
|
IMPLICIT NONE
|
|
|
|
! Argument
|
|
TYPE(TMPP) , INTENT(INOUT) :: td_mpp
|
|
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
|
|
|
|
! local variable
|
|
LOGICAL :: ll_iuse
|
|
LOGICAL :: ll_juse
|
|
|
|
INTEGER(i4) :: il_imin
|
|
INTEGER(i4) :: il_imax
|
|
INTEGER(i4) :: il_jmin
|
|
INTEGER(i4) :: il_jmax
|
|
|
|
! loop indices
|
|
INTEGER(i4) :: jk
|
|
!----------------------------------------------------------------
|
|
|
|
IF( ASSOCIATED(td_mpp%t_proc) )THEN
|
|
|
|
il_imin=1
|
|
il_imax=td_mpp%t_dim(1)%i_len
|
|
IF( PRESENT(id_imin) ) il_imin=id_imin
|
|
IF( PRESENT(id_imax) ) il_imax=id_imax
|
|
il_jmin=1
|
|
il_jmax=td_mpp%t_dim(2)%i_len
|
|
IF( PRESENT(id_jmin) ) il_jmin=id_jmin
|
|
IF( PRESENT(id_jmax) ) il_jmax=id_jmax
|
|
|
|
! check domain
|
|
IF( il_imin < 1 .OR. il_imin > td_mpp%t_dim(1)%i_len .OR. &
|
|
& il_imax < 1 .OR. il_imax > td_mpp%t_dim(1)%i_len .OR. &
|
|
& il_jmin < 1 .OR. il_jmin > td_mpp%t_dim(2)%i_len .OR. &
|
|
& il_jmax < 1 .OR. il_jmax > td_mpp%t_dim(2)%i_len )THEN
|
|
CALL logger_debug("MPP GET USE: mpp gloabl size "//&
|
|
& TRIM(fct_str(td_mpp%t_dim(1)%i_len))//","//&
|
|
& TRIM(fct_str(td_mpp%t_dim(2)%i_len)))
|
|
CALL logger_debug("MPP GET USE: i-indices "//&
|
|
& TRIM(fct_str(il_imin))//","//TRIM(fct_str(il_imax)))
|
|
CALL logger_debug("MPP GET USE: j-indices "//&
|
|
& TRIM(fct_str(il_jmin))//","//TRIM(fct_str(il_jmax)))
|
|
CALL logger_error("MPP GET USE: invalid indices ")
|
|
ELSE
|
|
td_mpp%t_proc(:)%l_use=.FALSE.
|
|
DO jk=1,td_mpp%i_nproc
|
|
|
|
! check i-direction
|
|
ll_iuse=.FALSE.
|
|
IF( il_imin < il_imax )THEN
|
|
|
|
! not overlap east west boundary
|
|
IF( td_mpp%t_proc(jk)%i_impp + td_mpp%t_proc(jk)%i_lci > &
|
|
& il_imin .AND. &
|
|
& td_mpp%t_proc(jk)%i_impp < il_imax )THEN
|
|
ll_iuse=.TRUE.
|
|
ENDIF
|
|
|
|
ELSEIF( il_imin == il_imax )THEN
|
|
|
|
! east west cyclic
|
|
ll_iuse=.TRUE.
|
|
|
|
ELSE ! il_imin > id_imax
|
|
|
|
! overlap east west boundary
|
|
IF( ( td_mpp%t_proc(jk)%i_impp + td_mpp%t_proc(jk)%i_lci > &
|
|
& il_imin ) &
|
|
& .OR. &
|
|
& ( td_mpp%t_proc(jk)%i_impp < il_imax) )THEN
|
|
ll_iuse=.TRUE.
|
|
ENDIF
|
|
|
|
ENDIF
|
|
|
|
! check j-direction
|
|
ll_juse=.FALSE.
|
|
IF( il_jmin < il_jmax )THEN
|
|
|
|
! not overlap north fold
|
|
IF( td_mpp%t_proc(jk)%i_jmpp + td_mpp%t_proc(jk)%i_lcj > &
|
|
& il_jmin .AND. &
|
|
& td_mpp%t_proc(jk)%i_jmpp < il_jmax )THEN
|
|
ll_juse=.TRUE.
|
|
ENDIF
|
|
|
|
ELSE ! id_jmin >= id_jmax
|
|
|
|
IF( td_mpp%t_proc(jk)%i_jmpp + td_mpp%t_proc(jk)%i_lcj > &
|
|
& il_jmin )THEN
|
|
ll_juse=.TRUE.
|
|
ENDIF
|
|
|
|
ENDIF
|
|
|
|
IF( ll_iuse .AND. ll_juse ) td_mpp%t_proc(jk)%l_use=.TRUE.
|
|
|
|
ENDDO
|
|
ENDIF
|
|
|
|
ELSE
|
|
CALL logger_error("MPP GET USE: mpp decomposition not define.")
|
|
ENDIF
|
|
|
|
END SUBROUTINE mpp__get_use_unit
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
SUBROUTINE mpp_get_contour(td_mpp)
|
|
!-------------------------------------------------------------------
|
|
!> @brief
|
|
!> This subroutine get sub domains which form global domain border.
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date November, 2013 - Initial version
|
|
!>
|
|
!> @param[inout] td_mpp mpp strcuture
|
|
!-------------------------------------------------------------------
|
|
|
|
IMPLICIT NONE
|
|
|
|
! Argument
|
|
TYPE(TMPP), INTENT(INOUT) :: td_mpp
|
|
|
|
! loop indices
|
|
INTEGER(i4) :: jk
|
|
!----------------------------------------------------------------
|
|
|
|
IF( ASSOCIATED(td_mpp%t_proc) )THEN
|
|
|
|
td_mpp%t_proc(:)%l_use = .FALSE.
|
|
DO jk=1,td_mpp%i_nproc
|
|
IF( td_mpp%t_proc(jk)%i_ldi == 1 .OR. &
|
|
& td_mpp%t_proc(jk)%i_ldj == 1 .OR. &
|
|
& td_mpp%t_proc(jk)%i_lei == td_mpp%t_proc(jk)%i_lci .OR. &
|
|
& td_mpp%t_proc(jk)%i_lej == td_mpp%t_proc(jk)%i_lcj )THEN
|
|
|
|
td_mpp%t_proc(jk)%l_use = .TRUE.
|
|
|
|
ENDIF
|
|
ENDDO
|
|
|
|
ELSE
|
|
CALL logger_error("MPP GET CONTOUR: domain decomposition not define.")
|
|
ENDIF
|
|
|
|
END SUBROUTINE mpp_get_contour
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
FUNCTION mpp_get_proc_index(td_mpp, id_procid) &
|
|
& RESULT(if_idx)
|
|
!-------------------------------------------------------------------
|
|
!> @brief
|
|
!> This function return processor indices, without overlap boundary,
|
|
!> given processor id.
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date November, 2013 - Initial version
|
|
!>
|
|
!> @param[in] td_mpp mpp strcuture
|
|
!> @param[in] id_procid processor id
|
|
!> @return array of index (/ i1, i2, j1, j2 /)
|
|
!-------------------------------------------------------------------
|
|
|
|
IMPLICIT NONE
|
|
|
|
! Argument
|
|
TYPE(TMPP) , INTENT(IN) :: td_mpp
|
|
INTEGER(i4), INTENT(IN) :: id_procid
|
|
|
|
! function
|
|
INTEGER(i4), DIMENSION(4) :: if_idx
|
|
|
|
! local variable
|
|
INTEGER(i4) :: il_i1, il_i2
|
|
INTEGER(i4) :: il_j1, il_j2
|
|
!----------------------------------------------------------------
|
|
|
|
IF( ASSOCIATED(td_mpp%t_proc) )THEN
|
|
|
|
IF( TRIM(td_mpp%c_dom) == '' )THEN
|
|
CALL logger_fatal("MPP GET PROC INDEX: decomposition type unknown. "//&
|
|
& "you should ahve run mpp_get_dom before.")
|
|
ENDIF
|
|
|
|
SELECT CASE(TRIM(td_mpp%c_dom))
|
|
CASE('full')
|
|
il_i1 = 1
|
|
il_j1 = 1
|
|
|
|
il_i2 = td_mpp%t_dim(1)%i_len
|
|
il_j2 = td_mpp%t_dim(2)%i_len
|
|
CASE('noextra')
|
|
il_i1 = td_mpp%t_proc(id_procid)%i_impp
|
|
il_j1 = td_mpp%t_proc(id_procid)%i_jmpp
|
|
|
|
il_i2 = il_i1 + td_mpp%t_proc(id_procid)%i_lci - 1
|
|
il_j2 = il_j1 + td_mpp%t_proc(id_procid)%i_lcj - 1
|
|
CASE('nooverlap')
|
|
il_i1 = td_mpp%t_proc(id_procid)%i_impp + &
|
|
& td_mpp%t_proc(id_procid)%i_ldi - 1
|
|
il_j1 = td_mpp%t_proc(id_procid)%i_jmpp + &
|
|
& td_mpp%t_proc(id_procid)%i_ldj - 1
|
|
|
|
il_i2 = td_mpp%t_proc(id_procid)%i_impp + &
|
|
& td_mpp%t_proc(id_procid)%i_lei - 1
|
|
il_j2 = td_mpp%t_proc(id_procid)%i_jmpp + &
|
|
& td_mpp%t_proc(id_procid)%i_lej - 1
|
|
CASE DEFAULT
|
|
CALL logger_error("MPP GET PROC INDEX: invalid "//&
|
|
& "decomposition type.")
|
|
END SELECT
|
|
|
|
if_idx(:)=(/il_i1, il_i2, il_j1, il_j2/)
|
|
|
|
ELSE
|
|
CALL logger_error("MPP GET PROC INDEX: domain decomposition not define.")
|
|
ENDIF
|
|
|
|
END FUNCTION mpp_get_proc_index
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
FUNCTION mpp_get_proc_size(td_mpp, id_procid) &
|
|
& RESULT(if_size)
|
|
!-------------------------------------------------------------------
|
|
!> @brief
|
|
!> This function return processor domain size, depending of domain
|
|
!> decompisition type, given sub domain id.
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date November, 2013 - Initial version
|
|
!>
|
|
!> @param[in] td_mpp mpp strcuture
|
|
!> @param[in] id_procid sub domain id
|
|
!> @return array of index (/ isize, jsize /)
|
|
!-------------------------------------------------------------------
|
|
|
|
IMPLICIT NONE
|
|
|
|
! Argument
|
|
TYPE(TMPP), INTENT(IN) :: td_mpp
|
|
INTEGER(i4), INTENT(IN) :: id_procid
|
|
|
|
! function
|
|
INTEGER(i4), DIMENSION(2) :: if_size
|
|
|
|
! local variable
|
|
INTEGER(i4) :: il_isize
|
|
INTEGER(i4) :: il_jsize
|
|
!----------------------------------------------------------------
|
|
|
|
IF( ASSOCIATED(td_mpp%t_proc) )THEN
|
|
|
|
IF( TRIM(td_mpp%c_dom) == '' )THEN
|
|
CALL logger_fatal("MPP GET PROC SIZE: decomposition type unknown. "//&
|
|
& "you should ahve run mpp_get_dom before.")
|
|
ENDIF
|
|
|
|
SELECT CASE(TRIM(td_mpp%c_dom))
|
|
CASE('full')
|
|
|
|
il_isize = td_mpp%t_dim(1)%i_len
|
|
il_jsize = td_mpp%t_dim(2)%i_len
|
|
|
|
CASE('noextra')
|
|
|
|
il_isize = td_mpp%t_proc(id_procid)%i_lci
|
|
il_jsize = td_mpp%t_proc(id_procid)%i_lcj
|
|
|
|
CASE('nooverlap')
|
|
il_isize = td_mpp%t_proc(id_procid)%i_lei - &
|
|
& td_mpp%t_proc(id_procid)%i_ldi + 1
|
|
il_jsize = td_mpp%t_proc(id_procid)%i_lej - &
|
|
& td_mpp%t_proc(id_procid)%i_ldj + 1
|
|
CASE DEFAULT
|
|
CALL logger_error("MPP GET PROC SIZE: invalid decomposition type : "//&
|
|
& TRIM(td_mpp%c_dom) )
|
|
END SELECT
|
|
|
|
if_size(:)=(/il_isize, il_jsize/)
|
|
|
|
ELSE
|
|
CALL logger_error("MPP GET PROC SIZE: domain decomposition not define.")
|
|
ENDIF
|
|
|
|
END FUNCTION mpp_get_proc_size
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
SUBROUTINE mpp_get_dom(td_mpp)
|
|
!-------------------------------------------------------------------
|
|
!> @brief
|
|
!> This subroutine determine domain decomposition type.
|
|
!> (full, overlap, noverlap)
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date November, 2013 - Initial version
|
|
!>
|
|
!> @param[inout] td_mpp mpp strcuture
|
|
!-------------------------------------------------------------------
|
|
|
|
IMPLICIT NONE
|
|
|
|
! Argument
|
|
TYPE(TMPP), INTENT(INOUT) :: td_mpp
|
|
|
|
! local variable
|
|
INTEGER(i4) :: il_isize
|
|
INTEGER(i4) :: il_jsize
|
|
!----------------------------------------------------------------
|
|
|
|
IF( ASSOCIATED(td_mpp%t_proc) )THEN
|
|
|
|
IF( td_mpp%i_niproc == 0 .AND. td_mpp%i_njproc == 0 )THEN
|
|
CALL logger_info("MPP GET DOM: use indoor indices to get domain "//&
|
|
& "decomposition type.")
|
|
IF((td_mpp%t_proc(1)%t_dim(1)%i_len == &
|
|
& td_mpp%t_proc(1)%i_lei - td_mpp%t_proc(1)%i_ldi + 1) .AND. &
|
|
& (td_mpp%t_proc(1)%t_dim(2)%i_len == &
|
|
& td_mpp%t_proc(1)%i_lej - td_mpp%t_proc(1)%i_ldj + 1) )THEN
|
|
|
|
td_mpp%c_dom='nooverlap'
|
|
|
|
ELSEIF((td_mpp%t_proc(1)%t_dim(1)%i_len == &
|
|
& td_mpp%t_proc(1)%i_lci ) .AND. &
|
|
& (td_mpp%t_proc(1)%t_dim(2)%i_len == &
|
|
& td_mpp%t_proc(1)%i_lcj ) )THEN
|
|
|
|
td_mpp%c_dom='noextra'
|
|
|
|
ELSEIF((td_mpp%t_proc(1)%t_dim(1)%i_len == &
|
|
& td_mpp%t_dim(1)%i_len ) .AND. &
|
|
& (td_mpp%t_proc(1)%t_dim(2)%i_len == &
|
|
& td_mpp%t_dim(2)%i_len ) )THEN
|
|
|
|
td_mpp%c_dom='full'
|
|
|
|
ELSE
|
|
|
|
CALL logger_error("MPP GET DOM: should have been an impossible case")
|
|
|
|
il_isize=td_mpp%t_proc(1)%t_dim(1)%i_len
|
|
il_jsize=td_mpp%t_proc(1)%t_dim(2)%i_len
|
|
CALL logger_debug("MPP GET DOM: proc size "//&
|
|
& TRIM(fct_str(il_isize))//" x "//TRIM(fct_str(il_jsize)) )
|
|
|
|
il_isize=td_mpp%t_proc(1)%i_lei - td_mpp%t_proc(1)%i_ldi + 1
|
|
il_jsize=td_mpp%t_proc(1)%i_lej - td_mpp%t_proc(1)%i_ldj + 1
|
|
CALL logger_debug("MPP GET DOM: no overlap size "//&
|
|
& TRIM(fct_str(il_isize))//" x "//TRIM(fct_str(il_jsize)) )
|
|
|
|
il_isize=td_mpp%t_proc(1)%i_lci
|
|
il_jsize=td_mpp%t_proc(1)%i_lcj
|
|
CALL logger_debug("MPP GET DOM: overlap size "//&
|
|
& TRIM(fct_str(il_isize))//" x "//TRIM(fct_str(il_jsize)) )
|
|
|
|
il_isize=td_mpp%t_dim(1)%i_len
|
|
il_jsize=td_mpp%t_dim(2)%i_len
|
|
CALL logger_debug("MPP GET DOM: full size "//&
|
|
& TRIM(fct_str(il_isize))//" x "//TRIM(fct_str(il_jsize)) )
|
|
|
|
ENDIF
|
|
|
|
ELSE
|
|
|
|
CALL logger_info("MPP GET DOM: use number of processors following "//&
|
|
& "I and J to get domain decomposition type.")
|
|
IF( td_mpp%i_niproc*td_mpp%i_njproc==td_mpp%i_nproc )THEN
|
|
IF( td_mpp%i_nproc == 1 )THEN
|
|
td_mpp%c_dom='full'
|
|
ENDIF
|
|
td_mpp%c_dom='nooverlap'
|
|
ELSE
|
|
td_mpp%c_dom='noextra'
|
|
ENDIF
|
|
|
|
ENDIF
|
|
|
|
ELSE
|
|
CALL logger_error("MPP GET DOM: domain decomposition not define.")
|
|
ENDIF
|
|
|
|
END SUBROUTINE mpp_get_dom
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
FUNCTION mpp__check_var_dim(td_mpp, td_var) &
|
|
& RESULT(lf_check)
|
|
!-------------------------------------------------------------------
|
|
!> @brief This function check if variable and mpp structure use same
|
|
!> dimension.
|
|
!>
|
|
!> @details
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date November, 2013 - Initial Version
|
|
!> @date September 2015
|
|
!> - do not check used dimension here
|
|
!>
|
|
!> @param[in] td_mpp mpp structure
|
|
!> @param[in] td_var variable structure
|
|
!> @return dimension of variable and mpp structure agree (or not)
|
|
!-------------------------------------------------------------------
|
|
|
|
IMPLICIT NONE
|
|
|
|
! Argument
|
|
TYPE(TMPP), INTENT(IN) :: td_mpp
|
|
TYPE(TVAR), INTENT(IN) :: td_var
|
|
|
|
! function
|
|
LOGICAL :: lf_check
|
|
|
|
! local variable
|
|
CHARACTER(LEN=lc) :: cl_dim
|
|
LOGICAL :: ll_error
|
|
LOGICAL :: ll_warn
|
|
|
|
INTEGER(i4) :: il_ind
|
|
|
|
! loop indices
|
|
INTEGER(i4) :: ji
|
|
!----------------------------------------------------------------
|
|
|
|
lf_check=.TRUE.
|
|
|
|
! check used dimension
|
|
ll_error=.FALSE.
|
|
ll_warn=.FALSE.
|
|
DO ji=1,ip_maxdim
|
|
il_ind=dim_get_index( td_mpp%t_dim(:), &
|
|
& TRIM(td_var%t_dim(ji)%c_name), &
|
|
& TRIM(td_var%t_dim(ji)%c_sname))
|
|
IF( il_ind /= 0 )THEN
|
|
IF( td_var%t_dim(ji)%l_use .AND. &
|
|
&td_mpp%t_dim(il_ind)%l_use .AND. &
|
|
&td_var%t_dim(ji)%i_len /= td_mpp%t_dim(il_ind)%i_len )THEN
|
|
IF( INDEX( TRIM(td_var%c_axis), &
|
|
& TRIM(fct_upper(td_var%t_dim(ji)%c_name))) == 0 )THEN
|
|
ll_warn=.TRUE.
|
|
ELSE
|
|
ll_error=.TRUE.
|
|
ENDIF
|
|
ENDIF
|
|
ENDIF
|
|
ENDDO
|
|
|
|
IF( ll_error )THEN
|
|
|
|
cl_dim='(/'
|
|
DO ji = 1, td_mpp%i_ndim
|
|
IF( td_mpp%t_dim(ji)%l_use )THEN
|
|
cl_dim=TRIM(cl_dim)//&
|
|
& TRIM(fct_upper(td_mpp%t_dim(ji)%c_sname))//':'//&
|
|
& TRIM(fct_str(td_mpp%t_dim(ji)%i_len))//','
|
|
ENDIF
|
|
ENDDO
|
|
cl_dim=TRIM(cl_dim)//'/)'
|
|
CALL logger_debug( " mpp dimension: "//TRIM(cl_dim) )
|
|
|
|
cl_dim='(/'
|
|
DO ji = 1, td_var%i_ndim
|
|
IF( td_var%t_dim(ji)%l_use )THEN
|
|
cl_dim=TRIM(cl_dim)//&
|
|
& TRIM(fct_upper(td_var%t_dim(ji)%c_sname))//':'//&
|
|
& TRIM(fct_str(td_var%t_dim(ji)%i_len))//','
|
|
ENDIF
|
|
ENDDO
|
|
cl_dim=TRIM(cl_dim)//'/)'
|
|
CALL logger_debug( " variable dimension: "//TRIM(cl_dim) )
|
|
|
|
lf_check=.FALSE.
|
|
|
|
CALL logger_error( &
|
|
& " MPP CHECK VAR DIM: variable and file dimension differ"//&
|
|
& " for variable "//TRIM(td_var%c_name)//&
|
|
& " and file "//TRIM(td_mpp%c_name))
|
|
|
|
ELSEIF( ll_warn )THEN
|
|
CALL logger_warn( &
|
|
& " MPP CHECK VAR DIM: variable and file dimension differ"//&
|
|
& " for variable "//TRIM(td_var%c_name)//&
|
|
& " and file "//TRIM(td_mpp%c_name)//". you should use"//&
|
|
& " var_check_dim to remove useless dimension.")
|
|
ELSE
|
|
|
|
IF( td_var%i_ndim > td_mpp%i_ndim )THEN
|
|
CALL logger_info("MPP CHECK VAR DIM: variable "//&
|
|
& TRIM(td_var%c_name)//" use more dimension than file "//&
|
|
& TRIM(td_mpp%c_name)//" do until now.")
|
|
ENDIF
|
|
|
|
ENDIF
|
|
|
|
END FUNCTION mpp__check_var_dim
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
FUNCTION mpp_get_index(td_mpp, cd_name) &
|
|
& RESULT(if_idx)
|
|
!-------------------------------------------------------------------
|
|
!> @brief This function return the mpp id, in a array of mpp
|
|
!> structure, given mpp base name.
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date November, 2013 - Initial Version
|
|
!>
|
|
!> @param[in] td_file array of file structure
|
|
!> @param[in] cd_name file name
|
|
!> @return file id in array of file structure (0 if not found)
|
|
!-------------------------------------------------------------------
|
|
|
|
IMPLICIT NONE
|
|
|
|
! Argument
|
|
TYPE(TMPP) , DIMENSION(:), INTENT(IN) :: td_mpp
|
|
CHARACTER(LEN=*), INTENT(IN) :: cd_name
|
|
|
|
! function
|
|
INTEGER(i4) :: if_idx
|
|
|
|
! local variable
|
|
CHARACTER(LEN=lc) :: cl_name
|
|
INTEGER(i4) :: il_size
|
|
|
|
! loop indices
|
|
INTEGER(i4) :: ji
|
|
!----------------------------------------------------------------
|
|
if_idx=0
|
|
il_size=SIZE(td_mpp(:))
|
|
|
|
cl_name=TRIM( file_rename(cd_name) )
|
|
|
|
! check if mpp is in array of mpp structure
|
|
DO ji=1,il_size
|
|
! look for file name
|
|
IF( TRIM(fct_lower(td_mpp(ji)%c_name)) == TRIM(fct_lower(cd_name)) )THEN
|
|
|
|
if_idx=ji
|
|
EXIT
|
|
|
|
ENDIF
|
|
ENDDO
|
|
|
|
END FUNCTION mpp_get_index
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
FUNCTION mpp_recombine_var(td_mpp, cd_name) &
|
|
& RESULT(tf_var)
|
|
!-------------------------------------------------------------------
|
|
!> @brief This function recombine variable splitted in mpp structure.
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date October, 2014 - Initial Version
|
|
!>
|
|
!> @param[in] td_mpp mpp file structure
|
|
!> @param[in] cd_name variable name
|
|
!> @return variable strucutre
|
|
!-------------------------------------------------------------------
|
|
|
|
IMPLICIT NONE
|
|
|
|
! Argument
|
|
TYPE(TMPP) , INTENT(IN) :: td_mpp
|
|
CHARACTER(LEN=*), INTENT(IN) :: cd_name
|
|
! function
|
|
TYPE(TVAR) :: tf_var
|
|
|
|
! local variable
|
|
INTEGER(i4) :: il_varid
|
|
INTEGER(i4) :: il_status
|
|
INTEGER(i4) :: il_i1p
|
|
INTEGER(i4) :: il_i2p
|
|
INTEGER(i4) :: il_j1p
|
|
INTEGER(i4) :: il_j2p
|
|
INTEGER(i4), DIMENSION(4) :: il_ind
|
|
|
|
INTEGER(i4), DIMENSION(ip_maxdim) :: il_strt
|
|
INTEGER(i4), DIMENSION(ip_maxdim) :: il_cnt
|
|
|
|
TYPE(TVAR) :: tl_tmp
|
|
|
|
! loop indices
|
|
INTEGER(i4) :: ji
|
|
INTEGER(i4) :: jk
|
|
!----------------------------------------------------------------
|
|
|
|
il_varid=var_get_index( td_mpp%t_proc(1)%t_var(:), cd_name)
|
|
IF( il_varid /= 0 )THEN
|
|
|
|
tf_var=var_copy(td_mpp%t_proc(1)%t_var(il_varid))
|
|
! Allocate space to hold variable value in structure
|
|
IF( ASSOCIATED(tf_var%d_value) )THEN
|
|
DEALLOCATE(tf_var%d_value)
|
|
ENDIF
|
|
!
|
|
DO ji=1,ip_maxdim
|
|
IF( tf_var%t_dim(ji)%l_use )THEN
|
|
tf_var%t_dim(ji)%i_len=td_mpp%t_dim(ji)%i_len
|
|
ENDIF
|
|
ENDDO
|
|
|
|
ALLOCATE(tf_var%d_value( tf_var%t_dim(1)%i_len, &
|
|
& tf_var%t_dim(2)%i_len, &
|
|
& tf_var%t_dim(3)%i_len, &
|
|
& tf_var%t_dim(4)%i_len),&
|
|
& stat=il_status)
|
|
IF(il_status /= 0 )THEN
|
|
|
|
CALL logger_error( &
|
|
& " MPP RECOMBINE VAR: not enough space to put variable "//&
|
|
& TRIM(tf_var%c_name)//" in variable structure")
|
|
|
|
ENDIF
|
|
|
|
! FillValue by default
|
|
tf_var%d_value(:,:,:,:)=tf_var%d_fill
|
|
|
|
! read processor
|
|
DO jk=1,td_mpp%i_nproc
|
|
IF( td_mpp%t_proc(jk)%l_use )THEN
|
|
! get processor indices
|
|
il_ind(:)=mpp_get_proc_index( td_mpp, jk )
|
|
il_i1p = il_ind(1)
|
|
il_i2p = il_ind(2)
|
|
il_j1p = il_ind(3)
|
|
il_j2p = il_ind(4)
|
|
|
|
il_strt(:)=(/ 1,1,1,1 /)
|
|
|
|
il_cnt(:)=(/ il_i2p-il_i1p+1, &
|
|
& il_j2p-il_j1p+1, &
|
|
& tf_var%t_dim(3)%i_len, &
|
|
& tf_var%t_dim(4)%i_len /)
|
|
|
|
tl_tmp=iom_read_var( td_mpp%t_proc(jk), tf_var%c_name,&
|
|
& il_strt(:), il_cnt(:) )
|
|
|
|
! replace value in output variable structure
|
|
tf_var%d_value( il_i1p : il_i2p, &
|
|
& il_j1p : il_j2p, &
|
|
& :,:) = tl_tmp%d_value(:,:,:,:)
|
|
|
|
! clean
|
|
CALL var_clean(tl_tmp)
|
|
|
|
ENDIF
|
|
ENDDO
|
|
|
|
ELSE
|
|
|
|
CALL logger_error( &
|
|
& " MPP RECOMBINE VAR: there is no variable with "//&
|
|
& "name or standard name"//TRIM(cd_name)//&
|
|
& " in mpp file "//TRIM(td_mpp%c_name))
|
|
ENDIF
|
|
|
|
END FUNCTION mpp_recombine_var
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
SUBROUTINE mpp__read_halo(td_file, td_dimglo)
|
|
!-------------------------------------------------------------------
|
|
!> @brief This subroutine read subdomain indices defined with halo
|
|
!> (NEMO netcdf way)
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date January, 2016 - Initial Version
|
|
!>
|
|
!> @param[inout] td_file mpp structure
|
|
!-------------------------------------------------------------------
|
|
|
|
IMPLICIT NONE
|
|
|
|
! Argument
|
|
TYPE(TFILE) , INTENT(INOUT) :: td_file
|
|
TYPE(TDIM) , DIMENSION(:), INTENT(IN ) :: td_dimglo
|
|
|
|
! local variable
|
|
INTEGER(i4) :: il_attid
|
|
INTEGER(i4) :: il_ifirst
|
|
INTEGER(i4) :: il_jfirst
|
|
INTEGER(i4) :: il_ilast
|
|
INTEGER(i4) :: il_jlast
|
|
INTEGER(i4) :: il_ihalostart
|
|
INTEGER(i4) :: il_jhalostart
|
|
INTEGER(i4) :: il_ihaloend
|
|
INTEGER(i4) :: il_jhaloend
|
|
|
|
CHARACTER(LEN=lc) :: cl_dom
|
|
!----------------------------------------------------------------
|
|
|
|
! DOMAIN_position_first
|
|
il_attid = 0
|
|
IF( ASSOCIATED(td_file%t_att) )THEN
|
|
il_attid=att_get_id( td_file%t_att, "DOMAIN_position_first" )
|
|
ENDIF
|
|
IF( il_attid /= 0 )THEN
|
|
il_ifirst = INT(td_file%t_att(il_attid)%d_value(1))
|
|
il_jfirst = INT(td_file%t_att(il_attid)%d_value(2))
|
|
ELSE
|
|
il_ifirst = 1
|
|
il_jfirst = 1
|
|
ENDIF
|
|
|
|
! DOMAIN_position_last
|
|
il_attid = 0
|
|
IF( ASSOCIATED(td_file%t_att) )THEN
|
|
il_attid=att_get_id( td_file%t_att, "DOMAIN_position_last" )
|
|
ENDIF
|
|
IF( il_attid /= 0 )THEN
|
|
il_ilast = INT(td_file%t_att(il_attid)%d_value(1))
|
|
il_jlast = INT(td_file%t_att(il_attid)%d_value(2))
|
|
ELSE
|
|
il_ilast = td_file%t_dim(1)%i_len
|
|
il_jlast = td_file%t_dim(2)%i_len
|
|
ENDIF
|
|
|
|
! DOMAIN_halo_size_start
|
|
il_attid = 0
|
|
IF( ASSOCIATED(td_file%t_att) )THEN
|
|
il_attid=att_get_id( td_file%t_att, "DOMAIN_halo_size_start" )
|
|
ENDIF
|
|
IF( il_attid /= 0 )THEN
|
|
il_ihalostart = INT(td_file%t_att(il_attid)%d_value(1))
|
|
il_jhalostart = INT(td_file%t_att(il_attid)%d_value(2))
|
|
ELSE
|
|
il_ihalostart = 0
|
|
il_jhalostart = 0
|
|
ENDIF
|
|
|
|
! DOMAIN_halo_size_end
|
|
il_attid = 0
|
|
IF( ASSOCIATED(td_file%t_att) )THEN
|
|
il_attid=att_get_id( td_file%t_att, "DOMAIN_halo_size_end" )
|
|
ENDIF
|
|
IF( il_attid /= 0 )THEN
|
|
il_ihaloend = INT(td_file%t_att(il_attid)%d_value(1))
|
|
il_jhaloend = INT(td_file%t_att(il_attid)%d_value(2))
|
|
ELSE
|
|
il_ihaloend = 0
|
|
il_jhaloend = 0
|
|
ENDIF
|
|
|
|
IF( (td_dimglo(jp_I)%i_len == td_file%t_dim(jp_I)%i_len) .AND. &
|
|
& (td_dimglo(jp_J)%i_len == td_file%t_dim(jp_J)%i_len) )THEN
|
|
cl_dom='full'
|
|
ELSEIF( il_ihalostart == 0 .AND. il_jhalostart == 0 .AND. &
|
|
& il_ihaloend == 0 .AND. il_jhaloend == 0 )THEN
|
|
cl_dom='nooverlap'
|
|
ELSE
|
|
cl_dom='noextra'
|
|
ENDIF
|
|
|
|
SELECT CASE(TRIM(cl_dom))
|
|
CASE('full')
|
|
td_file%i_impp = il_ifirst
|
|
td_file%i_jmpp = il_jfirst
|
|
td_file%i_lci = td_file%t_dim(jp_I)%i_len
|
|
td_file%i_lcj = td_file%t_dim(jp_J)%i_len
|
|
td_file%i_ldi = il_ihalostart + 1
|
|
td_file%i_ldj = il_jhalostart + 1
|
|
td_file%i_lei = td_file%t_dim(jp_I)%i_len - il_ihaloend
|
|
td_file%i_lej = td_file%t_dim(jp_J)%i_len - il_jhaloend
|
|
CASE('noextra')
|
|
td_file%i_impp = il_ifirst
|
|
td_file%i_jmpp = il_jfirst
|
|
td_file%i_lci = td_file%t_dim(jp_I)%i_len
|
|
td_file%i_lcj = td_file%t_dim(jp_J)%i_len
|
|
td_file%i_ldi = il_ihalostart + 1
|
|
td_file%i_ldj = il_jhalostart + 1
|
|
td_file%i_lei = td_file%i_lci - il_ihaloend
|
|
td_file%i_lej = td_file%i_lcj - il_jhaloend
|
|
CASE('nooverlap') !!!?????
|
|
td_file%i_impp = il_ifirst
|
|
td_file%i_jmpp = il_jfirst
|
|
td_file%i_lci = td_file%t_dim(jp_I)%i_len
|
|
td_file%i_lcj = td_file%t_dim(jp_J)%i_len
|
|
td_file%i_ldi = 1
|
|
td_file%i_ldj = 1
|
|
td_file%i_lei = td_file%t_dim(jp_I)%i_len
|
|
td_file%i_lej = td_file%t_dim(jp_J)%i_len
|
|
END SELECT
|
|
|
|
END SUBROUTINE mpp__read_halo
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
SUBROUTINE mpp__compute_halo(td_mpp)
|
|
!-------------------------------------------------------------------
|
|
!> @brief This subroutine compute subdomain indices defined with halo
|
|
!> (NEMO netcdf way)
|
|
!>
|
|
!> @author J.Paul
|
|
!> @date January, 2016 - Initial Version
|
|
!>
|
|
!> @param[inout] td_mpp mpp structure
|
|
!-------------------------------------------------------------------
|
|
|
|
IMPLICIT NONE
|
|
|
|
! Argument
|
|
TYPE(TMPP) , INTENT(INOUT) :: td_mpp
|
|
|
|
! local variable
|
|
INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ifirst
|
|
INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_jfirst
|
|
INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ilast
|
|
INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_jlast
|
|
INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ihalostart
|
|
INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_jhalostart
|
|
INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ihaloend
|
|
INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_jhaloend
|
|
|
|
TYPE(TATT) :: tl_att
|
|
|
|
! loop indices
|
|
INTEGER(i4) :: ji
|
|
!----------------------------------------------------------------
|
|
|
|
ALLOCATE( il_ifirst (td_mpp%i_nproc) )
|
|
ALLOCATE( il_jfirst (td_mpp%i_nproc) )
|
|
|
|
ALLOCATE( il_ilast (td_mpp%i_nproc) )
|
|
ALLOCATE( il_jlast (td_mpp%i_nproc) )
|
|
|
|
ALLOCATE( il_ihalostart(td_mpp%i_nproc) )
|
|
ALLOCATE( il_jhalostart(td_mpp%i_nproc) )
|
|
|
|
ALLOCATE( il_ihaloend (td_mpp%i_nproc) )
|
|
ALLOCATE( il_jhaloend (td_mpp%i_nproc) )
|
|
|
|
SELECT CASE(TRIM(td_mpp%c_dom))
|
|
CASE('full')
|
|
|
|
il_ifirst(:)=td_mpp%t_proc(:)%i_impp
|
|
il_jfirst(:)=td_mpp%t_proc(:)%i_jmpp
|
|
|
|
il_ilast(:)=td_mpp%t_proc(:)%i_impp + td_mpp%t_proc(:)%t_dim(jp_I)%i_len - 1
|
|
il_jlast(:)=td_mpp%t_proc(:)%i_jmpp + td_mpp%t_proc(:)%t_dim(jp_J)%i_len - 1
|
|
|
|
il_ihalostart(:)=td_mpp%t_proc(:)%i_ldi-1
|
|
il_jhalostart(:)=td_mpp%t_proc(:)%i_ldj-1
|
|
|
|
il_ihaloend(:)=td_mpp%t_proc(:)%t_dim(jp_I)%i_len - td_mpp%t_proc(:)%i_lei
|
|
il_jhaloend(:)=td_mpp%t_proc(:)%t_dim(jp_J)%i_len - td_mpp%t_proc(:)%i_lej
|
|
|
|
CASE('noextra')
|
|
|
|
il_ifirst(:)=td_mpp%t_proc(:)%i_impp
|
|
il_jfirst(:)=td_mpp%t_proc(:)%i_jmpp
|
|
|
|
il_ilast(:) =td_mpp%t_proc(:)%i_impp + td_mpp%t_proc(:)%i_lci - 1
|
|
il_jlast(:) =td_mpp%t_proc(:)%i_jmpp + td_mpp%t_proc(:)%i_lcj - 1
|
|
|
|
il_ihalostart(:)=td_mpp%t_proc(:)%i_ldi-1
|
|
il_jhalostart(:)=td_mpp%t_proc(:)%i_ldj-1
|
|
|
|
il_ihaloend(:)=td_mpp%t_proc(:)%i_lci - td_mpp%t_proc(:)%i_lei
|
|
il_jhaloend(:)=td_mpp%t_proc(:)%i_lcj - td_mpp%t_proc(:)%i_lej
|
|
|
|
CASE('nooverlap')
|
|
|
|
il_ifirst(:)=td_mpp%t_proc(:)%i_impp + td_mpp%t_proc(:)%i_ldi - 1
|
|
il_jfirst(:)=td_mpp%t_proc(:)%i_jmpp + td_mpp%t_proc(:)%i_ldj - 1
|
|
|
|
il_ilast(:)=td_mpp%t_proc(:)%i_impp + td_mpp%t_proc(:)%i_lei - 1
|
|
il_jlast(:)=td_mpp%t_proc(:)%i_jmpp + td_mpp%t_proc(:)%i_lej - 1
|
|
|
|
il_ihalostart(:)=0
|
|
il_jhalostart(:)=0
|
|
|
|
il_ihaloend(:)=0
|
|
il_jhaloend(:)=0
|
|
|
|
CASE DEFAULT
|
|
CALL logger_fatal("MPP INIT: invalid "//&
|
|
& "decomposition type.")
|
|
END SELECT
|
|
|
|
DO ji=1,td_mpp%i_nproc
|
|
tl_att=att_init( "DOMAIN_position_first", &
|
|
& (/ il_ifirst(ji), il_jfirst(ji) /) )
|
|
CALL file_move_att(td_mpp%t_proc(ji), tl_att)
|
|
|
|
tl_att=att_init( "DOMAIN_position_last", &
|
|
& (/ il_ilast(ji), il_jlast(ji) /) )
|
|
CALL file_move_att(td_mpp%t_proc(ji), tl_att)
|
|
|
|
tl_att=att_init( "DOMAIN_halo_size_start", &
|
|
& (/ il_ihalostart(ji), il_jhalostart(ji) /) )
|
|
CALL file_move_att( td_mpp%t_proc(ji), tl_att)
|
|
|
|
tl_att=att_init( "DOMAIN_halo_size_end", &
|
|
& (/ il_ihaloend(ji), il_jhaloend(ji) /) )
|
|
CALL file_move_att( td_mpp%t_proc(ji), tl_att)
|
|
ENDDO
|
|
|
|
DEALLOCATE( il_ifirst )
|
|
DEALLOCATE( il_jfirst )
|
|
|
|
DEALLOCATE( il_ilast )
|
|
DEALLOCATE( il_jlast )
|
|
|
|
DEALLOCATE( il_ihalostart)
|
|
DEALLOCATE( il_jhalostart)
|
|
|
|
DEALLOCATE( il_ihaloend )
|
|
DEALLOCATE( il_jhaloend )
|
|
|
|
!impp
|
|
tl_att=att_init( "SUBDOMAIN_I_left_bottom_indices", td_mpp%t_proc(:)%i_impp)
|
|
CALL mpp_move_att(td_mpp, tl_att)
|
|
|
|
tl_att=att_init( "SUBDOMAIN_J_left_bottom_indices", td_mpp%t_proc(:)%i_jmpp)
|
|
CALL mpp_move_att(td_mpp, tl_att)
|
|
|
|
! lci
|
|
tl_att=att_init( "SUBDOMAIN_I_dimensions", td_mpp%t_proc(:)%i_lci)
|
|
CALL mpp_move_att(td_mpp, tl_att)
|
|
|
|
tl_att=att_init( "SUBDOMAIN_J_dimensions", td_mpp%t_proc(:)%i_lcj)
|
|
CALL mpp_move_att(td_mpp, tl_att)
|
|
|
|
! ldi
|
|
tl_att=att_init( "SUBDOMAIN_I_first_indoor_indices", td_mpp%t_proc(:)%i_ldi)
|
|
CALL mpp_move_att(td_mpp, tl_att)
|
|
|
|
tl_att=att_init( "SUBDOMAIN_J_first_indoor_indices", td_mpp%t_proc(:)%i_ldj)
|
|
CALL mpp_move_att(td_mpp, tl_att)
|
|
|
|
! lei
|
|
tl_att=att_init( "SUBDOMAIN_I_last_indoor_indices", td_mpp%t_proc(:)%i_lei)
|
|
CALL mpp_move_att(td_mpp, tl_att)
|
|
|
|
tl_att=att_init( "SUBDOMAIN_J_last_indoor_indices", td_mpp%t_proc(:)%i_lej)
|
|
CALL mpp_move_att(td_mpp, tl_att)
|
|
|
|
! clean
|
|
CALL att_clean(tl_att)
|
|
|
|
END SUBROUTINE mpp__compute_halo
|
|
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
END MODULE mpp
|
|
|