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

Last change on this file since 179 was 179, checked in by hozdoba, 13 years ago
File size: 15.0 KB
Line 
1! --------------------------------------------- !
2!                 IXMLIOSERVER                  !
3!          GESTION DES ENTREES-SORTIES          !
4! --------------------------------------------- !
5
6#include "macro.inc"
7
8MODULE IXMLIOSERVER
9   USE, INTRINSIC :: 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, comm_client_server) 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, comm_client_server
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, comm_client_server)
236      TYPE(XHandle), INTENT(IN), VALUE :: context_hdl
237      INTEGER, INTENT(IN), OPTIONAL    :: filetype, comm_client_server
238      INTEGER                          :: filetype_, comm_client_server_
239     
240      IF (PRESENT(filetype)) THEN
241         filetype_ = filetype
242      ELSE
243         filetype_ = NETCDF4
244      END IF
245     
246      IF (PRESENT(comm_client_server)) THEN
247         comm_client_server_ = comm_client_server
248      ELSE
249         comm_client_server_ = -1
250      END IF
251     
252      CALL context_set_current(context_hdl)
253      CALL xios_dtreatment_start(context_hdl%daddr, filetype_, comm_client_server_)
254   END SUBROUTINE dtreatment_start
255
256   SUBROUTINE dtreatment_end(context_hdl)
257      TYPE(XHandle), INTENT(IN), VALUE :: context_hdl
258      CALL context_set_current(context_hdl)
259      CALL xios_dtreatment_end()
260   END SUBROUTINE dtreatment_end
261
262   SUBROUTINE write_data (fieldid,                         &
263                          data1d_k8, data2d_k8, data3d_k8)
264      CHARACTER(len = *), INTENT(IN)                     :: fieldid
265      REAL(kind = 8), DIMENSION(*), OPTIONAL, INTENT(IN) :: data1d_k8(:), data2d_k8(:,:), data3d_k8(:,:,:)
266      IF((.NOT. PRESENT(data1d_k8)) .AND. &
267         (.NOT. PRESENT(data2d_k8)) .AND. &
268         (.NOT. PRESENT(data3d_k8))) THEN
269         PRINT *, "(F2003 interface) Veuillez spécifier des données à écrire !"
270         STOP
271      END IF
272      IF (PRESENT (data1d_k8)) THEN
273         CALL xios_write_data(fieldid, len(fieldid), data1d_k8, &
274                              size(data1d_k8, 1), -1, -1)
275      ELSE IF (PRESENT (data2d_k8)) THEN
276         CALL xios_write_data(fieldid, len(fieldid), data2d_k8, &
277                              size(data2d_k8, 1), size(data2d_k8, 2), -1)
278      ELSE IF (PRESENT (data3d_k8)) THEN
279         CALL xios_write_data(fieldid, len(fieldid), data3d_k8, &
280                              size(data3d_k8, 1), size(data3d_k8, 2), size(data3d_k8, 3))
281      END IF
282   END SUBROUTINE
283
284   SUBROUTINE  set_axis_attributes( axis_hdl, ftype &
285   #undef  DECLARE_ATTRIBUTE
286   #define DECLARE_ATTRIBUTE(type, name) arg_##type(name) &
287   #include "../config/axis_attribute.conf"
288   )
289
290      TYPE(XHandle) :: axis_hdl
291      INTEGER (kind = C_INT)      :: ftype
292      #undef  DECLARE_ATTRIBUTE
293      #define DECLARE_ATTRIBUTE(type, name) def_##type(name)
294      #include "../config/axis_attribute.conf"
295
296      #undef  DECLARE_ATTRIBUTE
297      #define DECLARE_ATTRIBUTE(type, name) ip_##type(axis, name)
298      #include "../config/axis_attribute.conf"
299
300   END SUBROUTINE set_axis_attributes
301
302   SUBROUTINE  set_field_attributes( field_hdl, ftype &
303   #undef  DECLARE_ATTRIBUTE
304   #define DECLARE_ATTRIBUTE(type, name) arg_##type(name) &
305   #include "../config/field_attribute.conf"
306   )
307
308      TYPE(XHandle) :: field_hdl
309      INTEGER (kind = C_INT)      :: ftype
310      #undef  DECLARE_ATTRIBUTE
311      #define DECLARE_ATTRIBUTE(type, name) def_##type(name)
312      #include "../config/field_attribute.conf"
313
314      #undef  DECLARE_ATTRIBUTE
315      #define DECLARE_ATTRIBUTE(type, name) ip_##type(field, name)
316      #include "../config/field_attribute.conf"
317
318   END SUBROUTINE set_field_attributes
319
320   SUBROUTINE  set_context_attributes( context_hdl, ftype &
321   #undef  DECLARE_ATTRIBUTE
322   #define DECLARE_ATTRIBUTE(type, name) arg_##type(name) &
323   #include "../config/context_attribute.conf"
324   )
325
326      TYPE(XHandle) :: context_hdl
327      INTEGER (kind = C_INT)      :: ftype
328      #undef  DECLARE_ATTRIBUTE
329      #define DECLARE_ATTRIBUTE(type, name) def_##type(name)
330      #include "../config/context_attribute.conf"
331
332      #undef  DECLARE_ATTRIBUTE
333      #define DECLARE_ATTRIBUTE(type, name) ip_##type(context, name)
334      #include "../config/context_attribute.conf"
335
336   END SUBROUTINE set_context_attributes
337
338   SUBROUTINE  set_domain_attributes( domain_hdl, ftype &
339   #undef  DECLARE_ATTRIBUTE
340   #define DECLARE_ATTRIBUTE(type, name) arg_##type(name) &
341   #include "../config/domain_attribute.conf"
342   )
343
344      TYPE(XHandle) :: domain_hdl
345      INTEGER (kind = C_INT)      :: ftype
346      #undef  DECLARE_ATTRIBUTE
347      #define DECLARE_ATTRIBUTE(type, name) def_##type(name)
348      #include "../config/domain_attribute.conf"
349
350      #undef  DECLARE_ATTRIBUTE
351      #define DECLARE_ATTRIBUTE(type, name) ip_##type(domain, name)
352      #include "../config/domain_attribute.conf"
353
354   END SUBROUTINE set_domain_attributes
355
356   SUBROUTINE  set_grid_attributes( grid_hdl, ftype &
357   #undef  DECLARE_ATTRIBUTE
358   #define DECLARE_ATTRIBUTE(type, name) arg_##type(name) &
359   #include "../config/grid_attribute.conf"
360   )
361
362      TYPE(XHandle) :: grid_hdl
363      INTEGER (kind = C_INT)      :: ftype
364      #undef  DECLARE_ATTRIBUTE
365      #define DECLARE_ATTRIBUTE(type, name) def_##type(name)
366      #include "../config/grid_attribute.conf"
367
368      #undef  DECLARE_ATTRIBUTE
369      #define DECLARE_ATTRIBUTE(type, name) ip_##type(grid, name)
370      #include "../config/grid_attribute.conf"
371
372   END SUBROUTINE set_grid_attributes
373
374   SUBROUTINE  set_file_attributes( file_hdl, ftype &
375   #undef  DECLARE_ATTRIBUTE
376   #define DECLARE_ATTRIBUTE(type, name) arg_##type(name) &
377   #include "../config/file_attribute.conf"
378   )
379
380      TYPE(XHandle) :: file_hdl
381      INTEGER (kind = C_INT)      :: ftype
382      #undef  DECLARE_ATTRIBUTE
383      #define DECLARE_ATTRIBUTE(type, name) def_##type(name)
384      #include "../config/file_attribute.conf"
385
386      #undef  DECLARE_ATTRIBUTE
387      #define DECLARE_ATTRIBUTE(type, name) ip_##type(file, name)
388      #include "../config/file_attribute.conf"
389
390   END SUBROUTINE set_file_attributes
391
392END MODULE IXMLIOSERVER
Note: See TracBrowser for help on using the repository browser.