New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
mod_axis.f90 in vendors/XMLIO_SERVER/current/src/XMLIO – NEMO

source: vendors/XMLIO_SERVER/current/src/XMLIO/mod_axis.f90 @ 1897

Last change on this file since 1897 was 1897, checked in by flavoni, 14 years ago

importing XMLIO_SERVER vendor
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,   &
195                      ' : Attribute type is incompatible with the provided value'
196     CALL error('mod_axis::axis__set_attribut')
197   
198  END SUBROUTINE axis__set_attribut_pt
199 
200  SUBROUTINE axis__print(pt_axis)
201  IMPLICIT NONE
202    TYPE(axis), POINTER         :: pt_axis
203
204    PRINT *,"---- AXIS ----"
205    IF (pt_axis%has_id) THEN
206      PRINT *,"id = ",TRIM(pt_axis%id)
207    ELSE
208      PRINT *,"id undefined"
209    ENDIF
210   
211    IF (pt_axis%has_name) THEN
212      PRINT *,"name = ",TRIM(pt_axis%name)
213    ELSE
214      PRINT *,"name undefined"
215    ENDIF
216   
217    IF (pt_axis%has_description) THEN
218      PRINT *,"description = ",TRIM(pt_axis%description)
219    ELSE
220      PRINT *,"description undefined"
221    ENDIF
222 
223    IF (pt_axis%has_unit) THEN
224      PRINT *,"unit = ",TRIM(pt_axis%unit)
225    ELSE
226      PRINT *,"unit undefined"
227    ENDIF
228
229    IF (pt_axis%has_size) THEN
230      PRINT *,"size = ",pt_axis%size
231    ELSE
232      PRINT *,"size undefined"
233    ENDIF
234
235    IF (pt_axis%has_values) THEN
236      PRINT *,"values = ",pt_axis%values
237    ELSE
238      PRINT *,"values undefined"
239    ENDIF
240
241    IF (pt_axis%has_positive) THEN
242      PRINT *,"positive = ",pt_axis%positive
243    ELSE
244      PRINT *,"positive undefined"
245    ENDIF
246
247  END SUBROUTINE axis__print
248
249
250  SUBROUTINE axis__apply_default(pt_axis_default, pt_axis_in, pt_axis_out)
251
252    TYPE(axis), POINTER :: pt_axis_default, pt_axis_in, pt_axis_out
253
254    IF (pt_axis_in%has_name) THEN
255        pt_axis_out%name=pt_axis_in%name
256        pt_axis_out%has_name=.TRUE.
257    ELSE IF ( pt_axis_default%has_name) THEN
258        pt_axis_out%name=pt_axis_default%name
259        pt_axis_out%has_name=.TRUE.
260    ELSE
261        pt_axis_out%has_name=.FALSE.
262    ENDIF
263       
264    IF (pt_axis_in%has_description) THEN
265        pt_axis_out%description=pt_axis_in%description
266        pt_axis_out%has_description=.TRUE.
267    ELSE IF ( pt_axis_default%has_description ) THEN
268        pt_axis_out%description=pt_axis_default%description
269        pt_axis_out%has_description=.TRUE.
270    ELSE
271        pt_axis_out%has_description=.FALSE.
272    ENDIF
273
274    IF (pt_axis_in%has_unit) THEN
275        pt_axis_out%unit=pt_axis_in%unit
276        pt_axis_out%has_unit=.TRUE.
277    ELSE IF ( pt_axis_default%has_unit ) THEN
278        pt_axis_out%unit=pt_axis_default%unit
279        pt_axis_out%has_unit=.TRUE.
280    ELSE
281        pt_axis_out%has_unit=.FALSE.
282    ENDIF
283
284    IF (pt_axis_in%has_size) THEN
285        pt_axis_out%size=pt_axis_in%size
286        pt_axis_out%has_size=.TRUE.
287    ELSE IF ( pt_axis_default%has_size ) THEN
288        pt_axis_out%size=pt_axis_default%size
289        pt_axis_out%has_size=.TRUE.
290    ELSE
291        pt_axis_out%has_size=.FALSE.
292    ENDIF
293
294    IF (pt_axis_in%has_values) THEN
295        pt_axis_out%values(:)=pt_axis_in%values(:)
296        pt_axis_out%has_values=.TRUE.
297    ELSE IF ( pt_axis_default%has_values ) THEN
298        pt_axis_out%values(:)=pt_axis_default%values(:)
299        pt_axis_out%has_values=.TRUE.
300    ELSE
301        pt_axis_out%has_values=.FALSE.
302    ENDIF
303
304    IF (pt_axis_in%has_positive) THEN
305        pt_axis_out%positive=pt_axis_in%positive
306        pt_axis_out%has_positive=.TRUE.
307    ELSE IF ( pt_axis_default%has_positive ) THEN
308        pt_axis_out%positive=pt_axis_default%positive
309        pt_axis_out%has_positive=.TRUE.
310    ELSE
311        pt_axis_out%has_positive=.FALSE.
312    ENDIF
313   
314  END SUBROUTINE axis__apply_default
315
316  SUBROUTINE axis__check(pt_axis)
317  USE error_msg
318  IMPLICIT NONE
319    TYPE(axis), POINTER :: pt_axis
320     
321    IF (.NOT. pt_axis%has_name) THEN
322      IF (pt_axis%has_id) THEN
323        pt_axis%name=TRIM(pt_axis%id)
324      ELSE
325        WRITE(message,*) "Axis has no name and no id" 
326        CALL error("mod_axis::axis__check")
327      ENDIF
328    ENDIF
329 
330 END SUBROUTINE axis__Check
331
332END MODULE mod_axis
Note: See TracBrowser for help on using the repository browser.