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

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

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

File size: 10.4 KB
Line 
1MODULE mod_file
2
3  USE mod_xmlio_parameters
4  USE mod_field_group
5  USE mod_sorted_list
6
7  TYPE, PUBLIC :: file
8    CHARACTER(len=str_len)           :: id
9    LOGICAL                          :: has_id
10    CHARACTER(len=str_len)           :: name
11    LOGICAL                          :: has_name
12    CHARACTER(len=str_len)           :: name_suffix
13    LOGICAL                          :: has_name_suffix
14    CHARACTER(len=str_len)           :: description
15    LOGICAL                          :: has_description
16    INTEGER                          :: output_freq
17    LOGICAL                          :: has_output_freq
18    INTEGER                          :: output_level
19    LOGICAL                          :: has_output_level
20    LOGICAL                          :: enabled
21    LOGICAL                          :: has_enabled
22    INTEGER                          :: internal(internal_file)
23    TYPE(field_group),POINTER        :: field_list 
24  END TYPE file
25
26  INCLUDE 'vector_file_def.inc'
27 
28  TYPE(vector_file),POINTER,SAVE             :: file_Ids
29  TYPE(sorted_list),POINTER,SAVE,PRIVATE     :: Ids 
30
31  INTERFACE file__set_attribut
32    MODULE PROCEDURE file__set_attribut_id,file__set_attribut_pt
33  END INTERFACE
34
35CONTAINS
36  INCLUDE 'vector_file_contains.inc'
37
38  SUBROUTINE file__swap_context(saved_file_ids,saved_ids)
39  IMPLICIT NONE
40    TYPE(vector_file),POINTER      :: saved_file_Ids
41    TYPE(sorted_list),POINTER      :: saved_Ids
42   
43    file_ids=>saved_file_ids
44    ids=>saved_ids 
45 
46  END SUBROUTINE file__swap_context
47
48
49  SUBROUTINE file__init
50  IMPLICIT NONE
51   
52    CALL vector_file__new(file_Ids)
53    CALL sorted_list__new(Ids)
54   
55  END SUBROUTINE file__init
56 
57  SUBROUTINE file__get(Id,Pt_file)
58  USE string_function
59  IMPLICIT NONE
60    CHARACTER(LEN=*),INTENT(IN)     :: Id
61    TYPE(file),POINTER              :: Pt_file
62
63    INTEGER                         :: Pos
64    LOGICAL                         :: success
65   
66    CALL sorted_list__find(Ids,hash(Id),Pos,success)
67    IF (success) THEN
68      Pt_file=>file_ids%at(Pos)%Pt
69    ELSE
70      Pt_file=>NULL()
71    ENDIF
72   
73  END SUBROUTINE file__get
74 
75  SUBROUTINE file__new(pt_file,Id)
76  USE string_function
77  IMPLICIT NONE
78   TYPE(file), POINTER           :: pt_file
79   CHARACTER(LEN=*),OPTIONAL     :: Id
80   INTEGER                       :: Pos
81
82   ALLOCATE(pt_file%field_list)
83   CALL field_group__new(pt_file%field_list)
84     
85   pt_file%has_id           = .FALSE.
86   pt_file%has_name         = .FALSE.
87   pt_file%has_name_suffix  = .FALSE.
88   pt_file%has_description  = .FALSE.
89   pt_file%has_output_freq  = .FALSE.
90   pt_file%has_output_level = .FALSE.
91   pt_file%has_output_level = .FALSE.
92   
93   IF (PRESENT(Id)) THEN
94     Pt_file%id=TRIM(ADJUSTL(Id))
95     Pt_file%has_id=.TRUE.
96     CALL vector_file__set_new(file_Ids,Pt_file,Pos)
97     CALL sorted_list__Add(Ids,hash(id),Pos)
98   ENDIF
99
100  END SUBROUTINE file__new
101
102  SUBROUTINE file__set(pt_file, name, name_suffix, description, output_freq, output_level,enabled)
103  IMPLICIT NONE
104    TYPE(file), POINTER         :: pt_file
105    CHARACTER(len=*)  ,OPTIONAL :: name
106    CHARACTER(len=*)  ,OPTIONAL :: name_suffix
107    CHARACTER(len=*)  ,OPTIONAL :: description
108    INTEGER           ,OPTIONAL :: output_freq
109    INTEGER           ,OPTIONAL :: output_level
110    LOGICAL           ,OPTIONAL :: enabled
111
112    IF (PRESENT(name)) THEN
113        pt_file%name=TRIM(ADJUSTL(name))
114        pt_file%has_name = .TRUE.
115    ENDIF
116
117    IF (PRESENT(name_suffix)) THEN
118        pt_file%name_suffix=TRIM(ADJUSTL(name_suffix))
119        pt_file%has_name_suffix = .TRUE.
120    ENDIF
121
122    IF (PRESENT(description)) THEN
123        pt_file%description=TRIM(ADJUSTL(description))
124        pt_file%has_description = .TRUE.
125    ENDIF
126 
127    IF (PRESENT(output_freq)) then
128        pt_file%output_freq=output_freq
129        pt_file%has_output_freq = .TRUE.
130    ENDIF
131
132    IF (PRESENT(output_level)) then
133        pt_file%output_level = output_level
134        pt_file%has_output_level = .TRUE.
135    ENDIF
136
137    IF (PRESENT(enabled)) then
138        pt_file%enabled = enabled
139        pt_file%has_enabled = .TRUE.
140    ENDIF
141   
142  END SUBROUTINE file__set
143
144  SUBROUTINE file__set_attribut_id(id,attrib,ok)
145  USE mod_attribut
146  USE error_msg
147  IMPLICIT NONE
148    CHARACTER(LEN=*),INTENT(IN)   :: id
149    TYPE(attribut),INTENT(IN)     :: attrib
150    LOGICAL,OPTIONAL,INTENT(OUT)  :: ok
151   
152    TYPE(file),POINTER              :: Pt_file
153    INTEGER                         :: Pos
154    LOGICAL                         :: success
155   
156    CALL sorted_list__find(Ids,hash(Id),Pos,success)
157    IF (success) THEN
158      Pt_file=>file_ids%at(Pos)%Pt
159      CALL file__set_attribut_pt(Pt_file,attrib)
160      IF (PRESENT(OK)) OK=.TRUE.
161    ELSE
162      IF (.NOT.PRESENT(OK)) THEN
163        WRITE(message,*) 'File id : ',id,' is undefined'
164        CALL error('mod_file::file__set_attribut')
165      ELSE
166        OK=.FALSE.
167      ENDIF
168    ENDIF 
169 
170  END SUBROUTINE file__set_attribut_id
171     
172  SUBROUTINE file__set_attribut_pt(Pt_file,attrib)
173  USE mod_attribut
174  USE mod_file_attribut
175  USE error_msg
176  IMPLICIT NONE
177    TYPE(file),POINTER        :: Pt_file
178    TYPE(attribut),INTENT(IN) :: attrib
179
180   
181    SELECT CASE(attrib%name)
182      CASE (file__name)
183        IF (attrib%type==string0) CALL  file__set(pt_file,name=attrib%string0_ptr) ; RETURN
184      CASE (file__name_suffix)
185        IF (attrib%type==string0) CALL  file__set(pt_file,name_suffix=attrib%string0_ptr) ; RETURN
186      CASE (file__description)
187        IF (attrib%type==string0) CALL  file__set(pt_file,description=attrib%string0_ptr) ; RETURN
188      CASE (file__output_freq)
189        IF (attrib%type==integer0) CALL  file__set(pt_file,output_freq=attrib%integer0_ptr) ; RETURN
190      CASE (file__output_level)
191        IF (attrib%type==integer0) CALL  file__set(pt_file,output_level=attrib%integer0_ptr) ; RETURN
192      CASE (file__enabled)
193        IF (attrib%type==logical0) CALL  file__set(pt_file,enabled=attrib%logical0_ptr) ; RETURN
194     END SELECT
195
196     WRITE(message,*) 'file attribut ',attrib%name,' : type : ',attrib%type,' : Attribute type is incompatible with the provided value'
197     CALL error('mod_file::file__set_attribut')
198   
199  END SUBROUTINE file__set_attribut_pt
200 
201     
202  SUBROUTINE file__get_field_list(pt_file,pt_field_list)
203  IMPLICIT NONE
204    TYPE(file),POINTER         :: pt_file
205    TYPE(field_group),POINTER  :: pt_field_list
206   
207      pt_field_list=>pt_file%field_list
208 
209  END SUBROUTINE file__get_field_list
210   
211  SUBROUTINE file__print(pt_file)
212  IMPLICIT NONE
213    TYPE(file), POINTER         :: pt_file
214
215    PRINT *,"---- FILE ----"
216    IF (pt_file%has_id) THEN
217      PRINT *,"id = ",TRIM(pt_file%id)
218    ELSE
219      PRINT *,"id undefined"
220    ENDIF
221   
222    IF (pt_file%has_name) THEN
223      PRINT *,"name = ",TRIM(pt_file%name)
224    ELSE
225      PRINT *,"name undefined"
226    ENDIF
227
228    IF (pt_file%has_name_suffix) THEN
229      PRINT *,"name_suffix = ",TRIM(pt_file%name_suffix)
230    ELSE
231      PRINT *,"name_suffix undefined"
232    ENDIF
233   
234    IF (pt_file%has_description) THEN
235      PRINT *,"description = ",TRIM(pt_file%description)
236    ELSE
237      PRINT *,"description undefined"
238    ENDIF
239 
240    IF (pt_file%has_output_freq) THEN
241      PRINT *,"output_freq = ",pt_file%output_freq
242    ELSE
243      PRINT *,"output_freq undefined"
244    ENDIF
245
246    IF (pt_file%has_output_level) THEN
247      PRINT *,"output_level = ",pt_file%output_level
248    ELSE
249      PRINT *,"output_level undefined"
250    ENDIF
251
252    IF (pt_file%has_enabled) THEN
253      PRINT *,"enabled = ",pt_file%enabled
254    ELSE
255      PRINT *,"enabled undefined"
256    ENDIF
257
258    PRINT *,"field_list :"
259    CALL field_group__print(pt_file%field_list)
260
261    PRINT *,"--------------"
262
263  END SUBROUTINE file__print
264
265
266  SUBROUTINE file__apply_default(pt_file_default, pt_file_in, pt_file_out)
267
268    TYPE(file), POINTER :: pt_file_default, pt_file_in, pt_file_out
269
270    IF (pt_file_in%has_name) THEN
271        pt_file_out%name=pt_file_in%name
272        pt_file_out%has_name=.TRUE.
273    ELSE IF ( pt_file_default%has_name) THEN
274        pt_file_out%name=pt_file_default%name
275        pt_file_out%has_name=.TRUE.
276    ELSE
277        pt_file_out%has_name=.FALSE.
278    ENDIF
279
280    IF (pt_file_in%has_name_suffix) THEN
281        pt_file_out%name_suffix=pt_file_in%name_suffix
282        pt_file_out%has_name_suffix=.TRUE.
283    ELSE IF ( pt_file_default%has_name_suffix) THEN
284        pt_file_out%name_suffix=pt_file_default%name_suffix
285        pt_file_out%has_name_suffix=.TRUE.
286    ELSE
287        pt_file_out%has_name_suffix=.FALSE.
288    ENDIF
289       
290    IF (pt_file_in%has_description) THEN
291        pt_file_out%description=pt_file_in%description
292        pt_file_out%has_description=.TRUE.
293    ELSE IF ( pt_file_default%has_description ) THEN
294        pt_file_out%description=pt_file_default%description
295        pt_file_out%has_description=.TRUE.
296    ELSE
297        pt_file_out%has_description=.FALSE.
298    ENDIF
299
300    IF (pt_file_in%has_output_freq) THEN
301        pt_file_out%output_freq=pt_file_in%output_freq
302        pt_file_out%has_output_freq=.TRUE.
303    ELSE IF ( pt_file_default%has_output_freq ) THEN
304        pt_file_out%output_freq=pt_file_default%output_freq
305        pt_file_out%has_output_freq=.TRUE.
306    ELSE
307        pt_file_out%has_output_freq=.FALSE.
308    ENDIF
309
310    IF (pt_file_in%has_output_level) THEN
311        pt_file_out%output_level=pt_file_in%output_level
312        pt_file_out%has_output_level=.TRUE.
313    ELSE IF ( pt_file_default%has_output_level ) THEN
314        pt_file_out%output_level=pt_file_default%output_level
315        pt_file_out%has_output_level=.TRUE.
316    ELSE
317        pt_file_out%has_output_level=.FALSE.
318    ENDIF
319
320    IF (pt_file_in%has_enabled) THEN
321        pt_file_out%enabled=pt_file_in%enabled
322        pt_file_out%has_enabled=.TRUE.
323    ELSE IF ( pt_file_default%has_enabled ) THEN
324        pt_file_out%enabled=pt_file_default%enabled
325        pt_file_out%has_enabled=.TRUE.
326    ELSE
327        pt_file_out%has_enabled=.FALSE.
328    ENDIF
329   
330    CALL field_group__apply_default(pt_file_out%field_list)
331
332
333  END SUBROUTINE file__apply_default
334
335   
336  SUBROUTINE file__solve_field_ref(pt_file)
337  IMPLICIT NONE
338    TYPE(file), POINTER :: pt_file
339   
340    CALL field_group__solve_ref(pt_file%field_list)
341 
342  END SUBROUTINE file__solve_field_ref
343 
344 
345  SUBROUTINE file__Check(pt_file)
346  USE error_msg
347  IMPLICIT NONE
348    TYPE(file), POINTER :: pt_file
349     
350    IF (.NOT. pt_file%has_name) THEN
351      IF (pt_file%has_id) THEN
352        pt_file%name=TRIM(pt_file%id)
353      ELSE
354        WRITE(message,*) "File has no name and no id" 
355        CALL error("mod_file::file__check")
356      ENDIF
357    ENDIF
358 
359 END SUBROUTINE file__Check
360   
361END MODULE mod_file
Note: See TracBrowser for help on using the repository browser.