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.

attribute.f90 in utils/tools/SIREN/src – NEMO

Context Navigation

source: utils/tools/SIREN/src/attribute.f90 @ 12080

Last change on this file since 12080 was 12080, checked in by jpaul, 4 years ago
update nemo trunk
File size: 48.3 KB

Line
1	!----------------------------------------------------------------------
2	! NEMO system team, System and Interface for oceanic RElocable Nesting
3	!----------------------------------------------------------------------
4	!
5	! DESCRIPTION:
6	!> @brief
7	!> This module manage attribute of variable or file.
8	!>
9	!> @details
10	!> define type TATT:<br/>
11	!> @code
12	!> TYPE(TATT) :: tl_att
13	!> @endcode
14	!>
15	!> the attribute value inside attribute structure will be
16	!> character or real(8) 1D array.<br/>
17	!> However the attribute value could be initialized with:<br/>
18	!> - character
19	!> - scalar (real(4), real(8), integer(4) or integer(8))
20	!> - array 1D (real(4), real(8), integer(4) or integer(8))
21	!>
22	!> to initialize an attribute structure :<br/>
23	!> @code
24	!> tl_att=att_init('attname',value)
25	!> @endcode
26	!> - value is a character, scalar value or table of value
27	!>
28	!> to print attribute information of one or array of attribute structure:<br/>
29	!> @code
30	!> CALL att_print(td_att)
31	!> @endcode
32	!>
33	!> to clean attribute structure:<br/>
34	!> @code
35	!> CALL att_clean(td_att)
36	!> @endcode
37	!>
38	!> to copy attribute structure in another one (using different memory cell):<br/>
39	!> @code
40	!> tl_att2=att_copy(tl_att1)
41	!> @endcode
42	!> @note as we use pointer for the value array of the attribute structure,
43	!> the use of the assignment operator (=) to copy attribute structure
44	!> create a pointer on the same array.
45	!> This is not the case with this copy function.
46	!>
47	!> to get attribute index, in an array of attribute structure:<br/>
48	!> @code
49	!> il_index=att_get_index( td_att, cd_name )
50	!> @endcode
51	!> - td_att array of attribute structure
52	!> - cd_name attribute name
53	!>
54	!> to get attribute id, read from a file:<br/>
55	!>@code
56	!> il_id=att_get_id( td_att, cd_name )
57	!>@endcode
58	!> - td_att array of attribute structure
59	!> - cd_name attribute name
60	!>
61	!> to get attribute name
62	!> - tl_att\%c_name
63	!>
64	!> to get character length or the number of value store in attribute
65	!> - tl_att\%i_len
66	!>
67	!> to get attribute value:<br/>
68	!> - tl_att\%c_value (for character attribute)
69	!> - tl_att\%d_value(i) (otherwise)
70	!>
71	!> to get the type number (based on NETCDF type constants) of the
72	!> attribute:<br/>
73	!> - tl_att\%i_type
74	!>
75	!> to get attribute id (read from file):<br/>
76	!> - tl_att\%i_id
77	!>
78	!> @author J.Paul
79	!>
80	!> @date November, 2013 - Initial Version
81	!> @date November, 2014
82	!> - Fix memory leaks bug
83	!> @date September, 2015
84	!> - manage useless (dummy) attributes
85	!> @date May, 2019
86	!> - read number of element for each dummy array in configuration file
87	!>
88	!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
89	!----------------------------------------------------------------------
90	MODULE att
91
92	USE netcdf ! nf90 library
93	USE global ! global variable
94	USE kind ! F90 kind parameter
95	USE logger ! log file manager
96	USE fct ! basic useful function
97
98	IMPLICIT NONE
99
100	! NOTE_avoid_public_variables_if_possible
101
102	! type and variable
103	PUBLIC :: TATT !< attribute structure
104
105	PRIVATE :: im_ndumatt !< number of elt in dummy attribute array
106	PRIVATE :: cm_dumatt !< dummy attribute array
107
108	! function and subroutine
109	PUBLIC :: att_init !< initialize attribute structure
110	PUBLIC :: att_print !< print attribute structure
111	PUBLIC :: att_clean !< clean attribute strcuture
112	PUBLIC :: att_copy !< copy attribute structure
113	PUBLIC :: att_get_index !< get attribute index, in an array of attribute structure
114	PUBLIC :: att_get_id !< get attribute id, read from file
115	PUBLIC :: att_get_dummy !< fill dummy attribute array
116	PUBLIC :: att_is_dummy !< check if attribute is defined as dummy attribute
117
118	PRIVATE :: att__clean_unit ! clean attribute strcuture
119	PRIVATE :: att__clean_arr ! clean array of attribute strcuture
120	PRIVATE :: att__print_unit ! print information on one attribute
121	PRIVATE :: att__print_arr ! print information on a array of attribute
122	PRIVATE :: att__init_c ! initialize an attribute structure with character value
123	PRIVATE :: att__init_dp ! initialize an attribute structure with array of real(8) value
124	PRIVATE :: att__init_dp_0d ! initialize an attribute structure with real(8) value
125	PRIVATE :: att__init_sp ! initialize an attribute structure with array of real(4) value
126	PRIVATE :: att__init_sp_0d ! initialize an attribute structure with real(4) value
127	PRIVATE :: att__init_i1 ! initialize an attribute structure with array of integer(1) value
128	PRIVATE :: att__init_i1_0d ! initialize an attribute structure with integer(1) value
129	PRIVATE :: att__init_i2 ! initialize an attribute structure with array of integer(2) value
130	PRIVATE :: att__init_i2_0d ! initialize an attribute structure with integer(2) value
131	PRIVATE :: att__init_i4 ! initialize an attribute structure with array of integer(4) value
132	PRIVATE :: att__init_i4_0d ! initialize an attribute structure with integer(4) value
133	PRIVATE :: att__init_i8 ! initialize an attribute structure with array of integer(8) value
134	PRIVATE :: att__init_i8_0d ! initialize an attribute structure with integer(8) value
135	PRIVATE :: att__copy_unit ! copy attribute structure
136	PRIVATE :: att__copy_arr ! copy array of attribute structure
137
138	TYPE TATT !< attribute structure
139	CHARACTER(LEN=lc) :: c_name = '' !< attribute name
140	INTEGER(i4) :: i_id = 0 !< attribute id
141	INTEGER(i4) :: i_type = 0 !< attribute type
142	INTEGER(i4) :: i_len = 0 !< number of value store in attribute
143	CHARACTER(LEN=lc) :: c_value = 'none' !< attribute value if type CHAR
144	REAL(dp), DIMENSION(:), POINTER :: d_value => NULL() !< attribute value if type SHORT,INT,FLOAT or DOUBLE
145	END TYPE TATT
146
147	INTEGER(i4) , SAVE :: im_ndumatt !< number of elt in dummy attribute array
148	CHARACTER(LEN=lc), DIMENSION(ip_maxdumcfg), SAVE :: cm_dumatt !< dummy attribute
149
150	INTERFACE att_init
151	MODULE PROCEDURE att__init_c
152	MODULE PROCEDURE att__init_dp
153	MODULE PROCEDURE att__init_dp_0d
154	MODULE PROCEDURE att__init_sp
155	MODULE PROCEDURE att__init_sp_0d
156	MODULE PROCEDURE att__init_i1
157	MODULE PROCEDURE att__init_i1_0d
158	MODULE PROCEDURE att__init_i2
159	MODULE PROCEDURE att__init_i2_0d
160	MODULE PROCEDURE att__init_i4
161	MODULE PROCEDURE att__init_i4_0d
162	MODULE PROCEDURE att__init_i8
163	MODULE PROCEDURE att__init_i8_0d
164	END INTERFACE att_init
165
166	INTERFACE att_print
167	MODULE PROCEDURE att__print_unit ! print information on one attribute
168	MODULE PROCEDURE att__print_arr ! print information on a array of attribute
169	END INTERFACE att_print
170
171	INTERFACE att_clean
172	MODULE PROCEDURE att__clean_unit
173	MODULE PROCEDURE att__clean_arr
174	END INTERFACE
175
176	INTERFACE att_copy
177	MODULE PROCEDURE att__copy_unit ! copy attribute structure
178	MODULE PROCEDURE att__copy_arr ! copy array of attribute structure
179	END INTERFACE
180
181	CONTAINS
182	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
183	FUNCTION att__copy_arr(td_att) &
184	& RESULT(tf_att)
185	!-------------------------------------------------------------------
186	!> @brief
187	!> This subroutine copy a array of attribute structure in another one
188	!> @details
189	!> see att__copy_unit
190	!>
191	!> @warning do not use on the output of a function who create or read an
192	!> attribute (ex: tl_att=att_copy(att_init()) is forbidden).
193	!> This will create memory leaks.
194	!> @warning to avoid infinite loop, do not use any function inside
195	!> this subroutine
196	!>
197	!> @author J.Paul
198	!> @date November, 2013 - Initial Version
199	!> @date November, 2014
200	!> - use function instead of overload assignment operator
201	!> (to avoid memory leak)
202	!
203	!> @param[in] td_att array of attribute structure
204	!> @return copy of input array of attribute structure
205	!-------------------------------------------------------------------
206
207	IMPLICIT NONE
208
209	! Argument
210	TYPE(TATT), DIMENSION(:) , INTENT(IN) :: td_att
211	! function
212	TYPE(TATT), DIMENSION(SIZE(td_att(:))) :: tf_att
213
214	! local variable
215	! loop indices
216	INTEGER(i4) :: ji
217	!----------------------------------------------------------------
218
219	DO ji=1,SIZE(td_att(:))
220	tf_att(ji)=att_copy(td_att(ji))
221	ENDDO
222
223	END FUNCTION att__copy_arr
224	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
225	FUNCTION att__copy_unit(td_att) &
226	& RESULT (tf_att)
227	!-------------------------------------------------------------------
228	!> @brief
229	!> This subroutine copy an attribute structure in another one.
230	!> @details
231	!> attribute value are copied in a temporary array, so input and output
232	!> attribute structure value do not point on the same "memory cell", and so
233	!> on are independant.
234	!>
235	!> @warning do not use on the output of a function who create or read an
236	!> attribute (ex: tl_att=att_copy(att_init()) is forbidden).
237	!> This will create memory leaks.
238	!> @warning to avoid infinite loop, do not use any function inside
239	!> this subroutine
240	!>
241	!> @author J.Paul
242	!> @date November, 2013 - Initial Version
243	!> @date November, 2014
244	!> - use function instead of overload assignment operator (to avoid memory leak)
245	!>
246	!> @param[in] td_att attribute structure
247	!> @return copy of input attribute structure
248	!-------------------------------------------------------------------
249
250	IMPLICIT NONE
251
252	! Argument
253	TYPE(TATT), INTENT(IN) :: td_att
254
255	! function
256	TYPE(TATT) :: tf_att
257
258	! local variable
259	REAL(dp) , DIMENSION(:), ALLOCATABLE :: dl_value
260	!----------------------------------------------------------------
261
262	! copy attribute variable
263	tf_att%c_name = TRIM(td_att%c_name)
264	tf_att%i_id = td_att%i_id
265	tf_att%i_type = td_att%i_type
266	tf_att%i_len = td_att%i_len
267	tf_att%c_value = TRIM(td_att%c_value)
268
269	! copy attribute pointer in an independant variable
270	IF( ASSOCIATED(tf_att%d_value) ) DEALLOCATE(tf_att%d_value)
271	IF( ASSOCIATED(td_att%d_value) )THEN
272	ALLOCATE( dl_value(td_att%i_len) )
273	dl_value(:) = td_att%d_value(:)
274
275	ALLOCATE( tf_att%d_value(tf_att%i_len) )
276	tf_att%d_value(:) = dl_value(:)
277
278	DEALLOCATE( dl_value )
279	ENDIF
280
281	END FUNCTION att__copy_unit
282	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
283	FUNCTION att_get_index(td_att, cd_name) &
284	& RESULT(if_idx)
285	!-------------------------------------------------------------------
286	!> @brief This function return attribute index, in a array of attribute structure,
287	!> given attribute name.<br/>
288	!> @details
289	!> if attribute name do not exist, return 0.
290	!>
291	!> @author J.Paul
292	!> @date Septempber, 2014 - Initial Version
293	!
294	!> @param[in] td_att array of attribute structure
295	!> @param[in] cd_name attribute name
296	!> @return attribute index
297	!-------------------------------------------------------------------
298
299	IMPLICIT NONE
300
301	! Argument
302	TYPE(TATT), DIMENSION(:), INTENT(IN) :: td_att
303	CHARACTER(LEN=*), INTENT(IN) :: cd_name
304
305	! function
306	INTEGER(i4) :: if_idx
307
308	! local variable
309	INTEGER(i4) :: il_size
310
311	! loop indices
312	INTEGER(i4) :: ji
313	!----------------------------------------------------------------
314	if_idx=0
315
316	il_size=SIZE(td_att(:))
317	DO ji=1,il_size
318	IF( TRIM(td_att(ji)%c_name) == TRIM(cd_name) )THEN
319	if_idx=ji
320	EXIT
321	ENDIF
322	ENDDO
323
324	END FUNCTION att_get_index
325	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
326	FUNCTION att_get_id(td_att, cd_name) &
327	& RESULT (if_id)
328	!-------------------------------------------------------------------
329	!> @brief This function return attribute id, read from a file.<br/>
330	!> @details
331	!> if attribute name do not exist, return 0.
332	!>
333	!> @author J.Paul
334	!> @date November, 2013 - Initial Version
335	!> @date September, 2014
336	!> - bug fix with use of id read from attribute structure
337	!>
338	!> @param[in] td_att array of attribute structure
339	!> @param[in] cd_name attribute name
340	!> @return attribute id
341	!-------------------------------------------------------------------
342
343	IMPLICIT NONE
344
345	! Argument
346	TYPE(TATT), DIMENSION(:), INTENT(IN) :: td_att
347	CHARACTER(LEN=*), INTENT(IN) :: cd_name
348
349	! function
350	INTEGER(i4) :: if_id
351
352	! local variable
353	INTEGER(i4) :: il_size
354
355	! loop indices
356	INTEGER(i4) :: ji
357	!----------------------------------------------------------------
358	if_id=0
359
360	il_size=SIZE(td_att(:))
361	DO ji=1,il_size
362	IF( TRIM(td_att(ji)%c_name) == TRIM(cd_name) )THEN
363	if_id=td_att(ji)%i_id
364	EXIT
365	ENDIF
366	ENDDO
367
368	END FUNCTION att_get_id
369	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
370	FUNCTION att__init_c(cd_name, cd_value) &
371	& RESULT (tf_att)
372	!-------------------------------------------------------------------
373	!> @brief This function initialize an attribute structure with character
374	!> value.
375	!>
376	!> @author J.Paul
377	!> @date November, 2013 - Initial Version
378	!
379	!> @param[in] cd_name attribute name
380	!> @param[in] cd_value attribute value
381	!> @return attribute structure
382	!-------------------------------------------------------------------
383
384	IMPLICIT NONE
385
386	! Argument
387	CHARACTER(LEN=*), INTENT(IN) :: cd_name
388	CHARACTER(LEN=*), INTENT(IN) :: cd_value
389
390	! function
391	TYPE(TATT) :: tf_att
392	!----------------------------------------------------------------
393
394	! clean attribute
395	CALL att_clean(tf_att)
396
397	CALL logger_trace( &
398	& " ATT INIT: attribute name: "//TRIM(ADJUSTL(cd_name))//&
399	& " attribute value "//TRIM(ADJUSTL(cd_value)) )
400
401	tf_att%c_name=TRIM(ADJUSTL(cd_name))
402	tf_att%i_type=NF90_CHAR
403
404	tf_att%c_value=TRIM(ADJUSTL(cd_value))
405	tf_att%i_len=LEN( TRIM(ADJUSTL(cd_value)) )
406
407	END FUNCTION att__init_c
408	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
409	FUNCTION att__init_dp(cd_name, dd_value, id_type) &
410	& RESULT (tf_att)
411	!-------------------------------------------------------------------
412	!> @brief This function initialize an attribute structure with array
413	!> of real(8) value.
414	!> @details
415	!> Optionaly you could specify the type of the variable to be saved.
416	!>
417	!> @author J.Paul
418	!> @date November, 2013 - Initial Version
419	!
420	!> @param[in] cd_name attribute name
421	!> @param[in] dd_value attribute value
422	!> @param[in] id_type type of the variable to be saved
423	!> @return attribute structure
424	!-------------------------------------------------------------------
425
426	IMPLICIT NONE
427
428	! Argument
429	CHARACTER(LEN=*), INTENT(IN) :: cd_name
430	REAL(dp), DIMENSION(:), INTENT(IN) :: dd_value
431	INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type
432
433	! function
434	TYPE(TATT) :: tf_att
435
436	! local value
437	INTEGER(i4) :: il_len
438	CHARACTER(LEN=lc) :: cl_value
439
440	! loop indices
441	INTEGER(i4) :: ji
442	!----------------------------------------------------------------
443
444	! clean attribute
445	CALL att_clean(tf_att)
446
447	! array size
448	il_len=size(dd_value(:))
449
450	cl_value="(/"
451	DO ji=1,il_len-1
452	cl_value=TRIM(cl_value)//TRIM(fct_str(dd_value(ji)))//","
453	ENDDO
454	cl_value=TRIM(cl_value)//TRIM(fct_str(dd_value(il_len)))//"/)"
455
456	CALL logger_trace( &
457	& " ATT INIT: attribute name: "//TRIM(ADJUSTL(cd_name))//&
458	& " attribute value "//TRIM(ADJUSTL(cl_value)) )
459
460	tf_att%c_name=TRIM(ADJUSTL(cd_name))
461
462	IF( PRESENT(id_type) )THEN
463	tf_att%i_type=id_type
464	ELSE
465	tf_att%i_type=NF90_DOUBLE
466	ENDIF
467
468	IF( ASSOCIATED(tf_att%d_value) )THEN
469	DEALLOCATE(tf_att%d_value)
470	ENDIF
471	ALLOCATE(tf_att%d_value(il_len))
472
473	tf_att%d_value(:)=dd_value(:)
474	tf_att%i_len=il_len
475
476	END FUNCTION att__init_dp
477	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
478	FUNCTION att__init_dp_0d(cd_name, dd_value, id_type) &
479	& RESULT (tf_att)
480	!-------------------------------------------------------------------
481	!> @brief This function initialize an attribute structure with
482	!> real(8) value
483	!> @details
484	!> Optionaly you could specify the type of the variable to be saved.
485	!>
486	!> @author J.Paul
487	!> @date November, 2013 - Initial Version
488	!
489	!> @param[in] cd_name attribute name
490	!> @param[in] dd_value attribute value
491	!> @param[in] id_type type of the variable to be saved
492	!> @return attribute structure
493	!-------------------------------------------------------------------
494
495	IMPLICIT NONE
496
497	! Argument
498	CHARACTER(LEN=*), INTENT(IN) :: cd_name
499	REAL(dp), INTENT(IN) :: dd_value
500	INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type
501
502	! function
503	TYPE(TATT) :: tf_att
504
505	! local value
506	CHARACTER(LEN=lc) :: cl_value
507	!----------------------------------------------------------------
508
509	! clean attribute
510	CALL att_clean(tf_att)
511
512	cl_value="(/"//TRIM(fct_str(dd_value))//"/)"
513
514	CALL logger_trace( &
515	& " ATT INIT: attribute name: "//TRIM(ADJUSTL(cd_name))//&
516	& " attribute value "//TRIM(ADJUSTL(cl_value)) )
517
518	tf_att%c_name=TRIM(ADJUSTL(cd_name))
519
520	IF( PRESENT(id_type) )THEN
521	tf_att%i_type=id_type
522	ELSE
523	tf_att%i_type=NF90_DOUBLE
524	ENDIF
525
526	IF( ASSOCIATED(tf_att%d_value) )THEN
527	DEALLOCATE(tf_att%d_value)
528	ENDIF
529	ALLOCATE(tf_att%d_value(1))
530
531	tf_att%d_value(1)=dd_value
532	tf_att%i_len=1
533
534	END FUNCTION att__init_dp_0d
535	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
536	FUNCTION att__init_sp(cd_name, rd_value, id_type) &
537	& RESULT (tf_att)
538	!-------------------------------------------------------------------
539	!> @brief This function initialize an attribute structure with array
540	!> of real(4) value.
541	!> @details
542	!> Optionaly you could specify the type of the variable to be saved.
543	!>
544	!> @author J.Paul
545	!> @date November, 2013 - Initial Version
546	!
547	!> @param[in] cd_name attribute name
548	!> @param[in] rd_value attribute value
549	!> @param[in] id_type type of the variable to be saved
550	!> @return attribute structure
551	!-------------------------------------------------------------------
552
553	IMPLICIT NONE
554
555	! Argument
556	CHARACTER(LEN=*), INTENT(IN) :: cd_name
557	REAL(sp), DIMENSION(:), INTENT(IN) :: rd_value
558	INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type
559
560	! function
561	TYPE(TATT) :: tf_att
562
563	! local value
564	INTEGER(i4) :: il_len
565	CHARACTER(LEN=lc) :: cl_value
566
567	! loop indices
568	INTEGER(i4) :: ji
569	!----------------------------------------------------------------
570
571	! clean attribute
572	CALL att_clean(tf_att)
573
574	! array size
575	il_len=size(rd_value(:))
576
577	cl_value="(/"
578	DO ji=1,il_len-1
579	cl_value=TRIM(cl_value)//TRIM(fct_str(rd_value(ji)))//","
580	ENDDO
581	CALL logger_trace( &
582	& " ATT INIT: attribute name: il_len "//fct_str(il_len)&
583	)
584	cl_value=TRIM(cl_value)//TRIM(fct_str(rd_value(il_len)))//"/)"
585
586	CALL logger_trace( &
587	& " ATT INIT: attribute name: "//TRIM(ADJUSTL(cd_name))//&
588	& " attribute value "//TRIM(ADJUSTL(cl_value)) )
589
590	tf_att%c_name=TRIM(ADJUSTL(cd_name))
591
592	IF( PRESENT(id_type) )THEN
593	tf_att%i_type=id_type
594	ELSE
595	tf_att%i_type=NF90_FLOAT
596	ENDIF
597
598	IF( ASSOCIATED(tf_att%d_value) )THEN
599	DEALLOCATE(tf_att%d_value)
600	ENDIF
601	ALLOCATE(tf_att%d_value(il_len))
602
603	tf_att%d_value(:)=REAL(rd_value(:),dp)
604	tf_att%i_len=il_len
605
606	END FUNCTION att__init_sp
607	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
608	FUNCTION att__init_sp_0d(cd_name, rd_value, id_type) &
609	& RESULT (tf_att)
610	!-------------------------------------------------------------------
611	!> @brief This function initialize an attribute structure with
612	!> real(4) value.
613	!> @details
614	!> Optionaly you could specify the type of the variable to be saved.
615	!>
616	!> @author J.Paul
617	!> @date November, 2013 - Initial Version
618	!
619	!> @param[in] cd_name attribute name
620	!> @param[in] rd_value attribute value
621	!> @param[in] id_type type of the variable to be saved
622	!> @return attribute structure
623	!-------------------------------------------------------------------
624
625	IMPLICIT NONE
626
627	! Argument
628	CHARACTER(LEN=*), INTENT(IN) :: cd_name
629	REAL(sp), INTENT(IN) :: rd_value
630	INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type
631
632	! function
633	TYPE(TATT) :: tf_att
634
635	! local value
636	CHARACTER(LEN=lc) :: cl_value
637	!----------------------------------------------------------------
638
639	! clean attribute
640	CALL att_clean(tf_att)
641
642	cl_value="(/"//TRIM(fct_str(rd_value))//"/)"
643
644	CALL logger_trace( &
645	& " ATT INIT: attribute name: "//TRIM(ADJUSTL(cd_name))//&
646	& " attribute value "//TRIM(ADJUSTL(cl_value)) )
647
648	tf_att%c_name=TRIM(ADJUSTL(cd_name))
649
650	IF( PRESENT(id_type) )THEN
651	tf_att%i_type=id_type
652	ELSE
653	tf_att%i_type=NF90_FLOAT
654	ENDIF
655
656	IF( ASSOCIATED(tf_att%d_value) )THEN
657	DEALLOCATE(tf_att%d_value)
658	ENDIF
659	ALLOCATE(tf_att%d_value(1))
660
661	tf_att%d_value(1)=REAL(rd_value,dp)
662	tf_att%i_len=1
663
664	END FUNCTION att__init_sp_0d
665	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
666	FUNCTION att__init_i1(cd_name, bd_value, id_type) &
667	& RESULT (tf_att)
668	!-------------------------------------------------------------------
669	!> @brief This function initialize an attribute structure with array
670	!> of integer(1) value.
671	!> @details
672	!> Optionaly you could specify the type of the variable to be saved.
673	!>
674	!> @author J.Paul
675	!> @date November, 2013 - Initial Version
676	!
677	!> @param[in] cd_name attribute name
678	!> @param[in] bd_value attribute value
679	!> @param[in] id_type type of the variable to be saved
680	!> @return attribute structure
681	!-------------------------------------------------------------------
682
683	IMPLICIT NONE
684
685	! Argument
686	CHARACTER(LEN=*), INTENT(IN) :: cd_name
687	INTEGER(i1), DIMENSION(:), INTENT(IN) :: bd_value
688	INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type
689
690	! function
691	TYPE(TATT) :: tf_att
692
693	! local value
694	INTEGER(i4) :: il_len
695	CHARACTER(LEN=lc) :: cl_value
696
697	! loop indices
698	INTEGER(i4) :: ji
699	!----------------------------------------------------------------
700
701	! clean attribute
702	CALL att_clean(tf_att)
703
704	! array size
705	il_len=size(bd_value(:))
706
707	cl_value="(/"
708	DO ji=1,il_len-1
709	cl_value=TRIM(cl_value)//TRIM(fct_str(bd_value(ji)))//","
710	ENDDO
711	cl_value=TRIM(cl_value)//TRIM(fct_str(bd_value(il_len)))//"/)"
712
713	CALL logger_trace( &
714	& " ATT INIT: attribute name: "//TRIM(ADJUSTL(cd_name))//&
715	& " attribute value "//TRIM(ADJUSTL(cl_value)) )
716
717	tf_att%c_name=TRIM(ADJUSTL(cd_name))
718
719	IF( PRESENT(id_type) )THEN
720	tf_att%i_type=id_type
721	ELSE
722	tf_att%i_type=NF90_BYTE
723	ENDIF
724
725	IF( ASSOCIATED(tf_att%d_value) )THEN
726	DEALLOCATE(tf_att%d_value)
727	ENDIF
728	ALLOCATE(tf_att%d_value(il_len))
729
730	tf_att%d_value(:)=REAL(bd_value(:),dp)
731	tf_att%i_len=il_len
732
733	END FUNCTION att__init_i1
734	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
735	FUNCTION att__init_i1_0d(cd_name, bd_value, id_type) &
736	& RESULT (tf_att)
737	!-------------------------------------------------------------------
738	!> @brief This function initialize an attribute structure with
739	!> integer(1) value.
740	!> @details
741	!> Optionaly you could specify the type of the variable to be saved.
742	!>
743	!> @author J.Paul
744	!> @date November, 2013 - Initial Version
745	!
746	!> @param[in] cd_name attribute name
747	!> @param[in] bd_value attribute value
748	!> @param[in] id_type type of the variable to be saved
749	!> @return attribute structure
750	!-------------------------------------------------------------------
751
752	IMPLICIT NONE
753
754	! Argument
755	CHARACTER(LEN=*), INTENT(IN) :: cd_name
756	INTEGER(i1), INTENT(IN) :: bd_value
757	INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type
758
759	! function
760	TYPE(TATT) :: tf_att
761
762	!local value
763	CHARACTER(LEN=lc) :: cl_value
764	!----------------------------------------------------------------
765
766	! clean attribute
767	CALL att_clean(tf_att)
768
769	cl_value="(/"//TRIM(fct_str(bd_value))//"/)"
770
771	CALL logger_trace( &
772	& " ATT INIT: attribute name: "//TRIM(ADJUSTL(cd_name))//&
773	& " attibute value "//TRIM(ADJUSTL(cl_value)) )
774
775	tf_att%c_name=TRIM(ADJUSTL(cd_name))
776
777	IF( PRESENT(id_type) )THEN
778	tf_att%i_type=id_type
779	ELSE
780	tf_att%i_type=NF90_BYTE
781	ENDIF
782
783	IF( ASSOCIATED(tf_att%d_value) )THEN
784	DEALLOCATE(tf_att%d_value)
785	ENDIF
786	ALLOCATE(tf_att%d_value(1))
787
788	tf_att%d_value(1)=REAL(bd_value,dp)
789	tf_att%i_len=1
790
791	END FUNCTION att__init_i1_0d
792	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
793	FUNCTION att__init_i2(cd_name, sd_value, id_type) &
794	& RESULT (tf_att)
795	!-------------------------------------------------------------------
796	!> @brief This function initialize an attribute structure with array
797	!> of integer(2) value.
798	!> @details
799	!> Optionaly you could specify the type of the variable to be saved.
800	!>
801	!> @author J.Paul
802	!> @date November, 2013 - Initial Version
803	!
804	!> @param[in] cd_name attribute name
805	!> @param[in] sd_value attribute value
806	!> @param[in] id_type type of the variable to be saved
807	!> @return attribute structure
808	!-------------------------------------------------------------------
809
810	IMPLICIT NONE
811
812	! Argument
813	CHARACTER(LEN=*), INTENT(IN) :: cd_name
814	INTEGER(i2), DIMENSION(:), INTENT(IN) :: sd_value
815	INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type
816
817	! function
818	TYPE(TATT) :: tf_att
819
820	! local value
821	INTEGER(i4) :: il_len
822	CHARACTER(LEN=lc) :: cl_value
823
824	! loop indices
825	INTEGER(i4) :: ji
826	!----------------------------------------------------------------
827
828	! clean attribute
829	CALL att_clean(tf_att)
830
831	! array size
832	il_len=size(sd_value(:))
833
834	cl_value="(/"
835	DO ji=1,il_len-1
836	cl_value=TRIM(cl_value)//TRIM(fct_str(sd_value(ji)))//","
837	ENDDO
838	cl_value=TRIM(cl_value)//TRIM(fct_str(sd_value(il_len)))//"/)"
839
840	CALL logger_trace( &
841	& " ATT INIT: attribute name: "//TRIM(ADJUSTL(cd_name))//&
842	& " attribute value "//TRIM(ADJUSTL(cl_value)) )
843
844	tf_att%c_name=TRIM(ADJUSTL(cd_name))
845
846	IF( PRESENT(id_type) )THEN
847	tf_att%i_type=id_type
848	ELSE
849	tf_att%i_type=NF90_SHORT
850	ENDIF
851
852	IF( ASSOCIATED(tf_att%d_value) )THEN
853	DEALLOCATE(tf_att%d_value)
854	ENDIF
855	ALLOCATE(tf_att%d_value(il_len))
856
857	tf_att%d_value(:)=REAL(sd_value(:),dp)
858	tf_att%i_len=il_len
859
860	END FUNCTION att__init_i2
861	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
862	FUNCTION att__init_i2_0d(cd_name, sd_value, id_type) &
863	& RESULT (tf_att)
864	!-------------------------------------------------------------------
865	!> @brief This function initialize an attribute structure with
866	!> integer(2) value.
867	!> @details
868	!> Optionaly you could specify the type of the variable to be saved.
869	!>
870	!> @author J.Paul
871	!> @date November, 2013 - Initial Version
872	!
873	!> @param[in] cd_name attribute name
874	!> @param[in] sd_value attribute value
875	!> @param[in] id_type type of the variable to be saved
876	!> @return attribute structure
877	!-------------------------------------------------------------------
878
879	IMPLICIT NONE
880
881	! Argument
882	CHARACTER(LEN=*), INTENT(IN) :: cd_name
883	INTEGER(i2), INTENT(IN) :: sd_value
884	INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type
885
886	! function
887	TYPE(TATT) :: tf_att
888
889	!local value
890	CHARACTER(LEN=lc) :: cl_value
891	!----------------------------------------------------------------
892
893	! clean attribute
894	CALL att_clean(tf_att)
895
896	cl_value="(/"//TRIM(fct_str(sd_value))//"/)"
897
898	CALL logger_trace( &
899	& " ATT INIT: attribute name: "//TRIM(ADJUSTL(cd_name))//&
900	& " attibute value "//TRIM(ADJUSTL(cl_value)) )
901
902	tf_att%c_name=TRIM(ADJUSTL(cd_name))
903
904	IF( PRESENT(id_type) )THEN
905	tf_att%i_type=id_type
906	ELSE
907	tf_att%i_type=NF90_SHORT
908	ENDIF
909
910	IF( ASSOCIATED(tf_att%d_value) )THEN
911	DEALLOCATE(tf_att%d_value)
912	ENDIF
913	ALLOCATE(tf_att%d_value(1))
914
915	tf_att%d_value(1)=REAL(sd_value,dp)
916	tf_att%i_len=1
917
918	END FUNCTION att__init_i2_0d
919	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
920	FUNCTION att__init_i4(cd_name, id_value, id_type) &
921	& RESULT(tf_att)
922	!-------------------------------------------------------------------
923	!> @brief This function initialize an attribute structure with array
924	!> of integer(4) value.
925	!> @details
926	!> Optionaly you could specify the type of the variable to be saved.
927	!>
928	!> @author J.Paul
929	!> @date November, 2013 - Initial Version
930	!
931	!> @param[in] cd_name attribute name
932	!> @param[in] id_value attribute value
933	!> @param[in] id_type type of the variable to be saved
934	!> @return attribute structure
935	!-------------------------------------------------------------------
936
937	IMPLICIT NONE
938
939	! Argument
940	CHARACTER(LEN=*), INTENT(IN) :: cd_name
941	INTEGER(i4), DIMENSION(:), INTENT(IN) :: id_value
942	INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type
943
944	! function
945	TYPE(TATT) :: tf_att
946
947	! local value
948	INTEGER(i4) :: il_len
949	CHARACTER(LEN=lc) :: cl_value
950
951	! loop indices
952	INTEGER(i4) :: ji
953	!----------------------------------------------------------------
954
955	! clean attribute
956	CALL att_clean(tf_att)
957
958	! array size
959	il_len=size(id_value(:))
960
961	cl_value="(/"
962	DO ji=1,il_len-1
963	cl_value=TRIM(cl_value)//TRIM(fct_str(id_value(ji)))//","
964	ENDDO
965	cl_value=TRIM(cl_value)//TRIM(fct_str(id_value(il_len)))//"/)"
966
967	CALL logger_trace( &
968	& " ATT INIT: attribute name: "//TRIM(ADJUSTL(cd_name))//&
969	& " attribute value "//TRIM(ADJUSTL(cl_value)) )
970
971	tf_att%c_name=TRIM(ADJUSTL(cd_name))
972
973	IF( PRESENT(id_type) )THEN
974	tf_att%i_type=id_type
975	ELSE
976	tf_att%i_type=NF90_INT
977	ENDIF
978
979	IF( ASSOCIATED(tf_att%d_value) )THEN
980	DEALLOCATE(tf_att%d_value)
981	ENDIF
982	ALLOCATE(tf_att%d_value(il_len))
983
984	tf_att%d_value(:)=REAL(id_value(:),dp)
985	tf_att%i_len=il_len
986
987	END FUNCTION att__init_i4
988	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
989	FUNCTION att__init_i4_0d(cd_name, id_value, id_type) &
990	& RESULT (tf_att)
991	!-------------------------------------------------------------------
992	!> @brief This function initialize an attribute structure with
993	!> integer(4) value.
994	!> @details
995	!> Optionaly you could specify the type of the variable to be saved.
996	!>
997	!> @author J.Paul
998	!> @date November, 2013 - Initial Version
999	!>
1000	!> @param[in] cd_name attribute name
1001	!> @param[in] id_value attribute value
1002	!> @param[in] id_type type of the variable to be saved
1003	!> @return attribute structure
1004	!-------------------------------------------------------------------
1005
1006	IMPLICIT NONE
1007
1008	! Argument
1009	CHARACTER(LEN=*), INTENT(IN) :: cd_name
1010	INTEGER(i4), INTENT(IN) :: id_value
1011	INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type
1012
1013	! function
1014	TYPE(TATT) :: tf_att
1015
1016	!local value
1017	CHARACTER(LEN=lc) :: cl_value
1018	!----------------------------------------------------------------
1019
1020	! clean attribute
1021	CALL att_clean(tf_att)
1022
1023	cl_value="(/"//TRIM(fct_str(id_value))//"/)"
1024
1025	CALL logger_trace( &
1026	& " ATT INIT: attribute name: "//TRIM(ADJUSTL(cd_name))//&
1027	& " attibute value "//TRIM(ADJUSTL(cl_value)) )
1028
1029	tf_att%c_name=TRIM(ADJUSTL(cd_name))
1030
1031	IF( PRESENT(id_type) )THEN
1032	tf_att%i_type=id_type
1033	ELSE
1034	tf_att%i_type=NF90_INT
1035	ENDIF
1036
1037	IF( ASSOCIATED(tf_att%d_value) )THEN
1038	DEALLOCATE(tf_att%d_value)
1039	ENDIF
1040	ALLOCATE(tf_att%d_value(1))
1041
1042	tf_att%d_value(1)=REAL(id_value,dp)
1043	tf_att%i_len=1
1044
1045	END FUNCTION att__init_i4_0d
1046	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1047	FUNCTION att__init_i8(cd_name, kd_value, id_type) &
1048	& RESULT (tf_att)
1049	!-------------------------------------------------------------------
1050	!> @brief This function initialize an attribute structure with array
1051	!> of integer(8) value.
1052	!> @details
1053	!> Optionaly you could specify the type of the variable to be saved.
1054	!>
1055	!> @author J.Paul
1056	!> @date November, 2013 - Initial Version
1057	!
1058	!> @param[in] cd_name attribute name
1059	!> @param[in] kd_value attribute value
1060	!> @param[in] id_type type of the variable to be saved
1061	!> @return attribute structure
1062	!-------------------------------------------------------------------
1063
1064	IMPLICIT NONE
1065
1066	! Argument
1067	CHARACTER(LEN=*), INTENT(IN) :: cd_name
1068	INTEGER(i8), DIMENSION(:), INTENT(IN) :: kd_value
1069	INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type
1070
1071	! function
1072	TYPE(TATT) :: tf_att
1073
1074	! local value
1075	INTEGER(i4) :: il_len
1076	CHARACTER(LEN=lc) :: cl_value
1077
1078	! loop indices
1079	INTEGER(i4) :: ji
1080	!----------------------------------------------------------------
1081
1082	! clean attribute
1083	CALL att_clean(tf_att)
1084
1085	! array size
1086	il_len=size(kd_value(:))
1087
1088	cl_value="(/"
1089	DO ji=1,il_len
1090	cl_value=TRIM(cl_value)//TRIM(fct_str(kd_value(ji)))//","
1091	ENDDO
1092	cl_value=TRIM(cl_value)//TRIM(fct_str(kd_value(il_len)))//"/)"
1093
1094	CALL logger_trace( &
1095	& " ATT INIT: attribute name: "//TRIM(ADJUSTL(cd_name))//&
1096	& " attibute value "//TRIM(ADJUSTL(cl_value)) )
1097
1098	tf_att%c_name=TRIM(ADJUSTL(cd_name))
1099
1100	IF( PRESENT(id_type) )THEN
1101	tf_att%i_type=id_type
1102	ELSE
1103	tf_att%i_type=NF90_INT
1104	ENDIF
1105
1106	IF( ASSOCIATED(tf_att%d_value) )THEN
1107	DEALLOCATE(tf_att%d_value)
1108	ENDIF
1109	ALLOCATE(tf_att%d_value(il_len))
1110
1111	tf_att%d_value(:)=REAL(kd_value(:),dp)
1112	tf_att%i_len=il_len
1113
1114	END FUNCTION att__init_i8
1115	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1116	FUNCTION att__init_i8_0d(cd_name, kd_value, id_type) &
1117	& RESULT (tf_att)
1118	!-------------------------------------------------------------------
1119	!> @brief This function initialize an attribute structure with
1120	!> integer(8) value.
1121	!> @details
1122	!> Optionaly you could specify the type of the variable to be saved.
1123	!>
1124	!> @author J.Paul
1125	!> @date November, 2013 - Initial Version
1126	!
1127	!> @param[in] cd_name attribute name
1128	!> @param[in] kd_value attribute value
1129	!> @param[in] id_type type of the variable to be saved
1130	!> @return attribute structure
1131	!-------------------------------------------------------------------
1132
1133	IMPLICIT NONE
1134
1135	! Argument
1136	CHARACTER(LEN=*), INTENT(IN) :: cd_name
1137	INTEGER(i8), INTENT(IN) :: kd_value
1138	INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type
1139
1140	! function
1141	TYPE(TATT) :: tf_att
1142
1143	! local value
1144	CHARACTER(LEN=lc) :: cl_value
1145	!----------------------------------------------------------------
1146
1147	! clean attribute
1148	CALL att_clean(tf_att)
1149
1150	cl_value="(/"//TRIM(fct_str(kd_value))//"/)"
1151
1152	CALL logger_trace( &
1153	& " ATT INIT: attribute name: "//TRIM(ADJUSTL(cd_name))//&
1154	& " attibute value "//TRIM(ADJUSTL(cl_value)) )
1155
1156	tf_att%c_name=TRIM(ADJUSTL(cd_name))
1157
1158	IF( PRESENT(id_type) )THEN
1159	tf_att%i_type=id_type
1160	ELSE
1161	tf_att%i_type=NF90_INT
1162	ENDIF
1163
1164	IF( ASSOCIATED(tf_att%d_value) )THEN
1165	DEALLOCATE(tf_att%d_value)
1166	ENDIF
1167	ALLOCATE(tf_att%d_value(1))
1168
1169	tf_att%d_value(1)=REAL(kd_value,dp)
1170	tf_att%i_len=1
1171
1172	END FUNCTION att__init_i8_0d
1173	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1174	SUBROUTINE att__print_arr(td_att)
1175	!-------------------------------------------------------------------
1176	!> @brief This subroutine print informations of an array of attribute.
1177	!>
1178	!> @author J.Paul
1179	!> @date June, 2014 - Initial Version
1180	!>
1181	!> @param[in] td_att array of attribute structure
1182	!-------------------------------------------------------------------
1183
1184	IMPLICIT NONE
1185
1186	! Argument
1187	TYPE(TATT), DIMENSION(:), INTENT(IN) :: td_att
1188
1189	! loop indices
1190	INTEGER(i4) :: ji
1191	!----------------------------------------------------------------
1192
1193	DO ji=1,SIZE(td_att(:))
1194	CALL att_print(td_att(ji))
1195	ENDDO
1196
1197	END SUBROUTINE att__print_arr
1198	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1199	SUBROUTINE att__print_unit(td_att)
1200	!-------------------------------------------------------------------
1201	!> @brief This subroutine print attribute information.
1202	!>
1203	!> @author J.Paul
1204	!> @date November, 2013 - Initial Version
1205	!> @date September, 2014
1206	!> - take into account type of attribute.
1207	!
1208	!> @param[in] td_att attribute structure
1209	!-------------------------------------------------------------------
1210
1211	IMPLICIT NONE
1212
1213	! Argument
1214	TYPE(TATT), INTENT(IN) :: td_att
1215
1216	! local vairbale
1217	CHARACTER(LEN=lc) :: cl_type
1218	CHARACTER(LEN=lc) :: cl_value
1219
1220	INTEGER(i8) :: kl_tmp
1221	INTEGER(i2) :: sl_tmp
1222	INTEGER(i1) :: bl_tmp
1223	REAL(sp) :: rl_tmp
1224	REAL(dp) :: dl_tmp
1225
1226	! loop indices
1227	INTEGER(i4) :: ji
1228	!----------------------------------------------------------------
1229
1230	SELECT CASE( td_att%i_type )
1231
1232	CASE(NF90_CHAR)
1233	cl_type='CHAR'
1234	CASE(NF90_BYTE)
1235	cl_type='BYTE'
1236	CASE(NF90_SHORT)
1237	cl_type='SHORT'
1238	CASE(NF90_INT)
1239	cl_type='INT'
1240	CASE(NF90_FLOAT)
1241	cl_type='FLOAT'
1242	CASE(NF90_DOUBLE)
1243	cl_type='DOUBLE'
1244	CASE DEFAULT
1245	cl_type=''
1246
1247	END SELECT
1248
1249	SELECT CASE( td_att%i_type )
1250
1251	CASE(NF90_CHAR)
1252
1253	cl_value=td_att%c_value
1254
1255	CASE(NF90_BYTE)
1256	IF( td_att%i_len > 1 )THEN
1257	cl_value='(/'
1258	DO ji=1,td_att%i_len-1
1259	bl_tmp=INT(td_att%d_value(ji),i1)
1260	cl_value=TRIM(cl_value)//TRIM(fct_str(bl_tmp))//','
1261	ENDDO
1262	bl_tmp=INT(td_att%d_value(td_att%i_len),i1)
1263	cl_value=TRIM(cl_value)//TRIM(fct_str(bl_tmp))//'/)'
1264	ELSE
1265	cl_value='(/'//TRIM(fct_str(td_att%d_value(1)))//'/)'
1266	ENDIF
1267
1268	CASE(NF90_SHORT)
1269	IF( td_att%i_len > 1 )THEN
1270	cl_value='(/'
1271	DO ji=1,td_att%i_len-1
1272	sl_tmp=INT(td_att%d_value(ji),i2)
1273	cl_value=TRIM(cl_value)//TRIM(fct_str(sl_tmp))//','
1274	ENDDO
1275	sl_tmp=INT(td_att%d_value(td_att%i_len),i2)
1276	cl_value=TRIM(cl_value)//TRIM(fct_str(sl_tmp))//'/)'
1277	ELSE
1278	cl_value='(/'//TRIM(fct_str(td_att%d_value(1)))//'/)'
1279	ENDIF
1280
1281	CASE(NF90_INT)
1282	IF( td_att%i_len > 1 )THEN
1283	cl_value='(/'
1284	DO ji=1,td_att%i_len-1
1285	kl_tmp=INT(td_att%d_value(ji),i8)
1286	cl_value=TRIM(cl_value)//TRIM(fct_str(kl_tmp))//','
1287	ENDDO
1288	kl_tmp=INT(td_att%d_value(td_att%i_len),i8)
1289	cl_value=TRIM(cl_value)//TRIM(fct_str(kl_tmp))//'/)'
1290	ELSE
1291	cl_value='(/'//TRIM(fct_str(td_att%d_value(1)))//'/)'
1292	ENDIF
1293
1294	CASE(NF90_FLOAT)
1295	IF( td_att%i_len > 1 )THEN
1296	cl_value='(/'
1297	DO ji=1,td_att%i_len-1
1298	rl_tmp=REAL(td_att%d_value(ji),sp)
1299	cl_value=TRIM(cl_value)//TRIM(fct_str(rl_tmp))//','
1300	ENDDO
1301	rl_tmp=REAL(td_att%d_value(td_att%i_len),sp)
1302	cl_value=TRIM(cl_value)//TRIM(fct_str(rl_tmp))//'/)'
1303	ELSE
1304	cl_value='(/'//TRIM(fct_str(td_att%d_value(1)))//'/)'
1305	ENDIF
1306
1307	CASE(NF90_DOUBLE)
1308	IF( td_att%i_len > 1 )THEN
1309	cl_value='(/'
1310	DO ji=1,td_att%i_len-1
1311	dl_tmp=REAL(td_att%d_value(ji),dp)
1312	cl_value=TRIM(cl_value)//TRIM(fct_str(dl_tmp))//','
1313	ENDDO
1314	dl_tmp=REAL(td_att%d_value(td_att%i_len),dp)
1315	cl_value=TRIM(cl_value)//TRIM(fct_str(dl_tmp))//'/)'
1316	ELSE
1317	cl_value='(/'//TRIM(fct_str(td_att%d_value(1)))//'/)'
1318	ENDIF
1319
1320	CASE DEFAULT
1321	cl_value="none"
1322
1323	END SELECT
1324
1325	WRITE(*,'((3x,a,a),(/6x,a,i2.2),(a,a),(a,a))')&
1326	& " attribute : ",TRIM(ADJUSTL(td_att%c_name)), &
1327	& " id : ",td_att%i_id, &
1328	& " type : ",TRIM(ADJUSTL(cl_type)), &
1329	& " value : ",TRIM(ADJUSTL(cl_value))
1330
1331	END SUBROUTINE att__print_unit
1332	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1333	SUBROUTINE att__clean_unit(td_att)
1334	!-------------------------------------------------------------------
1335	!> @brief
1336	!> This subroutine clean attribute strcuture.
1337	!
1338	!> @author J.Paul
1339	!> @date November, 2013 - Initial Version
1340	!> @date January, 2019
1341	!> - nullify array inside attribute structure
1342	!>
1343	!> @param[inout] td_att attribute strcuture
1344	!-------------------------------------------------------------------
1345
1346	IMPLICIT NONE
1347
1348	! Argument
1349	TYPE(TATT), INTENT(INOUT) :: td_att
1350
1351	! local variable
1352	TYPE(TATT) :: tl_att ! empty attribute structure
1353	!----------------------------------------------------------------
1354
1355	CALL logger_trace( &
1356	& " CLEAN: reset attribute "//TRIM(td_att%c_name) )
1357
1358	IF( ASSOCIATED(td_att%d_value) )THEN
1359	! clean value
1360	DEALLOCATE(td_att%d_value)
1361	NULLIFY(td_att%d_value)
1362	ENDIF
1363
1364	! replace by empty structure
1365	td_att=att_copy(tl_att)
1366
1367	END SUBROUTINE att__clean_unit
1368	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1369	SUBROUTINE att__clean_arr(td_att)
1370	!-------------------------------------------------------------------
1371	!> @brief
1372	!> This subroutine clean array of attribute strcuture.
1373	!
1374	!> @author J.Paul
1375	!> @date September, 2014 - Initial Version
1376	!
1377	!> @param[inout] td_att attribute strcuture
1378	!-------------------------------------------------------------------
1379
1380	IMPLICIT NONE
1381
1382	! Argument
1383	TYPE(TATT), DIMENSION(:), INTENT(INOUT) :: td_att
1384
1385	! local variable
1386	! loop indices
1387	INTEGER(i4) :: ji
1388	!----------------------------------------------------------------
1389
1390	DO ji=SIZE(td_att(:)),1,-1
1391	CALL att_clean(td_att(ji) )
1392	ENDDO
1393
1394	END SUBROUTINE att__clean_arr
1395	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1396	SUBROUTINE att_get_dummy(cd_dummy)
1397	!-------------------------------------------------------------------
1398	!> @brief This subroutine fill dummy attribute array
1399	!
1400	!> @author J.Paul
1401	!> @date September, 2015 - Initial Version
1402	!> @date Marsh, 2016
1403	!> - close file (bugfix)
1404	!> @date May, 2019
1405	!> - read number of dummy element
1406	!>
1407	!> @param[in] cd_dummy dummy configuration file
1408	!-------------------------------------------------------------------
1409
1410	IMPLICIT NONE
1411
1412	! Argument
1413	CHARACTER(LEN=*), INTENT(IN) :: cd_dummy
1414
1415	! local variable
1416	INTEGER(i4) :: il_fileid
1417	INTEGER(i4) :: il_status
1418
1419	LOGICAL :: ll_exist
1420
1421	! namelist
1422	INTEGER(i4) :: in_ndumvar
1423	INTEGER(i4) :: in_ndumdim
1424	INTEGER(i4) :: in_ndumatt
1425	CHARACTER(LEN=lc), DIMENSION(ip_maxdumcfg) :: cn_dumvar
1426	CHARACTER(LEN=lc), DIMENSION(ip_maxdumcfg) :: cn_dumdim
1427	CHARACTER(LEN=lc), DIMENSION(ip_maxdumcfg) :: cn_dumatt
1428	!----------------------------------------------------------------
1429	NAMELIST /namdum/ & !< dummy namelist
1430	& in_ndumvar,& !< number of dummy elt in variable array
1431	& in_ndumdim,& !< number of dummy elt in dimension array
1432	& in_ndumatt,& !< number of dummy elt in attribute array
1433	& cn_dumvar, & !< variable name
1434	& cn_dumdim, & !< dimension name
1435	& cn_dumatt !< attribute name
1436	!----------------------------------------------------------------
1437
1438	! init
1439	cm_dumatt(:)=''
1440
1441	! read namelist
1442	INQUIRE(FILE=TRIM(cd_dummy), EXIST=ll_exist)
1443	IF( ll_exist )THEN
1444
1445	il_fileid=fct_getunit()
1446
1447	OPEN( il_fileid, FILE=TRIM(cd_dummy), &
1448	& FORM='FORMATTED', &
1449	& ACCESS='SEQUENTIAL', &
1450	& STATUS='OLD', &
1451	& ACTION='READ', &
1452	& IOSTAT=il_status)
1453	CALL fct_err(il_status)
1454	IF( il_status /= 0 )THEN
1455	CALL logger_fatal("DIM GET DUMMY: opening "//TRIM(cd_dummy))
1456	ENDIF
1457
1458	READ( il_fileid, NML = namdum )
1459	im_ndumatt = in_ndumatt
1460	cm_dumatt(:)= cn_dumatt(:)
1461
1462	CLOSE( il_fileid )
1463
1464	IF( im_ndumatt > ip_maxdumcfg )THEN
1465	CALL logger_fatal("ATT GET dUMMY : too much dummy attributes &
1466	& ( >"//fct_str(ip_maxdumcfg)//" ). &
1467	& set ip_maxdumcfg to higher value.")
1468	ENDIF
1469
1470	ENDIF
1471
1472	END SUBROUTINE att_get_dummy
1473	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1474	FUNCTION att_is_dummy(td_att) &
1475	& RESULT (lf_dummy)
1476	!-------------------------------------------------------------------
1477	!> @brief This function check if attribute is defined as dummy attribute
1478	!> in configuraton file
1479	!>
1480	!> @author J.Paul
1481	!> @date September, 2015 - Initial Version
1482	!> @date, May, 2019
1483	!> - use number of dummy elt in do-loop
1484	!>
1485	!> @param[in] td_att attribute structure
1486	!> @return true if attribute is dummy attribute
1487	!-------------------------------------------------------------------
1488
1489	IMPLICIT NONE
1490
1491	! Argument
1492	TYPE(TATT), INTENT(IN) :: td_att
1493
1494	! function
1495	LOGICAL :: lf_dummy
1496
1497	! loop indices
1498	INTEGER(i4) :: ji
1499	!----------------------------------------------------------------
1500
1501	CALL logger_trace("ATT IS DUMMY : check if attribute is useless")
1502
1503	lf_dummy=.FALSE.
1504	DO ji=1,im_ndumatt
1505	IF( fct_lower(td_att%c_name) == fct_lower(cm_dumatt(ji)) )THEN
1506	lf_dummy=.TRUE.
1507	EXIT
1508	ENDIF
1509	ENDDO
1510
1511	CALL logger_trace("ATT IS DUMMY : check ok")
1512
1513	END FUNCTION att_is_dummy
1514	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1515	END MODULE att
1516

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

Download in other formats: