source: XMLIO_V2/dev/common/src/xmlio/fortran/ixmlioserver.f03.in @ 219

Last change on this file since 219 was 219, checked in by hozdoba, 10 years ago

Préparation nouvelle arborescence

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   END INTERFACE
149
150   CONTAINS ! Fonctions disponibles pour les utilisateurs.
151
152   SUBROUTINE handle_create(ret, dtype, idt)
153      TYPE(XHandle), INTENT(OUT)     :: ret
154      INTEGER, INTENT(IN)            :: dtype
155      CHARACTER(len = *), INTENT(IN) :: idt
156      CALL xios_handle_create(ret%daddr, dtype, idt, len(idt))
157   END SUBROUTINE handle_create
158
159   SUBROUTINE set_timestep(timestep)
160      TYPE(XDuration), INTENT(IN):: timestep
161      CALL xios_set_timestep(timestep%year, timestep%month , timestep%day,   &
162                             timestep%hour, timestep%minute, timestep%second)
163   END SUBROUTINE set_timestep
164
165   SUBROUTINE update_calendar(step)
166      INTEGER, INTENT(IN):: step
167      IF (step < 1) THEN
168         PRINT *, "L'argument 'step' ne peut être négatif ou nul"
169         STOP
170      END IF
171      CALL xios_update_calendar(step)
172   END SUBROUTINE update_calendar
173
174   SUBROUTINE xml_tree_add(parent_hdl, parent_type, child_hdl, child_type, child_id)
175      TYPE(XHandle), INTENT(IN)                :: parent_hdl
176      TYPE(XHandle), INTENT(OUT)               :: child_hdl
177      INTEGER, INTENT(IN)                      :: child_type, parent_type
178      CHARACTER(len = *), OPTIONAL, INTENT(IN) :: child_id
179      child_hdl = NULLHANDLE
180
181      IF (PRESENT(child_id)) THEN
182         CALL xios_xml_tree_add(parent_hdl%daddr, parent_type, child_hdl%daddr, child_type, child_id, len(child_id))
183      ELSE
184         CALL xios_xml_tree_add(parent_hdl%daddr, parent_type, child_hdl%daddr, child_type, "NONE", -1)
185      END IF
186   END SUBROUTINE xml_tree_add
187
188   SUBROUTINE xml_tree_show(filename)
189      CHARACTER(len = *), OPTIONAL, INTENT(IN) :: filename
190      IF (PRESENT(filename)) THEN
191         CALL xios_xml_tree_show(filename, len(filename))
192      ELSE
193         CALL xios_xml_tree_show("NONE", -1)
194      END IF
195   END SUBROUTINE xml_tree_show
196
197   SUBROUTINE xml_parse_file(filename)
198      CHARACTER(len = *), INTENT(IN) :: filename
199      CALL xios_xml_Parse_File(filename, len(filename))
200   END SUBROUTINE xml_Parse_File
201
202   SUBROUTINE xml_parse_string(xmlcontent)
203      CHARACTER(len = *), INTENT(IN) :: xmlcontent
204      CALL xios_xml_Parse_String(xmlcontent, len(xmlcontent))
205   END SUBROUTINE xml_Parse_String
206
207   SUBROUTINE context_set_current(context, withswap)
208      TYPE(XHandle), INTENT(IN)                :: context
209      LOGICAL (kind = 1), OPTIONAL, INTENT(IN) :: withswap
210      LOGICAL (kind = 1)                       :: wswap
211      IF (PRESENT(withswap)) THEN
212         wswap = withswap
213      ELSE
214         wswap = .FALSE.
215      END IF
216      CALL xios_context_set_current(context%daddr, wswap)
217   END SUBROUTINE context_set_current
218
219   SUBROUTINE context_create(context_hdl, context_id, calendar_type, init_date)
220      TYPE(XHandle), INTENT(OUT)        :: context_hdl
221      CHARACTER(len = *), INTENT(IN)    :: context_id
222      INTEGER, INTENT(IN)               :: calendar_type
223      TYPE(XDate), INTENT(IN), OPTIONAL :: init_date
224      IF (PRESENT(init_date)) THEN
225         CALL xios_context_create(context_hdl%daddr, context_id, len(context_id), calendar_type, &
226                                  init_date%year, init_date%month, init_date%day,                &
227                                  init_date%hour, init_date%minute, init_date%second)
228      ELSE
229         CALL xios_context_create(context_hdl%daddr, context_id, len(context_id), calendar_type, &
230                                 0, 1, 1, 0, 0, 0)
231      END IF
232   END SUBROUTINE context_create
233
234   SUBROUTINE dtreatment_start(context_hdl, filetype, comm_client_server)
235      TYPE(XHandle), INTENT(IN), VALUE :: context_hdl
236      INTEGER, INTENT(IN), OPTIONAL    :: filetype, comm_client_server
237      INTEGER                          :: filetype_, comm_client_server_
238     
239      IF (PRESENT(filetype)) THEN
240         filetype_ = filetype
241      ELSE
242         filetype_ = NETCDF4
243      END IF
244     
245      IF (PRESENT(comm_client_server)) THEN
246         comm_client_server_ = comm_client_server
247      ELSE
248         comm_client_server_ = -1
249      END IF
250     
251      CALL context_set_current(context_hdl)
252      CALL xios_dtreatment_start(context_hdl%daddr, filetype_, comm_client_server_)
253   END SUBROUTINE dtreatment_start
254
255   SUBROUTINE dtreatment_end(context_hdl)
256      TYPE(XHandle), INTENT(IN), VALUE :: context_hdl
257      CALL context_set_current(context_hdl)
258      CALL xios_dtreatment_end()
259   END SUBROUTINE dtreatment_end
260
261   SUBROUTINE write_data (fieldid,                         &
262                          data1d_k8, data2d_k8, data3d_k8)
263      CHARACTER(len = *), INTENT(IN)                     :: fieldid
264      REAL(kind = 8), DIMENSION(*), OPTIONAL, INTENT(IN) :: data1d_k8(:), data2d_k8(:,:), data3d_k8(:,:,:)
265      IF((.NOT. PRESENT(data1d_k8)) .AND. &
266         (.NOT. PRESENT(data2d_k8)) .AND. &
267         (.NOT. PRESENT(data3d_k8))) THEN
268         PRINT *, "(F2003 interface) Veuillez spécifier des données à écrire !"
269         STOP
270      END IF
271      IF (PRESENT (data1d_k8)) THEN
272         CALL xios_write_data(fieldid, len(fieldid), data1d_k8, &
273                              size(data1d_k8, 1), -1, -1)
274      ELSE IF (PRESENT (data2d_k8)) THEN
275         CALL xios_write_data(fieldid, len(fieldid), data2d_k8, &
276                              size(data2d_k8, 1), size(data2d_k8, 2), -1)
277      ELSE IF (PRESENT (data3d_k8)) THEN
278         CALL xios_write_data(fieldid, len(fieldid), data3d_k8, &
279                              size(data3d_k8, 1), size(data3d_k8, 2), size(data3d_k8, 3))
280      END IF
281   END SUBROUTINE
282
283   SUBROUTINE  set_axis_attributes( axis_hdl, ftype &
284   #undef  DECLARE_ATTRIBUTE
285   #define DECLARE_ATTRIBUTE(type, name) arg_##type(name) &
286   #include "../config/axis_attribute.conf"
287   )
288
289      TYPE(XHandle) :: axis_hdl
290      INTEGER (kind = C_INT)      :: ftype
291      #undef  DECLARE_ATTRIBUTE
292      #define DECLARE_ATTRIBUTE(type, name) def_##type(name)
293      #include "../config/axis_attribute.conf"
294
295      #undef  DECLARE_ATTRIBUTE
296      #define DECLARE_ATTRIBUTE(type, name) ip_##type(axis, name)
297      #include "../config/axis_attribute.conf"
298
299   END SUBROUTINE set_axis_attributes
300
301   SUBROUTINE  set_field_attributes( field_hdl, ftype &
302   #undef  DECLARE_ATTRIBUTE
303   #define DECLARE_ATTRIBUTE(type, name) arg_##type(name) &
304   #include "../config/field_attribute.conf"
305   )
306
307      TYPE(XHandle) :: field_hdl
308      INTEGER (kind = C_INT)      :: ftype
309      #undef  DECLARE_ATTRIBUTE
310      #define DECLARE_ATTRIBUTE(type, name) def_##type(name)
311      #include "../config/field_attribute.conf"
312
313      #undef  DECLARE_ATTRIBUTE
314      #define DECLARE_ATTRIBUTE(type, name) ip_##type(field, name)
315      #include "../config/field_attribute.conf"
316
317   END SUBROUTINE set_field_attributes
318
319   SUBROUTINE  set_context_attributes( context_hdl, ftype &
320   #undef  DECLARE_ATTRIBUTE
321   #define DECLARE_ATTRIBUTE(type, name) arg_##type(name) &
322   #include "../config/context_attribute.conf"
323   )
324
325      TYPE(XHandle) :: context_hdl
326      INTEGER (kind = C_INT)      :: ftype
327      #undef  DECLARE_ATTRIBUTE
328      #define DECLARE_ATTRIBUTE(type, name) def_##type(name)
329      #include "../config/context_attribute.conf"
330
331      #undef  DECLARE_ATTRIBUTE
332      #define DECLARE_ATTRIBUTE(type, name) ip_##type(context, name)
333      #include "../config/context_attribute.conf"
334
335   END SUBROUTINE set_context_attributes
336
337   SUBROUTINE  set_domain_attributes( domain_hdl, ftype &
338   #undef  DECLARE_ATTRIBUTE
339   #define DECLARE_ATTRIBUTE(type, name) arg_##type(name) &
340   #include "../config/domain_attribute.conf"
341   )
342
343      TYPE(XHandle) :: domain_hdl
344      INTEGER (kind = C_INT)      :: ftype
345      #undef  DECLARE_ATTRIBUTE
346      #define DECLARE_ATTRIBUTE(type, name) def_##type(name)
347      #include "../config/domain_attribute.conf"
348
349      #undef  DECLARE_ATTRIBUTE
350      #define DECLARE_ATTRIBUTE(type, name) ip_##type(domain, name)
351      #include "../config/domain_attribute.conf"
352
353   END SUBROUTINE set_domain_attributes
354
355   SUBROUTINE  set_grid_attributes( grid_hdl, ftype &
356   #undef  DECLARE_ATTRIBUTE
357   #define DECLARE_ATTRIBUTE(type, name) arg_##type(name) &
358   #include "../config/grid_attribute.conf"
359   )
360
361      TYPE(XHandle) :: grid_hdl
362      INTEGER (kind = C_INT)      :: ftype
363      #undef  DECLARE_ATTRIBUTE
364      #define DECLARE_ATTRIBUTE(type, name) def_##type(name)
365      #include "../config/grid_attribute.conf"
366
367      #undef  DECLARE_ATTRIBUTE
368      #define DECLARE_ATTRIBUTE(type, name) ip_##type(grid, name)
369      #include "../config/grid_attribute.conf"
370
371   END SUBROUTINE set_grid_attributes
372
373   SUBROUTINE  set_file_attributes( file_hdl, ftype &
374   #undef  DECLARE_ATTRIBUTE
375   #define DECLARE_ATTRIBUTE(type, name) arg_##type(name) &
376   #include "../config/file_attribute.conf"
377   )
378
379      TYPE(XHandle) :: file_hdl
380      INTEGER (kind = C_INT)      :: ftype
381      #undef  DECLARE_ATTRIBUTE
382      #define DECLARE_ATTRIBUTE(type, name) def_##type(name)
383      #include "../config/file_attribute.conf"
384
385      #undef  DECLARE_ATTRIBUTE
386      #define DECLARE_ATTRIBUTE(type, name) ip_##type(file, name)
387      #include "../config/file_attribute.conf"
388
389   END SUBROUTINE set_file_attributes
390
391END MODULE IXMLIOSERVER
Note: See TracBrowser for help on using the repository browser.