source: utils/tools/SIREN/src/multi.f90 @ 12080

Last change on this file since 12080 was 12080, checked in by jpaul, 10 months ago

update nemo trunk

File size: 23.9 KB
Line 
1!----------------------------------------------------------------------
2! NEMO system team, System and Interface for oceanic RElocable Nesting
3!----------------------------------------------------------------------
4!
5! DESCRIPTION:
6!> This module manage multi file structure.
7!>
8!> @details
9!>    define type TMULTI:<br/>
10!> @code
11!>    TYPE(TMULTI) :: tl_multi
12!> @endcode
13!>
14!>    to initialize a multi-file structure:<br/>
15!> @code
16!>    tl_multi=multi_init(cd_varfile(:))
17!> @endcode
18!>       - cd_varfile : array of variable with file path
19!>       ('var1:file1','var2:file2')<br/>
20!>          file path could be replaced by a matrix of value.<br/>
21!>          separators used to defined matrix are:
22!>             - ',' for line
23!>             - '/' for row
24!>             - '\' for level<br/>
25!>             Example:<br/>
26!>                - 'var1:3,2,3/1,4,5'
27!>                - 3,2,3/1,4,5  => 
28!>                      @f$ \left( \begin{array}{ccc}
29!>                           3 & 2 & 3 \\
30!>                           1 & 4 & 5 \end{array} \right) @f$<br/>
31!>
32!>    to get the number of mpp file in mutli file structure:<br/>
33!>    - tl_multi\%i_nmpp
34!>
35!>    to get the total number of variable in mutli file structure:<br/>
36!>    - tl_multi\%i_nvar
37!>
38!>    @note number of variable and number of file could differ cause several variable
39!>    could be in the same file.
40!>
41!>    to get array of mpp structure in mutli file structure:<br/>
42!>    - tl_multi\%t_mpp(:)
43!>
44!>    to print information about multi structure:<br/>
45!> @code
46!>    CALL multi_print(td_multi)
47!> @endcode
48!>
49!>    to clean multi file strucutre:<br/>
50!> @code
51!>    CALL multi_clean(td_multi)
52!> @endcode
53!>       - td_multi is multi file structure
54!>
55!> @author
56!>  J.Paul
57!>
58!> @date November, 2013 - Initial Version
59!> @date October, 2014
60!> - use mpp file structure instead of file
61!> @date November, 2014
62!> - Fix memory leaks bug
63!>
64!> @note Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
65!----------------------------------------------------------------------
66MODULE multi
67
68   USE kind                            ! F90 kind parameter
69   USE logger                          ! log file manager
70   USE fct                             ! basic useful function
71   USE dim                             ! dimension manager
72   USE var                             ! variable manager
73   USE file                            ! file manager
74   USE iom                             ! I/O manager
75   USE mpp                             ! MPP manager
76   USE iom_mpp                         ! MPP I/O manager
77
78   IMPLICIT NONE
79   ! NOTE_avoid_public_variables_if_possible
80
81   ! type and variable
82   PUBLIC :: TMULTI       !< multi file structure
83
84   ! function and subroutine
85   PUBLIC :: multi_copy        !< copy multi structure
86   PUBLIC :: multi_init        !< initialise multi structure
87   PUBLIC :: multi_clean       !< clean multi strcuture
88   PUBLIC :: multi_print       !< print information about milti structure
89
90   PRIVATE :: multi__add_mpp   !< add file strucutre to multi file structure
91   PRIVATE :: multi__copy_unit !< copy multi file structure
92   PRIVATE :: multi__get_perio !< read periodicity from namelist
93
94   TYPE TMULTI !< multi file structure
95      ! general
96      INTEGER(i4)                         :: i_nmpp  = 0         !< number of mpp files
97      INTEGER(i4)                         :: i_nvar  = 0         !< total number of variables
98      TYPE(TMPP) , DIMENSION(:), POINTER  :: t_mpp => NULL()     !< mpp files composing multi
99   END TYPE
100
101   INTERFACE multi_copy
102      MODULE PROCEDURE multi__copy_unit   ! copy multi file structure
103   END INTERFACE   
104
105CONTAINS
106   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
107   FUNCTION multi__copy_unit(td_multi) &
108         & RESULT (tf_multi)
109   !-------------------------------------------------------------------
110   !> @brief
111   !> This function copy multi mpp structure in another one
112   !> @details
113   !> file variable value are copied in a temporary array,
114   !> so input and output file structure value do not point on the same
115   !> "memory cell", and so on are independant.
116   !>
117   !> @warning do not use on the output of a function who create or read an
118   !> attribute (ex: tl_att=att_copy(att_init()) is forbidden).
119   !> This will create memory leaks.
120   !> @warning to avoid infinite loop, do not use any function inside
121   !> this subroutine
122   !>   
123   !> @author J.Paul
124   !> @date November, 2013 - Initial Version
125   !> @date November, 2014
126   !>    - use function instead of overload assignment operator (to avoid memory leak)
127   !>
128   !> @param[in] td_multi    mpp structure
129   !> @return copy of input multi structure
130   !-------------------------------------------------------------------
131
132      IMPLICIT NONE
133
134      ! Argument
135      TYPE(TMULTI), INTENT(IN)  :: td_multi
136
137      ! function
138      TYPE(TMULTI)              :: tf_multi
139
140      ! local variable
141      TYPE(TMPP) :: tl_mpp
142
143      ! loop indices
144      INTEGER(i4) :: ji
145      !----------------------------------------------------------------
146
147      tf_multi%i_nmpp = td_multi%i_nmpp
148      tf_multi%i_nvar = td_multi%i_nvar
149
150      ! copy variable structure
151      IF( ASSOCIATED(tf_multi%t_mpp) )THEN
152         CALL mpp_clean(tf_multi%t_mpp(:))
153         DEALLOCATE(tf_multi%t_mpp)
154      ENDIF
155      IF( ASSOCIATED(td_multi%t_mpp) .AND. tf_multi%i_nmpp > 0 )THEN
156         ALLOCATE( tf_multi%t_mpp(tf_multi%i_nmpp) )
157         DO ji=1,tf_multi%i_nmpp
158            tl_mpp = mpp_copy(td_multi%t_mpp(ji))
159            tf_multi%t_mpp(ji) = mpp_copy(tl_mpp)
160         ENDDO
161         ! clean
162         CALL mpp_clean(tl_mpp)
163      ENDIF
164
165   END FUNCTION multi__copy_unit
166   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
167   FUNCTION multi_init(cd_varfile) &
168         & RESULT (tf_multi)
169   !-------------------------------------------------------------------
170   !> @brief This subroutine initialize multi file structure.
171   !>
172   !> @details
173   !> if variable name is 'all', add all the variable of the file in mutli file
174   !> structure.
175   !> Optionnaly, periodicity could be read behind filename.
176   !>
177   !> @note if first character of filename is numeric, assume matrix is given as
178   !> input.<br/>
179   !> create pseudo file named 'data-*', with matrix read as variable value.
180   !>
181   !> @author J.Paul
182   !> @date November, 2013 - Initial Version
183   !> @date July, 2015
184   !> - check if variable to be read is in file
185   !> @date January, 2016
186   !> - read variable dimensions
187   !> @date July, 2016
188   !> - get variable to be read and associated file first
189   !> @date August, 2017
190   !> - get perio from namelist
191   !> @date January, 2019
192   !> - create and clean file structure to avoid memory leaks
193   !> - fill value read from array of variable structure
194   !> @date May, 2019
195   !> - compare each elt of cl_tabfile to cl_file
196   !> @date August, 2019
197   !> - use periodicity read from namelist, and store in multi structure
198   !>
199   !> @param[in] cd_varfile   variable location information (from namelist)
200   !> @return multi file structure
201   !-------------------------------------------------------------------
202
203      IMPLICIT NONE
204
205      ! Argument
206      CHARACTER(LEN=*), DIMENSION(:), INTENT(IN) :: cd_varfile
207
208      ! function
209      TYPE(TMULTI)                               :: tf_multi
210
211      ! parameters
212      INTEGER(i4)   , PARAMETER        :: ip_nmaxfiles = 50
213      INTEGER(i4)   , PARAMETER        :: ip_nmaxvars = 100
214
215      ! local variable
216      INTEGER(i4)                                             :: il_nvar
217      INTEGER(i4)                                             :: il_nvarin
218      INTEGER(i4)                                             :: il_nfiles
219      INTEGER(i4)                                             :: il_varid
220      INTEGER(i4)                                             :: il_perio
221
222      REAL(dp)                                                :: dl_fill
223      CHARACTER(LEN=lc)                                       :: cl_name
224      CHARACTER(LEN=lc)                                       :: cl_varname
225      CHARACTER(LEN=lc)                                       :: cl_lower
226      CHARACTER(LEN=lc)                                       :: cl_file
227      CHARACTER(LEN=lc)                                       :: cl_matrix
228
229      CHARACTER(LEN=lc), DIMENSION(ip_nmaxfiles)              :: cl_tabfile
230      CHARACTER(LEN=lc), DIMENSION(ip_nmaxfiles, ip_nmaxvars) :: cl_tabvar
231
232      LOGICAL                                                 :: ll_dim
233
234      TYPE(TDIM), DIMENSION(ip_maxdim)                        :: tl_dim
235
236      TYPE(TVAR)                                              :: tl_var
237      TYPE(TVAR) , DIMENSION(:), ALLOCATABLE                  :: tl_varin
238
239      TYPE(TMPP)                                              :: tl_mpp
240
241      TYPE(TFILE)                                             :: tl_file
242
243      ! loop indices
244      INTEGER(i4) :: ji
245      INTEGER(i4) :: jj
246      INTEGER(i4) :: jk
247      INTEGER(i4) :: jl
248      INTEGER(i4) :: jf
249      INTEGER(i4) , DIMENSION(ip_nmaxvars) :: jv
250      !----------------------------------------------------------------
251
252      ji=1
253      jf=0
254      jv(:)=0
255      cl_tabfile(:)=''
256      DO WHILE( TRIM(cd_varfile(ji)) /= '' )
257
258         cl_name=fct_split(cd_varfile(ji),1,':')
259         IF( TRIM(cl_name) == '' )THEN
260            CALL logger_error("MULTI INIT: variable name "//&
261            &                 "is empty. check namelist.")
262         ENDIF
263
264         cl_file=fct_split(cd_varfile(ji),2,':')
265         IF( TRIM(cl_file) == '' )THEN
266            CALL logger_error("MULTI INIT: file name matching variable "//&
267            &                 TRIM(cl_name)//" is empty. check namelist.")
268         ENDIF
269         IF( LEN(TRIM(cl_file)) >= lc )THEN
270            CALL logger_fatal("MULTI INIT: file name too long (>"//&
271            &          TRIM(fct_str(lc))//"). check namelist.")
272         ENDIF
273         
274         IF( TRIM(cl_file) /= '' )THEN
275            jk=0
276            DO jj=1,jf
277               IF( TRIM(cl_file) == TRIM(cl_tabfile(jj)) )THEN           
278                  jk=jj
279                  EXIT
280               ENDIF
281            ENDDO
282            IF ( jk /= 0 )then
283               jv(jk)=jv(jk)+1
284               cl_tabvar(jk,jv(jk))=TRIM(cl_name)
285            ELSE ! jk == 0
286               jf=jf+1
287               IF( jf > ip_nmaxfiles )THEN
288                  CALL logger_fatal("MULTI INIT: too much files in "//&
289                  &  "varfile (>"//TRIM(fct_str(ip_nmaxfiles))//&
290                  &  "). check namelist.")
291               ENDIF
292               cl_tabfile(jf)=TRIM(cl_file)
293               jv(jf)=jv(jf)+1
294               cl_tabvar(jf,jv(jf))=TRIM(cl_name)
295            ENDIF
296         ENDIF
297
298         ji=ji+1
299      ENDDO
300
301!print *,'============'
302!print *,jf,' files ','============'
303!DO ji=1,jf
304!   print *,'file ',trim(cl_tabfile(ji))
305!   print *,jv(ji),' vars '
306!   DO jj=1,jv(ji)
307!      print *,'var ',trim(cl_tabvar(ji,jj))
308!   ENDDO
309!ENDDO
310!print *,'============'
311
312
313      il_nfiles=jf
314      il_nvar=0
315      DO ji=1,il_nfiles
316         cl_file=TRIM(cl_tabfile(ji))
317
318         cl_matrix=''
319         IF( fct_is_num(cl_file(1:1)) )THEN
320            cl_matrix=TRIM(cl_file)
321            WRITE(cl_file,'(a,i2.2)')'data-',ji
322
323            DO jj=1,jv(ji)
324               cl_name=TRIM(cl_tabvar(ji,jv(ji)))
325               cl_lower=TRIM(fct_lower(cl_name))
326
327               tl_var=var_init(TRIM(cl_name))
328               CALL var_read_matrix(tl_var, cl_matrix)
329
330               IF( jj == 1 )THEN
331                  ! create mpp structure
332                  tl_mpp=mpp_init(TRIM(cl_file), tl_var)
333               ENDIF
334
335               ! add variable
336               CALL mpp_add_var(tl_mpp,tl_var)
337               ! number of variable
338               il_nvar=il_nvar+1
339
340            ENDDO
341
342         ELSE
343            CALL multi__get_perio(cl_file, il_perio)
344
345            tl_file=file_init(TRIM(cl_file), id_perio=il_perio)
346            tl_mpp=mpp_init( tl_file, id_perio=il_perio )
347            ! clean
348            CALL file_clean(tl_file)
349
350            il_nvarin=tl_mpp%t_proc(1)%i_nvar
351            ALLOCATE(tl_varin(il_nvarin))
352            DO jj=1,il_nvarin
353               tl_varin(jj)=var_copy(tl_mpp%t_proc(1)%t_var(jj))
354               DO jl=1,ip_maxdim
355                  IF( tl_varin(jj)%t_dim(jl)%l_use )THEN
356                     tl_varin(jj)%t_dim(jl)=dim_copy(tl_mpp%t_dim(jl))
357                  ENDIF
358               ENDDO
359            ENDDO
360
361            ! clean all varible
362            CALL mpp_del_var(tl_mpp)
363
364            DO jj=1,jv(ji)
365               cl_name=TRIM(cl_tabvar(ji,jj))
366               cl_lower=TRIM(fct_lower(cl_name))
367               ! define variable
368               IF( TRIM(fct_lower(cl_lower)) /= 'all' )THEN
369
370                  ! check if variable is in file
371                  il_varid=var_get_index(tl_varin(:),cl_lower)
372                  IF( il_varid == 0 )THEN
373                     CALL logger_fatal("MULTI INIT: variable "//&
374                        & TRIM(cl_name)//" not in file "//&
375                        & TRIM(cl_file) )
376                  ENDIF
377
378                  ! get (global) variable dimension
379                  tl_dim(jp_I)=dim_copy(tl_varin(il_varid)%t_dim(jp_I))
380                  tl_dim(jp_J)=dim_copy(tl_varin(il_varid)%t_dim(jp_J))
381                  tl_dim(jp_K)=dim_copy(tl_varin(il_varid)%t_dim(jp_K))
382                  tl_dim(jp_L)=dim_copy(tl_varin(il_varid)%t_dim(jp_L))
383
384                  cl_varname=tl_varin(il_varid)%c_name
385                  dl_fill=tl_varin(il_varid)%d_fill
386
387                  tl_var=var_init(TRIM(cl_varname), td_dim=tl_dim(:), &
388                     &            dd_fill=dl_fill)
389
390                  ! add variable
391                  CALL mpp_add_var(tl_mpp,tl_var)
392
393                  ! number of variable
394                  il_nvar=il_nvar+1
395
396                  ! clean structure
397                  CALL var_clean(tl_var)
398
399               ELSE ! cl_lower == 'all'
400
401                  DO jk=il_nvarin,1,-1
402
403                     ! check if variable is dimension
404                     ll_dim=.FALSE.
405                     DO jl=1,ip_maxdim
406                        IF( TRIM(tl_mpp%t_proc(1)%t_dim(jl)%c_name) == &
407                        &   TRIM(tl_varin(jk)%c_name) )THEN
408                           ll_dim=.TRUE.
409                           CALL logger_trace("MULTI INIT: "//&
410                           &  TRIM(tl_varin(jk)%c_name)//&
411                           &  ' is var dimension')
412                           EXIT
413                        ENDIF
414                     ENDDO
415                     ! do not use variable dimension
416                     IF( ll_dim )THEN
417                        tl_var=var_init( TRIM(tl_varin(jk)%c_name) )
418                        ! delete variable
419                        CALL mpp_del_var(tl_mpp,tl_var)
420                        ! clean structure
421                        CALL var_clean(tl_var)
422                     ELSE
423                        ! add variable
424                        CALL mpp_add_var(tl_mpp, tl_varin(jk))
425                        ! number of variable
426                        il_nvar=il_nvar+1
427                     ENDIF
428
429                  ENDDO
430
431               ENDIF
432            ENDDO
433            ! clean structure
434            CALL var_clean(tl_varin)
435            DEALLOCATE(tl_varin)
436
437         ENDIF
438
439         CALL multi__add_mpp(tf_multi, tl_mpp)
440
441         ! update total number of variable
442         tf_multi%i_nvar=tf_multi%i_nvar+tl_mpp%t_proc(1)%i_nvar
443
444         ! clean
445         CALL mpp_clean(tl_mpp)
446
447      ENDDO
448
449   END FUNCTION multi_init
450   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
451   SUBROUTINE multi_clean(td_multi)
452   !-------------------------------------------------------------------
453   !> @brief This subroutine clean multi file strucutre.
454   !>
455   !> @author J.Paul
456   !> @date November, 2013 - Initial Version
457   !> @date January, 2019
458   !> - nullify mpp structure in multi file structure
459   !>
460   !> @param[in] td_multi  multi file structure
461   !-------------------------------------------------------------------
462
463      IMPLICIT NONE
464
465      ! Argument     
466      TYPE(TMULTI), INTENT(INOUT) :: td_multi
467
468      ! local variable
469      TYPE(TMULTI) :: tl_multi ! empty multi file structure
470
471      ! loop indices
472      !----------------------------------------------------------------
473
474      CALL logger_info( " CLEAN: reset multi file " )
475
476      IF( ASSOCIATED( td_multi%t_mpp ) )THEN
477         CALL mpp_clean(td_multi%t_mpp(:))
478         DEALLOCATE(td_multi%t_mpp)
479         NULLIFY(td_multi%t_mpp)
480      ENDIF
481
482      ! replace by empty structure
483      td_multi=multi_copy(tl_multi)
484
485   END SUBROUTINE multi_clean
486   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
487   SUBROUTINE multi_print(td_multi)
488   !-------------------------------------------------------------------
489   !> @brief This subroutine print some information about mpp strucutre.
490   !>
491   !> @author J.Paul
492   !> @date November, 2013 - Initial Version
493   !> @date January, 2019
494   !> - print periodicity
495   !> @date May, 2019
496   !> - specify format output
497   !>
498   !> @param[in] td_multi multi file structure
499   !-------------------------------------------------------------------
500
501      IMPLICIT NONE
502
503      ! Argument     
504      TYPE(TMULTI), INTENT(IN) :: td_multi
505
506      ! local variable
507
508      ! loop indices
509      INTEGER(i4) :: ji
510      INTEGER(i4) :: jj
511      !----------------------------------------------------------------
512
513      ! print file
514      IF( td_multi%i_nmpp /= 0 .AND. ASSOCIATED(td_multi%t_mpp) )THEN
515         WRITE(*,'(/a,i3)') 'MULTI: total number of file(s): ',&
516         &  td_multi%i_nmpp
517         WRITE(*,'(6x,a,i3)') ' total number of variable(s): ',&
518         &  td_multi%i_nvar
519         DO ji=1,td_multi%i_nmpp
520            WRITE(*,'(3x,3a)') 'FILE ',TRIM(td_multi%t_mpp(ji)%c_name),&
521            & ' CONTAINS'
522            DO jj=1,td_multi%t_mpp(ji)%t_proc(1)%i_nvar
523               IF( ASSOCIATED(td_multi%t_mpp(ji)%t_proc(1)%t_var) )THEN
524                  WRITE(*,'(6x,a)') &
525                  &  TRIM(td_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name)
526                  !WRITE(*,'(6x,a,i0)') 'perio ',td_multi%t_mpp(ji)%t_proc(1)%i_perio
527               ENDIF
528            ENDDO
529         ENDDO
530      ENDIF
531
532   END SUBROUTINE multi_print
533   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
534   SUBROUTINE multi__add_mpp(td_multi, td_mpp)
535   !-------------------------------------------------------------------
536   !> @brief
537   !>    This subroutine add file to multi file structure.
538   !>
539   !> @detail
540   !>
541   !> @author J.Paul
542   !> @date November, 2013 - Initial Version
543   !> @date October, 2014
544   !> - use mpp file structure instead of file
545   !> @date January, 2019
546   !> - deallocate mpp structure whatever happens
547   !>
548   !> @param[inout] td_multi  multi mpp file strcuture
549   !> @param[in]    td_mpp    mpp file strcuture
550   !> @return mpp file id in multi mpp file structure
551   !-------------------------------------------------------------------
552     
553      IMPLICIT NONE
554
555      ! Argument
556      TYPE(TMULTI), INTENT(INOUT) :: td_multi
557      TYPE(TMPP)  , INTENT(IN)    :: td_mpp
558
559      ! local variable
560      INTEGER(i4) :: il_status
561      INTEGER(i4) :: il_mppid
562     
563      TYPE(TMPP), DIMENSION(:), ALLOCATABLE :: tl_mpp
564
565      ! loop indices
566      INTEGER(i4) :: ji
567      !----------------------------------------------------------------
568
569      il_mppid=0
570      IF( ASSOCIATED(td_multi%t_mpp) )THEN
571         il_mppid=mpp_get_index(td_multi%t_mpp(:),TRIM(td_mpp%c_name))
572      ENDIF
573
574      IF( il_mppid /= 0 )THEN
575
576            CALL logger_debug( " MULTI ADD FILE: mpp file "//TRIM(td_mpp%c_name)//&
577            &               " already in multi mpp file structure")
578
579            ! add new variable
580            DO ji=1,td_mpp%t_proc(1)%i_nvar
581               CALL mpp_add_var(td_multi%t_mpp(il_mppid), td_mpp%t_proc(1)%t_var(ji))
582            ENDDO
583
584      ELSE
585 
586         CALL logger_trace("MULTI ADD MPP: add mpp "//&
587         &               TRIM(td_mpp%c_name)//" in multi mpp file structure")
588
589         IF( td_multi%i_nmpp > 0 )THEN
590            !
591            ! already other mpp file in multi file structure
592            ALLOCATE( tl_mpp(td_multi%i_nmpp), stat=il_status )
593            IF(il_status /= 0 )THEN
594
595               CALL logger_error( " MULTI ADD MPP FILE: not enough space to put &
596               &               mpp file in multi mpp file structure")
597
598            ELSE
599               ! save temporary multi file structure
600               tl_mpp(:)=mpp_copy(td_multi%t_mpp(:))
601
602               CALL mpp_clean(td_multi%t_mpp(:))
603               DEALLOCATE( td_multi%t_mpp )
604               ALLOCATE( td_multi%t_mpp(td_multi%i_nmpp+1), stat=il_status)
605               IF(il_status /= 0 )THEN
606
607                  CALL logger_error( " MULTI ADD MPP FILE: not enough space "//&
608                  &  "to put mpp file in multi mpp file structure ")
609
610               ENDIF
611
612               ! copy mpp file in multi mpp file before
613               td_multi%t_mpp(1:td_multi%i_nmpp) = mpp_copy(tl_mpp(:))
614
615               ! clean
616               CALL mpp_clean(tl_mpp(:))
617            ENDIF
618            DEALLOCATE(tl_mpp)
619
620         ELSE
621            ! no file in multi file structure
622            IF( ASSOCIATED(td_multi%t_mpp) )THEN
623               CALL mpp_clean(td_multi%t_mpp(:))
624               DEALLOCATE(td_multi%t_mpp)
625            ENDIF
626            ALLOCATE( td_multi%t_mpp(td_multi%i_nmpp+1), stat=il_status )
627            IF(il_status /= 0 )THEN
628
629               CALL logger_error( " MULTI ADD MPP FILE: not enough space "//&
630               &  "to put mpp file in multi mpp file structure " )
631
632            ENDIF
633         ENDIF
634
635         ! update number of mpp
636         td_multi%i_nmpp=td_multi%i_nmpp+1
637
638         ! add new mpp
639         td_multi%t_mpp(td_multi%i_nmpp)=mpp_copy(td_mpp)
640
641      ENDIF
642
643   END SUBROUTINE multi__add_mpp
644   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
645   SUBROUTINE multi__get_perio(cd_file, id_perio)
646   !-------------------------------------------------------------------
647   !> @brief
648   !> This subroutine check if variable file, read in namelist, contains
649   !> periodicity value and return it if true.
650   !>
651   !> @details
652   !> periodicity value is assume to follow string "perio ="
653   !>
654   !> @author J.Paul
655   !> @date January, 2019 - Initial Version
656   !> @date August, 209
657   !> - rewrite function to subroutine
658   !> - output filename string contains only filename (no more periodicity if
659   !> given)
660   !>
661   !> @param[inout] cd_file    file name
662   !> @param[  out] id_perio   NEMO periodicity
663   !-------------------------------------------------------------------
664
665      IMPLICIT NONE
666
667      ! Argument
668      CHARACTER(LEN=*), INTENT(INOUT) :: cd_file
669      INTEGER(i4)     , INTENT(  OUT) :: id_perio
670
671      ! local variable
672      CHARACTER(LEN=lc) :: cl_tmp
673      CHARACTER(LEN=lc) :: cl_perio
674 
675      INTEGER(i4)       :: il_ind
676
677      ! loop indices
678      INTEGER(i4) :: ji
679      INTEGER(i4) :: jj
680      !----------------------------------------------------------------
681
682      ! init
683      cl_perio=''
684      id_perio=-1
685
686      ji=1
687      cl_tmp=fct_split(cd_file,ji,';')
688      DO WHILE( TRIM(cl_tmp) /= '' )
689         il_ind=INDEX(TRIM(cl_tmp),'perio')
690         IF( il_ind /= 0 )THEN
691            ! check character just after
692            jj=il_ind+LEN('perio')
693            IF(  TRIM(cl_tmp(jj:jj)) == ' ' .OR. &
694            &    TRIM(cl_tmp(jj:jj)) == '=' )THEN
695               cl_perio=fct_split(cl_tmp,2,'=')
696               EXIT
697            ENDIF
698         ENDIF
699         ji=ji+1
700         cl_tmp=fct_split(cd_file,ji,';')         
701      ENDDO
702      cd_file=fct_split(cd_file,1,';')
703
704      IF( TRIM(cl_perio) /= '' )THEN
705         IF( fct_is_num(cl_perio) )THEN
706            READ(cl_perio,*) id_perio
707            CALL logger_debug("MULTI GET PERIO: will use periodicity value of "//&
708            &  TRIM(fct_str(id_perio))//" for file "//TRIM(cd_file) )
709         ELSE
710            CALL logger_error("MULTI GET PERIO: invalid periodicity value ("//&
711               & TRIM(cl_perio)//") for file "//TRIM(cd_file)//&
712               & ". check namelist." )
713         ENDIF
714      ENDIF
715
716   END SUBROUTINE multi__get_perio
717   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
718END MODULE multi
719
Note: See TracBrowser for help on using the repository browser.