New URL for NEMO forge! http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.

multi.f90 in utils/tools/SIREN/src – NEMO

Context Navigation

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

Last change on this file since 12080 was 12080, checked in by jpaul, 4 years 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	!----------------------------------------------------------------------
66	MODULE 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
105	CONTAINS
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	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
718	END MODULE multi
719

Note: See TracBrowser for help on using the repository browser.

Download in other formats: