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

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

Corrections après tests sur titane
File size: 16.1 KB
Line 
1! --------------------------------------------- !
2!                 IXMLIOSERVER                  !
3!          GESTION DES ENTREES-SORTIES          !
4! --------------------------------------------- !
5
6#include "macro.inc"
7
8MODULE XIOS
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_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      SUBROUTINE xios_write_data_f(fieldid, fieldid_size, data_k4, data_Xsize, data_Ysize, data_Zsize) BIND(C)
120         import C_INT, C_CHAR, C_PTR, C_FLOAT, C_BOOL
121         CHARACTER(kind = C_CHAR), DIMENSION(*) :: fieldid
122         INTEGER  (kind = C_INT),  VALUE        :: fieldid_size
123         REAL(kind = C_FLOAT), DIMENSION(*)     :: data_k4
124         INTEGER  (kind = C_INT), VALUE         :: data_Xsize, data_Ysize, data_Zsize
125      END SUBROUTINE xios_write_data_f
126
127      SUBROUTINE  xios_init_ioserver(comm_client) BIND(C)
128         import C_INT
129         INTEGER  (kind = C_INT) :: comm_client
130      END SUBROUTINE xios_init_ioserver
131
132#define DECLARE_ATTRIBUTE(type, name) \
133        DECLARE_INTERFACE(axis, type, name)
134#include "../config/axis_attribute.conf"
135
136#undef  DECLARE_ATTRIBUTE
137#define DECLARE_ATTRIBUTE(type, name) \
138        DECLARE_INTERFACE(field, type, name)
139#include "../config/field_attribute.conf"
140
141#undef  DECLARE_ATTRIBUTE
142#define DECLARE_ATTRIBUTE(type, name) \
143        DECLARE_INTERFACE(context, type, name)
144#include "../config/context_attribute.conf"
145
146#undef  DECLARE_ATTRIBUTE
147#define DECLARE_ATTRIBUTE(type, name) \
148        DECLARE_INTERFACE(domain, type, name)
149#include "../config/domain_attribute.conf"
150
151#undef  DECLARE_ATTRIBUTE
152#define DECLARE_ATTRIBUTE(type, name) \
153        DECLARE_INTERFACE(file, type, name)
154#include "../config/file_attribute.conf"
155
156#undef  DECLARE_ATTRIBUTE
157#define DECLARE_ATTRIBUTE(type, name) \
158        DECLARE_INTERFACE(grid, type, name)
159#include "../config/grid_attribute.conf"
160
161   END INTERFACE
162
163   CONTAINS ! Fonctions disponibles pour les utilisateurs.
164
165   SUBROUTINE  init_ioserver(comm_client)
166      INTEGER, INTENT(INOUT) :: comm_client
167      CALL xios_init_ioserver(comm_client)
168   END SUBROUTINE init_ioserver
169
170   SUBROUTINE handle_create(ret, dtype, idt)
171      TYPE(XHandle), INTENT(OUT)     :: ret
172      INTEGER, INTENT(IN)            :: dtype
173      CHARACTER(len = *), INTENT(IN) :: idt
174      CALL xios_handle_create(ret%daddr, dtype, idt, len(idt))
175   END SUBROUTINE handle_create
176
177   SUBROUTINE set_timestep(timestep)
178      TYPE(XDuration), INTENT(IN):: timestep
179      CALL xios_set_timestep(timestep%year, timestep%month , timestep%day,   &
180                             timestep%hour, timestep%minute, timestep%second)
181   END SUBROUTINE set_timestep
182
183   SUBROUTINE update_calendar(step)
184      INTEGER, INTENT(IN):: step
185      CALL xios_update_calendar(step)
186   END SUBROUTINE update_calendar
187
188   SUBROUTINE xml_tree_add(parent_hdl, parent_type, child_hdl, child_type, child_id)
189      TYPE(XHandle), INTENT(IN)                :: parent_hdl
190      TYPE(XHandle), INTENT(OUT)               :: child_hdl
191      INTEGER, INTENT(IN)                      :: child_type, parent_type
192      CHARACTER(len = *), OPTIONAL, INTENT(IN) :: child_id
193      child_hdl = NULLHANDLE
194
195      IF (PRESENT(child_id)) THEN
196         CALL xios_xml_tree_add(parent_hdl%daddr, parent_type, child_hdl%daddr, child_type, child_id, len(child_id))
197      ELSE
198         CALL xios_xml_tree_add(parent_hdl%daddr, parent_type, child_hdl%daddr, child_type, "NONE", -1)
199      END IF
200   END SUBROUTINE xml_tree_add
201
202   SUBROUTINE xml_tree_show(filename)
203      CHARACTER(len = *), OPTIONAL, INTENT(IN) :: filename
204      IF (PRESENT(filename)) THEN
205         CALL xios_xml_tree_show(filename, len(filename))
206      ELSE
207         CALL xios_xml_tree_show("NONE", -1)
208      END IF
209   END SUBROUTINE xml_tree_show
210
211   SUBROUTINE xml_parse_file(filename)
212      CHARACTER(len = *), INTENT(IN) :: filename
213      CALL xios_xml_Parse_File(filename, len(filename))
214   END SUBROUTINE xml_Parse_File
215
216   SUBROUTINE xml_parse_string(xmlcontent)
217      CHARACTER(len = *), INTENT(IN) :: xmlcontent
218      CALL xios_xml_Parse_String(xmlcontent, len(xmlcontent))
219   END SUBROUTINE xml_Parse_String
220
221   SUBROUTINE context_set_current(context, withswap)
222      TYPE(XHandle), INTENT(IN)                :: context
223      LOGICAL (kind = 1), OPTIONAL, INTENT(IN) :: withswap
224      LOGICAL (kind = 1)                       :: wswap
225      IF (PRESENT(withswap)) THEN
226         wswap = withswap
227      ELSE
228         wswap = .FALSE.
229      END IF
230      CALL xios_context_set_current(context%daddr, wswap)
231   END SUBROUTINE context_set_current
232
233   SUBROUTINE context_create(context_hdl, context_id, calendar_type, init_date)
234      TYPE(XHandle), INTENT(OUT)        :: context_hdl
235      CHARACTER(len = *), INTENT(IN)    :: context_id
236      INTEGER, INTENT(IN)               :: calendar_type
237      TYPE(XDate), INTENT(IN), OPTIONAL :: init_date
238      IF (PRESENT(init_date)) THEN
239         CALL xios_context_create(context_hdl%daddr, context_id, len(context_id), calendar_type, &
240                                  init_date%year, init_date%month, init_date%day,                &
241                                  init_date%hour, init_date%minute, init_date%second)
242      ELSE
243         CALL xios_context_create(context_hdl%daddr, context_id, len(context_id), calendar_type, &
244                                 0, 1, 1, 0, 0, 0)
245      END IF
246   END SUBROUTINE context_create
247
248   SUBROUTINE dtreatment_start(context_hdl, filetype, comm_client_server)
249      TYPE(XHandle), INTENT(IN), VALUE :: context_hdl
250      INTEGER, INTENT(IN), OPTIONAL    :: filetype, comm_client_server
251      INTEGER                          :: filetype_, comm_client_server_
252     
253      IF (PRESENT(filetype)) THEN
254         filetype_ = filetype
255      ELSE
256         filetype_ = NETCDF4
257      END IF
258     
259      IF (PRESENT(comm_client_server)) THEN
260         comm_client_server_ = comm_client_server
261      ELSE
262         comm_client_server_ = -1
263      END IF
264     
265      CALL context_set_current(context_hdl)
266      CALL xios_dtreatment_start(context_hdl%daddr, filetype_, comm_client_server_)
267   END SUBROUTINE dtreatment_start
268
269   SUBROUTINE dtreatment_end(context_hdl)
270      TYPE(XHandle), INTENT(IN), VALUE :: context_hdl
271      !CALL context_set_current(context_hdl)
272      CALL xios_dtreatment_end()
273   END SUBROUTINE dtreatment_end
274
275   SUBROUTINE write_data (fieldid, data1d_k4, data2d_k4, data3d_k4, data1d_k8, data2d_k8, data3d_k8)
276      CHARACTER(len = *), INTENT(IN)                     :: fieldid
277      REAL(kind = 8), DIMENSION(*), OPTIONAL, INTENT(IN) :: data1d_k8(:), data2d_k8(:,:), data3d_k8(:,:,:)
278      REAL(kind = 4), DIMENSION(*), OPTIONAL, INTENT(IN) :: data1d_k4(:), data2d_k4(:,:), data3d_k4(:,:,:)
279     
280      IF((.NOT. PRESENT(data1d_k8)) .AND. &
281         (.NOT. PRESENT(data2d_k8)) .AND. &
282         (.NOT. PRESENT(data3d_k8))) THEN
283         PRINT *, "(F2003 interface) Veuillez spécifier des données à écrire !"
284         STOP
285      END IF
286     
287      IF (PRESENT (data1d_k8)) THEN
288         CALL xios_write_data(fieldid, len(fieldid), data1d_k8, size(data1d_k8, 1), -1, -1)
289      ELSE IF (PRESENT (data2d_k8)) THEN
290         CALL xios_write_data(fieldid, len(fieldid), data2d_k8, size(data2d_k8, 1), size(data2d_k8, 2), -1)
291      ELSE IF (PRESENT (data3d_k8)) THEN
292         CALL xios_write_data(fieldid, len(fieldid), data3d_k8, size(data3d_k8, 1), size(data3d_k8, 2), size(data3d_k8, 3))
293      END IF
294     
295      IF (PRESENT (data1d_k4)) THEN
296         CALL xios_write_data_f(fieldid, len(fieldid), data1d_k4, size(data1d_k4, 1), -1, -1)
297      ELSE IF (PRESENT (data2d_k4)) THEN
298         CALL xios_write_data_f(fieldid, len(fieldid), data2d_k4, size(data2d_k4, 1), size(data2d_k4, 2), -1)
299      ELSE IF (PRESENT (data3d_k4)) THEN
300         CALL xios_write_data_f(fieldid, len(fieldid), data3d_k4, size(data3d_k4, 1), size(data3d_k4, 2), size(data3d_k4, 3))
301      END IF
302     
303     
304   END SUBROUTINE
305
306   SUBROUTINE  set_axis_attributes( axis_hdl, ftype &
307   #undef  DECLARE_ATTRIBUTE
308   #define DECLARE_ATTRIBUTE(type, name) arg_##type(name) &
309   #include "../config/axis_attribute.conf"
310   )
311
312      TYPE(XHandle) :: axis_hdl
313      INTEGER (kind = C_INT)      :: ftype
314      #undef  DECLARE_ATTRIBUTE
315      #define DECLARE_ATTRIBUTE(type, name) def_##type(name)
316      #include "../config/axis_attribute.conf"
317
318      #undef  DECLARE_ATTRIBUTE
319      #define DECLARE_ATTRIBUTE(type, name) ip_##type(axis, name)
320      #include "../config/axis_attribute.conf"
321
322   END SUBROUTINE set_axis_attributes
323
324   SUBROUTINE  set_field_attributes( field_hdl, ftype &
325   #undef  DECLARE_ATTRIBUTE
326   #define DECLARE_ATTRIBUTE(type, name) arg_##type(name) &
327   #include "../config/field_attribute.conf"
328   )
329
330      TYPE(XHandle) :: field_hdl
331      INTEGER (kind = C_INT)      :: ftype
332      #undef  DECLARE_ATTRIBUTE
333      #define DECLARE_ATTRIBUTE(type, name) def_##type(name)
334      #include "../config/field_attribute.conf"
335
336      #undef  DECLARE_ATTRIBUTE
337      #define DECLARE_ATTRIBUTE(type, name) ip_##type(field, name)
338      #include "../config/field_attribute.conf"
339
340   END SUBROUTINE set_field_attributes
341
342   SUBROUTINE  set_context_attributes( context_hdl, ftype &
343   #undef  DECLARE_ATTRIBUTE
344   #define DECLARE_ATTRIBUTE(type, name) arg_##type(name) &
345   #include "../config/context_attribute.conf"
346   )
347
348      TYPE(XHandle) :: context_hdl
349      INTEGER (kind = C_INT)      :: ftype
350      #undef  DECLARE_ATTRIBUTE
351      #define DECLARE_ATTRIBUTE(type, name) def_##type(name)
352      #include "../config/context_attribute.conf"
353
354      #undef  DECLARE_ATTRIBUTE
355      #define DECLARE_ATTRIBUTE(type, name) ip_##type(context, name)
356      #include "../config/context_attribute.conf"
357
358   END SUBROUTINE set_context_attributes
359
360   SUBROUTINE  set_domain_attributes( domain_hdl, ftype &
361   #undef  DECLARE_ATTRIBUTE
362   #define DECLARE_ATTRIBUTE(type, name) arg_##type(name) &
363   #include "../config/domain_attribute.conf"
364   )
365
366      TYPE(XHandle) :: domain_hdl
367      INTEGER (kind = C_INT)      :: ftype
368      #undef  DECLARE_ATTRIBUTE
369      #define DECLARE_ATTRIBUTE(type, name) def_##type(name)
370      #include "../config/domain_attribute.conf"
371
372      #undef  DECLARE_ATTRIBUTE
373      #define DECLARE_ATTRIBUTE(type, name) ip_##type(domain, name)
374      #include "../config/domain_attribute.conf"
375
376   END SUBROUTINE set_domain_attributes
377
378   SUBROUTINE  set_grid_attributes( grid_hdl, ftype &
379   #undef  DECLARE_ATTRIBUTE
380   #define DECLARE_ATTRIBUTE(type, name) arg_##type(name) &
381   #include "../config/grid_attribute.conf"
382   )
383
384      TYPE(XHandle) :: grid_hdl
385      INTEGER (kind = C_INT)      :: ftype
386      #undef  DECLARE_ATTRIBUTE
387      #define DECLARE_ATTRIBUTE(type, name) def_##type(name)
388      #include "../config/grid_attribute.conf"
389
390      #undef  DECLARE_ATTRIBUTE
391      #define DECLARE_ATTRIBUTE(type, name) ip_##type(grid, name)
392      #include "../config/grid_attribute.conf"
393
394   END SUBROUTINE set_grid_attributes
395
396   SUBROUTINE  set_file_attributes( file_hdl, ftype &
397   #undef  DECLARE_ATTRIBUTE
398   #define DECLARE_ATTRIBUTE(type, name) arg_##type(name) &
399   #include "../config/file_attribute.conf"
400   )
401
402      TYPE(XHandle) :: file_hdl
403      INTEGER (kind = C_INT)      :: ftype
404      #undef  DECLARE_ATTRIBUTE
405      #define DECLARE_ATTRIBUTE(type, name) def_##type(name)
406      #include "../config/file_attribute.conf"
407
408      #undef  DECLARE_ATTRIBUTE
409      #define DECLARE_ATTRIBUTE(type, name) ip_##type(file, name)
410      #include "../config/file_attribute.conf"
411
412   END SUBROUTINE set_file_attributes
413
414END MODULE XIOS
Note: See TracBrowser for help on using the repository browser.