source: XMLIO_SERVER/trunk/src/XMLIO/mod_file_group.f90 @ 42

Last change on this file since 42 was 42, checked in by ymipsl, 13 years ago

Correction bug sur les ids des file_group
+ possibilité de fixer les attributs des groupes à partir de l'ioserver

File size: 6.7 KB
Line 
1MODULE mod_file_group
2  USE mod_file
3  USE mod_xmlio_parameters
4
5  IMPLICIT NONE
6
7  TYPE file_group
8    CHARACTER(LEN=str_len)                    :: id
9    LOGICAL                                   :: has_id
10    TYPE(vector_file_group), POINTER          :: groups
11    TYPE(vector_file),POINTER                 :: files     
12    TYPE(file), POINTER                       :: default_attribut
13  END TYPE file_group
14
15  INCLUDE "vector_file_group_def.inc" 
16
17  TYPE(vector_file_group),POINTER,SAVE       :: file_group_Ids
18  TYPE(sorted_list),POINTER,PRIVATE,SAVE     :: Ids 
19
20  INTERFACE file_group__set_attribut
21    MODULE PROCEDURE file_group__set_attribut_id,file_group__set_attribut_pt
22  END INTERFACE
23
24CONTAINS
25
26  INCLUDE "vector_file_group_contains.inc"
27
28  SUBROUTINE file_group__swap_context(saved_file_group_ids,saved_ids)
29  IMPLICIT NONE
30    TYPE(vector_file_group),POINTER      :: saved_file_group_Ids
31    TYPE(sorted_list),POINTER            :: saved_Ids
32   
33    file_group_ids=>saved_file_group_ids
34    ids=>saved_ids 
35 
36  END SUBROUTINE file_group__swap_context
37
38  SUBROUTINE file_group__init
39  IMPLICIT NONE
40   
41    CALL vector_file_group__new(file_group_Ids)
42    CALL sorted_list__new(Ids)
43   
44  END SUBROUTINE file_group__init
45
46  SUBROUTINE file_group__get(Id,Pt_fg)
47  USE string_function
48  IMPLICIT NONE
49    CHARACTER(LEN=*),INTENT(IN)     :: Id
50    TYPE(file_group),POINTER        :: Pt_fg
51
52    INTEGER                         :: Pos
53    LOGICAL                         :: success
54   
55    CALL sorted_list__find(Ids,hash(Id),Pos,success)
56    IF (success) THEN
57      Pt_fg=>file_group_ids%at(Pos)%Pt
58    ELSE
59      Pt_fg=>NULL()
60    ENDIF
61   
62  END SUBROUTINE file_group__get
63
64  SUBROUTINE file_group__set_attribut_id(id,attrib,Ok)
65  USE mod_attribut
66  USE error_msg
67  IMPLICIT NONE
68    CHARACTER(LEN=*),INTENT(IN) :: id
69    TYPE(attribut),INTENT(IN) :: attrib
70    LOGICAL,OPTIONAL,INTENT(out)  :: Ok
71   
72    TYPE(file_group),POINTER             :: Pt_fg
73    INTEGER                         :: Pos
74    LOGICAL                         :: success
75   
76    CALL sorted_list__find(Ids,hash(Id),Pos,success)
77    IF (success) THEN
78      Pt_fg=>file_group_ids%at(Pos)%Pt
79      CALL file_group__set_attribut(Pt_fg,attrib)
80      IF (PRESENT(OK)) ok=.TRUE.
81    ELSE
82      IF (.NOT.PRESENT(OK)) THEN
83        WRITE(message,*) 'file group id :',id,' is undefined'
84        CALL error('mod_file_group::file_group__set_attribut')
85      ELSE
86        OK=.FALSE.
87      ENDIF
88    ENDIF
89   
90  END SUBROUTINE file_group__set_attribut_id
91 
92  SUBROUTINE file_group__set_attribut_pt(pt_fg,attrib)
93  USE mod_attribut
94  USE mod_object
95  IMPLICIT NONE
96    TYPE(file_group),POINTER :: Pt_fg
97    TYPE(attribut),INTENT(IN) :: attrib
98     
99    IF (attrib%object==file_object) THEN
100      CALL file__set_attribut(Pt_fg%default_attribut,attrib)
101    ENDIF
102   
103  END SUBROUTINE file_group__set_attribut_pt
104 
105     
106  RECURSIVE SUBROUTINE file_group__new(Pt_fg,Id)
107  USE string_function
108  IMPLICIT NONE
109    TYPE(file_group),POINTER                :: Pt_fg
110    CHARACTER(LEN=*),OPTIONAL,INTENT(IN)     :: Id
111   
112    INTEGER :: Pos
113   
114    ALLOCATE(Pt_fg%groups)
115    ALLOCATE(Pt_fg%files)
116    ALLOCATE(Pt_fg%default_attribut)
117   
118    CALL vector_file_group__new(Pt_fg%groups)
119    CALL vector_file__new(Pt_fg%files)
120    CALL file__new(Pt_fg%default_attribut)
121    Pt_fg%has_id=.FALSE.
122     
123    IF (PRESENT(Id)) THEN
124      Pt_fg%id=TRIM(Id)
125      Pt_fg%has_id=.TRUE.
126      CALL vector_file_group__set_new(file_group_Ids,Pt_fg,Pos)
127      CALL sorted_list__Add(Ids,hash(id),Pos)
128    ENDIF
129
130  END SUBROUTINE file_group__new
131
132     
133  SUBROUTINE file_group__get_new_group(Pt_fg,Pt_fg_out,Id)
134  IMPLICIT NONE
135    TYPE(file_group),POINTER             :: Pt_fg
136    TYPE(file_group),POINTER             :: Pt_fg_out
137    CHARACTER(LEN=*),OPTIONAL      :: Id
138   
139    CALL vector_file_group__get_new(Pt_fg%groups,Pt_fg_out)
140    CALL file_group__new(Pt_fg_out)
141
142    IF (PRESENT(id)) THEN
143      CALL file_group__new(Pt_fg_out,Id)
144    ELSE
145      CALL file_group__new(Pt_fg_out)
146    ENDIF
147   
148  END SUBROUTINE file_group__get_new_group
149
150 
151  SUBROUTINE file_group__get_new_file(Pt_fg,Pt_f_out,Id)
152  IMPLICIT NONE
153    TYPE(file_group),POINTER            :: Pt_fg
154    TYPE(file),POINTER                  :: Pt_f_out
155    CHARACTER(LEN=*),OPTIONAL      :: Id
156   
157    CALL vector_file__get_new(Pt_fg%files,Pt_f_out)
158   
159    IF (PRESENT(id)) THEN
160      CALL file__new(Pt_f_out,Id)
161    ELSE
162      CALL file__new(Pt_f_out)
163    ENDIF
164   
165  END SUBROUTINE file_group__get_new_file
166 
167 
168  SUBROUTINE file_group__get_default_attrib(Pt_fg,Pt_f)
169  IMPLICIT NONE
170    TYPE(file_group),POINTER  :: Pt_fg
171    TYPE(file),POINTER        :: Pt_f
172   
173    Pt_f=>Pt_fg%default_attribut
174  END SUBROUTINE file_group__get_default_attrib
175 
176  RECURSIVE SUBROUTINE file_group__apply_default(Pt_fg,default)
177  IMPLICIT NONE
178    TYPE(file_group),POINTER  :: Pt_fg
179    TYPE(file),POINTER,OPTIONAL        :: default
180   
181    INTEGER :: i
182   
183    IF (PRESENT(default)) THEN
184      CALL file__apply_default(default,Pt_fg%default_attribut,Pt_fg%default_attribut)
185    ENDIF
186     
187    DO i=1,Pt_fg%groups%size
188      CALL file_group__apply_default(Pt_fg%groups%at(i)%pt,Pt_fg%default_attribut)
189    ENDDO
190   
191    DO i=1,Pt_fg%files%size
192      CALL file__apply_default(Pt_fg%default_attribut,Pt_fg%files%at(i)%pt,Pt_fg%files%at(i)%pt)
193    ENDDO
194 
195  END SUBROUTINE file_group__apply_default
196
197  RECURSIVE SUBROUTINE file_group__solve_field_ref(pt_fg)
198  IMPLICIT NONE
199    TYPE(file_group),POINTER  :: Pt_fg
200
201    INTEGER :: i
202
203    DO i=1,Pt_fg%groups%size
204      CALL file_group__solve_field_ref(Pt_fg%groups%at(i)%pt)
205    ENDDO
206   
207    DO i=1,Pt_fg%files%size
208      CALL file__solve_field_ref(Pt_fg%files%at(i)%pt)
209    ENDDO
210 
211  END SUBROUTINE file_group__solve_field_ref
212 
213 
214  RECURSIVE SUBROUTINE file_group__print(Pt_fg)
215  IMPLICIT NONE
216    TYPE(file_group),POINTER  :: Pt_fg
217   
218    INTEGER :: i
219   
220    PRINT *,"--- FILE GROUP ---"
221    IF (Pt_fg%has_id) THEN
222      PRINT *,"id :",TRIM(Pt_fg%id)
223    ELSE
224      PRINT *,"id undefined"
225    ENDIF
226   
227    PRINT *,"file default attribut :"
228    CALL file__print(Pt_fg%default_attribut)   
229
230    PRINT *,"owned file groups :"     
231    DO i=1,Pt_fg%groups%size
232      CALL file_group__print(Pt_fg%groups%at(i)%pt)
233    ENDDO
234
235    PRINT *,"owned file :"     
236    DO i=1,Pt_fg%files%size
237      CALL file__print(Pt_fg%files%at(i)%pt)
238    ENDDO
239 
240  END SUBROUTINE file_group__print     
241
242  RECURSIVE SUBROUTINE file_group__Check(Pt_fg)
243  IMPLICIT NONE
244 
245    TYPE(file_group),POINTER  :: Pt_fg
246    INTEGER :: i
247   
248    DO i=1,Pt_fg%groups%size
249      CALL file_group__check(pt_fg%groups%at(i)%pt)
250    ENDDO
251
252    DO i=1,Pt_fg%files%size
253      CALL file__check(pt_fg%files%at(i)%pt)
254    ENDDO
255 
256  END SUBROUTINE file_group__check     
257         
258END MODULE mod_file_group
259
Note: See TracBrowser for help on using the repository browser.