Context Navigation

← Previous Revision
Next Revision →
Blame
Revision Log

file.f90

Last change on this file was 13369, checked in by jpaul, 4 years ago
update: cf changelog inside documentation
File size: 76.7 KB

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

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

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

Context Navigation

source: utils/tools/SIREN/src/file.f90

Download in other formats: