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

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

Correction bug : les fichiers de sortie disparaissaient aléatoirement...

YM+AC
File size: 10.5 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_enabled = .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(1:attrib%string_len)) ; RETURN
184      CASE (file__name_suffix)
185        IF (attrib%type==string0) CALL  file__set(pt_file,name_suffix=attrib%string0_ptr(1:attrib%string_len)) ; RETURN
186      CASE (file__description)
187        IF (attrib%type==string0) CALL  file__set(pt_file,description=attrib%string0_ptr(1:attrib%string_len)) ; 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,       &
197                      ' : Attribute type is incompatible with the provided value'
198     CALL error('mod_file::file__set_attribut')
199   
200  END SUBROUTINE file__set_attribut_pt
201 
202     
203  SUBROUTINE file__get_field_list(pt_file,pt_field_list)
204  IMPLICIT NONE
205    TYPE(file),POINTER         :: pt_file
206    TYPE(field_group),POINTER  :: pt_field_list
207   
208      pt_field_list=>pt_file%field_list
209 
210  END SUBROUTINE file__get_field_list
211   
212  SUBROUTINE file__print(pt_file)
213  IMPLICIT NONE
214    TYPE(file), POINTER         :: pt_file
215
216    PRINT *,"---- FILE ----"
217    IF (pt_file%has_id) THEN
218      PRINT *,"id = ",TRIM(pt_file%id)
219    ELSE
220      PRINT *,"id undefined"
221    ENDIF
222   
223    IF (pt_file%has_name) THEN
224      PRINT *,"name = ",TRIM(pt_file%name)
225    ELSE
226      PRINT *,"name undefined"
227    ENDIF
228
229    IF (pt_file%has_name_suffix) THEN
230      PRINT *,"name_suffix = ",TRIM(pt_file%name_suffix)
231    ELSE
232      PRINT *,"name_suffix undefined"
233    ENDIF
234   
235    IF (pt_file%has_description) THEN
236      PRINT *,"description = ",TRIM(pt_file%description)
237    ELSE
238      PRINT *,"description undefined"
239    ENDIF
240 
241    IF (pt_file%has_output_freq) THEN
242      PRINT *,"output_freq = ",pt_file%output_freq
243    ELSE
244      PRINT *,"output_freq undefined"
245    ENDIF
246
247    IF (pt_file%has_output_level) THEN
248      PRINT *,"output_level = ",pt_file%output_level
249    ELSE
250      PRINT *,"output_level undefined"
251    ENDIF
252
253    IF (pt_file%has_enabled) THEN
254      PRINT *,"enabled = ",pt_file%enabled
255    ELSE
256      PRINT *,"enabled undefined"
257    ENDIF
258
259    PRINT *,"field_list :"
260    CALL field_group__print(pt_file%field_list)
261
262    PRINT *,"--------------"
263
264  END SUBROUTINE file__print
265
266
267  SUBROUTINE file__apply_default(pt_file_default, pt_file_in, pt_file_out)
268
269    TYPE(file), POINTER :: pt_file_default, pt_file_in, pt_file_out
270
271    IF (pt_file_in%has_name) THEN
272        pt_file_out%name=pt_file_in%name
273        pt_file_out%has_name=.TRUE.
274    ELSE IF ( pt_file_default%has_name) THEN
275        pt_file_out%name=pt_file_default%name
276        pt_file_out%has_name=.TRUE.
277    ELSE
278        pt_file_out%has_name=.FALSE.
279    ENDIF
280
281    IF (pt_file_in%has_name_suffix) THEN
282        pt_file_out%name_suffix=pt_file_in%name_suffix
283        pt_file_out%has_name_suffix=.TRUE.
284    ELSE IF ( pt_file_default%has_name_suffix) THEN
285        pt_file_out%name_suffix=pt_file_default%name_suffix
286        pt_file_out%has_name_suffix=.TRUE.
287    ELSE
288        pt_file_out%has_name_suffix=.FALSE.
289    ENDIF
290       
291    IF (pt_file_in%has_description) THEN
292        pt_file_out%description=pt_file_in%description
293        pt_file_out%has_description=.TRUE.
294    ELSE IF ( pt_file_default%has_description ) THEN
295        pt_file_out%description=pt_file_default%description
296        pt_file_out%has_description=.TRUE.
297    ELSE
298        pt_file_out%has_description=.FALSE.
299    ENDIF
300
301    IF (pt_file_in%has_output_freq) THEN
302        pt_file_out%output_freq=pt_file_in%output_freq
303        pt_file_out%has_output_freq=.TRUE.
304    ELSE IF ( pt_file_default%has_output_freq ) THEN
305        pt_file_out%output_freq=pt_file_default%output_freq
306        pt_file_out%has_output_freq=.TRUE.
307    ELSE
308        pt_file_out%has_output_freq=.FALSE.
309    ENDIF
310
311    IF (pt_file_in%has_output_level) THEN
312        pt_file_out%output_level=pt_file_in%output_level
313        pt_file_out%has_output_level=.TRUE.
314    ELSE IF ( pt_file_default%has_output_level ) THEN
315        pt_file_out%output_level=pt_file_default%output_level
316        pt_file_out%has_output_level=.TRUE.
317    ELSE
318        pt_file_out%has_output_level=.FALSE.
319    ENDIF
320
321    IF (pt_file_in%has_enabled) THEN
322        pt_file_out%enabled=pt_file_in%enabled
323        pt_file_out%has_enabled=.TRUE.
324    ELSE IF ( pt_file_default%has_enabled ) THEN
325        pt_file_out%enabled=pt_file_default%enabled
326        pt_file_out%has_enabled=.TRUE.
327    ELSE
328        pt_file_out%has_enabled=.FALSE.
329    ENDIF
330   
331    CALL field_group__apply_default(pt_file_out%field_list)
332
333
334  END SUBROUTINE file__apply_default
335
336   
337  SUBROUTINE file__solve_field_ref(pt_file)
338  IMPLICIT NONE
339    TYPE(file), POINTER :: pt_file
340   
341    CALL field_group__solve_ref(pt_file%field_list)
342 
343  END SUBROUTINE file__solve_field_ref
344 
345 
346  SUBROUTINE file__Check(pt_file)
347  USE error_msg
348  IMPLICIT NONE
349    TYPE(file), POINTER :: pt_file
350     
351    IF (.NOT. pt_file%has_name) THEN
352      IF (pt_file%has_id) THEN
353        pt_file%name=TRIM(pt_file%id)
354      ELSE
355        WRITE(message,*) "File has no name and no id" 
356        CALL error("mod_file::file__check")
357      ENDIF
358    ENDIF
359 
360 END SUBROUTINE file__Check
361   
362END MODULE mod_file
Note: See TracBrowser for help on using the repository browser.