!----------------------------------------------------------------------
! NEMO system team, System and Interface for oceanic RElocable Nesting
!----------------------------------------------------------------------
!
! MODULE: mpp
!
!
! DESCRIPTION:
!> This module manage massively parallel processing
!
!> @details
!> define type TMPP:
!> TYPE(TMPP) :: tl_mpp
!>
!> to initialise a mpp structure:
!> - tl_mpp=mpp_init( cd_file, id_mask, [id_niproc,] [id_njproc,]
!> [id_nproc] [id_preci,] [id_precj,] [cd_type])
!> - tl_mpp=mpp_init( cd_file, td_var, [id_niproc,] [id_njproc,]
!> [id_nproc] [id_preci,] [id_precj,] [cd_type])
!> - tl_mpp=mpp_init( td_file )
!> - 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
!> - td_var is a variable structure (on T-point) from global domain file.
!> mask of the domain will be computed using FillValue
!> - 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
!> - id_precj is the size of the overlap region following J-direction
!> - cd_type is the type of files composing MPP
!>
!> 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 table 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:
!> - CALL mpp_clean(tl_mpp)
!>
!> to print information about mpp:
!> CALL mpp_print(tl_mpp)
!>
!> to add variable to mpp:
!> CALL mpp_add_var(td_mpp, td_var)
!> - td_var is a variable structure
!>
!> to add dimension to mpp:
!> CALL mpp_add_dim(td_mpp, td_dim)
!> - td_dim is a dimension structure
!>
!> to delete variable to mpp:
!> CALL mpp_del_var(td_mpp, td_var)
!> - td_var is a variable structure
!>
!> to delete dimension to mpp:
!> CALL mpp_del_dim(td_mpp, td_dim)
!> - td_dim is a dimension structure
!>
!> to overwrite variable to mpp:
!> CALL mpp_move_var(td_mpp, td_var)
!> - td_var is a variable structure
!>
!> to overwrite dimension to mpp:
!> CALL mpp_move_dim(td_mpp, td_dim)
!> - td_dim is a dimension structure
!>
!> to determine domain decomposition type:
!> CALL mpp_get_dom(td_mpp)
!>
!> to get processors to be used:
!> CALL mpp_get_use( td_mpp, td_dom )
!> - td_dom is a domain structure
!>
!> to get sub domains which form global domain contour:
!> CALL mpp_get_contour( td_mpp )
!>
!> to get global domain indices of one processor:
!> il_ind(1:4)=mpp_get_proc_index( td_mpp, id_procid )
!> - il_ind(1:4) are global domain indices (i1,i2,j1,j2)
!> - id_procid is the processor id
!>
!> to get the processor domain size:
!> il_size(1:2)=mpp_get_proc_size( td_mpp, id_procid )
!> - 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 Nov, 2013 - Initial Version
!> @todo
!> - add description generique de l'objet mpp
!> - mpp_print
!> - voir pour mettre cd_file systematiquement pour mpp_init
!> + modifier utilisation la haut
!
!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
!----------------------------------------------------------------------
MODULE mpp
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
! USE proc ! proc manager
USE dom ! domain manager
IMPLICIT NONE
PRIVATE
! NOTE_avoid_public_variables_if_possible
! type and variable
PUBLIC :: TMPP ! mpp structure
! function and subroutine
PUBLIC :: ASSIGNMENT(=) !< 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_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 one proc strucutre in mpp structure
PRIVATE :: mpp__del_proc !< delete one proc strucutre in mpp structure
PRIVATE :: mpp__move_proc !< overwrite proc strucutre in mpp structure
PRIVATE :: mpp__compute !< compute domain decomposition
PRIVATE :: mpp__del_land !< remove land sub domain from domain decomposition
PRIVATE :: mpp__optimiz !< compute optimum domain decomposition
PRIVATE :: mpp__land_proc !< check if processor is a land processor
PRIVATE :: mpp__check_dim !< check mpp structure dimension with proc or variable dimension
PRIVATE :: mpp__del_var_name !< delete variable in mpp structure, given variable name
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 !< copy mpp structure
!> @struct TMPP
TYPE TMPP
! general
CHARACTER(LEN=lc) :: c_name = '' !< base name ???
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
CHARACTER(LEN=lc) :: c_type = '' !< type of the files (cdf, cdf4, dimg)
CHARACTER(LEN=lc) :: c_dom = '' !< type of domain (full, overlap, 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
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
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_read
END INTERFACE mpp_init
INTERFACE ASSIGNMENT(=)
MODULE PROCEDURE mpp__copy ! copy mpp structure
END INTERFACE
CONTAINS
!-------------------------------------------------------------------
!> @brief
!> This subroutine copy mpp structure in another mpp
!> structure
!> @details
!> mpp file are copied in a temporary table,
!> so input and output mpp structure do not point on the same
!> "memory cell", and so on are independant.
!>
!> @author J.Paul
!> - Nov, 2013- Initial Version
!
!> @param[out] td_mpp1 : mpp structure
!> @param[in] td_mpp2 : mpp structure
!-------------------------------------------------------------------
! @code
SUBROUTINE mpp__copy( td_mpp1, td_mpp2 )
IMPLICIT NONE
! Argument
TYPE(TMPP), INTENT(OUT) :: td_mpp1
TYPE(TMPP), INTENT(IN) :: td_mpp2
! loop indices
INTEGER(i4) :: ji
!----------------------------------------------------------------
CALL logger_trace("COPY: mpp "//TRIM(td_mpp2%c_name)//" in "//&
& TRIM(td_mpp1%c_name))
! copy mpp variable
td_mpp1%c_name = TRIM(td_mpp2%c_name)
td_mpp1%i_niproc = td_mpp2%i_niproc
td_mpp1%i_njproc = td_mpp2%i_njproc
td_mpp1%i_nproc = td_mpp2%i_nproc
td_mpp1%i_preci = td_mpp2%i_preci
td_mpp1%i_precj = td_mpp2%i_precj
td_mpp1%c_type = TRIM(td_mpp2%c_type)
td_mpp1%c_dom = TRIM(td_mpp2%c_dom)
td_mpp1%i_ndim = td_mpp2%i_ndim
! copy dimension
td_mpp1%t_dim(:) = td_mpp2%t_dim(:)
! copy file structure
IF( ASSOCIATED(td_mpp1%t_proc) ) DEALLOCATE(td_mpp1%t_proc)
IF( ASSOCIATED(td_mpp2%t_proc) )THEN
ALLOCATE( td_mpp1%t_proc(td_mpp1%i_nproc) )
DO ji=1,td_mpp1%i_nproc
td_mpp1%t_proc(ji) = td_mpp2%t_proc(ji)
ENDDO
ENDIF
END SUBROUTINE mpp__copy
! @endcode
!-------------------------------------------------------------------
!> @brief This subroutine print some information about mpp strucutre.
!
!> @author J.Paul
!> - Nov, 2013- Initial Version
!
!> @param[in] td_mpp : mpp structure
!-------------------------------------------------------------------
! @code
SUBROUTINE mpp_print(td_mpp)
IMPLICIT NONE
! Argument
TYPE(TMPP), INTENT(IN) :: td_mpp
! local variable
INTEGER(i4), PARAMETER :: ip_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),6(/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
! print dimension
IF( td_mpp%i_ndim /= 0 )THEN
WRITE(*,'(/a)') " File 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
!! attribute
!DO jj=1, td_mpp%t_proc(ji)%i_natt
! CALL att_print(td_mpp%t_proc(ji)%t_att(jj))
!ENDDO
ENDDO
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
!! attribute
!DO jj=1, td_mpp%t_proc(ji)%i_natt
! CALL att_print(td_mpp%t_proc(ji)%t_att(jj))
!ENDDO
ENDDO
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) )
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
il_lci(ji,jj)=td_mpp%t_proc(jk)%i_lci
il_lcj(ji,jj)=td_mpp%t_proc(jk)%i_lcj
ENDDO
jl = 1
DO jk = 1,(td_mpp%i_niproc-1)/ip_freq+1
jm = MIN(td_mpp%i_niproc, jl+ip_freq-1)
WRITE(*,*)
WRITE(*,9401) (ji, ji = jl,jm)
WRITE(*,9400) ('***', ji = jl,jm-1)
DO jj = 1, td_mpp%i_njproc
WRITE(*,9403) (' ', ji = jl,jm-1)
WRITE(*,9402) jj, ( il_lci(ji,jj), il_lcj(ji,jj), ji = jl,jm)
WRITE(*,9404) (il_proc(ji,jj), ji= jl,jm)
WRITE(*,9403) (' ', ji = jl,jm-1)
WRITE(*,9400) ('***', ji = jl,jm-1)
ENDDO
jl = jl+ip_freq
ENDDO
DEALLOCATE( il_proc )
DEALLOCATE( il_lci )
DEALLOCATE( il_lcj )
ENDIF
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
! @endcode
!-------------------------------------------------------------------
!> @brief
!> This function initialised mpp structure, given file name, 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 Nov, 2013
!
!> @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)
!> @return mpp structure
!-------------------------------------------------------------------
!> @code
TYPE(TMPP) FUNCTION mpp__init_mask(cd_file, id_mask, &
& id_niproc, id_njproc, id_nproc,&
& id_preci, id_precj, &
cd_type)
IMPLICIT NONE
! Argument
CHARACTER(LEN=*), INTENT(IN) :: cd_file
INTEGER(i4), DIMENSION(:,:), INTENT(IN), OPTIONAL :: 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
! local variable
CHARACTER(LEN=lc) :: cl_type
INTEGER(i4) , DIMENSION(2) :: il_shape
TYPE(TDIM) :: tl_dim
TYPE(TATT) :: tl_att
! loop indices
INTEGER(i4) :: ji
!----------------------------------------------------------------
! clean mpp
CALL mpp_clean(mpp__init_mask)
! get mpp name
mpp__init_mask%c_name=TRIM(file_rename(cd_file))
! 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')
mpp__init_mask%c_type='cdf'
CASE('dimg')
mpp__init_mask%c_type='dimg'
CASE DEFAULT
CALL logger_warn( "MPP INIT: type "//TRIM(cd_type)//&
& " unknown. type dimg will be used for mpp "//&
& TRIM(mpp__init_mask%c_name) )
mpp__init_mask%c_type='dimg'
END SELECT
ELSE
mpp__init_mask%c_type=TRIM(file_get_type(cd_file))
ENDIF
IF( PRESENT(id_mask) )THEN
! get global domain dimension
il_shape(:)=SHAPE(id_mask)
tl_dim=dim_init('X',il_shape(1))
CALL mpp_add_dim(mpp__init_mask, tl_dim)
tl_dim=dim_init('Y',il_shape(2))
CALL mpp_add_dim(mpp__init_mask,tl_dim)
ENDIF
IF( ( PRESENT(id_niproc) .AND. (.NOT. PRESENT(id_niproc))) .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) ) mpp__init_mask%i_niproc=id_niproc
IF( PRESENT(id_njproc) ) mpp__init_mask%i_njproc=id_njproc
ENDIF
! get maximum number of processors to be used
IF( PRESENT(id_nproc) ) mpp__init_mask%i_nproc = id_nproc
! get overlap region length
IF( PRESENT(id_preci) ) mpp__init_mask%i_preci= id_preci
IF( PRESENT(id_precj) ) mpp__init_mask%i_precj= id_precj
IF( mpp__init_mask%i_nproc /= 0 .AND. &
& mpp__init_mask%i_niproc /= 0 .AND. &
& mpp__init_mask%i_njproc /= 0 .AND. &
& mpp__init_mask%i_nproc > &
& mpp__init_mask%i_niproc * mpp__init_mask%i_njproc )THEN
CALL logger_error("MPP INIT: invalid domain decomposition ")
CALL logger_debug("MPP INIT: "// &
& TRIM(fct_str(mpp__init_mask%i_nproc))//" > "//&
& TRIM(fct_str(mpp__init_mask%i_niproc))//" x "//&
& TRIM(fct_str(mpp__init_mask%i_njproc)) )
ELSE
IF( mpp__init_mask%i_niproc /= 0 .AND. mpp__init_mask%i_njproc /= 0 )THEN
! compute domain decomposition
CALL mpp__compute( mpp__init_mask )
! remove land sub domain
CALL mpp__del_land( mpp__init_mask, id_mask )
ELSEIF( mpp__init_mask%i_nproc /= 0 )THEN
! optimiz
CALL mpp__optimiz( mpp__init_mask, id_mask )
ELSE
CALL logger_error("MPP INIT: can't define domain decomposition")
CALL logger_debug ("MPP INIT: maximum number of processor to be used "//&
& "or number of processor following I and J direction must "//&
& "be specified.")
ENDIF
! get domain type
CALL mpp_get_dom( mpp__init_mask )
DO ji=1,mpp__init_mask%i_nproc
! get processor size
il_shape(:)=mpp_get_proc_size( mpp__init_mask, ji )
tl_dim=dim_init('X',il_shape(1))
CALL file_move_dim(mpp__init_mask%t_proc(ji), tl_dim)
tl_dim=dim_init('Y',il_shape(2))
CALL file_move_dim(mpp__init_mask%t_proc(ji), tl_dim)
! add type
mpp__init_mask%t_proc(ji)%c_type=TRIM(mpp__init_mask%c_type)
ENDDO
! add global attribute
tl_att=att_init("DOMAIN_number_total",mpp__init_mask%i_nproc)
CALL mpp_add_att(mpp__init_mask, tl_att)
tl_att=att_init("DOMAIN_I_number_total",mpp__init_mask%i_niproc)
CALL mpp_add_att(mpp__init_mask, tl_att)
tl_att=att_init("DOMAIN_J_number_total",mpp__init_mask%i_njproc)
CALL mpp_add_att(mpp__init_mask, tl_att)
tl_att=att_init("DOMAIN_size_global",mpp__init_mask%t_dim(1:2)%i_len)
CALL mpp_add_att(mpp__init_mask, tl_att)
tl_att=att_init( "DOMAIN_I_position_first", &
& mpp__init_mask%t_proc(:)%i_impp )
CALL mpp_add_att(mpp__init_mask, tl_att)
tl_att=att_init( "DOMAIN_J_position_first", &
& mpp__init_mask%t_proc(:)%i_jmpp )
CALL mpp_add_att(mpp__init_mask, tl_att)
tl_att=att_init( "DOMAIN_I_position_last", &
& mpp__init_mask%t_proc(:)%i_lci )
CALL mpp_add_att(mpp__init_mask, tl_att)
tl_att=att_init( "DOMAIN_J_position_last", &
& mpp__init_mask%t_proc(:)%i_lcj )
CALL mpp_add_att(mpp__init_mask, tl_att)
tl_att=att_init( "DOMAIN_I_halo_size_start", &
& mpp__init_mask%t_proc(:)%i_ldi )
CALL mpp_add_att(mpp__init_mask, tl_att)
tl_att=att_init( "DOMAIN_J_halo_size_start", &
& mpp__init_mask%t_proc(:)%i_ldj )
CALL mpp_add_att(mpp__init_mask, tl_att)
tl_att=att_init( "DOMAIN_I_halo_size_end", &
& mpp__init_mask%t_proc(:)%i_lei )
CALL mpp_add_att(mpp__init_mask, tl_att)
tl_att=att_init( "DOMAIN_J_halo_size_end", &
& mpp__init_mask%t_proc(:)%i_lej )
CALL mpp_add_att(mpp__init_mask, tl_att)
ENDIF
END FUNCTION mpp__init_mask
!> @endcode
!-------------------------------------------------------------------
!> @brief
!> This function initialised mpp structure, given variable strcuture
!> 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 Nov, 2013
!
!> @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)
!> @return mpp structure
!-------------------------------------------------------------------
!> @code
TYPE(TMPP) FUNCTION mpp__init_var( cd_file, td_var, &
& id_niproc, id_njproc, id_nproc,&
& id_preci, id_precj, cd_type )
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
! 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) )
il_mask(:,:)=var_get_mask(td_var)
mpp__init_var=mpp_init( cd_file, il_mask(:,:), &
& id_niproc, id_njproc, id_nproc,&
& id_preci, id_precj, cd_type )
DEALLOCATE(il_mask)
ELSE
CALL logger_error("MPP INIT: variable value not define.")
ENDIF
END FUNCTION mpp__init_var
!> @endcode
!-------------------------------------------------------------------
!> @brief This function initalise a mpp structure,
!> reading one restart dimg file, or some netcdf files.
!
!> @details
!>
!> @warning td_file should be not opened
!>
!> @author J.Paul
!> - Nov, 2013- Initial Version
!
!> @param[in] td_file : file strcuture
!> @return mpp structure
!-------------------------------------------------------------------
! @code
TYPE(TMPP) FUNCTION mpp__init_read( td_file )
IMPLICIT NONE
! Argument
TYPE(TFILE), INTENT(IN) :: td_file
! local variable
TYPE(TMPP) :: tl_mpp
TYPE(TFILE) :: tl_file
TYPE(TDIM) :: tl_dim
TYPE(TATT) :: tl_att
INTEGER(i4) :: il_nproc
INTEGER(i4) :: il_attid
INTEGER(i4), DIMENSION(2) :: il_shape
! loop indices
INTEGER(i4) :: ji
!----------------------------------------------------------------
! clean mpp
CALL mpp_clean(mpp__init_read)
! check file type
SELECT CASE( TRIM(td_file%c_type) )
CASE('cdf')
! need to read all file to get domain decomposition
tl_file=td_file
! open file
CALL iom_open(tl_file)
! read first file domain decomposition
tl_mpp=mpp__init_read_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_read_cdf(tl_file)
IF( ji == 1 )THEN
mpp__init_read=tl_mpp
ELSE
IF( ANY( mpp__init_read%t_dim(1:2)%i_len /= &
tl_mpp%t_dim(1:2)%i_len) )THEN
CALL logger_error("INIT READ: dimension from file "//&
& TRIM(tl_file%c_name)//" and mpp strcuture "//&
& TRIM(mpp__init_read%c_name)//"differ ")
ELSE
! add processor to mpp strcuture
CALL mpp__add_proc(mpp__init_read, tl_mpp%t_proc(1))
ENDIF
ENDIF
! close file
CALL iom_close(tl_file)
ENDDO
IF( mpp__init_read%i_nproc /= il_nproc )THEN
CALL logger_error("INIT READ: some processors can't be added &
& to mpp structure")
ENDIF
ELSE
mpp__init_read=tl_mpp
ENDIF
! mpp type
mpp__init_read%c_type=TRIM(td_file%c_type)
! mpp domain type
CALL mpp_get_dom(mpp__init_read)
! create some attributes for domain decomposition (use with dimg file)
tl_att=att_init( "DOMAIN_number_total", mpp__init_read%i_nproc )
CALL mpp_add_att(mpp__init_read, tl_att)
tl_att=att_init( "DOMAIN_I_position_first", mpp__init_read%t_proc(:)%i_impp )
CALL mpp_add_att(mpp__init_read, tl_att)
tl_att=att_init( "DOMAIN_J_position_first", mpp__init_read%t_proc(:)%i_jmpp )
CALL mpp_add_att(mpp__init_read, tl_att)
tl_att=att_init( "DOMAIN_I_position_last", mpp__init_read%t_proc(:)%i_lci )
CALL mpp_add_att(mpp__init_read, tl_att)
tl_att=att_init( "DOMAIN_J_position_last", mpp__init_read%t_proc(:)%i_lcj )
CALL mpp_add_att(mpp__init_read, tl_att)
tl_att=att_init( "DOMAIN_I_halo_size_start", mpp__init_read%t_proc(:)%i_ldi )
CALL mpp_add_att(mpp__init_read, tl_att)
tl_att=att_init( "DOMAIN_J_halo_size_start", mpp__init_read%t_proc(:)%i_ldj )
CALL mpp_add_att(mpp__init_read, tl_att)
tl_att=att_init( "DOMAIN_I_halo_size_end", mpp__init_read%t_proc(:)%i_lei )
CALL mpp_add_att(mpp__init_read, tl_att)
tl_att=att_init( "DOMAIN_J_halo_size_end", mpp__init_read%t_proc(:)%i_lej )
CALL mpp_add_att(mpp__init_read, tl_att)
CASE('dimg')
! domain decomposition could be read in one file
tl_file=td_file
! open file
CALL iom_open(tl_file)
! read mpp structure
mpp__init_read=mpp__init_read_rstdimg(tl_file)
! mpp type
mpp__init_read%c_type=TRIM(td_file%c_type)
! mpp domain type
CALL mpp_get_dom(mpp__init_read)
! get processor size
DO ji=1,mpp__init_read%i_nproc
il_shape(:)=mpp_get_proc_size( mpp__init_read, ji )
tl_dim=dim_init('X',il_shape(1))
CALL file_add_dim(mpp__init_read%t_proc(ji), tl_dim)
tl_dim=dim_init('Y',il_shape(2))
CALL file_add_dim(mpp__init_read%t_proc(ji), tl_dim)
ENDDO
! close file
CALL iom_close(tl_file)
CASE DEFAULT
CALL logger_error("INIT READ: invalid type for file "//&
& TRIM(tl_file%c_name))
END SELECT
END FUNCTION mpp__init_read
! @endcode
!-------------------------------------------------------------------
!> @brief This function initalise a mpp structure,
!> reading some netcdf files.
!
!> @details
!
!> @author J.Paul
!> - Nov, 2013- Initial Version
!
!> @param[in] td_file : file strcuture
!> @return mpp structure
!-------------------------------------------------------------------
! @code
TYPE(TMPP) FUNCTION mpp__init_read_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(TFILE) :: tl_proc
!----------------------------------------------------------------
CALL logger_trace(" 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("INIT READ: netcdf file "//TRIM(td_file%c_name)//&
& " not opened")
ELSE
! get mpp name
mpp__init_read_cdf%c_name=TRIM( file_rename(td_file%c_name) )
! add type
mpp__init_read_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
mpp__init_read_cdf%t_dim(1)= &
& dim_init('X',INT(td_file%t_att(il_attid)%d_value(1)))
mpp__init_read_cdf%t_dim(2)= &
& dim_init('Y',INT(td_file%t_att(il_attid)%d_value(2)))
ELSE
mpp__init_read_cdf%t_dim(1)= &
& dim_init( td_file%t_dim(1)%c_name, td_file%t_dim(1)%i_len)
mpp__init_read_cdf%t_dim(2)= &
& dim_init( td_file%t_dim(2)%c_name, td_file%t_dim(2)%i_len)
ENDIF
mpp__init_read_cdf%t_dim(3)= &
& dim_init( td_file%t_dim(3)%c_name, td_file%t_dim(1)%i_len)
mpp__init_read_cdf%t_dim(4)= &
& dim_init( td_file%t_dim(4)%c_name, td_file%t_dim(2)%i_len)
! initialise file/processor
tl_proc=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(:)=td_file%t_dim(:)
! 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
tl_proc%i_impp = INT(td_file%t_att(il_attid)%d_value(1))
tl_proc%i_jmpp = INT(td_file%t_att(il_attid)%d_value(2))
ELSE
tl_proc%i_impp = 1
tl_proc%i_jmpp = 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
tl_proc%i_lci = INT(td_file%t_att(il_attid)%d_value(1)) + tl_proc%i_impp
tl_proc%i_lcj = INT(td_file%t_att(il_attid)%d_value(2)) + tl_proc%i_jmpp
ELSE
tl_proc%i_lci = mpp__init_read_cdf%t_dim(1)%i_len
tl_proc%i_lcj = mpp__init_read_cdf%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
tl_proc%i_ldi = INT(td_file%t_att(il_attid)%d_value(1))
tl_proc%i_ldj = INT(td_file%t_att(il_attid)%d_value(2))
ELSE
tl_proc%i_ldi = 1
tl_proc%i_ldj = 1
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
tl_proc%i_lei = INT(td_file%t_att(il_attid)%d_value(1))
tl_proc%i_lej = INT(td_file%t_att(il_attid)%d_value(2))
ELSE
tl_proc%i_lei = mpp__init_read_cdf%t_dim(1)%i_len
tl_proc%i_lej = mpp__init_read_cdf%t_dim(2)%i_len
ENDIF
! add attributes
tl_att=att_init( "DOMAIN_size_global", &
& mpp__init_read_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)
tl_att=att_init( "DOMAIN_position_first", &
& (/tl_proc%i_impp, tl_proc%i_jmpp /) )
CALL file_move_att(tl_proc, tl_att)
tl_att=att_init( "DOMAIN_position_last", &
& (/tl_proc%i_lci, tl_proc%i_lcj /) )
CALL file_move_att(tl_proc, tl_att)
tl_att=att_init( "DOMAIN_halo_size_start", &
& (/tl_proc%i_ldi, tl_proc%i_ldj /) )
CALL file_move_att(tl_proc, tl_att)
tl_att=att_init( "DOMAIN_halo_size_end", &
& (/tl_proc%i_lei, tl_proc%i_lej /) )
CALL file_move_att(tl_proc, tl_att)
! add processor to mpp structure
CALL mpp__add_proc(mpp__init_read_cdf, tl_proc)
ENDIF
ELSE
CALL logger_error("INIT READ: netcdf file "//TRIM(td_file%c_name)//&
& " do not exist")
ENDIF
END FUNCTION mpp__init_read_cdf
! @endcode
!-------------------------------------------------------------------
!> @brief This function initalise a mpp structure,
!> reading one dimg restart file.
!
!> @details
!
!> @author J.Paul
!> - Nov, 2013- Initial Version
!
!> @param[in] td_file : file strcuture
!> @return mpp structure
!-------------------------------------------------------------------
! @code
TYPE(TMPP) FUNCTION mpp__init_read_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
LOGICAL :: ll_exist
LOGICAL :: ll_open
CHARACTER(LEN=lc) :: cl_file
TYPE(TDIM) :: tl_dim ! dimension structure
TYPE(TATT) :: tl_att
! 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("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("INIT READ: read first line header of "//&
& TRIM(td_file%c_name))
ENDIF
! get mpp name
mpp__init_read_rstdimg%c_name=TRIM( file_rename(td_file%c_name) )
! number of processors to be read
mpp__init_read_rstdimg%i_nproc = il_pnij
mpp__init_read_rstdimg%i_niproc = il_pni
mpp__init_read_rstdimg%i_njproc = il_pnj
IF( ASSOCIATED(mpp__init_read_rstdimg%t_proc) )THEN
DEALLOCATE(mpp__init_read_rstdimg%t_proc)
ENDIF
ALLOCATE( mpp__init_read_rstdimg%t_proc(il_pnij) , stat=il_status )
IF( il_status /= 0 )THEN
CALL logger_error("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, &
& mpp__init_read_rstdimg%t_proc(:)%i_lci, &
& mpp__init_read_rstdimg%t_proc(:)%i_lcj, &
& mpp__init_read_rstdimg%t_proc(:)%i_ldi, &
& mpp__init_read_rstdimg%t_proc(:)%i_ldj, &
& mpp__init_read_rstdimg%t_proc(:)%i_lei, &
& mpp__init_read_rstdimg%t_proc(:)%i_lej, &
& mpp__init_read_rstdimg%t_proc(:)%i_impp, &
& mpp__init_read_rstdimg%t_proc(:)%i_jmpp
CALL fct_err(il_status)
IF( il_status /= 0 )THEN
CALL logger_error("INIT READ: read first line of "//&
& TRIM(td_file%c_name))
ENDIF
! mpp dimension
tl_dim=dim_init('X',il_iglo)
CALL mpp_add_dim(mpp__init_read_rstdimg,tl_dim)
tl_dim=dim_init('Y',il_jglo)
CALL mpp_add_dim(mpp__init_read_rstdimg,tl_dim)
DO ji=1,mpp__init_read_rstdimg%i_nproc
! get file name
cl_file = file_rename(td_file%c_name,ji)
mpp__init_read_rstdimg%t_proc(ji)%c_name = TRIM(cl_file)
! update processor id
mpp__init_read_rstdimg%t_proc(ji)%i_pid=ji
! add attributes
tl_att=att_init( "DOMAIN_number", ji )
CALL file_move_att(mpp__init_read_rstdimg%t_proc(ji), tl_att)
tl_att=att_init( "DOMAIN_position_first", &
& (/mpp__init_read_rstdimg%t_proc(ji)%i_impp, &
& mpp__init_read_rstdimg%t_proc(ji)%i_jmpp /) )
CALL file_move_att(mpp__init_read_rstdimg%t_proc(ji), tl_att)
tl_att=att_init( "DOMAIN_position_last", &
& (/mpp__init_read_rstdimg%t_proc(ji)%i_lci, &
& mpp__init_read_rstdimg%t_proc(ji)%i_lcj /) )
CALL file_move_att(mpp__init_read_rstdimg%t_proc(ji), tl_att)
tl_att=att_init( "DOMAIN_halo_size_start", &
& (/mpp__init_read_rstdimg%t_proc(ji)%i_ldi, &
& mpp__init_read_rstdimg%t_proc(ji)%i_ldj /) )
CALL file_move_att(mpp__init_read_rstdimg%t_proc(ji), tl_att)
tl_att=att_init( "DOMAIN_halo_size_end", &
& (/mpp__init_read_rstdimg%t_proc(ji)%i_lei, &
& mpp__init_read_rstdimg%t_proc(ji)%i_lej /) )
CALL file_move_att(mpp__init_read_rstdimg%t_proc(ji), tl_att)
ENDDO
! add type
mpp__init_read_rstdimg%t_proc(:)%c_type="dimg"
! add attributes
tl_att=att_init( "DOMAIN_size_global", &
& mpp__init_read_rstdimg%t_dim(:)%i_len)
CALL mpp_move_att(mpp__init_read_rstdimg, tl_att)
tl_att=att_init( "DOMAIN_number_total", &
& mpp__init_read_rstdimg%i_nproc )
CALL mpp_add_att(mpp__init_read_rstdimg, tl_att)
tl_att=att_init( "DOMAIN_I_number_total", &
& mpp__init_read_rstdimg%i_niproc )
CALL mpp_add_att(mpp__init_read_rstdimg, tl_att)
tl_att=att_init( "DOMAIN_J_number_total", &
& mpp__init_read_rstdimg%i_njproc )
CALL mpp_add_att(mpp__init_read_rstdimg, tl_att)
tl_att=att_init( "DOMAIN_I_position_first", &
& mpp__init_read_rstdimg%t_proc(:)%i_impp )
CALL mpp_add_att(mpp__init_read_rstdimg, tl_att)
tl_att=att_init( "DOMAIN_J_position_first", &
& mpp__init_read_rstdimg%t_proc(:)%i_jmpp )
CALL mpp_add_att(mpp__init_read_rstdimg, tl_att)
tl_att=att_init( "DOMAIN_I_position_last", &
& mpp__init_read_rstdimg%t_proc(:)%i_lci )
CALL mpp_add_att(mpp__init_read_rstdimg, tl_att)
tl_att=att_init( "DOMAIN_J_position_last", &
& mpp__init_read_rstdimg%t_proc(:)%i_lcj )
CALL mpp_add_att(mpp__init_read_rstdimg, tl_att)
tl_att=att_init( "DOMAIN_I_halo_size_start", &
& mpp__init_read_rstdimg%t_proc(:)%i_ldi )
CALL mpp_add_att(mpp__init_read_rstdimg, tl_att)
tl_att=att_init( "DOMAIN_J_halo_size_start", &
& mpp__init_read_rstdimg%t_proc(:)%i_ldj )
CALL mpp_add_att(mpp__init_read_rstdimg, tl_att)
tl_att=att_init( "DOMAIN_I_halo_size_end", &
& mpp__init_read_rstdimg%t_proc(:)%i_lei )
CALL mpp_add_att(mpp__init_read_rstdimg, tl_att)
tl_att=att_init( "DOMAIN_J_halo_size_end", &
& mpp__init_read_rstdimg%t_proc(:)%i_lej )
CALL mpp_add_att(mpp__init_read_rstdimg, tl_att)
ENDIF
ELSE
CALL logger_error("INIT READ: dimg file "//TRIM(td_file%c_name)//&
& " do not exist")
ENDIF
END FUNCTION mpp__init_read_rstdimg
! @endcode
!-------------------------------------------------------------------
!> @brief This function check if variable and mpp structure use same
!> dimension.
!
!> @details
!
!> @author J.Paul
!> - Nov, 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)
!-------------------------------------------------------------------
! @code
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( " 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( " CHECK DIM: processor and mpp dimension differ" )
ENDIF
ENDIF
END FUNCTION mpp__check_proc_dim
! @endcode
!-------------------------------------------------------------------
!> @brief
!> This subroutine add variable to mpp structure.
!>
!> @detail
!
!> @author J.Paul
!> @date Nov, 2013
!
!> @param[inout] td_mpp : mpp strcuture
!> @param[in] td_var : variable strcuture
!
!> @todo
!-------------------------------------------------------------------
!> @code
SUBROUTINE mpp_add_var( 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
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: domain decomposition not define "//&
& "for mpp "//TRIM(td_mpp%c_name))
ELSEIF( td_mpp%i_ndim == 0 )THEN
CALL logger_error( " MPP ADD VAR: no dimension define for "//&
& " mpp strcuture "//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_id( 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 ADD VAR: variable "//TRIM(td_var%c_name)//&
& ", standard name "//TRIM(td_var%c_stdname)//&
& ", already in mpp "//TRIM(td_mpp%c_name) )
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
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
! 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)
ENDDO
ENDIF
ENDIF
ENDIF
ENDIF
END SUBROUTINE mpp_add_var
!> @endcode
!-------------------------------------------------------------------
!> @brief This function extract from variable structure, part that will
!> be written in processor id_procid.
!
!> @details
!
!> @author J.Paul
!> - Nov, 2013- Initial Version
!
!> @param[in] td_mpp : mpp structure
!> @param[in] td_var : variable structure
!> @param[in] id_procid : processor id
!> @return variable structure
!-------------------------------------------------------------------
! @code
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=td_var
! 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, :, :) )
END FUNCTION mpp__split_var
!> @endcode
!-------------------------------------------------------------------
!> @brief
!> This subroutine delete variable in mpp structure, given variable
!> structure.
!>
!> @detail
!
!> @author J.Paul
!> @date Nov, 2013
!
!> @param[inout] td_mpp : mpp strcuture
!> @param[in] td_var : variable strcuture
!
!> @todo
!-------------------------------------------------------------------
!> @code
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( " 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_id( td_mpp%t_proc(1)%t_var(:), &
& td_var%c_name, td_var%c_stdname )
ENDIF
IF( il_varid == 0 )THEN
CALL logger_error( &
& " 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( " 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
!> @endcode
!-------------------------------------------------------------------
!> @brief
!> This subroutine delete variable in mpp structure, given variable name.
!>
!> @detail
!
!> @author J.Paul
!> @date Nov, 2013
!
!> @param[inout] td_mpp : mpp strcuture
!> @param[in] cd_name: variable name
!
!> @todo
!-------------------------------------------------------------------
!> @code
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
!----------------------------------------------------------------
! check if mpp exist
IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
CALL logger_error( " 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( " 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_id( td_mpp%t_proc(1)%t_var(:), &
& cd_name )
ENDIF
IF( il_varid == 0 )THEN
CALL logger_warn( &
& "DEL VAR : there is no variable with name "//&
& "or standard name "//TRIM(ADJUSTL(cd_name))//&
& " in mpp structure "//TRIM(td_mpp%c_name))
ELSE
CALL mpp_del_var(td_mpp, td_mpp%t_proc(1)%t_var(il_varid))
ENDIF
ENDIF
ENDIF
END SUBROUTINE mpp__del_var_name
!> @endcode
!-------------------------------------------------------------------
!> @brief
!> This subroutine overwrite variable in mpp structure.
!>
!> @detail
!
!> @author J.Paul
!> @date Nov, 2013
!
!> @param[inout] td_mpp : mpp strcuture
!> @param[in] td_var : variable structure
!> @todo
!> - voir si il ne faut pas redefinir (__copy) variable si elle vient de mpp
!> exemple CALL mpp_move_var( td_mpp, td_mpp%t_proc()%t_var )
!> remarque cas probabelement impossible puisque td_var doit avoir dim de td_mpp
!-------------------------------------------------------------------
!> @code
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 variable
tl_var=td_var
! remove processor
CALL mpp_del_var(td_mpp, tl_var)
! add processor
CALL mpp_add_var(td_mpp, tl_var)
END SUBROUTINE mpp_move_var
!> @endcode
!-------------------------------------------------------------------
!> @brief
!> This subroutine add processor to mpp structure.
!>
!> @detail
!
!> @author J.Paul
!> @date Nov, 2013
!
!> @param[inout] td_mpp : mpp strcuture
!> @param[in] td_proc : processor strcuture
!
!> @todo
!> - check proc type
!-------------------------------------------------------------------
!> @code
SUBROUTINE mpp__add_proc( 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
!----------------------------------------------------------------
! 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( &
& " ADD PROC: processor "//TRIM(fct_str(td_proc%i_pid))//&
& ", already in mpp structure " )
ELSE
CALL logger_trace("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( " ADD PROC: not enough space to put processor &
& in mpp structure")
ELSE
! save temporary mpp structure
tl_proc(:)=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( " ADD PROC: not enough space to put "//&
& "processor in mpp structure ")
ENDIF
! copy processor in mpp before
! processor with lesser id than new processor
td_mpp%t_proc( 1:il_procid ) = tl_proc( 1:il_procid )
! processor with greater id than new processor
td_mpp%t_proc( il_procid+1 : td_mpp%i_nproc+1 ) = &
& tl_proc( il_procid : td_mpp%i_nproc )
DEALLOCATE(tl_proc)
ENDIF
ELSE
! no processor in mpp structure
IF( ASSOCIATED(td_mpp%t_proc) )THEN
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( " 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( "ADD PROC: mpp structure and new processor "//&
& " dimension differ. ")
CALL logger_debug("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("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)=td_proc
ENDIF
ENDIF
END SUBROUTINE mpp__add_proc
!> @endcode
!-------------------------------------------------------------------
!> @brief
!> This subroutine delete processor in mpp structure, given processor id.
!>
!> @detail
!
!> @author J.Paul
!> @date Nov, 2013
!
!> @param[inout] td_mpp : mpp strcuture
!> @param[in] id_procid : processor id
!
!> @todo check proc id exist
!-------------------------------------------------------------------
!> @code
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
!----------------------------------------------------------------
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("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( " 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)=td_mpp%t_proc(1:il_procid-1)
ENDIF
tl_proc(il_procid:)=td_mpp%t_proc(il_procid+1:)
! new number of processor in mpp
td_mpp%i_nproc=td_mpp%i_nproc-1
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( " DEL PROC: not enough space to put processors &
& in mpp structure " )
ELSE
! copy processor in mpp before
td_mpp%t_proc(:)=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
ELSE
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
!> @endcode
!-------------------------------------------------------------------
!> @brief
!> This subroutine delete processor in mpp structure, given processor
!> structure.
!>
!> @detail
!
!> @author J.Paul
!> @date Nov, 2013
!
!> @param[inout] td_mpp : mpp strcuture
!> @param[in] td_proc : file/processor structure
!
!> @todo check proc id exist
!-------------------------------------------------------------------
!> @code
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("DEL PROC: processor not defined")
ENDIF
END SUBROUTINE mpp__del_proc_str
!> @endcode
!-------------------------------------------------------------------
!> @brief
!> This subroutine overwrite processor in mpp structure.
!>
!> @detail
!
!> @author J.Paul
!> @date Nov, 2013
!
!> @param[inout] td_mpp : mpp strcuture
!> @param[in] id_procid : processor id
!> @todo
!> - voir si il ne faut pas redefinir (__copy) proc si il vient de mpp
!> exemple CALL mpp_move_proc( td_mpp, td_mpp%t_proc )
!-------------------------------------------------------------------
!> @code
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
!> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine add a dimension structure in a mpp
!> structure.
!> Do not overwrite, if dimension already in mpp structure.
!
!> @details
!
!> @author J.Paul
!> - Nov, 2013- Initial Version
!
!> @param[inout] td_mpp : mpp structure
!> @param[in] td_dim : dimension structure
!
!> @todo
!-------------------------------------------------------------------
! @code
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_dimid
! loop indices
!----------------------------------------------------------------
IF( td_mpp%i_ndim <= 4 )THEN
! check if dimension already in mpp structure
il_dimid=dim_get_id(td_mpp%t_dim(:), td_dim%c_name, td_dim%c_sname)
IF( il_dimid /= 0 )THEN
CALL logger_error( &
& " ADD DIM: dimension "//TRIM(td_dim%c_name)//&
& ", short name "//TRIM(td_dim%c_sname)//&
& ", already in mpp "//TRIM(td_mpp%c_name) )
ELSE
CALL logger_debug( &
& " ADD DIM: add dimension "//TRIM(td_dim%c_name)//&
& ", short name "//TRIM(td_dim%c_sname)//&
& ", in mpp "//TRIM(td_mpp%c_name) )
IF( td_mpp%i_ndim == 4 )THEN
! search empty dimension
il_dimid=dim_get_void_id(td_mpp%t_dim(:),TRIM(td_dim%c_name), &
& TRIM(td_dim%c_sname))
! replace empty dimension
td_mpp%t_dim(il_dimid)=td_dim
td_mpp%t_dim(il_dimid)%i_id=il_dimid
td_mpp%t_dim(il_dimid)%l_use=.TRUE.
ELSE
il_dimid=dim_get_void_id(td_mpp%t_dim(:),TRIM(td_dim%c_name), &
& TRIM(td_dim%c_sname))
! add new dimension
td_mpp%t_dim(il_dimid)=td_dim
td_mpp%t_dim(il_dimid)%i_id=td_mpp%i_ndim+1
td_mpp%t_dim(il_dimid)%l_use=.TRUE.
! 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)
ENDIF
ELSE
CALL logger_error( &
& " 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
! @endcode
!-------------------------------------------------------------------
!> @brief This subroutine delete a dimension structure in a mpp
!> structure.
!
!> @details
!
!> @author J.Paul
!> - Nov, 2013- Initial Version
!
!> @param[inout] td_mpp : mpp structure
!> @param[in] td_dim : dimension structure
!
!> @todo
!-------------------------------------------------------------------
! @code
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_status
INTEGER(i4) :: il_dimid
TYPE(TDIM), DIMENSION(:), ALLOCATABLE :: tl_dim
! loop indices
!----------------------------------------------------------------
IF( td_mpp%i_ndim <= 4 )THEN
! check if dimension already in mpp structure
il_dimid=dim_get_id(td_mpp%t_dim(:), td_dim%c_name, td_dim%c_sname)
IF( il_dimid == 0 )THEN
CALL logger_error( &
& " DEL DIM: no dimension "//TRIM(td_dim%c_name)//&
& ", short name "//TRIM(td_dim%c_sname)//&
& ", in mpp "//TRIM(td_mpp%c_name) )
ELSE
CALL logger_debug( &
& " DEL DIM: delete dimension "//TRIM(td_dim%c_name)//&
& ", short name "//TRIM(td_dim%c_sname)//&
& ", in mpp "//TRIM(td_mpp%c_name) )
IF( td_mpp%i_ndim == 4 )THEN
ALLOCATE( tl_dim(1), stat=il_status )
IF(il_status /= 0 )THEN
CALL logger_error( &
& " DEL DIM: not enough space to put dimensions from "//&
& TRIM(td_mpp%c_name)//" in temporary dimension structure")
ELSE
! replace dimension by empty one
td_mpp%t_dim(il_dimid)=tl_dim(1)
ENDIF
DEALLOCATE(tl_dim)
ELSE
!
ALLOCATE( tl_dim(td_mpp%i_ndim), stat=il_status )
IF(il_status /= 0 )THEN
CALL logger_error( &
& " DEL DIM: not enough space to put dimensions from "//&
& TRIM(td_mpp%c_name)//" in temporary dimension structure")
ELSE
! save temporary dimension's mpp structure
tl_dim( 1 : il_dimid-1 ) = td_mpp%t_dim( 1 : il_dimid-1 )
tl_dim( il_dimid : td_mpp%i_ndim-1 ) = &
& td_mpp%t_dim( il_dimid+1 : td_mpp%i_ndim )
! copy dimension in file, except one
td_mpp%t_dim(1:td_mpp%i_ndim)=tl_dim(:)
! update number of dimension
td_mpp%i_ndim=td_mpp%i_ndim-1
ENDIF
ENDIF
! reorder dimension to ('x','y','z','t')
CALL dim_reorder(td_mpp%t_dim)
!IF( ASSOCIATED(td_mpp%t_proc) )THEN
! ! del dimension of processor
! DO ji=1,td_mpp%i_nproc
! CALL file_del_dim(td_mpp%t_proc(ji), td_dim)
! ENDDO
!ENDIF
ENDIF
ELSE
CALL logger_error( &
& " 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
! @endcode
!-------------------------------------------------------------------
!> @brief This subroutine move a dimension structure
!> in mpp structure.
!> @warning dimension order may have changed
!
!> @details
!
!> @author J.Paul
!> - Nov, 2013- Initial Version
!
!> @param[inout] td_mpp : mpp structure
!> @param[in] td_dim : dimension structure
!> @todo
!-------------------------------------------------------------------
! @code
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_dimid
!----------------------------------------------------------------
il_dimid=dim_get_id(td_mpp%t_dim(:), TRIM(td_dim%c_name), &
& TRIM(td_dim%c_sname))
IF( il_dimid /= 0 )THEN
! remove dimension with same name
CALL mpp_del_dim(td_mpp, td_dim)
ENDIF
! add new dimension
CALL mpp_add_dim(td_mpp, td_dim)
END SUBROUTINE mpp_move_dim
! @endcode
!-------------------------------------------------------------------
!> @brief
!> This subroutine add global attribute to mpp structure.
!>
!> @detail
!
!> @author J.Paul
!> @date Nov, 2013
!
!> @param[inout] td_mpp : mpp strcuture
!> @param[in] td_att : attribute strcuture
!
!> @todo
!-------------------------------------------------------------------
!> @code
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_id( 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 VAR: 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
!> @endcode
!-------------------------------------------------------------------
!> @brief
!> This subroutine delete attribute in mpp structure, given attribute
!> structure.
!>
!> @detail
!
!> @author J.Paul
!> @date Nov, 2013
!
!> @param[inout] td_mpp : mpp strcuture
!> @param[in] td_att : attribute strcuture
!
!> @todo
!> - check proc id exist
!> - check proc dimension
!> - check proc file name
!> - check proc type
!-------------------------------------------------------------------
!> @code
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_error( " 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_id( td_mpp%t_proc(1)%t_att(:), &
& td_att%c_name )
ENDIF
IF( il_attid == 0 )THEN
CALL logger_error( &
& " DEL VAR: no attribute "//TRIM(td_att%c_name)//&
& ", in mpp structure "//TRIM(td_mpp%c_name) )
DO ji=1,td_mpp%t_proc(1)%i_natt
CALL logger_debug( " DEL ATT: in mpp structure : &
& attribute : "//TRIM(td_mpp%t_proc(1)%t_var(ji)%c_name) )
ENDDO
ELSE
cl_name=TRIM(td_att%c_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
!> @endcode
!-------------------------------------------------------------------
!> @brief
!> This subroutine delete attribute in mpp structure, given attribute name.
!>
!> @detail
!
!> @author J.Paul
!> @date Nov, 2013
!
!> @param[inout] td_mpp : mpp strcuture
!> @param[in] cd_name: attribute name
!
!> @todo
!> - check proc id exist
!> - check proc dimension
!> - check proc file name
!> - check proc type
!-------------------------------------------------------------------
!> @code
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
!----------------------------------------------------------------
! check if mpp exist
IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
CALL logger_error( " 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( " 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_warn( &
& " DEL ATT : there is no attribute with "//&
& "name "//TRIM(cd_name)//" in mpp structure "//&
& TRIM(td_mpp%c_name))
ELSE
CALL mpp_del_att(td_mpp, td_mpp%t_proc(1)%t_att(il_attid))
ENDIF
ENDIF
ENDIF
END SUBROUTINE mpp__del_att_name
!> @endcode
!-------------------------------------------------------------------
!> @brief
!> This subroutine overwrite attribute in mpp structure.
!>
!> @detail
!
!> @author J.Paul
!> @date Nov, 2013
!
!> @param[inout] td_mpp : mpp strcuture
!> @param[in] td_att : attribute structure
!> @todo
!-------------------------------------------------------------------
!> @code
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=td_att
! remove processor
CALL mpp_del_att(td_mpp, tl_att)
! add processor
CALL mpp_add_att(td_mpp, tl_att)
END SUBROUTINE mpp_move_att
!> @endcode
!-------------------------------------------------------------------
!> @brief
!> This subroutine compute domain decomposition for niproc and njproc
!> processors following I and J.
!>
!> @detail
!> To do so, it need to know :
!> - global domain dimension
!> - overlap region length
!> - number of processors following I and J
!
!> @author J.Paul
!> @date Nov, 2013
!
!> @param[inout] td_mpp : mpp strcuture
!-------------------------------------------------------------------
!> @code
SUBROUTINE mpp__compute( td_mpp )
IMPLICIT NONE
! Argument
TYPE(TMPP), INTENT(INOUT) :: td_mpp
! local variable
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 !<
INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_nlci
INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_nlcj
INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_impp
INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_jmpp
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_trace( "COMPUTE: compute domain decomposition with "//&
& TRIM(fct_str(td_mpp%i_niproc))//" x "//&
& TRIM(fct_str(td_mpp%i_njproc))//" processors")
! 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
il_resti = MOD(td_mpp%t_dim(1)%i_len - 2*td_mpp%i_preci, td_mpp%i_niproc)
il_restj = MOD(td_mpp%t_dim(2)%i_len - 2*td_mpp%i_precj, td_mpp%i_njproc)
IF( il_resti == 0 ) il_resti = td_mpp%i_niproc
IF( il_restj == 0 ) il_restj = td_mpp%i_njproc
! compute dimension of each sub domain
ALLOCATE( il_nlci(td_mpp%i_niproc,td_mpp%i_njproc) )
ALLOCATE( il_nlcj(td_mpp%i_niproc,td_mpp%i_njproc) )
il_nlci( 1 : il_resti , : ) = il_isize
il_nlci( il_resti+1 : td_mpp%i_niproc, : ) = il_isize-1
il_nlcj( : , 1 : il_restj ) = il_jsize
il_nlcj( : , il_restj+1 : td_mpp%i_njproc) = il_jsize-1
! compute first index of each sub domain
ALLOCATE( il_impp(td_mpp%i_niproc,td_mpp%i_njproc) )
ALLOCATE( il_jmpp(td_mpp%i_niproc,td_mpp%i_njproc) )
il_impp(:,:)=1
il_jmpp(:,:)=1
DO jj=1,td_mpp%i_njproc
DO ji=2,td_mpp%i_niproc
il_impp(ji,jj)=il_impp(ji-1,jj)+il_nlci(ji-1,jj)-2*td_mpp%i_preci
ENDDO
ENDDO
DO jj=2,td_mpp%i_njproc
DO ji=1,td_mpp%i_niproc
il_jmpp(ji,jj)=il_jmpp(ji,jj-1)+il_nlcj(ji,jj-1)-2*td_mpp%i_precj
ENDDO
ENDDO
DO jj=1,td_mpp%i_njproc
DO ji=1,td_mpp%i_niproc
jk=ji+(jj-1)*td_mpp%i_niproc
! 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 = il_impp(ji,jj)
tl_proc%i_jmpp = il_jmpp(ji,jj)
tl_att=att_init( "DOMAIN_poistion_first", &
& (/tl_proc%i_impp, tl_proc%i_jmpp/) )
CALL file_add_att(tl_proc, tl_att)
tl_proc%i_lci = il_nlci(ji,jj)
tl_proc%i_lcj = il_nlcj(ji,jj)
tl_att=att_init( "DOMAIN_poistion_last", &
& (/tl_proc%i_lci, tl_proc%i_lcj/) )
CALL file_add_att(tl_proc, tl_att)
! 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 = il_nlci(ji,jj)
tl_proc%l_ctr = .TRUE.
ELSE
tl_proc%i_lei = il_nlci(ji,jj) - td_mpp%i_preci
ENDIF
! north boundary
IF( jj == td_mpp%i_njproc )THEN
tl_proc%i_lej = il_nlcj(ji,jj)
tl_proc%l_ctr = .TRUE.
ELSE
tl_proc%i_lej = il_nlcj(ji,jj) - td_mpp%i_precj
ENDIF
tl_att=att_init( "DOMAIN_halo_size_start", &
& (/tl_proc%i_ldi, tl_proc%i_ldj/) )
CALL file_add_att(tl_proc, tl_att)
tl_att=att_init( "DOMAIN_halo_size_end", &
& (/tl_proc%i_ldi, tl_proc%i_ldj/) )
CALL file_add_att(tl_proc, tl_att)
! add processor to mpp structure
CALL mpp__add_proc(td_mpp, tl_proc)
ENDDO
ENDDO
DEALLOCATE( il_impp, il_jmpp )
DEALLOCATE( il_nlci, il_nlcj )
END SUBROUTINE mpp__compute
!> @endcode
!-------------------------------------------------------------------
!> @brief
!> This subroutine remove land processor from domain decomposition.
!
!> @author J.Paul
!> @date Nov, 2013
!
!> @param[inout] td_mpp : mpp strcuture
!> @param[in] id_mask : sub domain mask (sea=1, land=0)
!-------------------------------------------------------------------
!> @code
SUBROUTINE mpp__del_land( td_mpp, id_mask )
IMPLICIT NONE
! Argument
TYPE(TMPP), INTENT(INOUT) :: td_mpp
INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_mask
! loop indices
INTEGER(i4) :: jk
!----------------------------------------------------------------
IF( ASSOCIATED(td_mpp%t_proc) )THEN
jk=1
DO WHILE( jk <= td_mpp%i_nproc )
IF( mpp__land_proc(td_mpp, jk, id_mask(:,:)) )THEN
CALL mpp__del_proc(td_mpp, jk)
ELSE
jk=jk+1
ENDIF
ENDDO
ELSE
CALL logger_error("DEL LAND: domain decomposition not define.")
ENDIF
END SUBROUTINE mpp__del_land
!> @endcode
!-------------------------------------------------------------------
!> @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
!> processor removed.
!
!> @author J.Paul
!> @date Nov, 2013
!
!> @param[inout] td_mpp : mpp strcuture
!-------------------------------------------------------------------
!> @code
SUBROUTINE mpp__optimiz( td_mpp, id_mask )
IMPLICIT NONE
! Argument
TYPE(TMPP), INTENT(INOUT) :: td_mpp
INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_mask
! local variable
TYPE(TMPP) :: tl_mpp
INTEGER(i4) :: il_maxproc
TYPE(TFILE), DIMENSION(:), ALLOCATABLE :: tl_proc
! loop indices
INTEGER(i4) :: ji
INTEGER(i4) :: jj
!----------------------------------------------------------------
CALL logger_trace("OPTIMIZ: look for best domain decomposition")
tl_mpp=td_mpp
! save maximum number of processor to be used
il_maxproc=td_mpp%i_nproc
!
td_mpp%i_nproc=0
DO ji=1,il_maxproc
DO jj=1,il_maxproc
! clean mpp processor
IF( ASSOCIATED(tl_mpp%t_proc) )THEN
DEALLOCATE(tl_mpp%t_proc)
ENDIF
! compute domain decomposition
tl_mpp%i_niproc=ji
tl_mpp%i_njproc=jj
CALL mpp__compute( tl_mpp )
! remove land sub domain
CALL mpp__del_land( tl_mpp, id_mask )
CALL logger_info("OPTIMIZ: number of processor "//&
& TRIM(fct_str(tl_mpp%i_nproc)) )
IF( tl_mpp%i_nproc > td_mpp%i_nproc .AND. &
& tl_mpp%i_nproc <= il_maxproc )THEN
! save optimiz decomposition
! clean mpp
CALL mpp_clean(td_mpp)
! save processor table
ALLOCATE( tl_proc(tl_mpp%i_nproc) )
tl_proc(:)=tl_mpp%t_proc(:)
! remove pointer on processor table
DEALLOCATE(tl_mpp%t_proc)
! save data except processor table
td_mpp=tl_mpp
! save processor table
ALLOCATE( td_mpp%t_proc(td_mpp%i_nproc) )
td_mpp%t_proc(:)=tl_proc(:)
DEALLOCATE( tl_proc )
ENDIF
ENDDO
ENDDO
END SUBROUTINE mpp__optimiz
!> @endcode
!-------------------------------------------------------------------
!> @brief
!> This function check if processor is a land processor.
!
!> @author J.Paul
!> @date Nov, 2013
!
!> @param[in] td_mpp : mpp strcuture
!> @param[in] id_proc : processor id
!> @param[in] id_mask : sub domain mask (sea=1, land=0)
!-------------------------------------------------------------------
!> @code
LOGICAL FUNCTION mpp__land_proc( td_mpp , id_proc, id_mask )
IMPLICIT NONE
! Argument
TYPE(TMPP), INTENT(IN) :: td_mpp
INTEGER(i4), INTENT(IN) :: id_proc
INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_mask
! local variable
INTEGER(i4), DIMENSION(2) :: il_shape
!----------------------------------------------------------------
CALL logger_trace("LAND PROC: check processor "//TRIM(fct_str(id_proc))//&
& " of mpp "//TRIM(td_mpp%c_name) )
mpp__land_proc=.FALSE.
IF( ASSOCIATED(td_mpp%t_proc) )THEN
il_shape(:)=SHAPE(id_mask)
IF( il_shape(1) /= td_mpp%t_dim(1)%i_len .OR. &
& il_shape(2) /= td_mpp%t_dim(2)%i_len )THEN
CALL logger_error("LAND PROC: mask and domain size differ")
ELSE
IF( ALL(id_mask( td_mpp%t_proc(id_proc)%i_impp + &
& td_mpp%t_proc(id_proc)%i_ldi - 1 : &
& td_mpp%t_proc(id_proc)%i_impp + &
& td_mpp%t_proc(id_proc)%i_lei - 1, &
& td_mpp%t_proc(id_proc)%i_jmpp + &
& td_mpp%t_proc(id_proc)%i_ldj - 1 : &
& td_mpp%t_proc(id_proc)%i_jmpp + &
& td_mpp%t_proc(id_proc)%i_lej - 1) &
& /= 1 ) )THEN
! land domain
CALL logger_info(" LAND PROC: processor "//TRIM(fct_str(id_proc))//&
& " is land processor")
mpp__land_proc=.TRUE.
ENDIF
ENDIF
ELSE
CALL logger_error("LAND PROC: domain decomposition not define.")
ENDIF
END FUNCTION mpp__land_proc
!> @endcode
!-------------------------------------------------------------------
!> @brief
!> This subroutine clean mpp strcuture.
!
!> @author J.Paul
!> @date Nov, 2013
!
!> @param[inout] td_mpp : mpp strcuture
!-------------------------------------------------------------------
!> @code
SUBROUTINE mpp_clean( td_mpp )
IMPLICIT NONE
! Argument
TYPE(TMPP), INTENT(INOUT) :: td_mpp
! local variable
TYPE(TMPP) :: tl_mpp ! empty mpp structure
! loop indices
INTEGER(i4) :: ji
!----------------------------------------------------------------
CALL logger_info( &
& " CLEAN: reset mpp "//TRIM(td_mpp%c_name) )
! del dimension
IF( td_mpp%i_ndim /= 0 )THEN
DO ji=td_mpp%i_ndim,1,-1
CALL dim_clean( td_mpp%t_dim(ji) )
ENDDO
ENDIF
IF( ASSOCIATED(td_mpp%t_proc) )THEN
! clean each proc
DO ji=1,td_mpp%i_nproc
CALL file_clean( td_mpp%t_proc(ji) )
ENDDO
DEALLOCATE(td_mpp%t_proc)
ENDIF
! replace by empty structure
td_mpp=tl_mpp
END SUBROUTINE mpp_clean
!> @endcode
!-------------------------------------------------------------------
!> @brief
!> This subroutine get sub domains which cover "zoom domain".
!
!> @author J.Paul
!> @date Nov, 2013
!
!> @param[inout] td_mpp : mpp strcuture
!> @param[in] td_dom : domain strcuture
!-------------------------------------------------------------------
!> @code
SUBROUTINE mpp_get_use( td_mpp, td_dom )
IMPLICIT NONE
! Argument
TYPE(TMPP), INTENT(INOUT) :: td_mpp
TYPE(TDOM), INTENT(IN) :: td_dom
! local variable
INTEGER(i4) :: il_jmin
LOGICAL :: ll_iuse
LOGICAL :: ll_juse
! loop indices
INTEGER(i4) :: jk
!----------------------------------------------------------------
IF( ASSOCIATED(td_mpp%t_proc) )THEN
! check domain
IF( td_mpp%t_dim(1)%i_len == td_dom%t_dim0(1)%i_len .AND. &
& td_mpp%t_dim(2)%i_len == td_dom%t_dim0(2)%i_len )THEN
td_mpp%t_proc(:)%l_use=.FALSE.
DO jk=1,td_mpp%i_nproc
! check i-direction
ll_iuse=.FALSE.
IF( td_dom%i_imin < td_dom%i_imax )THEN
! not overlap east west boundary
IF( td_mpp%t_proc(jk)%i_impp + td_mpp%t_proc(jk)%i_lci > &
& td_dom%i_imin .AND. &
& td_mpp%t_proc(jk)%i_impp < td_dom%i_imax )THEN
ll_iuse=.TRUE.
ENDIF
ELSEIF( td_dom%i_imin == td_dom%i_imax )THEN
! east west cyclic
ll_iuse=.TRUE.
ELSE ! td_dom%i_imin > td_dom%i_imax
! overlap east west boundary
IF( ( td_mpp%t_proc(jk)%i_impp + td_mpp%t_proc(jk)%i_lci > &
& td_dom%i_imin .AND. &
& td_mpp%t_proc(jk)%i_impp < td_dom%t_dim0(1)%i_len ) &
& .OR. &
& ( td_mpp%t_proc(jk)%i_impp + td_mpp%t_proc(jk)%i_lci > &
& 1 .AND. &
& td_mpp%t_proc(jk)%i_impp < td_dom%i_imax) )THEN
ll_iuse=.TRUE.
ENDIF
ENDIF
! check j-direction
ll_juse=.FALSE.
IF( td_dom%i_jmin < td_dom%i_jmax )THEN
! not overlap north fold
IF( td_mpp%t_proc(jk)%i_jmpp + td_mpp%t_proc(jk)%i_lcj > &
& td_dom%i_jmin .AND. &
& td_mpp%t_proc(jk)%i_jmpp < td_dom%i_jmax )THEN
ll_juse=.TRUE.
ENDIF
ELSE ! td_dom%i_jmin >= td_dom%i_jmax
il_jmin=MIN(td_dom%i_jmin,td_dom%i_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
ELSE
CALL logger_error("GET USE: domain differ")
ENDIF
ELSE
CALL logger_error("GET USE: domain decomposition not define.")
ENDIF
END SUBROUTINE mpp_get_use
!> @endcode
!-------------------------------------------------------------------
!> @brief
!> This subroutine get sub domains which form global domain border.
!
!> @author J.Paul
!> @date Nov, 2013
!
!> @param[inout] td_mpp : mpp strcuture
!-------------------------------------------------------------------
!> @code
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_ctr = .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_ctr = .TRUE.
ENDIF
ENDDO
ELSE
CALL logger_error("GET CONTOUR: domain decomposition not define.")
ENDIF
END SUBROUTINE mpp_get_contour
!> @endcode
!-------------------------------------------------------------------
!> @brief
!> This function return processor indices, without overlap boundary,
!> given processor id. This depends of domain decompisition type.
!
!> @author J.Paul
!> @date Nov, 2013
!
!> @param[in] td_mpp : mpp strcuture
!> @param[in] id_procid : processor id
!> @return table of index (/ i1, i2, j1, j2 /)
!-------------------------------------------------------------------
!> @code
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
TYPE(TMPP) :: tl_mpp
!----------------------------------------------------------------
IF( ASSOCIATED(td_mpp%t_proc) )THEN
tl_mpp=td_mpp
!IF( TRIM(td_mpp%c_dom) == "unknown" )THEN
IF( TRIM(td_mpp%c_dom) == '' )THEN
CALL logger_warn("GET PROC INDEX: decomposition type unknown. "//&
& "look for it")
CALL mpp_get_dom( tl_mpp )
ENDIF
SELECT CASE(TRIM(tl_mpp%c_dom))
CASE('full')
il_i1 = 1 ; il_i2 = td_mpp%t_dim(1)%i_len
il_j1 = 1 ; il_j2 = td_mpp%t_dim(2)%i_len
CASE('overlap')
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 ! attention lei dans ioRestartDimg
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("GET PROC INDEX: invalid decomposition type.")
END SELECT
mpp_get_proc_index(:)=(/il_i1, il_i2, il_j1, il_j2/)
ELSE
CALL logger_error("GET PROC INDEX: domain decomposition not define.")
ENDIF
END FUNCTION mpp_get_proc_index
!> @endcode
!-------------------------------------------------------------------
!> @brief
!> This function return processor domain size, depending of domain
!> decompisition type, given sub domain id.
!
!> @author J.Paul
!> @date Nov, 2013
!
!> @param[in] td_mpp : mpp strcuture
!> @param[in] id_procid : sub domain id
!> @return table of index (/ isize, jsize /)
!-------------------------------------------------------------------
!> @code
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
TYPE(TMPP) :: tl_mpp
!----------------------------------------------------------------
IF( ASSOCIATED(td_mpp%t_proc) )THEN
tl_mpp=td_mpp
!IF( TRIM(td_mpp%c_dom) == "unknown" )THEN
IF( TRIM(td_mpp%c_dom) == '' )THEN
CALL logger_warn("GET PROC SIZE: decomposition type unknown. "//&
& "look for it")
CALL mpp_get_dom( tl_mpp )
ENDIF
SELECT CASE(TRIM(tl_mpp%c_dom))
CASE('full')
il_isize = td_mpp%t_dim(1)%i_len
il_jsize = td_mpp%t_dim(2)%i_len
CASE('overlap')
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("GET PROC SIZE: invalid decomposition type : "//&
& TRIM(tl_mpp%c_dom) )
END SELECT
mpp_get_proc_size(:)=(/il_isize, il_jsize/)
ELSE
CALL logger_error("GET PROC SIZE: domain decomposition not define.")
ENDIF
END FUNCTION mpp_get_proc_size
!> @endcode
!-------------------------------------------------------------------
!> @brief
!> This subroutine determine domain decomposition type.
!> (full, overlap, noverlap)
!
!> @author J.Paul
!> @date Nov, 2013
!
!> @param[inout] td_mpp : mpp strcuture
!> @todo
!> - change name, confusing with domain.f90
!-------------------------------------------------------------------
!> @code
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_niproc == 0 )THEN
CALL logger_info("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='overlap'
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("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("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("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("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("GET DOM: full size "//&
& TRIM(fct_str(il_isize))//" x "//TRIM(fct_str(il_jsize)) )
ENDIF
ELSE
CALL logger_info("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='overlap'
ENDIF
ENDIF
ELSE
CALL logger_error("GET DOM: domain decomposition not define.")
ENDIF
END SUBROUTINE mpp_get_dom
!> @endcode
!-------------------------------------------------------------------
!> @brief This function check if variable and mpp structure use same
!> dimension.
!
!> @details
!
!> @author J.Paul
!> - Nov, 2013- Initial Version
!
!> @param[in] td_mpp : mpp structure
!> @param[in] td_var : variable structure
!> @return dimension of variable and mpp structure agree (or not)
!-------------------------------------------------------------------
! @code
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
INTEGER(i4) :: il_ndim
! loop indices
INTEGER(i4) :: ji
!----------------------------------------------------------------
mpp__check_var_dim=.TRUE.
! check used dimension
IF( ANY( td_var%t_dim(:)%l_use .AND. &
& td_var%t_dim(:)%i_len /= td_mpp%t_dim(:)%i_len) )THEN
mpp__check_var_dim=.FALSE.
CALL logger_error( &
& " CHECK DIM: variable and mpp dimension differ"//&
& " for variable "//TRIM(td_var%c_name)//&
& " and mpp "//TRIM(td_mpp%c_name))
CALL logger_debug( &
& " mpp dimension: "//TRIM(fct_str(td_mpp%i_ndim))//&
& " variable dimension: "//TRIM(fct_str(td_var%i_ndim)) )
il_ndim=MIN(td_var%i_ndim, td_mpp%i_ndim )
DO ji = 1, il_ndim
CALL logger_debug( &
& " CHECK DIM: for dimension "//&
& TRIM(td_mpp%t_dim(ji)%c_name)//&
& ", mpp length: "//&
& TRIM(fct_str(td_mpp%t_dim(ji)%i_len))//&
& ", variable length: "//&
& TRIM(fct_str(td_var%t_dim(ji)%i_len))//&
& ", variable used "//TRIM(fct_str(td_var%t_dim(ji)%l_use)))
ENDDO
ENDIF
END FUNCTION mpp__check_var_dim
! @endcode
END MODULE mpp