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 branches/2016/dev_INGV_UKMO_2016/NEMOGCM/TOOLS/SIREN/src – NEMO

Context Navigation

source: branches/2016/dev_INGV_UKMO_2016/NEMOGCM/TOOLS/SIREN/src/multi.f90 @ 7351

Last change on this file since 7351 was 7351, checked in by emanuelaclementi, 7 years ago
ticket #1805 step 3: /2016/dev_INGV_UKMO_2016 aligned to the trunk at revision 7161
File size: 17.1 KB

Line
1	!----------------------------------------------------------------------
2	! NEMO system team, System and Interface for oceanic RElocable Nesting
3	!----------------------------------------------------------------------
4	!
5	! MODULE: multi
6	!
7	! DESCRIPTION:
8	!> This module manage multi file structure.
9	!
10	!> @details
11	!> define type TMULTI:<br/>
12	!> @code
13	!> TYPE(TMULTI) :: tl_multi
14	!> @endcode
15	!>
16	!> to initialize a multi-file structure:<br/>
17	!> @code
18	!> tl_multi=multi_init(cd_varfile(:))
19	!> @endcode
20	!> - cd_varfile : array of variable with file path
21	!> ('var1:file1','var2:file2')<br/>
22	!> file path could be replaced by a matrix of value.<br/>
23	!> separators used to defined matrix are:
24	!> - ',' for line
25	!> - '/' for row
26	!> - '\' for level<br/>
27	!> Example:<br/>
28	!> - 'var1:3,2,3/1,4,5'
29	!> - 3,2,3/1,4,5 =>
30	!> @f$ \left( \begin{array}{ccc}
31	!> 3 & 2 & 3 \\
32	!> 1 & 4 & 5 \end{array} \right) @f$<br/>
33	!>
34	!> to get the number of mpp file in mutli file structure:<br/>
35	!> - tl_multi\%i_nmpp
36	!>
37	!> to get the total number of variable in mutli file structure:<br/>
38	!> - tl_multi\%i_nvar
39	!>
40	!> @note number of variable and number of file could differ cause several variable
41	!> could be in the same file.
42	!>
43	!> to get array of mpp structure in mutli file structure:<br/>
44	!> - tl_multi\%t_mpp(:)
45	!>
46	!> to print information about multi structure:<br/>
47	!> @code
48	!> CALL multi_print(td_multi)
49	!> @endcode
50	!>
51	!> to clean multi file strucutre:<br/>
52	!> @code
53	!> CALL multi_clean(td_multi)
54	!> @endcode
55	!> - td_multi is multi file structure
56	!>
57	!> @author
58	!> J.Paul
59	! REVISION HISTORY:
60	!> @date November, 2013 - Initial Version
61	!> @date October, 2014
62	!> - use mpp file structure instead of file
63	!> @date November, 2014
64	!> - Fix memory leaks bug
65	!
66	!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
67	!----------------------------------------------------------------------
68	MODULE multi
69	USE kind ! F90 kind parameter
70	USE logger ! log file manager
71	USE fct ! basic useful function
72	USE dim ! dimension manager
73	USE var ! variable manager
74	USE file ! file manager
75	USE iom ! I/O manager
76	USE mpp ! MPP manager
77	USE iom_mpp ! MPP I/O manager
78
79	IMPLICIT NONE
80	! NOTE_avoid_public_variables_if_possible
81
82	! type and variable
83	PUBLIC :: TMULTI !< multi file structure
84
85	! function and subroutine
86	PUBLIC :: multi_copy !< copy multi structure
87	PUBLIC :: multi_init !< initialise multi structure
88	PUBLIC :: multi_clean !< clean multi strcuture
89	PUBLIC :: multi_print !< print information about milti structure
90
91	PUBLIC :: multi__add_mpp !< add file strucutre to multi file structure
92	PRIVATE :: multi__copy_unit !< copy multi file structure
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	!> @brief
108	!> This function copy multi mpp structure in another one
109	!> @details
110	!> file variable value are copied in a temporary array,
111	!> so input and output file structure value do not point on the same
112	!> "memory cell", and so on are independant.
113	!>
114	!> @warning do not use on the output of a function who create or read an
115	!> attribute (ex: tl_att=att_copy(att_init()) is forbidden).
116	!> This will create memory leaks.
117	!> @warning to avoid infinite loop, do not use any function inside
118	!> this subroutine
119	!>
120	!> @author J.Paul
121	!> @date November, 2013 - Initial Version
122	!> @date November, 2014
123	!> - use function instead of overload assignment operator (to avoid memory leak)
124	!>
125	!> @param[in] td_multi mpp structure
126	!> @return copy of input multi structure
127	!-------------------------------------------------------------------
128	FUNCTION multi__copy_unit( td_multi )
129	IMPLICIT NONE
130	! Argument
131	TYPE(TMULTI), INTENT(IN) :: td_multi
132	! function
133	TYPE(TMULTI) :: multi__copy_unit
134
135	! local variable
136	TYPE(TMPP) :: tl_mpp
137
138	! loop indices
139	INTEGER(i4) :: ji
140	!----------------------------------------------------------------
141
142	multi__copy_unit%i_nmpp = td_multi%i_nmpp
143	multi__copy_unit%i_nvar = td_multi%i_nvar
144
145	! copy variable structure
146	IF( ASSOCIATED(multi__copy_unit%t_mpp) )THEN
147	CALL mpp_clean(multi__copy_unit%t_mpp(:))
148	DEALLOCATE(multi__copy_unit%t_mpp)
149	ENDIF
150	IF( ASSOCIATED(td_multi%t_mpp) .AND. multi__copy_unit%i_nmpp > 0 )THEN
151	ALLOCATE( multi__copy_unit%t_mpp(multi__copy_unit%i_nmpp) )
152	DO ji=1,multi__copy_unit%i_nmpp
153	tl_mpp = mpp_copy(td_multi%t_mpp(ji))
154	multi__copy_unit%t_mpp(ji) = mpp_copy(tl_mpp)
155	ENDDO
156	! clean
157	CALL mpp_clean(tl_mpp)
158	ENDIF
159
160	END FUNCTION multi__copy_unit
161	!-------------------------------------------------------------------
162	!> @brief This subroutine initialize multi file structure.
163	!>
164	!> @details
165	!> if variable name is 'all', add all the variable of the file in mutli file
166	!> structure.
167	!> @note if first character of filename is numeric, assume matrix is given as
168	!> input.<br/>
169	!> create pseudo file named 'data-*', with matrix read as variable value.
170	!>
171	!> @author J.Paul
172	!> @date November, 2013 - Initial Version
173	!> @date July, 2015
174	!> - check if variable to be read is in file
175	!> @date January, 2016
176	!> - read variable dimensions
177	!>
178	!> @param[in] cd_varfile variable location information (from namelist)
179	!> @return multi file structure
180	!-------------------------------------------------------------------
181	FUNCTION multi_init(cd_varfile)
182	IMPLICIT NONE
183
184	! Argument
185	CHARACTER(LEN=*), DIMENSION(:), INTENT(IN) :: cd_varfile
186
187	! function
188	TYPE(TMULTI) :: multi_init
189
190	! local variable
191	CHARACTER(LEN=lc) :: cl_name
192	CHARACTER(LEN=lc) :: cl_lower
193	CHARACTER(LEN=lc) :: cl_file
194	CHARACTER(LEN=lc) :: cl_matrix
195
196	INTEGER(i4) :: il_nvar
197	INTEGER(i4) :: il_varid
198
199	LOGICAL :: ll_dim
200
201	TYPE(TDIM), DIMENSION(ip_maxdim) :: tl_dim
202
203	TYPE(TVAR) :: tl_var
204
205	TYPE(TMPP) :: tl_mpp
206
207	! loop indices
208	INTEGER(i4) :: ji
209	INTEGER(i4) :: jj
210	INTEGER(i4) :: jk
211	!----------------------------------------------------------------
212
213	ji=1
214	DO WHILE( TRIM(cd_varfile(ji)) /= '' )
215
216	il_nvar=0
217	cl_name=fct_split(cd_varfile(ji),1,':')
218	cl_lower=fct_lower(cl_name)
219	cl_file=fct_split(cd_varfile(ji),2,':')
220
221	IF( LEN(TRIM(cl_file)) == lc )THEN
222	CALL logger_fatal("MULTI INIT: file name too long (>"//&
223	& TRIM(fct_str(lc))//"). check namelist.")
224	ENDIF
225
226	IF( TRIM(cl_lower) /= '' )THEN
227	IF( TRIM(cl_file) /= '' )THEN
228	cl_matrix=''
229	IF( fct_is_num(cl_file(1:1)) )THEN
230	cl_matrix=TRIM(cl_file)
231	WRITE(cl_file,'(a,i2.2)')'data-',ji
232
233	tl_var=var_init(TRIM(cl_name))
234	CALL var_read_matrix(tl_var, cl_matrix)
235
236	! create mpp structure
237	tl_mpp=mpp_init(TRIM(cl_file), tl_var)
238
239	! add variable
240	CALL mpp_add_var(tl_mpp,tl_var)
241
242	! number of variable
243	il_nvar=il_nvar+1
244
245	ELSE
246
247	!
248	tl_mpp=mpp_init( file_init(TRIM(cl_file)) )
249	! define variable
250	IF( TRIM(fct_lower(cl_lower)) /= 'all' )THEN
251
252	! check if variable is in file
253	il_varid=var_get_index(tl_mpp%t_proc(1)%t_var(:),cl_lower)
254	IF( il_varid == 0 )THEN
255	CALL logger_fatal("MULTI INIT: variable "//&
256	& TRIM(cl_name)//" not in file "//&
257	& TRIM(cl_file) )
258	ENDIF
259
260	! get (global) variable dimension
261	tl_dim(jp_I)=dim_copy(tl_mpp%t_dim(jp_I))
262	tl_dim(jp_J)=dim_copy(tl_mpp%t_dim(jp_J))
263	tl_dim(jp_K)=dim_copy(tl_mpp%t_proc(1)%t_var(il_varid)%t_dim(jp_K))
264	tl_dim(jp_L)=dim_copy(tl_mpp%t_proc(1)%t_var(il_varid)%t_dim(jp_L))
265
266	! clean all varible
267	CALL mpp_del_var(tl_mpp)
268
269	tl_var=var_init(TRIM(cl_lower), td_dim=tl_dim(:))
270
271	! add variable
272	CALL mpp_add_var(tl_mpp,tl_var)
273
274	! number of variable
275	il_nvar=il_nvar+1
276
277	! clean structure
278	CALL var_clean(tl_var)
279
280	ELSE ! cl_lower == 'all'
281
282	DO jk=tl_mpp%t_proc(1)%i_nvar,1,-1
283
284	! check if variable is dimension
285	ll_dim=.FALSE.
286	DO jj=1,ip_maxdim
287	IF( TRIM(tl_mpp%t_proc(1)%t_dim(jj)%c_name) == &
288	& TRIM(tl_mpp%t_proc(1)%t_var(jk)%c_name) )THEN
289	ll_dim=.TRUE.
290	CALL logger_trace("MULTI INIT: "//&
291	& TRIM(tl_mpp%t_proc(1)%t_var(jk)%c_name)//&
292	& ' is var dimension')
293	EXIT
294	ENDIF
295	ENDDO
296	! do not use variable dimension
297	IF( ll_dim )THEN
298	tl_var=var_init( &
299	& TRIM(tl_mpp%t_proc(1)%t_var(jk)%c_name) )
300	! delete variable
301	CALL mpp_del_var(tl_mpp,tl_var)
302	! clean structure
303	CALL var_clean(tl_var)
304	ELSE
305	! number of variable
306	il_nvar=il_nvar+1
307	ENDIF
308
309	ENDDO
310
311	ENDIF
312
313	ENDIF
314
315	CALL multi__add_mpp(multi_init, tl_mpp)
316
317	! update total number of variable
318	multi_init%i_nvar=multi_init%i_nvar+il_nvar
319
320	! clean
321	CALL mpp_clean(tl_mpp)
322
323	ELSE
324	CALL logger_error("MULTI INIT: file name matching variable "//&
325	& TRIM(cl_name)//" is empty. check namelist.")
326	ENDIF
327	ELSE
328	CALL logger_error("MULTI INIT: variable name "//&
329	& "is empty. check namelist.")
330	ENDIF
331
332	ji=ji+1
333	ENDDO
334
335	END FUNCTION multi_init
336	!-------------------------------------------------------------------
337	!> @brief This subroutine clean multi file strucutre.
338	!
339	!> @author J.Paul
340	!> @date November, 2013 - Initial Version
341	!
342	!> @param[in] td_multi multi file structure
343	!-------------------------------------------------------------------
344	SUBROUTINE multi_clean(td_multi)
345	IMPLICIT NONE
346
347	! Argument
348	TYPE(TMULTI), INTENT(INOUT) :: td_multi
349
350	! local variable
351	TYPE(TMULTI) :: tl_multi ! empty multi file structure
352
353	! loop indices
354	!----------------------------------------------------------------
355
356	CALL logger_info( " CLEAN: reset multi file " )
357
358	IF( ASSOCIATED( td_multi%t_mpp ) )THEN
359	CALL mpp_clean(td_multi%t_mpp(:))
360	DEALLOCATE(td_multi%t_mpp)
361	ENDIF
362
363	! replace by empty structure
364	td_multi=multi_copy(tl_multi)
365
366	END SUBROUTINE multi_clean
367	!-------------------------------------------------------------------
368	!> @brief This subroutine print some information about mpp strucutre.
369	!
370	!> @author J.Paul
371	!> @date November, 2013 - Initial Version
372	!
373	!> @param[in] td_multi multi file structure
374	!-------------------------------------------------------------------
375	SUBROUTINE multi_print(td_multi)
376	IMPLICIT NONE
377
378	! Argument
379	TYPE(TMULTI), INTENT(IN) :: td_multi
380
381	! local variable
382
383	! loop indices
384	INTEGER(i4) :: ji
385	INTEGER(i4) :: jj
386	!----------------------------------------------------------------
387
388	! print file
389	IF( td_multi%i_nmpp /= 0 .AND. ASSOCIATED(td_multi%t_mpp) )THEN
390	WRITE(*,'(/a,i3)') 'MULTI: total number of file(s): ',&
391	& td_multi%i_nmpp
392	WRITE(*,'(6x,a,i3)') ' total number of variable(s): ',&
393	& td_multi%i_nvar
394	DO ji=1,td_multi%i_nmpp
395	WRITE(*,'(3x,3a)') 'FILE ',TRIM(td_multi%t_mpp(ji)%c_name),&
396	& ' CONTAINS'
397	DO jj=1,td_multi%t_mpp(ji)%t_proc(1)%i_nvar
398	IF( ASSOCIATED(td_multi%t_mpp(ji)%t_proc(1)%t_var) )THEN
399	WRITE(*,'(6x,a)') &
400	& TRIM(td_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name)
401	ENDIF
402	ENDDO
403	ENDDO
404	ENDIF
405
406	END SUBROUTINE multi_print
407	!-------------------------------------------------------------------
408	!> @brief
409	!> This subroutine add file to multi file structure.
410	!>
411	!> @detail
412	!
413	!> @author J.Paul
414	!> @date November, 2013 - Initial Version
415	!> @date October, 2014
416	!> - use mpp file structure instead of file
417	!
418	!> @param[inout] td_multi multi mpp file strcuture
419	!> @param[in] td_mpp mpp file strcuture
420	!> @return mpp file id in multi mpp file structure
421	!-------------------------------------------------------------------
422	SUBROUTINE multi__add_mpp( td_multi, td_mpp )
423	IMPLICIT NONE
424	! Argument
425	TYPE(TMULTI), INTENT(INOUT) :: td_multi
426	TYPE(TMPP) , INTENT(IN) :: td_mpp
427
428	! local variable
429	INTEGER(i4) :: il_status
430	INTEGER(i4) :: il_mppid
431
432	TYPE(TMPP), DIMENSION(:), ALLOCATABLE :: tl_mpp
433
434	! loop indices
435	INTEGER(i4) :: ji
436	!----------------------------------------------------------------
437
438	il_mppid=0
439	IF( ASSOCIATED(td_multi%t_mpp) )THEN
440	il_mppid=mpp_get_index(td_multi%t_mpp(:),TRIM(td_mpp%c_name))
441	ENDIF
442
443	IF( il_mppid /= 0 )THEN
444
445	CALL logger_debug( " MULTI ADD FILE: mpp file "//TRIM(td_mpp%c_name)//&
446	& " already in multi mpp file structure")
447
448	! add new variable
449	DO ji=1,td_mpp%t_proc(1)%i_nvar
450	CALL mpp_add_var(td_multi%t_mpp(il_mppid), td_mpp%t_proc(1)%t_var(ji))
451	ENDDO
452
453	ELSE
454
455	CALL logger_trace("MULTI ADD MPP: add mpp "//&
456	& TRIM(td_mpp%c_name)//" in multi mpp file structure")
457
458	IF( td_multi%i_nmpp > 0 )THEN
459	!
460	! already other mpp file in multi file structure
461	ALLOCATE( tl_mpp(td_multi%i_nmpp), stat=il_status )
462	IF(il_status /= 0 )THEN
463
464	CALL logger_error( " MULTI ADD MPP FILE: not enough space to put &
465	& mpp file in multi mpp file structure")
466
467	ELSE
468	! save temporary multi file structure
469	tl_mpp(:)=mpp_copy(td_multi%t_mpp(:))
470
471	CALL mpp_clean(td_multi%t_mpp(:))
472	DEALLOCATE( td_multi%t_mpp )
473	ALLOCATE( td_multi%t_mpp(td_multi%i_nmpp+1), stat=il_status)
474	IF(il_status /= 0 )THEN
475
476	CALL logger_error( " MULTI ADD MPP FILE: not enough space "//&
477	& "to put mpp file in multi mpp file structure ")
478
479	ENDIF
480
481	! copy mpp file in multi mpp file before
482	td_multi%t_mpp(1:td_multi%i_nmpp) = mpp_copy(tl_mpp(:))
483
484	! clean
485	CALL mpp_clean(tl_mpp(:))
486	DEALLOCATE(tl_mpp)
487	ENDIF
488
489	ELSE
490	! no file in multi file structure
491	IF( ASSOCIATED(td_multi%t_mpp) )THEN
492	CALL mpp_clean(td_multi%t_mpp(:))
493	DEALLOCATE(td_multi%t_mpp)
494	ENDIF
495	ALLOCATE( td_multi%t_mpp(td_multi%i_nmpp+1), stat=il_status )
496	IF(il_status /= 0 )THEN
497
498	CALL logger_error( " MULTI ADD MPP FILE: not enough space "//&
499	& "to put mpp file in multi mpp file structure " )
500
501	ENDIF
502	ENDIF
503
504	! update number of mpp
505	td_multi%i_nmpp=td_multi%i_nmpp+1
506
507	! add new mpp
508	td_multi%t_mpp(td_multi%i_nmpp)=mpp_copy(td_mpp)
509
510	ENDIF
511	END SUBROUTINE multi__add_mpp
512	END MODULE multi
513

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

Download in other formats: