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 NEMO/releases/release-3.6/NEMOGCM/TOOLS/SIREN/src – NEMO

Context Navigation

source: NEMO/releases/release-3.6/NEMOGCM/TOOLS/SIREN/src/file.f90 @ 11998

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

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

Download in other formats: