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

Context Navigation

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

Last change on this file since 7351 was 7351, checked in by emanuelaclementi, 7 years ago
ticket #1805 step 3: /2016/dev_INGV_UKMO_2016 aligned to the trunk at revision 7161
File size: 72.9 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	file_init%c_type=TRIM(file_get_type(cd_file))
498	ENDIF
499
500	! create some global attribute
501	IF( TRIM(file_init%c_type) == 'cdf' )THEN
502	tl_att=att_init("Conventions","CF-1.5")
503	CALL file_add_att(file_init,tl_att)
504	ENDIF
505
506	tl_att=att_init("Grid",TRIM(file_init%c_grid))
507	CALL file_add_att(file_init,tl_att)
508
509	IF( PRESENT(ld_wrt) )THEN
510	file_init%l_wrt=ld_wrt
511	ENDIF
512
513	IF( PRESENT(id_ew) )THEN
514	file_init%i_ew=id_ew
515	IF( id_ew >= 0 )THEN
516	tl_att=att_init('ew_overlap',id_ew)
517	CALL file_move_att(file_init, tl_att)
518	ENDIF
519	ENDIF
520
521	IF( PRESENT(id_perio) )THEN
522	file_init%i_perio=id_perio
523	IF( id_perio >= 0 )THEN
524	tl_att=att_init('periodicity',id_perio)
525	CALL file_move_att(file_init, tl_att)
526	ENDIF
527	ENDIF
528
529	IF( PRESENT(id_pivot) )THEN
530	file_init%i_pivot=id_pivot
531	IF( id_pivot > 0 )THEN
532	tl_att=att_init('pivot_point',id_pivot)
533	CALL file_move_att(file_init, tl_att)
534	ENDIF
535	ENDIF
536
537	IF( PRESENT(cd_grid) )THEN
538	file_init%c_grid=cd_grid
539	ENDIF
540
541	! clean
542	CALL att_clean(tl_att)
543
544	END FUNCTION file_init
545	!-------------------------------------------------------------------
546	!> @brief
547	!> This function get type of file, given file name.
548	!> @details
549	!> Actually it get suffix of the file name, and compare it to 'nc', 'cdf' or
550	!> 'dimg'<br/>
551	!> If no suffix or suffix not identify, we assume file is dimg
552	!
553	!> @details
554	!
555	!> @author J.Paul
556	!> @date November, 2013 - Initial Version
557	!
558	!> @param[in] cd_file file name
559	!> @return type of file
560	!-------------------------------------------------------------------
561	CHARACTER(LEN=lc) FUNCTION file_get_type(cd_file)
562	IMPLICIT NONE
563	! Argument
564	CHARACTER(LEN=*), INTENT(IN) :: cd_file
565
566	!local variable
567	CHARACTER(LEN=lc) :: cl_suffix
568	!----------------------------------------------------------------
569
570	cl_suffix=file__get_suffix(cd_file)
571	SELECT CASE( TRIM(fct_lower(cl_suffix)) )
572	CASE('.nc','.cdf')
573	CALL logger_debug(" FILE GET TYPE: file "//TRIM(cd_file)//" is cdf")
574	file_get_type='cdf'
575	CASE('.dimg')
576	CALL logger_debug(" FILE GET TYPE: file "//TRIM(cd_file)//" is dimg" )
577	file_get_type='dimg'
578	CASE DEFAULT
579	CALL logger_warn(" FILE GET TYPE: type unknown, we assume file: "//&
580	& TRIM(cd_file)//" is dimg ")
581	file_get_type='dimg'
582	END SELECT
583
584	END FUNCTION file_get_type
585	!-------------------------------------------------------------------
586	!> @brief This function check if variable dimension to be used
587	!> have the same length that in file structure.
588	!
589	!> @details
590	!
591	!> @author J.Paul
592	!> @date November, 2013 - Initial Version
593	!
594	!> @param[in] td_file file structure
595	!> @param[in] td_var variable structure
596	!> @return true if dimension of variable and file structure agree
597	!-------------------------------------------------------------------
598	LOGICAL FUNCTION file_check_var_dim(td_file, td_var)
599	IMPLICIT NONE
600	! Argument
601	TYPE(TFILE), INTENT(IN) :: td_file
602	TYPE(TVAR), INTENT(IN) :: td_var
603
604	! local variable
605	CHARACTER(LEN=lc) :: cl_dim
606	LOGICAL :: ll_error
607	LOGICAL :: ll_warn
608
609	INTEGER(i4) :: il_ind
610
611	! loop indices
612	INTEGER(i4) :: ji
613	!----------------------------------------------------------------
614	file_check_var_dim=.TRUE.
615
616	! check used dimension
617	ll_error=.FALSE.
618	ll_warn=.FALSE.
619	DO ji=1,ip_maxdim
620	il_ind=dim_get_index( td_file%t_dim(:), &
621	& TRIM(td_var%t_dim(ji)%c_name), &
622	& TRIM(td_var%t_dim(ji)%c_sname))
623	IF( il_ind /= 0 )THEN
624	IF( td_var%t_dim(ji)%l_use .AND. &
625	& td_file%t_dim(il_ind)%l_use .AND. &
626	& td_var%t_dim(ji)%i_len /= td_file%t_dim(il_ind)%i_len )THEN
627	IF( INDEX( TRIM(td_var%c_axis), &
628	& TRIM(fct_upper(td_var%t_dim(ji)%c_name))) == 0 )THEN
629	ll_warn=.TRUE.
630	ELSE
631	ll_error=.TRUE.
632	ENDIF
633	ENDIF
634	ENDIF
635	ENDDO
636
637	IF( ll_error )THEN
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	file_check_var_dim=.FALSE.
662
663	CALL logger_error( &
664	& " FILE CHECK VAR DIM: variable and file dimension differ"//&
665	& " for variable "//TRIM(td_var%c_name)//&
666	& " and file "//TRIM(td_file%c_name))
667
668	ELSEIF( ll_warn )THEN
669	CALL logger_warn( &
670	& " FILE CHECK VAR DIM: variable and file dimension differ"//&
671	& " for variable "//TRIM(td_var%c_name)//&
672	& " and file "//TRIM(td_file%c_name)//". you should use"//&
673	& " var_check_dim to remove useless dimension.")
674	ELSE
675
676	IF( td_var%i_ndim > td_file%i_ndim )THEN
677	CALL logger_info("FILE CHECK VAR DIM: variable "//&
678	& TRIM(td_var%c_name)//" use more dimension than file "//&
679	& TRIM(td_file%c_name)//" do until now.")
680	ENDIF
681
682	ENDIF
683
684	END FUNCTION file_check_var_dim
685	!-------------------------------------------------------------------
686	!> @brief This subroutine add a variable structure in a file structure.<br/>
687	!> Do not overwrite, if variable already in file structure.
688	!
689	!> @note variable value is suppose to be ordered ('x','y','z','t')
690	!
691	!> @details
692	!
693	!> @author J.Paul
694	!> @date November, 2013 - Initial Version
695	!> @date September, 2014
696	!> - add dimension in file if need be
697	!> - do not reorder dimension from variable, before put in file
698	!> @date September, 2015
699	!> - check variable dimension expected
700	!
701	!> @param[inout] td_file file structure
702	!> @param[in] td_var variable structure
703	!-------------------------------------------------------------------
704	SUBROUTINE file_add_var(td_file, td_var)
705	IMPLICIT NONE
706
707	! Argument
708	TYPE(TFILE), INTENT(INOUT) :: td_file
709	TYPE(TVAR) , INTENT(INOUT) :: td_var
710
711	! local variable
712	INTEGER(i4) :: il_status
713	!INTEGER(i4) :: il_rec
714	INTEGER(i4) :: il_ind
715
716	TYPE(TVAR), DIMENSION(:), ALLOCATABLE :: tl_var
717
718	! loop indices
719	INTEGER(i4) :: ji
720	!----------------------------------------------------------------
721	! check if file opened
722	IF( TRIM(td_file%c_name) == '' )THEN
723
724	CALL logger_debug( " FILE ADD VAR: you should have used file_init before "//&
725	& "running file_add_var" )
726	CALL logger_error( " FILE ADD VAR: structure file unknown" )
727
728	ELSE
729	! check if variable exist
730	IF( TRIM(td_var%c_name) == '' .AND. &
731	& TRIM(td_var%c_stdname) == '' )THEN
732	CALL logger_error(" FILE ADD VAR: variable without name ")
733	ELSE
734	! check if variable already in file structure
735	il_ind=0
736	IF( ASSOCIATED(td_file%t_var) )THEN
737	il_ind=var_get_index( td_file%t_var(:), td_var%c_name, &
738	& td_var%c_stdname )
739	ENDIF
740	CALL logger_debug( &
741	& " FILE ADD VAR: ind "//TRIM(fct_str(il_ind)) )
742	IF( il_ind /= 0 )THEN
743
744	CALL logger_error( &
745	& " FILE ADD VAR: variable "//TRIM(td_var%c_name)//&
746	& ", standard name "//TRIM(td_var%c_stdname)//&
747	& ", already in file "//TRIM(td_file%c_name) )
748
749	DO ji=1,td_file%i_nvar
750	CALL logger_debug( " ADD VAR: in file : &
751	& variable "//TRIM(td_file%t_var(ji)%c_name)//&
752	& ", standard name "//TRIM(td_file%t_var(ji)%c_stdname) )
753	ENDDO
754
755	ELSE
756
757	CALL logger_debug( &
758	& " FILE ADD VAR: add variable "//TRIM(td_var%c_name)//&
759	& ", standard name "//TRIM(td_var%c_stdname)//&
760	& ", in file "//TRIM(td_file%c_name) )
761
762	! check used dimension
763	IF( file_check_var_dim(td_file, td_var) )THEN
764
765	! check variable dimension expected
766	CALL var_check_dim(td_var)
767
768	! update dimension if need be
769	DO ji=1,ip_maxdim
770	IF( td_var%t_dim(ji)%l_use .AND. &
771	& .NOT. td_file%t_dim(ji)%l_use )THEN
772	CALL file_add_dim(td_file,td_var%t_dim(ji))
773	ENDIF
774	ENDDO
775
776	! get index of new variable
777	SELECT CASE(td_var%i_ndim)
778	CASE(0)
779	il_ind=td_file%i_n0d+1
780	!il_rec=0
781	CASE(1)
782	il_ind=td_file%i_n0d+td_file%i_n1d+1
783	!il_rec=1
784	CASE(2)
785	il_ind=td_file%i_n0d+td_file%i_n1d+td_file%i_n2d+1
786	!il_rec=1
787	CASE(3,4)
788	il_ind=td_file%i_n0d+td_file%i_n1d+td_file%i_n2d+td_file%i_n3d+1
789	!il_rec=td_file%t_dim(3)%i_len
790	END SELECT
791
792	IF( td_file%i_nvar > 0 )THEN
793	! already other variable in file structure
794	ALLOCATE( tl_var(td_file%i_nvar), stat=il_status )
795	IF(il_status /= 0 )THEN
796
797	CALL logger_error( &
798	& " FILE ADD VAR: not enough space to put variables "//&
799	& "from "//TRIM(td_file%c_name)//&
800	& " in variable structure")
801
802	ELSE
803
804	! save temporary variable of file structure
805	tl_var(:)=var_copy(td_file%t_var(:))
806
807	CALL var_clean( td_file%t_var(:) )
808	DEALLOCATE(td_file%t_var)
809	ALLOCATE( td_file%t_var(td_file%i_nvar+1), &
810	& stat=il_status)
811	IF(il_status /= 0 )THEN
812
813	CALL logger_error( &
814	& " FILE ADD VAR: not enough space to put variable "//&
815	& "in file structure "//TRIM(td_file%c_name) )
816
817	ENDIF
818
819	! copy variable in file before
820	! variable with less than or equal dimension that new variable
821	IF( il_ind > 1 )THEN
822	td_file%t_var( 1:il_ind-1 ) = var_copy(tl_var(1:il_ind-1))
823	ENDIF
824
825	IF( il_ind < td_file%i_nvar+1 )THEN
826	! variable with more dimension than new variable
827	td_file%t_var( il_ind+1 : td_file%i_nvar+1 ) = &
828	& var_copy( tl_var(il_ind : td_file%i_nvar) )
829	ENDIF
830
831	! clean
832	CALL var_clean(tl_var(:))
833	DEALLOCATE(tl_var)
834	ENDIF
835
836	ELSE
837	! no variable in file structure
838	IF( ASSOCIATED(td_file%t_var) )THEN
839	CALL var_clean(td_file%t_var(:))
840	DEALLOCATE(td_file%t_var)
841	ENDIF
842	ALLOCATE( td_file%t_var(td_file%i_nvar+1), stat=il_status )
843	IF(il_status /= 0 )THEN
844
845	CALL logger_error( &
846	& " FILE ADD VAR: not enough space to put variable "//&
847	& "in file structure "//TRIM(td_file%c_name) )
848
849	ENDIF
850
851	ENDIF
852
853	! add new variable in array of variable
854	ALLOCATE( tl_var(1), stat=il_status )
855	IF(il_status /= 0 )THEN
856
857	CALL logger_error( &
858	& " FILE ADD VAR: not enough space to put variables from "//&
859	& TRIM(td_var%c_name)//" in variable structure")
860
861	ELSE
862	tl_var(1)=var_copy(td_var)
863
864	! update dimension name in new variable
865	tl_var(1)%t_dim(:)%c_name = td_file%t_dim(:)%c_name
866
867	! add new variable
868	td_file%t_var(il_ind)=var_copy(tl_var(1))
869
870	! update number of variable
871	td_file%i_nvar=td_file%i_nvar+1
872	SELECT CASE(tl_var(1)%i_ndim)
873	CASE(0)
874	td_file%i_n0d=td_file%i_n0d+1
875	CASE(1)
876	td_file%i_n1d=td_file%i_n1d+1
877	CASE(2)
878	td_file%i_n2d=td_file%i_n2d+1
879	CASE(3,4)
880	td_file%i_n3d=td_file%i_n3d+1
881	END SELECT
882
883	! update variable id
884	td_file%t_var(il_ind)%i_id=var_get_unit(td_file%t_var(:))
885
886	! update dimension used
887	td_file%t_dim(:)%l_use=.FALSE.
888	DO ji=1,ip_maxdim
889	IF( ANY(td_file%t_var(:)%t_dim(ji)%l_use) )THEN
890	td_file%t_dim(ji)%l_use=.TRUE.
891	ENDIF
892	ENDDO
893
894	! update number of dimension
895	td_file%i_ndim=COUNT(td_file%t_dim(:)%l_use)
896
897	! clean
898	CALL var_clean( tl_var(:) )
899	DEALLOCATE(tl_var)
900	ENDIF
901	ENDIF
902	ENDIF
903	ENDIF
904	ENDIF
905
906	END SUBROUTINE file_add_var
907	!-------------------------------------------------------------------
908	!> @brief This subroutine delete a variable structure
909	!> in file structure, given variable name or standard name.
910	!
911	!> @author J.Paul
912	!> @date November, 2013 - Initial Version
913	!> @date February, 2015
914	!> - define local variable structure to avoid mistake with pointer
915	!
916	!> @param[inout] td_file file structure
917	!> @param[in] cd_name variable name or standard name
918	!-------------------------------------------------------------------
919	SUBROUTINE file__del_var_name(td_file, cd_name )
920	IMPLICIT NONE
921
922	! Argument
923	TYPE(TFILE) , INTENT(INOUT) :: td_file
924	CHARACTER(LEN=*), INTENT(IN ) :: cd_name
925
926	! local variable
927	INTEGER(i4) :: il_ind
928	TYPE(TVAR) :: tl_var
929	!----------------------------------------------------------------
930
931	! check if file opened
932	IF( TRIM(td_file%c_name) == '' )THEN
933
934	CALL logger_error( " FILE DEL VAR NAME: file structure unknown ")
935	CALL logger_debug( " FILE DEL VAR NAME: you should have used file_init before "//&
936	& "running file_del_var" )
937
938	ELSE
939
940	IF( td_file%i_nvar /= 0 )THEN
941
942	! get the variable index, in file variable structure
943	il_ind=0
944	IF( ASSOCIATED(td_file%t_var) )THEN
945	il_ind=var_get_index(td_file%t_var(:), cd_name )
946	ENDIF
947
948	IF( il_ind /= 0 )THEN
949
950	tl_var=var_copy(td_file%t_var(il_ind))
951	CALL file_del_var(td_file, tl_var)
952
953	ELSE
954
955	CALL logger_debug( &
956	& " FILE DEL VAR NAME: there is no variable with name or "//&
957	& "standard name "//TRIM(cd_name)//" in file "//&
958	& TRIM(td_file%c_name))
959
960	ENDIF
961
962	ELSE
963	CALL logger_debug( " FILE DEL VAR NAME: "//&
964	& "no variable associated to file "//&
965	& TRIM(td_file%c_name) )
966	ENDIF
967
968	ENDIF
969
970	END SUBROUTINE file__del_var_name
971	!-------------------------------------------------------------------
972	!> @brief This subroutine delete a variable structure
973	!> in file structure, given variable structure.
974	!>
975	!> @author J.Paul
976	!> @date November, 2013 - Initial Version
977	!>
978	!> @param[inout] td_file file structure
979	!> @param[in] td_var variable structure
980	!-------------------------------------------------------------------
981	SUBROUTINE file__del_var_str(td_file, td_var)
982	IMPLICIT NONE
983
984	! Argument
985	TYPE(TFILE), INTENT(INOUT) :: td_file
986	TYPE(TVAR), INTENT(IN) :: td_var
987
988	! local variable
989	INTEGER(i4) :: il_status
990	INTEGER(i4) :: il_ind
991	INTEGER(i4) :: il_rec
992	TYPE(TVAR), DIMENSION(:), ALLOCATABLE :: tl_var
993
994	! loop indices
995	INTEGER(i4) :: ji
996	!----------------------------------------------------------------
997
998	! check if file opened
999	IF( TRIM(td_file%c_name) == '' )THEN
1000
1001	CALL logger_error( " FILE DEL VAR: file structure unknown ")
1002	CALL logger_debug( " FILE DEL VAR: you should have used "//&
1003	& "file_init before running file_del_var" )
1004
1005	ELSE
1006
1007	! check if variable is member of a file
1008	IF( td_var%l_file )THEN
1009	CALL logger_warn( &
1010	& " FILE DEL VAR: variable "//TRIM(td_var%c_name)//&
1011	& ", belong to file "//TRIM(td_file%c_name)//&
1012	& " and can not be removed.")
1013	ELSE
1014	! check if variable already in file structure
1015	il_ind=0
1016	IF( ASSOCIATED(td_file%t_var) )THEN
1017	il_ind=var_get_index( td_file%t_var(:), td_var%c_name, &
1018	& td_var%c_stdname )
1019	ENDIF
1020
1021	IF( il_ind == 0 )THEN
1022
1023	CALL logger_warn( "FILE DEL VAR: no variable "//&
1024	& TRIM(td_var%c_name)//", in file "//TRIM(td_file%c_name) )
1025
1026	DO ji=1,td_file%i_nvar
1027	CALL logger_debug( "FILE DEL VAR: in file "//&
1028	& TRIM(td_file%t_var(ji)%c_name)//", standard name "//&
1029	& TRIM(td_file%t_var(ji)%c_stdname) )
1030	ENDDO
1031
1032	ELSE
1033
1034	CALL logger_trace( "FILE DEL VAR: delete variable "//&
1035	& TRIM(td_var%c_name)//", from file "//TRIM(td_file%c_name) )
1036
1037	ALLOCATE( tl_var(td_file%i_nvar-1), stat=il_status )
1038	IF(il_status /= 0 )THEN
1039
1040	CALL logger_error( &
1041	& " FILE DEL VAR: not enough space to put variables from "//&
1042	& TRIM(td_file%c_name)//" in temporary variable structure")
1043
1044	ELSE
1045
1046	! save temporary variable's file structure
1047	IF( il_ind > 1 )THEN
1048	tl_var(1:il_ind-1)=var_copy(td_file%t_var(1:il_ind-1))
1049	ENDIF
1050
1051	IF( il_ind < td_file%i_nvar )THEN
1052	tl_var(il_ind:)=var_copy(td_file%t_var(il_ind+1:))
1053	ENDIF
1054
1055	! new number of variable in file
1056	td_file%i_nvar=td_file%i_nvar-1
1057	SELECT CASE(td_var%i_ndim)
1058	CASE(0)
1059	td_file%i_n0d=td_file%i_n0d-1
1060	il_rec=0
1061	CASE(1)
1062	td_file%i_n1d=td_file%i_n1d-1
1063	il_rec=1
1064	CASE(2)
1065	td_file%i_n2d=td_file%i_n2d-1
1066	il_rec=1
1067	CASE(3,4)
1068	td_file%i_n3d=td_file%i_n3d-1
1069	il_rec=td_file%t_dim(3)%i_len
1070	END SELECT
1071
1072	CALL var_clean( td_file%t_var(:) )
1073	DEALLOCATE(td_file%t_var)
1074
1075	IF( td_file%i_nvar > 0 )THEN
1076	ALLOCATE( td_file%t_var(td_file%i_nvar), stat=il_status )
1077	IF(il_status /= 0 )THEN
1078
1079	CALL logger_error( " FILE DEL VAR: not enough space"//&
1080	& "to put variables in file structure "//&
1081	& TRIM(td_file%c_name) )
1082
1083	ENDIF
1084
1085	! copy attribute in file before
1086	td_file%t_var(:)=var_copy(tl_var(:))
1087
1088	! update dimension used
1089	td_file%t_dim(:)%l_use=.FALSE.
1090	DO ji=1,ip_maxdim
1091	IF( ANY(td_file%t_var(:)%t_dim(ji)%l_use) )THEN
1092	td_file%t_dim(ji)%l_use=.TRUE.
1093	ENDIF
1094	ENDDO
1095
1096	! update number of dimension
1097	td_file%i_ndim=COUNT(td_file%t_dim(:)%l_use)
1098
1099	ENDIF
1100
1101	! clean
1102	CALL var_clean(tl_var(:))
1103	DEALLOCATE(tl_var)
1104
1105	ENDIF
1106	ENDIF
1107	ENDIF
1108	ENDIF
1109
1110	END SUBROUTINE file__del_var_str
1111	!-------------------------------------------------------------------
1112	!> @brief This subroutine overwrite variable structure
1113	!> in file structure.
1114	!
1115	!> @warning change variable id in file structure.
1116	!
1117	!> @author J.Paul
1118	!> @date November, 2013 - Initial Version
1119	!
1120	!> @param[inout] td_file file structure
1121	!> @param[in] td_var variable structure
1122	!-------------------------------------------------------------------
1123	SUBROUTINE file_move_var(td_file, td_var)
1124	IMPLICIT NONE
1125
1126	! Argument
1127	TYPE(TFILE), INTENT(INOUT) :: td_file
1128	TYPE(TVAR), INTENT(IN) :: td_var
1129
1130	! local variable
1131	TYPE(TVAR) :: tl_var
1132	!----------------------------------------------------------------
1133
1134	! copy variable
1135	tl_var=var_copy(td_var)
1136
1137	! remove variable with same name or standard name
1138	CALL file_del_var(td_file, tl_var)
1139
1140	! add new variable
1141	CALL file_add_var(td_file, tl_var)
1142
1143	! clean
1144	CALL var_clean(tl_var)
1145
1146	END SUBROUTINE file_move_var
1147	!-------------------------------------------------------------------
1148	!> @brief This subroutine add a global attribute
1149	!> in a file structure.<br/>
1150	!> Do not overwrite, if attribute already in file structure.
1151	!
1152	!> @author J.Paul
1153	!> @date November, 2013 - Initial Version
1154	!
1155	!> @param[inout] td_file file structure
1156	!> @param[in] td_att attribute structure
1157	!-------------------------------------------------------------------
1158	SUBROUTINE file_add_att(td_file, td_att)
1159	IMPLICIT NONE
1160
1161	! Argument
1162	TYPE(TFILE), INTENT(INOUT) :: td_file
1163	TYPE(TATT), INTENT(IN) :: td_att
1164
1165	! local variable
1166	INTEGER(i4) :: il_status
1167	INTEGER(i4) :: il_ind
1168	TYPE(TATT), DIMENSION(:), ALLOCATABLE :: tl_att
1169
1170	! loop indices
1171	INTEGER(i4) :: ji
1172	!----------------------------------------------------------------
1173
1174	! check if file opened
1175	IF( TRIM(td_file%c_name) == '' )THEN
1176
1177	CALL logger_error( " FILE ADD ATT: file structure unknown ")
1178	CALL logger_debug( " FILE ADD ATT: you should have used file_init before "//&
1179	& "running file_add_att" )
1180
1181	ELSE
1182
1183	! check if attribute already in file structure
1184	il_ind=0
1185	IF( ASSOCIATED(td_file%t_att) )THEN
1186	il_ind=att_get_index( td_file%t_att(:), td_att%c_name )
1187	ENDIF
1188
1189	IF( il_ind /= 0 )THEN
1190
1191	CALL logger_error( &
1192	& " FILE ADD ATT: attribute "//TRIM(td_att%c_name)//&
1193	& ", already in file "//TRIM(td_file%c_name) )
1194
1195	DO ji=1,td_file%i_natt
1196	CALL logger_debug( &
1197	& " FILE ADD ATT: in file "//TRIM(td_file%t_att(ji)%c_name) )
1198	ENDDO
1199
1200	ELSE
1201
1202	CALL logger_trace( &
1203	& " FILE ADD ATT: add attribute "//TRIM(td_att%c_name)//&
1204	& ", in file "//TRIM(td_file%c_name) )
1205
1206	IF( td_file%i_natt > 0 )THEN
1207	! already other attribute in file structure
1208	ALLOCATE( tl_att(td_file%i_natt), stat=il_status )
1209	IF(il_status /= 0 )THEN
1210
1211	CALL logger_error( &
1212	& " FILE ADD ATT: not enough space to put attributes from "//&
1213	& TRIM(td_file%c_name)//" in temporary attribute structure")
1214
1215	ELSE
1216
1217	! save temporary global attribute's file structure
1218	tl_att(:)=att_copy(td_file%t_att(:))
1219
1220	CALL att_clean( td_file%t_att(:) )
1221	DEALLOCATE(td_file%t_att)
1222	ALLOCATE( td_file%t_att(td_file%i_natt+1), stat=il_status )
1223	IF(il_status /= 0 )THEN
1224
1225	CALL logger_error( &
1226	& " FILE ADD ATT: not enough space to put attributes "//&
1227	& "in file structure "//TRIM(td_file%c_name) )
1228
1229	ENDIF
1230
1231	! copy attribute in file before
1232	td_file%t_att(1:td_file%i_natt)=att_copy(tl_att(:))
1233
1234	! clean
1235	CALL att_clean(tl_att(:))
1236	DEALLOCATE(tl_att)
1237
1238	ENDIF
1239	ELSE
1240	! no attribute in file structure
1241	IF( ASSOCIATED(td_file%t_att) )THEN
1242	CALL att_clean(td_file%t_att(:))
1243	DEALLOCATE(td_file%t_att)
1244	ENDIF
1245
1246	ALLOCATE( td_file%t_att(td_file%i_natt+1), stat=il_status )
1247	IF(il_status /= 0 )THEN
1248
1249	CALL logger_error( &
1250	& " FILE ADD ATT: not enough space to put attributes "//&
1251	& "in file structure "//TRIM(td_file%c_name) )
1252
1253	ENDIF
1254	ENDIF
1255	! add new attribute
1256	td_file%t_att(td_file%i_natt+1)=att_copy(td_att)
1257
1258	! update number of attribute
1259	td_file%i_natt=td_file%i_natt+1
1260	ENDIF
1261	ENDIF
1262
1263	END SUBROUTINE file_add_att
1264	!-------------------------------------------------------------------
1265	!> @brief This subroutine delete a global attribute structure
1266	!> in file structure, given attribute name.
1267	!
1268	!> @author J.Paul
1269	!> @date November, 2013 - Initial Version
1270	!> @date February, 2015
1271	!> - define local attribute structure to avoid mistake
1272	!> with pointer
1273	!
1274	!> @param[inout] td_file file structure
1275	!> @param[in] cd_name attribute name
1276	!-------------------------------------------------------------------
1277	SUBROUTINE file__del_att_name(td_file, cd_name )
1278	IMPLICIT NONE
1279
1280	! Argument
1281	TYPE(TFILE) , INTENT(INOUT) :: td_file
1282	CHARACTER(LEN=*), INTENT(IN ) :: cd_name
1283
1284	! local variable
1285	INTEGER(i4) :: il_ind
1286	TYPE(TATT) :: tl_att
1287	!----------------------------------------------------------------
1288
1289	! check if file opened
1290	IF( TRIM(td_file%c_name) == '' )THEN
1291
1292	CALL logger_error( " FILE DEL ATT NAME: file structure unknown ")
1293	CALL logger_debug( " FILE DEL ATT NAME: you should have "//&
1294	& "used file_init before running file_del_att" )
1295
1296	ELSE
1297
1298	IF( td_file%i_natt /= 0 )THEN
1299
1300	! get the variable id, in file variable structure
1301	il_ind=0
1302	IF( ASSOCIATED(td_file%t_att) )THEN
1303	il_ind=att_get_index(td_file%t_att(:), cd_name )
1304	ENDIF
1305
1306	IF( il_ind /= 0 )THEN
1307
1308	tl_att=att_copy(td_file%t_att(il_ind))
1309	CALL file_del_att(td_file, tl_att)
1310
1311	ELSE
1312
1313	CALL logger_debug( &
1314	& " FILE DEL ATT NAME: there is no attribute with name "//&
1315	& TRIM(cd_name)//" in file "//TRIM(td_file%c_name))
1316
1317	ENDIF
1318
1319	ELSE
1320	CALL logger_debug( " FILE DEL ATT NAME: no attribute "//&
1321	& "associated to file "//TRIM(td_file%c_name) )
1322	ENDIF
1323
1324	ENDIF
1325
1326	END SUBROUTINE file__del_att_name
1327	!-------------------------------------------------------------------
1328	!> @brief This subroutine delete a global attribute structure
1329	!> from file structure, given attribute structure.
1330	!
1331	!> @author J.Paul
1332	!> @date November, 2013 - Initial Version
1333	!
1334	!> @param[inout] td_file file structure
1335	!> @param[in] td_att attribute structure
1336	!-------------------------------------------------------------------
1337	SUBROUTINE file__del_att_str(td_file, td_att)
1338	IMPLICIT NONE
1339
1340	! Argument
1341	TYPE(TFILE), INTENT(INOUT) :: td_file
1342	TYPE(TATT), INTENT(IN) :: td_att
1343
1344	! local variable
1345	INTEGER(i4) :: il_status
1346	INTEGER(i4) :: il_ind
1347	TYPE(TATT), DIMENSION(:), ALLOCATABLE :: tl_att
1348
1349	! loop indices
1350	!----------------------------------------------------------------
1351
1352	! check if file opened
1353	IF( TRIM(td_file%c_name) == '' )THEN
1354
1355	CALL logger_error( " FILE DEL ATT: file structure unknown ")
1356	CALL logger_debug( " FILE DEL ATT: you should have used "//&
1357	& "file_init before running file_del_att" )
1358
1359	ELSE
1360
1361	! check if attribute already in file structure
1362	il_ind=0
1363	IF( ASSOCIATED(td_file%t_att) )THEN
1364	il_ind=att_get_index( td_file%t_att(:), td_att%c_name )
1365	ENDIF
1366
1367	IF( il_ind == 0 )THEN
1368
1369	CALL logger_error( &
1370	& " FILE DEL ATT: no attribute "//TRIM(td_att%c_name)//&
1371	& ", in file "//TRIM(td_file%c_name) )
1372
1373	ELSE
1374
1375	CALL logger_trace( &
1376	& " FILE DEL ATT: del attribute "//TRIM(td_att%c_name)//&
1377	& ", in file "//TRIM(td_file%c_name) )
1378
1379	ALLOCATE( tl_att(td_file%i_natt-1), stat=il_status )
1380	IF(il_status /= 0 )THEN
1381
1382	CALL logger_error( &
1383	& " FILE ADD ATT: not enough space to put attributes from "//&
1384	& TRIM(td_file%c_name)//" in temporary attribute structure")
1385
1386	ELSE
1387
1388	! save temporary global attribute's file structure
1389	IF( il_ind > 1 )THEN
1390	tl_att(1:il_ind-1)=att_copy(td_file%t_att(1:il_ind-1))
1391	ENDIF
1392
1393	IF( il_ind < td_file%i_natt )THEN
1394	tl_att(il_ind:)=att_copy(td_file%t_att(il_ind+1:))
1395	ENDIF
1396
1397	CALL att_clean( td_file%t_att(:) )
1398	DEALLOCATE(td_file%t_att)
1399
1400	! new number of attribute in file
1401	td_file%i_natt=td_file%i_natt-1
1402
1403	ALLOCATE( td_file%t_att(td_file%i_natt), stat=il_status )
1404	IF(il_status /= 0 )THEN
1405
1406	CALL logger_error( &
1407	& " FILE ADD ATT: not enough space to put attributes "//&
1408	& "in file structure "//TRIM(td_file%c_name) )
1409
1410	ENDIF
1411
1412	! copy attribute in file before
1413	td_file%t_att(1:td_file%i_natt)=att_copy(tl_att(:))
1414
1415	! clean
1416	CALL att_clean(tl_att(:))
1417	DEALLOCATE(tl_att)
1418
1419	ENDIF
1420	ENDIF
1421	ENDIF
1422
1423	END SUBROUTINE file__del_att_str
1424	!-------------------------------------------------------------------
1425	!> @brief This subroutine move a global attribute structure
1426	!> from file structure.
1427	!> @warning change attribute id in file structure.
1428	!
1429	!> @author J.Paul
1430	!> @date November, 2013 - Initial Version
1431	!
1432	!> @param[inout] td_file file structure
1433	!> @param[in] td_att attribute structure
1434	!-------------------------------------------------------------------
1435	SUBROUTINE file_move_att(td_file, td_att)
1436	IMPLICIT NONE
1437
1438	! Argument
1439	TYPE(TFILE), INTENT(INOUT) :: td_file
1440	TYPE(TATT), INTENT(IN) :: td_att
1441
1442	! local variable
1443	TYPE(TATT) :: tl_att
1444	INTEGER(i4) :: il_ind
1445	!----------------------------------------------------------------
1446
1447	! copy attribute
1448	tl_att=att_copy(td_att)
1449
1450	IF( ASSOCIATED(td_file%t_att) )THEN
1451	il_ind=att_get_index(td_file%t_att(:),TRIM(tl_att%c_name))
1452	IF( il_ind /= 0 )THEN
1453	! remove attribute with same name
1454	CALL file_del_att(td_file, tl_att)
1455	ENDIF
1456	ENDIF
1457
1458	! add new attribute
1459	CALL file_add_att(td_file, tl_att)
1460
1461	! clean
1462	CALL att_clean(tl_att)
1463
1464	END SUBROUTINE file_move_att
1465	!-------------------------------------------------------------------
1466	!> @brief This subroutine add a dimension structure in file
1467	!> structure.
1468	!> Do not overwrite, if dimension already in file structure.
1469	!
1470	!> @author J.Paul
1471	!> @date November, 2013 - Initial Version
1472	!> @date September, 2014
1473	!> - do not reorder dimension, before put in file
1474	!
1475	!> @param[inout] td_file file structure
1476	!> @param[in] td_dim dimension structure
1477	!-------------------------------------------------------------------
1478	SUBROUTINE file_add_dim(td_file, td_dim)
1479	IMPLICIT NONE
1480
1481	! Argument
1482	TYPE(TFILE) , INTENT(INOUT) :: td_file
1483	TYPE(TDIM) , INTENT(IN ) :: td_dim
1484
1485	! local variable
1486	INTEGER(i4) :: il_ind
1487
1488	! loop indices
1489	INTEGER(i4) :: ji
1490	!----------------------------------------------------------------
1491	! check if file opened
1492	IF( TRIM(td_file%c_name) == '' )THEN
1493
1494	CALL logger_error( " FILE ADD DIM: file structure unknown ")
1495	CALL logger_debug( " FILE ADD DIM: you should have used "//&
1496	& "file_init before running file_add_dim" )
1497
1498	ELSE
1499
1500	IF( td_file%i_ndim <= ip_maxdim )THEN
1501
1502	! check if dimension already in file structure
1503	il_ind=dim_get_index(td_file%t_dim(:), td_dim%c_sname)
1504	IF( il_ind /= 0 )THEN
1505	IF( td_file%t_dim(il_ind)%l_use )THEN
1506	CALL logger_error( &
1507	& "FILE ADD DIM: dimension "//TRIM(td_dim%c_name)//&
1508	& ", short name "//TRIM(td_dim%c_sname)//&
1509	& ", already used in file "//TRIM(td_file%c_name) )
1510	ELSE
1511	! replace dimension
1512	td_file%t_dim(il_ind)=dim_copy(td_dim)
1513	td_file%t_dim(il_ind)%i_id=il_ind
1514	td_file%t_dim(il_ind)%l_use=.TRUE.
1515	ENDIF
1516	ELSE
1517	IF( td_file%i_ndim == ip_maxdim )THEN
1518	CALL logger_error( &
1519	& "FILE ADD DIM: can not add dimension "//TRIM(td_dim%c_name)//&
1520	& ", short name "//TRIM(td_dim%c_sname)//&
1521	& ", in file "//TRIM(td_file%c_name)//". Already "//&
1522	& TRIM(fct_str(ip_maxdim))//" dimensions." )
1523	ELSE
1524	! search empty dimension
1525	DO ji=1,ip_maxdim
1526	IF( td_file%t_dim(ji)%i_id == 0 )THEN
1527	il_ind=ji
1528	EXIT
1529	ENDIF
1530	ENDDO
1531
1532	! add new dimension
1533	td_file%t_dim(il_ind)=dim_copy(td_dim)
1534	! update number of attribute
1535	td_file%i_ndim=COUNT(td_file%t_dim(:)%l_use)
1536
1537	td_file%t_dim(il_ind)%i_id=td_file%i_ndim
1538	td_file%t_dim(il_ind)%l_use=.TRUE.
1539	ENDIF
1540	ENDIF
1541
1542	ELSE
1543	CALL logger_error( &
1544	& " FILE ADD DIM: too much dimension in file "//&
1545	& TRIM(td_file%c_name)//" ("//TRIM(fct_str(td_file%i_ndim))//")")
1546	ENDIF
1547
1548	ENDIF
1549
1550	END SUBROUTINE file_add_dim
1551	!-------------------------------------------------------------------
1552	!> @brief This subroutine delete a dimension structure in file
1553	!> structure.
1554	!>
1555	!> @author J.Paul
1556	!> @date November, 2013 - Initial Version
1557	!
1558	!> @param[inout] td_file file structure
1559	!> @param[in] td_dim dimension structure
1560	!-------------------------------------------------------------------
1561	SUBROUTINE file_del_dim(td_file, td_dim)
1562	IMPLICIT NONE
1563
1564	! Argument
1565	TYPE(TFILE) , INTENT(INOUT) :: td_file
1566	TYPE(TDIM) , INTENT(IN ) :: td_dim
1567
1568	! local variable
1569	INTEGER(i4) :: il_status
1570	INTEGER(i4) :: il_ind
1571
1572	TYPE(TDIM), DIMENSION(:), ALLOCATABLE :: tl_dim
1573
1574	! loop indices
1575	INTEGER(i4) :: ji
1576	!----------------------------------------------------------------
1577	! check if file opened
1578	IF( TRIM(td_file%c_name) == '' )THEN
1579
1580	CALL logger_error( " FILE DEL DIM: file structure unknown ")
1581	CALL logger_debug( " FILE DEL DIM: you should have used "//&
1582	& "file_init before running file_del_dim" )
1583
1584	ELSE
1585
1586	! check if dimension already in file structure
1587	il_ind=dim_get_index(td_file%t_dim(:), td_dim%c_sname)
1588	IF( il_ind == 0 )THEN
1589
1590	CALL logger_error( &
1591	& "FILE DEL DIM: no dimension "//TRIM(td_dim%c_name)//&
1592	& ", short name "//TRIM(td_dim%c_sname)//&
1593	& ", in file "//TRIM(td_file%c_name) )
1594
1595	ELSE
1596	ALLOCATE( tl_dim(td_file%i_ndim-1), stat=il_status )
1597	IF(il_status /= 0 )THEN
1598
1599	CALL logger_error( &
1600	& "FILE DEL DIM: not enough space to put dimensions from "//&
1601	& TRIM(td_file%c_name)//" in temporary dimension structure")
1602
1603	ELSE
1604	! save temporary dimension's mpp structure
1605	tl_dim( 1 : il_ind-1 ) = dim_copy(td_file%t_dim(1 : il_ind-1))
1606	tl_dim( il_ind : td_file%i_ndim-1 ) = &
1607	& dim_copy(td_file%t_dim(il_ind+1 : td_file%i_ndim))
1608
1609	! remove dimension from file
1610	CALL dim_clean(td_file%t_dim(:))
1611	! copy dimension in file, except one
1612	td_file%t_dim(1:td_file%i_ndim)=dim_copy(tl_dim(:))
1613
1614	! update number of dimension
1615	td_file%i_ndim=td_file%i_ndim-1
1616
1617	! update dimension id
1618	DO ji=1,td_file%i_ndim
1619	td_file%t_dim(ji)%i_id=ji
1620	ENDDO
1621
1622	! clean
1623	CALL dim_clean(tl_dim(:))
1624	DEALLOCATE(tl_dim)
1625	ENDIF
1626	ENDIF
1627	ENDIF
1628
1629	END SUBROUTINE file_del_dim
1630	!-------------------------------------------------------------------
1631	!> @brief This subroutine move a dimension structure
1632	!> in file structure.
1633	!> @warning change dimension order in file structure.
1634	!
1635	!> @author J.Paul
1636	!> @date November, 2013 - Initial Version
1637	!
1638	!> @param[inout] td_file file structure
1639	!> @param[in] td_dim dimension structure
1640	!-------------------------------------------------------------------
1641	SUBROUTINE file_move_dim(td_file, td_dim)
1642	IMPLICIT NONE
1643
1644	! Argument
1645	TYPE(TFILE) , INTENT(INOUT) :: td_file
1646	TYPE(TDIM) , INTENT(IN ) :: td_dim
1647
1648	! local variable
1649	INTEGER(i4) :: il_ind
1650	INTEGER(i4) :: il_dimid
1651	!----------------------------------------------------------------
1652	IF( td_file%i_ndim <= ip_maxdim )THEN
1653
1654	! check if dimension already in mpp structure
1655	il_ind=dim_get_index(td_file%t_dim(:), td_dim%c_name, td_dim%c_sname)
1656	IF( il_ind /= 0 )THEN
1657
1658	il_dimid=td_file%t_dim(il_ind)%i_id
1659	! replace dimension
1660	td_file%t_dim(il_ind)=dim_copy(td_dim)
1661	td_file%t_dim(il_ind)%i_id=il_dimid
1662	td_file%t_dim(il_ind)%l_use=.TRUE.
1663
1664	ELSE
1665	CALL file_add_dim(td_file, td_dim)
1666	ENDIF
1667
1668	ELSE
1669	CALL logger_error( &
1670	& "FILE MOVE DIM: too much dimension in mpp "//&
1671	& TRIM(td_file%c_name)//" ("//TRIM(fct_str(td_file%i_ndim))//")")
1672	ENDIF
1673
1674	END SUBROUTINE file_move_dim
1675	!-------------------------------------------------------------------
1676	!> @brief This subroutine print some information about file strucutre.
1677	!
1678	!> @author J.Paul
1679	!> @date November, 2013 - Initial Version
1680	!
1681	!> @param[in] td_file file structure
1682	!-------------------------------------------------------------------
1683	SUBROUTINE file_print(td_file)
1684	IMPLICIT NONE
1685
1686	! Argument
1687	TYPE(TFILE), INTENT(IN) :: td_file
1688
1689	! local variable
1690	CHARACTER(LEN=lc) :: cl_mode
1691
1692	! loop indices
1693	INTEGER(i4) :: ji
1694	!----------------------------------------------------------------
1695
1696	cl_mode='READ'
1697	IF( td_file%l_wrt ) cl_mode='WRITE'
1698
1699	WRITE(*,'((a,a),2(/3x,a,a),4(/3x,a,i0))')&
1700	& "File : ",TRIM(td_file%c_name), &
1701	& " type : ",TRIM(td_file%c_type), &
1702	& " mode : ",TRIM(cl_mode), &
1703	& " id : ",td_file%i_id, &
1704	& " ndim : ",td_file%i_ndim, &
1705	& " natt : ",td_file%i_natt, &
1706	& " nvar : ",td_file%i_nvar
1707
1708	SELECT CASE(TRIM(td_file%c_type))
1709	CASE('cdf')
1710	WRITE(*,'((/3x,a,a),(/3x,a,i3))')&
1711	& "define mode : ",TRIM(fct_str(td_file%l_def)),&
1712	& "unlimited id : ",td_file%i_uldid
1713	CASE('dimg')
1714	WRITE(*,'(5(/3x,a,i0))')&
1715	& " record length : ",td_file%i_recl, &
1716	& " n0d : ",td_file%i_n0d, &
1717	& " n1d : ",td_file%i_n1d, &
1718	& " n2d : ",td_file%i_n2d, &
1719	& " n3d : ",td_file%i_n3d
1720	END SELECT
1721
1722	! print dimension
1723	IF( td_file%i_ndim /= 0 )THEN
1724	WRITE(*,'(/a)') " File dimension"
1725	DO ji=1,ip_maxdim
1726	IF( td_file%t_dim(ji)%l_use )THEN
1727	CALL dim_print(td_file%t_dim(ji))
1728	ENDIF
1729	ENDDO
1730	ENDIF
1731
1732	! print global attribute
1733	IF( td_file%i_natt /= 0 )THEN
1734	WRITE(*,'(/a)') " File attribute"
1735	DO ji=1,td_file%i_natt
1736	CALL att_print(td_file%t_att(ji))
1737	ENDDO
1738	ENDIF
1739
1740	! print variable
1741	IF( td_file%i_nvar /= 0 )THEN
1742	WRITE(*,'(/a)') " File variable"
1743	DO ji=1,td_file%i_nvar
1744	CALL var_print(td_file%t_var(ji),.FALSE.)
1745	ENDDO
1746	ENDIF
1747
1748	END SUBROUTINE file_print
1749	!-------------------------------------------------------------------
1750	!> @brief This function get suffix of file name.
1751	!> @details
1752	!> we assume suffix is define as alphanumeric character following the
1753	!> last '.' in file name.<br/>
1754	!> If no suffix is found, return empty character.
1755	!
1756	!> @author J.Paul
1757	!> @date November, 2013 - Initial Version
1758	!
1759	!> @param[in] cd_file file structure
1760	!> @return suffix
1761	!-------------------------------------------------------------------
1762	CHARACTER(LEN=lc) FUNCTION file__get_suffix(cd_file)
1763	IMPLICIT NONE
1764
1765	! Argument
1766	CHARACTER(LEN=*), INTENT(IN) :: cd_file
1767
1768	! local variable
1769	INTEGER(i4) :: il_ind
1770	!----------------------------------------------------------------
1771
1772	CALL logger_trace( "FILE GET SUFFIX: look for suffix in file name "//&
1773	& TRIM(cd_file) )
1774
1775	il_ind=INDEX(TRIM(cd_file),'.',BACK=.TRUE.)
1776	IF( il_ind /= 0 )THEN
1777	! read number in basename
1778	READ( cd_file(il_ind:),'(a)' ) file__get_suffix
1779
1780	IF( fct_is_num(file__get_suffix(2:)) )THEN
1781	file__get_suffix=''
1782	ENDIF
1783
1784	ELSE
1785	file__get_suffix=''
1786	ENDIF
1787
1788	END FUNCTION file__get_suffix
1789	!-------------------------------------------------------------------
1790	!> @brief This function get number in file name without suffix.
1791	!> @details
1792	!> Actually it get the number following the last separator.
1793	!> separator could be '.' or '_'.
1794	!
1795	!> @author J.Paul
1796	!> @date November, 2013 - Initial Version
1797	!> @date February, 2015
1798	!> - add case to not return date (yyyymmdd) at the end of filename
1799	!> @date February, 2015
1800	!> - add case to not return release number
1801	!> we assume release number only on one digit (ex : file_v3.5.nc)
1802	!
1803	!> @param[in] cd_file file name (without suffix)
1804	!> @return character file number.
1805	!-------------------------------------------------------------------
1806	CHARACTER(LEN=lc) FUNCTION file__get_number(cd_file)
1807	IMPLICIT NONE
1808
1809	! Argument
1810	CHARACTER(LEN=lc), INTENT(IN) :: cd_file
1811
1812	! local variable
1813	INTEGER(i4) :: il_indmax
1814	INTEGER(i4) :: il_ind
1815
1816	! loop indices
1817	INTEGER(i4) :: ji
1818	!----------------------------------------------------------------
1819
1820	! get number position in file name
1821	il_indmax=0
1822	DO ji=1,ip_nsep
1823	il_ind=INDEX(TRIM(cd_file),TRIM(cp_sep(ji)),BACK=.TRUE.)
1824	IF( il_ind > il_indmax )THEN
1825	il_indmax=il_ind
1826	ENDIF
1827	ENDDO
1828
1829	IF( il_indmax /= 0 )THEN
1830	! read number in basename
1831	READ( cd_file(il_indmax:),'(a)' ) file__get_number
1832
1833	IF( .NOT. fct_is_num(file__get_number(2:)) )THEN
1834	file__get_number=''
1835	ELSEIF( LEN(TRIM(file__get_number))-1 == 8 )THEN
1836	! date case yyyymmdd
1837	file__get_number=''
1838	ELSEIF( LEN(TRIM(file__get_number))-1 == 1 )THEN
1839	! release number case
1840	file__get_number=''
1841	ENDIF
1842	ELSE
1843	file__get_number=''
1844	ENDIF
1845
1846	END FUNCTION file__get_number
1847	!-------------------------------------------------------------------
1848	!> @brief This function rename file name, given processor number.
1849	!> @details
1850	!> If no processor number is given, return file name without number
1851	!> If processor number is given, return file name with new number
1852	!
1853	!> @author J.Paul
1854	!> @date November, 2013 - Initial Version
1855	!
1856	!> @param[in] td_file file structure
1857	!> @param[in] id_num processor number (start to 1)
1858	!> @return file name
1859	!-------------------------------------------------------------------
1860	CHARACTER(LEN=lc) FUNCTION file__rename_char(cd_file, id_num)
1861	IMPLICIT NONE
1862
1863	! Argument
1864	CHARACTER(LEN=*), INTENT(IN) :: cd_file
1865	INTEGER(i4), INTENT(IN), OPTIONAL :: id_num
1866
1867	! local variable
1868	CHARACTER(LEN=lc) :: cl_suffix
1869	CHARACTER(LEN=lc) :: cl_file
1870	CHARACTER(LEN=lc) :: cl_number
1871	CHARACTER(LEN=lc) :: cl_base
1872	CHARACTER(LEN=lc) :: cl_sep
1873	CHARACTER(LEN=lc) :: cl_format
1874	INTEGER(i4) :: il_ind
1875	INTEGER(i4) :: il_numlen
1876	!----------------------------------------------------------------
1877
1878	! get suffix
1879	cl_suffix=file__get_suffix(cd_file)
1880	IF( TRIM(cl_suffix) /= '' )THEN
1881	il_ind=INDEX(TRIM(cd_file),TRIM(cl_suffix(1:1)),BACK=.TRUE.)
1882	cl_file=TRIM(cd_file(:il_ind-1))
1883	ELSE
1884	cl_file=TRIM(cd_file)
1885	ENDIF
1886
1887	cl_number=file__get_number(cl_file)
1888	IF( TRIM(cl_number) /= '' )THEN
1889	il_ind=INDEX(TRIM(cl_file),TRIM(cl_number(1:1)),BACK=.TRUE.)
1890	cl_base=TRIM(cl_file(:il_ind-1))
1891
1892	cl_sep=TRIM(cl_number(1:1))
1893	il_numlen=LEN(TRIM(cl_number))-1
1894	ELSE
1895	cl_base=TRIM(cl_file)
1896	il_numlen=4
1897	cl_sep='_'
1898	ENDIF
1899
1900	IF( PRESENT(id_num) )THEN
1901	! format
1902	WRITE(cl_format,'(a,i1.1,a,i1.1,a)') '(a,a,i',il_numlen,'.',il_numlen,',a)'
1903	WRITE(file__rename_char,cl_format) TRIM(cl_base),TRIM(cl_sep),id_num,TRIM(cl_suffix)
1904	ELSE
1905	WRITE(file__rename_char,'(a,a)') TRIM(cl_base),TRIM(cl_suffix)
1906	ENDIF
1907	CALL logger_trace(" FILE RENAME : "//TRIM(file__rename_char))
1908
1909	END FUNCTION file__rename_char
1910	!-------------------------------------------------------------------
1911	!> @brief This function rename file name, given file structure.
1912	!> @details
1913	!> If no processor number is given, return file name without number
1914	!> I processor number is given, return file name with new number
1915	!
1916	!> @author J.Paul
1917	!> @date November, 2013 - Initial Version
1918	!
1919	!> @param[in] td_file file structure
1920	!> @param[in] id_num processor number (start to 1)
1921	!> @return file structure
1922	!-------------------------------------------------------------------
1923	TYPE(TFILE) FUNCTION file__rename_str(td_file, id_num)
1924	IMPLICIT NONE
1925
1926	! Argument
1927	TYPE(TFILE), INTENT(IN) :: td_file
1928	INTEGER(i4), INTENT(IN), OPTIONAL :: id_num
1929
1930	! local variable
1931	CHARACTER(LEN=lc) :: cl_name
1932	!----------------------------------------------------------------
1933
1934	! change name
1935	cl_name=TRIM( file_rename(td_file%c_name, id_num) )
1936
1937	file__rename_str=file_init(TRIM(cl_name), TRIM(td_file%c_type))
1938
1939	END FUNCTION file__rename_str
1940	!-------------------------------------------------------------------
1941	!> @brief This function add suffix to file name.
1942	!
1943	!> @author J.Paul
1944	!> @date November, 2013 - Initial Version
1945	!
1946	!> @param[in] td_file file structure
1947	!> @return file name
1948	!-------------------------------------------------------------------
1949	CHARACTER(LEN=lc) FUNCTION file_add_suffix(cd_file, cd_type)
1950	IMPLICIT NONE
1951
1952	! Argument
1953	CHARACTER(LEN=*), INTENT(IN) :: cd_file
1954	CHARACTER(LEN=*), INTENT(IN) :: cd_type
1955
1956	! local variable
1957	INTEGER(i4) :: il_ind
1958	CHARACTER(LEN=lc) :: cl_file
1959	CHARACTER(LEN=lc) :: cl_suffix
1960	!----------------------------------------------------------------
1961	! get suffix
1962	cl_suffix=file__get_suffix(cd_file)
1963	IF( TRIM(cl_suffix) /= '' )THEN
1964	il_ind=INDEX(TRIM(cd_file),TRIM(cl_suffix(1:1)),BACK=.TRUE.)
1965	cl_file=TRIM(cd_file(:il_ind-1))
1966	ELSE
1967	cl_file=TRIM(cd_file)
1968	ENDIF
1969
1970	SELECT CASE(TRIM(cd_type))
1971	CASE('cdf')
1972	file_add_suffix=TRIM(cl_file)//'.nc'
1973	CASE('dimg')
1974	IF( TRIM(cl_suffix) /= '' )THEN
1975	file_add_suffix=TRIM(cl_file)//'.dimg'
1976	ELSE
1977	file_add_suffix=TRIM(cl_file)
1978	ENDIF
1979	CASE DEFAULT
1980	CALL logger_error(" FILE ADD SUFFIX: type unknown "//TRIM(cd_type))
1981	END SELECT
1982
1983	END FUNCTION file_add_suffix
1984	!-------------------------------------------------------------------
1985	!> @brief
1986	!> This subroutine clean file strcuture.
1987	!
1988	!> @author J.Paul
1989	!> @date November, 2013 - Inital version
1990	!
1991	!> @param[inout] td_file file strcuture
1992	!-------------------------------------------------------------------
1993	SUBROUTINE file__clean_unit( td_file )
1994	IMPLICIT NONE
1995	! Argument
1996	TYPE(TFILE), INTENT(INOUT) :: td_file
1997
1998	! local variable
1999	TYPE(TFILE) :: tl_file ! empty file structure
2000
2001	! loop indices
2002	!----------------------------------------------------------------
2003
2004	CALL logger_trace( &
2005	& " FILE CLEAN: reset file "//TRIM(td_file%c_name) )
2006
2007	! del attribute
2008	IF( ASSOCIATED( td_file%t_att ) )THEN
2009	CALL att_clean( td_file%t_att(:) )
2010	DEALLOCATE(td_file%t_att)
2011	ENDIF
2012
2013	! del dimension
2014	IF( td_file%i_ndim /= 0 )THEN
2015	CALL dim_clean( td_file%t_dim(:) )
2016	ENDIF
2017
2018	! del variable
2019	IF( ASSOCIATED( td_file%t_var ) )THEN
2020	CALL var_clean( td_file%t_var(:) )
2021	DEALLOCATE(td_file%t_var)
2022	ENDIF
2023
2024	! replace by empty structure
2025	td_file=file_copy(tl_file)
2026
2027	END SUBROUTINE file__clean_unit
2028	!-------------------------------------------------------------------
2029	!> @brief
2030	!> This subroutine clean file array of file strcuture.
2031	!
2032	!> @author J.Paul
2033	!> @date Marsh, 2014 - Inital version
2034	!
2035	!> @param[inout] td_file array file strcuture
2036	!-------------------------------------------------------------------
2037	SUBROUTINE file__clean_arr( td_file )
2038	IMPLICIT NONE
2039	! Argument
2040	TYPE(TFILE), DIMENSION(:), INTENT(INOUT) :: td_file
2041
2042	! local variable
2043	! loop indices
2044	INTEGER(i4) :: ji
2045	!----------------------------------------------------------------
2046
2047	DO ji=SIZE(td_file(:)),1,-1
2048	CALL file_clean(td_file(ji))
2049	ENDDO
2050
2051	END SUBROUTINE file__clean_arr
2052	!-------------------------------------------------------------------
2053	!> @brief This function return the file id, in a array of file
2054	!> structure, given file name.
2055	!
2056	!> @author J.Paul
2057	!> @date November, 2013 - Initial Version
2058	!
2059	!> @param[in] td_file array of file structure
2060	!> @param[in] cd_name file name
2061	!> @return file id in array of file structure (0 if not found)
2062	!-------------------------------------------------------------------
2063	INTEGER(i4) FUNCTION file_get_id(td_file, cd_name)
2064	IMPLICIT NONE
2065	! Argument
2066	TYPE(TFILE) , DIMENSION(:), INTENT(IN) :: td_file
2067	CHARACTER(LEN=*), INTENT(IN) :: cd_name
2068
2069	! local variable
2070	INTEGER(i4) :: il_size
2071
2072	! loop indices
2073	INTEGER(i4) :: ji
2074	!----------------------------------------------------------------
2075	file_get_id=0
2076	il_size=SIZE(td_file(:))
2077
2078	! check if file is in array of file structure
2079	DO ji=1,il_size
2080	! look for file name
2081	IF( fct_lower(td_file(ji)%c_name) == fct_lower(cd_name) )THEN
2082
2083	file_get_id=td_file(ji)%i_id
2084	EXIT
2085
2086	ENDIF
2087	ENDDO
2088
2089	END FUNCTION file_get_id
2090	!-------------------------------------------------------------------
2091	!> @brief
2092	!> This function get the next unused unit in array of file structure.
2093	!>
2094	!> @author J.Paul
2095	!> @date September, 2014 - Initial Version
2096	!
2097	!> @param[in] td_file array of file
2098	!-------------------------------------------------------------------
2099	FUNCTION file_get_unit(td_file)
2100	IMPLICIT NONE
2101	! Argument
2102	TYPE(TFILE), DIMENSION(:), INTENT(IN ) :: td_file
2103
2104	! function
2105	INTEGER(i4) :: file_get_unit
2106
2107	! local variable
2108	! loop indices
2109	!----------------------------------------------------------------
2110
2111	file_get_unit=MAXVAL(td_file(:)%i_id)+1
2112
2113	END FUNCTION file_get_unit
2114	END MODULE file
2115

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

Download in other formats: