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.

file.f90 in branches/2014/dev_r4650_UKMO7_STARTHOUR/NEMOGCM/TOOLS/SIREN/src – NEMO

Context Navigation

source: branches/2014/dev_r4650_UKMO7_STARTHOUR/NEMOGCM/TOOLS/SIREN/src/file.f90 @ 5075

Last change on this file since 5075 was 5075, checked in by timgraham, 9 years ago
Upgraded branch to current head of trunk (r5072) so it can be used with the trunk
File size: 71.3 KB

Line
1	!----------------------------------------------------------------------
2	! NEMO system team, System and Interface for oceanic RElocable Nesting
3	!----------------------------------------------------------------------
4	!
5	! MODULE: file
6	!
7	!> @brief
8	!> This module manage file structure.
9	!>
10	!> @details
11	!> define type TFILE:<br/>
12	!> @code
13	!> TYPE(TFILE) :: tl_file
14	!> @endcode
15	!>
16	!> to initialize a file structure:<br/>
17	!> @code
18	!> tl_file=file_init(cd_file [,cd_type] [,ld_wrt] [,cd_grid])
19	!% tl_file=file_init(cd_file [,cd_type] [,ld_wrt] [,id_ew] [,id_perio] [,id_pivot] [,cd_grid])
20	!> @endcode
21	!> - cd_file is the file name
22	!> - cd_type is the type of the file ('cdf', 'dimg') [optional]
23	!> - ld_wrt file in write mode or not [optional]
24	!% - id_ew is the number of point for east-west overlap [optional]
25	!% - id_perio is the NEMO periodicity index [optional]
26	!% - id_pivot is the NEMO pivot point index F(0),T(1) [optional]
27	!> - cd_grid is the grid type (default 'ARAKAWA-C')
28	!>
29	!> to get file name:<br/>
30	!> - tl_file\%c_name
31	!>
32	!> to get file id (units):<br/>
33	!> - tl_file\%i_id
34	!>
35	!> to get the type of the file (cdf, cdf4, dimg):<br/>
36	!> - tl_file\%c_type
37	!>
38	!> to know if file was open in write mode:<br/>
39	!> - tl_file\%l_wrt
40	!>
41	!> to get the record length of the file:<br/>
42	!> - tl_file\%i_recl
43	!>
44	!> Files variables<br/>
45	!> to get the number of variable in the file:<br/>
46	!> - tl_file\%i_nvar
47	!>
48	!> to get the array of variable structure associated to the file:<br/>
49	!> - tl_file\%t_var(:)
50	!>
51	!> Files attributes<br/>
52	!> to get the nmber of global attributes of the file:<br/>
53	!> - tl_file\%i_natt
54	!>
55	!> to get the array of attributes structure associated to the file:<br/>
56	!> - tl_file\%t_att(:)
57	!>
58	!> Files dimensions<br/>
59	!> to get the number of dimension used in the file:<br/>
60	!> - tl_file\%i_ndim
61	!>
62	!> to get the array of dimension structure (4 elts) associated to the
63	!> file:<br/>
64	!> - tl_file\%t_dim(:)
65	!>
66	!> to print information about file structure:<br/>
67	!> @code
68	!> CALL file_print(td_file)
69	!> @endcode
70	!>
71	!> to clean file structure:<br/>
72	!> @code
73	!> CALL file_clean(td_file)
74	!> @endcode
75	!>
76	!> to add a global attribute structure in file structure:<br/>
77	!> @code
78	!> CALL file_add_att(td_file, td_att)
79	!> @endcode
80	!> - td_att is an attribute structure
81	!>
82	!> to add a dimension structure in file structure:<br/>
83	!> @code
84	!> CALL file_add_dim(td_file, td_dim)
85	!> @endcode
86	!> - td_dim is a dimension structure
87	!>
88	!> to add a variable structure in file structure:<br/>
89	!> @code
90	!> CALL file_add_var(td_file, td_var)
91	!> @endcode
92	!> - td_var is a variable structure
93	!>
94	!> to delete a global attribute structure in file structure:<br/>
95	!> @code
96	!> CALL file_del_att(td_file, td_att)
97	!> @endcode
98	!> - td_att is an attribute structure
99	!>
100	!> to delete a dimension structure in file structure:<br/>
101	!> @code
102	!> CALL file_del_dim(td_file, td_dim)
103	!> @endcode
104	!> - td_dim is a dimension structure
105	!>
106	!> to delete a variable structure in file structure:<br/>
107	!> @code
108	!> CALL file_del_var(td_file, td_var)
109	!> @endcode
110	!> - td_var is a variable structure
111	!>
112	!> to overwrite one attribute structure in file structure:<br/>
113	!> @code
114	!> CALL file_move_att(td_file, td_att)
115	!> @endcode
116	!> - td_att is an attribute structure
117	!>
118	!> to overwrite one dimension strucutre in file structure:<br/>
119	!> @code
120	!> CALL file_move_dim(td_file, td_dim)
121	!> @endcode
122	!> - td_dim is a dimension structure
123	!>
124	!> to overwrite one variable structure in file structure:<br/>
125	!> @code
126	!> CALL file_move_var(td_file, td_var)
127	!> @endcode
128	!> - td_var is a variable structure
129	!>
130	!> to check if file and variable structure share same dimension:<br/>
131	!> @code
132	!> ll_check_dim = file_check_var_dim(td_file, td_var)
133	!> @endcode
134	!> - td_var is a variable structure
135	!>
136	!> @author
137	!> J.Paul
138	! REVISION HISTORY:
139	!> @date November, 2013- Initial Version
140	!> @date November, 2014 - Fix memory leaks bug
141	!>
142	!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
143	!----------------------------------------------------------------------
144	MODULE file
145	USE kind ! F90 kind parameter
146	USE global ! global variable
147	USE fct ! basic useful function
148	USE logger ! log file manager
149	USE dim ! dimension manager
150	USE att ! attribute manager
151	USE var ! variable manager
152	IMPLICIT NONE
153	! NOTE_avoid_public_variables_if_possible
154
155	! type and variable
156	PUBLIC :: TFILE !< file structure
157
158	! function and subroutine
159	PUBLIC :: file_copy !< copy file structure
160	PUBLIC :: file_print !< print information about file structure
161	PUBLIC :: file_clean !< clean file structure
162	PUBLIC :: file_init !< initialize file structure
163	PUBLIC :: file_add_att !< add one attribute structure in file structure
164	PUBLIC :: file_add_var !< add one variable structure in file structure
165	PUBLIC :: file_add_dim !< add one dimension strucutre in file structure
166	PUBLIC :: file_del_att !< delete one attribute structure of file structure
167	PUBLIC :: file_del_var !< delete one variable structure of file structure
168	PUBLIC :: file_del_dim !< delete one dimension strucutre of file structure
169	PUBLIC :: file_move_att !< overwrite one attribute structure in file structure
170	PUBLIC :: file_move_var !< overwrite one variable structure in file structure
171	PUBLIC :: file_move_dim !< overwrite one dimension strucutre in file structure
172	PUBLIC :: file_check_var_dim !< check if file and variable structure use same dimension.
173	PUBLIC :: file_get_type !< get type of file
174	PUBLIC :: file_get_id !< get file id
175	PUBLIC :: file_rename !< rename file name
176	PUBLIC :: file_add_suffix !< add suffix to file name
177
178	PRIVATE :: file__clean_unit ! clean file structure
179	PRIVATE :: file__clean_arr ! clean array of file structure
180	PRIVATE :: file__del_var_name ! delete a variable structure in file structure, given variable name or standard name
181	PRIVATE :: file__del_var_str ! delete a variable structure in file structure, given variable structure
182	PRIVATE :: file__del_att_name ! delete a attribute structure in file structure, given attribute name
183	PRIVATE :: file__del_att_str ! delete a attribute structure in file structure, given attribute structure
184	PRIVATE :: file__get_number ! get number in file name without suffix
185	PRIVATE :: file__get_suffix ! get suffix of file name
186	PRIVATE :: file__copy_unit ! copy file structure
187	PRIVATE :: file__copy_arr ! copy array of file structure
188	PRIVATE :: file__rename_char ! rename file name, given processor number.
189	PRIVATE :: file__rename_str ! rename file name, given file structure.
190
191	TYPE TFILE !< file structure
192
193	! general
194	CHARACTER(LEN=lc) :: c_name = "" !< file name
195	CHARACTER(LEN=lc) :: c_type = "" !< type of the file (cdf, cdf4, dimg)
196	INTEGER(i4) :: i_id = 0 !< file id
197	LOGICAL :: l_wrt = .FALSE. !< read or write mode
198	INTEGER(i4) :: i_nvar = 0 !< number of variable
199	TYPE(TVAR), DIMENSION(:), POINTER :: t_var => NULL() !< file variables
200
201	CHARACTER(LEN=lc) :: c_grid = 'ARAKAWA-C' !< grid type
202
203	INTEGER(i4) :: i_ew =-1 !< east-west overlap
204	INTEGER(i4) :: i_perio =-1 !< NEMO periodicity index
205	INTEGER(i4) :: i_pivot =-1 !< NEMO pivot point index F(0),T(1)
206
207	INTEGER(i4) :: i_depthid = 0 !< variable id of depth
208	INTEGER(i4) :: i_timeid = 0 !< variable id of time
209
210	! netcdf file
211	INTEGER(i4) :: i_ndim = 0 !< number of dimensions used in the file
212	INTEGER(i4) :: i_natt = 0 !< number of global attributes in the file
213	INTEGER(i4) :: i_uldid = 0 !< id of the unlimited dimension in the file
214	LOGICAL :: l_def = .FALSE. !< define mode or not
215	TYPE(TATT), DIMENSION(:), POINTER :: t_att => NULL() !< global attributes
216	TYPE(TDIM), DIMENSION(ip_maxdim) :: t_dim !< dimension structure
217
218	! dimg file
219	INTEGER(i4) :: i_recl = 0 !< record length (binary file)
220	INTEGER(i4) :: i_n0d = 0 !< number of scalar variable
221	INTEGER(i4) :: i_n1d = 0 !< number of 1D variable
222	INTEGER(i4) :: i_n2d = 0 !< number of 2D variable
223	INTEGER(i4) :: i_n3d = 0 !< number of 3D variable
224	INTEGER(i4) :: i_rhd = 0 !< record of the header infos (last record)
225
226	! mpp
227	! only use for massively parallel processing
228	INTEGER(i4) :: i_pid = -1 !< processor id (start to 1)
229	INTEGER(i4) :: i_impp = 0 !< i-indexes for mpp-subdomain left bottom
230	INTEGER(i4) :: i_jmpp = 0 !< j-indexes for mpp-subdomain left bottom
231	INTEGER(i4) :: i_lci = 0 !< i-dimensions of subdomain
232	INTEGER(i4) :: i_lcj = 0 !< j-dimensions of subdomain
233	INTEGER(i4) :: i_ldi = 0 !< first indoor i-indices
234	INTEGER(i4) :: i_ldj = 0 !< first indoor j-indices
235	INTEGER(i4) :: i_lei = 0 !< last indoor i-indices
236	INTEGER(i4) :: i_lej = 0 !< last indoor j-indices
237
238	LOGICAL :: l_ctr = .FALSE. !< domain is on border
239	LOGICAL :: l_use = .FALSE. !< domain is used
240
241	! only use to draw domain decomposition when initialize with mpp_init
242	INTEGER(i4) :: i_iind = 0 !< i-direction indices
243	INTEGER(i4) :: i_jind = 0 !< j-direction indices
244
245	END TYPE TFILE
246
247	INTERFACE file_clean
248	MODULE PROCEDURE file__clean_unit
249	MODULE PROCEDURE file__clean_arr
250	END INTERFACE file_clean
251
252	INTERFACE file_del_var
253	MODULE PROCEDURE file__del_var_name
254	MODULE PROCEDURE file__del_var_str
255	END INTERFACE file_del_var
256
257	INTERFACE file_del_att
258	MODULE PROCEDURE file__del_att_name
259	MODULE PROCEDURE file__del_att_str
260	END INTERFACE file_del_att
261
262	INTERFACE file_rename
263	MODULE PROCEDURE file__rename_char
264	MODULE PROCEDURE file__rename_str
265	END INTERFACE file_rename
266
267	INTERFACE file_copy
268	MODULE PROCEDURE file__copy_unit
269	MODULE PROCEDURE file__copy_arr
270	END INTERFACE
271
272	CONTAINS
273	!-------------------------------------------------------------------
274	!> @brief
275	!> This subroutine copy file structure in another one
276	!> @details
277	!> file variable and attribute value are copied in a temporary array,
278	!> so input and output file structure value do not point on the same
279	!> "memory cell", and so on are independant.
280	!>
281	!> @note new file is assume to be closed.
282	!>
283	!> @warning do not use on the output of a function who create or read an
284	!> structure (ex: tl_file=file_copy(file_init()) is forbidden).
285	!> This will create memory leaks.
286	!> @warning to avoid infinite loop, do not use any function inside
287	!> this subroutine
288	!>
289	!> @author J.Paul
290	!> - November, 2013- Initial Version
291	!> @date November, 2014
292	!> - use function instead of overload assignment operator
293	!> (to avoid memory leak)
294	!
295	!> @param[in] td_file file structure
296	!> @return copy of input file structure
297	!-------------------------------------------------------------------
298	FUNCTION file__copy_unit( td_file )
299	IMPLICIT NONE
300	! Argument
301	TYPE(TFILE), INTENT(IN) :: td_file
302	! function
303	TYPE(TFILE) :: file__copy_unit
304
305	! local variable
306	TYPE(TVAR) :: tl_var
307	TYPE(TATT) :: tl_att
308
309	! loop indices
310	INTEGER(i4) :: ji
311	!----------------------------------------------------------------
312
313	CALL logger_trace("FILE COPY: file "//TRIM(td_file%c_name) )
314
315	! copy file variable
316	file__copy_unit%c_name = TRIM(td_file%c_name)
317	file__copy_unit%c_type = TRIM(td_file%c_type)
318	! file1 should be closed even if file2 is opened right now
319	file__copy_unit%i_id = 0
320	file__copy_unit%l_wrt = td_file%l_wrt
321	file__copy_unit%i_nvar = td_file%i_nvar
322
323	file__copy_unit%c_grid = td_file%c_grid
324
325	file__copy_unit%i_ew = td_file%i_ew
326	file__copy_unit%i_perio= td_file%i_perio
327	file__copy_unit%i_pivot= td_file%i_pivot
328
329	file__copy_unit%i_depthid = td_file%i_depthid
330	file__copy_unit%i_timeid = td_file%i_timeid
331
332	! copy variable structure
333	IF( ASSOCIATED(file__copy_unit%t_var) )THEN
334	CALL var_clean(file__copy_unit%t_var(:))
335	DEALLOCATE(file__copy_unit%t_var)
336	ENDIF
337	IF( ASSOCIATED(td_file%t_var) .AND. file__copy_unit%i_nvar > 0 )THEN
338	ALLOCATE( file__copy_unit%t_var(file__copy_unit%i_nvar) )
339	DO ji=1,file__copy_unit%i_nvar
340	tl_var = var_copy(td_file%t_var(ji))
341	file__copy_unit%t_var(ji) = var_copy(tl_var)
342	ENDDO
343	ENDIF
344
345	! copy netcdf variable
346	file__copy_unit%i_ndim = td_file%i_ndim
347	file__copy_unit%i_natt = td_file%i_natt
348	file__copy_unit%i_uldid = td_file%i_uldid
349	file__copy_unit%l_def = td_file%l_def
350
351	! copy dimension
352	file__copy_unit%t_dim(:) = dim_copy(td_file%t_dim(:))
353
354	! copy attribute structure
355	IF( ASSOCIATED(file__copy_unit%t_att) )THEN
356	CALL att_clean(file__copy_unit%t_att(:))
357	DEALLOCATE(file__copy_unit%t_att)
358	ENDIF
359	IF( ASSOCIATED(td_file%t_att) .AND. file__copy_unit%i_natt > 0 )THEN
360	ALLOCATE( file__copy_unit%t_att(file__copy_unit%i_natt) )
361	DO ji=1,file__copy_unit%i_natt
362	tl_att = att_copy(td_file%t_att(ji))
363	file__copy_unit%t_att(ji) = att_copy(tl_att)
364	ENDDO
365	ENDIF
366
367	! clean
368	CALL att_clean(tl_att)
369
370	! copy dimg variable
371	file__copy_unit%i_recl = td_file%i_recl
372	file__copy_unit%i_n0d = td_file%i_n0d
373	file__copy_unit%i_n1d = td_file%i_n1d
374	file__copy_unit%i_n2d = td_file%i_n2d
375	file__copy_unit%i_n3d = td_file%i_n3d
376	file__copy_unit%i_rhd = td_file%i_rhd
377
378	! copy mpp variable
379	file__copy_unit%i_pid = td_file%i_pid
380	file__copy_unit%i_impp = td_file%i_impp
381	file__copy_unit%i_jmpp = td_file%i_jmpp
382	file__copy_unit%i_lci = td_file%i_lci
383	file__copy_unit%i_lcj = td_file%i_lcj
384	file__copy_unit%i_ldi = td_file%i_ldi
385	file__copy_unit%i_ldj = td_file%i_ldj
386	file__copy_unit%i_lei = td_file%i_lei
387	file__copy_unit%i_lej = td_file%i_lej
388	file__copy_unit%l_ctr = td_file%l_ctr
389	file__copy_unit%l_use = td_file%l_use
390	file__copy_unit%i_iind = td_file%i_iind
391	file__copy_unit%i_jind = td_file%i_jind
392
393	END FUNCTION file__copy_unit
394	!-------------------------------------------------------------------
395	!> @brief
396	!> This subroutine copy a array of file structure in another one
397	!> @details
398	!> file variable and attribute value are copied in a temporary array,
399	!> so input and output file structure value do not point on the same
400	!> "memory cell", and so on are independant.
401	!>
402	!> @note new file is assume to be closed.
403	!>
404	!> @warning do not use on the output of a function who create or read an
405	!> structure (ex: tl_file=file_copy(file_init()) is forbidden).
406	!> This will create memory leaks.
407	!> @warning to avoid infinite loop, do not use any function inside
408	!> this subroutine
409	!>
410	!> @author J.Paul
411	!> - November, 2013- Initial Version
412	!> @date November, 2014
413	!> - use function instead of overload assignment operator
414	!> (to avoid memory leak)
415	!
416	!> @param[in] td_file file structure
417	!> @return copy of input array of file structure
418	!-------------------------------------------------------------------
419	FUNCTION file__copy_arr( td_file )
420	IMPLICIT NONE
421	! Argument
422	TYPE(TFILE), DIMENSION(:) , INTENT(IN ) :: td_file
423	! function
424	TYPE(TFILE), DIMENSION(SIZE(td_file(:))) :: file__copy_arr
425
426	! loop indices
427	INTEGER(i4) :: ji
428	!----------------------------------------------------------------
429
430	DO ji=1,SIZE(td_file(:))
431	file__copy_arr(ji)=file_copy(td_file(ji))
432	ENDDO
433
434	END FUNCTION file__copy_arr
435	!-------------------------------------------------------------------
436	!> @brief This function initialize file structure.<br/>
437	!> @details
438	!> If cd_type is not specify, check if file name include '.nc' or
439	!> '.dimg'<br/>
440	!> Optionally, you could specify:<br/>
441	!> - write mode (default .FALSE., ld_wrt)
442	!% - East-West overlap (id_ew)
443	!% - NEMO periodicity index (id_perio)
444	!% - NEMO pivot point index F(0),T(1) (id_pivot)
445	!> - grid type (default: 'ARAKAWA-C')
446	!
447	!> @details
448	!
449	!> @author J.Paul
450	!> - November, 2013- Initial Version
451	!
452	!> @param[in] cd_file file name
453	!> @param[in] cd_type file type ('cdf', 'dimg')
454	!> @param[in] ld_wrt write mode (default .FALSE.)
455	!> @param[in] id_ew east-west overlap
456	!> @param[in] id_perio NEMO periodicity index
457	!> @param[in] id_pivot NEMO pivot point index F(0),T(1)
458	!> @param[in] cd_grid grid type (default 'ARAKAWA-C')
459	!> @return file structure
460	!-------------------------------------------------------------------
461	TYPE(TFILE) FUNCTION file_init( cd_file, cd_type, ld_wrt, &
462	& id_ew, id_perio, id_pivot,&
463	& cd_grid)
464	IMPLICIT NONE
465	! Argument
466	CHARACTER(LEN=*), INTENT(IN) :: cd_file
467	CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_type
468	LOGICAL , INTENT(IN), OPTIONAL :: ld_wrt
469	INTEGER(i4) , INTENT(IN), OPTIONAL :: id_ew
470	INTEGER(i4) , INTENT(IN), OPTIONAL :: id_perio
471	INTEGER(i4) , INTENT(IN), OPTIONAL :: id_pivot
472	CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_grid
473
474	! local variable
475	TYPE(TATT) :: tl_att
476	!----------------------------------------------------------------
477
478	! clean file
479	CALL file_clean(file_init)
480
481	file_init%c_name=TRIM(ADJUSTL(cd_file))
482	CALL logger_trace("FILE INIT: initialize file "//TRIM(file_init%c_name))
483
484	! check type
485	IF( PRESENT(cd_type) )THEN
486	SELECT CASE(TRIM(cd_type))
487	CASE('cdf')
488	file_init%c_type='cdf'
489	CASE('dimg')
490	file_init%c_type='dimg'
491	CASE DEFAULT
492	CALL logger_error( " FILE INIT: can't initialize file "//&
493	& TRIM(file_init%c_name)//" : type unknown " )
494	END SELECT
495	ELSE
496	file_init%c_type=TRIM(file_get_type(cd_file))
497	ENDIF
498
499	! create some global attribute
500	IF( TRIM(file_init%c_type) == 'cdf' )THEN
501	tl_att=att_init("Conventions","CF-1.5")
502	CALL file_add_att(file_init,tl_att)
503	ENDIF
504
505	tl_att=att_init("Grid",TRIM(file_init%c_grid))
506	CALL file_add_att(file_init,tl_att)
507
508	IF( PRESENT(ld_wrt) )THEN
509	file_init%l_wrt=ld_wrt
510	ENDIF
511
512	IF( PRESENT(id_ew) )THEN
513	file_init%i_ew=id_ew
514	IF( id_ew >= 0 )THEN
515	tl_att=att_init('ew_overlap',id_ew)
516	CALL file_move_att(file_init, tl_att)
517	ENDIF
518	ENDIF
519
520	IF( PRESENT(id_perio) )THEN
521	file_init%i_perio=id_perio
522	IF( id_perio >= 0 )THEN
523	tl_att=att_init('periodicity',id_perio)
524	CALL file_move_att(file_init, tl_att)
525	ENDIF
526	ENDIF
527
528	IF( PRESENT(id_pivot) )THEN
529	file_init%i_pivot=id_pivot
530	IF( id_pivot > 0 )THEN
531	tl_att=att_init('pivot_point',id_pivot)
532	CALL file_move_att(file_init, tl_att)
533	ENDIF
534	ENDIF
535
536	IF( PRESENT(cd_grid) )THEN
537	file_init%c_grid=cd_grid
538	ENDIF
539
540	! clean
541	CALL att_clean(tl_att)
542
543	END FUNCTION file_init
544	!-------------------------------------------------------------------
545	!> @brief
546	!> This function get type of file, given file name.
547	!> @details
548	!> Actually it get suffix of the file name, and compare it to 'nc', 'cdf' or
549	!> 'dimg'<br/>
550	!> If no suffix or suffix not identify, we assume file is dimg
551	!
552	!> @details
553	!
554	!> @author J.Paul
555	!> - November, 2013- Initial Version
556	!
557	!> @param[in] cd_file file name
558	!> @return type of file
559	!-------------------------------------------------------------------
560	CHARACTER(LEN=lc) FUNCTION file_get_type(cd_file)
561	IMPLICIT NONE
562	! Argument
563	CHARACTER(LEN=*), INTENT(IN) :: cd_file
564
565	!local variable
566	CHARACTER(LEN=lc) :: cl_suffix
567	!----------------------------------------------------------------
568
569	cl_suffix=file__get_suffix(cd_file)
570	SELECT CASE( TRIM(fct_lower(cl_suffix)) )
571	CASE('.nc','.cdf')
572	CALL logger_debug(" FILE GET TYPE: file "//TRIM(cd_file)//" is cdf")
573	file_get_type='cdf'
574	CASE('.dimg')
575	CALL logger_debug(" FILE GET TYPE: file "//TRIM(cd_file)//" is dimg" )
576	file_get_type='dimg'
577	CASE DEFAULT
578	CALL logger_warn(" FILE GET TYPE: type unknown, we assume file: "//&
579	& TRIM(cd_file)//" is dimg ")
580	file_get_type='dimg'
581	END SELECT
582
583	END FUNCTION file_get_type
584	!-------------------------------------------------------------------
585	!> @brief This function check if variable dimension to be used
586	!> have the same length that in file structure.
587	!
588	!> @details
589	!
590	!> @author J.Paul
591	!> - November, 2013- Initial Version
592	!
593	!> @param[in] td_file file structure
594	!> @param[in] td_var variable structure
595	!> @return true if dimension of variable and file structure agree
596	!-------------------------------------------------------------------
597	LOGICAL FUNCTION file_check_var_dim(td_file, td_var)
598	IMPLICIT NONE
599	! Argument
600	TYPE(TFILE), INTENT(IN) :: td_file
601	TYPE(TVAR), INTENT(IN) :: td_var
602
603	! local variable
604	CHARACTER(LEN=lc) :: cl_dim
605	LOGICAL :: ll_error
606
607	INTEGER(i4) :: il_ind
608
609	! loop indices
610	INTEGER(i4) :: ji
611	!----------------------------------------------------------------
612	file_check_var_dim=.TRUE.
613
614	! check used dimension
615	ll_error=.FALSE.
616	DO ji=1,ip_maxdim
617	il_ind=dim_get_index( td_file%t_dim(:), &
618	& TRIM(td_var%t_dim(ji)%c_name), &
619	& TRIM(td_var%t_dim(ji)%c_sname))
620	IF( il_ind /= 0 )THEN
621	IF( td_var%t_dim(ji)%l_use .AND. &
622	& td_file%t_dim(il_ind)%l_use .AND. &
623	& td_var%t_dim(ji)%i_len /= td_file%t_dim(il_ind)%i_len )THEN
624	ll_error=.TRUE.
625	ENDIF
626	ENDIF
627	ENDDO
628
629	IF( ll_error )THEN
630
631	file_check_var_dim=.FALSE.
632
633	CALL logger_error( &
634	& " FILE CHECK VAR DIM: variable and file dimension differ"//&
635	& " for variable "//TRIM(td_var%c_name)//&
636	& " and file "//TRIM(td_file%c_name))
637
638
639	cl_dim='(/'
640	DO ji = 1, td_file%i_ndim
641	IF( td_file%t_dim(ji)%l_use )THEN
642	cl_dim=TRIM(cl_dim)//&
643	& TRIM(fct_upper(td_file%t_dim(ji)%c_sname))//':'//&
644	& TRIM(fct_str(td_file%t_dim(ji)%i_len))//','
645	ENDIF
646	ENDDO
647	cl_dim=TRIM(cl_dim)//'/)'
648	CALL logger_debug( " file dimension: "//TRIM(cl_dim) )
649
650	cl_dim='(/'
651	DO ji = 1, td_var%i_ndim
652	IF( td_var%t_dim(ji)%l_use )THEN
653	cl_dim=TRIM(cl_dim)//&
654	& TRIM(fct_upper(td_var%t_dim(ji)%c_sname))//':'//&
655	& TRIM(fct_str(td_var%t_dim(ji)%i_len))//','
656	ENDIF
657	ENDDO
658	cl_dim=TRIM(cl_dim)//'/)'
659	CALL logger_debug( " variable dimension: "//TRIM(cl_dim) )
660
661	ELSE
662
663	IF( td_var%i_ndim > td_file%i_ndim )THEN
664	CALL logger_info("FILE CHECK VAR DIM: variable "//&
665	& TRIM(td_var%c_name)//" use more dimension than file "//&
666	& TRIM(td_file%c_name)//" do until now.")
667	ENDIF
668
669	ENDIF
670
671	END FUNCTION file_check_var_dim
672	!-------------------------------------------------------------------
673	!> @brief This subroutine add a variable structure in a file structure.<br/>
674	!> Do not overwrite, if variable already in file structure.
675	!
676	!> @note variable value is suppose to be ordered ('x','y','z','t')
677	!
678	!> @details
679	!
680	!> @author J.Paul
681	!> - November, 2013- Initial Version
682	!> @date September, 2014
683	!> - add dimension to file if need be
684	!> - do not reorder dimension from variable, before put in file
685	!
686	!> @param[inout] td_file file structure
687	!> @param[in] td_var variable structure
688	!-------------------------------------------------------------------
689	SUBROUTINE file_add_var(td_file, td_var)
690	IMPLICIT NONE
691
692	! Argument
693	TYPE(TFILE), INTENT(INOUT) :: td_file
694	TYPE(TVAR) , INTENT(IN ) :: td_var
695
696	! local variable
697	INTEGER(i4) :: il_status
698	!INTEGER(i4) :: il_rec
699	INTEGER(i4) :: il_ind
700
701	TYPE(TVAR), DIMENSION(:), ALLOCATABLE :: tl_var
702
703	! loop indices
704	INTEGER(i4) :: ji
705	!----------------------------------------------------------------
706	! check if file opened
707	IF( TRIM(td_file%c_name) == '' )THEN
708
709	CALL logger_error( " FILE ADD VAR: structure file unknown" )
710	CALL logger_debug( " FILE ADD VAR: you should have used file_init before "//&
711	& "running file_add_var" )
712
713	ELSE
714	! check if variable exist
715	IF( TRIM(td_var%c_name) == '' .AND. &
716	& TRIM(td_var%c_stdname) == '' )THEN
717	CALL logger_error(" FILE ADD VAR: variable without name ")
718	ELSE
719	! check if variable already in file structure
720	il_ind=0
721	IF( ASSOCIATED(td_file%t_var) )THEN
722	il_ind=var_get_index( td_file%t_var(:), td_var%c_name, &
723	& td_var%c_stdname )
724	ENDIF
725
726	IF( il_ind /= 0 )THEN
727
728	CALL logger_error( &
729	& " FILE ADD VAR: variable "//TRIM(td_var%c_name)//&
730	& ", standard name "//TRIM(td_var%c_stdname)//&
731	& ", already in file "//TRIM(td_file%c_name) )
732
733	DO ji=1,td_file%i_nvar
734	CALL logger_debug( " ADD VAR: in file : &
735	& variable "//TRIM(td_file%t_var(ji)%c_name)//&
736	& ", standard name "//TRIM(td_file%t_var(ji)%c_stdname) )
737	ENDDO
738
739	ELSE
740
741	CALL logger_trace( &
742	& " FILE ADD VAR: add variable "//TRIM(td_var%c_name)//&
743	& ", standard name "//TRIM(td_var%c_stdname)//&
744	& ", in file "//TRIM(td_file%c_name) )
745
746	! check used dimension
747	IF( file_check_var_dim(td_file, td_var) )THEN
748
749	! update dimension if need be
750	DO ji=1,ip_maxdim
751	IF( td_var%t_dim(ji)%l_use .AND. &
752	& .NOT. td_file%t_dim(ji)%l_use )THEN
753	CALL file_add_dim(td_file,td_var%t_dim(ji))
754	ENDIF
755	ENDDO
756
757	! get index of new variable
758	SELECT CASE(td_var%i_ndim)
759	CASE(0)
760	il_ind=td_file%i_n0d+1
761	!il_rec=0
762	CASE(1)
763	il_ind=td_file%i_n0d+td_file%i_n1d+1
764	!il_rec=1
765	CASE(2)
766	il_ind=td_file%i_n0d+td_file%i_n1d+td_file%i_n2d+1
767	!il_rec=1
768	CASE(3,4)
769	il_ind=td_file%i_n0d+td_file%i_n1d+td_file%i_n2d+td_file%i_n3d+1
770	!il_rec=td_file%t_dim(3)%i_len
771	END SELECT
772	CALL logger_info( &
773	& " FILE ADD VAR: variable index "//TRIM(fct_str(il_ind)))
774
775	IF( td_file%i_nvar > 0 )THEN
776	! already other variable in file structure
777	ALLOCATE( tl_var(td_file%i_nvar), stat=il_status )
778	IF(il_status /= 0 )THEN
779
780	CALL logger_error( &
781	& " FILE ADD VAR: not enough space to put variables "//&
782	& "from "//TRIM(td_file%c_name)//&
783	& " in variable structure")
784
785	ELSE
786
787	! save temporary variable of file structure
788	tl_var(:)=var_copy(td_file%t_var(:))
789
790	CALL var_clean( td_file%t_var(:) )
791	DEALLOCATE(td_file%t_var)
792	ALLOCATE( td_file%t_var(td_file%i_nvar+1), &
793	& stat=il_status)
794	IF(il_status /= 0 )THEN
795
796	CALL logger_error( &
797	& " FILE ADD VAR: not enough space to put variable "//&
798	& "in file structure "//TRIM(td_file%c_name) )
799
800	ENDIF
801
802	! copy variable in file before
803	! variable with less than or equal dimension that new variable
804	IF( il_ind > 1 )THEN
805	td_file%t_var( 1:il_ind-1 ) = var_copy(tl_var(1:il_ind-1))
806	ENDIF
807
808	IF( il_ind < td_file%i_nvar )THEN
809	! variable with more dimension than new variable
810	td_file%t_var( il_ind+1 : td_file%i_nvar+1 ) = &
811	& var_copy( tl_var(il_ind : td_file%i_nvar) )
812	ENDIF
813
814	! clean
815	CALL var_clean(tl_var(:))
816	DEALLOCATE(tl_var)
817	ENDIF
818
819	ELSE
820	! no variable in file structure
821	IF( ASSOCIATED(td_file%t_var) )THEN
822	CALL var_clean(td_file%t_var(:))
823	DEALLOCATE(td_file%t_var)
824	ENDIF
825	ALLOCATE( td_file%t_var(td_file%i_nvar+1), stat=il_status )
826	IF(il_status /= 0 )THEN
827
828	CALL logger_error( &
829	& " FILE ADD VAR: not enough space to put variable "//&
830	& "in file structure "//TRIM(td_file%c_name) )
831
832	ENDIF
833
834	ENDIF
835
836	! add new variable in array of variable
837	ALLOCATE( tl_var(1), stat=il_status )
838	IF(il_status /= 0 )THEN
839
840	CALL logger_error( &
841	& " FILE ADD VAR: not enough space to put variables from "//&
842	& TRIM(td_var%c_name)//" in variable structure")
843
844	ELSE
845	tl_var(1)=var_copy(td_var)
846
847	! update dimension name in new variable
848	tl_var(1)%t_dim(:)%c_name = td_file%t_dim(:)%c_name
849
850	! add new variable
851	td_file%t_var(il_ind)=var_copy(tl_var(1))
852
853	! update number of variable
854	td_file%i_nvar=td_file%i_nvar+1
855	SELECT CASE(tl_var(1)%i_ndim)
856	CASE(0)
857	td_file%i_n0d=td_file%i_n0d+1
858	CASE(1)
859	td_file%i_n1d=td_file%i_n1d+1
860	CASE(2)
861	td_file%i_n2d=td_file%i_n2d+1
862	CASE(3,4)
863	td_file%i_n3d=td_file%i_n3d+1
864	END SELECT
865
866	! update variable id
867	td_file%t_var(il_ind)%i_id=var_get_unit(td_file%t_var(:))
868
869	! update dimension used
870	td_file%t_dim(:)%l_use=.FALSE.
871	DO ji=1,ip_maxdim
872	IF( ANY(td_file%t_var(:)%t_dim(ji)%l_use) )THEN
873	td_file%t_dim(ji)%l_use=.TRUE.
874	ENDIF
875	ENDDO
876
877	! update number of dimension
878	td_file%i_ndim=COUNT(td_file%t_dim(:)%l_use)
879
880	! clean
881	CALL var_clean( tl_var(:) )
882	DEALLOCATE(tl_var)
883	ENDIF
884	ENDIF
885	ENDIF
886	ENDIF
887	ENDIF
888
889	END SUBROUTINE file_add_var
890	!-------------------------------------------------------------------
891	!> @brief This subroutine delete a variable structure
892	!> in file structure, given variable name or standard name.
893	!
894	!> @author J.Paul
895	!> - November, 2013- Initial Version
896	!
897	!> @param[inout] td_file file structure
898	!> @param[in] cd_name variable name or standard name
899	!-------------------------------------------------------------------
900	SUBROUTINE file__del_var_name(td_file, cd_name )
901	IMPLICIT NONE
902
903	! Argument
904	TYPE(TFILE) , INTENT(INOUT) :: td_file
905	CHARACTER(LEN=*), INTENT(IN ) :: cd_name
906
907	! local variable
908	INTEGER(i4) :: il_ind
909	!----------------------------------------------------------------
910
911	! check if file opened
912	IF( TRIM(td_file%c_name) == '' )THEN
913
914	CALL logger_error( " FILE DEL VAR NAME: file structure unknown ")
915	CALL logger_debug( " FILE DEL VAR NAME: you should have used file_init before "//&
916	& "running file_del_var" )
917
918	ELSE
919
920	IF( td_file%i_nvar /= 0 )THEN
921
922	! get the variable index, in file variable structure
923	il_ind=0
924	IF( ASSOCIATED(td_file%t_var) )THEN
925	il_ind=var_get_index(td_file%t_var(:), cd_name )
926	ENDIF
927
928	IF( il_ind /= 0 )THEN
929
930	CALL file_del_var(td_file, td_file%t_var(il_ind))
931
932	ELSE
933
934	CALL logger_warn( &
935	& " FILE DEL VAR NAME: there is no variable with name or "//&
936	& "standard name "//TRIM(cd_name)//" in file "//&
937	& TRIM(td_file%c_name))
938
939	ENDIF
940
941	ELSE
942	CALL logger_debug( " FILE DEL VAR NAME: "//&
943	& "no variable associated to file "//&
944	& TRIM(td_file%c_name) )
945	ENDIF
946
947	ENDIF
948
949	END SUBROUTINE file__del_var_name
950	!-------------------------------------------------------------------
951	!> @brief This subroutine delete a variable structure
952	!> in file structure, given variable structure.
953	!>
954	!> @author J.Paul
955	!> - November, 2013- Initial Version
956	!>
957	!> @param[inout] td_file file structure
958	!> @param[in] td_var variable structure
959	!-------------------------------------------------------------------
960	SUBROUTINE file__del_var_str(td_file, td_var)
961	IMPLICIT NONE
962
963	! Argument
964	TYPE(TFILE), INTENT(INOUT) :: td_file
965	TYPE(TVAR), INTENT(IN) :: td_var
966
967	! local variable
968	INTEGER(i4) :: il_status
969	INTEGER(i4) :: il_ind
970	INTEGER(i4) :: il_rec
971	TYPE(TVAR), DIMENSION(:), ALLOCATABLE :: tl_var
972
973	! loop indices
974	INTEGER(i4) :: ji
975	!----------------------------------------------------------------
976
977	! check if file opened
978	IF( TRIM(td_file%c_name) == '' )THEN
979
980	CALL logger_error( " FILE DEL VAR: file structure unknown ")
981	CALL logger_debug( " FILE DEL VAR: you should have used "//&
982	& "file_init before running file_del_var" )
983
984	ELSE
985
986	! check if variable is member of a file
987	IF( td_var%l_file )THEN
988	CALL logger_warn( &
989	& " FILE DEL VAR: variable "//TRIM(td_var%c_name)//&
990	& ", belong to file "//TRIM(td_file%c_name)//&
991	& " and can not be removed.")
992	ELSE
993	! check if variable already in file structure
994	il_ind=0
995	IF( ASSOCIATED(td_file%t_var) )THEN
996	il_ind=var_get_index( td_file%t_var(:), td_var%c_name, &
997	& td_var%c_stdname )
998	ENDIF
999
1000	IF( il_ind == 0 )THEN
1001
1002	CALL logger_warn( "FILE DEL VAR: no variable "//&
1003	& TRIM(td_var%c_name)//", in file "//TRIM(td_file%c_name) )
1004
1005	DO ji=1,td_file%i_nvar
1006	CALL logger_debug( "FILE DEL VAR: in file "//&
1007	& TRIM(td_file%t_var(ji)%c_name)//", standard name "//&
1008	& TRIM(td_file%t_var(ji)%c_stdname) )
1009	ENDDO
1010
1011	ELSE
1012
1013	CALL logger_trace( "FILE DEL VAR: delete variable "//&
1014	& TRIM(td_var%c_name)//", from file "//TRIM(td_file%c_name) )
1015
1016	ALLOCATE( tl_var(td_file%i_nvar-1), stat=il_status )
1017	IF(il_status /= 0 )THEN
1018
1019	CALL logger_error( &
1020	& " FILE DEL VAR: not enough space to put variables from "//&
1021	& TRIM(td_file%c_name)//" in temporary variable structure")
1022
1023	ELSE
1024
1025	! save temporary variable's file structure
1026	IF( il_ind > 1 )THEN
1027	tl_var(1:il_ind-1)=var_copy(td_file%t_var(1:il_ind-1))
1028	ENDIF
1029
1030	IF( il_ind < td_file%i_nvar )THEN
1031	tl_var(il_ind:)=var_copy(td_file%t_var(il_ind+1:))
1032	ENDIF
1033
1034	! new number of variable in file
1035	td_file%i_nvar=td_file%i_nvar-1
1036
1037	SELECT CASE(td_var%i_ndim)
1038	CASE(0)
1039	td_file%i_n0d=td_file%i_n0d-1
1040	il_rec=0
1041	CASE(1)
1042	td_file%i_n1d=td_file%i_n1d-1
1043	il_rec=1
1044	CASE(2)
1045	td_file%i_n2d=td_file%i_n2d-1
1046	il_rec=1
1047	CASE(3,4)
1048	td_file%i_n3d=td_file%i_n3d-1
1049	il_rec=td_file%t_dim(3)%i_len
1050	END SELECT
1051
1052	CALL var_clean( td_file%t_var(:) )
1053	DEALLOCATE(td_file%t_var)
1054
1055	IF( td_file%i_nvar > 0 )THEN
1056	ALLOCATE( td_file%t_var(td_file%i_nvar), stat=il_status )
1057	IF(il_status /= 0 )THEN
1058
1059	CALL logger_error( " FILE DEL VAR: not enough space"//&
1060	& "to put variables in file structure "//&
1061	& TRIM(td_file%c_name) )
1062
1063	ENDIF
1064
1065	! copy attribute in file before
1066	td_file%t_var(:)=var_copy(tl_var(:))
1067
1068	! update dimension used
1069	td_file%t_dim(:)%l_use=.FALSE.
1070	DO ji=1,ip_maxdim
1071	IF( ANY(td_file%t_var(:)%t_dim(ji)%l_use) )THEN
1072	td_file%t_dim(ji)%l_use=.TRUE.
1073	ENDIF
1074	ENDDO
1075
1076	! update number of dimension
1077	td_file%i_ndim=COUNT(td_file%t_dim(:)%l_use)
1078
1079	ENDIF
1080
1081	! clean
1082	CALL var_clean(tl_var(:))
1083	DEALLOCATE(tl_var)
1084
1085	ENDIF
1086	ENDIF
1087	ENDIF
1088	ENDIF
1089
1090	END SUBROUTINE file__del_var_str
1091	!-------------------------------------------------------------------
1092	!> @brief This subroutine overwrite variable structure
1093	!> in file structure.
1094	!
1095	!> @warning change variable id in file structure.
1096	!
1097	!> @author J.Paul
1098	!> - November, 2013- Initial Version
1099	!
1100	!> @param[inout] td_file file structure
1101	!> @param[in] td_var variable structure
1102	!-------------------------------------------------------------------
1103	SUBROUTINE file_move_var(td_file, td_var)
1104	IMPLICIT NONE
1105
1106	! Argument
1107	TYPE(TFILE), INTENT(INOUT) :: td_file
1108	TYPE(TVAR), INTENT(IN) :: td_var
1109
1110	! local variable
1111	TYPE(TVAR) :: tl_var
1112	!----------------------------------------------------------------
1113
1114	! copy variable
1115	tl_var=var_copy(td_var)
1116
1117	! remove variable with same name or standard name
1118	CALL file_del_var(td_file, tl_var)
1119
1120	! add new variable
1121	CALL file_add_var(td_file, tl_var)
1122
1123	! clean
1124	CALL var_clean(tl_var)
1125
1126	END SUBROUTINE file_move_var
1127	!-------------------------------------------------------------------
1128	!> @brief This subroutine add a global attribute
1129	!> in a file structure.<br/>
1130	!> Do not overwrite, if attribute already in file structure.
1131	!
1132	!> @author J.Paul
1133	!> - November, 2013- Initial Version
1134	!
1135	!> @param[inout] td_file file structure
1136	!> @param[in] td_att attribute structure
1137	!-------------------------------------------------------------------
1138	SUBROUTINE file_add_att(td_file, td_att)
1139	IMPLICIT NONE
1140
1141	! Argument
1142	TYPE(TFILE), INTENT(INOUT) :: td_file
1143	TYPE(TATT), INTENT(IN) :: td_att
1144
1145	! local variable
1146	INTEGER(i4) :: il_status
1147	INTEGER(i4) :: il_ind
1148	TYPE(TATT), DIMENSION(:), ALLOCATABLE :: tl_att
1149
1150	! loop indices
1151	INTEGER(i4) :: ji
1152	!----------------------------------------------------------------
1153
1154	! check if file opened
1155	IF( TRIM(td_file%c_name) == '' )THEN
1156
1157	CALL logger_error( " FILE ADD ATT: file structure unknown ")
1158	CALL logger_debug( " FILE ADD ATT: you should have used file_init before "//&
1159	& "running file_add_att" )
1160
1161	ELSE
1162
1163	! check if attribute already in file structure
1164	il_ind=0
1165	IF( ASSOCIATED(td_file%t_att) )THEN
1166	il_ind=att_get_index( td_file%t_att(:), td_att%c_name )
1167	ENDIF
1168
1169	IF( il_ind /= 0 )THEN
1170
1171	CALL logger_error( &
1172	& " FILE ADD ATT: attribute "//TRIM(td_att%c_name)//&
1173	& ", already in file "//TRIM(td_file%c_name) )
1174
1175	DO ji=1,td_file%i_natt
1176	CALL logger_debug( &
1177	& " FILE ADD ATT: in file "//TRIM(td_file%t_att(ji)%c_name) )
1178	ENDDO
1179
1180	ELSE
1181
1182	CALL logger_trace( &
1183	& " FILE ADD ATT: add attribute "//TRIM(td_att%c_name)//&
1184	& ", in file "//TRIM(td_file%c_name) )
1185
1186	IF( td_file%i_natt > 0 )THEN
1187	! already other attribute in file structure
1188	ALLOCATE( tl_att(td_file%i_natt), stat=il_status )
1189	IF(il_status /= 0 )THEN
1190
1191	CALL logger_error( &
1192	& " FILE ADD ATT: not enough space to put attributes from "//&
1193	& TRIM(td_file%c_name)//" in temporary attribute structure")
1194
1195	ELSE
1196
1197	! save temporary global attribute's file structure
1198	tl_att(:)=att_copy(td_file%t_att(:))
1199
1200	CALL att_clean( td_file%t_att(:) )
1201	DEALLOCATE(td_file%t_att)
1202	ALLOCATE( td_file%t_att(td_file%i_natt+1), stat=il_status )
1203	IF(il_status /= 0 )THEN
1204
1205	CALL logger_error( &
1206	& " FILE ADD ATT: not enough space to put attributes "//&
1207	& "in file structure "//TRIM(td_file%c_name) )
1208
1209	ENDIF
1210
1211	! copy attribute in file before
1212	td_file%t_att(1:td_file%i_natt)=att_copy(tl_att(:))
1213
1214	! clean
1215	CALL att_clean(tl_att(:))
1216	DEALLOCATE(tl_att)
1217
1218	ENDIF
1219	ELSE
1220	! no attribute in file structure
1221	IF( ASSOCIATED(td_file%t_att) )THEN
1222	CALL att_clean(td_file%t_att(:))
1223	DEALLOCATE(td_file%t_att)
1224	ENDIF
1225
1226	ALLOCATE( td_file%t_att(td_file%i_natt+1), stat=il_status )
1227	IF(il_status /= 0 )THEN
1228
1229	CALL logger_error( &
1230	& " FILE ADD ATT: not enough space to put attributes "//&
1231	& "in file structure "//TRIM(td_file%c_name) )
1232
1233	ENDIF
1234	ENDIF
1235	! add new attribute
1236	td_file%t_att(td_file%i_natt+1)=att_copy(td_att)
1237
1238	! update number of attribute
1239	td_file%i_natt=td_file%i_natt+1
1240	ENDIF
1241	ENDIF
1242
1243	END SUBROUTINE file_add_att
1244	!-------------------------------------------------------------------
1245	!> @brief This subroutine delete a global attribute structure
1246	!> in file structure, given attribute name.
1247	!
1248	!> @author J.Paul
1249	!> - November, 2013- Initial Version
1250	!
1251	!> @param[inout] td_file file structure
1252	!> @param[in] cd_name attribute name
1253	!-------------------------------------------------------------------
1254	SUBROUTINE file__del_att_name(td_file, cd_name )
1255	IMPLICIT NONE
1256
1257	! Argument
1258	TYPE(TFILE) , INTENT(INOUT) :: td_file
1259	CHARACTER(LEN=*), INTENT(IN ) :: cd_name
1260
1261	! local variable
1262	INTEGER(i4) :: il_ind
1263	!----------------------------------------------------------------
1264
1265	! check if file opened
1266	IF( TRIM(td_file%c_name) == '' )THEN
1267
1268	CALL logger_error( " FILE DEL ATT NAME: file structure unknown ")
1269	CALL logger_debug( " FILE DEL ATT NAME: you should have "//&
1270	& "used file_init before running file_del_att" )
1271
1272	ELSE
1273
1274	IF( td_file%i_natt /= 0 )THEN
1275
1276	! get the variable id, in file variable structure
1277	il_ind=0
1278	IF( ASSOCIATED(td_file%t_att) )THEN
1279	il_ind=att_get_index(td_file%t_att(:), cd_name )
1280	ENDIF
1281
1282	IF( il_ind /= 0 )THEN
1283
1284	CALL file_del_att(td_file, td_file%t_att(il_ind))
1285
1286	ELSE
1287
1288	CALL logger_warn( &
1289	& " FILE DEL ATT NAME: there is no attribute with name "//&
1290	& TRIM(cd_name)//" in file "//TRIM(td_file%c_name))
1291
1292	ENDIF
1293
1294	ELSE
1295	CALL logger_debug( " FILE DEL ATT NAME: no attribute "//&
1296	& "associated to file "//TRIM(td_file%c_name) )
1297	ENDIF
1298
1299	ENDIF
1300
1301	END SUBROUTINE file__del_att_name
1302	!-------------------------------------------------------------------
1303	!> @brief This subroutine delete a global attribute structure
1304	!> from file structure, given attribute structure.
1305	!
1306	!> @author J.Paul
1307	!> - November, 2013- Initial Version
1308	!
1309	!> @param[inout] td_file file structure
1310	!> @param[in] td_att attribute structure
1311	!-------------------------------------------------------------------
1312	SUBROUTINE file__del_att_str(td_file, td_att)
1313	IMPLICIT NONE
1314
1315	! Argument
1316	TYPE(TFILE), INTENT(INOUT) :: td_file
1317	TYPE(TATT), INTENT(IN) :: td_att
1318
1319	! local variable
1320	INTEGER(i4) :: il_status
1321	INTEGER(i4) :: il_ind
1322	TYPE(TATT), DIMENSION(:), ALLOCATABLE :: tl_att
1323
1324	! loop indices
1325	!----------------------------------------------------------------
1326
1327	! check if file opened
1328	IF( TRIM(td_file%c_name) == '' )THEN
1329
1330	CALL logger_error( " FILE DEL ATT: file structure unknown ")
1331	CALL logger_debug( " FILE DEL ATT: you should have used "//&
1332	& "file_init before running file_del_att" )
1333
1334	ELSE
1335
1336	! check if attribute already in file structure
1337	il_ind=0
1338	IF( ASSOCIATED(td_file%t_att) )THEN
1339	il_ind=att_get_index( td_file%t_att(:), td_att%c_name )
1340	ENDIF
1341
1342	IF( il_ind == 0 )THEN
1343
1344	CALL logger_error( &
1345	& " FILE DEL ATT: no attribute "//TRIM(td_att%c_name)//&
1346	& ", in file "//TRIM(td_file%c_name) )
1347
1348	ELSE
1349
1350	CALL logger_trace( &
1351	& " FILE DEL ATT: del attribute "//TRIM(td_att%c_name)//&
1352	& ", in file "//TRIM(td_file%c_name) )
1353
1354	ALLOCATE( tl_att(td_file%i_natt-1), stat=il_status )
1355	IF(il_status /= 0 )THEN
1356
1357	CALL logger_error( &
1358	& " FILE ADD ATT: not enough space to put attributes from "//&
1359	& TRIM(td_file%c_name)//" in temporary attribute structure")
1360
1361	ELSE
1362
1363	! save temporary global attribute's file structure
1364	IF( il_ind > 1 )THEN
1365	tl_att(1:il_ind-1)=att_copy(td_file%t_att(1:il_ind-1))
1366	ENDIF
1367
1368	IF( il_ind < td_file%i_natt )THEN
1369	tl_att(il_ind:)=att_copy(td_file%t_att(il_ind+1:))
1370	ENDIF
1371
1372	CALL att_clean( td_file%t_att(:) )
1373	DEALLOCATE(td_file%t_att)
1374
1375	! new number of attribute in file
1376	td_file%i_natt=td_file%i_natt-1
1377
1378	ALLOCATE( td_file%t_att(td_file%i_natt), stat=il_status )
1379	IF(il_status /= 0 )THEN
1380
1381	CALL logger_error( &
1382	& " FILE ADD ATT: not enough space to put attributes "//&
1383	& "in file structure "//TRIM(td_file%c_name) )
1384
1385	ENDIF
1386
1387	! copy attribute in file before
1388	td_file%t_att(1:td_file%i_natt)=att_copy(tl_att(:))
1389
1390	! clean
1391	CALL att_clean(tl_att(:))
1392	DEALLOCATE(tl_att)
1393
1394	ENDIF
1395	ENDIF
1396	ENDIF
1397
1398	END SUBROUTINE file__del_att_str
1399	!-------------------------------------------------------------------
1400	!> @brief This subroutine move a global attribute structure
1401	!> from file structure.
1402	!> @warning change attribute id in file structure.
1403	!
1404	!> @author J.Paul
1405	!> - November, 2013- Initial Version
1406	!
1407	!> @param[inout] td_file file structure
1408	!> @param[in] td_att attribute structure
1409	!-------------------------------------------------------------------
1410	SUBROUTINE file_move_att(td_file, td_att)
1411	IMPLICIT NONE
1412
1413	! Argument
1414	TYPE(TFILE), INTENT(INOUT) :: td_file
1415	TYPE(TATT), INTENT(IN) :: td_att
1416
1417	! local variable
1418	TYPE(TATT) :: tl_att
1419	INTEGER(i4) :: il_ind
1420	!----------------------------------------------------------------
1421
1422	! copy attribute
1423	tl_att=att_copy(td_att)
1424
1425	IF( ASSOCIATED(td_file%t_att) )THEN
1426	il_ind=att_get_index(td_file%t_att(:),TRIM(tl_att%c_name))
1427	IF( il_ind /= 0 )THEN
1428	! remove attribute with same name
1429	CALL file_del_att(td_file, tl_att)
1430	ENDIF
1431	ENDIF
1432
1433	! add new attribute
1434	CALL file_add_att(td_file, tl_att)
1435
1436	! clean
1437	CALL att_clean(tl_att)
1438
1439	END SUBROUTINE file_move_att
1440	!-------------------------------------------------------------------
1441	!> @brief This subroutine add a dimension structure in file
1442	!> structure.
1443	!> Do not overwrite, if dimension already in file structure.
1444	!
1445	!> @author J.Paul
1446	!> - November, 2013- Initial Version
1447	!> @date September, 2014
1448	!> - do not reorder dimension, before put in file
1449	!
1450	!> @param[inout] td_file file structure
1451	!> @param[in] td_dim dimension structure
1452	!-------------------------------------------------------------------
1453	SUBROUTINE file_add_dim(td_file, td_dim)
1454	IMPLICIT NONE
1455
1456	! Argument
1457	TYPE(TFILE) , INTENT(INOUT) :: td_file
1458	TYPE(TDIM) , INTENT(IN ) :: td_dim
1459
1460	! local variable
1461	INTEGER(i4) :: il_ind
1462
1463	! loop indices
1464	INTEGER(i4) :: ji
1465	!----------------------------------------------------------------
1466	! check if file opened
1467	IF( TRIM(td_file%c_name) == '' )THEN
1468
1469	CALL logger_error( " FILE ADD DIM: file structure unknown ")
1470	CALL logger_debug( " FILE ADD DIM: you should have used "//&
1471	& "file_init before running file_add_dim" )
1472
1473	ELSE
1474
1475	IF( td_file%i_ndim <= ip_maxdim )THEN
1476
1477	! check if dimension already in file structure
1478	il_ind=dim_get_index(td_file%t_dim(:), td_dim%c_sname)
1479	IF( il_ind /= 0 )THEN
1480	IF( td_file%t_dim(il_ind)%l_use )THEN
1481	CALL logger_error( &
1482	& "FILE ADD DIM: dimension "//TRIM(td_dim%c_name)//&
1483	& ", short name "//TRIM(td_dim%c_sname)//&
1484	& ", already used in file "//TRIM(td_file%c_name) )
1485	ELSE
1486	! replace dimension
1487	td_file%t_dim(il_ind)=dim_copy(td_dim)
1488	td_file%t_dim(il_ind)%i_id=il_ind
1489	td_file%t_dim(il_ind)%l_use=.TRUE.
1490	ENDIF
1491	ELSE
1492	IF( td_file%i_ndim == ip_maxdim )THEN
1493	CALL logger_error( &
1494	& "FILE ADD DIM: can not add dimension "//TRIM(td_dim%c_name)//&
1495	& ", short name "//TRIM(td_dim%c_sname)//&
1496	& ", in file "//TRIM(td_file%c_name)//". Already "//&
1497	& TRIM(fct_str(ip_maxdim))//" dimensions." )
1498	ELSE
1499	! search empty dimension
1500	DO ji=1,ip_maxdim
1501	IF( td_file%t_dim(ji)%i_id == 0 )THEN
1502	il_ind=ji
1503	EXIT
1504	ENDIF
1505	ENDDO
1506
1507	! add new dimension
1508	td_file%t_dim(il_ind)=dim_copy(td_dim)
1509	! update number of attribute
1510	td_file%i_ndim=COUNT(td_file%t_dim(:)%l_use)
1511
1512	td_file%t_dim(il_ind)%i_id=td_file%i_ndim
1513	td_file%t_dim(il_ind)%l_use=.TRUE.
1514	ENDIF
1515	ENDIF
1516
1517	ELSE
1518	CALL logger_error( &
1519	& " FILE ADD DIM: too much dimension in file "//&
1520	& TRIM(td_file%c_name)//" ("//TRIM(fct_str(td_file%i_ndim))//")")
1521	ENDIF
1522
1523	ENDIF
1524
1525	END SUBROUTINE file_add_dim
1526	!-------------------------------------------------------------------
1527	!> @brief This subroutine delete a dimension structure in file
1528	!> structure.
1529	!>
1530	!> @author J.Paul
1531	!> - November, 2013- Initial Version
1532	!
1533	!> @param[inout] td_file file structure
1534	!> @param[in] td_dim dimension structure
1535	!-------------------------------------------------------------------
1536	SUBROUTINE file_del_dim(td_file, td_dim)
1537	IMPLICIT NONE
1538
1539	! Argument
1540	TYPE(TFILE) , INTENT(INOUT) :: td_file
1541	TYPE(TDIM) , INTENT(IN ) :: td_dim
1542
1543	! local variable
1544	INTEGER(i4) :: il_status
1545	INTEGER(i4) :: il_ind
1546
1547	TYPE(TDIM), DIMENSION(:), ALLOCATABLE :: tl_dim
1548
1549	! loop indices
1550	INTEGER(i4) :: ji
1551	!----------------------------------------------------------------
1552	! check if file opened
1553	IF( TRIM(td_file%c_name) == '' )THEN
1554
1555	CALL logger_error( " FILE DEL DIM: file structure unknown ")
1556	CALL logger_debug( " FILE DEL DIM: you should have used "//&
1557	& "file_init before running file_del_dim" )
1558
1559	ELSE
1560
1561	! check if dimension already in file structure
1562	il_ind=dim_get_index(td_file%t_dim(:), td_dim%c_sname)
1563	IF( il_ind == 0 )THEN
1564
1565	CALL logger_error( &
1566	& "FILE DEL DIM: no dimension "//TRIM(td_dim%c_name)//&
1567	& ", short name "//TRIM(td_dim%c_sname)//&
1568	& ", in file "//TRIM(td_file%c_name) )
1569
1570	ELSE
1571	ALLOCATE( tl_dim(td_file%i_ndim-1), stat=il_status )
1572	IF(il_status /= 0 )THEN
1573
1574	CALL logger_error( &
1575	& "FILE DEL DIM: not enough space to put dimensions from "//&
1576	& TRIM(td_file%c_name)//" in temporary dimension structure")
1577
1578	ELSE
1579	! save temporary dimension's mpp structure
1580	tl_dim( 1 : il_ind-1 ) = dim_copy(td_file%t_dim(1 : il_ind-1))
1581	tl_dim( il_ind : td_file%i_ndim-1 ) = &
1582	& dim_copy(td_file%t_dim(il_ind+1 : td_file%i_ndim))
1583
1584	! remove dimension from file
1585	CALL dim_clean(td_file%t_dim(:))
1586	! copy dimension in file, except one
1587	td_file%t_dim(1:td_file%i_ndim)=dim_copy(tl_dim(:))
1588
1589	! update number of dimension
1590	td_file%i_ndim=td_file%i_ndim-1
1591
1592	! update dimension id
1593	DO ji=1,td_file%i_ndim
1594	td_file%t_dim(ji)%i_id=ji
1595	ENDDO
1596
1597	! clean
1598	CALL dim_clean(tl_dim(:))
1599	DEALLOCATE(tl_dim)
1600	ENDIF
1601	ENDIF
1602	ENDIF
1603
1604	END SUBROUTINE file_del_dim
1605	!-------------------------------------------------------------------
1606	!> @brief This subroutine move a dimension structure
1607	!> in file structure.
1608	!> @warning change dimension order in file structure.
1609	!
1610	!> @author J.Paul
1611	!> - November, 2013- Initial Version
1612	!
1613	!> @param[inout] td_file file structure
1614	!> @param[in] td_dim dimension structure
1615	!-------------------------------------------------------------------
1616	SUBROUTINE file_move_dim(td_file, td_dim)
1617	IMPLICIT NONE
1618
1619	! Argument
1620	TYPE(TFILE) , INTENT(INOUT) :: td_file
1621	TYPE(TDIM) , INTENT(IN ) :: td_dim
1622
1623	! local variable
1624	INTEGER(i4) :: il_ind
1625	INTEGER(i4) :: il_dimid
1626	!----------------------------------------------------------------
1627	IF( td_file%i_ndim <= ip_maxdim )THEN
1628
1629	! check if dimension already in mpp structure
1630	il_ind=dim_get_index(td_file%t_dim(:), td_dim%c_name, td_dim%c_sname)
1631	IF( il_ind /= 0 )THEN
1632
1633	il_dimid=td_file%t_dim(il_ind)%i_id
1634	! replace dimension
1635	td_file%t_dim(il_ind)=dim_copy(td_dim)
1636	td_file%t_dim(il_ind)%i_id=il_dimid
1637	td_file%t_dim(il_ind)%l_use=.TRUE.
1638
1639	ELSE
1640	CALL file_add_dim(td_file, td_dim)
1641	ENDIF
1642
1643	ELSE
1644	CALL logger_error( &
1645	& "FILE MOVE DIM: too much dimension in mpp "//&
1646	& TRIM(td_file%c_name)//" ("//TRIM(fct_str(td_file%i_ndim))//")")
1647	ENDIF
1648
1649	END SUBROUTINE file_move_dim
1650	!-------------------------------------------------------------------
1651	!> @brief This subroutine print some information about file strucutre.
1652	!
1653	!> @author J.Paul
1654	!> - November, 2013- Initial Version
1655	!
1656	!> @param[in] td_file file structure
1657	!-------------------------------------------------------------------
1658	SUBROUTINE file_print(td_file)
1659	IMPLICIT NONE
1660
1661	! Argument
1662	TYPE(TFILE), INTENT(IN) :: td_file
1663
1664	! local variable
1665	CHARACTER(LEN=lc) :: cl_mode
1666
1667	! loop indices
1668	INTEGER(i4) :: ji
1669	!----------------------------------------------------------------
1670
1671	cl_mode='READ'
1672	IF( td_file%l_wrt ) cl_mode='WRITE'
1673
1674	WRITE(*,'((a,a),2(/3x,a,a),4(/3x,a,i0))')&
1675	& "File : ",TRIM(td_file%c_name), &
1676	& " type : ",TRIM(td_file%c_type), &
1677	& " mode : ",TRIM(cl_mode), &
1678	& " id : ",td_file%i_id, &
1679	& " ndim : ",td_file%i_ndim, &
1680	& " natt : ",td_file%i_natt, &
1681	& " nvar : ",td_file%i_nvar
1682
1683	SELECT CASE(TRIM(td_file%c_type))
1684	CASE('cdf')
1685	WRITE(*,'((/3x,a,a),(/3x,a,i3))')&
1686	& "define mode : ",TRIM(fct_str(td_file%l_def)),&
1687	& "unlimited id : ",td_file%i_uldid
1688	CASE('dimg')
1689	WRITE(*,'(5(/3x,a,i0))')&
1690	& " record length : ",td_file%i_recl, &
1691	& " n0d : ",td_file%i_n0d, &
1692	& " n1d : ",td_file%i_n1d, &
1693	& " n2d : ",td_file%i_n2d, &
1694	& " n3d : ",td_file%i_n3d
1695	END SELECT
1696
1697	! print dimension
1698	IF( td_file%i_ndim /= 0 )THEN
1699	WRITE(*,'(/a)') " File dimension"
1700	DO ji=1,ip_maxdim
1701	IF( td_file%t_dim(ji)%l_use )THEN
1702	CALL dim_print(td_file%t_dim(ji))
1703	ENDIF
1704	ENDDO
1705	ENDIF
1706
1707	! print global attribute
1708	IF( td_file%i_natt /= 0 )THEN
1709	WRITE(*,'(/a)') " File attribute"
1710	DO ji=1,td_file%i_natt
1711	CALL att_print(td_file%t_att(ji))
1712	ENDDO
1713	ENDIF
1714
1715	! print variable
1716	IF( td_file%i_nvar /= 0 )THEN
1717	WRITE(*,'(/a)') " File variable"
1718	DO ji=1,td_file%i_nvar
1719	CALL var_print(td_file%t_var(ji))!,.FALSE.)
1720	ENDDO
1721	ENDIF
1722
1723	END SUBROUTINE file_print
1724	!-------------------------------------------------------------------
1725	!> @brief This function get suffix of file name.
1726	!> @details
1727	!> we assume suffix is define as alphanumeric character following the
1728	!> last '.' in file name.<br/>
1729	!> If no suffix is found, return empty character.
1730	!
1731	!> @author J.Paul
1732	!> - November, 2013- Initial Version
1733	!
1734	!> @param[in] cd_file file structure
1735	!> @return suffix
1736	!-------------------------------------------------------------------
1737	CHARACTER(LEN=lc) FUNCTION file__get_suffix(cd_file)
1738	IMPLICIT NONE
1739
1740	! Argument
1741	CHARACTER(LEN=*), INTENT(IN) :: cd_file
1742
1743	! local variable
1744	INTEGER(i4) :: il_ind
1745	!----------------------------------------------------------------
1746
1747	CALL logger_trace( "FILE GET SUFFIX: look for suffix in file name "//&
1748	& TRIM(cd_file) )
1749
1750	il_ind=INDEX(TRIM(cd_file),'.',BACK=.TRUE.)
1751	IF( il_ind /= 0 )THEN
1752	! read number in basename
1753	READ( cd_file(il_ind:),'(a)' ) file__get_suffix
1754
1755	IF( fct_is_num(file__get_suffix(2:)) )THEN
1756	file__get_suffix=''
1757	ENDIF
1758
1759	ELSE
1760	file__get_suffix=''
1761	ENDIF
1762
1763	END FUNCTION file__get_suffix
1764	!-------------------------------------------------------------------
1765	!> @brief This function get number in file name without suffix.
1766	!> @details
1767	!> Actually it get the number following the last separator.
1768	!> separator could be '.' or '_'.
1769	!
1770	!> @author J.Paul
1771	!> - November, 2013- Initial Version
1772	!
1773	!> @param[in] cd_file file name (without suffix)
1774	!> @return character file number.
1775	!-------------------------------------------------------------------
1776	CHARACTER(LEN=lc) FUNCTION file__get_number(cd_file)
1777	IMPLICIT NONE
1778
1779	! Argument
1780	CHARACTER(LEN=lc), INTENT(IN) :: cd_file
1781
1782	! local variable
1783	INTEGER(i4) :: il_indmax
1784	INTEGER(i4) :: il_ind
1785
1786	! loop indices
1787	INTEGER(i4) :: ji
1788	!----------------------------------------------------------------
1789
1790	! get number position in file name
1791	il_indmax=0
1792	DO ji=1,ip_nsep
1793	il_ind=INDEX(TRIM(cd_file),TRIM(cp_sep(ji)),BACK=.TRUE.)
1794	IF( il_ind > il_indmax )THEN
1795	il_indmax=il_ind
1796	ENDIF
1797	ENDDO
1798
1799	IF( il_indmax /= 0 )THEN
1800	! read number in basename
1801	READ( cd_file(il_indmax:),'(a)' ) file__get_number
1802
1803	IF( .NOT. fct_is_num(file__get_number(2:)) )THEN
1804	file__get_number=''
1805	ENDIF
1806	ELSE
1807	file__get_number=''
1808	ENDIF
1809
1810	END FUNCTION file__get_number
1811	!-------------------------------------------------------------------
1812	!> @brief This function rename file name, given processor number.
1813	!> @details
1814	!> If no processor number is given, return file name without number
1815	!> If processor number is given, return file name with new number
1816	!
1817	!> @author J.Paul
1818	!> - November, 2013- Initial Version
1819	!
1820	!> @param[in] td_file file structure
1821	!> @param[in] id_num processor number (start to 1)
1822	!> @return file name
1823	!-------------------------------------------------------------------
1824	CHARACTER(LEN=lc) FUNCTION file__rename_char(cd_file, id_num)
1825	IMPLICIT NONE
1826
1827	! Argument
1828	CHARACTER(LEN=*), INTENT(IN) :: cd_file
1829	INTEGER(i4), INTENT(IN), OPTIONAL :: id_num
1830
1831	! local variable
1832	CHARACTER(LEN=lc) :: cl_suffix
1833	CHARACTER(LEN=lc) :: cl_file
1834	CHARACTER(LEN=lc) :: cl_number
1835	CHARACTER(LEN=lc) :: cl_base
1836	CHARACTER(LEN=lc) :: cl_sep
1837	CHARACTER(LEN=lc) :: cl_format
1838	INTEGER(i4) :: il_ind
1839	INTEGER(i4) :: il_numlen
1840	!----------------------------------------------------------------
1841
1842	! get suffix
1843	cl_suffix=file__get_suffix(cd_file)
1844	IF( TRIM(cl_suffix) /= '' )THEN
1845	il_ind=INDEX(TRIM(cd_file),TRIM(cl_suffix(1:1)),BACK=.TRUE.)
1846	cl_file=TRIM(cd_file(:il_ind-1))
1847	ELSE
1848	cl_file=TRIM(cd_file)
1849	ENDIF
1850
1851	cl_number=file__get_number(cl_file)
1852	IF( TRIM(cl_number) /= '' )THEN
1853	il_ind=INDEX(TRIM(cl_file),TRIM(cl_number(1:1)),BACK=.TRUE.)
1854	cl_base=TRIM(cl_file(:il_ind-1))
1855
1856	cl_sep=TRIM(cl_number(1:1))
1857	il_numlen=LEN(TRIM(cl_number))-1
1858	ELSE
1859	cl_base=TRIM(cl_file)
1860	il_numlen=4
1861	cl_sep='_'
1862	ENDIF
1863
1864	IF( PRESENT(id_num) )THEN
1865	! format
1866	WRITE(cl_format,'(a,i1.1,a,i1.1,a)') '(a,a,i',il_numlen,'.',il_numlen,',a)'
1867	WRITE(file__rename_char,cl_format) TRIM(cl_base),TRIM(cl_sep),id_num,TRIM(cl_suffix)
1868	ELSE
1869	WRITE(file__rename_char,'(a,a)') TRIM(cl_base),TRIM(cl_suffix)
1870	ENDIF
1871	CALL logger_trace(" FILE RENAME : "//TRIM(file__rename_char))
1872
1873	END FUNCTION file__rename_char
1874	!-------------------------------------------------------------------
1875	!> @brief This function rename file name, given file structure.
1876	!> @details
1877	!> If no processor number is given, return file name without number
1878	!> I processor number is given, return file name with new number
1879	!
1880	!> @author J.Paul
1881	!> - November, 2013- Initial Version
1882	!
1883	!> @param[in] td_file file structure
1884	!> @param[in] id_num processor number (start to 1)
1885	!> @return file structure
1886	!-------------------------------------------------------------------
1887	TYPE(TFILE) FUNCTION file__rename_str(td_file, id_num)
1888	IMPLICIT NONE
1889
1890	! Argument
1891	TYPE(TFILE), INTENT(IN) :: td_file
1892	INTEGER(i4), INTENT(IN), OPTIONAL :: id_num
1893
1894	! local variable
1895	CHARACTER(LEN=lc) :: cl_name
1896	!----------------------------------------------------------------
1897
1898	! change name
1899	cl_name=TRIM( file_rename(td_file%c_name, id_num) )
1900
1901	file__rename_str=file_init(TRIM(cl_name), TRIM(td_file%c_type))
1902
1903	END FUNCTION file__rename_str
1904	!-------------------------------------------------------------------
1905	!> @brief This function add suffix to file name.
1906	!
1907	!> @author J.Paul
1908	!> - November, 2013- Initial Version
1909	!
1910	!> @param[in] td_file file structure
1911	!> @return file name
1912	!-------------------------------------------------------------------
1913	CHARACTER(LEN=lc) FUNCTION file_add_suffix(cd_file, cd_type)
1914	IMPLICIT NONE
1915
1916	! Argument
1917	CHARACTER(LEN=*), INTENT(IN) :: cd_file
1918	CHARACTER(LEN=*), INTENT(IN) :: cd_type
1919
1920	! local variable
1921	INTEGER(i4) :: il_ind
1922	CHARACTER(LEN=lc) :: cl_file
1923	CHARACTER(LEN=lc) :: cl_suffix
1924	!----------------------------------------------------------------
1925	! get suffix
1926	cl_suffix=file__get_suffix(cd_file)
1927	IF( TRIM(cl_suffix) /= '' )THEN
1928	il_ind=INDEX(TRIM(cd_file),TRIM(cl_suffix(1:1)),BACK=.TRUE.)
1929	cl_file=TRIM(cd_file(:il_ind-1))
1930	ELSE
1931	cl_file=TRIM(cd_file)
1932	ENDIF
1933
1934	SELECT CASE(TRIM(cd_type))
1935	CASE('cdf')
1936	file_add_suffix=TRIM(cl_file)//'.nc'
1937	CASE('dimg')
1938	IF( TRIM(cl_suffix) /= '' )THEN
1939	file_add_suffix=TRIM(cl_file)//'.dimg'
1940	ELSE
1941	file_add_suffix=TRIM(cl_file)
1942	ENDIF
1943	CASE DEFAULT
1944	CALL logger_error(" FILE ADD SUFFIX: type unknown "//TRIM(cd_type))
1945	END SELECT
1946
1947	END FUNCTION file_add_suffix
1948	!-------------------------------------------------------------------
1949	!> @brief
1950	!> This subroutine clean file strcuture.
1951	!
1952	!> @author J.Paul
1953	!> @date November, 2013 - Inital version
1954	!
1955	!> @param[inout] td_file file strcuture
1956	!-------------------------------------------------------------------
1957	SUBROUTINE file__clean_unit( td_file )
1958	IMPLICIT NONE
1959	! Argument
1960	TYPE(TFILE), INTENT(INOUT) :: td_file
1961
1962	! local variable
1963	TYPE(TFILE) :: tl_file ! empty file structure
1964
1965	! loop indices
1966	!----------------------------------------------------------------
1967
1968	CALL logger_trace( &
1969	& " FILE CLEAN: reset file "//TRIM(td_file%c_name) )
1970
1971	! del attribute
1972	IF( ASSOCIATED( td_file%t_att ) )THEN
1973	CALL att_clean( td_file%t_att(:) )
1974	DEALLOCATE(td_file%t_att)
1975	ENDIF
1976
1977	! del dimension
1978	IF( td_file%i_ndim /= 0 )THEN
1979	CALL dim_clean( td_file%t_dim(:) )
1980	ENDIF
1981
1982	! del variable
1983	IF( ASSOCIATED( td_file%t_var ) )THEN
1984	CALL var_clean( td_file%t_var(:) )
1985	DEALLOCATE(td_file%t_var)
1986	ENDIF
1987
1988	! replace by empty structure
1989	td_file=file_copy(tl_file)
1990
1991	END SUBROUTINE file__clean_unit
1992	!-------------------------------------------------------------------
1993	!> @brief
1994	!> This subroutine clean file array of file strcuture.
1995	!
1996	!> @author J.Paul
1997	!> @date Marsh, 2014 - Inital version
1998	!
1999	!> @param[inout] td_file array file strcuture
2000	!-------------------------------------------------------------------
2001	SUBROUTINE file__clean_arr( td_file )
2002	IMPLICIT NONE
2003	! Argument
2004	TYPE(TFILE), DIMENSION(:), INTENT(INOUT) :: td_file
2005
2006	! local variable
2007	! loop indices
2008	INTEGER(i4) :: ji
2009	!----------------------------------------------------------------
2010
2011	DO ji=SIZE(td_file(:)),1,-1
2012	CALL file_clean(td_file(ji))
2013	ENDDO
2014
2015	END SUBROUTINE file__clean_arr
2016	!-------------------------------------------------------------------
2017	!> @brief This function return the file id, in a array of file
2018	!> structure, given file name.
2019	!
2020	!> @author J.Paul
2021	!> - November, 2013- Initial Version
2022	!
2023	!> @param[in] td_file array of file structure
2024	!> @param[in] cd_name file name
2025	!> @return file id in array of file structure (0 if not found)
2026	!-------------------------------------------------------------------
2027	INTEGER(i4) FUNCTION file_get_id(td_file, cd_name)
2028	IMPLICIT NONE
2029	! Argument
2030	TYPE(TFILE) , DIMENSION(:), INTENT(IN) :: td_file
2031	CHARACTER(LEN=*), INTENT(IN) :: cd_name
2032
2033	! local variable
2034	INTEGER(i4) :: il_size
2035
2036	! loop indices
2037	INTEGER(i4) :: ji
2038	!----------------------------------------------------------------
2039	file_get_id=0
2040	il_size=SIZE(td_file(:))
2041
2042	! check if file is in array of file structure
2043	DO ji=1,il_size
2044	! look for file name
2045	IF( fct_lower(td_file(ji)%c_name) == fct_lower(cd_name) )THEN
2046
2047	file_get_id=td_file(ji)%i_id
2048	EXIT
2049
2050	ENDIF
2051	ENDDO
2052
2053	END FUNCTION file_get_id
2054	!-------------------------------------------------------------------
2055	!> @brief
2056	!> This function get the next unused unit in array of file structure.
2057	!>
2058	!> @author J.Paul
2059	!> - September, 2014- Initial Version
2060	!
2061	!> @param[in] td_file array of file
2062	!-------------------------------------------------------------------
2063	FUNCTION file_get_unit(td_file)
2064	IMPLICIT NONE
2065	! Argument
2066	TYPE(TFILE), DIMENSION(:), INTENT(IN ) :: td_file
2067
2068	! function
2069	INTEGER(i4) :: file_get_unit
2070
2071	! local variable
2072	! loop indices
2073	!----------------------------------------------------------------
2074
2075	file_get_unit=MAXVAL(td_file(:)%i_id)+1
2076
2077	END FUNCTION file_get_unit
2078	END MODULE file
2079

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

Download in other formats: