source: XMLIO_SERVER/trunk/src/XMLIO/mod_axis.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: 9.2 KB
Line 
1MODULE mod_axis
2
3  USE mod_xmlio_parameters
4  USE mod_sorted_list
5
6 
7  IMPLICIT NONE
8
9  TYPE, PUBLIC :: axis
10    CHARACTER(len=str_len)      :: id
11    LOGICAL                     :: has_id
12    CHARACTER(len=str_len)      :: name
13    LOGICAL                     :: has_name
14    INTEGER                     :: size
15    LOGICAL                     :: has_size
16    CHARACTER(len=str_len)      :: description
17    LOGICAL                     :: has_description
18    CHARACTER(len=str_len)      :: unit
19    LOGICAL                     :: has_unit
20    LOGICAL                     :: positive
21    LOGICAL                     :: has_positive
22    REAL, DIMENSION(:), POINTER :: values
23    LOGICAL                     :: has_values
24
25  END TYPE axis
26
27  INCLUDE 'vector_axis_def.inc'
28 
29  TYPE(vector_axis),POINTER,SAVE             :: axis_Ids
30  TYPE(sorted_list),POINTER,SAVE,PRIVATE     :: Ids 
31
32  INTERFACE axis__set_attribut
33    MODULE PROCEDURE axis__set_attribut_id,axis__set_attribut_pt
34  END INTERFACE
35
36CONTAINS
37  INCLUDE 'vector_axis_contains.inc'
38
39  SUBROUTINE axis__swap_context(saved_axis_Ids,saved_Ids)
40  IMPLICIT NONE
41    TYPE(vector_axis),POINTER          :: saved_axis_Ids
42    TYPE(sorted_list),POINTER          :: saved_Ids 
43   
44    axis_ids=>saved_axis_ids
45    ids=>saved_ids
46   
47  END SUBROUTINE axis__swap_context
48
49  SUBROUTINE axis__init
50  IMPLICIT NONE
51   
52    CALL vector_axis__new(axis_Ids)
53    CALL sorted_list__new(Ids)
54   
55  END SUBROUTINE axis__init
56 
57  SUBROUTINE axis__get(Id,Pt_axis)
58  USE string_function
59  IMPLICIT NONE
60    CHARACTER(LEN=*),INTENT(IN)     :: Id
61    TYPE(axis),POINTER              :: Pt_axis
62
63    INTEGER                         :: Pos
64    LOGICAL                         :: success
65   
66    CALL sorted_list__find(Ids,hash(Id),Pos,success)
67    IF (success) THEN
68      Pt_axis=>axis_ids%at(Pos)%Pt
69    ELSE
70      Pt_axis=>NULL()
71    ENDIF
72   
73  END SUBROUTINE axis__get
74 
75  SUBROUTINE axis__new(pt_axis,Id)
76  USE string_function
77  IMPLICIT NONE
78   TYPE(axis), POINTER           :: pt_axis
79   CHARACTER(LEN=*),OPTIONAL     :: Id
80   INTEGER                       :: Pos
81   
82   pt_axis%has_id          = .FALSE.
83   pt_axis%has_name        = .FALSE.
84   pt_axis%has_size        = .FALSE.
85   pt_axis%has_description = .FALSE.
86   pt_axis%has_unit        = .FALSE.
87   pt_axis%has_values      = .FALSE.
88   pt_axis%has_positive    = .FALSE. 
89     
90   IF (PRESENT(Id)) THEN
91     Pt_axis%id=TRIM(ADJUSTL(Id))
92     Pt_axis%has_id=.TRUE.
93     CALL vector_axis__set_new(axis_Ids,Pt_axis,Pos)
94     CALL sorted_list__Add(Ids,hash(id),Pos)
95   ENDIF
96
97 END SUBROUTINE axis__new
98
99  SUBROUTINE axis__set(pt_axis, name, description, unit, a_size, values, positive)
100  IMPLICIT NONE
101    TYPE(axis), POINTER         :: pt_axis
102    CHARACTER(len=*)  ,OPTIONAL :: name
103    CHARACTER(len=*)  ,OPTIONAL :: description
104    CHARACTER(len=*)  ,OPTIONAL :: unit
105    INTEGER           ,OPTIONAL :: a_size
106    REAL, DIMENSION(:),OPTIONAL :: values
107    LOGICAL           ,OPTIONAL :: positive
108
109    IF (PRESENT(name)) THEN
110        pt_axis%name=TRIM(ADJUSTL(name))
111        pt_axis%has_name = .TRUE.
112    ENDIF
113
114    IF (PRESENT(description)) THEN
115        pt_axis%description=TRIM(ADJUSTL(description))
116        pt_axis%has_description = .TRUE.
117    ENDIF
118 
119    IF (PRESENT(unit)) then
120        pt_axis%unit=TRIM(ADJUSTL(unit))
121        pt_axis%has_unit = .TRUE.
122    ENDIF
123
124    IF (PRESENT(a_size)) then
125        pt_axis%size=a_size
126        pt_axis%has_size = .TRUE.
127    ENDIF
128   
129    IF (PRESENT(values)) then
130        IF (pt_axis%has_values) DEALLOCATE(pt_axis%values) 
131        ALLOCATE(pt_axis%values(size(values)))
132        pt_axis%values(:)=values(:)
133        pt_axis%has_values = .TRUE.
134    ENDIF
135
136    IF (PRESENT(positive)) then
137        pt_axis%positive=positive
138        pt_axis%has_positive = .TRUE.
139    ENDIF
140
141  END SUBROUTINE axis__set
142
143  SUBROUTINE axis__set_attribut_id(id,attrib,ok)
144  USE mod_attribut
145  USE error_msg
146  IMPLICIT NONE
147    CHARACTER(LEN=*),INTENT(IN)   :: id
148    TYPE(attribut),INTENT(IN)     :: attrib
149    LOGICAL,OPTIONAL,INTENT(OUT)  :: ok
150   
151    TYPE(axis),POINTER              :: Pt_axis
152    INTEGER                         :: Pos
153    LOGICAL                         :: success
154   
155    CALL sorted_list__find(Ids,hash(Id),Pos,success)
156    IF (success) THEN
157      Pt_axis=>axis_ids%at(Pos)%Pt
158      CALL axis__set_attribut_pt(Pt_axis,attrib)
159      IF (PRESENT(OK)) OK=.TRUE.
160    ELSE
161      IF (.NOT.PRESENT(OK)) THEN
162        WRITE(message,*) 'axis id :',id,'is undefined'
163        CALL error('mod_axis::axis__set_attribut')
164      ELSE
165        OK=.FALSE.
166      ENDIF
167    ENDIF 
168 
169  END SUBROUTINE axis__set_attribut_id
170     
171  SUBROUTINE axis__set_attribut_pt(Pt_axis,attrib)
172  USE mod_attribut
173  USE mod_axis_attribut
174  USE error_msg
175  IMPLICIT NONE
176    TYPE(axis),POINTER        :: Pt_axis
177    TYPE(attribut),INTENT(IN) :: attrib
178   
179    SELECT CASE(attrib%name)
180      CASE (axis__name)
181        IF (attrib%type==string0) CALL  axis__set(pt_axis,name=attrib%string0_ptr) ; RETURN
182      CASE (axis__description)
183        IF (attrib%type==string0) CALL  axis__set(pt_axis,description=attrib%string0_ptr) ; RETURN
184      CASE (axis__unit)
185        IF (attrib%type==string0) CALL  axis__set(pt_axis,unit=attrib%string0_ptr) ; RETURN
186      CASE (axis__size)
187        IF (attrib%type==integer0) CALL  axis__set(pt_axis,a_size=attrib%integer0_ptr) ; RETURN
188      CASE (axis__values)
189        IF (attrib%type==real1) CALL  axis__set(pt_axis,values=attrib%real1_ptr) ; RETURN
190      CASE (axis__positive)
191        IF (attrib%type==logical0) CALL  axis__set(pt_axis,positive=attrib%logical0_ptr) ; RETURN
192       END SELECT
193
194     WRITE(message,*) 'axis attribut ',attrib%name,' : type :',attrib%type,' : Attribute type is incompatible with the provided value'
195     CALL error('mod_axis::axis__set_attribut')
196   
197  END SUBROUTINE axis__set_attribut_pt
198 
199  SUBROUTINE axis__print(pt_axis)
200  IMPLICIT NONE
201    TYPE(axis), POINTER         :: pt_axis
202
203    PRINT *,"---- AXIS ----"
204    IF (pt_axis%has_id) THEN
205      PRINT *,"id = ",TRIM(pt_axis%id)
206    ELSE
207      PRINT *,"id undefined"
208    ENDIF
209   
210    IF (pt_axis%has_name) THEN
211      PRINT *,"name = ",TRIM(pt_axis%name)
212    ELSE
213      PRINT *,"name undefined"
214    ENDIF
215   
216    IF (pt_axis%has_description) THEN
217      PRINT *,"description = ",TRIM(pt_axis%description)
218    ELSE
219      PRINT *,"description undefined"
220    ENDIF
221 
222    IF (pt_axis%has_unit) THEN
223      PRINT *,"unit = ",TRIM(pt_axis%unit)
224    ELSE
225      PRINT *,"unit undefined"
226    ENDIF
227
228    IF (pt_axis%has_size) THEN
229      PRINT *,"size = ",pt_axis%size
230    ELSE
231      PRINT *,"size undefined"
232    ENDIF
233
234    IF (pt_axis%has_values) THEN
235      PRINT *,"values = ",pt_axis%values
236    ELSE
237      PRINT *,"values undefined"
238    ENDIF
239
240    IF (pt_axis%has_positive) THEN
241      PRINT *,"positive = ",pt_axis%positive
242    ELSE
243      PRINT *,"positive undefined"
244    ENDIF
245
246  END SUBROUTINE axis__print
247
248
249  SUBROUTINE axis__apply_default(pt_axis_default, pt_axis_in, pt_axis_out)
250
251    TYPE(axis), POINTER :: pt_axis_default, pt_axis_in, pt_axis_out
252
253    IF (pt_axis_in%has_name) THEN
254        pt_axis_out%name=pt_axis_in%name
255        pt_axis_out%has_name=.TRUE.
256    ELSE IF ( pt_axis_default%has_name) THEN
257        pt_axis_out%name=pt_axis_default%name
258        pt_axis_out%has_name=.TRUE.
259    ELSE
260        pt_axis_out%has_name=.FALSE.
261    ENDIF
262       
263    IF (pt_axis_in%has_description) THEN
264        pt_axis_out%description=pt_axis_in%description
265        pt_axis_out%has_description=.TRUE.
266    ELSE IF ( pt_axis_default%has_description ) THEN
267        pt_axis_out%description=pt_axis_default%description
268        pt_axis_out%has_description=.TRUE.
269    ELSE
270        pt_axis_out%has_description=.FALSE.
271    ENDIF
272
273    IF (pt_axis_in%has_unit) THEN
274        pt_axis_out%unit=pt_axis_in%unit
275        pt_axis_out%has_unit=.TRUE.
276    ELSE IF ( pt_axis_default%has_unit ) THEN
277        pt_axis_out%unit=pt_axis_default%unit
278        pt_axis_out%has_unit=.TRUE.
279    ELSE
280        pt_axis_out%has_unit=.FALSE.
281    ENDIF
282
283    IF (pt_axis_in%has_size) THEN
284        pt_axis_out%size=pt_axis_in%size
285        pt_axis_out%has_size=.TRUE.
286    ELSE IF ( pt_axis_default%has_size ) THEN
287        pt_axis_out%size=pt_axis_default%size
288        pt_axis_out%has_size=.TRUE.
289    ELSE
290        pt_axis_out%has_size=.FALSE.
291    ENDIF
292
293    IF (pt_axis_in%has_values) THEN
294        pt_axis_out%values(:)=pt_axis_in%values(:)
295        pt_axis_out%has_values=.TRUE.
296    ELSE IF ( pt_axis_default%has_values ) THEN
297        pt_axis_out%values(:)=pt_axis_default%values(:)
298        pt_axis_out%has_values=.TRUE.
299    ELSE
300        pt_axis_out%has_values=.FALSE.
301    ENDIF
302
303    IF (pt_axis_in%has_positive) THEN
304        pt_axis_out%positive=pt_axis_in%positive
305        pt_axis_out%has_positive=.TRUE.
306    ELSE IF ( pt_axis_default%has_positive ) THEN
307        pt_axis_out%positive=pt_axis_default%positive
308        pt_axis_out%has_positive=.TRUE.
309    ELSE
310        pt_axis_out%has_positive=.FALSE.
311    ENDIF
312   
313  END SUBROUTINE axis__apply_default
314
315  SUBROUTINE axis__check(pt_axis)
316  USE error_msg
317  IMPLICIT NONE
318    TYPE(axis), POINTER :: pt_axis
319     
320    IF (.NOT. pt_axis%has_name) THEN
321      IF (pt_axis%has_id) THEN
322        pt_axis%name=TRIM(pt_axis%id)
323      ELSE
324        WRITE(message,*) "Axis has no name and no id" 
325        CALL error("mod_axis::axis__check")
326      ENDIF
327    ENDIF
328 
329 END SUBROUTINE axis__Check
330
331END MODULE mod_axis
Note: See TracBrowser for help on using the repository browser.