! --------------------------------------------- ! ! IXMLIOSERVER ! ! GESTION DES ENTREES-SORTIES ! ! --------------------------------------------- ! #include "macro.inc" MODULE IXMLIOSERVER USE, INTRINSIC :: ISO_C_BINDING ! Ne jamais modifier les valeurs internes de ce type dans le code fortran. TYPE XHandle INTEGER(kind = C_INTPTR_T) :: daddr END TYPE XHandle ! enum XDType INTEGER(kind = C_INT), PARAMETER :: NOTYPE = 0 INTEGER(kind = C_INT), PARAMETER :: DTREATMENT = 1, DDATE = 2, CALENDAR = 3, ECONTEXT = 4 INTEGER(kind = C_INT), PARAMETER :: EAXIS = 5 , EDOMAIN = 6 , EFIELD = 7 , EFILE = 8 , EGRID = 9 INTEGER(kind = C_INT), PARAMETER :: GAXIS = 10, GDOMAIN = 11, GFIELD = 12, GFILE = 13, GGRID = 14 ! enum XCalendarType INTEGER(kind = C_INT), PARAMETER :: D360 = 0 , ALLLEAP = 1 , NOLEAP = 2 , JULIAN = 3 , GREGORIAN = 4 TYPE XDate INTEGER :: year, month, day, hour, minute, second END TYPE XDate TYPE XDuration REAL(kind = 8) :: year, month, day, hour, minute, second END TYPE XDuration ! Autres constantes TYPE(XHandle) , PARAMETER :: NULLHANDLE = XHandle(0) INTERFACE ! Ne pas appeler directement/Interface FORTRAN 2003 <-> C99 SUBROUTINE xios_handle_create(ret, dtype, idt, idt_size) BIND(C) import C_CHAR, C_INTPTR_T, C_INT INTEGER (kind = C_INTPTR_T) :: ret INTEGER (kind = C_INT), VALUE :: dtype CHARACTER(kind = C_CHAR), DIMENSION(*) :: idt INTEGER (kind = C_INT), VALUE :: idt_size END SUBROUTINE xios_handle_create SUBROUTINE xios_set_timestep(ts_year, ts_month, ts_day, & ts_hour, ts_minute, ts_second) BIND(C) import C_DOUBLE REAL (kind = C_DOUBLE), VALUE :: ts_year, ts_month, ts_day, & ts_hour, ts_minute, ts_second END SUBROUTINE xios_set_timestep SUBROUTINE xios_update_calendar(step) BIND(C) import C_INT INTEGER (kind = C_INT), VALUE :: step END SUBROUTINE xios_update_calendar SUBROUTINE xios_xml_tree_add(parent_, parent_type, child_, child_type, child_id, child_id_size) BIND(C) import C_CHAR, C_INT, C_INTPTR_T INTEGER (kind = C_INTPTR_T), VALUE :: parent_ INTEGER (kind = C_INT), VALUE :: parent_type INTEGER (kind = C_INTPTR_T) :: child_ INTEGER (kind = C_INT), VALUE :: child_type CHARACTER(kind = C_CHAR), DIMENSION(*) :: child_id INTEGER (kind = C_INT), VALUE :: child_id_size END SUBROUTINE xios_xml_tree_add SUBROUTINE xios_xml_tree_show(filename, filename_size) BIND(C) import C_CHAR, C_INT CHARACTER(kind = C_CHAR), DIMENSION(*) :: filename INTEGER (kind = C_INT), VALUE :: filename_size END SUBROUTINE xios_xml_tree_show SUBROUTINE xios_xml_parse_file(filename, filename_size) BIND(C) import C_CHAR, C_INT CHARACTER(kind = C_CHAR), DIMENSION(*) :: filename INTEGER (kind = C_INT), VALUE :: filename_size END SUBROUTINE xios_xml_Parse_File SUBROUTINE xios_xml_parse_string(xmlcontent, xmlcontent_size) BIND(C) import C_CHAR, C_INT CHARACTER(kind = C_CHAR), DIMENSION(*) :: xmlcontent INTEGER (kind = C_INT), VALUE :: xmlcontent_size END SUBROUTINE xios_xml_Parse_String SUBROUTINE xios_context_set_current(context, withswap) BIND(C) import C_BOOL, C_INT, C_INTPTR_T INTEGER (kind = C_INTPTR_T), VALUE :: context LOGICAL (kind = C_BOOL), VALUE :: withswap END SUBROUTINE xios_context_set_current SUBROUTINE xios_context_create(context, context_id, context_id_size, calendar_type, & year, month, day, hour, minute, second) BIND(C) import C_CHAR, C_INT, C_INTPTR_T INTEGER (kind = C_INTPTR_T) :: context CHARACTER(kind = C_CHAR), DIMENSION(*) :: context_id INTEGER (kind = C_INT), VALUE :: context_id_size INTEGER (kind = C_INT), VALUE :: calendar_type, year, month, day, hour, minute, second END SUBROUTINE xios_context_create SUBROUTINE xios_dtreatment_start(context_hdl, filetype, comm_client_server) BIND(C) import C_INTPTR_T, C_INT INTEGER (kind = C_INTPTR_T), VALUE :: context_hdl INTEGER (kind = C_INT), VALUE :: filetype, comm_client_server END SUBROUTINE xios_dtreatment_start SUBROUTINE xios_dtreatment_end() BIND(C) ! Sans argument END SUBROUTINE xios_dtreatment_end SUBROUTINE xios_write_data(fieldid, fieldid_size, data_k8, data_Xsize, data_Ysize, data_Zsize) BIND(C) import C_INT, C_CHAR, C_PTR, C_FLOAT, C_DOUBLE, C_BOOL CHARACTER(kind = C_CHAR), DIMENSION(*) :: fieldid INTEGER (kind = C_INT), VALUE :: fieldid_size REAL(kind = C_DOUBLE), DIMENSION(*) :: data_k8 INTEGER (kind = C_INT), VALUE :: data_Xsize, data_Ysize, data_Zsize END SUBROUTINE xios_write_data #define DECLARE_ATTRIBUTE(type, name) \ DECLARE_INTERFACE(axis, type, name) #include "../config/axis_attribute.conf" #undef DECLARE_ATTRIBUTE #define DECLARE_ATTRIBUTE(type, name) \ DECLARE_INTERFACE(field, type, name) #include "../config/field_attribute.conf" #undef DECLARE_ATTRIBUTE #define DECLARE_ATTRIBUTE(type, name) \ DECLARE_INTERFACE(context, type, name) #include "../config/context_attribute.conf" #undef DECLARE_ATTRIBUTE #define DECLARE_ATTRIBUTE(type, name) \ DECLARE_INTERFACE(domain, type, name) #include "../config/domain_attribute.conf" #undef DECLARE_ATTRIBUTE #define DECLARE_ATTRIBUTE(type, name) \ DECLARE_INTERFACE(file, type, name) #include "../config/file_attribute.conf" #undef DECLARE_ATTRIBUTE #define DECLARE_ATTRIBUTE(type, name) \ DECLARE_INTERFACE(grid, type, name) #include "../config/grid_attribute.conf" END INTERFACE CONTAINS ! Fonctions disponibles pour les utilisateurs. SUBROUTINE handle_create(ret, dtype, idt) TYPE(XHandle), INTENT(OUT) :: ret INTEGER, INTENT(IN) :: dtype CHARACTER(len = *), INTENT(IN) :: idt CALL xios_handle_create(ret%daddr, dtype, idt, len(idt)) END SUBROUTINE handle_create SUBROUTINE set_timestep(timestep) TYPE(XDuration), INTENT(IN):: timestep CALL xios_set_timestep(timestep%year, timestep%month , timestep%day, & timestep%hour, timestep%minute, timestep%second) END SUBROUTINE set_timestep SUBROUTINE update_calendar(step) INTEGER, INTENT(IN):: step IF (step < 1) THEN PRINT *, "L'argument 'step' ne peut être négatif ou nul" STOP END IF CALL xios_update_calendar(step) END SUBROUTINE update_calendar SUBROUTINE xml_tree_add(parent_hdl, parent_type, child_hdl, child_type, child_id) TYPE(XHandle), INTENT(IN) :: parent_hdl TYPE(XHandle), INTENT(OUT) :: child_hdl INTEGER, INTENT(IN) :: child_type, parent_type CHARACTER(len = *), OPTIONAL, INTENT(IN) :: child_id child_hdl = NULLHANDLE IF (PRESENT(child_id)) THEN CALL xios_xml_tree_add(parent_hdl%daddr, parent_type, child_hdl%daddr, child_type, child_id, len(child_id)) ELSE CALL xios_xml_tree_add(parent_hdl%daddr, parent_type, child_hdl%daddr, child_type, "NONE", -1) END IF END SUBROUTINE xml_tree_add SUBROUTINE xml_tree_show(filename) CHARACTER(len = *), OPTIONAL, INTENT(IN) :: filename IF (PRESENT(filename)) THEN CALL xios_xml_tree_show(filename, len(filename)) ELSE CALL xios_xml_tree_show("NONE", -1) END IF END SUBROUTINE xml_tree_show SUBROUTINE xml_parse_file(filename) CHARACTER(len = *), INTENT(IN) :: filename CALL xios_xml_Parse_File(filename, len(filename)) END SUBROUTINE xml_Parse_File SUBROUTINE xml_parse_string(xmlcontent) CHARACTER(len = *), INTENT(IN) :: xmlcontent CALL xios_xml_Parse_String(xmlcontent, len(xmlcontent)) END SUBROUTINE xml_Parse_String SUBROUTINE context_set_current(context, withswap) TYPE(XHandle), INTENT(IN) :: context LOGICAL (kind = 1), OPTIONAL, INTENT(IN) :: withswap LOGICAL (kind = 1) :: wswap IF (PRESENT(withswap)) THEN wswap = withswap ELSE wswap = .FALSE. END IF CALL xios_context_set_current(context%daddr, wswap) END SUBROUTINE context_set_current SUBROUTINE context_create(context_hdl, context_id, calendar_type, init_date) TYPE(XHandle), INTENT(OUT) :: context_hdl CHARACTER(len = *), INTENT(IN) :: context_id INTEGER, INTENT(IN) :: calendar_type TYPE(XDate), INTENT(IN), OPTIONAL :: init_date IF (PRESENT(init_date)) THEN CALL xios_context_create(context_hdl%daddr, context_id, len(context_id), calendar_type, & init_date%year, init_date%month, init_date%day, & init_date%hour, init_date%minute, init_date%second) ELSE CALL xios_context_create(context_hdl%daddr, context_id, len(context_id), calendar_type, & 0, 1, 1, 0, 0, 0) END IF END SUBROUTINE context_create SUBROUTINE dtreatment_start(context_hdl, filetype, comm_client_server) TYPE(XHandle), INTENT(IN), VALUE :: context_hdl INTEGER, INTENT(IN), OPTIONAL :: filetype, comm_client_server INTEGER :: filetype_, comm_client_server_ IF (PRESENT(filetype)) THEN filetype_ = filetype ELSE filetype_ = NETCDF4 END IF IF (PRESENT(comm_client_server)) THEN comm_client_server_ = comm_client_server ELSE comm_client_server_ = -1 END IF CALL context_set_current(context_hdl) CALL xios_dtreatment_start(context_hdl%daddr, filetype_, comm_client_server_) END SUBROUTINE dtreatment_start SUBROUTINE dtreatment_end(context_hdl) TYPE(XHandle), INTENT(IN), VALUE :: context_hdl CALL context_set_current(context_hdl) CALL xios_dtreatment_end() END SUBROUTINE dtreatment_end SUBROUTINE write_data (fieldid, & data1d_k8, data2d_k8, data3d_k8) CHARACTER(len = *), INTENT(IN) :: fieldid REAL(kind = 8), DIMENSION(*), OPTIONAL, INTENT(IN) :: data1d_k8(:), data2d_k8(:,:), data3d_k8(:,:,:) IF((.NOT. PRESENT(data1d_k8)) .AND. & (.NOT. PRESENT(data2d_k8)) .AND. & (.NOT. PRESENT(data3d_k8))) THEN PRINT *, "(F2003 interface) Veuillez spécifier des données à écrire !" STOP END IF IF (PRESENT (data1d_k8)) THEN CALL xios_write_data(fieldid, len(fieldid), data1d_k8, & size(data1d_k8, 1), -1, -1) ELSE IF (PRESENT (data2d_k8)) THEN CALL xios_write_data(fieldid, len(fieldid), data2d_k8, & size(data2d_k8, 1), size(data2d_k8, 2), -1) ELSE IF (PRESENT (data3d_k8)) THEN CALL xios_write_data(fieldid, len(fieldid), data3d_k8, & size(data3d_k8, 1), size(data3d_k8, 2), size(data3d_k8, 3)) END IF END SUBROUTINE SUBROUTINE set_axis_attributes( axis_hdl, ftype & #undef DECLARE_ATTRIBUTE #define DECLARE_ATTRIBUTE(type, name) arg_##type(name) & #include "../config/axis_attribute.conf" ) TYPE(XHandle) :: axis_hdl INTEGER (kind = C_INT) :: ftype #undef DECLARE_ATTRIBUTE #define DECLARE_ATTRIBUTE(type, name) def_##type(name) #include "../config/axis_attribute.conf" #undef DECLARE_ATTRIBUTE #define DECLARE_ATTRIBUTE(type, name) ip_##type(axis, name) #include "../config/axis_attribute.conf" END SUBROUTINE set_axis_attributes SUBROUTINE set_field_attributes( field_hdl, ftype & #undef DECLARE_ATTRIBUTE #define DECLARE_ATTRIBUTE(type, name) arg_##type(name) & #include "../config/field_attribute.conf" ) TYPE(XHandle) :: field_hdl INTEGER (kind = C_INT) :: ftype #undef DECLARE_ATTRIBUTE #define DECLARE_ATTRIBUTE(type, name) def_##type(name) #include "../config/field_attribute.conf" #undef DECLARE_ATTRIBUTE #define DECLARE_ATTRIBUTE(type, name) ip_##type(field, name) #include "../config/field_attribute.conf" END SUBROUTINE set_field_attributes SUBROUTINE set_context_attributes( context_hdl, ftype & #undef DECLARE_ATTRIBUTE #define DECLARE_ATTRIBUTE(type, name) arg_##type(name) & #include "../config/context_attribute.conf" ) TYPE(XHandle) :: context_hdl INTEGER (kind = C_INT) :: ftype #undef DECLARE_ATTRIBUTE #define DECLARE_ATTRIBUTE(type, name) def_##type(name) #include "../config/context_attribute.conf" #undef DECLARE_ATTRIBUTE #define DECLARE_ATTRIBUTE(type, name) ip_##type(context, name) #include "../config/context_attribute.conf" END SUBROUTINE set_context_attributes SUBROUTINE set_domain_attributes( domain_hdl, ftype & #undef DECLARE_ATTRIBUTE #define DECLARE_ATTRIBUTE(type, name) arg_##type(name) & #include "../config/domain_attribute.conf" ) TYPE(XHandle) :: domain_hdl INTEGER (kind = C_INT) :: ftype #undef DECLARE_ATTRIBUTE #define DECLARE_ATTRIBUTE(type, name) def_##type(name) #include "../config/domain_attribute.conf" #undef DECLARE_ATTRIBUTE #define DECLARE_ATTRIBUTE(type, name) ip_##type(domain, name) #include "../config/domain_attribute.conf" END SUBROUTINE set_domain_attributes SUBROUTINE set_grid_attributes( grid_hdl, ftype & #undef DECLARE_ATTRIBUTE #define DECLARE_ATTRIBUTE(type, name) arg_##type(name) & #include "../config/grid_attribute.conf" ) TYPE(XHandle) :: grid_hdl INTEGER (kind = C_INT) :: ftype #undef DECLARE_ATTRIBUTE #define DECLARE_ATTRIBUTE(type, name) def_##type(name) #include "../config/grid_attribute.conf" #undef DECLARE_ATTRIBUTE #define DECLARE_ATTRIBUTE(type, name) ip_##type(grid, name) #include "../config/grid_attribute.conf" END SUBROUTINE set_grid_attributes SUBROUTINE set_file_attributes( file_hdl, ftype & #undef DECLARE_ATTRIBUTE #define DECLARE_ATTRIBUTE(type, name) arg_##type(name) & #include "../config/file_attribute.conf" ) TYPE(XHandle) :: file_hdl INTEGER (kind = C_INT) :: ftype #undef DECLARE_ATTRIBUTE #define DECLARE_ATTRIBUTE(type, name) def_##type(name) #include "../config/file_attribute.conf" #undef DECLARE_ATTRIBUTE #define DECLARE_ATTRIBUTE(type, name) ip_##type(file, name) #include "../config/file_attribute.conf" END SUBROUTINE set_file_attributes END MODULE IXMLIOSERVER