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