source: XMLIO_SERVER/trunk/src/XMLIO/mod_parse_xml.f90 @ 17

Last change on this file since 17 was 17, checked in by ymipsl, 16 years ago

Correction de bugs pour portage sur Mercure
File size: 18.3 KB
Line 
1MODULE parsing_xml
2  USE flib_dom
3  USE error_msg
4  USE string_function
5 
6CONTAINS
7
8  SUBROUTINE parsing_xml_file(name)
9  IMPLICIT NONE
10    CHARACTER(len=*), INTENT(IN) :: name
11    TYPE(fnode), POINTER :: myDoc
12
13    myDoc => parsefile(name)
14    CALL parsing_root(myDoc)
15
16    PRINT *, 'Le parsing est termine !!! '
17 
18  END SUBROUTINE parsing_xml_file
19 
20 
21  SUBROUTINE parsing_root(root)
22  IMPLICIT NONE
23    TYPE(fnode), POINTER :: root
24    TYPE(fnode), POINTER :: child_node
25    TYPE(fnodeList), POINTER :: child_list
26
27    INTEGER :: il
28    CHARACTER(len=100) :: node_name
29     
30     IF (hasChildNodes(root)) THEN
31      child_list => getChildnodes(root)
32
33      DO il=0,getLength(child_list)-1
34        child_node => item(child_list,il)
35        node_name=getNodename(child_node)
36         
37        SELECT CASE (TRIM(node_name)) 
38         
39           CASE ('simulation') 
40             CALL parsing_definition(child_node)
41
42           CASE DEFAULT
43             IF (is_bad_node(node_name)) THEN
44               WRITE(message,*) 'Unknown node <<',TRIM(node_name),'>> while parsing root'
45               CALL Warning("mod_parse_xml:parsing_root")
46             ENDIF
47         END SELECT
48       
49       ENDDO
50    ENDIF
51             
52  END SUBROUTINE parsing_root
53
54
55  SUBROUTINE parsing_definition(root)
56  USE mod_axis_definition
57  USE mod_grid_definition
58  USE mod_field_definition
59  USE mod_file_definition
60 
61  IMPLICIT NONE
62    TYPE(fnode), POINTER :: root
63    TYPE(fnode), POINTER :: child_node
64    TYPE(fnodeList), POINTER :: child_list
65
66    INTEGER :: il
67    CHARACTER(len=100) :: node_name
68
69    IF (hasChildNodes(root)) THEN
70      child_list => getChildnodes(root)
71      DO il=0,getLength(child_list)-1
72        child_node => item(child_list,il)
73        node_name=getNodename(child_node)
74         
75        SELECT CASE (TRIM(node_name)) 
76         
77           CASE ('axis_definition') 
78             CALL parsing_axis_group(child_node,axis_definition,root=.TRUE.)
79               
80           CASE ('grid_definition')
81             CALL parsing_grid_group(child_node,grid_definition,root=.TRUE.)
82               
83           CASE ('field_definition')
84             CALL parsing_field_group(child_node,field_definition,root=.TRUE.)
85               
86           CASE ('file_definition')
87             CALL parsing_file_group(child_node,file_definition,root=.TRUE.)
88               
89           CASE DEFAULT
90             IF (is_bad_node(node_name)) THEN
91               WRITE(message,*) 'Unknown node <<',TRIM(node_name),'>> while parsing definition'
92               CALL Warning("mod_parse_xml:parsing_definition")
93             ENDIF   
94         END SELECT
95       
96       ENDDO
97    ENDIF
98   
99  END SUBROUTINE parsing_definition
100 
101
102
103
104
105 
106  RECURSIVE SUBROUTINE parsing_axis_group(node,parent,root)
107  USE mod_axis_definition
108  USE mod_axis_group
109  USE mod_axis
110  IMPLICIT NONE 
111    TYPE(fnode), POINTER         :: node
112    TYPE(axis_group),POINTER     :: parent
113    LOGICAL,INTENT(IN),OPTIONAL :: root
114   
115    TYPE(axis_group),POINTER :: pt_axis_group
116    TYPE(fnode), POINTER     :: child_node
117    TYPE(fnodeList), POINTER :: child_list
118    TYPE(axis),POINTER       :: attribute
119    LOGICAL                  :: is_root
120    INTEGER :: il
121    CHARACTER(len=100) :: node_name
122    CHARACTER(len=100) :: value
123   
124    is_root=.FALSE.
125    IF (PRESENT(root)) is_root=root
126 
127    IF (is_root) THEN
128      pt_axis_group=>parent
129    ELSE 
130      IF (is_attribute_exist(node,"id")) THEN
131        value=getAttribute(node,"id")
132        CALL axis_group__get_new_group(parent,pt_axis_group,TRIM(value))
133      ELSE
134        CALL axis_group__get_new_group(parent,pt_axis_group)
135      ENDIF
136    ENDIF
137     
138    CALL axis_group__get_default_attrib(pt_axis_group,attribute)
139    CALL parsing_axis_attribute(node,attribute)
140   
141    IF (hasChildNodes(node)) THEN
142      child_list => getChildnodes(node)
143
144      DO il=0,getLength(child_list)-1
145        child_node => item(child_list,il)
146        node_name=getNodename(child_node)
147       
148        SELECT CASE (TRIM(node_name)) 
149       
150          CASE ('group') 
151            CALL parsing_axis_group(child_node,pt_axis_group)
152             
153          CASE ('axis')
154            CALL parsing_axis(child_node,pt_axis_group)
155
156          CASE DEFAULT
157            IF (is_bad_node(node_name)) THEN
158              WRITE(message,*) 'Unknown node <<',TRIM(node_name),'>> while parsing group_axis'
159              CALL Warning("mod_parse_xml:parsing_group_axis")
160            ENDIF
161        END SELECT
162      ENDDO
163    ENDIF
164
165  END SUBROUTINE parsing_axis_group
166
167  SUBROUTINE parsing_axis(node,parent)
168  USE mod_axis_group
169  USE mod_axis
170  IMPLICIT NONE 
171    TYPE(fnode), POINTER     :: node
172    TYPE(axis_group),POINTER :: parent
173   
174    TYPE(axis),POINTER :: pt_axis
175    TYPE(axis),POINTER       :: attribute
176    INTEGER :: il
177    CHARACTER(len=100) :: node_name
178    CHARACTER(len=100) :: value
179 
180     
181    IF (is_attribute_exist(node,"id")) THEN
182      value=getAttribute(node,"id")
183      CALL axis_group__get_new_axis(parent,pt_axis,TRIM(value))
184    ELSE
185      CALL axis_group__get_new_axis(parent,pt_axis)
186    ENDIF
187     
188    CALL parsing_axis_attribute(node,pt_axis)
189 
190  END SUBROUTINE parsing_axis
191
192 
193  SUBROUTINE parsing_axis_attribute(node,pt_axis)
194  USE mod_axis
195  IMPLICIT NONE
196    TYPE(fnode), POINTER     :: node
197    TYPE(axis),POINTER :: pt_axis
198
199    CHARACTER(len=100) :: value
200   
201    IF (is_attribute_exist(node,"name")) THEN
202      value =  getAttribute(node,"name")
203      CALL axis__set(pt_axis,name=TRIM(value))
204    ENDIF
205
206    IF (is_attribute_exist(node,"description")) THEN
207      value =  getAttribute(node,"description")
208      CALL axis__set(pt_axis,description=TRIM(value))
209    ENDIF
210       
211    IF (is_attribute_exist(node,"unit")) THEN
212      value =  getAttribute(node,"unit")
213      CALL axis__set(pt_axis,unit=TRIM(value))
214    ENDIF
215
216    IF (is_attribute_exist(node,"size")) THEN
217      value =  getAttribute(node,"size")
218      CALL axis__set(pt_axis,a_size=string_to_integer(value))
219    ENDIF
220   
221  END SUBROUTINE parsing_axis_attribute 
222
223
224
225
226
227
228
229
230  RECURSIVE SUBROUTINE parsing_grid_group(node,parent,root)
231  USE mod_grid_definition
232  USE mod_grid_group
233  USE mod_grid
234  IMPLICIT NONE 
235    TYPE(fnode), POINTER     :: node
236    TYPE(grid_group),POINTER :: parent
237    LOGICAL,INTENT(IN),OPTIONAL :: root
238
239    TYPE(grid_group),POINTER :: pt_grid_group
240    TYPE(fnode), POINTER     :: child_node
241    TYPE(fnodeList), POINTER :: child_list
242    TYPE(grid),POINTER       :: attribute
243    LOGICAL                  :: is_root
244    INTEGER :: il
245    CHARACTER(len=100) :: node_name
246    CHARACTER(len=100) :: value
247 
248    is_root=.FALSE.
249    IF (PRESENT(root)) is_root=root
250 
251    IF (is_root) THEN
252      pt_grid_group=>parent
253    ELSE 
254      IF (is_attribute_exist(node,"id")) THEN
255        value=getAttribute(node,"id")
256        CALL grid_group__get_new_group(parent,pt_grid_group,TRIM(value))
257      ELSE
258        CALL grid_group__get_new_group(parent,pt_grid_group)
259      ENDIF
260    ENDIF
261     
262    CALL grid_group__get_default_attrib(pt_grid_group,attribute)
263    CALL parsing_grid_attribute(node,attribute)
264   
265    IF (hasChildNodes(node)) THEN
266      child_list => getChildnodes(node)
267
268      DO il=0,getLength(child_list)-1
269        child_node => item(child_list,il)
270        node_name=getNodename(child_node)
271       
272        SELECT CASE (TRIM(node_name)) 
273       
274          CASE ('group') 
275            CALL parsing_grid_group(child_node,pt_grid_group)
276             
277          CASE ('grid')
278            CALL parsing_grid(child_node,pt_grid_group)
279
280          CASE DEFAULT
281            IF (is_bad_node(node_name)) THEN
282              WRITE(message,*) 'Unknown node <<',TRIM(node_name),'>> while parsing group_grid'
283              CALL Warning("mod_parse_xml:parsing_group_grid")
284            ENDIF
285        END SELECT
286      ENDDO
287    ENDIF
288
289  END SUBROUTINE parsing_grid_group
290
291  SUBROUTINE parsing_grid(node,parent)
292  USE mod_grid_group
293  USE mod_grid
294  IMPLICIT NONE 
295    TYPE(fnode), POINTER     :: node
296    TYPE(grid_group),POINTER :: parent
297   
298    TYPE(grid),POINTER :: pt_grid
299    TYPE(grid),POINTER       :: attribute
300    INTEGER :: il
301    CHARACTER(len=100) :: node_name
302    CHARACTER(len=100) :: value
303 
304     
305    IF (is_attribute_exist(node,"id")) THEN
306      value=getAttribute(node,"id")
307      CALL grid_group__get_new_grid(parent,pt_grid,TRIM(value))
308    ELSE
309      CALL grid_group__get_new_grid(parent,pt_grid)
310    ENDIF
311     
312    CALL parsing_grid_attribute(node,pt_grid)
313 
314  END SUBROUTINE parsing_grid
315
316 
317  SUBROUTINE parsing_grid_attribute(node,pt_grid)
318  USE mod_grid
319  IMPLICIT NONE
320    TYPE(fnode), POINTER     :: node
321    TYPE(grid),POINTER :: pt_grid
322
323    CHARACTER(len=100) :: value
324   
325    IF (is_attribute_exist(node,"name")) THEN
326      value =  getAttribute(node,"name")
327      CALL grid__set(pt_grid,name=TRIM(value))
328    ENDIF
329
330    IF (is_attribute_exist(node,"description")) THEN
331      value =  getAttribute(node,"description")
332      CALL grid__set(pt_grid,description=TRIM(value))
333    ENDIF
334       
335  END SUBROUTINE parsing_grid_attribute 
336
337
338
339
340
341
342
343  RECURSIVE SUBROUTINE parsing_field_group(node,parent,root)
344  USE mod_field_definition
345  USE mod_field_group
346  USE mod_field
347  IMPLICIT NONE 
348    TYPE(fnode), POINTER          :: node
349    TYPE(field_group),POINTER     :: parent
350    LOGICAL,INTENT(IN),OPTIONAL   :: root
351   
352    TYPE(field_group),POINTER :: pt_field_group
353    TYPE(fnode), POINTER     :: child_node
354    TYPE(fnodeList), POINTER :: child_list
355    TYPE(field),POINTER       :: attribute
356    INTEGER :: il
357    CHARACTER(len=100) :: node_name
358    CHARACTER(len=100) :: value
359    LOGICAL            :: is_root
360   
361    is_root=.FALSE.
362    IF (PRESENT(root)) is_root=root
363   
364    IF (is_root) THEN
365      pt_field_group=>parent
366    ELSE 
367      IF (is_attribute_exist(node,"id")) THEN
368        value=getAttribute(node,"id")
369        CALL field_group__get_new_group(parent,pt_field_group,TRIM(value))
370      ELSE
371        CALL field_group__get_new_group(parent,pt_field_group)
372      ENDIF
373    ENDIF
374     
375    CALL field_group__get_default_attrib(pt_field_group,attribute)
376    CALL parsing_field_attribute(node,attribute)
377   
378    IF (hasChildNodes(node)) THEN
379      child_list => getChildnodes(node)
380
381      DO il=0,getLength(child_list)-1
382        child_node => item(child_list,il)
383        node_name=getNodename(child_node)
384       
385        SELECT CASE (TRIM(node_name)) 
386       
387          CASE ('group') 
388            CALL parsing_field_group(child_node,pt_field_group)
389             
390          CASE ('field')
391            CALL parsing_field(child_node,pt_field_group)
392
393          CASE DEFAULT
394            IF (is_bad_node(node_name)) THEN
395              WRITE(message,*) 'Unknown node <<',TRIM(node_name),'>> while parsing group_field'
396              CALL Warning("mod_parse_xml:parsing_group_field")
397            ENDIF
398        END SELECT
399      ENDDO
400    ENDIF
401
402  END SUBROUTINE parsing_field_group
403
404  SUBROUTINE parsing_field(node,parent)
405  USE mod_field_group
406  USE mod_field
407  IMPLICIT NONE 
408    TYPE(fnode), POINTER     :: node
409    TYPE(field_group),POINTER :: parent
410   
411    TYPE(field),POINTER :: pt_field
412    TYPE(field),POINTER       :: attribute
413    INTEGER :: il
414    CHARACTER(len=100) :: node_name
415    CHARACTER(len=100) :: value
416 
417     
418    IF (is_attribute_exist(node,"id")) THEN
419      value=getAttribute(node,"id")
420      CALL field_group__get_new_field(parent,pt_field,TRIM(value))
421    ELSE
422      CALL field_group__get_new_field(parent,pt_field)
423    ENDIF
424     
425    CALL parsing_field_attribute(node,pt_field)
426 
427  END SUBROUTINE parsing_field
428
429 
430  SUBROUTINE parsing_field_attribute(node,pt_field)
431  USE mod_field
432  IMPLICIT NONE
433    TYPE(fnode), POINTER     :: node
434    TYPE(field),POINTER :: pt_field
435
436    CHARACTER(len=100) :: value
437   
438    IF (is_attribute_exist(node,"name")) THEN
439      value =  getAttribute(node,"name")
440      CALL field__set(pt_field,name=TRIM(value))
441    ENDIF
442
443    IF (is_attribute_exist(node,"description")) THEN
444      value =  getAttribute(node,"description")
445      CALL field__set(pt_field,description=TRIM(value))
446    ENDIF
447       
448    IF (is_attribute_exist(node,"unit")) THEN
449      value =  getAttribute(node,"unit")
450      CALL field__set(pt_field,unit=TRIM(value))
451    ENDIF
452
453    IF (is_attribute_exist(node,"operation")) THEN
454      value =  getAttribute(node,"operation")
455      CALL field__set(pt_field,operation=TRIM(value))
456    ENDIF
457
458    IF (is_attribute_exist(node,"freq_op")) THEN
459      value =  getAttribute(node,"freq_op")
460      CALL field__set(pt_field,freq_op=string_to_integer(value))
461    ENDIF
462   
463    IF (is_attribute_exist(node,"axis_ref")) THEN
464      value =  getAttribute(node,"axis_ref")
465      CALL field__set(pt_field,axis_ref=TRIM(value))
466    ENDIF
467
468    IF (is_attribute_exist(node,"grid_ref")) THEN
469      value =  getAttribute(node,"grid_ref")
470      CALL field__set(pt_field,grid_ref=TRIM(value))
471    ENDIF
472
473    IF (is_attribute_exist(node,"level")) THEN
474      value =  getAttribute(node,"level")
475      CALL field__set(pt_field,level=string_to_integer(value))
476    ENDIF
477   
478    IF (is_attribute_exist(node,"prec")) THEN
479      value =  getAttribute(node,"prec")
480      CALL field__set(pt_field,prec=string_to_integer(value))
481    ENDIF
482
483    IF (is_attribute_exist(node,"ref")) THEN
484      value =  getAttribute(node,"ref")
485      CALL field__set(pt_field,ref=TRIM(value))
486    ENDIF
487
488    IF (is_attribute_exist(node,"enabled")) THEN
489      value =  getAttribute(node,"enabled")
490      CALL field__set(pt_field,enabled=string_to_logical(value))
491    ENDIF
492 
493
494  END SUBROUTINE parsing_field_attribute 
495 
496 
497 
498
499
500  RECURSIVE SUBROUTINE parsing_file_group(node,parent,root)
501  USE mod_file_definition
502  USE mod_file_group
503  USE mod_file
504  IMPLICIT NONE 
505    TYPE(fnode), POINTER          :: node
506    TYPE(file_group),POINTER      :: parent
507    LOGICAL,INTENT(IN),OPTIONAL   :: root
508
509    TYPE(file_group),POINTER :: pt_file_group
510    TYPE(fnode), POINTER     :: child_node
511    TYPE(fnodeList), POINTER :: child_list
512    TYPE(file),POINTER       :: attribute
513    LOGICAL                  :: is_root
514    INTEGER :: il
515    CHARACTER(len=100) :: node_name
516    CHARACTER(len=100) :: value
517   
518    is_root=.FALSE.
519    IF (PRESENT(root)) is_root=root
520 
521    IF (is_root) THEN
522      pt_file_group=>parent
523    ELSE 
524      IF (is_attribute_exist(node,"id")) THEN
525        value=getAttribute(node,"id")
526        CALL file_group__get_new_group(parent,pt_file_group,TRIM(value))
527      ELSE
528        CALL file_group__get_new_group(parent,pt_file_group)
529      ENDIF
530    ENDIF
531     
532    CALL file_group__get_default_attrib(pt_file_group,attribute)
533    CALL parsing_file_attribute(node,attribute)
534   
535    IF (hasChildNodes(node)) THEN
536      child_list => getChildnodes(node)
537
538      DO il=0,getLength(child_list)-1
539        child_node => item(child_list,il)
540        node_name=getNodename(child_node)
541       
542        SELECT CASE (TRIM(node_name)) 
543       
544          CASE ('group') 
545            CALL parsing_file_group(child_node,pt_file_group)
546             
547          CASE ('file')
548            CALL parsing_file(child_node,pt_file_group)
549
550          CASE DEFAULT
551            IF (is_bad_node(node_name)) THEN
552              WRITE(message,*) 'Unknown node <<',TRIM(node_name),'>> while parsing group_file'
553              CALL Warning("mod_parse_xml:parsing_group_file")
554            ENDIF
555        END SELECT
556      ENDDO
557    ENDIF
558
559  END SUBROUTINE parsing_file_group
560
561  SUBROUTINE parsing_file(node,parent)
562  USE mod_file_group
563  USE mod_file
564  IMPLICIT NONE 
565    TYPE(fnode), POINTER     :: node
566    TYPE(file_group),POINTER :: parent
567   
568    TYPE(file),POINTER :: pt_file
569    TYPE(file),POINTER       :: attribute
570    TYPE(fnode), POINTER     :: child_node
571    TYPE(fnodeList), POINTER :: child_list
572    INTEGER :: il
573    CHARACTER(len=100) :: node_name
574    CHARACTER(len=100) :: value
575 
576     
577    IF (is_attribute_exist(node,"id")) THEN
578      value=getAttribute(node,"id")
579      CALL file_group__get_new_file(parent,pt_file,TRIM(value))
580    ELSE
581      CALL file_group__get_new_file(parent,pt_file)
582    ENDIF
583     
584    CALL parsing_file_attribute(node,pt_file)
585 
586    IF (hasChildNodes(node)) THEN
587      child_list => getChildnodes(node)
588
589      DO il=0,getLength(child_list)-1
590        child_node => item(child_list,il)
591        node_name=getNodename(child_node)
592       
593        SELECT CASE (TRIM(node_name)) 
594       
595          CASE ('group') 
596            CALL parsing_field_group(child_node,pt_file%field_list)
597             
598          CASE ('field')
599            CALL parsing_field(child_node,pt_file%field_list)
600
601          CASE DEFAULT
602            IF (is_bad_node(node_name)) THEN
603              WRITE(message,*) 'Unknown node <<',TRIM(node_name),'>> while parsing group_file'
604              CALL Warning("mod_parse_xml:parsing_group_file")
605            ENDIF
606        END SELECT
607      ENDDO
608    ENDIF
609  END SUBROUTINE parsing_file
610
611 
612  SUBROUTINE parsing_file_attribute(node,pt_file)
613  USE mod_file
614  IMPLICIT NONE
615    TYPE(fnode), POINTER     :: node
616    TYPE(file),POINTER :: pt_file
617
618    CHARACTER(len=100) :: value
619   
620    IF (is_attribute_exist(node,"name")) THEN
621      value =  getAttribute(node,"name")
622      CALL file__set(pt_file,name=TRIM(value))
623    ENDIF
624
625    IF (is_attribute_exist(node,"description")) THEN
626      value =  getAttribute(node,"description")
627      CALL file__set(pt_file,description=TRIM(value))
628    ENDIF
629       
630    IF (is_attribute_exist(node,"output_freq")) THEN
631      value =  getAttribute(node,"output_freq")
632      CALL file__set(pt_file,output_freq=string_to_integer(value))
633    ENDIF
634   
635    IF (is_attribute_exist(node,"output_level")) THEN
636      value =  getAttribute(node,"output_level")
637      CALL file__set(pt_file,output_level=string_to_integer(value))
638    ENDIF
639
640    IF (is_attribute_exist(node,"enabled")) THEN
641      value =  getAttribute(node,"enabled")
642      CALL file__set(pt_file,enabled=string_to_logical(value))
643    ENDIF
644
645  END SUBROUTINE parsing_file_attribute
646 
647
648   
649 
650  FUNCTION is_attribute_exist(node, name)
651
652    LOGICAL :: is_attribute_exist
653    TYPE(fnode), POINTER :: node
654    CHARACTER(len=*) :: name
655    CHARACTER(len=100) :: value
656
657    value=""
658   
659    is_attribute_exist= .false.
660    value=getAttribute(node, TRIM(name))
661    IF (value .NE. "") is_attribute_exist= .true.
662
663  END FUNCTION is_attribute_exist
664
665  FUNCTION is_bad_node(node_name)
666  IMPLICIT NONE
667    CHARACTER(len=*),INTENT(IN) :: node_name
668    LOGICAL                     :: is_bad_node
669   
670    IF (TRIM(node_name)=='#text' .OR. TRIM(node_name)=='#comment') THEN
671      is_bad_node=.FALSE.
672    ELSE
673      is_bad_node=.TRUE.
674    ENDIF
675     
676  END FUNCTION is_bad_node
677 
678END MODULE parsing_xml
Note: See TracBrowser for help on using the repository browser.