!----------------------------------------------------------------------
! NEMO system team, System and Interface for oceanic RElocable Nesting
!----------------------------------------------------------------------
!
! DESCRIPTION:
!> This module manage multi file structure.
!>
!> @details
!> define type TMULTI:
!> @code
!> TYPE(TMULTI) :: tl_multi
!> @endcode
!>
!> to initialize a multi-file structure:
!> @code
!> tl_multi=multi_init(cd_varfile(:))
!> @endcode
!> - cd_varfile : array of variable with file path
!> ('var1:file1','var2:file2')
!> file path could be replaced by a matrix of value.
!> separators used to defined matrix are:
!> - ',' for line
!> - '/' for row
!> - '\' for level
!> Example:
!> - 'var1:3,2,3/1,4,5'
!> - 3,2,3/1,4,5 =>
!> @f$ \left( \begin{array}{ccc}
!> 3 & 2 & 3 \\
!> 1 & 4 & 5 \end{array} \right) @f$
!>
!> to get the number of mpp file in mutli file structure:
!> - tl_multi\%i_nmpp
!>
!> to get the total number of variable in mutli file structure:
!> - tl_multi\%i_nvar
!>
!> @note number of variable and number of file could differ cause several variable
!> could be in the same file.
!>
!> to get array of mpp structure in mutli file structure:
!> - tl_multi\%t_mpp(:)
!>
!> to print information about multi structure:
!> @code
!> CALL multi_print(td_multi)
!> @endcode
!>
!> to clean multi file strucutre:
!> @code
!> CALL multi_clean(td_multi)
!> @endcode
!> - td_multi is multi file structure
!>
!> @author
!> J.Paul
!>
!> @date November, 2013 - Initial Version
!> @date October, 2014
!> - use mpp file structure instead of file
!> @date November, 2014
!> - Fix memory leaks bug
!>
!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
!----------------------------------------------------------------------
MODULE multi
USE kind ! F90 kind parameter
USE logger ! log file manager
USE fct ! basic useful function
USE dim ! dimension manager
USE var ! variable manager
USE file ! file manager
USE iom ! I/O manager
USE mpp ! MPP manager
USE iom_mpp ! MPP I/O manager
IMPLICIT NONE
! NOTE_avoid_public_variables_if_possible
! type and variable
PUBLIC :: TMULTI !< multi file structure
! function and subroutine
PUBLIC :: multi_copy !< copy multi structure
PUBLIC :: multi_init !< initialise multi structure
PUBLIC :: multi_clean !< clean multi strcuture
PUBLIC :: multi_print !< print information about milti structure
PRIVATE :: multi__add_mpp !< add file strucutre to multi file structure
PRIVATE :: multi__copy_unit !< copy multi file structure
PRIVATE :: multi__get_perio !< read periodicity from namelist
TYPE TMULTI !< multi file structure
! general
INTEGER(i4) :: i_nmpp = 0 !< number of mpp files
INTEGER(i4) :: i_nvar = 0 !< total number of variables
TYPE(TMPP) , DIMENSION(:), POINTER :: t_mpp => NULL() !< mpp files composing multi
END TYPE
INTERFACE multi_copy
MODULE PROCEDURE multi__copy_unit ! copy multi file structure
END INTERFACE
CONTAINS
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
FUNCTION multi__copy_unit(td_multi) &
& RESULT (tf_multi)
!-------------------------------------------------------------------
!> @brief
!> This function copy multi mpp structure in another one
!> @details
!> file variable value are copied in a temporary array,
!> so input and output file structure value 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
!> attribute (ex: tl_att=att_copy(att_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_multi mpp structure
!> @return copy of input multi structure
!-------------------------------------------------------------------
IMPLICIT NONE
! Argument
TYPE(TMULTI), INTENT(IN) :: td_multi
! function
TYPE(TMULTI) :: tf_multi
! local variable
TYPE(TMPP) :: tl_mpp
! loop indices
INTEGER(i4) :: ji
!----------------------------------------------------------------
tf_multi%i_nmpp = td_multi%i_nmpp
tf_multi%i_nvar = td_multi%i_nvar
! copy variable structure
IF( ASSOCIATED(tf_multi%t_mpp) )THEN
CALL mpp_clean(tf_multi%t_mpp(:))
DEALLOCATE(tf_multi%t_mpp)
ENDIF
IF( ASSOCIATED(td_multi%t_mpp) .AND. tf_multi%i_nmpp > 0 )THEN
ALLOCATE( tf_multi%t_mpp(tf_multi%i_nmpp) )
DO ji=1,tf_multi%i_nmpp
tl_mpp = mpp_copy(td_multi%t_mpp(ji))
tf_multi%t_mpp(ji) = mpp_copy(tl_mpp)
ENDDO
! clean
CALL mpp_clean(tl_mpp)
ENDIF
END FUNCTION multi__copy_unit
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
FUNCTION multi_init(cd_varfile) &
& RESULT (tf_multi)
!-------------------------------------------------------------------
!> @brief This subroutine initialize multi file structure.
!>
!> @details
!> if variable name is 'all', add all the variable of the file in mutli file
!> structure.
!> Optionnaly, periodicity could be read behind filename.
!>
!> @note if first character of filename is numeric, assume matrix is given as
!> input.
!> create pseudo file named 'data-*', with matrix read as variable value.
!>
!> @author J.Paul
!> @date November, 2013 - Initial Version
!> @date July, 2015
!> - check if variable to be read is in file
!> @date January, 2016
!> - read variable dimensions
!> @date July, 2016
!> - get variable to be read and associated file first
!> @date August, 2017
!> - get perio from namelist
!> @date January, 2019
!> - create and clean file structure to avoid memory leaks
!> - fill value read from array of variable structure
!> @date May, 2019
!> - compare each elt of cl_tabfile to cl_file
!> @date August, 2019
!> - use periodicity read from namelist, and store in multi structure
!>
!> @param[in] cd_varfile variable location information (from namelist)
!> @return multi file structure
!-------------------------------------------------------------------
IMPLICIT NONE
! Argument
CHARACTER(LEN=*), DIMENSION(:), INTENT(IN) :: cd_varfile
! function
TYPE(TMULTI) :: tf_multi
! parameters
INTEGER(i4) , PARAMETER :: ip_nmaxfiles = 50
INTEGER(i4) , PARAMETER :: ip_nmaxvars = 100
! local variable
INTEGER(i4) :: il_nvar
INTEGER(i4) :: il_nvarin
INTEGER(i4) :: il_nfiles
INTEGER(i4) :: il_varid
INTEGER(i4) :: il_perio
REAL(dp) :: dl_fill
CHARACTER(LEN=lc) :: cl_name
CHARACTER(LEN=lc) :: cl_varname
CHARACTER(LEN=lc) :: cl_lower
CHARACTER(LEN=lc) :: cl_file
CHARACTER(LEN=lc) :: cl_matrix
CHARACTER(LEN=lc), DIMENSION(ip_nmaxfiles) :: cl_tabfile
CHARACTER(LEN=lc), DIMENSION(ip_nmaxfiles, ip_nmaxvars) :: cl_tabvar
LOGICAL :: ll_dim
TYPE(TDIM), DIMENSION(ip_maxdim) :: tl_dim
TYPE(TVAR) :: tl_var
TYPE(TVAR) , DIMENSION(:), ALLOCATABLE :: tl_varin
TYPE(TMPP) :: tl_mpp
TYPE(TFILE) :: tl_file
! loop indices
INTEGER(i4) :: ji
INTEGER(i4) :: jj
INTEGER(i4) :: jk
INTEGER(i4) :: jl
INTEGER(i4) :: jf
INTEGER(i4) , DIMENSION(ip_nmaxvars) :: jv
!----------------------------------------------------------------
ji=1
jf=0
jv(:)=0
cl_tabfile(:)=''
DO WHILE( TRIM(cd_varfile(ji)) /= '' )
cl_name=fct_split(cd_varfile(ji),1,':')
IF( TRIM(cl_name) == '' )THEN
CALL logger_error("MULTI INIT: variable name "//&
& "is empty. check namelist.")
ENDIF
cl_file=fct_split(cd_varfile(ji),2,':')
IF( TRIM(cl_file) == '' )THEN
CALL logger_error("MULTI INIT: file name matching variable "//&
& TRIM(cl_name)//" is empty. check namelist.")
ENDIF
IF( LEN(TRIM(cl_file)) >= lc )THEN
CALL logger_fatal("MULTI INIT: file name too long (>"//&
& TRIM(fct_str(lc))//"). check namelist.")
ENDIF
IF( TRIM(cl_file) /= '' )THEN
jk=0
DO jj=1,jf
IF( TRIM(cl_file) == TRIM(cl_tabfile(jj)) )THEN
jk=jj
EXIT
ENDIF
ENDDO
IF ( jk /= 0 )then
jv(jk)=jv(jk)+1
cl_tabvar(jk,jv(jk))=TRIM(cl_name)
ELSE ! jk == 0
jf=jf+1
IF( jf > ip_nmaxfiles )THEN
CALL logger_fatal("MULTI INIT: too much files in "//&
& "varfile (>"//TRIM(fct_str(ip_nmaxfiles))//&
& "). check namelist.")
ENDIF
cl_tabfile(jf)=TRIM(cl_file)
jv(jf)=jv(jf)+1
cl_tabvar(jf,jv(jf))=TRIM(cl_name)
ENDIF
ENDIF
ji=ji+1
ENDDO
!print *,'============'
!print *,jf,' files ','============'
!DO ji=1,jf
! print *,'file ',trim(cl_tabfile(ji))
! print *,jv(ji),' vars '
! DO jj=1,jv(ji)
! print *,'var ',trim(cl_tabvar(ji,jj))
! ENDDO
!ENDDO
!print *,'============'
il_nfiles=jf
il_nvar=0
DO ji=1,il_nfiles
cl_file=TRIM(cl_tabfile(ji))
cl_matrix=''
IF( fct_is_num(cl_file(1:1)) )THEN
cl_matrix=TRIM(cl_file)
WRITE(cl_file,'(a,i2.2)')'data-',ji
DO jj=1,jv(ji)
cl_name=TRIM(cl_tabvar(ji,jv(ji)))
cl_lower=TRIM(fct_lower(cl_name))
tl_var=var_init(TRIM(cl_name))
CALL var_read_matrix(tl_var, cl_matrix)
IF( jj == 1 )THEN
! create mpp structure
tl_mpp=mpp_init(TRIM(cl_file), tl_var)
ENDIF
! add variable
CALL mpp_add_var(tl_mpp,tl_var)
! number of variable
il_nvar=il_nvar+1
ENDDO
ELSE
CALL multi__get_perio(cl_file, il_perio)
tl_file=file_init(TRIM(cl_file), id_perio=il_perio)
tl_mpp=mpp_init( tl_file, id_perio=il_perio )
! clean
CALL file_clean(tl_file)
il_nvarin=tl_mpp%t_proc(1)%i_nvar
ALLOCATE(tl_varin(il_nvarin))
DO jj=1,il_nvarin
tl_varin(jj)=var_copy(tl_mpp%t_proc(1)%t_var(jj))
DO jl=1,ip_maxdim
IF( tl_varin(jj)%t_dim(jl)%l_use )THEN
tl_varin(jj)%t_dim(jl)=dim_copy(tl_mpp%t_dim(jl))
ENDIF
ENDDO
ENDDO
! clean all varible
CALL mpp_del_var(tl_mpp)
DO jj=1,jv(ji)
cl_name=TRIM(cl_tabvar(ji,jj))
cl_lower=TRIM(fct_lower(cl_name))
! define variable
IF( TRIM(fct_lower(cl_lower)) /= 'all' )THEN
! check if variable is in file
il_varid=var_get_index(tl_varin(:),cl_lower)
IF( il_varid == 0 )THEN
CALL logger_fatal("MULTI INIT: variable "//&
& TRIM(cl_name)//" not in file "//&
& TRIM(cl_file) )
ENDIF
! get (global) variable dimension
tl_dim(jp_I)=dim_copy(tl_varin(il_varid)%t_dim(jp_I))
tl_dim(jp_J)=dim_copy(tl_varin(il_varid)%t_dim(jp_J))
tl_dim(jp_K)=dim_copy(tl_varin(il_varid)%t_dim(jp_K))
tl_dim(jp_L)=dim_copy(tl_varin(il_varid)%t_dim(jp_L))
cl_varname=tl_varin(il_varid)%c_name
dl_fill=tl_varin(il_varid)%d_fill
tl_var=var_init(TRIM(cl_varname), td_dim=tl_dim(:), &
& dd_fill=dl_fill)
! add variable
CALL mpp_add_var(tl_mpp,tl_var)
! number of variable
il_nvar=il_nvar+1
! clean structure
CALL var_clean(tl_var)
ELSE ! cl_lower == 'all'
DO jk=il_nvarin,1,-1
! check if variable is dimension
ll_dim=.FALSE.
DO jl=1,ip_maxdim
IF( TRIM(tl_mpp%t_proc(1)%t_dim(jl)%c_name) == &
& TRIM(tl_varin(jk)%c_name) )THEN
ll_dim=.TRUE.
CALL logger_trace("MULTI INIT: "//&
& TRIM(tl_varin(jk)%c_name)//&
& ' is var dimension')
EXIT
ENDIF
ENDDO
! do not use variable dimension
IF( ll_dim )THEN
tl_var=var_init( TRIM(tl_varin(jk)%c_name) )
! delete variable
CALL mpp_del_var(tl_mpp,tl_var)
! clean structure
CALL var_clean(tl_var)
ELSE
! add variable
CALL mpp_add_var(tl_mpp, tl_varin(jk))
! number of variable
il_nvar=il_nvar+1
ENDIF
ENDDO
ENDIF
ENDDO
! clean structure
CALL var_clean(tl_varin)
DEALLOCATE(tl_varin)
ENDIF
CALL multi__add_mpp(tf_multi, tl_mpp)
! update total number of variable
tf_multi%i_nvar=tf_multi%i_nvar+tl_mpp%t_proc(1)%i_nvar
! clean
CALL mpp_clean(tl_mpp)
ENDDO
END FUNCTION multi_init
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SUBROUTINE multi_clean(td_multi)
!-------------------------------------------------------------------
!> @brief This subroutine clean multi file strucutre.
!>
!> @author J.Paul
!> @date November, 2013 - Initial Version
!> @date January, 2019
!> - nullify mpp structure in multi file structure
!>
!> @param[in] td_multi multi file structure
!-------------------------------------------------------------------
IMPLICIT NONE
! Argument
TYPE(TMULTI), INTENT(INOUT) :: td_multi
! local variable
TYPE(TMULTI) :: tl_multi ! empty multi file structure
! loop indices
!----------------------------------------------------------------
CALL logger_info( " CLEAN: reset multi file " )
IF( ASSOCIATED( td_multi%t_mpp ) )THEN
CALL mpp_clean(td_multi%t_mpp(:))
DEALLOCATE(td_multi%t_mpp)
NULLIFY(td_multi%t_mpp)
ENDIF
! replace by empty structure
td_multi=multi_copy(tl_multi)
END SUBROUTINE multi_clean
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SUBROUTINE multi_print(td_multi)
!-------------------------------------------------------------------
!> @brief This subroutine print some information about mpp strucutre.
!>
!> @author J.Paul
!> @date November, 2013 - Initial Version
!> @date January, 2019
!> - print periodicity
!> @date May, 2019
!> - specify format output
!>
!> @param[in] td_multi multi file structure
!-------------------------------------------------------------------
IMPLICIT NONE
! Argument
TYPE(TMULTI), INTENT(IN) :: td_multi
! local variable
! loop indices
INTEGER(i4) :: ji
INTEGER(i4) :: jj
!----------------------------------------------------------------
! print file
IF( td_multi%i_nmpp /= 0 .AND. ASSOCIATED(td_multi%t_mpp) )THEN
WRITE(*,'(/a,i3)') 'MULTI: total number of file(s): ',&
& td_multi%i_nmpp
WRITE(*,'(6x,a,i3)') ' total number of variable(s): ',&
& td_multi%i_nvar
DO ji=1,td_multi%i_nmpp
WRITE(*,'(3x,3a)') 'FILE ',TRIM(td_multi%t_mpp(ji)%c_name),&
& ' CONTAINS'
DO jj=1,td_multi%t_mpp(ji)%t_proc(1)%i_nvar
IF( ASSOCIATED(td_multi%t_mpp(ji)%t_proc(1)%t_var) )THEN
WRITE(*,'(6x,a)') &
& TRIM(td_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name)
!WRITE(*,'(6x,a,i0)') 'perio ',td_multi%t_mpp(ji)%t_proc(1)%i_perio
ENDIF
ENDDO
ENDDO
ENDIF
END SUBROUTINE multi_print
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SUBROUTINE multi__add_mpp(td_multi, td_mpp)
!-------------------------------------------------------------------
!> @brief
!> This subroutine add file to multi file structure.
!>
!> @detail
!>
!> @author J.Paul
!> @date November, 2013 - Initial Version
!> @date October, 2014
!> - use mpp file structure instead of file
!> @date January, 2019
!> - deallocate mpp structure whatever happens
!>
!> @param[inout] td_multi multi mpp file strcuture
!> @param[in] td_mpp mpp file strcuture
!> @return mpp file id in multi mpp file structure
!-------------------------------------------------------------------
IMPLICIT NONE
! Argument
TYPE(TMULTI), INTENT(INOUT) :: td_multi
TYPE(TMPP) , INTENT(IN) :: td_mpp
! local variable
INTEGER(i4) :: il_status
INTEGER(i4) :: il_mppid
TYPE(TMPP), DIMENSION(:), ALLOCATABLE :: tl_mpp
! loop indices
INTEGER(i4) :: ji
!----------------------------------------------------------------
il_mppid=0
IF( ASSOCIATED(td_multi%t_mpp) )THEN
il_mppid=mpp_get_index(td_multi%t_mpp(:),TRIM(td_mpp%c_name))
ENDIF
IF( il_mppid /= 0 )THEN
CALL logger_debug( " MULTI ADD FILE: mpp file "//TRIM(td_mpp%c_name)//&
& " already in multi mpp file structure")
! add new variable
DO ji=1,td_mpp%t_proc(1)%i_nvar
CALL mpp_add_var(td_multi%t_mpp(il_mppid), td_mpp%t_proc(1)%t_var(ji))
ENDDO
ELSE
CALL logger_trace("MULTI ADD MPP: add mpp "//&
& TRIM(td_mpp%c_name)//" in multi mpp file structure")
IF( td_multi%i_nmpp > 0 )THEN
!
! already other mpp file in multi file structure
ALLOCATE( tl_mpp(td_multi%i_nmpp), stat=il_status )
IF(il_status /= 0 )THEN
CALL logger_error( " MULTI ADD MPP FILE: not enough space to put &
& mpp file in multi mpp file structure")
ELSE
! save temporary multi file structure
tl_mpp(:)=mpp_copy(td_multi%t_mpp(:))
CALL mpp_clean(td_multi%t_mpp(:))
DEALLOCATE( td_multi%t_mpp )
ALLOCATE( td_multi%t_mpp(td_multi%i_nmpp+1), stat=il_status)
IF(il_status /= 0 )THEN
CALL logger_error( " MULTI ADD MPP FILE: not enough space "//&
& "to put mpp file in multi mpp file structure ")
ENDIF
! copy mpp file in multi mpp file before
td_multi%t_mpp(1:td_multi%i_nmpp) = mpp_copy(tl_mpp(:))
! clean
CALL mpp_clean(tl_mpp(:))
ENDIF
DEALLOCATE(tl_mpp)
ELSE
! no file in multi file structure
IF( ASSOCIATED(td_multi%t_mpp) )THEN
CALL mpp_clean(td_multi%t_mpp(:))
DEALLOCATE(td_multi%t_mpp)
ENDIF
ALLOCATE( td_multi%t_mpp(td_multi%i_nmpp+1), stat=il_status )
IF(il_status /= 0 )THEN
CALL logger_error( " MULTI ADD MPP FILE: not enough space "//&
& "to put mpp file in multi mpp file structure " )
ENDIF
ENDIF
! update number of mpp
td_multi%i_nmpp=td_multi%i_nmpp+1
! add new mpp
td_multi%t_mpp(td_multi%i_nmpp)=mpp_copy(td_mpp)
ENDIF
END SUBROUTINE multi__add_mpp
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SUBROUTINE multi__get_perio(cd_file, id_perio)
!-------------------------------------------------------------------
!> @brief
!> This subroutine check if variable file, read in namelist, contains
!> periodicity value and return it if true.
!>
!> @details
!> periodicity value is assume to follow string "perio ="
!>
!> @author J.Paul
!> @date January, 2019 - Initial Version
!> @date August, 209
!> - rewrite function to subroutine
!> - output filename string contains only filename (no more periodicity if
!> given)
!>
!> @param[inout] cd_file file name
!> @param[ out] id_perio NEMO periodicity
!-------------------------------------------------------------------
IMPLICIT NONE
! Argument
CHARACTER(LEN=*), INTENT(INOUT) :: cd_file
INTEGER(i4) , INTENT( OUT) :: id_perio
! local variable
CHARACTER(LEN=lc) :: cl_tmp
CHARACTER(LEN=lc) :: cl_perio
INTEGER(i4) :: il_ind
! loop indices
INTEGER(i4) :: ji
INTEGER(i4) :: jj
!----------------------------------------------------------------
! init
cl_perio=''
id_perio=-1
ji=1
cl_tmp=fct_split(cd_file,ji,';')
DO WHILE( TRIM(cl_tmp) /= '' )
il_ind=INDEX(TRIM(cl_tmp),'perio')
IF( il_ind /= 0 )THEN
! check character just after
jj=il_ind+LEN('perio')
IF( TRIM(cl_tmp(jj:jj)) == ' ' .OR. &
& TRIM(cl_tmp(jj:jj)) == '=' )THEN
cl_perio=fct_split(cl_tmp,2,'=')
EXIT
ENDIF
ENDIF
ji=ji+1
cl_tmp=fct_split(cd_file,ji,';')
ENDDO
cd_file=fct_split(cd_file,1,';')
IF( TRIM(cl_perio) /= '' )THEN
IF( fct_is_num(cl_perio) )THEN
READ(cl_perio,*) id_perio
CALL logger_debug("MULTI GET PERIO: will use periodicity value of "//&
& TRIM(fct_str(id_perio))//" for file "//TRIM(cd_file) )
ELSE
CALL logger_error("MULTI GET PERIO: invalid periodicity value ("//&
& TRIM(cl_perio)//") for file "//TRIM(cd_file)//&
& ". check namelist." )
ENDIF
ENDIF
END SUBROUTINE multi__get_perio
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
END MODULE multi