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

Last change on this file since 40 was 40, checked in by ymipsl, 15 years ago
  • Les attributs XML peuvent désormais être passer dynamiquement à travers l'interface du server IO.
  • ajout d'un attribut name_suffix pour les fichiers

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