Context Navigation

source: XMLIO_SERVER/trunk/src/XMLIO/mod_field.f90 @ 8

Last change on this file since 8 was 8, checked in by ymipsl, 15 years ago
Importation des sources du serveur XMLIO
File size: 14.9 KB

Line
1	MODULE mod_field
2
3	USE mod_xmlio_parameters
4	USE mod_sorted_list
5	USE mod_axis
6	USE mod_grid
7
8	IMPLICIT NONE
9
10	TYPE, PUBLIC :: field
11	CHARACTER(len=str_len) :: id
12	LOGICAL :: has_id
13	CHARACTER(len=str_len) :: name
14	LOGICAL :: has_name
15	CHARACTER(len=str_len) :: description
16	LOGICAL :: has_description
17	CHARACTER(len=str_len) :: unit
18	LOGICAL :: has_unit
19	CHARACTER(len=str_len) :: operation
20	LOGICAL :: has_operation
21	INTEGER :: freq_op
22	LOGICAL :: has_freq_op
23	CHARACTER(len=str_len) :: axis_ref
24	LOGICAL :: has_axis_ref
25	CHARACTER(len=str_len) :: grid_ref
26	LOGICAL :: has_grid_ref
27	INTEGER :: level
28	LOGICAL :: has_level
29	INTEGER :: prec
30	LOGICAL :: has_prec
31	CHARACTER(len=str_len) :: field_ref
32	LOGICAL :: has_field_ref
33	TYPE(field),POINTER :: field_base
34	LOGICAL :: has_field_base
35	LOGICAL :: enabled
36	LOGICAL :: has_enabled
37	LOGICAL :: solved_field_ref
38	TYPE(axis), POINTER :: axis
39	LOGICAL :: has_axis
40	TYPE(grid),POINTER :: grid
41	LOGICAL :: has_grid
42	INTEGER :: internal(internal_field)
43
44
45	END TYPE field
46
47	INCLUDE 'vector_field_def.inc'
48
49	TYPE(vector_field),POINTER :: field_Ids
50	TYPE(sorted_list),POINTER,PRIVATE :: Ids
51
52	CONTAINS
53	INCLUDE 'vector_field_contains.inc'
54
55	SUBROUTINE field__init
56	IMPLICIT NONE
57
58	ALLOCATE(field_Ids)
59	ALLOCATE(Ids)
60
61	CALL vector_field__new(field_Ids)
62	CALL sorted_list__new(Ids)
63
64	END SUBROUTINE field__init
65
66	SUBROUTINE field__get(Id,Pt_field)
67	USE string_function
68	IMPLICIT NONE
69	CHARACTER(LEN=*),INTENT(IN) :: Id
70	TYPE(field),POINTER :: Pt_field
71
72	INTEGER :: Pos
73	LOGICAL :: success
74
75	CALL sorted_list__find(Ids,hash(Id),Pos,success)
76	IF (success) THEN
77	Pt_field=>field_ids%at(Pos)%Pt
78	ELSE
79	Pt_field=>NULL()
80	ENDIF
81
82	END SUBROUTINE field__get
83
84
85	SUBROUTINE field__new(pt_field,Id)
86	USE string_function
87	IMPLICIT NONE
88	TYPE(field), POINTER :: pt_field
89	CHARACTER(LEN=*),OPTIONAL :: Id
90
91	INTEGER :: Pos
92
93	Pt_field%has_id=.FALSE.
94	pt_field%has_name = .FALSE.
95	pt_field%has_description = .FALSE.
96	pt_field%has_unit = .FALSE.
97	pt_field%has_operation = .FALSE.
98	pt_field%has_freq_op = .FALSE.
99	pt_field%has_axis_ref = .FALSE.
100	pt_field%has_grid_ref = .FALSE.
101	pt_field%has_prec = .FALSE.
102	pt_field%has_level = .FALSE.
103	pt_field%has_field_ref = .FALSE.
104	pt_field%has_field_base = .FALSE.
105	pt_field%has_enabled = .FALSE.
106	Pt_field%solved_field_ref=.FALSE.
107	Pt_field%has_axis=.FALSE.
108	Pt_field%has_grid=.FALSE.
109
110	IF (PRESENT(Id)) THEN
111	Pt_field%id=TRIM(ADJUSTL(Id))
112	Pt_field%has_id=.TRUE.
113	CALL vector_field__set_new(field_Ids,Pt_field,Pos)
114	CALL sorted_list__Add(Ids,hash(id),Pos)
115	ENDIF
116
117	END SUBROUTINE field__new
118
119
120	SUBROUTINE field__set(p_field, name, ref, description, unit, operation, freq_op, axis_ref, grid_ref, prec, level, enabled)
121
122	TYPE(field), pointer :: p_field
123	CHARACTER(len=*), OPTIONAL :: name
124	CHARACTER(len=*), OPTIONAL :: ref
125	CHARACTER(len=*), OPTIONAL :: description
126	CHARACTER(len=*), OPTIONAL :: unit
127	CHARACTER(len=*), OPTIONAL :: operation
128	INTEGER, OPTIONAL :: freq_op
129	CHARACTER(len=*),OPTIONAL :: axis_ref
130	CHARACTER(len=*),OPTIONAL :: grid_ref
131	INTEGER, OPTIONAL :: prec
132	INTEGER, OPTIONAL :: level
133	LOGICAL, OPTIONAL :: enabled
134
135	IF (PRESENT(name)) THEN
136	p_field%name=TRIM(ADJUSTL(name))
137	p_field%has_name = .TRUE.
138	ENDIF
139	IF (PRESENT(ref)) THEN
140	p_field%field_ref=TRIM(ADJUSTL(ref))
141	p_field%has_field_ref = .TRUE.
142	ENDIF
143	IF (PRESENT(description)) THEN
144	p_field%description=TRIM(ADJUSTL(description))
145	p_field%has_description = .TRUE.
146	ENDIF
147
148	IF (PRESENT(unit)) then
149	p_field%unit=TRIM(ADJUSTL(unit))
150	p_field%has_unit = .TRUE.
151	ENDIF
152	IF (PRESENT(operation)) THEN
153	p_field%operation=TRIM(ADJUSTL(operation))
154	p_field%has_operation = .TRUE.
155	ENDIF
156	IF (PRESENT(freq_op)) THEN
157	p_field%freq_op=freq_op
158	p_field%has_freq_op = .TRUE.
159	ENDIF
160	IF (PRESENT(axis_ref)) THEN
161	p_field%axis_ref=TRIM(ADJUSTL(axis_ref))
162	p_field%has_axis_ref = .TRUE.
163	ENDIF
164	IF (PRESENT(grid_ref)) THEN
165	p_field%grid_ref=TRIM(ADJUSTL(grid_ref))
166	p_field%has_grid_ref = .TRUE.
167	ENDIF
168	IF (PRESENT(prec)) then
169	p_field%prec=prec
170	p_field%has_prec = .TRUE.
171	ENDIF
172
173	IF (PRESENT(level)) then
174	p_field%level=level
175	p_field%has_level = .TRUE.
176	ENDIF
177
178	IF (PRESENT(enabled)) then
179	p_field%enabled=enabled
180	p_field%has_enabled = .TRUE.
181	ENDIF
182
183	END SUBROUTINE field__set
184
185
186	SUBROUTINE field__print(pt_field)
187
188	TYPE(field), POINTER :: pt_field
189
190	PRINT *,"--- FIELD ---"
191
192	IF (pt_field%has_id) THEN
193	PRINT *, 'id : ',TRIM(pt_field%id)
194	ELSE
195	PRINT *, 'id undefined '
196	ENDIF
197
198	IF (pt_field%has_name) THEN
199	PRINT *, 'name : ',TRIM(pt_field%name)
200	ELSE
201	PRINT *, 'name undefined '
202	ENDIF
203	IF (pt_field%has_description) THEN
204	PRINT *, 'description : ',TRIM(pt_field%description)
205	ELSE
206	PRINT *, 'description undefined '
207	ENDIF
208	IF (pt_field%has_unit) THEN
209	PRINT *, 'unit : ',TRIM(pt_field%unit)
210	ELSE
211	PRINT *, 'unit undefined '
212	ENDIF
213	IF (pt_field%has_operation) THEN
214	PRINT *, 'operation ',TRIM(pt_field%operation)
215	ELSE
216	PRINT *, 'operation undefined '
217	ENDIF
218	IF (pt_field%has_freq_op) THEN
219	PRINT *, 'freq_op ',pt_field%freq_op
220	ELSE
221	PRINT *, 'freq_op undefined '
222	ENDIF
223
224	IF (pt_field%has_axis_ref) THEN
225	PRINT *, 'axis_ref : ',TRIM(pt_field%axis_ref)
226	ELSE
227	PRINT *, 'axis_ref undefined '
228	ENDIF
229
230	IF (pt_field%has_grid_ref) THEN
231	PRINT *, 'grid_ref : ',TRIM(pt_field%grid_ref)
232	ELSE
233	PRINT *, 'grid_ref undefined '
234	ENDIF
235
236	IF (pt_field%has_field_ref) THEN
237	PRINT *, 'field_ref : ',TRIM(pt_field%field_ref)
238	ELSE
239	PRINT *, 'field_ref undefined '
240	ENDIF
241
242	! call vert_axis__print(pt_field%p_vert_axis)
243	!
244	! IF (pt_field%is_vert_axis_ref_def) THEN
245	! PRINT *, 'pt_field%vert_axis_ref ',TRIM(pt_field%vert_axis_ref)
246	! ELSE
247	! PRINT *, 'pt_field%vert_axis_ref undefined '
248	! ENDIF
249	IF (pt_field%has_prec) THEN
250	PRINT *, 'prec ',pt_field%prec
251	ELSE
252	PRINT *, 'prec undefined '
253	ENDIF
254	IF (pt_field%has_level) then
255	PRINT *, 'level ',pt_field%level
256	ELSE
257	PRINT *, 'level undefined '
258	ENDIF
259	IF (pt_field%has_field_base) THEN
260	PRINT *, 'field_base :',TRIM(Pt_field%field_base%id)
261	ELSE
262	PRINT *, 'field_base indefini'
263	ENDIF
264
265	IF (pt_field%has_enabled) THEN
266	PRINT *, 'enabled : ',pt_field%enabled
267	ELSE
268	PRINT *, 'enabled indefini'
269	ENDIF
270
271	PRINT *,"------------"
272
273	END SUBROUTINE field__print
274
275	! SUBROUTINE field__resolve_ref_vert_axis(p_field)
276	!
277	! TYPE(field), POINTER :: p_field
278	! CHARACTER(len=str_len) :: name
279	!
280	! IF (p_field%is_vert_axis_ref_def) THEN
281	! name=p_field%vert_axis_ref
282	! IF (vert_axis_def__is_exist(name)) THEN
283	! CALL vert_axis_def__get(name,p_field%p_vert_axis)
284	! p_field%is_vert_axis_def = .TRUE.
285	! ENDIF
286	! ENDIF
287	!
288	! END SUBROUTINE field__resolve_ref_vert_axis
289
290	SUBROUTINE field__apply_default(pt_field_default, pt_field_in, pt_field_out)
291
292	TYPE(field), POINTER :: pt_field_default, pt_field_in, pt_field_out
293
294	IF (pt_field_in%has_name) THEN
295	pt_field_out%name=pt_field_in%name
296	pt_field_out%has_name=.TRUE.
297	ELSE IF ( pt_field_default%has_name) THEN
298	pt_field_out%name=pt_field_default%name
299	pt_field_out%has_name=.TRUE.
300	ELSE
301	pt_field_out%has_name=.FALSE.
302	ENDIF
303
304	IF (pt_field_in%has_description) THEN
305	pt_field_out%description=pt_field_in%description
306	pt_field_out%has_description=.TRUE.
307	ELSE IF ( pt_field_default%has_description ) THEN
308	pt_field_out%description=pt_field_default%description
309	pt_field_out%has_description=.TRUE.
310	ELSE
311	pt_field_out%has_description=.FALSE.
312	ENDIF
313
314	IF (pt_field_in%has_unit) THEN
315	pt_field_out%unit=pt_field_in%unit
316	pt_field_out%has_unit=.TRUE.
317	ELSE IF ( pt_field_default%has_unit ) THEN
318	pt_field_out%unit=pt_field_default%unit
319	pt_field_out%has_unit=.TRUE.
320	ELSE
321	pt_field_out%has_unit=.FALSE.
322	ENDIF
323
324	IF (pt_field_in%has_operation) THEN
325	pt_field_out%operation=pt_field_in%operation
326	pt_field_out%has_operation=.TRUE.
327	ELSE IF ( pt_field_default%has_operation ) THEN
328	pt_field_out%operation=pt_field_default%operation
329	pt_field_out%has_operation=.TRUE.
330	ELSE
331	pt_field_out%has_operation=.FALSE.
332	ENDIF
333
334	IF (pt_field_in%has_freq_op) THEN
335	pt_field_out%freq_op=pt_field_in%freq_op
336	pt_field_out%has_freq_op=.TRUE.
337	ELSE IF ( pt_field_default%has_freq_op ) THEN
338	pt_field_out%freq_op=pt_field_default%freq_op
339	pt_field_out%has_freq_op=.TRUE.
340	ELSE
341	pt_field_out%has_freq_op=.FALSE.
342	ENDIF
343
344	! IF (pt_field_in%has_axis) THEN
345	! pt_field_out%p_axis => pt_field_in%p_axis
346	! pt_field_out%has_axis=.TRUE.
347	! ELSE IF ( pt_field_default%has_axis ) THEN
348	! pt_field_out%p_axis => pt_field_default%p_axis
349	! pt_field_out%has_axis=.TRUE.
350	! ELSE
351	! pt_field_out%has_axis=.FALSE.
352	! ENDIF
353
354	IF (pt_field_in%has_axis_ref) THEN
355	pt_field_out%axis_ref=pt_field_in%axis_ref
356	pt_field_out%has_axis_ref=.TRUE.
357	ELSE IF ( pt_field_default%has_axis_ref ) THEN
358	pt_field_out%axis_ref=pt_field_default%axis_ref
359	pt_field_out%has_axis_ref=.TRUE.
360	ELSE
361	pt_field_out%has_axis_ref=.FALSE.
362	ENDIF
363
364	IF (pt_field_in%has_grid_ref) THEN
365	pt_field_out%grid_ref=pt_field_in%grid_ref
366	pt_field_out%has_grid_ref=.TRUE.
367	ELSE IF ( pt_field_default%has_grid_ref ) THEN
368	pt_field_out%grid_ref=pt_field_default%grid_ref
369	pt_field_out%has_grid_ref=.TRUE.
370	ELSE
371	pt_field_out%has_grid_ref=.FALSE.
372	ENDIF
373
374	IF (pt_field_in%has_prec) THEN
375	pt_field_out%prec=pt_field_in%prec
376	pt_field_out%has_prec=.TRUE.
377	ELSE IF ( pt_field_default%has_prec ) THEN
378	pt_field_out%prec=pt_field_default%prec
379	pt_field_out%has_prec=.TRUE.
380	ELSE
381	pt_field_out%has_prec=.FALSE.
382	ENDIF
383
384	IF (pt_field_in%has_level) THEN
385	pt_field_out%level=pt_field_in%level
386	pt_field_out%has_level=.TRUE.
387	ELSE IF ( pt_field_default%has_level ) THEN
388	pt_field_out%level=pt_field_default%level
389	pt_field_out%has_level=.TRUE.
390	ELSE
391	pt_field_out%has_level=.FALSE.
392	ENDIF
393
394	IF (pt_field_in%has_enabled) THEN
395	pt_field_out%enabled=pt_field_in%enabled
396	pt_field_out%has_enabled=.TRUE.
397	ELSE IF ( pt_field_default%has_enabled ) THEN
398	pt_field_out%enabled=pt_field_default%enabled
399	pt_field_out%has_enabled=.TRUE.
400	ELSE
401	pt_field_out%has_enabled=.FALSE.
402	ENDIF
403
404	END SUBROUTINE field__apply_default
405
406	! FUNCTION field__is_vert_axis_attached(p_field, vert_axis_name)
407	!
408	! LOGICAL :: field__is_vert_axis_attached
409	! TYPE(field), POINTER :: p_field
410	! CHARACTER(len=*), INTENT(IN) :: vert_axis_name
411	!
412	! field__is_vert_axis_attached = .false.
413	! IF (p_field%is_vert_axis_def) THEN
414	! IF (vert_axis_name == p_field%p_vert_axis%name) field__is_vert_axis_attached = .TRUE.
415	! ENDIF
416	!
417	! END FUNCTION field__is_vert_axis_attached
418
419	RECURSIVE SUBROUTINE field__solve_field_ref(pt_field)
420	USE error_msg
421	IMPLICIT NONE
422	TYPE(field), POINTER :: pt_field
423
424	TYPE(field), POINTER :: field_ref
425
426	IF (.NOT. pt_field%solved_field_ref) THEN
427
428	IF (pt_field%has_field_ref) THEN
429
430	CALL field__get(pt_field%field_ref,field_ref)
431
432	IF (.NOT. ASSOCIATED(field_ref)) THEN
433	WRITE (message,*) "The field : id = ",pt_field%id," name = ",Pt_field%name, &
434	" has a unknown reference to field : id =",pt_field%field_ref
435	CALL error("field__solve_field_ref")
436	ENDIF
437
438	CALL field__get_field_base(field_ref,pt_field%field_base)
439	Pt_field%has_field_base=.TRUE.
440
441	CALL field__apply_default(field_ref,pt_field,pt_field)
442
443
444	ELSE
445
446	IF (pt_field%has_id) THEN
447	pt_field%field_base=>pt_field
448	ENDIF
449
450	ENDIF
451
452	IF (.NOT. pt_field%has_name) THEN
453	IF (pt_field%has_id) THEN
454	pt_field%name=pt_field%id
455	pt_field%has_name=.TRUE.
456	ENDIF
457	ENDIF
458
459	Pt_field%solved_field_ref=.TRUE.
460
461	ENDIF
462
463	END SUBROUTINE field__solve_field_ref
464
465
466	RECURSIVE SUBROUTINE field__get_field_base(pt_field,pt_field_base)
467	IMPLICIT NONE
468	TYPE(field), POINTER :: pt_field
469	TYPE(field), POINTER :: pt_field_base
470
471
472	IF (.NOT. Pt_field%solved_field_ref) THEN
473	CALL field__solve_field_ref(Pt_field)
474	ENDIF
475
476	IF (pt_field%has_field_base) THEN
477	pt_field_base=>pt_field%field_base
478	ELSE
479	pt_field_base=>pt_field
480	ENDIF
481
482	END SUBROUTINE field__get_field_base
483
484	SUBROUTINE field__solve_axis_ref(pt_field)
485	USE error_msg
486	IMPLICIT NONE
487	TYPE(field), POINTER :: pt_field
488
489	IF (pt_field%has_axis_ref) THEN
490	CALL axis__get(pt_field%axis_ref,pt_field%axis)
491	IF (ASSOCIATED(pt_field%axis)) THEN
492	pt_field%has_axis=.TRUE.
493	ELSE
494	WRITE (message,*) "The field : id = ",pt_field%id," name = ",Pt_field%name, &
495	" has a unknown reference to axis : id =",pt_field%axis_ref
496	CALL error("mod_field::field__solve_axis_ref")
497	ENDIF
498	ENDIF
499
500	END SUBROUTINE field__solve_axis_ref
501
502	SUBROUTINE field__solve_grid_ref(pt_field)
503	USE error_msg
504	IMPLICIT NONE
505	TYPE(field), POINTER :: pt_field
506
507	IF (pt_field%has_grid_ref) THEN
508	CALL grid__get(pt_field%grid_ref,pt_field%grid)
509	IF (ASSOCIATED(pt_field%grid)) THEN
510	pt_field%has_grid=.TRUE.
511	ELSE
512	WRITE (message,*) "The field : id = ",pt_field%id," name = ",Pt_field%name, &
513	" has a unknown reference to grid : id =",pt_field%grid_ref
514	CALL error("mod_field::field__solve_grid_ref")
515	ENDIF
516	ENDIF
517
518	END SUBROUTINE field__solve_grid_ref
519
520
521
522	END MODULE mod_field

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

Download in other formats: