!---------------------------------------------------------------------- ! NEMO system team, System and Interface for oceanic RElocable Nesting !---------------------------------------------------------------------- ! ! MODULE: mpp ! ! DESCRIPTION: !> @brief !> This module manage massively parallel processing. ! !> @details !> define type TMPP:
!> @code !> TYPE(TMPP) :: tl_mpp !> @endcode !> !> to initialise a mpp structure:
!> @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]
!> !> to get mpp name:
!> - tl_mpp\%c_name !> !> to get the total number of processor:
!> - tl_mpp\%i_nproc !> !> to get the number of processor following I-direction:
!> - tl_mpp\%i_niproc !> !> to get the number of processor following J-direction:
!> - tl_mpp\%i_njproc !> !> to get the length of the overlap region following I-direction:
!> - tl_mpp\%i_preci !> !> to get the length of the overlap region following J-direction:
!> - tl_mpp\%i_precj !> !> to get the type of files composing mpp structure:
!> - tl_mpp\%c_type !> !> to get the type of the global domain:
!> - tl_mpp\%c_dom !> !> MPP dimensions (global domain)
!> to get the number of dimensions to be used in mpp strcuture:
!> - tl_mpp\%i_ndim !> !> to get the array of dimension structure (4 elts) associated to the !> mpp structure:
!> - tl_mpp\%t_dim(:) !> !> MPP processor (files composing domain)
!> - tl_mpp\%t_proc(:) !> !> to clean a mpp structure:
!> @code !> CALL mpp_clean(tl_mpp) !> @endcode !> !> to print information about mpp:
!> @code !> CALL mpp_print(tl_mpp) !> @endcode !> !> to add variable to mpp:
!> @code !> CALL mpp_add_var(td_mpp, td_var) !> @endcode !> - td_var is a variable structure !> !> to add dimension to mpp:
!> @code !> CALL mpp_add_dim(td_mpp, td_dim) !> @endcode !> - td_dim is a dimension structure !> !> to add attribute to mpp:
!> @code !> CALL mpp_add_att(td_mpp, td_att) !> @endcode !> - td_att is a attribute structure !> !> to delete variable from mpp:
!> @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:
!> @code !> CALL mpp_del_dim(td_mpp, td_dim) !> @endcode !> - td_dim is a dimension structure !> !> to delete attribute from mpp:
!> @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:
!> @code !> CALL mpp_move_var(td_mpp, td_var) !> @endcode !> - td_var is a variable structure !> !> to overwrite dimension to mpp:
!> @code !> CALL mpp_move_dim(td_mpp, td_dim) !> @endcode !> - td_dim is a dimension structure !> !> to overwrite attribute to mpp:
!> @code !> CALL mpp_move_att(td_mpp, td_att) !> @endcode !> - td_att is a attribute structure !> !> to determine domain decomposition type:
!> @code !> CALL mpp_get_dom(td_mpp) !> @endcode !> !> to get processors to be used:
!> @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:
!> @code !> CALL mpp_get_contour( td_mpp ) !> @endcode !> !> to get global domain indices of one processor:
!> @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:
!> @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 ! REVISION HISTORY: !> @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) !---------------------------------------------------------------------- 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__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 file name 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 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_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 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 !------------------------------------------------------------------- !> @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) ! !> @param[in] td_mpp mpp structure !> @return copy of input mpp structure !------------------------------------------------------------------- FUNCTION mpp__copy_unit( td_mpp ) IMPLICIT NONE ! Argument TYPE(TMPP), INTENT(IN) :: td_mpp ! function TYPE(TMPP) :: mpp__copy_unit ! local variable TYPE(TFILE) :: tl_file ! loop indices INTEGER(i4) :: ji !---------------------------------------------------------------- CALL logger_trace("MPP COPY: "//TRIM(td_mpp%c_name)//" in "//& & TRIM(mpp__copy_unit%c_name)) ! copy mpp variable mpp__copy_unit%c_name = TRIM(td_mpp%c_name) mpp__copy_unit%i_id = td_mpp%i_id mpp__copy_unit%i_niproc = td_mpp%i_niproc mpp__copy_unit%i_njproc = td_mpp%i_njproc mpp__copy_unit%i_nproc = td_mpp%i_nproc mpp__copy_unit%i_preci = td_mpp%i_preci mpp__copy_unit%i_precj = td_mpp%i_precj mpp__copy_unit%c_type = TRIM(td_mpp%c_type) mpp__copy_unit%c_dom = TRIM(td_mpp%c_dom) mpp__copy_unit%i_ndim = td_mpp%i_ndim mpp__copy_unit%i_ew = td_mpp%i_ew mpp__copy_unit%i_perio = td_mpp%i_perio mpp__copy_unit%i_pivot = td_mpp%i_pivot ! copy dimension mpp__copy_unit%t_dim(:) = dim_copy(td_mpp%t_dim(:)) ! copy file structure IF( ASSOCIATED(mpp__copy_unit%t_proc) )THEN CALL file_clean(mpp__copy_unit%t_proc(:)) DEALLOCATE(mpp__copy_unit%t_proc) ENDIF IF( ASSOCIATED(td_mpp%t_proc) .AND. mpp__copy_unit%i_nproc > 0 )THEN ALLOCATE( mpp__copy_unit%t_proc(mpp__copy_unit%i_nproc) ) DO ji=1,mpp__copy_unit%i_nproc tl_file = file_copy(td_mpp%t_proc(ji)) mpp__copy_unit%t_proc(ji) = file_copy(tl_file) ENDDO ! clean CALL file_clean(tl_file) ENDIF END FUNCTION mpp__copy_unit !------------------------------------------------------------------- !> @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 !------------------------------------------------------------------- FUNCTION mpp__copy_arr( td_mpp ) IMPLICIT NONE ! Argument TYPE(TMPP), DIMENSION(:), INTENT(IN) :: td_mpp ! function TYPE(TMPP), DIMENSION(SIZE(td_mpp(:))) :: mpp__copy_arr ! local variable ! loop indices INTEGER(i4) :: ji !---------------------------------------------------------------- DO ji=1,SIZE(td_mpp(:)) mpp__copy_arr(ji)=mpp_copy(td_mpp(ji)) ENDDO END FUNCTION mpp__copy_arr !------------------------------------------------------------------- !> @brief This subroutine print some information about mpp strucutre. ! !> @author J.Paul !> @date November, 2013 - Initial Version ! !> @param[in] td_mpp mpp structure !------------------------------------------------------------------- SUBROUTINE mpp_print(td_mpp) IMPLICIT NONE ! Argument TYPE(TMPP), INTENT(IN) :: td_mpp ! local variable INTEGER(i4), PARAMETER :: il_freq = 4 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 DO ji=1,td_mpp%i_nproc 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%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 DO ji=1,td_mpp%i_nproc 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%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 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)/il_freq+1 jm = MIN(td_mpp%i_niproc, jl+il_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+il_freq ENDDO DEALLOCATE( il_proc ) DEALLOCATE( il_lci ) DEALLOCATE( il_lcj ) ENDIF ELSE WRITE(*,'(/a)') " Domain decomposition : none" ENDIF 9400 FORMAT(' ***',20('*************',a3)) 9403 FORMAT(' * ',20(' * ',a3)) 9401 FORMAT(' ',20(' ',i3,' ')) 9402 FORMAT(' ',i3,' * ',20(i0,' x',i0,' * ')) 9404 FORMAT(' * ',20(' ',i3,' * ')) END SUBROUTINE mpp_print !------------------------------------------------------------------- !> @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 ! !> @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 !------------------------------------------------------------------- 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 ) & & RESULT(td_mpp) 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 ! function TYPE(TMPP) :: td_mpp ! local variable CHARACTER(LEN=lc) :: cl_type INTEGER(i4) , DIMENSION(2) :: il_shape TYPE(TDIM) :: tl_dim TYPE(TATT) :: tl_att TYPE(TLAY) :: tl_lay ! loop indices INTEGER(i4) :: ji !---------------------------------------------------------------- ! clean mpp CALL mpp_clean(td_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') td_mpp%c_type='cdf' CASE('dimg') td_mpp%c_type='dimg' CASE DEFAULT CALL logger_warn( "MPP INIT: type "//TRIM(cd_type)//& & " unknown. type dimg will be used for mpp "//& & TRIM(td_mpp%c_name) ) td_mpp%c_type='dimg' END SELECT ELSE td_mpp%c_type=TRIM(file_get_type(cd_file)) ENDIF ! get mpp name td_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(td_mpp, td_dim(ji)) ENDIF ENDDO ELSE tl_dim=dim_init('X',il_shape(1)) CALL mpp_add_dim(td_mpp, tl_dim) tl_dim=dim_init('Y',il_shape(2)) CALL mpp_add_dim(td_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) ) td_mpp%i_niproc=id_niproc IF( PRESENT(id_njproc) ) td_mpp%i_njproc=id_njproc ENDIF ! get maximum number of processors to be used IF( PRESENT(id_nproc) ) td_mpp%i_nproc = id_nproc ! get overlap region length IF( PRESENT(id_preci) ) td_mpp%i_preci= id_preci IF( PRESENT(id_precj) ) td_mpp%i_precj= id_precj ! east-west overlap IF( PRESENT(id_ew) ) td_mpp%i_ew= id_ew ! NEMO periodicity IF( PRESENT(id_perio) ) td_mpp%i_perio= id_perio IF( PRESENT(id_pivot) ) td_mpp%i_pivot= id_pivot IF( td_mpp%i_nproc /= 0 .AND. & & td_mpp%i_niproc /= 0 .AND. & & td_mpp%i_njproc /= 0 .AND. & & td_mpp%i_nproc > & & td_mpp%i_niproc * td_mpp%i_njproc )THEN CALL logger_error("MPP INIT: invalid domain decomposition ") CALL logger_debug("MPP INIT: "// & & TRIM(fct_str(td_mpp%i_nproc))//" > "//& & TRIM(fct_str(td_mpp%i_niproc))//" x "//& & TRIM(fct_str(td_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( td_mpp%i_niproc /= 0 .AND. & & td_mpp%i_njproc /= 0 )THEN ! compute domain layout tl_lay=layout__init( td_mpp, id_mask, td_mpp%i_niproc, td_mpp%i_njproc ) ! create mpp domain layout CALL mpp__create_layout( td_mpp, tl_lay ) ! clean CALL layout__clean( tl_lay ) ELSEIF( td_mpp%i_nproc /= 0 )THEN ! optimiz CALL mpp__optimiz( td_mpp, id_mask, td_mpp%i_nproc ) ELSE CALL logger_warn("MPP INIT: number of processor to be used "//& & "not specify. force to one.") ! optimiz CALL mpp__optimiz( td_mpp, id_mask, 1 ) ENDIF CALL logger_info("MPP INIT: domain decoposition : "//& & 'niproc('//TRIM(fct_str(td_mpp%i_niproc))//') * '//& & 'njproc('//TRIM(fct_str(td_mpp%i_njproc))//') = '//& & 'nproc('//TRIM(fct_str(td_mpp%i_nproc))//')' ) ! get domain type CALL mpp_get_dom( td_mpp ) DO ji=1,td_mpp%i_nproc ! get processor size il_shape(:)=mpp_get_proc_size( td_mpp, ji ) tl_dim=dim_init('X',il_shape(1)) CALL file_move_dim(td_mpp%t_proc(ji), tl_dim) tl_dim=dim_init('Y',il_shape(2)) CALL file_move_dim(td_mpp%t_proc(ji), tl_dim) IF( PRESENT(td_dim) )THEN IF( td_dim(jp_K)%l_use )THEN CALL file_move_dim(td_mpp%t_proc(ji), td_dim(jp_K)) ENDIF IF( td_dim(jp_L)%l_use )THEN CALL file_move_dim(td_mpp%t_proc(ji), td_dim(jp_L)) ENDIF ENDIF ! add type td_mpp%t_proc(ji)%c_type=TRIM(td_mpp%c_type) ! clean CALL dim_clean(tl_dim) ENDDO ! add global attribute tl_att=att_init("DOMAIN_number_total",td_mpp%i_nproc) CALL mpp_add_att(td_mpp, tl_att) tl_att=att_init("DOMAIN_LOCAL",TRIM(td_mpp%c_dom)) CALL mpp_add_att(td_mpp, tl_att) tl_att=att_init("DOMAIN_I_number_total",td_mpp%i_niproc) CALL mpp_add_att(td_mpp, tl_att) tl_att=att_init("DOMAIN_J_number_total",td_mpp%i_njproc) CALL mpp_add_att(td_mpp, tl_att) tl_att=att_init("DOMAIN_size_global",td_mpp%t_dim(1:2)%i_len) CALL mpp_add_att(td_mpp, tl_att) CALL mpp__compute_halo(td_mpp) ENDIF END FUNCTION mpp__init_mask !------------------------------------------------------------------- !> @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 ! !> @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 !------------------------------------------------------------------- TYPE(TMPP) FUNCTION mpp__init_var( cd_file, td_var, & & id_niproc, id_njproc, id_nproc,& & id_preci, id_precj, cd_type, & & id_perio, id_pivot ) 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 ! 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)) mpp__init_var=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) DEALLOCATE(il_mask) ELSE CALL logger_error("MPP INIT: variable value not define.") ENDIF END FUNCTION mpp__init_var !------------------------------------------------------------------- !> @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 ! !> @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 !------------------------------------------------------------------- TYPE(TMPP) FUNCTION mpp__init_file( td_file, id_ew, id_perio, id_pivot ) 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 ! local variable INTEGER(i4) :: il_nproc INTEGER(i4) :: il_attid INTEGER(i4), DIMENSION(2) :: il_shape 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(mpp__init_file) ! 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 tl_file=file_rename(td_file,ji) ! open file CALL iom_open(tl_file) ! read domain decomposition tl_mpp = mpp__init_file_cdf(tl_file) IF( ji == 1 )THEN mpp__init_file=mpp_copy(tl_mpp) ELSE IF( ANY( mpp__init_file%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(mpp__init_file%c_name)//"differ ") ELSE ! add processor to mpp strcuture CALL mpp__add_proc(mpp__init_file, tl_mpp%t_proc(1)) ENDIF ENDIF ! close file CALL iom_close(tl_file) ENDDO IF( mpp__init_file%i_nproc /= il_nproc )THEN CALL logger_error("MPP INIT READ: some processors can't be added & & to mpp structure") ENDIF ELSE mpp__init_file=mpp_copy(tl_mpp) ENDIF ! mpp type mpp__init_file%c_type=TRIM(td_file%c_type) ! mpp domain type CALL mpp_get_dom(mpp__init_file) ! create some attributes for domain decomposition (use with dimg file) tl_att=att_init( "DOMAIN_number_total", mpp__init_file%i_nproc ) CALL mpp_move_att(mpp__init_file, tl_att) CALL mpp__compute_halo(mpp__init_file) ! 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 mpp__init_file=mpp__init_file_rstdimg(tl_file) ! mpp type mpp__init_file%c_type=TRIM(td_file%c_type) ! mpp domain type CALL logger_debug("MPP INIT READ: mpp_get_dom ") CALL mpp_get_dom(mpp__init_file) ! get processor size CALL logger_debug("MPP INIT READ: get processor size ") DO ji=1,mpp__init_file%i_nproc il_shape(:)=mpp_get_proc_size( mpp__init_file, ji ) tl_dim=dim_init('X',il_shape(1)) CALL file_add_dim(mpp__init_file%t_proc(ji), tl_dim) tl_dim=dim_init('Y',il_shape(2)) CALL file_add_dim(mpp__init_file%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) ) mpp__init_file%i_ew=id_ew ! NEMO periodicity IF( PRESENT(id_perio) )THEN mpp__init_file%i_perio= id_perio SELECT CASE(id_perio) CASE(3,4) mpp__init_file%i_pivot=1 CASE(5,6) mpp__init_file%i_pivot=0 CASE DEFAULT mpp__init_file%i_pivot=1 END SELECT ENDIF IF( PRESENT(id_pivot) ) mpp__init_file%i_pivot= id_pivot ! clean CALL file_clean(tl_file) END FUNCTION mpp__init_file !------------------------------------------------------------------- !> @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 !------------------------------------------------------------------- TYPE(TMPP) FUNCTION mpp__init_file_cdf( td_file ) IMPLICIT NONE ! Argument TYPE(TFILE), INTENT(IN) :: td_file ! 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 mpp__init_file_cdf%c_name=TRIM( file_rename(td_file%c_name) ) ! add type mpp__init_file_cdf%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(mpp__init_file_cdf,tl_dim) tl_dim=dim_init('Y',INT(td_file%t_att(il_attid)%d_value(2))) CALL mpp_add_dim(mpp__init_file_cdf,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(mpp__init_file_cdf,tl_dim) tl_dim=dim_init( td_file%t_dim(2)%c_name, td_file%t_dim(2)%i_len) CALL mpp_add_dim(mpp__init_file_cdf,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(mpp__init_file_cdf,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(mpp__init_file_cdf,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, mpp__init_file_cdf%t_dim(:) ) ! add attributes tl_att=att_init( "DOMAIN_size_global", & & mpp__init_file_cdf%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(mpp__init_file_cdf, 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 !------------------------------------------------------------------- !> @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 !> !> @param[in] td_file file strcuture !> @return mpp structure !------------------------------------------------------------------- TYPE(TMPP) FUNCTION mpp__init_file_rstdimg( td_file ) IMPLICIT NONE ! Argument TYPE(TFILE), INTENT(IN) :: td_file ! 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 mpp__init_file_rstdimg%c_name=TRIM( file_rename(td_file%c_name) ) ! add type mpp__init_file_rstdimg%c_type="dimg" ! number of processors to be read mpp__init_file_rstdimg%i_nproc = il_pnij mpp__init_file_rstdimg%i_niproc = il_pni mpp__init_file_rstdimg%i_njproc = il_pnj IF( ASSOCIATED(mpp__init_file_rstdimg%t_proc) )THEN CALL file_clean(mpp__init_file_rstdimg%t_proc(:)) DEALLOCATE(mpp__init_file_rstdimg%t_proc) ENDIF ALLOCATE( mpp__init_file_rstdimg%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,mpp__init_file_rstdimg%i_nproc mpp__init_file_rstdimg%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 mpp__init_file_rstdimg%t_proc(1:il_pnij)%i_lci = il_lci (1:il_pnij) mpp__init_file_rstdimg%t_proc(1:il_pnij)%i_lcj = il_lcj (1:il_pnij) mpp__init_file_rstdimg%t_proc(1:il_pnij)%i_ldi = il_ldi (1:il_pnij) mpp__init_file_rstdimg%t_proc(1:il_pnij)%i_ldj = il_ldj (1:il_pnij) mpp__init_file_rstdimg%t_proc(1:il_pnij)%i_lei = il_lei (1:il_pnij) mpp__init_file_rstdimg%t_proc(1:il_pnij)%i_lej = il_lej (1:il_pnij) mpp__init_file_rstdimg%t_proc(1:il_pnij)%i_impp= il_impp(1:il_pnij) mpp__init_file_rstdimg%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(mpp__init_file_rstdimg,tl_dim) tl_dim=dim_init('Y',il_jglo) CALL mpp_add_dim(mpp__init_file_rstdimg,tl_dim) tl_dim=dim_init('Z',il_nz) CALL mpp_add_dim(mpp__init_file_rstdimg,tl_dim) DO ji=1,mpp__init_file_rstdimg%i_nproc ! get file name cl_file = file_rename(td_file%c_name,ji) mpp__init_file_rstdimg%t_proc(ji)%c_name = TRIM(cl_file) ! update processor id mpp__init_file_rstdimg%t_proc(ji)%i_pid=ji ! add attributes tl_att=att_init( "DOMAIN_number", ji ) CALL file_move_att(mpp__init_file_rstdimg%t_proc(ji), tl_att) ENDDO ! add type mpp__init_file_rstdimg%t_proc(:)%c_type="dimg" ! add attributes tl_att=att_init( "DOMAIN_size_global", & & mpp__init_file_rstdimg%t_dim(:)%i_len) CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) tl_att=att_init( "DOMAIN_number_total", & & mpp__init_file_rstdimg%i_nproc ) CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) tl_att=att_init( "DOMAIN_I_number_total", & & mpp__init_file_rstdimg%i_niproc ) CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) tl_att=att_init( "DOMAIN_J_number_total", & & mpp__init_file_rstdimg%i_njproc ) CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) CALL mpp_get_dom( mpp__init_file_rstdimg ) CALL mpp__compute_halo( mpp__init_file_rstdimg ) ! clean CALL dim_clean(tl_dim) CALL att_clean(tl_att) 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 !------------------------------------------------------------------- !> @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) !------------------------------------------------------------------- LOGICAL FUNCTION mpp__check_proc_dim(td_mpp, td_proc) IMPLICIT NONE ! Argument TYPE(TMPP), INTENT(IN) :: td_mpp TYPE(TFILE), INTENT(IN) :: td_proc ! local variable INTEGER(i4) :: il_isize !< i-direction maximum sub domain size INTEGER(i4) :: il_jsize !< j-direction maximum sub domain size !---------------------------------------------------------------- mpp__check_proc_dim=.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 mpp__check_proc_dim=.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 mpp__check_proc_dim=.FALSE. CALL logger_error( "MPP CHECK DIM: processor and mpp dimension differ" ) ENDIF ENDIF END FUNCTION mpp__check_proc_dim !------------------------------------------------------------------- !> @brief !> This subroutine add variable in all files of mpp structure. !> !> @author J.Paul !> @date November, 2013 - Initial version ! !> @param[inout] td_mpp mpp strcuture !> @param[in] td_var variable strcuture !------------------------------------------------------------------- SUBROUTINE mpp_add_var( td_mpp, td_var ) 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 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 END SUBROUTINE mpp_add_var !------------------------------------------------------------------- !> @brief This function extract, from variable structure, part that will !> be written in processor id_procid.
! !> @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 !------------------------------------------------------------------- TYPE(TVAR) FUNCTION mpp__split_var(td_mpp, td_var, id_procid) IMPLICIT NONE ! Argument TYPE(TMPP), INTENT(IN) :: td_mpp TYPE(TVAR), INTENT(IN) :: td_var INTEGER(i4), INTENT(IN) :: id_procid ! 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 mpp__split_var=var_copy(td_var) IF( ASSOCIATED(td_var%d_value) )THEN ! remove value over global domain from pointer CALL var_del_value( mpp__split_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( mpp__split_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( mpp__split_var, tl_dim ) ENDIF ! 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 ! add variable value on processor CALL var_add_value( mpp__split_var, & & td_var%d_value(il_i1:il_i2, il_j1:il_j2, :, :) ) ENDIF END FUNCTION mpp__split_var !------------------------------------------------------------------- !> @brief !> This subroutine delete all variable in mpp strcuture. !> !> @author J.Paul !> @date October, 2014 - Initial version !> !> @param[inout] td_mpp mpp strcuture !------------------------------------------------------------------- SUBROUTINE mpp__del_var_mpp( td_mpp ) 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 !------------------------------------------------------------------- !> @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 !------------------------------------------------------------------- SUBROUTINE mpp__del_var_str( td_mpp, td_var ) 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 !------------------------------------------------------------------- !> @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 ! !> @param[inout] td_mpp mpp strcuture !> @param[in] cd_name variable name !------------------------------------------------------------------- SUBROUTINE mpp__del_var_name( td_mpp, cd_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) ENDIF ENDIF ENDIF END SUBROUTINE mpp__del_var_name !------------------------------------------------------------------- !> @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 !------------------------------------------------------------------- SUBROUTINE mpp_move_var( td_mpp, td_var ) 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 !> @endcode !------------------------------------------------------------------- !> @brief !> This subroutine add processor to mpp structure. !> !> @author J.Paul !> @date November, 2013 - Initial version ! !> @param[inout] td_mpp mpp strcuture !> @param[in] td_proc processor strcuture ! !> @todo !> - check proc type !------------------------------------------------------------------- SUBROUTINE mpp__add_proc_unit( td_mpp, td_proc ) 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 CHARACTER(LEN=lc) :: cl_name !---------------------------------------------------------------- ! ALLOCATE(tl_proc(1)) ! tl_proc(1)=file_copy(td_proc) ! ! CALL mpp__add_proc(td_mpp, tl_proc(:)) ! ! CALL file_clean(tl_proc(:)) ! DEALLOCATE(tl_proc) ! 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 il_ind(:)=MINLOC( td_mpp%t_proc(:)%i_pid, & mask=(td_mpp%t_proc(:)%i_pid==td_proc%i_pid) ) il_procid=il_ind(1) 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(:)) DEALLOCATE(tl_proc) ENDIF 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 !------------------------------------------------------------------- !> @brief !> This subroutine delete processor in mpp structure, given processor id. !> !> @author J.Paul !> @date November, 2013 - Initial version !> !> @param[inout] td_mpp mpp strcuture !> @param[in] id_procid processor id !------------------------------------------------------------------- SUBROUTINE mpp__del_proc_id( td_mpp, id_procid ) 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 !------------------------------------------------------------------- !> @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 !------------------------------------------------------------------- SUBROUTINE mpp__del_proc_str( td_mpp, td_proc ) 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 !------------------------------------------------------------------- !> @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 !------------------------------------------------------------------- SUBROUTINE mpp__move_proc( td_mpp, td_proc ) 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 !------------------------------------------------------------------- !> @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 !------------------------------------------------------------------- SUBROUTINE mpp_add_dim(td_mpp, td_dim) 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 !------------------------------------------------------------------- !> @brief This subroutine delete a dimension structure in a mpp !> structure.
!> !> @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 !------------------------------------------------------------------- SUBROUTINE mpp_del_dim(td_mpp, td_dim) 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 !------------------------------------------------------------------- !> @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 !------------------------------------------------------------------- SUBROUTINE mpp_move_dim(td_mpp, td_dim) 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 !------------------------------------------------------------------- !> @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 !------------------------------------------------------------------- SUBROUTINE mpp_add_att( td_mpp, td_att ) 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 !------------------------------------------------------------------- !> @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 !------------------------------------------------------------------- SUBROUTINE mpp__del_att_str( td_mpp, td_att ) 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 !------------------------------------------------------------------- !> @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 ! !> @param[inout] td_mpp mpp strcuture !> @param[in] cd_name attribute name !------------------------------------------------------------------- SUBROUTINE mpp__del_att_name( td_mpp, cd_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) ENDIF ENDIF ENDIF END SUBROUTINE mpp__del_att_name !------------------------------------------------------------------- !> @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 !------------------------------------------------------------------- SUBROUTINE mpp_move_att( td_mpp, td_att ) 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 !------------------------------------------------------------------- !> @brief !> This function initialise domain layout !> !> @detail !> Domain layout is first compute, 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 ! !> @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 !------------------------------------------------------------------- FUNCTION layout__init( td_mpp, id_mask, id_niproc, id_njproc ) RESULT(td_lay) 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) :: td_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 td_lay%i_niproc=id_niproc td_lay%i_njproc=id_njproc CALL logger_info( "MPP COMPUTE LAYOUT: compute domain layout with "//& & TRIM(fct_str(td_lay%i_niproc))//" x "//& & TRIM(fct_str(td_lay%i_njproc))//" processors") ! maximum size of sub domain il_isize = ((td_mpp%t_dim(1)%i_len - 2*td_mpp%i_preci + (td_lay%i_niproc-1))/ & & td_lay%i_niproc) + 2*td_mpp%i_preci il_jsize = ((td_mpp%t_dim(2)%i_len - 2*td_mpp%i_precj + (td_lay%i_njproc-1))/ & & td_lay%i_njproc) + 2*td_mpp%i_precj il_resti = MOD(td_mpp%t_dim(1)%i_len - 2*td_mpp%i_preci, td_lay%i_niproc) il_restj = MOD(td_mpp%t_dim(2)%i_len - 2*td_mpp%i_precj, td_lay%i_njproc) IF( il_resti == 0 ) il_resti = td_lay%i_niproc IF( il_restj == 0 ) il_restj = td_lay%i_njproc ! compute dimension of each sub domain ALLOCATE( td_lay%i_lci(td_lay%i_niproc,td_lay%i_njproc) ) ALLOCATE( td_lay%i_lcj(td_lay%i_niproc,td_lay%i_njproc) ) td_lay%i_lci( 1 : il_resti , : ) = il_isize td_lay%i_lci( il_resti+1 : td_lay%i_niproc, : ) = il_isize-1 td_lay%i_lcj( : , 1 : il_restj ) = il_jsize td_lay%i_lcj( : , il_restj+1 : td_lay%i_njproc) = il_jsize-1 ! compute first index of each sub domain ALLOCATE( td_lay%i_impp(td_lay%i_niproc,td_lay%i_njproc) ) ALLOCATE( td_lay%i_jmpp(td_lay%i_niproc,td_lay%i_njproc) ) td_lay%i_impp(:,:)=1 td_lay%i_jmpp(:,:)=1 IF( td_lay%i_niproc > 1 )THEN DO jj=1,td_lay%i_njproc DO ji=2,td_lay%i_niproc td_lay%i_impp(ji,jj) = td_lay%i_impp(ji-1,jj) + & & td_lay%i_lci (ji-1,jj) - 2*td_mpp%i_preci ENDDO ENDDO ENDIF IF( td_lay%i_njproc > 1 )THEN DO jj=2,td_lay%i_njproc DO ji=1,td_lay%i_niproc td_lay%i_jmpp(ji,jj) = td_lay%i_jmpp(ji,jj-1) + & & td_lay%i_lcj (ji,jj-1) - 2*td_mpp%i_precj ENDDO ENDDO ENDIF ALLOCATE(td_lay%i_msk(td_lay%i_niproc,td_lay%i_njproc)) td_lay%i_msk(:,:)=0 ! init number of sea/land proc td_lay%i_nsea=0 td_lay%i_nland=td_lay%i_njproc*td_lay%i_niproc ! check if processor is land or sea DO jj = 1,td_lay%i_njproc DO ji = 1,td_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 == td_mpp%i_niproc )THEN il_lei = td_lay%i_lci(ji,jj) ELSE il_lei = td_lay%i_lci(ji,jj) - td_mpp%i_preci ENDIF ! north boundary IF( jj == td_mpp%i_njproc )THEN il_lej = td_lay%i_lcj(ji,jj) ELSE il_lej = td_lay%i_lcj(ji,jj) - td_mpp%i_precj ENDIF ii1=td_lay%i_impp(ji,jj) + il_ldi - 1 ii2=td_lay%i_impp(ji,jj) + il_lei - 1 ij1=td_lay%i_jmpp(ji,jj) + il_ldj - 1 ij2=td_lay%i_jmpp(ji,jj) + il_lej - 1 td_lay%i_msk(ji,jj)=SUM( id_mask(ii1:ii2,ij1:ij2) ) IF( td_lay%i_msk(ji,jj) > 0 )THEN ! sea td_lay%i_nsea =td_lay%i_nsea +1 td_lay%i_nland=td_lay%i_nland-1 ENDIF ENDDO ENDDO CALL logger_info( "MPP COMPUTE LAYOUT: sea proc "//TRIM(fct_str(td_lay%i_nsea))) CALL logger_info( "MPP COMPUTE LAYOUT: land proc "//TRIM(fct_str(td_lay%i_nland))) CALL logger_info( "MPP COMPUTE LAYOUT: sum "//TRIM(fct_str( SUM(td_lay%i_msk(:,:))))) td_lay%i_mean= SUM(td_lay%i_msk(:,:)) / td_lay%i_nsea td_lay%i_min = MINVAL(td_lay%i_msk(:,:),td_lay%i_msk(:,:)/=0) td_lay%i_max = MAXVAL(td_lay%i_msk(:,:)) IF( lm_layout )THEN ! print info WRITE(im_iumout,*) ' ' WRITE(im_iumout,*) " jpni=",td_lay%i_niproc ," jpnj=",td_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 ',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 END FUNCTION layout__init !------------------------------------------------------------------- !> @brief !> This subroutine clean domain layout strcuture. !> !> @author J.Paul !> @date October, 2015 - Initial version !> !> @param[inout] td_lay domain layout strcuture !------------------------------------------------------------------- SUBROUTINE layout__clean( td_lay ) IMPLICIT NONE ! Argument TYPE(TLAY), INTENT(INOUT) :: td_lay !---------------------------------------------------------------- IF( ASSOCIATED(td_lay%i_msk) )THEN DEALLOCATE(td_lay%i_msk) ENDIF IF( ASSOCIATED(td_lay%i_impp) )THEN DEALLOCATE(td_lay%i_impp) ENDIF IF( ASSOCIATED(td_lay%i_jmpp) )THEN DEALLOCATE(td_lay%i_jmpp) ENDIF IF( ASSOCIATED(td_lay%i_lci) )THEN DEALLOCATE(td_lay%i_lci) ENDIF IF( ASSOCIATED(td_lay%i_lcj) )THEN DEALLOCATE(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 !------------------------------------------------------------------- !> @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 !------------------------------------------------------------------- FUNCTION layout__copy( td_lay ) IMPLICIT NONE ! Argument TYPE(TLAY), INTENT(IN) :: td_lay ! function TYPE(TLAY) :: layout__copy ! local variable INTEGER(i4), DIMENSION(2) :: il_shape INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_tmp ! loop indices !---------------------------------------------------------------- ! copy scalar layout__copy%i_niproc = td_lay%i_niproc layout__copy%i_njproc = td_lay%i_njproc layout__copy%i_nland = td_lay%i_nland layout__copy%i_nsea = td_lay%i_nsea layout__copy%i_mean = td_lay%i_mean layout__copy%i_min = td_lay%i_min layout__copy%i_max = td_lay%i_max ! copy pointers IF( ASSOCIATED(layout__copy%i_msk) )THEN DEALLOCATE(layout__copy%i_msk) ENDIF IF( ASSOCIATED(td_lay%i_msk) )THEN il_shape(:)=SHAPE(td_lay%i_msk(:,:)) ALLOCATE( layout__copy%i_msk(il_shape(jp_I),il_shape(jp_J)) ) layout__copy%i_msk(:,:)=td_lay%i_msk(:,:) ENDIF IF( ASSOCIATED(layout__copy%i_msk) ) DEALLOCATE(layout__copy%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( layout__copy%i_msk(il_shape(jp_I),il_shape(jp_J)) ) layout__copy%i_msk(:,:)=il_tmp(:,:) DEALLOCATE(il_tmp) ENDIF IF( ASSOCIATED(layout__copy%i_impp) ) DEALLOCATE(layout__copy%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( layout__copy%i_impp(il_shape(jp_I),il_shape(jp_J)) ) layout__copy%i_impp(:,:)=il_tmp(:,:) DEALLOCATE(il_tmp) ENDIF IF( ASSOCIATED(layout__copy%i_jmpp) ) DEALLOCATE(layout__copy%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( layout__copy%i_jmpp(il_shape(jp_I),il_shape(jp_J)) ) layout__copy%i_jmpp(:,:)=il_tmp(:,:) DEALLOCATE(il_tmp) ENDIF IF( ASSOCIATED(layout__copy%i_lci) ) DEALLOCATE(layout__copy%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( layout__copy%i_lci(il_shape(jp_I),il_shape(jp_J)) ) layout__copy%i_lci(:,:)=il_tmp(:,:) DEALLOCATE(il_tmp) ENDIF IF( ASSOCIATED(layout__copy%i_lcj) ) DEALLOCATE(layout__copy%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( layout__copy%i_lcj(il_shape(jp_I),il_shape(jp_J)) ) layout__copy%i_lcj(:,:)=il_tmp(:,:) DEALLOCATE(il_tmp) ENDIF END FUNCTION layout__copy !------------------------------------------------------------------- !> @brief !> This subroutine create mpp structure using domain layout !> !> @detail ! !> @author J.Paul !> @date October, 2015 - Initial version ! !> @param[inout] td_mpp mpp strcuture !> @param[in] td_lay domain layout structure !------------------------------------------------------------------- SUBROUTINE mpp__create_layout( td_mpp, td_lay ) IMPLICIT NONE ! Argument TYPE(TMPP), INTENT(INOUT) :: td_mpp TYPE(TLAY), INTENT(IN ) :: td_lay ! local variable CHARACTER(LEN=lc) :: cl_file TYPE(TFILE) :: tl_proc TYPE(TATT) :: tl_att ! 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 jk=0 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 cl_file=file_rename(td_mpp%c_name,jk) ! initialise file structure tl_proc=file_init(cl_file,td_mpp%c_type) ! procesor id tl_proc%i_pid=jk tl_att=att_init("DOMAIN_number",tl_proc%i_pid) CALL file_add_att(tl_proc, tl_att) ! processor indices tl_proc%i_iind=ji tl_proc%i_jind=jj ! fill processor dimension and first indices tl_proc%i_impp = td_lay%i_impp(ji,jj) tl_proc%i_jmpp = td_lay%i_jmpp(ji,jj) tl_proc%i_lci = td_lay%i_lci(ji,jj) tl_proc%i_lcj = td_lay%i_lcj(ji,jj) ! compute first and last indoor indices ! west boundary IF( ji == 1 )THEN tl_proc%i_ldi = 1 tl_proc%l_ctr = .TRUE. ELSE tl_proc%i_ldi = 1 + td_mpp%i_preci ENDIF ! south boundary IF( jj == 1 )THEN tl_proc%i_ldj = 1 tl_proc%l_ctr = .TRUE. ELSE tl_proc%i_ldj = 1 + td_mpp%i_precj ENDIF ! east boundary IF( ji == td_mpp%i_niproc )THEN tl_proc%i_lei = td_lay%i_lci(ji,jj) tl_proc%l_ctr = .TRUE. ELSE tl_proc%i_lei = td_lay%i_lci(ji,jj) - td_mpp%i_preci ENDIF ! north boundary IF( jj == td_mpp%i_njproc )THEN tl_proc%i_lej = td_lay%i_lcj(ji,jj) tl_proc%l_ctr = .TRUE. ELSE tl_proc%i_lej = td_lay%i_lcj(ji,jj) - td_mpp%i_precj ENDIF ! add processor to mpp structure CALL mpp__add_proc(td_mpp, tl_proc) ! clean CALL att_clean(tl_att) CALL file_clean(tl_proc) ! update proc number jk=jk+1 !ji+(jj-1)*td_lay%i_niproc ENDIF ENDDO ENDDO END SUBROUTINE mpp__create_layout !------------------------------------------------------------------- !> @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 !------------------------------------------------------------------- SUBROUTINE mpp__optimiz( td_mpp, id_mask, id_nproc ) 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 !------------------------------------------------------------------- !> @brief !> This subroutine clean mpp strcuture. !> !> @author J.Paul !> @date November, 2013 - Initial version !> !> @param[inout] td_mpp mpp strcuture !------------------------------------------------------------------- SUBROUTINE mpp__clean_unit( td_mpp ) 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) 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 !------------------------------------------------------------------- !> @brief !> This subroutine get sub domains which cover "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 !------------------------------------------------------------------- SUBROUTINE mpp__get_use_unit( td_mpp, id_imin, id_imax, & & id_jmin, id_jmax ) 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 !------------------------------------------------------------------- !> @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 !------------------------------------------------------------------- SUBROUTINE mpp_get_contour( td_mpp ) 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 !------------------------------------------------------------------- !> @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 /) !------------------------------------------------------------------- FUNCTION mpp_get_proc_index( td_mpp, id_procid ) IMPLICIT NONE ! Argument TYPE(TMPP) , INTENT(IN) :: td_mpp INTEGER(i4), INTENT(IN) :: id_procid ! function INTEGER(i4), DIMENSION(4) :: mpp_get_proc_index ! 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 mpp_get_proc_index(:)=(/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 !------------------------------------------------------------------- !> @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 /) !------------------------------------------------------------------- FUNCTION mpp_get_proc_size( td_mpp, id_procid ) IMPLICIT NONE ! Argument TYPE(TMPP), INTENT(IN) :: td_mpp INTEGER(i4), INTENT(IN) :: id_procid ! function INTEGER(i4), DIMENSION(2) :: mpp_get_proc_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 mpp_get_proc_size(:)=(/il_isize, il_jsize/) ELSE CALL logger_error("MPP GET PROC SIZE: domain decomposition not define.") ENDIF END FUNCTION mpp_get_proc_size !------------------------------------------------------------------- !> @brief !> This subroutine determine domain decomposition type. !> (full, overlap, noverlap) !> !> @author J.Paul !> @date November, 2013 - Initial version !> !> @param[inout] td_mpp mpp strcuture !------------------------------------------------------------------- SUBROUTINE mpp_get_dom( td_mpp ) 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 !------------------------------------------------------------------- !> @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) !------------------------------------------------------------------- LOGICAL FUNCTION mpp__check_var_dim(td_mpp, td_var) IMPLICIT NONE ! Argument TYPE(TMPP), INTENT(IN) :: td_mpp TYPE(TVAR), INTENT(IN) :: td_var ! local variable CHARACTER(LEN=lc) :: cl_dim LOGICAL :: ll_error LOGICAL :: ll_warn INTEGER(i4) :: il_ind ! loop indices INTEGER(i4) :: ji !---------------------------------------------------------------- mpp__check_var_dim=.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) ) mpp__check_var_dim=.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 !------------------------------------------------------------------- !> @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) !------------------------------------------------------------------- INTEGER(i4) FUNCTION mpp_get_index(td_mpp, cd_name) IMPLICIT NONE ! Argument TYPE(TMPP) , DIMENSION(:), INTENT(IN) :: td_mpp CHARACTER(LEN=*), INTENT(IN) :: cd_name ! local variable CHARACTER(LEN=lc) :: cl_name INTEGER(i4) :: il_size ! loop indices INTEGER(i4) :: ji !---------------------------------------------------------------- mpp_get_index=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 mpp_get_index=ji EXIT ENDIF ENDDO END FUNCTION mpp_get_index !------------------------------------------------------------------- !> @brief This function recombine variable splitted mpp structure. ! !> @author J.Paul !> @date Ocotber, 2014 - Initial Version ! !> @param[in] td_mpp mpp file structure !> @param[in] cd_name variable name !> @return variable strucutre !------------------------------------------------------------------- TYPE(TVAR) FUNCTION mpp_recombine_var(td_mpp, cd_name) IMPLICIT NONE ! Argument TYPE(TMPP) , INTENT(IN) :: td_mpp CHARACTER(LEN=*), INTENT(IN) :: cd_name ! 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 TYPE(TVAR) :: tl_var ! 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 tl_var=var_copy(td_mpp%t_proc(1)%t_var(il_varid)) ! Allocate space to hold variable value in structure IF( ASSOCIATED(tl_var%d_value) )THEN DEALLOCATE(tl_var%d_value) ENDIF ! DO ji=1,ip_maxdim IF( tl_var%t_dim(ji)%l_use )THEN tl_var%t_dim(ji)%i_len=td_mpp%t_dim(ji)%i_len ENDIF ENDDO ALLOCATE(tl_var%d_value( tl_var%t_dim(1)%i_len, & & tl_var%t_dim(2)%i_len, & & tl_var%t_dim(3)%i_len, & & tl_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(tl_var%c_name)//" in variable structure") ENDIF ! FillValue by default tl_var%d_value(:,:,:,:)=tl_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, & & tl_var%t_dim(3)%i_len, & & tl_var%t_dim(4)%i_len /) tl_tmp=iom_read_var( td_mpp%t_proc(jk), tl_var%c_name,& & il_strt(:), il_cnt(:) ) ! replace value in output variable structure tl_var%d_value( il_i1p : il_i2p, & & il_j1p : il_j2p, & & :,:) = tl_tmp%d_value(:,:,:,:) ! clean CALL var_clean(tl_tmp) ENDIF ENDDO mpp_recombine_var=var_copy(tl_var) ! clean CALL var_clean(tl_var) 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 !------------------------------------------------------------------- !> @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 !------------------------------------------------------------------- SUBROUTINE mpp__read_halo(td_file, td_dimglo) 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 !------------------------------------------------------------------- !> @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 !------------------------------------------------------------------- SUBROUTINE mpp__compute_halo(td_mpp) 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