source: XMLIO_V2/dev/dev_rv/src/fortran/ixmlioserver.f03.in @ 141

Last change on this file since 141 was 141, checked in by hozdoba, 13 years ago

Mise à jour depuis un autre dépôt
File size: 14.7 KB
Line 
1! --------------------------------------------- !
2!                 IXMLIOSERVER                  !
3!          GESTION DES ENTREES-SORTIES          !
4! --------------------------------------------- !
5
6#include "macro.inc"
7
8MODULE IXMLIOSERVER
9   USE ISO_C_BINDING
10
11   ! Ne jamais modifier les valeurs internes de ce type dans le code fortran.
12   TYPE XHandle
13      INTEGER(kind = C_INTPTR_T) :: daddr
14   END TYPE XHandle
15
16   ! enum XDType
17   INTEGER(kind = C_INT), PARAMETER  :: NOTYPE = 0
18   INTEGER(kind = C_INT), PARAMETER  :: DTREATMENT = 1, DDATE = 2, CALENDAR = 3, ECONTEXT = 4
19   INTEGER(kind = C_INT), PARAMETER  :: EAXIS = 5 , EDOMAIN = 6 , EFIELD = 7 , EFILE = 8 , EGRID = 9
20   INTEGER(kind = C_INT), PARAMETER  :: GAXIS = 10, GDOMAIN = 11, GFIELD = 12, GFILE = 13, GGRID = 14
21
22   ! enum XCalendarType
23   INTEGER(kind = C_INT), PARAMETER  :: D360 = 0 , ALLLEAP = 1 , NOLEAP = 2 , JULIAN = 3 , GREGORIAN = 4
24
25   TYPE XDate
26      INTEGER :: year, month, day, hour, minute, second
27   END TYPE XDate
28
29   TYPE XDuration
30      REAL(kind = 8) :: year, month, day, hour, minute, second
31   END TYPE XDuration
32
33   ! Autres constantes
34   TYPE(XHandle)  , PARAMETER :: NULLHANDLE = XHandle(0)
35
36   INTERFACE ! Ne pas appeler directement/Interface FORTRAN 2003 <-> C99
37
38      SUBROUTINE xios_handle_create(ret, dtype, idt, idt_size) BIND(C)
39         import C_CHAR, C_INTPTR_T, C_INT
40         INTEGER  (kind = C_INTPTR_T)             :: ret
41         INTEGER  (kind = C_INT), VALUE         :: dtype
42         CHARACTER(kind = C_CHAR), DIMENSION(*) :: idt
43         INTEGER  (kind = C_INT), VALUE         :: idt_size
44      END SUBROUTINE xios_handle_create
45
46      SUBROUTINE xios_set_timestep(ts_year, ts_month, ts_day,          &
47                                   ts_hour, ts_minute, ts_second) BIND(C)
48         import C_DOUBLE
49         REAL (kind = C_DOUBLE), VALUE :: ts_year, ts_month, ts_day,   &
50                                          ts_hour, ts_minute, ts_second
51      END SUBROUTINE xios_set_timestep
52
53      SUBROUTINE xios_update_calendar(step) BIND(C)
54         import C_INT
55         INTEGER  (kind = C_INT), VALUE :: step
56      END SUBROUTINE xios_update_calendar
57
58      SUBROUTINE xios_xml_tree_add(parent_, parent_type, child_, child_type, child_id, child_id_size) BIND(C)
59         import C_CHAR, C_INT, C_INTPTR_T
60         INTEGER  (kind = C_INTPTR_T), VALUE    :: parent_
61         INTEGER  (kind = C_INT), VALUE         :: parent_type
62         INTEGER  (kind = C_INTPTR_T)           :: child_
63         INTEGER  (kind = C_INT), VALUE         :: child_type
64         CHARACTER(kind = C_CHAR), DIMENSION(*) :: child_id
65         INTEGER  (kind = C_INT), VALUE         :: child_id_size
66      END SUBROUTINE xios_xml_tree_add
67
68      SUBROUTINE  xios_xml_tree_show(filename, filename_size) BIND(C)
69         import C_CHAR, C_INT
70         CHARACTER(kind = C_CHAR), DIMENSION(*) :: filename
71         INTEGER  (kind = C_INT), VALUE         :: filename_size
72      END SUBROUTINE xios_xml_tree_show
73
74      SUBROUTINE xios_xml_parse_file(filename, filename_size) BIND(C)
75         import C_CHAR, C_INT
76         CHARACTER(kind = C_CHAR), DIMENSION(*) :: filename
77         INTEGER  (kind = C_INT), VALUE         :: filename_size
78      END SUBROUTINE xios_xml_Parse_File
79
80      SUBROUTINE xios_xml_parse_string(xmlcontent, xmlcontent_size) BIND(C)
81         import C_CHAR, C_INT
82         CHARACTER(kind = C_CHAR), DIMENSION(*) :: xmlcontent
83         INTEGER  (kind = C_INT), VALUE         :: xmlcontent_size
84      END SUBROUTINE xios_xml_Parse_String
85
86      SUBROUTINE xios_context_set_current(context, withswap) BIND(C)
87         import C_BOOL, C_INT, C_INTPTR_T
88         INTEGER  (kind = C_INTPTR_T), VALUE :: context
89         LOGICAL (kind = C_BOOL), VALUE      :: withswap
90      END SUBROUTINE xios_context_set_current
91
92      SUBROUTINE xios_context_create(context, context_id, context_id_size, calendar_type, &
93                                     year, month, day, hour, minute, second) BIND(C)
94         import C_CHAR, C_INT, C_INTPTR_T
95         INTEGER  (kind = C_INTPTR_T)           :: context
96         CHARACTER(kind = C_CHAR), DIMENSION(*) :: context_id
97         INTEGER  (kind = C_INT), VALUE         :: context_id_size
98         INTEGER  (kind = C_INT), VALUE         :: calendar_type, year, month, day, hour, minute, second
99      END SUBROUTINE xios_context_create
100
101      SUBROUTINE xios_dtreatment_start(context_hdl, filetype) BIND(C)
102         import C_INTPTR_T, C_INT
103         INTEGER  (kind = C_INTPTR_T), VALUE  :: context_hdl
104         INTEGER  (kind = C_INT), VALUE       :: filetype
105      END SUBROUTINE xios_dtreatment_start
106
107      SUBROUTINE xios_dtreatment_end() BIND(C)
108         ! Sans argument
109      END SUBROUTINE xios_dtreatment_end
110
111      SUBROUTINE xios_write_data(fieldid, fieldid_size, data_k8, data_Xsize, data_Ysize, data_Zsize) BIND(C)
112         import C_INT, C_CHAR, C_PTR, C_FLOAT, C_DOUBLE, C_BOOL
113         CHARACTER(kind = C_CHAR), DIMENSION(*) :: fieldid
114         INTEGER  (kind = C_INT),  VALUE        :: fieldid_size
115         REAL(kind = C_DOUBLE), DIMENSION(*)    :: data_k8
116         INTEGER  (kind = C_INT), VALUE         :: data_Xsize, data_Ysize, data_Zsize
117      END SUBROUTINE xios_write_data
118
119#define DECLARE_ATTRIBUTE(type, name) \
120        DECLARE_INTERFACE(axis, type, name)
121#include "../config/axis_attribute.conf"
122
123#undef  DECLARE_ATTRIBUTE
124#define DECLARE_ATTRIBUTE(type, name) \
125        DECLARE_INTERFACE(field, type, name)
126#include "../config/field_attribute.conf"
127
128#undef  DECLARE_ATTRIBUTE
129#define DECLARE_ATTRIBUTE(type, name) \
130        DECLARE_INTERFACE(context, type, name)
131#include "../config/context_attribute.conf"
132
133#undef  DECLARE_ATTRIBUTE
134#define DECLARE_ATTRIBUTE(type, name) \
135        DECLARE_INTERFACE(domain, type, name)
136#include "../config/domain_attribute.conf"
137
138#undef  DECLARE_ATTRIBUTE
139#define DECLARE_ATTRIBUTE(type, name) \
140        DECLARE_INTERFACE(file, type, name)
141#include "../config/file_attribute.conf"
142
143#undef  DECLARE_ATTRIBUTE
144#define DECLARE_ATTRIBUTE(type, name) \
145        DECLARE_INTERFACE(grid, type, name)
146#include "../config/grid_attribute.conf"
147
148
149   END INTERFACE
150
151   CONTAINS ! Fonctions disponibles pour les utilisateurs.
152
153   SUBROUTINE handle_create(ret, dtype, idt)
154      TYPE(XHandle), INTENT(OUT)     :: ret
155      INTEGER, INTENT(IN)            :: dtype
156      CHARACTER(len = *), INTENT(IN) :: idt
157      CALL xios_handle_create(ret%daddr, dtype, idt, len(idt))
158   END SUBROUTINE handle_create
159
160   SUBROUTINE set_timestep(timestep)
161      TYPE(XDuration), INTENT(IN):: timestep
162      CALL xios_set_timestep(timestep%year, timestep%month , timestep%day,   &
163                             timestep%hour, timestep%minute, timestep%second)
164   END SUBROUTINE set_timestep
165
166   SUBROUTINE update_calendar(step)
167      INTEGER, INTENT(IN):: step
168      IF (step < 1) THEN
169         PRINT *, "L'argument 'step' ne peut être négatif ou nul"
170         STOP
171      END IF
172      CALL xios_update_calendar(step)
173   END SUBROUTINE update_calendar
174
175   SUBROUTINE xml_tree_add(parent_hdl, parent_type, child_hdl, child_type, child_id)
176      TYPE(XHandle), INTENT(IN)                :: parent_hdl
177      TYPE(XHandle), INTENT(OUT)               :: child_hdl
178      INTEGER, INTENT(IN)                      :: child_type, parent_type
179      CHARACTER(len = *), OPTIONAL, INTENT(IN) :: child_id
180      child_hdl = NULLHANDLE
181
182      IF (PRESENT(child_id)) THEN
183         CALL xios_xml_tree_add(parent_hdl%daddr, parent_type, child_hdl%daddr, child_type, child_id, len(child_id))
184      ELSE
185         CALL xios_xml_tree_add(parent_hdl%daddr, parent_type, child_hdl%daddr, child_type, "NONE", -1)
186      END IF
187   END SUBROUTINE xml_tree_add
188
189   SUBROUTINE xml_tree_show(filename)
190      CHARACTER(len = *), OPTIONAL, INTENT(IN) :: filename
191      IF (PRESENT(filename)) THEN
192         CALL xios_xml_tree_show(filename, len(filename))
193      ELSE
194         CALL xios_xml_tree_show("NONE", -1)
195      END IF
196   END SUBROUTINE xml_tree_show
197
198   SUBROUTINE xml_parse_file(filename)
199      CHARACTER(len = *), INTENT(IN) :: filename
200      CALL xios_xml_Parse_File(filename, len(filename))
201   END SUBROUTINE xml_Parse_File
202
203   SUBROUTINE xml_parse_string(xmlcontent)
204      CHARACTER(len = *), INTENT(IN) :: xmlcontent
205      CALL xios_xml_Parse_String(xmlcontent, len(xmlcontent))
206   END SUBROUTINE xml_Parse_String
207
208   SUBROUTINE context_set_current(context, withswap)
209      TYPE(XHandle), INTENT(IN)                :: context
210      LOGICAL (kind = 1), OPTIONAL, INTENT(IN) :: withswap
211      LOGICAL (kind = 1)                       :: wswap
212      IF (PRESENT(withswap)) THEN
213         wswap = withswap
214      ELSE
215         wswap = .FALSE.
216      END IF
217      CALL xios_context_set_current(context%daddr, wswap)
218   END SUBROUTINE context_set_current
219
220   SUBROUTINE context_create(context_hdl, context_id, calendar_type, init_date)
221      TYPE(XHandle), INTENT(OUT)        :: context_hdl
222      CHARACTER(len = *), INTENT(IN)    :: context_id
223      INTEGER, INTENT(IN)               :: calendar_type
224      TYPE(XDate), INTENT(IN), OPTIONAL :: init_date
225      IF (PRESENT(init_date)) THEN
226         CALL xios_context_create(context_hdl%daddr, context_id, len(context_id), calendar_type, &
227                                  init_date%year, init_date%month, init_date%day,                &
228                                  init_date%hour, init_date%minute, init_date%second)
229      ELSE
230         CALL xios_context_create(context_hdl%daddr, context_id, len(context_id), calendar_type, &
231                                 0, 1, 1, 0, 0, 0)
232      END IF
233   END SUBROUTINE context_create
234
235   SUBROUTINE dtreatment_start(context_hdl, filetype)
236      TYPE(XHandle), INTENT(IN), VALUE :: context_hdl
237      INTEGER, INTENT(IN), OPTIONAL    :: filetype
238      INTEGER                          :: filetype_
239      IF (PRESENT(filetype)) THEN
240         filetype_ = filetype
241      ELSE
242         filetype_ = NETCDF4
243      END IF
244         CALL context_set_current(context_hdl)
245         CALL xios_dtreatment_start(context_hdl%daddr, filetype_)
246   END SUBROUTINE dtreatment_start
247
248   SUBROUTINE dtreatment_end(context_hdl)
249      TYPE(XHandle), INTENT(IN), VALUE :: context_hdl
250      CALL context_set_current(context_hdl)
251      CALL xios_dtreatment_end()
252   END SUBROUTINE dtreatment_end
253
254   SUBROUTINE write_data (fieldid,                         &
255                          data1d_k8, data2d_k8, data3d_k8)
256      CHARACTER(len = *), INTENT(IN)                     :: fieldid
257      REAL(kind = 8), DIMENSION(*), OPTIONAL, INTENT(IN) :: data1d_k8(:), data2d_k8(:,:), data3d_k8(:,:,:)
258      IF((.NOT. PRESENT(data1d_k8)) .AND. &
259         (.NOT. PRESENT(data2d_k8)) .AND. &
260         (.NOT. PRESENT(data3d_k8))) THEN
261         PRINT *, "(F2003 interface) Veuillez spécifier des données à écrire !"
262         STOP
263      END IF
264      IF (PRESENT (data1d_k8)) THEN
265         CALL xios_write_data(fieldid, len(fieldid), data1d_k8, &
266                              size(data1d_k8, 1), -1, -1)
267      ELSE IF (PRESENT (data2d_k8)) THEN
268         CALL xios_write_data(fieldid, len(fieldid), data2d_k8, &
269                              size(data2d_k8, 1), size(data2d_k8, 2), -1)
270      ELSE IF (PRESENT (data3d_k8)) THEN
271         CALL xios_write_data(fieldid, len(fieldid), data3d_k8, &
272                              size(data3d_k8, 1), size(data3d_k8, 2), size(data3d_k8, 3))
273      END IF
274   END SUBROUTINE
275
276   SUBROUTINE  set_axis_attributes( axis_hdl, ftype &
277   #undef  DECLARE_ATTRIBUTE
278   #define DECLARE_ATTRIBUTE(type, name) arg_##type(name) &
279   #include "../config/axis_attribute.conf"
280   )
281
282      TYPE(XHandle) :: axis_hdl
283      INTEGER (kind = C_INT)      :: ftype
284      #undef  DECLARE_ATTRIBUTE
285      #define DECLARE_ATTRIBUTE(type, name) def_##type(name)
286      #include "../config/axis_attribute.conf"
287
288      #undef  DECLARE_ATTRIBUTE
289      #define DECLARE_ATTRIBUTE(type, name) ip_##type(axis, name)
290      #include "../config/axis_attribute.conf"
291
292   END SUBROUTINE set_axis_attributes
293
294   SUBROUTINE  set_field_attributes( field_hdl, ftype &
295   #undef  DECLARE_ATTRIBUTE
296   #define DECLARE_ATTRIBUTE(type, name) arg_##type(name) &
297   #include "../config/field_attribute.conf"
298   )
299
300      TYPE(XHandle) :: field_hdl
301      INTEGER (kind = C_INT)      :: ftype
302      #undef  DECLARE_ATTRIBUTE
303      #define DECLARE_ATTRIBUTE(type, name) def_##type(name)
304      #include "../config/field_attribute.conf"
305
306      #undef  DECLARE_ATTRIBUTE
307      #define DECLARE_ATTRIBUTE(type, name) ip_##type(field, name)
308      #include "../config/field_attribute.conf"
309
310   END SUBROUTINE set_field_attributes
311
312   SUBROUTINE  set_context_attributes( context_hdl, ftype &
313   #undef  DECLARE_ATTRIBUTE
314   #define DECLARE_ATTRIBUTE(type, name) arg_##type(name) &
315   #include "../config/context_attribute.conf"
316   )
317
318      TYPE(XHandle) :: context_hdl
319      INTEGER (kind = C_INT)      :: ftype
320      #undef  DECLARE_ATTRIBUTE
321      #define DECLARE_ATTRIBUTE(type, name) def_##type(name)
322      #include "../config/context_attribute.conf"
323
324      #undef  DECLARE_ATTRIBUTE
325      #define DECLARE_ATTRIBUTE(type, name) ip_##type(context, name)
326      #include "../config/context_attribute.conf"
327
328   END SUBROUTINE set_context_attributes
329
330   SUBROUTINE  set_domain_attributes( domain_hdl, ftype &
331   #undef  DECLARE_ATTRIBUTE
332   #define DECLARE_ATTRIBUTE(type, name) arg_##type(name) &
333   #include "../config/domain_attribute.conf"
334   )
335
336      TYPE(XHandle) :: domain_hdl
337      INTEGER (kind = C_INT)      :: ftype
338      #undef  DECLARE_ATTRIBUTE
339      #define DECLARE_ATTRIBUTE(type, name) def_##type(name)
340      #include "../config/domain_attribute.conf"
341
342      #undef  DECLARE_ATTRIBUTE
343      #define DECLARE_ATTRIBUTE(type, name) ip_##type(domain, name)
344      #include "../config/domain_attribute.conf"
345
346   END SUBROUTINE set_domain_attributes
347
348   SUBROUTINE  set_grid_attributes( grid_hdl, ftype &
349   #undef  DECLARE_ATTRIBUTE
350   #define DECLARE_ATTRIBUTE(type, name) arg_##type(name) &
351   #include "../config/grid_attribute.conf"
352   )
353
354      TYPE(XHandle) :: grid_hdl
355      INTEGER (kind = C_INT)      :: ftype
356      #undef  DECLARE_ATTRIBUTE
357      #define DECLARE_ATTRIBUTE(type, name) def_##type(name)
358      #include "../config/grid_attribute.conf"
359
360      #undef  DECLARE_ATTRIBUTE
361      #define DECLARE_ATTRIBUTE(type, name) ip_##type(grid, name)
362      #include "../config/grid_attribute.conf"
363
364   END SUBROUTINE set_grid_attributes
365
366   SUBROUTINE  set_file_attributes( file_hdl, ftype &
367   #undef  DECLARE_ATTRIBUTE
368   #define DECLARE_ATTRIBUTE(type, name) arg_##type(name) &
369   #include "../config/file_attribute.conf"
370   )
371
372      TYPE(XHandle) :: file_hdl
373      INTEGER (kind = C_INT)      :: ftype
374      #undef  DECLARE_ATTRIBUTE
375      #define DECLARE_ATTRIBUTE(type, name) def_##type(name)
376      #include "../config/file_attribute.conf"
377
378      #undef  DECLARE_ATTRIBUTE
379      #define DECLARE_ATTRIBUTE(type, name) ip_##type(file, name)
380      #include "../config/file_attribute.conf"
381
382   END SUBROUTINE set_file_attributes
383
384END MODULE IXMLIOSERVER
Note: See TracBrowser for help on using the repository browser.